0000: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
0010: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0020: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0030: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0040: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 43 6f 70 79 ========.;; Copy
0050: 72 69 67 68 74 20 32 30 30 36 2d 32 30 31 33 2c right 2006-2013,
0060: 20 4d 61 74 74 68 65 77 20 57 65 6c 6c 61 6e 64 Matthew Welland
0070: 2e 0a 3b 3b 20 0a 3b 3b 20 54 68 69 73 20 66 69 ..;; .;; This fi
0080: 6c 65 20 69 73 20 70 61 72 74 20 6f 66 20 4d 65 le is part of Me
0090: 67 61 74 65 73 74 2e 0a 3b 3b 20 0a 3b 3b 20 20 gatest..;; .;;
00a0: 20 20 20 4d 65 67 61 74 65 73 74 20 69 73 20 66 Megatest is f
00b0: 72 65 65 20 73 6f 66 74 77 61 72 65 3a 20 79 6f ree software: yo
00c0: 75 20 63 61 6e 20 72 65 64 69 73 74 72 69 62 75 u can redistribu
00d0: 74 65 20 69 74 20 61 6e 64 2f 6f 72 20 6d 6f 64 te it and/or mod
00e0: 69 66 79 0a 3b 3b 20 20 20 20 20 69 74 20 75 6e ify.;; it un
00f0: 64 65 72 20 74 68 65 20 74 65 72 6d 73 20 6f 66 der the terms of
0100: 20 74 68 65 20 47 4e 55 20 47 65 6e 65 72 61 6c the GNU General
0110: 20 50 75 62 6c 69 63 20 4c 69 63 65 6e 73 65 20 Public License
0120: 61 73 20 70 75 62 6c 69 73 68 65 64 20 62 79 0a as published by.
0130: 3b 3b 20 20 20 20 20 74 68 65 20 46 72 65 65 20 ;; the Free
0140: 53 6f 66 74 77 61 72 65 20 46 6f 75 6e 64 61 74 Software Foundat
0150: 69 6f 6e 2c 20 65 69 74 68 65 72 20 76 65 72 73 ion, either vers
0160: 69 6f 6e 20 33 20 6f 66 20 74 68 65 20 4c 69 63 ion 3 of the Lic
0170: 65 6e 73 65 2c 20 6f 72 0a 3b 3b 20 20 20 20 20 ense, or.;;
0180: 28 61 74 20 79 6f 75 72 20 6f 70 74 69 6f 6e 29 (at your option)
0190: 20 61 6e 79 20 6c 61 74 65 72 20 76 65 72 73 69 any later versi
01a0: 6f 6e 2e 0a 3b 3b 20 0a 3b 3b 20 20 20 20 20 4d on..;; .;; M
01b0: 65 67 61 74 65 73 74 20 69 73 20 64 69 73 74 72 egatest is distr
01c0: 69 62 75 74 65 64 20 69 6e 20 74 68 65 20 68 6f ibuted in the ho
01d0: 70 65 20 74 68 61 74 20 69 74 20 77 69 6c 6c 20 pe that it will
01e0: 62 65 20 75 73 65 66 75 6c 2c 0a 3b 3b 20 20 20 be useful,.;;
01f0: 20 20 62 75 74 20 57 49 54 48 4f 55 54 20 41 4e but WITHOUT AN
0200: 59 20 57 41 52 52 41 4e 54 59 3b 20 77 69 74 68 Y WARRANTY; with
0210: 6f 75 74 20 65 76 65 6e 20 74 68 65 20 69 6d 70 out even the imp
0220: 6c 69 65 64 20 77 61 72 72 61 6e 74 79 20 6f 66 lied warranty of
0230: 0a 3b 3b 20 20 20 20 20 4d 45 52 43 48 41 4e 54 .;; MERCHANT
0240: 41 42 49 4c 49 54 59 20 6f 72 20 46 49 54 4e 45 ABILITY or FITNE
0250: 53 53 20 46 4f 52 20 41 20 50 41 52 54 49 43 55 SS FOR A PARTICU
0260: 4c 41 52 20 50 55 52 50 4f 53 45 2e 20 20 53 65 LAR PURPOSE. Se
0270: 65 20 74 68 65 0a 3b 3b 20 20 20 20 20 47 4e 55 e the.;; GNU
0280: 20 47 65 6e 65 72 61 6c 20 50 75 62 6c 69 63 20 General Public
0290: 4c 69 63 65 6e 73 65 20 66 6f 72 20 6d 6f 72 65 License for more
02a0: 20 64 65 74 61 69 6c 73 2e 0a 3b 3b 20 0a 3b 3b details..;; .;;
02b0: 20 20 20 20 20 59 6f 75 20 73 68 6f 75 6c 64 20 You should
02c0: 68 61 76 65 20 72 65 63 65 69 76 65 64 20 61 20 have received a
02d0: 63 6f 70 79 20 6f 66 20 74 68 65 20 47 4e 55 20 copy of the GNU
02e0: 47 65 6e 65 72 61 6c 20 50 75 62 6c 69 63 20 4c General Public L
02f0: 69 63 65 6e 73 65 0a 3b 3b 20 20 20 20 20 61 6c icense.;; al
0300: 6f 6e 67 20 77 69 74 68 20 4d 65 67 61 74 65 73 ong with Megates
0310: 74 2e 20 20 49 66 20 6e 6f 74 2c 20 73 65 65 20 t. If not, see
0320: 3c 68 74 74 70 3a 2f 2f 77 77 77 2e 67 6e 75 2e <http://www.gnu.
0330: 6f 72 67 2f 6c 69 63 65 6e 73 65 73 2f 3e 2e 0a org/licenses/>..
0340: 3b 3b 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;.;;===========
0350: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0360: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0370: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0380: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 3d ===========..;;=
0390: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
03a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
03b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
03c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
03d0: 3d 3d 3d 3d 3d 0a 3b 3b 20 54 65 73 74 73 0a 3b =====.;; Tests.;
03e0: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
03f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0400: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0410: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0420: 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 63 6c 61 72 =======..(declar
0430: 65 20 28 75 6e 69 74 20 74 65 73 74 73 29 29 0a e (unit tests)).
0440: 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 6c (declare (uses l
0450: 6f 63 6b 2d 71 75 65 75 65 29 29 0a 28 64 65 63 ock-queue)).(dec
0460: 6c 61 72 65 20 28 75 73 65 73 20 64 62 29 29 0a lare (uses db)).
0470: 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 74 (declare (uses t
0480: 64 62 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 db)).(declare (u
0490: 73 65 73 20 63 6f 6d 6d 6f 6e 29 29 0a 3b 3b 20 ses common)).;;
04a0: 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 64 (declare (uses d
04b0: 63 6f 6d 6d 6f 6e 29 29 20 3b 3b 20 6e 65 65 64 common)) ;; need
04c0: 65 64 20 66 6f 72 20 74 68 65 20 73 74 65 70 73 ed for the steps
04d0: 20 70 72 6f 63 65 73 73 69 6e 67 0a 28 64 65 63 processing.(dec
04e0: 6c 61 72 65 20 28 75 73 65 73 20 69 74 65 6d 73 lare (uses items
04f0: 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 )).(declare (use
0500: 73 20 72 75 6e 63 6f 6e 66 69 67 29 29 0a 3b 3b s runconfig)).;;
0510: 20 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 (declare (uses
0520: 73 64 62 29 29 0a 28 64 65 63 6c 61 72 65 20 28 sdb)).(declare (
0530: 75 73 65 73 20 73 65 72 76 65 72 29 29 0a 3b 3b uses server)).;;
0540: 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 73 (declare (uses s
0550: 74 6d 6c 32 29 29 0a 0a 28 75 73 65 20 73 71 6c tml2))..(use sql
0560: 69 74 65 33 20 73 72 66 69 2d 31 20 70 6f 73 69 ite3 srfi-1 posi
0570: 78 20 72 65 67 65 78 20 72 65 67 65 78 2d 63 61 x regex regex-ca
0580: 73 65 20 73 72 66 69 2d 36 39 20 64 6f 74 2d 6c se srfi-69 dot-l
0590: 6f 63 6b 69 6e 67 20 74 63 70 20 64 69 72 65 63 ocking tcp direc
05a0: 74 6f 72 79 2d 75 74 69 6c 73 29 0a 28 69 6d 70 tory-utils).(imp
05b0: 6f 72 74 20 28 70 72 65 66 69 78 20 73 71 6c 69 ort (prefix sqli
05c0: 74 65 33 20 73 71 6c 69 74 65 33 3a 29 29 0a 28 te3 sqlite3:)).(
05d0: 75 73 65 20 73 74 6d 6c 32 29 0a 0a 28 69 6e 63 use stml2)..(inc
05e0: 6c 75 64 65 20 22 63 6f 6d 6d 6f 6e 5f 72 65 63 lude "common_rec
05f0: 6f 72 64 73 2e 73 63 6d 22 29 0a 28 69 6e 63 6c ords.scm").(incl
0600: 75 64 65 20 22 6b 65 79 5f 72 65 63 6f 72 64 73 ude "key_records
0610: 2e 73 63 6d 22 29 0a 28 69 6e 63 6c 75 64 65 20 .scm").(include
0620: 22 64 62 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 "db_records.scm"
0630: 29 0a 28 69 6e 63 6c 75 64 65 20 22 72 75 6e 5f ).(include "run_
0640: 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a 28 69 records.scm").(i
0650: 6e 63 6c 75 64 65 20 22 74 65 73 74 5f 72 65 63 nclude "test_rec
0660: 6f 72 64 73 2e 73 63 6d 22 29 0a 28 69 6e 63 6c ords.scm").(incl
0670: 75 64 65 20 22 6a 73 2d 70 61 74 68 2e 73 63 6d ude "js-path.scm
0680: 22 29 0a 0a 28 64 65 66 69 6e 65 20 28 69 6e 69 ")..(define (ini
0690: 74 2d 6a 61 76 61 2d 73 63 72 69 70 74 2d 6c 69 t-java-script-li
06a0: 62 29 0a 20 20 28 73 65 74 21 20 2a 6a 61 76 61 b). (set! *java
06b0: 2d 73 63 72 69 70 74 2d 6c 69 62 2a 20 28 63 6f -script-lib* (co
06c0: 6e 63 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d nc (common:get-
06d0: 69 6e 73 74 61 6c 6c 2d 61 72 65 61 29 20 22 2f install-area) "/
06e0: 73 68 61 72 65 2f 6a 73 2f 6a 71 75 65 72 79 2d share/js/jquery-
06f0: 33 2e 31 2e 30 2e 73 6c 69 6d 2e 6d 69 6e 2e 6a 3.1.0.slim.min.j
0700: 73 22 29 29 0a 20 20 29 0a 0a 3b 3b 20 43 61 6c s")). )..;; Cal
0710: 6c 20 74 68 69 73 20 6f 6e 65 20 74 6f 20 64 6f l this one to do
0720: 20 61 6c 6c 20 74 68 65 20 77 6f 72 6b 20 61 6e all the work an
0730: 64 20 67 65 74 20 61 20 73 74 61 6e 64 61 72 64 d get a standard
0740: 69 7a 65 64 20 6c 69 73 74 20 6f 66 20 74 65 73 ized list of tes
0750: 74 73 0a 3b 3b 20 20 20 67 65 74 73 20 70 61 74 ts.;; gets pat
0760: 68 73 20 66 72 6f 6d 20 63 6f 6e 66 69 67 73 20 hs from configs
0770: 61 6e 64 20 66 69 6e 64 73 20 76 61 6c 69 64 20 and finds valid
0780: 74 65 73 74 73 20 0a 3b 3b 20 20 20 72 65 74 75 tests .;; retu
0790: 72 6e 73 20 68 61 73 68 20 6f 66 20 74 65 73 74 rns hash of test
07a0: 6e 61 6d 65 20 2d 2d 3e 20 66 75 6c 6c 70 61 74 name --> fullpat
07b0: 68 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 65 h.;;.(define (te
07c0: 73 74 73 3a 67 65 74 2d 61 6c 6c 29 0a 20 20 28 sts:get-all). (
07d0: 6c 65 74 2a 20 28 28 74 65 73 74 2d 73 65 61 72 let* ((test-sear
07e0: 63 68 2d 70 61 74 68 20 20 20 28 74 65 73 74 73 ch-path (tests
07f0: 3a 67 65 74 2d 74 65 73 74 73 2d 73 65 61 72 63 :get-tests-searc
0800: 68 2d 70 61 74 68 20 2a 63 6f 6e 66 69 67 64 61 h-path *configda
0810: 74 2a 29 29 29 0a 20 20 20 20 28 74 65 73 74 73 t*))). (tests
0820: 3a 67 65 74 2d 76 61 6c 69 64 2d 74 65 73 74 73 :get-valid-tests
0830: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
0840: 65 29 20 74 65 73 74 2d 73 65 61 72 63 68 2d 70 e) test-search-p
0850: 61 74 68 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ath)))..(define
0860: 28 74 65 73 74 73 3a 67 65 74 2d 74 65 73 74 73 (tests:get-tests
0870: 2d 73 65 61 72 63 68 2d 70 61 74 68 20 63 66 67 -search-path cfg
0880: 64 61 74 29 0a 20 20 28 6c 65 74 20 28 28 70 61 dat). (let ((pa
0890: 74 68 73 20 28 6c 65 74 20 28 28 73 65 63 74 69 ths (let ((secti
08a0: 6f 6e 20 28 69 66 20 63 66 67 64 61 74 0a 09 09 on (if cfgdat...
08b0: 09 09 20 20 28 63 6f 6e 66 69 67 66 3a 67 65 74 .. (configf:get
08c0: 2d 73 65 63 74 69 6f 6e 20 63 66 67 64 61 74 20 -section cfgdat
08d0: 22 74 65 73 74 73 2d 70 61 74 68 73 22 29 0a 09 "tests-paths")..
08e0: 09 09 09 20 20 23 66 29 29 29 0a 09 09 20 28 69 ... #f)))... (i
08f0: 66 20 73 65 63 74 69 6f 6e 0a 09 09 20 20 20 20 f section...
0900: 20 28 6d 61 70 20 63 61 64 72 20 73 65 63 74 69 (map cadr secti
0910: 6f 6e 29 0a 09 09 20 20 20 20 20 27 28 29 29 29 on)... '()))
0920: 29 29 0a 20 20 20 20 28 66 69 6c 74 65 72 20 28 )). (filter (
0930: 6c 61 6d 62 64 61 20 28 64 29 0a 09 20 20 20 20 lambda (d)..
0940: 20 20 28 69 66 20 28 64 69 72 65 63 74 6f 72 79 (if (directory
0950: 2d 65 78 69 73 74 73 3f 20 64 29 0a 09 09 20 20 -exists? d)...
0960: 64 0a 09 09 20 20 28 62 65 67 69 6e 0a 09 09 20 d... (begin...
0970: 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 6c (if (common:l
0980: 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 20 36 ow-noise-print 6
0990: 30 20 22 74 65 73 74 73 3a 67 65 74 2d 74 65 73 0 "tests:get-tes
09a0: 74 73 2d 73 65 61 72 63 68 2d 70 61 74 68 22 20 ts-search-path"
09b0: 64 29 0a 09 09 09 28 64 65 62 75 67 3a 70 72 69 d)....(debug:pri
09c0: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
09d0: 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 g-port* "WARNING
09e0: 3a 20 70 72 6f 62 6c 65 6d 20 77 69 74 68 20 64 : problem with d
09f0: 69 72 65 63 74 6f 72 79 20 22 20 64 20 22 2c 20 irectory " d ",
0a00: 64 72 6f 70 70 69 6e 67 20 69 74 20 66 72 6f 6d dropping it from
0a10: 20 74 65 73 74 73 20 70 61 74 68 22 29 29 0a 09 tests path"))..
0a20: 09 20 20 20 20 23 66 29 29 29 0a 09 20 20 20 20 . #f)))..
0a30: 28 61 70 70 65 6e 64 20 70 61 74 68 73 20 28 6c (append paths (l
0a40: 69 73 74 20 28 63 6f 6e 63 20 2a 74 6f 70 70 61 ist (conc *toppa
0a50: 74 68 2a 20 22 2f 74 65 73 74 73 22 29 29 29 29 th* "/tests"))))
0a60: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 ))..(define (tes
0a70: 74 73 3a 67 65 74 2d 76 61 6c 69 64 2d 74 65 73 ts:get-valid-tes
0a80: 74 73 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 ts test-registry
0a90: 20 74 65 73 74 73 2d 70 61 74 68 73 29 0a 20 20 tests-paths).
0aa0: 28 69 66 20 28 6e 75 6c 6c 3f 20 74 65 73 74 73 (if (null? tests
0ab0: 2d 70 61 74 68 73 29 20 0a 20 20 20 20 20 20 74 -paths) . t
0ac0: 65 73 74 2d 72 65 67 69 73 74 72 79 0a 20 20 20 est-registry.
0ad0: 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 (let loop ((h
0ae0: 65 64 20 28 63 61 72 20 74 65 73 74 73 2d 70 61 ed (car tests-pa
0af0: 74 68 73 29 29 0a 09 09 20 28 74 61 6c 20 28 63 ths))... (tal (c
0b00: 64 72 20 74 65 73 74 73 2d 70 61 74 68 73 29 29 dr tests-paths))
0b10: 29 0a 09 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 66 )..(if (common:f
0b20: 69 6c 65 2d 65 78 69 73 74 73 3f 20 68 65 64 29 ile-exists? hed)
0b30: 0a 09 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 .. (for-each
0b40: 28 6c 61 6d 62 64 61 20 28 74 65 73 74 2d 70 61 (lambda (test-pa
0b50: 74 68 29 0a 09 09 09 28 6c 65 74 2a 20 28 28 74 th)....(let* ((t
0b60: 6e 61 6d 65 20 20 20 28 6c 61 73 74 20 28 73 74 name (last (st
0b70: 72 69 6e 67 2d 73 70 6c 69 74 20 74 65 73 74 2d ring-split test-
0b80: 70 61 74 68 20 22 2f 22 29 29 29 0a 09 09 09 20 path "/")))....
0b90: 20 20 20 20 20 20 28 74 63 6f 6e 66 69 67 20 28 (tconfig (
0ba0: 63 6f 6e 63 20 74 65 73 74 2d 70 61 74 68 20 22 conc test-path "
0bb0: 2f 74 65 73 74 63 6f 6e 66 69 67 22 29 29 29 0a /testconfig"))).
0bc0: 09 09 09 20 20 28 69 66 20 28 61 6e 64 20 28 6e ... (if (and (n
0bd0: 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 ot (hash-table-r
0be0: 65 66 2f 64 65 66 61 75 6c 74 20 74 65 73 74 2d ef/default test-
0bf0: 72 65 67 69 73 74 72 79 20 74 6e 61 6d 65 20 23 registry tname #
0c00: 66 29 29 0a 09 09 09 09 20 20 20 28 63 6f 6d 6d f))..... (comm
0c10: 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 on:file-exists?
0c20: 74 63 6f 6e 66 69 67 29 29 0a 09 09 09 20 20 20 tconfig))....
0c30: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 (hash-table-s
0c40: 65 74 21 20 74 65 73 74 2d 72 65 67 69 73 74 72 et! test-registr
0c50: 79 20 74 6e 61 6d 65 20 74 65 73 74 2d 70 61 74 y tname test-pat
0c60: 68 29 29 29 29 0a 09 09 20 20 20 20 20 20 28 67 h))))... (g
0c70: 6c 6f 62 20 28 63 6f 6e 63 20 68 65 64 20 22 2f lob (conc hed "/
0c80: 2a 22 29 29 29 29 0a 09 28 69 66 20 28 6e 75 6c *"))))..(if (nul
0c90: 6c 3f 20 74 61 6c 29 0a 09 20 20 20 20 74 65 73 l? tal).. tes
0ca0: 74 2d 72 65 67 69 73 74 72 79 0a 09 20 20 20 20 t-registry..
0cb0: 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 (loop (car tal)(
0cc0: 63 64 72 20 74 61 6c 29 29 29 29 29 29 0a 0a 28 cdr tal))))))..(
0cd0: 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 66 69 define (tests:fi
0ce0: 6c 74 65 72 2d 74 65 73 74 2d 6e 61 6d 65 73 2d lter-test-names-
0cf0: 6e 6f 74 2d 6d 61 74 63 68 65 64 20 74 65 73 74 not-matched test
0d00: 2d 6e 61 6d 65 73 20 74 65 73 74 2d 70 61 74 74 -names test-patt
0d10: 73 29 0a 20 20 28 64 65 6c 65 74 65 2d 64 75 70 s). (delete-dup
0d20: 6c 69 63 61 74 65 73 0a 20 20 20 28 66 69 6c 74 licates. (filt
0d30: 65 72 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 er (lambda (test
0d40: 6e 61 6d 65 29 0a 09 20 20 20 20 20 28 6e 6f 74 name).. (not
0d50: 20 28 74 65 73 74 73 3a 6d 61 74 63 68 20 74 65 (tests:match te
0d60: 73 74 2d 70 61 74 74 73 20 74 65 73 74 6e 61 6d st-patts testnam
0d70: 65 20 23 66 29 29 29 0a 09 20 20 20 74 65 73 74 e #f))).. test
0d80: 2d 6e 61 6d 65 73 29 29 29 0a 0a 0a 28 64 65 66 -names)))...(def
0d90: 69 6e 65 20 28 74 65 73 74 73 3a 66 69 6c 74 65 ine (tests:filte
0da0: 72 2d 74 65 73 74 2d 6e 61 6d 65 73 20 74 65 73 r-test-names tes
0db0: 74 2d 6e 61 6d 65 73 20 74 65 73 74 2d 70 61 74 t-names test-pat
0dc0: 74 73 29 0a 20 20 28 64 65 6c 65 74 65 2d 64 75 ts). (delete-du
0dd0: 70 6c 69 63 61 74 65 73 0a 20 20 20 28 66 69 6c plicates. (fil
0de0: 74 65 72 20 28 6c 61 6d 62 64 61 20 28 74 65 73 ter (lambda (tes
0df0: 74 6e 61 6d 65 29 0a 09 20 20 20 20 20 28 74 65 tname).. (te
0e00: 73 74 73 3a 6d 61 74 63 68 20 74 65 73 74 2d 70 sts:match test-p
0e10: 61 74 74 73 20 74 65 73 74 6e 61 6d 65 20 23 66 atts testname #f
0e20: 29 29 0a 09 20 20 20 74 65 73 74 2d 6e 61 6d 65 )).. test-name
0e30: 73 29 29 29 0a 0a 3b 3b 20 69 74 65 6d 6d 61 70 s)))..;; itemmap
0e40: 20 69 73 20 61 20 6c 69 73 74 20 6f 66 20 74 65 is a list of te
0e50: 73 74 6e 61 6d 65 20 70 61 74 74 65 72 6e 73 20 stname patterns
0e60: 74 6f 20 6d 61 70 73 0a 3b 3b 20 20 20 20 20 74 to maps.;; t
0e70: 65 73 74 31 20 2e 2a 2f 62 61 72 2f 28 5c 64 2b est1 .*/bar/(\d+
0e80: 29 20 66 6f 6f 2f 5c 31 0a 3b 3b 20 20 20 20 20 ) foo/\1.;;
0e90: 25 20 20 20 20 20 66 6f 6f 2f 28 5b 5e 2f 5d 2b % foo/([^/]+
0ea0: 29 20 20 5c 31 2f 62 61 72 0a 3b 3b 0a 3b 3b 20 ) \1/bar.;;.;;
0eb0: 23 20 4e 4f 54 45 3a 20 74 68 65 20 6c 69 6e 65 # NOTE: the line
0ec0: 20 77 69 74 68 20 74 68 65 20 73 69 6e 67 6c 65 with the single
0ed0: 20 25 20 63 6f 75 6c 64 20 62 65 20 74 68 65 20 % could be the
0ee0: 72 65 73 75 6c 74 20 6f 66 0a 3b 3b 20 23 20 20 result of.;; #
0ef0: 20 20 20 20 20 69 74 65 6d 6d 61 70 20 65 6e 74 itemmap ent
0f00: 72 79 20 69 6e 20 72 65 71 75 69 72 65 6d 65 6e ry in requiremen
0f10: 74 73 20 28 6c 65 67 61 63 79 29 2e 20 54 68 65 ts (legacy). The
0f20: 20 69 74 65 6d 6d 61 70 0a 3b 3b 20 23 20 20 20 itemmap.;; #
0f30: 20 20 20 20 72 65 71 75 69 72 65 6d 65 6e 74 73 requirements
0f40: 20 65 6e 74 72 79 20 69 73 20 64 65 70 72 65 63 entry is deprec
0f50: 61 74 65 64 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 ated.;;.(define
0f60: 28 74 65 73 74 73 3a 67 65 74 2d 69 74 65 6d 6d (tests:get-itemm
0f70: 61 70 73 20 74 63 6f 6e 66 69 67 29 0a 20 20 28 aps tconfig). (
0f80: 6c 65 74 20 28 28 62 61 73 65 2d 69 74 65 6d 6d let ((base-itemm
0f90: 61 70 20 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f ap (configf:loo
0fa0: 6b 75 70 20 74 63 6f 6e 66 69 67 20 22 72 65 71 kup tconfig "req
0fb0: 75 69 72 65 6d 65 6e 74 73 22 20 22 69 74 65 6d uirements" "item
0fc0: 6d 61 70 22 29 29 0a 09 28 69 74 65 6d 6d 61 70 map"))..(itemmap
0fd0: 2d 74 61 62 6c 65 20 28 63 6f 6e 66 69 67 66 3a -table (configf:
0fe0: 67 65 74 2d 73 65 63 74 69 6f 6e 20 74 63 6f 6e get-section tcon
0ff0: 66 69 67 20 22 69 74 65 6d 6d 61 70 22 29 29 29 fig "itemmap")))
1000: 0a 20 20 20 20 28 61 70 70 65 6e 64 20 28 69 66 . (append (if
1010: 20 62 61 73 65 2d 69 74 65 6d 6d 61 70 0a 09 09 base-itemmap...
1020: 28 6c 69 73 74 20 28 6c 69 73 74 20 22 25 22 20 (list (list "%"
1030: 62 61 73 65 2d 69 74 65 6d 6d 61 70 29 29 0a 09 base-itemmap))..
1040: 09 27 28 29 29 0a 09 20 20 20 20 28 69 66 20 69 .'()).. (if i
1050: 74 65 6d 6d 61 70 2d 74 61 62 6c 65 0a 09 09 69 temmap-table...i
1060: 74 65 6d 6d 61 70 2d 74 61 62 6c 65 0a 09 09 27 temmap-table...'
1070: 28 29 29 29 29 29 0a 0a 3b 3b 20 67 69 76 65 6e ()))))..;; given
1080: 20 61 20 6c 69 73 74 20 6f 66 20 69 74 65 6d 6d a list of itemm
1090: 61 70 73 20 28 74 65 73 74 6e 61 6d 65 20 2e 20 aps (testname .
10a0: 6d 61 70 29 2c 20 72 65 74 75 72 6e 20 74 68 65 map), return the
10b0: 20 66 69 72 73 74 20 6d 61 74 63 68 0a 3b 3b 0a first match.;;.
10c0: 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 6c (define (tests:l
10d0: 6f 6f 6b 75 70 2d 69 74 65 6d 6d 61 70 20 69 74 ookup-itemmap it
10e0: 65 6d 6d 61 70 73 20 74 65 73 74 6e 61 6d 65 29 emmaps testname)
10f0: 0a 20 20 28 6c 65 74 20 28 28 62 65 73 74 2d 6d . (let ((best-m
1100: 61 74 63 68 65 73 20 28 66 69 6c 74 65 72 20 28 atches (filter (
1110: 6c 61 6d 62 64 61 20 28 69 74 65 6d 6d 61 70 29 lambda (itemmap)
1120: 0a 09 09 09 09 28 74 65 73 74 73 3a 6d 61 74 63 .....(tests:matc
1130: 68 20 28 63 61 72 20 69 74 65 6d 6d 61 70 29 20 h (car itemmap)
1140: 74 65 73 74 6e 61 6d 65 20 23 66 29 29 0a 09 09 testname #f))...
1150: 09 20 20 20 20 20 20 69 74 65 6d 6d 61 70 73 29 . itemmaps)
1160: 29 29 0a 20 20 20 20 28 69 66 20 28 6e 75 6c 6c )). (if (null
1170: 3f 20 62 65 73 74 2d 6d 61 74 63 68 65 73 29 0a ? best-matches).
1180: 09 23 66 0a 09 28 6c 65 74 20 28 28 72 65 73 20 .#f..(let ((res
1190: 28 63 61 72 20 62 65 73 74 2d 6d 61 74 63 68 65 (car best-matche
11a0: 73 29 29 29 0a 09 20 20 3b 3b 20 28 64 65 62 75 s))).. ;; (debu
11b0: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
11c0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 65 lt-log-port* "re
11d0: 73 3d 22 20 72 65 73 29 0a 09 20 20 28 63 6f 6e s=" res).. (con
11e0: 64 0a 09 20 20 20 28 28 73 74 72 69 6e 67 3f 20 d.. ((string?
11f0: 72 65 73 29 20 72 65 73 29 20 3b 3b 3b 20 46 49 res) res) ;;; FI
1200: 58 20 54 48 45 20 52 4f 4f 54 20 43 41 55 53 45 X THE ROOT CAUSE
1210: 20 48 45 52 45 20 2e 2e 2e 2e 0a 09 20 20 20 28 HERE ...... (
1220: 28 6e 75 6c 6c 3f 20 72 65 73 29 20 20 20 23 66 (null? res) #f
1230: 29 0a 09 20 20 20 28 28 73 74 72 69 6e 67 3f 20 ).. ((string?
1240: 28 63 64 72 20 72 65 73 29 29 20 28 63 64 72 20 (cdr res)) (cdr
1250: 72 65 73 29 29 20 20 3b 3b 20 69 74 20 69 73 20 res)) ;; it is
1260: 61 20 70 61 69 72 0a 09 20 20 20 28 28 73 74 72 a pair.. ((str
1270: 69 6e 67 3f 20 28 63 61 64 72 20 72 65 73 29 29 ing? (cadr res))
1280: 28 63 61 64 72 20 72 65 73 29 29 20 3b 3b 20 69 (cadr res)) ;; i
1290: 74 20 69 73 20 61 20 6c 69 73 74 0a 09 20 20 20 t is a list..
12a0: 28 65 6c 73 65 20 63 61 64 72 20 72 65 73 29 29 (else cadr res))
12b0: 29 29 29 29 0a 0a 3b 3b 20 72 65 74 75 72 6e 20 ))))..;; return
12c0: 69 74 65 6d 73 20 67 69 76 65 6e 20 63 6f 6e 66 items given conf
12d0: 69 67 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 ig.;;.(define (t
12e0: 65 73 74 73 3a 67 65 74 2d 69 74 65 6d 73 20 74 ests:get-items t
12f0: 63 6f 6e 66 69 67 29 0a 20 20 28 6c 65 74 20 28 config). (let (
1300: 28 69 74 65 6d 73 20 20 20 20 20 20 28 68 61 73 (items (has
1310: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
1320: 75 6c 74 20 74 63 6f 6e 66 69 67 20 22 69 74 65 ult tconfig "ite
1330: 6d 73 22 20 23 66 29 29 20 3b 3b 20 69 74 65 6d ms" #f)) ;; item
1340: 73 20 34 0a 09 28 69 74 65 6d 73 74 61 62 6c 65 s 4..(itemstable
1350: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
1360: 2f 64 65 66 61 75 6c 74 20 74 63 6f 6e 66 69 67 /default tconfig
1370: 20 22 69 74 65 6d 73 74 61 62 6c 65 22 20 23 66 "itemstable" #f
1380: 29 29 29 20 0a 20 20 20 20 3b 3b 20 69 66 20 65 ))) . ;; if e
1390: 69 74 68 65 72 20 69 74 65 6d 73 20 6f 72 20 69 ither items or i
13a0: 74 65 6d 73 20 74 61 62 6c 65 20 69 73 20 61 20 tems table is a
13b0: 70 72 6f 63 20 72 65 74 75 72 6e 20 69 74 20 73 proc return it s
13c0: 6f 20 74 65 73 74 20 72 75 6e 6e 69 6e 67 0a 20 o test running.
13d0: 20 20 20 3b 3b 20 70 72 6f 63 65 73 73 20 63 61 ;; process ca
13e0: 6e 20 6b 6e 6f 77 20 74 6f 20 63 61 6c 6c 20 69 n know to call i
13f0: 74 65 6d 73 3a 67 65 74 2d 69 74 65 6d 73 2d 66 tems:get-items-f
1400: 72 6f 6d 2d 63 6f 6e 66 69 67 0a 20 20 20 20 3b rom-config. ;
1410: 3b 20 69 66 20 65 69 74 68 65 72 20 69 73 20 61 ; if either is a
1420: 20 6c 69 73 74 20 61 6e 64 20 6e 6f 6e 65 20 69 list and none i
1430: 73 20 61 20 70 72 6f 63 20 67 6f 20 61 68 65 61 s a proc go ahea
1440: 64 20 61 6e 64 20 63 61 6c 6c 20 67 65 74 2d 69 d and call get-i
1450: 74 65 6d 73 0a 20 20 20 20 3b 3b 20 6f 74 68 65 tems. ;; othe
1460: 72 77 69 73 65 20 72 65 74 75 72 6e 20 23 66 20 rwise return #f
1470: 2d 20 74 68 69 73 20 69 73 20 6e 6f 74 20 61 6e - this is not an
1480: 20 69 74 65 72 61 74 65 64 20 74 65 73 74 0a 20 iterated test.
1490: 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 28 28 (cond. ((
14a0: 70 72 6f 63 65 64 75 72 65 3f 20 69 74 65 6d 73 procedure? items
14b0: 29 20 20 20 20 20 20 0a 20 20 20 20 20 20 28 64 ) . (d
14c0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
14d0: 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 4 *default-log-p
14e0: 6f 72 74 2a 20 22 69 74 65 6d 73 20 69 73 20 61 ort* "items is a
14f0: 20 70 72 6f 63 65 64 75 72 65 2c 20 77 69 6c 6c procedure, will
1500: 20 63 61 6c 63 20 6c 61 74 65 72 22 29 0a 20 20 calc later").
1510: 20 20 20 20 69 74 65 6d 73 29 20 20 20 20 20 20 items)
1520: 20 20 20 20 20 20 3b 3b 20 63 61 6c 63 20 6c 61 ;; calc la
1530: 74 65 72 0a 20 20 20 20 20 28 28 70 72 6f 63 65 ter. ((proce
1540: 64 75 72 65 3f 20 69 74 65 6d 73 74 61 62 6c 65 dure? itemstable
1550: 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 ). (debug:p
1560: 72 69 6e 74 2d 69 6e 66 6f 20 34 20 2a 64 65 66 rint-info 4 *def
1570: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
1580: 69 74 65 6d 73 74 61 62 6c 65 20 69 73 20 61 20 itemstable is a
1590: 70 72 6f 63 65 64 75 72 65 2c 20 77 69 6c 6c 20 procedure, will
15a0: 63 61 6c 63 20 6c 61 74 65 72 22 29 0a 20 20 20 calc later").
15b0: 20 20 20 69 74 65 6d 73 74 61 62 6c 65 29 20 20 itemstable)
15c0: 20 20 20 20 20 3b 3b 20 63 61 6c 63 20 6c 61 74 ;; calc lat
15d0: 65 72 0a 20 20 20 20 20 28 28 66 69 6c 74 65 72 er. ((filter
15e0: 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 09 28 (lambda (x)...(
15f0: 6c 65 74 20 28 28 76 61 6c 20 28 63 61 72 20 78 let ((val (car x
1600: 29 29 29 0a 09 09 20 20 28 69 66 20 28 70 72 6f )))... (if (pro
1610: 63 65 64 75 72 65 3f 20 76 61 6c 29 20 76 61 6c cedure? val) val
1620: 20 23 66 29 29 29 0a 09 20 20 20 20 20 20 28 61 #f))).. (a
1630: 70 70 65 6e 64 20 28 69 66 20 28 6c 69 73 74 3f ppend (if (list?
1640: 20 69 74 65 6d 73 29 20 69 74 65 6d 73 20 27 28 items) items '(
1650: 29 29 0a 09 09 20 20 20 20 20 20 28 69 66 20 28 ))... (if (
1660: 6c 69 73 74 3f 20 69 74 65 6d 73 74 61 62 6c 65 list? itemstable
1670: 29 20 69 74 65 6d 73 74 61 62 6c 65 20 27 28 29 ) itemstable '()
1680: 29 29 29 0a 20 20 20 20 20 20 27 68 61 76 65 2d ))). 'have-
1690: 70 72 6f 63 65 64 75 72 65 29 0a 20 20 20 20 20 procedure).
16a0: 28 28 6f 72 20 28 6c 69 73 74 3f 20 69 74 65 6d ((or (list? item
16b0: 73 29 28 6c 69 73 74 3f 20 69 74 65 6d 73 74 61 s)(list? itemsta
16c0: 62 6c 65 29 29 20 3b 3b 20 63 61 6c 63 20 6e 6f ble)) ;; calc no
16d0: 77 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 w. (debug:p
16e0: 72 69 6e 74 2d 69 6e 66 6f 20 34 20 2a 64 65 66 rint-info 4 *def
16f0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
1700: 69 74 65 6d 73 20 61 6e 64 20 69 74 65 6d 73 74 items and itemst
1710: 61 62 6c 65 20 61 72 65 20 6c 69 73 74 73 2c 20 able are lists,
1720: 63 61 6c 63 20 6e 6f 77 5c 6e 22 0a 09 09 09 22 calc now\n"...."
1730: 20 20 20 20 69 74 65 6d 73 3a 20 22 20 69 74 65 items: " ite
1740: 6d 73 20 22 20 69 74 65 6d 73 74 61 62 6c 65 3a ms " itemstable:
1750: 20 22 20 69 74 65 6d 73 74 61 62 6c 65 29 0a 20 " itemstable).
1760: 20 20 20 20 20 28 69 74 65 6d 73 3a 67 65 74 2d (items:get-
1770: 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 items-from-confi
1780: 67 20 74 63 6f 6e 66 69 67 29 29 0a 20 20 20 20 g tconfig)).
1790: 20 28 65 6c 73 65 20 23 66 29 29 29 29 20 20 20 (else #f))))
17a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
17b0: 20 20 20 20 20 20 20 20 3b 3b 20 6e 6f 74 20 69 ;; not i
17c0: 74 65 72 61 74 65 64 0a 0a 0a 3b 3b 20 72 65 74 terated...;; ret
17d0: 75 72 6e 73 20 77 61 69 74 6f 6e 73 20 77 61 69 urns waitons wai
17e0: 74 6f 72 73 20 74 63 6f 6e 66 69 67 64 61 74 0a tors tconfigdat.
17f0: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 ;;.(define (test
1800: 73 3a 67 65 74 2d 77 61 69 74 6f 6e 73 20 74 65 s:get-waitons te
1810: 73 74 2d 6e 61 6d 65 20 61 6c 6c 2d 74 65 73 74 st-name all-test
1820: 73 2d 72 65 67 69 73 74 72 79 29 0a 20 20 20 28 s-registry). (
1830: 6c 65 74 2a 20 28 28 63 6f 6e 66 69 67 20 20 28 let* ((config (
1840: 74 65 73 74 73 3a 67 65 74 2d 74 65 73 74 63 6f tests:get-testco
1850: 6e 66 69 67 20 74 65 73 74 2d 6e 61 6d 65 20 23 nfig test-name #
1860: 66 20 61 6c 6c 2d 74 65 73 74 73 2d 72 65 67 69 f all-tests-regi
1870: 73 74 72 79 20 27 72 65 74 75 72 6e 2d 70 72 6f stry 'return-pro
1880: 63 73 29 29 29 20 3b 3b 20 61 73 73 75 6d 69 6e cs))) ;; assumin
1890: 67 20 6e 6f 20 70 72 6f 62 6c 65 6d 73 20 77 69 g no problems wi
18a0: 74 68 20 69 6d 6d 65 64 69 61 74 65 20 65 76 61 th immediate eva
18b0: 6c 75 61 74 69 6f 6e 2c 20 74 68 69 73 20 63 6f luation, this co
18c0: 75 6c 64 20 62 65 20 73 69 6d 70 6c 69 66 69 65 uld be simplifie
18d0: 64 20 28 27 72 65 74 75 72 6e 2d 70 72 6f 63 73 d ('return-procs
18e0: 20 2d 3e 20 23 74 29 0a 20 20 20 20 20 28 6c 65 -> #t). (le
18f0: 74 20 28 28 69 6e 73 74 72 20 28 69 66 20 63 6f t ((instr (if co
1900: 6e 66 69 67 20 0a 09 09 20 20 20 20 20 20 28 63 nfig ... (c
1910: 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 63 6f onfigf:lookup co
1920: 6e 66 69 67 20 22 72 65 71 75 69 72 65 6d 65 6e nfig "requiremen
1930: 74 73 22 20 22 77 61 69 74 6f 6e 22 29 0a 09 09 ts" "waiton")...
1940: 20 20 20 20 20 20 28 62 65 67 69 6e 20 3b 3b 20 (begin ;;
1950: 4e 6f 20 63 6f 6e 66 69 67 20 6d 65 61 6e 73 20 No config means
1960: 74 68 69 73 20 69 73 20 61 20 6e 6f 6e 2d 65 78 this is a non-ex
1970: 69 73 74 61 6e 74 20 74 65 73 74 0a 09 09 09 28 istant test....(
1980: 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f debug:print-erro
1990: 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 r 0 *default-log
19a0: 2d 70 6f 72 74 2a 20 22 6e 6f 6e 2d 65 78 69 73 -port* "non-exis
19b0: 74 65 6e 74 20 72 65 71 75 69 72 65 64 20 74 65 tent required te
19c0: 73 74 20 5c 22 22 20 74 65 73 74 2d 6e 61 6d 65 st \"" test-name
19d0: 20 22 5c 22 22 29 0a 09 09 09 28 65 78 69 74 20 "\"")....(exit
19e0: 31 29 29 29 29 0a 09 20 20 20 28 69 6e 73 74 72 1)))).. (instr
19f0: 32 20 28 69 66 20 63 6f 6e 66 69 67 0a 09 09 20 2 (if config...
1a00: 20 20 20 20 20 20 28 63 6f 6e 66 69 67 66 3a 6c (configf:l
1a10: 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 20 22 72 65 ookup config "re
1a20: 71 75 69 72 65 6d 65 6e 74 73 22 20 22 77 61 69 quirements" "wai
1a30: 74 6f 72 22 29 0a 09 09 20 20 20 20 20 20 20 22 tor")... "
1a40: 22 29 29 29 0a 20 20 20 20 20 20 20 28 64 65 62 "))). (deb
1a50: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 38 20 ug:print-info 8
1a60: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
1a70: 74 2a 20 22 77 61 69 74 6f 6e 73 20 73 74 72 69 t* "waitons stri
1a80: 6e 67 20 69 73 20 22 20 69 6e 73 74 72 20 22 2c ng is " instr ",
1a90: 20 77 61 69 74 6f 72 73 20 73 74 72 69 6e 67 20 waitors string
1aa0: 69 73 20 22 20 69 6e 73 74 72 32 29 0a 20 20 20 is " instr2).
1ab0: 20 20 20 20 28 6c 65 74 20 28 28 6e 65 77 77 61 (let ((newwa
1ac0: 69 74 6f 6e 73 0a 09 20 20 20 20 20 20 28 73 74 itons.. (st
1ad0: 72 69 6e 67 2d 73 70 6c 69 74 20 28 63 6f 6e 64 ring-split (cond
1ae0: 0a 09 09 09 20 20 20 20 20 28 28 70 72 6f 63 65 .... ((proce
1af0: 64 75 72 65 3f 20 69 6e 73 74 72 29 20 3b 3b 20 dure? instr) ;;
1b00: 68 65 72 65 20 0a 09 09 09 20 20 20 20 20 20 28 here .... (
1b10: 6c 65 74 20 28 28 72 65 73 20 28 69 6e 73 74 72 let ((res (instr
1b20: 29 29 29 0a 09 09 09 09 28 64 65 62 75 67 3a 70 ))).....(debug:p
1b30: 72 69 6e 74 2d 69 6e 66 6f 20 38 20 2a 64 65 66 rint-info 8 *def
1b40: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
1b50: 77 61 69 74 6f 6e 20 70 72 6f 63 65 64 75 72 65 waiton procedure
1b60: 20 72 65 73 75 6c 74 73 20 69 6e 20 73 74 72 69 results in stri
1b70: 6e 67 20 22 20 72 65 73 20 22 20 66 6f 72 20 74 ng " res " for t
1b80: 65 73 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 29 est " test-name)
1b90: 0a 09 09 09 09 72 65 73 29 29 0a 09 09 09 20 20 .....res))....
1ba0: 20 20 20 28 28 73 74 72 69 6e 67 3f 20 69 6e 73 ((string? ins
1bb0: 74 72 29 20 20 20 20 20 69 6e 73 74 72 29 0a 09 tr) instr)..
1bc0: 09 09 20 20 20 20 20 28 65 6c 73 65 20 0a 09 09 .. (else ...
1bd0: 09 20 20 20 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 . ;; NOTE:
1be0: 54 68 69 73 20 69 73 20 61 63 74 75 61 6c 6c 79 This is actually
1bf0: 20 74 68 65 20 63 61 73 65 20 6f 66 20 2a 6e 6f the case of *no
1c00: 2a 20 77 61 69 74 6f 6e 73 21 20 3b 3b 20 28 64 * waitons! ;; (d
1c10: 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 ebug:print-error
1c20: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
1c30: 70 6f 72 74 2a 20 22 73 6f 6d 65 74 68 69 6e 67 port* "something
1c40: 20 77 65 6e 74 20 77 72 6f 6e 67 20 69 6e 20 70 went wrong in p
1c50: 72 6f 63 65 73 73 69 6e 67 20 77 61 69 74 6f 6e rocessing waiton
1c60: 73 20 66 6f 72 20 74 65 73 74 20 22 20 74 65 73 s for test " tes
1c70: 74 2d 6e 61 6d 65 29 0a 09 09 09 20 20 20 20 20 t-name)....
1c80: 20 22 22 29 29 29 29 0a 09 20 20 20 20 20 28 6e "")))).. (n
1c90: 65 77 77 61 69 74 6f 72 73 0a 09 20 20 20 20 20 ewwaitors..
1ca0: 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 28 (string-split (
1cb0: 63 6f 6e 64 0a 09 09 09 20 20 20 20 20 28 28 70 cond.... ((p
1cc0: 72 6f 63 65 64 75 72 65 3f 20 69 6e 73 74 72 32 rocedure? instr2
1cd0: 29 0a 09 09 09 20 20 20 20 20 20 28 6c 65 74 20 ).... (let
1ce0: 28 28 72 65 73 20 28 69 6e 73 74 72 32 29 29 29 ((res (instr2)))
1cf0: 0a 09 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e .....(debug:prin
1d00: 74 2d 69 6e 66 6f 20 38 20 2a 64 65 66 61 75 6c t-info 8 *defaul
1d10: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 77 61 69 t-log-port* "wai
1d20: 74 6f 72 20 70 72 6f 63 65 64 75 72 65 20 72 65 tor procedure re
1d30: 73 75 6c 74 73 20 69 6e 20 73 74 72 69 6e 67 20 sults in string
1d40: 22 20 72 65 73 20 22 20 66 6f 72 20 74 65 73 74 " res " for test
1d50: 20 22 20 74 65 73 74 2d 6e 61 6d 65 29 0a 09 09 " test-name)...
1d60: 09 09 72 65 73 29 29 0a 09 09 09 20 20 20 20 20 ..res))....
1d70: 28 28 73 74 72 69 6e 67 3f 20 69 6e 73 74 72 32 ((string? instr2
1d80: 29 20 20 20 20 20 69 6e 73 74 72 32 29 0a 09 09 ) instr2)...
1d90: 09 20 20 20 20 20 28 65 6c 73 65 20 0a 09 09 09 . (else ....
1da0: 20 20 20 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 54 ;; NOTE: T
1db0: 68 69 73 20 69 73 20 61 63 74 75 61 6c 6c 79 20 his is actually
1dc0: 74 68 65 20 63 61 73 65 20 6f 66 20 2a 6e 6f 2a the case of *no*
1dd0: 20 77 61 69 74 6f 6e 73 21 20 3b 3b 20 28 64 65 waitons! ;; (de
1de0: 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 bug:print-error
1df0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
1e00: 6f 72 74 2a 20 22 73 6f 6d 65 74 68 69 6e 67 20 ort* "something
1e10: 77 65 6e 74 20 77 72 6f 6e 67 20 69 6e 20 70 72 went wrong in pr
1e20: 6f 63 65 73 73 69 6e 67 20 77 61 69 74 6f 6e 73 ocessing waitons
1e30: 20 66 6f 72 20 74 65 73 74 20 22 20 74 65 73 74 for test " test
1e40: 2d 6e 61 6d 65 29 0a 09 09 09 20 20 20 20 20 20 -name)....
1e50: 22 22 29 29 29 29 29 0a 09 20 28 76 61 6c 75 65 ""))))).. (value
1e60: 73 0a 09 20 20 3b 3b 20 74 68 65 20 77 61 69 74 s.. ;; the wait
1e70: 6f 6e 73 0a 09 20 20 28 66 69 6c 74 65 72 20 28 ons.. (filter (
1e80: 6c 61 6d 62 64 61 20 28 78 29 0a 09 09 20 20 20 lambda (x)...
1e90: 20 28 69 66 20 28 68 61 73 68 2d 74 61 62 6c 65 (if (hash-table
1ea0: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 61 6c 6c -ref/default all
1eb0: 2d 74 65 73 74 73 2d 72 65 67 69 73 74 72 79 20 -tests-registry
1ec0: 78 20 23 66 29 0a 09 09 09 23 74 0a 09 09 09 28 x #f)....#t....(
1ed0: 62 65 67 69 6e 0a 09 09 09 20 20 28 64 65 62 75 begin.... (debu
1ee0: 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 g:print-error 0
1ef0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
1f00: 74 2a 20 22 74 65 73 74 20 22 20 74 65 73 74 2d t* "test " test-
1f10: 6e 61 6d 65 20 22 20 68 61 73 20 75 6e 72 65 63 name " has unrec
1f20: 6f 67 6e 69 73 65 64 20 77 61 69 74 6f 6e 20 74 ognised waiton t
1f30: 65 73 74 6e 61 6d 65 20 22 20 78 29 0a 09 09 09 estname " x)....
1f40: 20 20 23 66 29 29 29 0a 09 09 20 20 6e 65 77 77 #f)))... neww
1f50: 61 69 74 6f 6e 73 29 0a 09 20 20 28 66 69 6c 74 aitons).. (filt
1f60: 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 er (lambda (x)..
1f70: 09 20 20 20 20 28 69 66 20 28 68 61 73 68 2d 74 . (if (hash-t
1f80: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
1f90: 20 61 6c 6c 2d 74 65 73 74 73 2d 72 65 67 69 73 all-tests-regis
1fa0: 74 72 79 20 78 20 23 66 29 0a 09 09 09 23 74 0a try x #f)....#t.
1fb0: 09 09 09 28 62 65 67 69 6e 0a 09 09 09 20 20 28 ...(begin.... (
1fc0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f debug:print-erro
1fd0: 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 r 0 *default-log
1fe0: 2d 70 6f 72 74 2a 20 22 74 65 73 74 20 22 20 74 -port* "test " t
1ff0: 65 73 74 2d 6e 61 6d 65 20 22 20 68 61 73 20 75 est-name " has u
2000: 6e 72 65 63 6f 67 6e 69 73 65 64 20 77 61 69 74 nrecognised wait
2010: 6f 6e 20 74 65 73 74 6e 61 6d 65 20 22 20 78 29 on testname " x)
2020: 0a 09 09 09 20 20 23 66 29 29 29 0a 09 09 20 20 .... #f)))...
2030: 6e 65 77 77 61 69 74 6f 72 73 29 0a 09 20 20 63 newwaitors).. c
2040: 6f 6e 66 69 67 29 29 29 29 29 0a 09 09 09 09 09 onfig)))))......
2050: 20 20 20 20 20 0a 3b 3b 20 67 69 76 65 6e 20 77 .;; given w
2060: 61 69 74 69 6e 67 2d 74 65 73 74 20 74 68 61 74 aiting-test that
2070: 20 69 73 20 77 61 69 74 69 6e 67 20 6f 6e 20 77 is waiting on w
2080: 61 69 74 6f 6e 2d 74 65 73 74 20 65 78 74 65 6e aiton-test exten
2090: 64 20 74 65 73 74 2d 70 61 74 74 20 61 70 70 72 d test-patt appr
20a0: 6f 70 72 69 61 74 65 6c 79 0a 3b 3b 0a 3b 3b 20 opriately.;;.;;
20b0: 20 67 65 6e 6c 69 62 2f 74 65 73 74 63 6f 6e 66 genlib/testconf
20c0: 69 67 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ig
20d0: 20 73 69 6d 2f 74 65 73 74 63 6f 6e 66 69 67 0a sim/testconfig.
20e0: 3b 3b 20 20 67 65 6e 6c 69 62 2f 73 63 68 20 20 ;; genlib/sch
20f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2100: 20 20 20 20 73 69 6d 2f 73 63 68 2f 63 65 6c 6c sim/sch/cell
2110: 31 0a 3b 3b 0a 3b 3b 20 20 5b 72 65 71 75 69 72 1.;;.;; [requir
2120: 65 6d 65 6e 74 73 5d 20 20 20 20 20 20 20 20 20 ements]
2130: 20 20 20 20 20 20 20 20 20 5b 72 65 71 75 69 72 [requir
2140: 65 6d 65 6e 74 73 5d 0a 3b 3b 20 20 20 20 20 20 ements].;;
2150: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2160: 20 20 20 20 20 20 20 20 20 20 20 20 6d 6f 64 65 mode
2170: 20 69 74 65 6d 77 61 69 74 0a 3b 3b 20 20 20 20 itemwait.;;
2180: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2190: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 23 20 #
21a0: 74 72 69 6d 20 6f 66 66 20 74 68 65 20 63 65 6c trim off the cel
21b0: 6c 20 74 6f 20 64 65 74 65 72 6d 69 6e 65 20 77 l to determine w
21c0: 68 61 74 20 74 6f 20 72 75 6e 20 66 6f 72 20 67 hat to run for g
21d0: 65 6e 6c 69 62 0a 3b 3b 20 20 20 20 20 20 20 20 enlib.;;
21e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
21f0: 20 20 20 20 20 20 20 20 20 20 69 74 65 6d 6d 61 itemma
2200: 70 20 2f 2e 2a 0a 3b 3b 0a 3b 3b 20 20 20 20 20 p /.*.;;.;;
2210: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2220: 20 20 20 20 20 20 20 20 20 20 20 20 20 77 61 69 wai
2230: 74 69 6e 67 2d 74 65 73 74 20 69 73 20 77 61 69 ting-test is wai
2240: 74 69 6e 67 20 6f 6e 20 77 61 69 74 6f 6e 2d 74 ting on waiton-t
2250: 65 73 74 20 73 6f 20 77 65 20 6e 65 65 64 20 74 est so we need t
2260: 6f 20 63 72 65 61 74 65 20 61 20 70 61 74 74 65 o create a patte
2270: 72 6e 20 66 6f 72 20 77 61 69 74 6f 6e 2d 74 65 rn for waiton-te
2280: 73 74 20 67 69 76 65 6e 20 77 61 69 74 69 6e 67 st given waiting
2290: 2d 74 65 73 74 20 61 6e 64 20 69 74 65 6d 6d 61 -test and itemma
22a0: 70 0a 3b 3b 20 42 42 3e 20 28 74 65 73 74 73 3a p.;; BB> (tests:
22b0: 65 78 74 65 6e 64 2d 74 65 73 74 2d 70 61 74 74 extend-test-patt
22c0: 73 20 22 6e 6f 72 6d 61 6c 2d 73 65 63 6f 6e 64 s "normal-second
22d0: 2f 32 22 20 22 6e 6f 72 6d 61 6c 2d 73 65 63 6f /2" "normal-seco
22e0: 6e 64 22 20 22 6e 6f 72 6d 61 6c 2d 66 69 72 73 nd" "normal-firs
22f0: 74 22 20 27 28 29 29 0a 3b 3b 20 6f 62 73 65 72 t" '()).;; obser
2300: 76 65 64 20 2d 3e 20 22 6e 6f 72 6d 61 6c 2d 66 ved -> "normal-f
2310: 69 72 73 74 2f 32 2c 6e 6f 72 6d 61 6c 2d 66 69 irst/2,normal-fi
2320: 72 73 74 2f 2c 6e 6f 72 6d 61 6c 2d 73 65 63 6f rst/,normal-seco
2330: 6e 64 2f 32 2c 6e 6f 72 6d 61 6c 2d 73 65 63 6f nd/2,normal-seco
2340: 6e 64 2f 22 0a 3b 3b 20 65 78 70 65 63 74 65 64 nd/".;; expected
2350: 20 2d 3e 20 22 6e 6f 72 6d 61 6c 2d 66 69 72 73 -> "normal-firs
2360: 74 2c 6e 6f 72 6d 61 6c 2d 73 65 63 6f 6e 64 2f t,normal-second/
2370: 32 2c 6e 6f 72 6d 61 6c 2d 73 65 63 6f 6e 64 2f 2,normal-second/
2380: 22 0a 3b 3b 20 74 65 73 74 70 61 74 74 20 3d 20 ".;; testpatt =
2390: 6e 6f 72 6d 61 6c 2d 73 65 63 6f 6e 64 2f 32 0a normal-second/2.
23a0: 3b 3b 20 77 61 69 74 69 6e 67 2d 74 65 73 74 20 ;; waiting-test
23b0: 3d 20 6e 6f 72 6d 61 6c 2d 73 65 63 6f 6e 64 0a = normal-second.
23c0: 3b 3b 20 77 61 69 74 6f 6e 2d 74 65 73 74 20 3d ;; waiton-test =
23d0: 20 6e 6f 72 6d 61 6c 2d 66 69 72 73 74 0a 3b 3b normal-first.;;
23e0: 20 69 74 65 6d 6d 61 70 73 20 3d 20 28 29 0a 0a itemmaps = ()..
23f0: 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 65 (define (tests:e
2400: 78 74 65 6e 64 2d 74 65 73 74 2d 70 61 74 74 73 xtend-test-patts
2410: 20 74 65 73 74 2d 70 61 74 74 20 77 61 69 74 69 test-patt waiti
2420: 6e 67 2d 74 65 73 74 20 77 61 69 74 6f 6e 2d 74 ng-test waiton-t
2430: 65 73 74 20 69 74 65 6d 6d 61 70 73 20 69 74 65 est itemmaps ite
2440: 6d 69 7a 65 64 2d 77 61 69 74 6f 6e 29 0a 20 20 mized-waiton).
2450: 28 63 6f 6e 64 0a 20 20 20 28 69 74 65 6d 69 7a (cond. (itemiz
2460: 65 64 2d 77 61 69 74 6f 6e 0a 20 20 20 20 28 6c ed-waiton. (l
2470: 65 74 2a 20 28 28 69 74 65 6d 6d 61 70 20 20 20 et* ((itemmap
2480: 20 20 20 20 20 20 20 28 74 65 73 74 73 3a 6c 6f (tests:lo
2490: 6f 6b 75 70 2d 69 74 65 6d 6d 61 70 20 69 74 65 okup-itemmap ite
24a0: 6d 6d 61 70 73 20 77 61 69 74 6f 6e 2d 74 65 73 mmaps waiton-tes
24b0: 74 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 t)). (
24c0: 70 61 74 74 73 20 20 20 20 20 20 20 20 20 20 20 patts
24d0: 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 74 (string-split t
24e0: 65 73 74 2d 70 61 74 74 20 22 2c 22 29 29 0a 20 est-patt ",")).
24f0: 20 20 20 20 20 20 20 20 20 20 28 77 61 69 74 69 (waiti
2500: 6e 67 2d 74 65 73 74 2d 6c 65 6e 20 28 2b 20 28 ng-test-len (+ (
2510: 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 77 61 string-length wa
2520: 69 74 69 6e 67 2d 74 65 73 74 29 20 31 29 29 0a iting-test) 1)).
2530: 20 20 20 20 20 20 20 20 20 20 20 28 70 61 74 74 (patt
2540: 73 2d 77 61 69 74 6f 6e 20 20 20 20 20 28 6d 61 s-waiton (ma
2550: 70 20 28 6c 61 6d 62 64 61 20 28 78 29 20 20 3b p (lambda (x) ;
2560: 3b 20 66 6f 72 20 65 61 63 68 20 69 6e 63 6f 6d ; for each incom
2570: 69 6e 67 20 70 61 74 74 20 74 68 61 74 20 6d 61 ing patt that ma
2580: 74 63 68 65 73 20 74 68 65 20 77 61 69 74 69 6e tches the waitin
2590: 67 20 74 65 73 74 0a 20 20 20 20 20 20 20 20 20 g test.
25a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
25b0: 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 2a (let*
25c0: 20 28 28 6d 6f 64 70 61 74 74 20 28 69 66 20 69 ((modpatt (if i
25d0: 74 65 6d 6d 61 70 20 28 64 62 3a 63 6f 6e 76 65 temmap (db:conve
25e0: 72 74 2d 74 65 73 74 2d 69 74 65 6d 70 61 74 68 rt-test-itempath
25f0: 20 78 20 69 74 65 6d 6d 61 70 29 20 78 29 29 20 x itemmap) x))
2600: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
2610: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2620: 20 20 20 20 20 20 20 20 20 20 20 20 28 6e 65 77 (new
2630: 70 61 74 74 20 28 63 6f 6e 63 20 77 61 69 74 6f patt (conc waito
2640: 6e 2d 74 65 73 74 20 22 2f 22 20 28 73 75 62 73 n-test "/" (subs
2650: 74 72 69 6e 67 20 6d 6f 64 70 61 74 74 20 77 61 tring modpatt wa
2660: 69 74 69 6e 67 2d 74 65 73 74 2d 6c 65 6e 20 28 iting-test-len (
2670: 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 6d 6f string-length mo
2680: 64 70 61 74 74 29 29 29 29 29 0a 20 20 20 20 20 dpatt))))).
2690: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
26a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
26b0: 20 3b 3b 20 28 63 6f 6e 63 20 77 61 69 74 69 6e ;; (conc waitin
26c0: 67 2d 74 65 73 74 20 22 2f 2c 22 20 77 61 69 74 g-test "/," wait
26d0: 69 6e 67 2d 74 65 73 74 20 22 2f 22 20 28 73 75 ing-test "/" (su
26e0: 62 73 74 72 69 6e 67 20 6d 6f 64 70 61 74 74 20 bstring modpatt
26f0: 77 61 69 74 6f 6e 2d 74 65 73 74 2d 6c 65 6e 20 waiton-test-len
2700: 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 6d (string-length m
2710: 6f 64 70 61 74 74 29 29 29 29 29 0a 20 20 20 20 odpatt))))).
2720: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2730: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2740: 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 69 6e 20 ;; (print "in
2750: 6d 61 70 2c 20 78 3d 22 20 78 20 22 2c 20 6e 65 map, x=" x ", ne
2760: 77 70 61 74 74 3d 22 20 6e 65 77 70 61 74 74 29 wpatt=" newpatt)
2770: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
2780: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2790: 20 20 20 20 20 20 20 6e 65 77 70 61 74 74 29 29 newpatt))
27a0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
27b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
27c0: 20 20 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 (filter (lamb
27d0: 64 61 20 28 78 29 0a 20 20 20 20 20 20 20 20 20 da (x).
27e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
27f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2800: 20 20 20 28 65 71 3f 20 28 73 75 62 73 74 72 69 (eq? (substri
2810: 6e 67 2d 69 6e 64 65 78 20 28 63 6f 6e 63 20 77 ng-index (conc w
2820: 61 69 74 69 6e 67 2d 74 65 73 74 20 22 2f 22 29 aiting-test "/")
2830: 20 78 29 20 30 29 29 20 3b 3b 20 69 73 20 74 68 x) 0)) ;; is th
2840: 69 73 20 70 61 74 74 20 70 65 72 74 69 6e 65 6e is patt pertinen
2850: 74 20 74 6f 20 74 68 65 20 77 61 69 74 69 6e 67 t to the waiting
2860: 20 74 65 73 74 0a 20 20 20 20 20 20 20 20 20 20 test.
2870: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2880: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2890: 70 61 74 74 73 29 29 29 0a 20 20 20 20 20 20 20 patts))).
28a0: 20 20 20 20 28 65 78 74 65 6e 64 65 64 2d 74 65 (extended-te
28b0: 73 74 2d 70 61 74 74 20 20 20 28 61 70 70 65 6e st-patt (appen
28c0: 64 20 70 61 74 74 73 20 28 69 66 20 28 6e 75 6c d patts (if (nul
28d0: 6c 3f 20 70 61 74 74 73 2d 77 61 69 74 6f 6e 29 l? patts-waiton)
28e0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
28f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2900: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2910: 20 20 20 20 28 6c 69 73 74 20 28 63 6f 6e 63 20 (list (conc
2920: 77 61 69 74 6f 6e 2d 74 65 73 74 20 22 2f 25 22 waiton-test "/%"
2930: 29 29 20 3b 3b 20 72 65 61 6c 6c 79 20 73 68 6f )) ;; really sho
2940: 75 6c 64 6e 27 74 20 61 64 64 20 74 68 65 20 77 uldn't add the w
2950: 61 69 74 6f 6e 20 66 6f 72 63 65 66 75 6c 6c 79 aiton forcefully
2960: 20 6c 69 6b 65 20 74 68 69 73 0a 20 20 20 20 20 like this.
2970: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2980: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2990: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 70 61 pa
29a0: 74 74 73 2d 77 61 69 74 6f 6e 29 29 29 0a 20 20 tts-waiton))).
29b0: 20 20 20 20 20 20 20 20 20 28 65 78 74 65 6e 64 (extend
29c0: 65 64 2d 74 65 73 74 2d 70 61 74 74 2d 77 69 74 ed-test-patt-wit
29d0: 68 2d 74 6f 70 6c 65 76 65 6c 73 0a 20 20 20 20 h-toplevels.
29e0: 20 20 20 20 20 20 20 20 28 66 6f 6c 64 20 28 6c (fold (l
29f0: 61 6d 62 64 61 20 28 74 65 73 74 70 61 74 74 2d ambda (testpatt-
2a00: 69 74 65 6d 20 61 63 63 75 6d 20 29 0a 20 20 20 item accum ).
2a10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2a20: 20 28 6c 65 74 20 28 28 6d 79 2d 6d 61 74 63 68 (let ((my-match
2a30: 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 22 (string-match "
2a40: 5e 28 5b 5e 25 5c 5c 2f 5d 2b 29 5c 5c 2f 2e 2b ^([^%\\/]+)\\/.+
2a50: 24 22 20 74 65 73 74 70 61 74 74 2d 69 74 65 6d $" testpatt-item
2a60: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
2a70: 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 73 20 (cons
2a80: 74 65 73 74 70 61 74 74 2d 69 74 65 6d 0a 20 20 testpatt-item.
2a90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2aa0: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 6d 79 (if my
2ab0: 2d 6d 61 74 63 68 0a 20 20 20 20 20 20 20 20 20 -match.
2ac0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2ad0: 20 20 20 20 20 20 20 28 63 6f 6e 73 0a 20 20 20 (cons.
2ae0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2af0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c
2b00: 6f 6e 63 20 28 63 61 64 72 20 6d 79 2d 6d 61 74 onc (cadr my-mat
2b10: 63 68 29 20 22 2f 22 29 0a 20 20 20 20 20 20 20 ch) "/").
2b20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2b30: 20 20 20 20 20 20 20 20 20 20 61 63 63 75 6d 29 accum)
2b40: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
2b50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2b60: 20 61 63 63 75 6d 29 29 29 29 0a 20 20 20 20 20 accum)))).
2b70: 20 20 20 20 20 20 20 20 20 20 20 20 20 27 28 29 '()
2b80: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
2b90: 20 20 20 65 78 74 65 6e 64 65 64 2d 74 65 73 74 extended-test
2ba0: 2d 70 61 74 74 29 29 29 0a 20 20 20 20 20 20 28 -patt))). (
2bb0: 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
2bc0: 73 65 20 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 se (delete-dupli
2bd0: 63 61 74 65 73 20 65 78 74 65 6e 64 65 64 2d 74 cates extended-t
2be0: 65 73 74 2d 70 61 74 74 2d 77 69 74 68 2d 74 6f est-patt-with-to
2bf0: 70 6c 65 76 65 6c 73 29 20 22 2c 22 29 29 29 0a plevels) ","))).
2c00: 20 20 20 28 65 6c 73 65 20 3b 3b 20 6e 6f 74 20 (else ;; not
2c10: 77 61 69 74 69 6e 67 20 6f 6e 20 69 74 65 6d 73 waiting on items
2c20: 2c 20 77 61 69 74 69 6e 67 20 6f 6e 20 65 6e 74 , waiting on ent
2c30: 69 72 65 20 77 61 69 74 6f 6e 20 74 65 73 74 2e ire waiton test.
2c40: 0a 20 20 20 20 28 6c 65 74 2a 20 28 28 70 61 74 . (let* ((pat
2c50: 74 73 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 ts (string-split
2c60: 20 74 65 73 74 2d 70 61 74 74 20 22 2c 22 29 29 test-patt ","))
2c70: 0a 20 20 20 20 20 20 20 20 20 20 20 28 6e 65 77 . (new
2c80: 2d 70 61 74 74 73 20 28 69 66 20 28 6d 65 6d 62 -patts (if (memb
2c90: 65 72 20 77 61 69 74 6f 6e 2d 74 65 73 74 20 70 er waiton-test p
2ca0: 61 74 74 73 29 0a 20 20 20 20 20 20 20 20 20 20 atts).
2cb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2cc0: 70 61 74 74 73 0a 20 20 20 20 20 20 20 20 20 20 patts.
2cd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2ce0: 28 63 6f 6e 73 20 77 61 69 74 6f 6e 2d 74 65 73 (cons waiton-tes
2cf0: 74 20 70 61 74 74 73 29 29 29 29 0a 20 20 20 20 t patts)))).
2d00: 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 (string-inters
2d10: 70 65 72 73 65 20 28 64 65 6c 65 74 65 2d 64 75 perse (delete-du
2d20: 70 6c 69 63 61 74 65 73 20 6e 65 77 2d 70 61 74 plicates new-pat
2d30: 74 73 29 20 22 2c 22 29 29 29 29 29 0a 0a 28 64 ts) ",")))))..(d
2d40: 65 66 69 6e 65 20 2a 67 6c 6f 62 2d 6c 69 6b 65 efine *glob-like
2d50: 2d 6d 61 74 63 68 2d 63 61 63 68 65 2a 20 28 6d -match-cache* (m
2d60: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
2d70: 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a .(define (tests:
2d80: 63 61 63 68 65 2d 72 65 67 65 78 70 20 73 74 72 cache-regexp str
2d90: 2d 69 6e 20 66 6c 61 67 29 0a 20 20 28 6c 65 74 -in flag). (let
2da0: 2a 20 28 28 6b 65 79 20 28 63 6f 6e 63 20 73 74 * ((key (conc st
2db0: 72 2d 69 6e 20 66 6c 61 67 29 29 29 0a 20 20 20 r-in flag))).
2dc0: 20 28 6f 72 20 28 68 61 73 68 2d 74 61 62 6c 65 (or (hash-table
2dd0: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 67 6c -ref/default *gl
2de0: 6f 62 2d 6c 69 6b 65 2d 6d 61 74 63 68 2d 63 61 ob-like-match-ca
2df0: 63 68 65 2a 20 6b 65 79 20 23 66 29 0a 09 28 6c che* key #f)..(l
2e00: 65 74 2a 20 28 28 6e 65 77 72 78 20 28 72 65 67 et* ((newrx (reg
2e10: 65 78 70 20 73 74 72 2d 69 6e 20 66 6c 61 67 29 exp str-in flag)
2e20: 29 29 0a 09 20 20 28 68 61 73 68 2d 74 61 62 6c )).. (hash-tabl
2e30: 65 2d 73 65 74 21 20 2a 67 6c 6f 62 2d 6c 69 6b e-set! *glob-lik
2e40: 65 2d 6d 61 74 63 68 2d 63 61 63 68 65 2a 20 6b e-match-cache* k
2e50: 65 79 20 6e 65 77 72 78 29 0a 09 20 20 6e 65 77 ey newrx).. new
2e60: 72 78 29 29 29 29 0a 0a 3b 3b 20 74 65 73 74 73 rx))))..;; tests
2e70: 3a 67 6c 6f 62 2d 6c 69 6b 65 2d 6d 61 74 63 68 :glob-like-match
2e80: 20 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 .(define (tests
2e90: 3a 67 6c 6f 62 2d 6c 69 6b 65 2d 6d 61 74 63 68 :glob-like-match
2ea0: 20 70 61 74 74 20 73 74 72 29 20 0a 20 20 28 6c patt str) . (l
2eb0: 65 74 2a 20 28 28 6c 69 6b 65 20 20 20 20 20 28 et* ((like (
2ec0: 73 75 62 73 74 72 69 6e 67 2d 69 6e 64 65 78 20 substring-index
2ed0: 22 25 22 20 70 61 74 74 29 29 0a 09 20 28 6e 6f "%" patt)).. (no
2ee0: 74 70 61 74 74 20 20 28 65 71 75 61 6c 3f 20 28 tpatt (equal? (
2ef0: 73 75 62 73 74 72 69 6e 67 2d 69 6e 64 65 78 20 substring-index
2f00: 22 7e 22 20 70 61 74 74 29 20 30 29 29 0a 09 20 "~" patt) 0))..
2f10: 28 6e 65 77 70 61 74 74 20 20 28 69 66 20 6e 6f (newpatt (if no
2f20: 74 70 61 74 74 20 28 73 75 62 73 74 72 69 6e 67 tpatt (substring
2f30: 20 70 61 74 74 20 31 29 20 70 61 74 74 29 29 0a patt 1) patt)).
2f40: 09 20 28 66 69 6e 70 61 74 74 20 20 28 69 66 20 . (finpatt (if
2f50: 6c 69 6b 65 0a 09 09 20 20 20 20 20 20 20 28 73 like... (s
2f60: 74 72 69 6e 67 2d 73 75 62 73 74 69 74 75 74 65 tring-substitute
2f70: 20 28 72 65 67 65 78 70 20 22 25 22 29 20 22 2e (regexp "%") ".
2f80: 2a 22 20 6e 65 77 70 61 74 74 20 23 66 29 0a 09 *" newpatt #f)..
2f90: 09 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d . (string-
2fa0: 73 75 62 73 74 69 74 75 74 65 20 28 72 65 67 65 substitute (rege
2fb0: 78 70 20 22 5c 5c 2a 22 29 20 22 2e 2a 22 20 6e xp "\\*") ".*" n
2fc0: 65 77 70 61 74 74 20 23 66 29 29 29 0a 09 20 28 ewpatt #f))).. (
2fd0: 72 78 20 20 20 20 20 20 20 28 74 65 73 74 73 3a rx (tests:
2fe0: 63 61 63 68 65 2d 72 65 67 65 78 70 20 66 69 6e cache-regexp fin
2ff0: 70 61 74 74 20 28 69 66 20 6c 69 6b 65 20 23 74 patt (if like #t
3000: 20 23 66 29 29 29 0a 09 20 28 72 65 73 20 20 20 #f))).. (res
3010: 20 20 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 (string-match
3020: 20 72 78 20 73 74 72 29 29 29 0a 20 20 20 20 28 rx str))). (
3030: 69 66 20 6e 6f 74 70 61 74 74 20 28 6e 6f 74 20 if notpatt (not
3040: 72 65 73 29 20 72 65 73 29 29 29 0a 0a 3b 3b 20 res) res)))..;;
3050: 69 66 20 69 74 65 6d 70 61 74 68 20 69 73 20 23 if itempath is #
3060: 66 20 74 68 65 6e 20 6c 6f 6f 6b 20 6f 6e 6c 79 f then look only
3070: 20 61 74 20 74 68 65 20 74 65 73 74 6e 61 6d 65 at the testname
3080: 20 70 61 72 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 part.;;.(define
3090: 20 28 74 65 73 74 73 3a 6d 61 74 63 68 20 70 61 (tests:match pa
30a0: 74 74 65 72 6e 73 20 74 65 73 74 6e 61 6d 65 20 tterns testname
30b0: 69 74 65 6d 70 61 74 68 20 23 21 6b 65 79 20 28 itempath #!key (
30c0: 72 65 71 75 69 72 65 64 20 27 28 29 29 29 0a 20 required '())).
30d0: 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 70 61 (if (string? pa
30e0: 74 74 65 72 6e 73 29 0a 20 20 20 20 20 20 28 6c tterns). (l
30f0: 65 74 20 28 28 70 61 74 74 73 20 28 61 70 70 65 et ((patts (appe
3100: 6e 64 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 nd (string-split
3110: 20 70 61 74 74 65 72 6e 73 20 22 2c 22 29 20 72 patterns ",") r
3120: 65 71 75 69 72 65 64 29 29 29 0a 09 28 69 66 20 equired)))..(if
3130: 28 6e 75 6c 6c 3f 20 70 61 74 74 73 29 20 3b 3b (null? patts) ;;
3140: 3b 20 6e 6f 20 70 61 74 74 65 72 6e 28 73 29 20 ; no pattern(s)
3150: 6d 65 61 6e 73 20 6e 6f 20 6d 61 74 63 68 0a 09 means no match..
3160: 20 20 20 20 23 66 0a 09 20 20 20 20 28 6c 65 74 #f.. (let
3170: 20 6c 6f 6f 70 20 28 28 70 61 74 74 20 28 63 61 loop ((patt (ca
3180: 72 20 70 61 74 74 73 29 29 0a 09 09 20 20 20 20 r patts))...
3190: 20 20 20 28 74 61 6c 20 20 28 63 64 72 20 70 61 (tal (cdr pa
31a0: 74 74 73 29 29 29 0a 09 20 20 20 20 20 20 3b 3b tts))).. ;;
31b0: 20 28 70 72 69 6e 74 20 22 6c 6f 6f 70 3a 20 70 (print "loop: p
31c0: 61 74 74 3a 20 22 20 70 61 74 74 20 22 2c 20 74 att: " patt ", t
31d0: 61 6c 20 22 20 74 61 6c 29 0a 09 20 20 20 20 20 al " tal)..
31e0: 20 28 69 66 20 28 73 74 72 69 6e 67 3d 3f 20 70 (if (string=? p
31f0: 61 74 74 20 22 22 29 0a 09 09 20 20 23 66 20 3b att "")... #f ;
3200: 3b 20 6e 6f 74 68 69 6e 67 20 65 76 65 72 20 6d ; nothing ever m
3210: 61 74 63 68 65 73 20 65 6d 70 74 79 20 73 74 72 atches empty str
3220: 69 6e 67 20 2d 20 70 6f 6c 69 63 79 0a 09 09 20 ing - policy...
3230: 20 28 6c 65 74 2a 20 28 28 70 61 74 74 2d 70 61 (let* ((patt-pa
3240: 72 74 73 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 rts (string-matc
3250: 68 20 28 72 65 67 65 78 70 20 22 5e 28 5b 5e 5c h (regexp "^([^\
3260: 5c 2f 5d 2a 29 28 5c 5c 2f 28 2e 2a 29 7c 29 24 \/]*)(\\/(.*)|)$
3270: 22 29 20 70 61 74 74 29 29 0a 09 09 09 20 28 74 ") patt)).... (t
3280: 65 73 74 2d 70 61 74 74 20 20 28 63 61 64 72 20 est-patt (cadr
3290: 70 61 74 74 2d 70 61 72 74 73 29 29 0a 09 09 09 patt-parts))....
32a0: 20 28 69 74 65 6d 2d 70 61 74 74 20 20 28 63 61 (item-patt (ca
32b0: 64 64 64 72 20 70 61 74 74 2d 70 61 72 74 73 29 dddr patt-parts)
32c0: 29 29 0a 09 09 20 20 20 20 3b 3b 20 73 70 65 63 ))... ;; spec
32d0: 69 61 6c 20 63 61 73 65 3a 20 74 65 73 74 20 76 ial case: test v
32e0: 73 2e 20 74 65 73 74 2f 0a 09 09 20 20 20 20 3b s. test/... ;
32f0: 3b 20 20 20 74 65 73 74 20 20 3d 3e 20 22 74 65 ; test => "te
3300: 73 74 22 20 22 25 22 0a 09 09 20 20 20 20 3b 3b st" "%"... ;;
3310: 20 20 20 74 65 73 74 2f 20 3d 3e 20 22 74 65 73 test/ => "tes
3320: 74 22 20 22 22 0a 09 09 20 20 20 20 28 69 66 20 t" ""... (if
3330: 28 61 6e 64 20 28 6e 6f 74 20 28 73 75 62 73 74 (and (not (subst
3340: 72 69 6e 67 2d 69 6e 64 65 78 20 22 2f 22 20 70 ring-index "/" p
3350: 61 74 74 29 29 20 3b 3b 20 6e 6f 20 73 6c 61 73 att)) ;; no slas
3360: 68 20 69 6e 20 74 68 65 20 6f 72 69 67 69 6e 61 h in the origina
3370: 6c 0a 09 09 09 20 20 20 20 20 28 6f 72 20 28 6e l.... (or (n
3380: 6f 74 20 69 74 65 6d 2d 70 61 74 74 29 0a 09 09 ot item-patt)...
3390: 09 09 20 28 65 71 75 61 6c 3f 20 69 74 65 6d 2d .. (equal? item-
33a0: 70 61 74 74 20 22 22 29 29 29 20 20 20 20 20 20 patt "")))
33b0: 3b 3b 20 73 68 6f 75 6c 64 20 61 6c 77 61 79 73 ;; should always
33c0: 20 62 65 20 74 72 75 65 20 74 68 61 74 20 69 74 be true that it
33d0: 65 6d 2d 70 61 74 74 20 69 73 20 22 22 0a 09 09 em-patt is ""...
33e0: 09 28 73 65 74 21 20 69 74 65 6d 2d 70 61 74 74 .(set! item-patt
33f0: 20 22 25 22 29 29 0a 09 09 20 20 20 20 3b 3b 20 "%"))... ;;
3400: 28 70 72 69 6e 74 20 22 74 65 73 74 73 3a 6d 61 (print "tests:ma
3410: 74 63 68 20 3d 3e 20 70 61 74 74 2d 70 61 72 74 tch => patt-part
3420: 73 3a 20 22 20 70 61 74 74 2d 70 61 72 74 73 20 s: " patt-parts
3430: 22 2c 20 74 65 73 74 2d 70 61 74 74 3a 20 22 20 ", test-patt: "
3440: 74 65 73 74 2d 70 61 74 74 20 22 2c 20 69 74 65 test-patt ", ite
3450: 6d 2d 70 61 74 74 3a 20 22 20 69 74 65 6d 2d 70 m-patt: " item-p
3460: 61 74 74 29 0a 09 09 20 20 20 20 28 69 66 20 28 att)... (if (
3470: 61 6e 64 20 28 74 65 73 74 73 3a 67 6c 6f 62 2d and (tests:glob-
3480: 6c 69 6b 65 2d 6d 61 74 63 68 20 74 65 73 74 2d like-match test-
3490: 70 61 74 74 20 74 65 73 74 6e 61 6d 65 29 0a 09 patt testname)..
34a0: 09 09 20 20 20 20 20 28 6f 72 20 28 6e 6f 74 20 .. (or (not
34b0: 69 74 65 6d 70 61 74 68 29 0a 09 09 09 09 20 28 itempath)..... (
34c0: 74 65 73 74 73 3a 67 6c 6f 62 2d 6c 69 6b 65 2d tests:glob-like-
34d0: 6d 61 74 63 68 20 28 69 66 20 69 74 65 6d 2d 70 match (if item-p
34e0: 61 74 74 20 69 74 65 6d 2d 70 61 74 74 20 22 22 att item-patt ""
34f0: 29 20 69 74 65 6d 70 61 74 68 29 29 29 0a 09 09 ) itempath)))...
3500: 09 23 74 0a 09 09 09 28 69 66 20 28 6e 75 6c 6c .#t....(if (null
3510: 3f 20 74 61 6c 29 0a 09 09 09 20 20 20 20 23 66 ? tal).... #f
3520: 0a 09 09 09 20 20 20 20 28 6c 6f 6f 70 20 28 63 .... (loop (c
3530: 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 ar tal)(cdr tal)
3540: 29 29 29 29 29 29 29 29 29 29 0a 0a 3b 3b 20 69 ))))))))))..;; i
3550: 66 20 69 74 65 6d 70 61 74 68 20 69 73 20 23 66 f itempath is #f
3560: 20 74 68 65 6e 20 6c 6f 6f 6b 20 6f 6e 6c 79 20 then look only
3570: 61 74 20 74 68 65 20 74 65 73 74 6e 61 6d 65 20 at the testname
3580: 70 61 72 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 part.;;.(define
3590: 28 74 65 73 74 73 3a 6d 61 74 63 68 2d 3e 73 71 (tests:match->sq
35a0: 6c 71 72 79 20 70 61 74 74 65 72 6e 73 29 0a 20 lqry patterns).
35b0: 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 70 61 (if (string? pa
35c0: 74 74 65 72 6e 73 29 0a 20 20 20 20 20 20 28 6c tterns). (l
35d0: 65 74 20 28 28 70 61 74 74 73 20 28 73 74 72 69 et ((patts (stri
35e0: 6e 67 2d 73 70 6c 69 74 20 70 61 74 74 65 72 6e ng-split pattern
35f0: 73 20 22 2c 22 29 29 29 0a 09 28 69 66 20 28 6e s ",")))..(if (n
3600: 75 6c 6c 3f 20 70 61 74 74 73 29 20 3b 3b 3b 20 ull? patts) ;;;
3610: 6e 6f 20 70 61 74 74 65 72 6e 28 73 29 20 6d 65 no pattern(s) me
3620: 61 6e 73 20 6e 6f 20 6d 61 74 63 68 2c 20 77 65 ans no match, we
3630: 20 77 69 6c 6c 20 64 6f 20 6e 6f 20 71 75 65 72 will do no quer
3640: 79 0a 09 20 20 20 20 23 66 0a 09 20 20 20 20 28 y.. #f.. (
3650: 6c 65 74 20 6c 6f 6f 70 20 28 28 70 61 74 74 20 let loop ((patt
3660: 28 63 61 72 20 70 61 74 74 73 29 29 0a 09 09 20 (car patts))...
3670: 20 20 20 20 20 20 28 74 61 6c 20 20 28 63 64 72 (tal (cdr
3680: 20 70 61 74 74 73 29 29 0a 09 09 20 20 20 20 20 patts))...
3690: 20 20 28 72 65 73 20 20 27 28 29 29 29 0a 09 20 (res '()))..
36a0: 20 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 ;; (print "
36b0: 6c 6f 6f 70 3a 20 70 61 74 74 3a 20 22 20 70 61 loop: patt: " pa
36c0: 74 74 20 22 2c 20 74 61 6c 20 22 20 74 61 6c 29 tt ", tal " tal)
36d0: 0a 09 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 .. (let* ((
36e0: 70 61 74 74 2d 70 61 72 74 73 20 28 73 74 72 69 patt-parts (stri
36f0: 6e 67 2d 6d 61 74 63 68 20 28 72 65 67 65 78 70 ng-match (regexp
3700: 20 22 5e 28 5b 5e 5c 5c 2f 5d 2a 29 28 5c 5c 2f "^([^\\/]*)(\\/
3710: 28 2e 2a 29 7c 29 24 22 29 20 70 61 74 74 29 29 (.*)|)$") patt))
3720: 0a 09 09 20 20 20 20 20 28 74 65 73 74 2d 70 61 ... (test-pa
3730: 74 74 20 20 28 63 61 64 72 20 70 61 74 74 2d 70 tt (cadr patt-p
3740: 61 72 74 73 29 29 0a 09 09 20 20 20 20 20 28 69 arts))... (i
3750: 74 65 6d 2d 70 61 74 74 20 20 28 63 61 64 64 64 tem-patt (caddd
3760: 72 20 70 61 74 74 2d 70 61 72 74 73 29 29 0a 09 r patt-parts))..
3770: 09 20 20 20 20 20 28 74 65 73 74 2d 71 72 79 20 . (test-qry
3780: 20 20 28 64 62 3a 70 61 74 74 2d 3e 6c 69 6b 65 (db:patt->like
3790: 20 22 74 65 73 74 6e 61 6d 65 22 20 74 65 73 74 "testname" test
37a0: 2d 70 61 74 74 29 29 0a 09 09 20 20 20 20 20 28 -patt))... (
37b0: 69 74 65 6d 2d 71 72 79 20 20 20 28 64 62 3a 70 item-qry (db:p
37c0: 61 74 74 2d 3e 6c 69 6b 65 20 22 69 74 65 6d 5f att->like "item_
37d0: 70 61 74 68 22 20 69 74 65 6d 2d 70 61 74 74 29 path" item-patt)
37e0: 29 0a 09 09 20 20 20 20 20 28 71 72 79 20 20 20 )... (qry
37f0: 20 20 20 20 20 28 63 6f 6e 63 20 22 28 22 20 74 (conc "(" t
3800: 65 73 74 2d 71 72 79 20 22 20 41 4e 44 20 22 20 est-qry " AND "
3810: 69 74 65 6d 2d 71 72 79 20 22 29 22 29 29 29 0a item-qry ")"))).
3820: 09 09 3b 3b 20 28 70 72 69 6e 74 20 22 74 65 73 ..;; (print "tes
3830: 74 73 3a 6d 61 74 63 68 20 3d 3e 20 70 61 74 74 ts:match => patt
3840: 2d 70 61 72 74 73 3a 20 22 20 70 61 74 74 2d 70 -parts: " patt-p
3850: 61 72 74 73 20 22 2c 20 74 65 73 74 2d 70 61 74 arts ", test-pat
3860: 74 3a 20 22 20 74 65 73 74 2d 70 61 74 74 20 22 t: " test-patt "
3870: 2c 20 69 74 65 6d 2d 70 61 74 74 3a 20 22 20 69 , item-patt: " i
3880: 74 65 6d 2d 70 61 74 74 29 0a 09 09 28 69 66 20 tem-patt)...(if
3890: 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 20 20 (null? tal)...
38a0: 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 (string-inters
38b0: 70 65 72 73 65 20 28 61 70 70 65 6e 64 20 28 72 perse (append (r
38c0: 65 76 65 72 73 65 20 72 65 73 29 28 6c 69 73 74 everse res)(list
38d0: 20 71 72 79 29 29 20 22 20 4f 52 20 22 29 0a 09 qry)) " OR ")..
38e0: 09 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 . (loop (car
38f0: 74 61 6c 29 28 63 64 72 20 74 61 6c 29 28 63 6f tal)(cdr tal)(co
3900: 6e 73 20 71 72 79 20 72 65 73 29 29 29 29 29 29 ns qry res))))))
3910: 29 0a 20 20 20 20 20 20 23 66 29 29 0a 0a 3b 3b ). #f))..;;
3920: 20 43 68 65 63 6b 20 66 6f 72 20 77 61 69 76 65 Check for waive
3930: 72 20 65 6c 69 67 69 62 69 6c 69 74 79 0a 3b 3b r eligibility.;;
3940: 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a .(define (tests:
3950: 63 68 65 63 6b 2d 77 61 69 76 65 72 2d 65 6c 69 check-waiver-eli
3960: 67 69 62 69 6c 69 74 79 20 74 65 73 74 64 61 74 gibility testdat
3970: 20 70 72 65 76 2d 74 65 73 74 64 61 74 29 0a 20 prev-testdat).
3980: 20 28 6c 65 74 2a 20 28 28 74 65 73 74 2d 72 65 (let* ((test-re
3990: 67 69 73 74 72 79 20 28 6d 61 6b 65 2d 68 61 73 gistry (make-has
39a0: 68 2d 74 61 62 6c 65 29 29 0a 09 20 28 74 65 73 h-table)).. (tes
39b0: 74 63 6f 6e 66 69 67 20 20 28 74 65 73 74 73 3a tconfig (tests:
39c0: 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 28 get-testconfig (
39d0: 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 db:test-get-test
39e0: 6e 61 6d 65 20 74 65 73 74 64 61 74 29 20 28 64 name testdat) (d
39f0: 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d b:test-get-item-
3a00: 70 61 74 68 20 74 65 73 74 64 61 74 29 20 74 65 path testdat) te
3a10: 73 74 2d 72 65 67 69 73 74 72 79 20 23 66 29 29 st-registry #f))
3a20: 0a 09 20 28 74 65 73 74 2d 72 75 6e 64 69 72 20 .. (test-rundir
3a30: 3b 3b 20 28 73 64 62 3a 71 72 79 20 27 70 61 73 ;; (sdb:qry 'pas
3a40: 73 73 74 72 20 0a 09 20 20 28 64 62 3a 74 65 73 sstr .. (db:tes
3a50: 74 2d 67 65 74 2d 72 75 6e 64 69 72 20 74 65 73 t-get-rundir tes
3a60: 74 64 61 74 29 29 20 3b 3b 20 29 0a 09 20 28 70 tdat)) ;; ).. (p
3a70: 72 65 76 2d 72 75 6e 64 69 72 20 3b 3b 20 28 73 rev-rundir ;; (s
3a80: 64 62 3a 71 72 79 20 27 70 61 73 73 73 74 72 20 db:qry 'passstr
3a90: 0a 09 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 .. (db:test-get
3aa0: 2d 72 75 6e 64 69 72 20 70 72 65 76 2d 74 65 73 -rundir prev-tes
3ab0: 74 64 61 74 29 29 20 3b 3b 20 29 0a 09 20 28 77 tdat)) ;; ).. (w
3ac0: 61 69 76 65 72 73 20 20 20 20 20 28 69 66 20 74 aivers (if t
3ad0: 65 73 74 63 6f 6e 66 69 67 20 28 63 6f 6e 66 69 estconfig (confi
3ae0: 67 66 3a 73 65 63 74 69 6f 6e 2d 76 61 72 73 20 gf:section-vars
3af0: 74 65 73 74 63 6f 6e 66 69 67 20 22 77 61 69 76 testconfig "waiv
3b00: 65 72 73 22 29 20 27 28 29 29 29 0a 09 20 28 77 ers") '())).. (w
3b10: 61 69 76 65 72 2d 72 78 20 20 20 28 72 65 67 65 aiver-rx (rege
3b20: 78 70 20 22 5e 28 5c 5c 53 2b 29 5c 5c 73 2b 28 xp "^(\\S+)\\s+(
3b30: 2e 2a 29 24 22 29 29 0a 09 20 28 64 69 66 66 2d .*)$")).. (diff-
3b40: 72 75 6c 65 20 20 20 22 64 69 66 66 20 25 66 69 rule "diff %fi
3b50: 6c 65 31 25 20 25 66 69 6c 65 32 25 22 29 0a 09 le1% %file2%")..
3b60: 20 28 6c 6f 67 70 72 6f 2d 72 75 6c 65 20 22 64 (logpro-rule "d
3b70: 69 66 66 20 25 66 69 6c 65 31 25 20 25 66 69 6c iff %file1% %fil
3b80: 65 32 25 20 7c 20 6c 6f 67 70 72 6f 20 25 77 61 e2% | logpro %wa
3b90: 69 76 65 72 6e 61 6d 65 25 2e 6c 6f 67 70 72 6f ivername%.logpro
3ba0: 20 25 77 61 69 76 65 72 6e 61 6d 65 25 2e 68 74 %waivername%.ht
3bb0: 6d 6c 22 29 29 0a 20 20 20 20 28 69 66 20 28 6e ml")). (if (n
3bc0: 6f 74 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d ot (common:file-
3bd0: 65 78 69 73 74 73 3f 20 74 65 73 74 2d 72 75 6e exists? test-run
3be0: 64 69 72 29 29 0a 09 28 62 65 67 69 6e 0a 09 20 dir))..(begin..
3bf0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 (debug:print-er
3c00: 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c ror 0 *default-l
3c10: 6f 67 2d 70 6f 72 74 2a 20 22 74 65 73 74 20 72 og-port* "test r
3c20: 75 6e 20 64 69 72 65 63 74 6f 72 79 20 69 73 20 un directory is
3c30: 67 6f 6e 65 2c 20 63 61 6e 6e 6f 74 20 70 72 6f gone, cannot pro
3c40: 70 61 67 61 74 65 20 77 61 69 76 65 72 22 29 0a pagate waiver").
3c50: 09 20 20 23 66 29 0a 09 28 62 65 67 69 6e 0a 09 . #f)..(begin..
3c60: 20 20 28 70 75 73 68 2d 64 69 72 65 63 74 6f 72 (push-director
3c70: 79 20 74 65 73 74 2d 72 75 6e 64 69 72 29 0a 09 y test-rundir)..
3c80: 20 20 28 6c 65 74 20 28 28 72 65 73 75 6c 74 20 (let ((result
3c90: 28 69 66 20 28 6e 75 6c 6c 3f 20 77 61 69 76 65 (if (null? waive
3ca0: 72 73 29 0a 09 09 09 20 20 20 20 23 66 0a 09 09 rs).... #f...
3cb0: 09 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 . (let loop (
3cc0: 28 68 65 64 20 28 63 61 72 20 77 61 69 76 65 72 (hed (car waiver
3cd0: 73 29 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 s))..... (
3ce0: 74 61 6c 20 28 63 64 72 20 77 61 69 76 65 72 73 tal (cdr waivers
3cf0: 29 29 29 0a 09 09 09 20 20 20 20 20 20 28 64 65 ))).... (de
3d00: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
3d10: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
3d20: 49 4e 46 4f 3a 20 41 70 70 6c 79 69 6e 67 20 77 INFO: Applying w
3d30: 61 69 76 65 72 20 72 75 6c 65 20 5c 22 22 20 68 aiver rule \"" h
3d40: 65 64 20 22 5c 22 22 29 0a 09 09 09 20 20 20 20 ed "\"")....
3d50: 20 20 28 6c 65 74 2a 20 28 28 77 61 69 76 65 72 (let* ((waiver
3d60: 20 20 20 20 20 20 28 63 6f 6e 66 69 67 66 3a 6c (configf:l
3d70: 6f 6f 6b 75 70 20 74 65 73 74 63 6f 6e 66 69 67 ookup testconfig
3d80: 20 22 77 61 69 76 65 72 73 22 20 68 65 64 29 29 "waivers" hed))
3d90: 0a 09 09 09 09 20 20 20 20 20 28 77 70 61 72 74 ..... (wpart
3da0: 73 20 20 20 20 20 20 28 69 66 20 77 61 69 76 65 s (if waive
3db0: 72 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 r (string-match
3dc0: 77 61 69 76 65 72 2d 72 78 20 77 61 69 76 65 72 waiver-rx waiver
3dd0: 29 20 23 66 29 29 0a 09 09 09 09 20 20 20 20 20 ) #f)).....
3de0: 28 77 61 69 76 65 72 2d 72 75 6c 65 20 28 69 66 (waiver-rule (if
3df0: 20 77 70 61 72 74 73 20 28 63 61 64 72 20 77 70 wparts (cadr wp
3e00: 61 72 74 73 29 20 20 23 66 29 29 0a 09 09 09 09 arts) #f)).....
3e10: 20 20 20 20 20 28 77 61 69 76 65 72 2d 67 6c 6f (waiver-glo
3e20: 62 20 28 69 66 20 77 70 61 72 74 73 20 28 63 61 b (if wparts (ca
3e30: 64 64 72 20 77 70 61 72 74 73 29 20 23 66 29 29 ddr wparts) #f))
3e40: 0a 09 09 09 09 20 20 20 20 20 28 6c 6f 67 70 72 ..... (logpr
3e50: 6f 2d 66 69 6c 65 20 28 69 66 20 77 61 69 76 65 o-file (if waive
3e60: 72 0a 09 09 09 09 09 09 20 20 20 20 20 20 28 6c r....... (l
3e70: 65 74 20 28 28 66 6e 61 6d 65 20 28 63 6f 6e 63 et ((fname (conc
3e80: 20 68 65 64 20 22 2e 6c 6f 67 70 72 6f 22 29 29 hed ".logpro"))
3e90: 29 0a 09 09 09 09 09 09 09 28 69 66 20 28 63 6f )........(if (co
3ea0: 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 mmon:file-exists
3eb0: 3f 20 66 6e 61 6d 65 29 0a 09 09 09 09 09 09 09 ? fname)........
3ec0: 20 20 20 20 66 6e 61 6d 65 20 0a 09 09 09 09 09 fname ......
3ed0: 09 09 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 .. (begin....
3ee0: 09 09 09 09 20 20 20 20 20 20 28 64 65 62 75 67 .... (debug
3ef0: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
3f00: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 4e 46 t-log-port* "INF
3f10: 4f 3a 20 4e 6f 20 6c 6f 67 70 72 6f 20 66 69 6c O: No logpro fil
3f20: 65 20 22 20 66 6e 61 6d 65 20 22 20 66 61 6c 6c e " fname " fall
3f30: 69 6e 67 20 62 61 63 6b 20 74 6f 20 64 69 66 66 ing back to diff
3f40: 22 29 0a 09 09 09 09 09 09 09 20 20 20 20 20 20 ")........
3f50: 23 66 29 29 29 0a 09 09 09 09 09 09 20 20 20 20 #f))).......
3f60: 20 20 23 66 29 29 0a 09 09 09 09 20 20 20 20 20 #f)).....
3f70: 3b 3b 20 69 66 20 72 75 6c 65 20 62 79 20 6e 61 ;; if rule by na
3f80: 6d 65 20 6f 66 20 77 61 69 76 65 72 2d 72 75 6c me of waiver-rul
3f90: 65 20 69 73 20 66 6f 75 6e 64 20 69 6e 20 74 65 e is found in te
3fa0: 73 74 63 6f 6e 66 69 67 20 2d 20 75 73 65 20 69 stconfig - use i
3fb0: 74 0a 09 09 09 09 20 20 20 20 20 3b 3b 20 65 6c t..... ;; el
3fc0: 73 65 20 69 66 20 77 61 69 76 65 72 6e 61 6d 65 se if waivername
3fd0: 2e 6c 6f 67 70 72 6f 20 65 78 69 73 74 73 20 75 .logpro exists u
3fe0: 73 65 20 6c 6f 67 70 72 6f 2d 72 75 6c 65 0a 09 se logpro-rule..
3ff0: 09 09 09 20 20 20 20 20 3b 3b 20 65 6c 73 65 20 ... ;; else
4000: 64 65 66 61 75 6c 74 20 74 6f 20 64 69 66 66 2d default to diff-
4010: 72 75 6c 65 0a 09 09 09 09 20 20 20 20 20 28 72 rule..... (r
4020: 75 6c 65 2d 73 74 72 69 6e 67 20 28 6c 65 74 20 ule-string (let
4030: 28 28 72 75 6c 65 20 28 63 6f 6e 66 69 67 66 3a ((rule (configf:
4040: 6c 6f 6f 6b 75 70 20 74 65 73 74 63 6f 6e 66 69 lookup testconfi
4050: 67 20 22 77 61 69 76 65 72 5f 72 75 6c 65 73 22 g "waiver_rules"
4060: 20 77 61 69 76 65 72 2d 72 75 6c 65 29 29 29 0a waiver-rule))).
4070: 09 09 09 09 09 09 20 20 20 20 28 69 66 20 72 75 ...... (if ru
4080: 6c 65 0a 09 09 09 09 09 09 09 72 75 6c 65 0a 09 le........rule..
4090: 09 09 09 09 09 09 28 69 66 20 6c 6f 67 70 72 6f ......(if logpro
40a0: 2d 66 69 6c 65 0a 09 09 09 09 09 09 09 20 20 20 -file........
40b0: 20 6c 6f 67 70 72 6f 2d 72 75 6c 65 0a 09 09 09 logpro-rule....
40c0: 09 09 09 09 20 20 20 20 28 62 65 67 69 6e 0a 09 .... (begin..
40d0: 09 09 09 09 09 09 20 20 20 20 20 20 28 64 65 62 ...... (deb
40e0: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
40f0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 ult-log-port* "I
4100: 4e 46 4f 3a 20 4e 6f 20 6c 6f 67 70 72 6f 20 66 NFO: No logpro f
4110: 69 6c 65 20 22 20 6c 6f 67 70 72 6f 2d 66 69 6c ile " logpro-fil
4120: 65 20 22 20 66 6f 75 6e 64 2c 20 75 73 69 6e 67 e " found, using
4130: 20 64 69 66 66 20 72 75 6c 65 22 29 0a 09 09 09 diff rule")....
4140: 09 09 09 09 20 20 20 20 20 20 64 69 66 66 2d 72 .... diff-r
4150: 75 6c 65 29 29 29 29 29 0a 09 09 09 09 20 20 20 ule))))).....
4160: 20 20 3b 3b 20 28 73 74 72 69 6e 67 2d 73 75 62 ;; (string-sub
4170: 73 74 69 74 75 74 65 20 22 25 66 69 6c 65 31 25 stitute "%file1%
4180: 22 20 22 66 6f 6f 66 6f 6f 2e 74 78 74 22 20 22 " "foofoo.txt" "
4190: 54 68 69 73 20 69 73 20 25 66 69 6c 65 31 25 20 This is %file1%
41a0: 61 6e 64 20 73 6f 20 69 73 20 74 68 69 73 20 25 and so is this %
41b0: 66 69 6c 65 31 25 2e 22 20 23 74 29 0a 09 09 09 file1%." #t)....
41c0: 09 20 20 20 20 20 28 70 72 6f 63 65 73 73 65 64 . (processed
41d0: 2d 63 6d 64 20 28 73 74 72 69 6e 67 2d 73 75 62 -cmd (string-sub
41e0: 73 74 69 74 75 74 65 20 0a 09 09 09 09 09 09 20 stitute .......
41f0: 20 20 20 20 22 25 66 69 6c 65 31 25 22 20 28 63 "%file1%" (c
4200: 6f 6e 63 20 74 65 73 74 2d 72 75 6e 64 69 72 20 onc test-rundir
4210: 22 2f 22 20 77 61 69 76 65 72 2d 67 6c 6f 62 29 "/" waiver-glob)
4220: 0a 09 09 09 09 09 09 20 20 20 20 20 28 73 74 72 ....... (str
4230: 69 6e 67 2d 73 75 62 73 74 69 74 75 74 65 0a 09 ing-substitute..
4240: 09 09 09 09 09 20 20 20 20 20 20 22 25 66 69 6c ..... "%fil
4250: 65 32 25 22 20 28 63 6f 6e 63 20 70 72 65 76 2d e2%" (conc prev-
4260: 72 75 6e 64 69 72 20 22 2f 22 20 77 61 69 76 65 rundir "/" waive
4270: 72 2d 67 6c 6f 62 29 0a 09 09 09 09 09 09 20 20 r-glob).......
4280: 20 20 20 20 28 73 74 72 69 6e 67 2d 73 75 62 73 (string-subs
4290: 74 69 74 75 74 65 0a 09 09 09 09 09 09 20 20 20 titute.......
42a0: 20 20 20 20 22 25 77 61 69 76 65 72 6e 61 6d 65 "%waivername
42b0: 25 22 20 68 65 64 20 72 75 6c 65 2d 73 74 72 69 %" hed rule-stri
42c0: 6e 67 20 23 74 29 20 23 74 29 20 23 74 29 29 0a ng #t) #t) #t)).
42d0: 09 09 09 09 20 20 20 20 20 28 72 65 73 20 20 20 .... (res
42e0: 20 20 20 20 20 20 20 20 20 23 66 29 29 0a 09 09 #f))...
42f0: 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 ..(debug:print 0
4300: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
4310: 72 74 2a 20 22 49 4e 46 4f 3a 20 77 61 69 76 65 rt* "INFO: waive
4320: 72 20 63 6f 6d 6d 61 6e 64 20 69 73 20 5c 22 22 r command is \""
4330: 20 70 72 6f 63 65 73 73 65 64 2d 63 6d 64 20 22 processed-cmd "
4340: 5c 22 22 29 0a 09 09 09 09 28 69 66 20 28 65 71 \"").....(if (eq
4350: 3f 20 28 73 79 73 74 65 6d 20 70 72 6f 63 65 73 ? (system proces
4360: 73 65 64 2d 63 6d 64 29 20 30 29 0a 09 09 09 09 sed-cmd) 0).....
4370: 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 (if (null? t
4380: 61 6c 29 0a 09 09 09 09 09 23 74 0a 09 09 09 09 al)......#t.....
4390: 09 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 .(loop (car tal)
43a0: 28 63 64 72 20 74 61 6c 29 29 29 0a 09 09 09 09 (cdr tal))).....
43b0: 20 20 20 20 23 66 29 29 29 29 29 29 0a 09 20 20 #f))))))..
43c0: 20 20 28 70 6f 70 2d 64 69 72 65 63 74 6f 72 79 (pop-directory
43d0: 29 0a 09 20 20 20 20 72 65 73 75 6c 74 29 29 29 ).. result)))
43e0: 29 29 0a 0a 3b 3b 20 44 6f 20 6e 6f 74 20 72 70 ))..;; Do not rp
43f0: 63 20 74 68 69 73 20 6f 6e 65 2c 20 64 6f 20 74 c this one, do t
4400: 68 65 20 75 6e 64 65 72 6c 79 69 6e 67 20 63 61 he underlying ca
4410: 6c 6c 73 21 21 21 0a 28 64 65 66 69 6e 65 20 28 lls!!!.(define (
4420: 74 65 73 74 73 3a 74 65 73 74 2d 73 65 74 2d 73 tests:test-set-s
4430: 74 61 74 75 73 21 20 72 75 6e 2d 69 64 20 74 65 tatus! run-id te
4440: 73 74 2d 69 64 20 73 74 61 74 65 20 73 74 61 74 st-id state stat
4450: 75 73 20 63 6f 6d 6d 65 6e 74 20 64 61 74 20 23 us comment dat #
4460: 21 6b 65 79 20 28 77 6f 72 6b 2d 61 72 65 61 20 !key (work-area
4470: 23 66 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 72 #f)). (let* ((r
4480: 65 61 6c 2d 73 74 61 74 75 73 20 73 74 61 74 75 eal-status statu
4490: 73 29 0a 09 20 28 6f 74 68 65 72 64 61 74 20 20 s).. (otherdat
44a0: 20 20 28 69 66 20 64 61 74 20 64 61 74 20 28 6d (if dat dat (m
44b0: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
44c0: 29 0a 09 20 28 74 65 73 74 64 61 74 20 20 20 20 ).. (testdat
44d0: 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 (rmt:get-test-i
44e0: 6e 66 6f 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 nfo-by-id run-id
44f0: 20 74 65 73 74 2d 69 64 29 29 0a 09 20 28 74 65 test-id)).. (te
4500: 73 74 2d 6e 61 6d 65 20 20 20 28 64 62 3a 74 65 st-name (db:te
4510: 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 st-get-testname
4520: 20 74 65 73 74 64 61 74 29 29 0a 09 20 28 69 74 testdat)).. (it
4530: 65 6d 2d 70 61 74 68 20 20 20 28 64 62 3a 74 65 em-path (db:te
4540: 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 st-get-item-path
4550: 20 74 65 73 74 64 61 74 29 29 0a 09 20 3b 3b 20 testdat)).. ;;
4560: 62 65 66 6f 72 65 20 70 72 6f 63 65 65 64 69 6e before proceedin
4570: 67 20 77 65 20 6d 75 73 74 20 66 69 6e 64 20 6f g we must find o
4580: 75 74 20 69 66 20 74 68 65 20 70 72 65 76 69 6f ut if the previo
4590: 75 73 20 74 65 73 74 20 28 77 68 65 72 65 20 61 us test (where a
45a0: 6c 6c 20 6b 65 79 73 20 6d 61 74 63 68 65 64 20 ll keys matched
45b0: 65 78 63 65 70 74 20 72 75 6e 6e 61 6d 65 29 0a except runname).
45c0: 09 20 3b 3b 20 77 61 73 20 57 41 49 56 45 44 20 . ;; was WAIVED
45d0: 69 66 20 74 68 69 73 20 74 65 73 74 20 69 73 20 if this test is
45e0: 46 41 49 4c 0a 0a 09 20 3b 3b 20 4e 4f 54 45 53 FAIL... ;; NOTES
45f0: 3a 0a 09 20 3b 3b 20 20 31 2e 20 49 73 20 74 68 :.. ;; 1. Is th
4600: 65 20 63 61 6c 6c 20 74 6f 20 74 65 73 74 3a 67 e call to test:g
4610: 65 74 2d 70 72 65 76 69 6f 75 73 2d 72 75 6e 2d et-previous-run-
4620: 72 65 63 6f 72 64 20 72 65 6d 6f 74 69 66 69 65 record remotifie
4630: 64 3f 0a 09 20 3b 3b 20 20 32 2e 20 41 64 64 20 d?.. ;; 2. Add
4640: 74 65 73 74 20 66 6f 72 20 74 65 73 74 63 6f 6e test for testcon
4650: 66 69 67 20 77 61 69 76 65 72 20 70 72 6f 70 61 fig waiver propa
4660: 67 61 74 69 6f 6e 20 63 6f 6e 74 72 6f 6c 20 68 gation control h
4670: 65 72 65 0a 09 20 3b 3b 0a 09 20 28 70 72 65 76 ere.. ;;.. (prev
4680: 2d 74 65 73 74 20 20 20 28 69 66 20 28 65 71 75 -test (if (equ
4690: 61 6c 3f 20 73 74 61 74 75 73 20 22 46 41 49 4c al? status "FAIL
46a0: 22 29 0a 09 09 09 20 20 28 72 6d 74 3a 67 65 74 ").... (rmt:get
46b0: 2d 70 72 65 76 69 6f 75 73 2d 74 65 73 74 2d 72 -previous-test-r
46c0: 75 6e 2d 72 65 63 6f 72 64 20 72 75 6e 2d 69 64 un-record run-id
46d0: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item-
46e0: 70 61 74 68 29 0a 09 09 09 20 20 23 66 29 29 0a path).... #f)).
46f0: 09 20 28 77 61 69 76 65 64 20 20 20 28 69 66 20 . (waived (if
4700: 70 72 65 76 2d 74 65 73 74 0a 09 09 20 20 20 20 prev-test...
4710: 20 20 20 28 69 66 20 70 72 65 76 2d 74 65 73 74 (if prev-test
4720: 20 3b 3b 20 74 72 75 65 20 69 66 20 77 65 20 66 ;; true if we f
4730: 6f 75 6e 64 20 61 20 70 72 65 76 69 6f 75 73 20 ound a previous
4740: 74 65 73 74 20 69 6e 20 74 68 69 73 20 72 75 6e test in this run
4750: 20 73 65 72 69 65 73 0a 09 09 09 20 20 20 28 6c series.... (l
4760: 65 74 20 28 28 70 72 65 76 2d 73 74 61 74 75 73 et ((prev-status
4770: 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 (db:test-get-s
4780: 74 61 74 75 73 20 20 70 72 65 76 2d 74 65 73 74 tatus prev-test
4790: 29 29 0a 09 09 09 09 20 28 70 72 65 76 2d 73 74 ))..... (prev-st
47a0: 61 74 65 20 20 20 28 64 62 3a 74 65 73 74 2d 67 ate (db:test-g
47b0: 65 74 2d 73 74 61 74 65 20 20 20 70 72 65 76 2d et-state prev-
47c0: 74 65 73 74 29 29 0a 09 09 09 09 20 28 70 72 65 test))..... (pre
47d0: 76 2d 63 6f 6d 6d 65 6e 74 20 28 64 62 3a 74 65 v-comment (db:te
47e0: 73 74 2d 67 65 74 2d 63 6f 6d 6d 65 6e 74 20 70 st-get-comment p
47f0: 72 65 76 2d 74 65 73 74 29 29 29 0a 09 09 09 20 rev-test)))....
4800: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
4810: 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 4 *default-log-
4820: 70 6f 72 74 2a 20 22 70 72 65 76 2d 73 74 61 74 port* "prev-stat
4830: 75 73 20 22 20 70 72 65 76 2d 73 74 61 74 75 73 us " prev-status
4840: 20 22 2c 20 70 72 65 76 2d 73 74 61 74 65 20 22 ", prev-state "
4850: 20 70 72 65 76 2d 73 74 61 74 65 20 22 2c 20 70 prev-state ", p
4860: 72 65 76 2d 63 6f 6d 6d 65 6e 74 20 22 20 70 72 rev-comment " pr
4870: 65 76 2d 63 6f 6d 6d 65 6e 74 29 0a 09 09 09 20 ev-comment)....
4880: 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 65 71 (if (and (eq
4890: 75 61 6c 3f 20 70 72 65 76 2d 73 74 61 74 65 20 ual? prev-state
48a0: 20 22 43 4f 4d 50 4c 45 54 45 44 22 29 0a 09 09 "COMPLETED")...
48b0: 09 09 20 20 20 20 20 20 28 65 71 75 61 6c 3f 20 .. (equal?
48c0: 70 72 65 76 2d 73 74 61 74 75 73 20 22 57 41 49 prev-status "WAI
48d0: 56 45 44 22 29 29 0a 09 09 09 09 20 28 69 66 20 VED"))..... (if
48e0: 63 6f 6d 6d 65 6e 74 0a 09 09 09 09 20 20 20 20 comment.....
48f0: 20 63 6f 6d 6d 65 6e 74 0a 09 09 09 09 20 20 20 comment.....
4900: 20 20 70 72 65 76 2d 63 6f 6d 6d 65 6e 74 29 20 prev-comment)
4910: 3b 3b 20 77 61 69 76 65 64 20 69 73 20 65 69 74 ;; waived is eit
4920: 68 65 72 20 74 68 65 20 63 6f 6d 6d 65 6e 74 20 her the comment
4930: 6f 72 20 23 66 0a 09 09 09 09 20 23 66 29 29 0a or #f..... #f)).
4940: 09 09 09 20 20 20 23 66 29 0a 09 09 20 20 20 20 ... #f)...
4950: 20 20 20 23 66 29 29 29 0a 20 20 20 20 28 69 66 #f))). (if
4960: 20 28 61 6e 64 20 77 61 69 76 65 64 20 0a 09 20 (and waived ..
4970: 20 20 20 20 28 74 65 73 74 73 3a 63 68 65 63 6b (tests:check
4980: 2d 77 61 69 76 65 72 2d 65 6c 69 67 69 62 69 6c -waiver-eligibil
4990: 69 74 79 20 74 65 73 74 64 61 74 20 70 72 65 76 ity testdat prev
49a0: 2d 74 65 73 74 29 29 0a 09 28 73 65 74 21 20 72 -test))..(set! r
49b0: 65 61 6c 2d 73 74 61 74 75 73 20 22 57 41 49 56 eal-status "WAIV
49c0: 45 44 22 29 29 0a 0a 20 20 20 20 28 64 65 62 75 ED")).. (debu
49d0: 67 3a 70 72 69 6e 74 20 34 20 2a 64 65 66 61 75 g:print 4 *defau
49e0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 65 lt-log-port* "re
49f0: 61 6c 2d 73 74 61 74 75 73 20 22 20 72 65 61 6c al-status " real
4a00: 2d 73 74 61 74 75 73 20 22 2c 20 77 61 69 76 65 -status ", waive
4a10: 64 20 22 20 77 61 69 76 65 64 20 22 2c 20 73 74 d " waived ", st
4a20: 61 74 75 73 20 22 20 73 74 61 74 75 73 29 0a 0a atus " status)..
4a30: 20 20 20 20 3b 3b 20 75 70 64 61 74 65 20 74 68 ;; update th
4a40: 65 20 70 72 69 6d 61 72 79 20 72 65 63 6f 72 64 e primary record
4a50: 20 49 46 20 73 74 61 74 65 20 41 4e 44 20 73 74 IF state AND st
4a60: 61 74 75 73 20 61 72 65 20 64 65 66 69 6e 65 64 atus are defined
4a70: 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 73 74 . (if (and st
4a80: 61 74 65 20 73 74 61 74 75 73 29 0a 09 28 62 65 ate status)..(be
4a90: 67 69 6e 0a 09 20 20 28 72 6d 74 3a 73 65 74 2d gin.. (rmt:set-
4aa0: 73 74 61 74 65 2d 73 74 61 74 75 73 2d 61 6e 64 state-status-and
4ab0: 2d 72 6f 6c 6c 2d 75 70 2d 69 74 65 6d 73 20 72 -roll-up-items r
4ac0: 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 69 74 un-id test-id it
4ad0: 65 6d 2d 70 61 74 68 20 73 74 61 74 65 20 72 65 em-path state re
4ae0: 61 6c 2d 73 74 61 74 75 73 20 28 69 66 20 77 61 al-status (if wa
4af0: 69 76 65 64 20 77 61 69 76 65 64 20 63 6f 6d 6d ived waived comm
4b00: 65 6e 74 29 29 0a 09 20 20 3b 3b 20 28 6d 74 3a ent)).. ;; (mt:
4b10: 70 72 6f 63 65 73 73 2d 74 72 69 67 67 65 72 73 process-triggers
4b20: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 run-id test-id
4b30: 73 74 61 74 65 20 72 65 61 6c 2d 73 74 61 74 75 state real-statu
4b40: 73 29 20 3b 3b 20 74 72 69 67 67 65 72 73 20 61 s) ;; triggers a
4b50: 72 65 20 63 61 6c 6c 65 64 20 69 6e 20 74 65 73 re called in tes
4b60: 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 t-set-state-stat
4b70: 75 73 0a 09 20 20 29 29 0a 20 20 20 20 0a 20 20 us.. )). .
4b80: 20 20 3b 3b 20 69 66 20 73 74 61 74 75 73 20 69 ;; if status i
4b90: 73 20 22 41 55 54 4f 22 20 74 68 65 6e 20 63 61 s "AUTO" then ca
4ba0: 6c 6c 20 72 6f 6c 6c 75 70 20 28 6e 6f 74 65 2c ll rollup (note,
4bb0: 20 74 68 69 73 20 6f 6e 65 20 6d 6f 64 69 66 69 this one modifi
4bc0: 65 73 20 64 61 74 61 20 69 6e 20 74 65 73 74 0a es data in test.
4bd0: 20 20 20 20 3b 3b 20 72 75 6e 20 61 72 65 61 2c ;; run area,
4be0: 20 69 74 20 64 6f 65 73 20 72 65 6d 6f 74 65 20 it does remote
4bf0: 63 61 6c 6c 73 20 75 6e 64 65 72 20 74 68 65 20 calls under the
4c00: 68 6f 6f 64 2e 0a 20 20 20 20 3b 3b 20 28 69 66 hood.. ;; (if
4c10: 20 28 61 6e 64 20 74 65 73 74 2d 69 64 20 73 74 (and test-id st
4c20: 61 74 65 20 73 74 61 74 75 73 20 28 65 71 75 61 ate status (equa
4c30: 6c 3f 20 73 74 61 74 75 73 20 22 41 55 54 4f 22 l? status "AUTO"
4c40: 29 29 20 0a 20 20 20 20 3b 3b 20 09 28 72 6d 74 )) . ;; .(rmt
4c50: 3a 74 65 73 74 2d 64 61 74 61 2d 72 6f 6c 6c 75 :test-data-rollu
4c60: 70 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 p run-id test-id
4c70: 20 73 74 61 74 75 73 29 29 0a 0a 20 20 20 20 3b status)).. ;
4c80: 3b 20 61 64 64 20 6d 65 74 61 64 61 74 61 20 28 ; add metadata (
4c90: 6e 65 65 64 20 74 6f 20 64 6f 20 74 68 69 73 20 need to do this
4ca0: 77 61 79 20 74 6f 20 61 76 6f 69 64 20 53 51 4c way to avoid SQL
4cb0: 20 69 6e 6a 65 63 74 69 6f 6e 20 69 73 73 75 65 injection issue
4cc0: 73 29 0a 0a 20 20 20 20 3b 3b 20 3a 66 69 72 73 s).. ;; :firs
4cd0: 74 5f 65 72 72 0a 20 20 20 20 3b 3b 20 28 6c 65 t_err. ;; (le
4ce0: 74 20 28 28 76 61 6c 20 28 68 61 73 68 2d 74 61 t ((val (hash-ta
4cf0: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
4d00: 6f 74 68 65 72 64 61 74 20 22 3a 66 69 72 73 74 otherdat ":first
4d10: 5f 65 72 72 22 20 23 66 29 29 29 0a 20 20 20 20 _err" #f))).
4d20: 3b 3b 20 20 20 28 69 66 20 76 61 6c 0a 20 20 20 ;; (if val.
4d30: 20 3b 3b 20 20 20 20 20 20 20 28 73 71 6c 69 74 ;; (sqlit
4d40: 65 33 3a 65 78 65 63 75 74 65 20 64 62 20 22 55 e3:execute db "U
4d50: 50 44 41 54 45 20 74 65 73 74 73 20 53 45 54 20 PDATE tests SET
4d60: 66 69 72 73 74 5f 65 72 72 3d 3f 20 57 48 45 52 first_err=? WHER
4d70: 45 20 72 75 6e 5f 69 64 3d 3f 20 41 4e 44 20 74 E run_id=? AND t
4d80: 65 73 74 6e 61 6d 65 3d 3f 20 41 4e 44 20 69 74 estname=? AND it
4d90: 65 6d 5f 70 61 74 68 3d 3f 3b 22 20 76 61 6c 20 em_path=?;" val
4da0: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
4db0: 20 69 74 65 6d 2d 70 61 74 68 29 29 29 0a 20 20 item-path))).
4dc0: 20 20 3b 3b 20 0a 20 20 20 20 3b 3b 20 3b 3b 20 ;; . ;; ;;
4dd0: 3a 66 69 72 73 74 5f 77 61 72 6e 0a 20 20 20 20 :first_warn.
4de0: 3b 3b 20 28 6c 65 74 20 28 28 76 61 6c 20 28 68 ;; (let ((val (h
4df0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
4e00: 66 61 75 6c 74 20 6f 74 68 65 72 64 61 74 20 22 fault otherdat "
4e10: 3a 66 69 72 73 74 5f 77 61 72 6e 22 20 23 66 29 :first_warn" #f)
4e20: 29 29 0a 20 20 20 20 3b 3b 20 20 20 28 69 66 20 )). ;; (if
4e30: 76 61 6c 0a 20 20 20 20 3b 3b 20 20 20 20 20 20 val. ;;
4e40: 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 (sqlite3:execut
4e50: 65 20 64 62 20 22 55 50 44 41 54 45 20 74 65 73 e db "UPDATE tes
4e60: 74 73 20 53 45 54 20 66 69 72 73 74 5f 77 61 72 ts SET first_war
4e70: 6e 3d 3f 20 57 48 45 52 45 20 72 75 6e 5f 69 64 n=? WHERE run_id
4e80: 3d 3f 20 41 4e 44 20 74 65 73 74 6e 61 6d 65 3d =? AND testname=
4e90: 3f 20 41 4e 44 20 69 74 65 6d 5f 70 61 74 68 3d ? AND item_path=
4ea0: 3f 3b 22 20 76 61 6c 20 72 75 6e 2d 69 64 20 74 ?;" val run-id t
4eb0: 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 est-name item-pa
4ec0: 74 68 29 29 29 0a 0a 20 20 20 20 28 6c 65 74 20 th))).. (let
4ed0: 28 28 63 61 74 65 67 6f 72 79 20 28 68 61 73 68 ((category (hash
4ee0: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
4ef0: 6c 74 20 6f 74 68 65 72 64 61 74 20 22 3a 63 61 lt otherdat ":ca
4f00: 74 65 67 6f 72 79 22 20 22 22 29 29 0a 09 20 20 tegory" ""))..
4f10: 28 76 61 72 69 61 62 6c 65 20 28 68 61 73 68 2d (variable (hash-
4f20: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
4f30: 74 20 6f 74 68 65 72 64 61 74 20 22 3a 76 61 72 t otherdat ":var
4f40: 69 61 62 6c 65 22 20 22 22 29 29 0a 09 20 20 28 iable" "")).. (
4f50: 76 61 6c 75 65 20 20 20 20 28 68 61 73 68 2d 74 value (hash-t
4f60: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
4f70: 20 6f 74 68 65 72 64 61 74 20 22 3a 76 61 6c 75 otherdat ":valu
4f80: 65 22 20 20 20 20 23 66 29 29 0a 09 20 20 28 65 e" #f)).. (e
4f90: 78 70 65 63 74 65 64 20 28 68 61 73 68 2d 74 61 xpected (hash-ta
4fa0: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
4fb0: 6f 74 68 65 72 64 61 74 20 22 3a 65 78 70 65 63 otherdat ":expec
4fc0: 74 65 64 22 20 22 6e 2f 61 22 29 29 0a 09 20 20 ted" "n/a"))..
4fd0: 28 74 6f 6c 20 20 20 20 20 20 28 68 61 73 68 2d (tol (hash-
4fe0: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
4ff0: 74 20 6f 74 68 65 72 64 61 74 20 22 3a 74 6f 6c t otherdat ":tol
5000: 22 20 20 20 20 20 20 22 6e 2f 61 22 29 29 0a 09 " "n/a"))..
5010: 20 20 28 75 6e 69 74 73 20 20 20 20 28 68 61 73 (units (has
5020: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
5030: 75 6c 74 20 6f 74 68 65 72 64 61 74 20 22 3a 75 ult otherdat ":u
5040: 6e 69 74 73 22 20 20 20 20 22 22 29 29 0a 09 20 nits" ""))..
5050: 20 28 74 79 70 65 20 20 20 20 20 28 68 61 73 68 (type (hash
5060: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
5070: 6c 74 20 6f 74 68 65 72 64 61 74 20 22 3a 74 79 lt otherdat ":ty
5080: 70 65 22 20 20 20 20 20 22 22 29 29 0a 09 20 20 pe" ""))..
5090: 28 64 63 6f 6d 6d 65 6e 74 20 28 68 61 73 68 2d (dcomment (hash-
50a0: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
50b0: 74 20 6f 74 68 65 72 64 61 74 20 22 3a 63 6f 6d t otherdat ":com
50c0: 6d 65 6e 74 22 20 20 22 22 29 29 29 0a 20 20 20 ment" ""))).
50d0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
50e0: 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 4 *default-log-p
50f0: 6f 72 74 2a 20 0a 09 09 20 20 20 22 63 61 74 65 ort* ... "cate
5100: 67 6f 72 79 3a 20 22 20 63 61 74 65 67 6f 72 79 gory: " category
5110: 20 22 2c 20 76 61 72 69 61 62 6c 65 3a 20 22 20 ", variable: "
5120: 76 61 72 69 61 62 6c 65 20 22 2c 20 76 61 6c 75 variable ", valu
5130: 65 3a 20 22 20 76 61 6c 75 65 0a 09 09 20 20 20 e: " value...
5140: 22 2c 20 65 78 70 65 63 74 65 64 3a 20 22 20 65 ", expected: " e
5150: 78 70 65 63 74 65 64 20 22 2c 20 74 6f 6c 3a 20 xpected ", tol:
5160: 22 20 74 6f 6c 20 22 2c 20 75 6e 69 74 73 3a 20 " tol ", units:
5170: 22 20 75 6e 69 74 73 29 0a 20 20 20 20 20 20 28 " units). (
5180: 69 66 20 28 61 6e 64 20 76 61 6c 75 65 29 20 3b if (and value) ;
5190: 3b 20 72 65 71 75 69 72 65 20 6f 6e 6c 79 20 76 ; require only v
51a0: 61 6c 75 65 3b 20 42 42 20 77 61 73 2d 20 61 6c alue; BB was- al
51b0: 6c 20 74 68 72 65 65 20 72 65 71 75 69 72 65 64 l three required
51c0: 0a 09 20 20 28 6c 65 74 20 28 28 64 61 74 20 28 .. (let ((dat (
51d0: 63 6f 6e 63 20 63 61 74 65 67 6f 72 79 20 22 2c conc category ",
51e0: 22 0a 09 09 09 20 20 20 76 61 72 69 61 62 6c 65 ".... variable
51f0: 20 22 2c 22 0a 09 09 09 20 20 20 76 61 6c 75 65 ",".... value
5200: 20 20 20 20 22 2c 22 0a 09 09 09 20 20 20 65 78 ",".... ex
5210: 70 65 63 74 65 64 20 22 2c 22 0a 09 09 09 20 20 pected ","....
5220: 20 74 6f 6c 20 20 20 20 20 20 22 2c 22 0a 09 09 tol ","...
5230: 09 20 20 20 75 6e 69 74 73 20 20 20 20 22 2c 22 . units ","
5240: 0a 09 09 09 20 20 20 64 63 6f 6d 6d 65 6e 74 20 .... dcomment
5250: 22 2c 2c 22 20 3b 3b 20 65 78 74 72 61 20 63 6f ",," ;; extra co
5260: 6d 6d 61 20 66 6f 72 20 73 74 61 74 75 73 0a 09 mma for status..
5270: 09 09 20 20 20 74 79 70 65 20 20 20 20 20 29 29 .. type ))
5280: 29 0a 09 20 20 20 20 3b 3b 20 54 68 69 73 20 77 ).. ;; This w
5290: 61 73 20 72 75 6e 20 72 65 6d 6f 74 65 2c 20 64 as run remote, d
52a0: 6f 6e 27 74 20 74 68 69 6e 6b 20 74 68 61 74 20 on't think that
52b0: 6d 61 6b 65 73 20 73 65 6e 73 65 2e 20 50 65 72 makes sense. Per
52c0: 68 61 70 73 20 6e 6f 74 2c 20 62 75 74 20 74 68 haps not, but th
52d0: 61 74 20 69 73 20 74 68 65 20 65 61 73 69 65 73 at is the easies
52e0: 74 20 70 61 74 68 20 66 6f 72 20 74 68 65 20 6d t path for the m
52f0: 6f 6d 65 6e 74 2e 0a 09 20 20 20 20 28 72 6d 74 oment... (rmt
5300: 3a 63 73 76 2d 3e 74 65 73 74 2d 64 61 74 61 20 :csv->test-data
5310: 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 0a 09 run-id test-id..
5320: 09 09 09 64 61 74 29 0a 09 20 20 20 20 3b 3b 20 ...dat).. ;;
5330: 54 68 69 73 20 77 61 73 20 61 64 64 65 64 20 69 This was added i
5340: 6e 20 63 68 65 63 6b 2d 69 6e 20 61 35 61 64 66 n check-in a5adf
5350: 61 33 66 39 61 2e 20 4d 65 73 73 61 67 65 20 77 a3f9a. Message w
5360: 61 73 3a 20 22 2e 2e 2e 61 64 64 65 64 20 64 65 as: "...added de
5370: 6c 61 79 20 69 6e 20 73 65 74 2d 76 61 6c 75 65 lay in set-value
5380: 73 20 74 6f 20 61 6c 6c 6f 77 20 66 6f 72 20 64 s to allow for d
5390: 65 6c 61 79 65 64 20 77 72 69 74 65 20 6f 6e 20 elayed write on
53a0: 73 65 72 76 65 72 20 73 74 61 72 74 22 0a 09 20 server start"..
53b0: 20 20 20 3b 3b 20 49 27 6d 20 69 6e 73 65 72 74 ;; I'm insert
53c0: 69 6e 67 20 61 6e 20 61 72 62 69 74 72 61 72 79 ing an arbitrary
53d0: 20 72 6d 74 3a 20 63 61 6c 6c 20 74 6f 20 66 6f rmt: call to fo
53e0: 72 63 65 2f 65 6e 73 75 72 65 20 74 68 61 74 20 rce/ensure that
53f0: 74 68 65 20 73 65 72 76 65 72 20 69 73 20 61 76 the server is av
5400: 61 69 6c 61 62 6c 65 20 74 6f 20 28 68 6f 70 65 ailable to (hope
5410: 66 75 6c 6c 79 29 20 70 72 65 76 65 6e 74 20 61 fully) prevent a
5420: 20 63 6f 6d 6d 75 6e 69 63 61 74 69 6f 6e 20 69 communication i
5430: 73 73 75 65 2e 0a 09 20 20 20 20 28 72 6d 74 3a ssue... (rmt:
5440: 67 65 74 2d 76 61 72 20 22 4d 45 47 41 54 45 53 get-var "MEGATES
5450: 54 5f 56 45 52 53 49 4f 4e 22 29 20 3b 3b 20 74 T_VERSION") ;; t
5460: 68 69 73 20 64 6f 65 73 20 4e 4f 54 48 49 4e 47 his does NOTHING
5470: 20 62 75 74 20 65 6e 73 75 72 65 20 74 68 65 20 but ensure the
5480: 73 65 72 76 65 72 20 69 73 20 72 65 61 63 68 61 server is reacha
5490: 62 6c 65 2e 20 54 68 69 73 20 69 73 20 61 6c 6d ble. This is alm
54a0: 6f 73 74 20 63 65 72 74 61 69 6e 6c 79 20 4e 4f ost certainly NO
54b0: 54 20 6e 65 65 64 65 64 20 3a 29 0a 20 20 20 20 T needed :).
54c0: 20 20 20 20 20 20 20 20 3b 3b 20 42 42 20 2d 20 ;; BB -
54d0: 63 6f 6d 6d 65 6e 74 69 6f 6e 67 20 6f 75 74 20 commentiong out
54e0: 61 72 62 69 74 72 61 72 79 20 31 30 20 73 65 63 arbitrary 10 sec
54f0: 6f 6e 64 20 77 61 69 74 20 28 74 68 72 65 61 64 ond wait (thread
5500: 2d 73 6c 65 65 70 21 20 31 30 29 20 3b 3b 20 61 -sleep! 10) ;; a
5510: 64 64 20 31 30 20 73 65 63 6f 6e 64 20 64 65 6c dd 10 second del
5520: 61 79 20 62 65 66 6f 72 65 20 71 75 69 74 20 69 ay before quit i
5530: 6e 63 61 73 65 20 72 6d 74 20 6e 65 65 64 73 20 ncase rmt needs
5540: 74 69 6d 65 20 74 6f 20 73 74 61 72 74 20 61 20 time to start a
5550: 73 65 72 76 65 72 2e 0a 20 20 20 20 20 20 20 20 server..
5560: 20 20 20 20 29 29 29 0a 20 20 20 20 20 20 0a 20 ))). .
5570: 20 20 20 3b 3b 20 6e 65 65 64 20 74 6f 20 75 70 ;; need to up
5580: 64 61 74 65 20 74 68 65 20 74 6f 70 20 74 65 73 date the top tes
5590: 74 20 72 65 63 6f 72 64 20 69 66 20 50 41 53 53 t record if PASS
55a0: 20 6f 72 20 46 41 49 4c 20 61 6e 64 20 74 68 69 or FAIL and thi
55b0: 73 20 69 73 20 61 20 73 75 62 74 65 73 74 0a 20 s is a subtest.
55c0: 20 20 20 3b 3b 3b 3b 3b 3b 20 28 69 66 20 28 6e ;;;;;; (if (n
55d0: 6f 74 20 28 65 71 75 61 6c 3f 20 69 74 65 6d 2d ot (equal? item-
55e0: 70 61 74 68 20 22 22 29 29 0a 20 20 20 20 3b 3b path "")). ;;
55f0: 3b 3b 3b 3b 20 20 20 20 20 28 72 6d 74 3a 73 65 ;;;; (rmt:se
5600: 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d 61 t-state-status-a
5610: 6e 64 2d 72 6f 6c 6c 2d 75 70 2d 69 74 65 6d 73 nd-roll-up-items
5620: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
5630: 65 20 69 74 65 6d 2d 70 61 74 68 20 73 74 61 74 e item-path stat
5640: 65 20 73 74 61 74 75 73 20 23 66 29 20 3b 3b 3b e status #f) ;;;
5650: 3b 3b 29 0a 0a 20 20 20 20 28 69 66 20 28 6f 72 ;;).. (if (or
5660: 20 28 61 6e 64 20 28 73 74 72 69 6e 67 3f 20 63 (and (string? c
5670: 6f 6d 6d 65 6e 74 29 0a 09 09 20 28 73 74 72 69 omment)... (stri
5680: 6e 67 2d 6d 61 74 63 68 20 28 72 65 67 65 78 70 ng-match (regexp
5690: 20 22 5c 5c 53 2b 22 29 20 63 6f 6d 6d 65 6e 74 "\\S+") comment
56a0: 29 29 0a 09 20 20 20 20 77 61 69 76 65 64 29 0a )).. waived).
56b0: 09 28 6c 65 74 20 28 28 63 6d 74 20 20 28 69 66 .(let ((cmt (if
56c0: 20 77 61 69 76 65 64 20 77 61 69 76 65 64 20 63 waived waived c
56d0: 6f 6d 6d 65 6e 74 29 29 29 0a 09 20 20 28 72 6d omment))).. (rm
56e0: 74 3a 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 t:general-call '
56f0: 73 65 74 2d 74 65 73 74 2d 63 6f 6d 6d 65 6e 74 set-test-comment
5700: 20 72 75 6e 2d 69 64 20 63 6d 74 20 74 65 73 74 run-id cmt test
5710: 2d 69 64 29 29 29 29 29 0a 0a 28 64 65 66 69 6e -id)))))..(defin
5720: 65 20 28 74 65 73 74 73 3a 74 65 73 74 2d 73 65 e (tests:test-se
5730: 74 2d 74 6f 70 6c 6f 67 21 20 72 75 6e 2d 69 64 t-toplog! run-id
5740: 20 74 65 73 74 2d 6e 61 6d 65 20 6c 6f 67 66 29 test-name logf)
5750: 20 0a 20 20 28 72 6d 74 3a 67 65 6e 65 72 61 6c . (rmt:general
5760: 2d 63 61 6c 6c 20 27 74 65 73 74 73 3a 74 65 73 -call 'tests:tes
5770: 74 2d 73 65 74 2d 74 6f 70 6c 6f 67 20 72 75 6e t-set-toplog run
5780: 2d 69 64 20 6c 6f 67 66 20 72 75 6e 2d 69 64 20 -id logf run-id
5790: 74 65 73 74 2d 6e 61 6d 65 29 29 0a 0a 28 64 65 test-name))..(de
57a0: 66 69 6e 65 20 28 74 65 73 74 73 3a 73 75 6d 6d fine (tests:summ
57b0: 61 72 69 7a 65 2d 69 74 65 6d 73 20 72 75 6e 2d arize-items run-
57c0: 69 64 20 74 65 73 74 2d 69 64 20 74 65 73 74 2d id test-id test-
57d0: 6e 61 6d 65 20 66 6f 72 63 65 29 0a 20 20 3b 3b name force). ;;
57e0: 20 69 66 20 6e 6f 74 20 66 6f 72 63 65 20 74 68 if not force th
57f0: 65 6e 20 6f 6e 6c 79 20 75 70 64 61 74 65 20 74 en only update t
5800: 68 65 20 72 65 63 6f 72 64 20 69 66 20 6f 6e 65 he record if one
5810: 20 6f 66 20 74 68 65 73 65 20 69 73 20 74 72 75 of these is tru
5820: 65 3a 0a 20 20 3b 3b 20 20 20 31 2e 20 6c 6f 67 e:. ;; 1. log
5830: 66 20 69 73 20 22 6c 6f 67 2f 66 69 6e 61 6c 2e f is "log/final.
5840: 6c 6f 67 0a 20 20 3b 3b 20 20 20 32 2e 20 6c 6f log. ;; 2. lo
5850: 67 66 20 69 73 20 73 61 6d 65 20 61 73 20 6f 75 gf is same as ou
5860: 74 70 75 74 66 69 6c 65 6e 61 6d 65 0a 20 20 28 tputfilename. (
5870: 6c 65 74 2a 20 28 28 6f 75 74 70 75 74 66 69 6c let* ((outputfil
5880: 65 6e 61 6d 65 20 28 63 6f 6e 63 20 22 6d 65 67 ename (conc "meg
5890: 61 74 65 73 74 2d 72 6f 6c 6c 75 70 2d 22 20 74 atest-rollup-" t
58a0: 65 73 74 2d 6e 61 6d 65 20 22 2e 68 74 6d 6c 22 est-name ".html"
58b0: 29 29 0a 09 20 28 6f 72 69 67 2d 64 69 72 20 20 )).. (orig-dir
58c0: 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d 64 69 (current-di
58d0: 72 65 63 74 6f 72 79 29 29 0a 09 20 28 6c 6f 67 rectory)).. (log
58e0: 66 2d 69 6e 66 6f 20 20 20 20 20 20 28 72 6d 74 f-info (rmt
58f0: 3a 74 65 73 74 2d 67 65 74 2d 6c 6f 67 66 69 6c :test-get-logfil
5900: 65 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 20 74 65 e-info run-id te
5910: 73 74 2d 6e 61 6d 65 29 29 0a 09 20 28 6c 6f 67 st-name)).. (log
5920: 66 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 f (if
5930: 6c 6f 67 66 2d 69 6e 66 6f 20 28 63 61 64 72 20 logf-info (cadr
5940: 6c 6f 67 66 2d 69 6e 66 6f 29 20 23 66 29 29 0a logf-info) #f)).
5950: 09 20 28 70 61 74 68 20 20 20 20 20 20 20 20 20 . (path
5960: 20 20 28 69 66 20 6c 6f 67 66 2d 69 6e 66 6f 20 (if logf-info
5970: 28 63 61 72 20 20 6c 6f 67 66 2d 69 6e 66 6f 29 (car logf-info)
5980: 20 23 66 29 29 29 0a 20 20 20 20 3b 3b 20 54 68 #f))). ;; Th
5990: 69 73 20 71 75 65 72 79 20 66 69 6e 64 73 20 74 is query finds t
59a0: 68 65 20 70 61 74 68 20 61 6e 64 20 63 68 61 6e he path and chan
59b0: 67 65 73 20 74 68 65 20 64 69 72 65 63 74 6f 72 ges the director
59c0: 79 20 74 6f 20 69 74 20 66 6f 72 20 74 68 65 20 y to it for the
59d0: 74 65 73 74 0a 20 20 20 20 28 69 66 20 28 61 6e test. (if (an
59e0: 64 20 28 73 74 72 69 6e 67 3f 20 70 61 74 68 29 d (string? path)
59f0: 0a 09 20 20 20 20 20 28 64 69 72 65 63 74 6f 72 .. (director
5a00: 79 3f 20 70 61 74 68 29 29 20 3b 3b 20 63 61 6e y? path)) ;; can
5a10: 20 67 65 74 20 23 66 20 68 65 72 65 20 75 6e 64 get #f here und
5a20: 65 72 20 73 6f 6d 65 20 77 69 65 72 64 20 63 6f er some wierd co
5a30: 6e 64 69 74 69 6f 6e 73 2e 20 77 68 79 2c 20 75 nditions. why, u
5a40: 6e 6b 6e 6f 77 6e 20 2e 2e 2e 0a 09 28 62 65 67 nknown .....(beg
5a50: 69 6e 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 in.. (debug:pri
5a60: 6e 74 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 4 *default-lo
5a70: 67 2d 70 6f 72 74 2a 20 22 46 6f 75 6e 64 20 70 g-port* "Found p
5a80: 61 74 68 3a 20 22 20 70 61 74 68 29 0a 09 20 20 ath: " path)..
5a90: 28 63 68 61 6e 67 65 2d 64 69 72 65 63 74 6f 72 (change-director
5aa0: 79 20 70 61 74 68 29 29 0a 09 3b 3b 20 28 73 65 y path))..;; (se
5ab0: 74 21 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d t! outputfilenam
5ac0: 65 20 28 63 6f 6e 63 20 70 61 74 68 20 22 2f 22 e (conc path "/"
5ad0: 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 29 outputfilename)
5ae0: 29 29 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 ))..(debug:print
5af0: 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c -error 0 *defaul
5b00: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 75 6d t-log-port* "sum
5b10: 6d 61 72 69 7a 65 2d 69 74 65 6d 73 20 66 6f 72 marize-items for
5b20: 20 72 75 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 64 run-id=" run-id
5b30: 20 22 2c 20 74 65 73 74 2d 6e 61 6d 65 3d 22 20 ", test-name="
5b40: 74 65 73 74 2d 6e 61 6d 65 20 22 2c 20 6e 6f 20 test-name ", no
5b50: 73 75 63 68 20 70 61 74 68 3a 20 22 20 70 61 74 such path: " pat
5b60: 68 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 h)). (debug:p
5b70: 72 69 6e 74 20 34 20 2a 64 65 66 61 75 6c 74 2d rint 4 *default-
5b80: 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 75 6d 6d 61 log-port* "summa
5b90: 72 69 7a 65 2d 69 74 65 6d 73 20 77 69 74 68 20 rize-items with
5ba0: 6c 6f 67 66 20 22 20 6c 6f 67 66 20 22 2c 20 6f logf " logf ", o
5bb0: 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 20 22 20 utputfilename "
5bc0: 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 20 22 outputfilename "
5bd0: 20 61 6e 64 20 66 6f 72 63 65 20 22 20 66 6f 72 and force " for
5be0: 63 65 29 0a 20 20 20 20 28 69 66 20 28 6f 72 20 ce). (if (or
5bf0: 28 65 71 75 61 6c 3f 20 6c 6f 67 66 20 22 6c 6f (equal? logf "lo
5c00: 67 73 2f 66 69 6e 61 6c 2e 6c 6f 67 22 29 0a 09 gs/final.log")..
5c10: 20 20 20 20 28 65 71 75 61 6c 3f 20 6c 6f 67 66 (equal? logf
5c20: 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 29 outputfilename)
5c30: 0a 09 20 20 20 20 66 6f 72 63 65 29 0a 09 28 6c .. force)..(l
5c40: 65 74 20 28 28 6d 79 2d 73 74 61 72 74 2d 74 69 et ((my-start-ti
5c50: 6d 65 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f me (current-seco
5c60: 6e 64 73 29 29 0a 09 20 20 20 20 20 20 28 6c 6f nds)).. (lo
5c70: 63 6b 66 20 20 20 20 20 20 20 20 20 28 63 6f 6e ckf (con
5c80: 63 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 c outputfilename
5c90: 20 22 2e 6c 6f 63 6b 22 29 29 29 0a 09 20 20 28 ".lock"))).. (
5ca0: 6c 65 74 20 6c 6f 6f 70 20 28 28 68 61 76 65 2d let loop ((have-
5cb0: 6c 6f 63 6b 20 20 28 63 6f 6d 6d 6f 6e 3a 73 69 lock (common:si
5cc0: 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 20 6c mple-file-lock l
5cd0: 6f 63 6b 66 29 29 29 0a 09 20 20 20 20 28 69 66 ockf))).. (if
5ce0: 20 68 61 76 65 2d 6c 6f 63 6b 0a 09 09 28 6c 65 have-lock...(le
5cf0: 74 20 28 28 73 63 72 69 70 74 20 28 63 6f 6e 66 t ((script (conf
5d00: 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 igf:lookup *conf
5d10: 69 67 64 61 74 2a 20 22 74 65 73 74 72 6f 6c 6c igdat* "testroll
5d20: 75 70 22 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 up" test-name)))
5d30: 0a 09 09 20 20 28 70 72 69 6e 74 20 22 4f 62 74 ... (print "Obt
5d40: 61 69 6e 65 64 20 6c 6f 63 6b 20 66 6f 72 20 22 ained lock for "
5d50: 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 29 outputfilename)
5d60: 0a 09 09 20 20 28 72 6d 74 3a 73 65 74 2d 73 74 ... (rmt:set-st
5d70: 61 74 65 2d 73 74 61 74 75 73 2d 61 6e 64 2d 72 ate-status-and-r
5d80: 6f 6c 6c 2d 75 70 2d 69 74 65 6d 73 20 72 75 6e oll-up-items run
5d90: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 22 22 -id test-name ""
5da0: 20 23 66 20 23 66 20 23 66 29 0a 09 09 20 20 28 #f #f #f)... (
5db0: 69 66 20 73 63 72 69 70 74 0a 09 09 20 20 20 20 if script...
5dc0: 20 20 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 (system (conc
5dd0: 73 63 72 69 70 74 20 22 20 3e 20 22 20 6f 75 74 script " > " out
5de0: 70 75 74 66 69 6c 65 6e 61 6d 65 20 22 20 26 20 putfilename " &
5df0: 22 29 29 0a 09 09 20 20 20 20 20 20 28 74 65 73 "))... (tes
5e00: 74 73 3a 67 65 6e 65 72 61 74 65 2d 68 74 6d 6c ts:generate-html
5e10: 2d 73 75 6d 6d 61 72 79 2d 66 6f 72 2d 69 74 65 -summary-for-ite
5e20: 72 61 74 65 64 2d 74 65 73 74 20 72 75 6e 2d 69 rated-test run-i
5e30: 64 20 74 65 73 74 2d 69 64 20 74 65 73 74 2d 6e d test-id test-n
5e40: 61 6d 65 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 ame outputfilena
5e50: 6d 65 29 29 0a 09 09 20 20 28 63 6f 6d 6d 6f 6e me))... (common
5e60: 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 72 65 6c :simple-file-rel
5e70: 65 61 73 65 2d 6c 6f 63 6b 20 6c 6f 63 6b 66 29 ease-lock lockf)
5e80: 0a 09 09 20 20 28 63 68 61 6e 67 65 2d 64 69 72 ... (change-dir
5e90: 65 63 74 6f 72 79 20 6f 72 69 67 2d 64 69 72 29 ectory orig-dir)
5ea0: 0a 09 09 20 20 3b 3b 20 4e 42 2f 2f 20 74 65 73 ... ;; NB// tes
5eb0: 74 73 3a 74 65 73 74 2d 73 65 74 2d 74 6f 70 6c ts:test-set-topl
5ec0: 6f 67 21 20 69 73 20 72 65 6d 6f 74 65 20 69 6e og! is remote in
5ed0: 74 65 72 6e 61 6c 2e 2e 2e 0a 09 09 20 20 28 74 ternal...... (t
5ee0: 65 73 74 73 3a 74 65 73 74 2d 73 65 74 2d 74 6f ests:test-set-to
5ef0: 70 6c 6f 67 21 20 72 75 6e 2d 69 64 20 74 65 73 plog! run-id tes
5f00: 74 2d 6e 61 6d 65 20 6f 75 74 70 75 74 66 69 6c t-name outputfil
5f10: 65 6e 61 6d 65 29 29 0a 09 09 3b 3b 20 64 69 64 ename))...;; did
5f20: 6e 27 74 20 67 65 74 20 74 68 65 20 6c 6f 63 6b n't get the lock
5f30: 2c 20 63 68 65 63 6b 20 74 6f 20 73 65 65 20 69 , check to see i
5f40: 66 20 63 75 72 72 65 6e 74 20 75 70 64 61 74 65 f current update
5f50: 20 73 74 61 72 74 65 64 20 6c 61 74 65 72 20 74 started later t
5f60: 68 61 6e 20 74 68 69 73 20 0a 09 09 3b 3b 20 75 han this ...;; u
5f70: 70 64 61 74 65 2c 20 69 66 20 73 6f 20 77 65 20 pdate, if so we
5f80: 63 61 6e 20 65 78 69 74 20 77 69 74 68 6f 75 74 can exit without
5f90: 20 64 6f 69 6e 67 20 61 6e 79 20 77 6f 72 6b 0a doing any work.
5fa0: 09 09 28 69 66 20 28 3e 20 6d 79 2d 73 74 61 72 ..(if (> my-star
5fb0: 74 2d 74 69 6d 65 20 28 68 61 6e 64 6c 65 2d 65 t-time (handle-e
5fc0: 78 63 65 70 74 69 6f 6e 73 0a 09 09 09 09 09 20 xceptions......
5fd0: 65 78 6e 0a 09 09 09 09 20 20 20 20 20 20 20 28 exn..... (
5fe0: 62 65 67 69 6e 0a 09 09 09 09 09 20 28 70 72 69 begin...... (pri
5ff0: 6e 74 20 22 66 61 69 6c 65 64 20 74 6f 20 67 65 nt "failed to ge
6000: 74 20 6d 6f 64 20 74 69 6d 65 20 6f 6e 20 22 20 t mod time on "
6010: 6c 6f 63 6b 66 20 22 2c 20 65 78 6e 3d 22 20 65 lockf ", exn=" e
6020: 78 6e 29 0a 09 09 09 09 09 20 30 29 0a 09 09 09 xn)...... 0)....
6030: 09 20 20 20 20 20 20 20 28 66 69 6c 65 2d 6d 6f . (file-mo
6040: 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 dification-time
6050: 6c 6f 63 6b 66 29 29 29 0a 09 09 20 20 20 20 3b lockf)))... ;
6060: 3b 20 77 65 20 73 74 61 72 74 65 64 20 73 69 6e ; we started sin
6070: 63 65 20 63 75 72 72 65 6e 74 20 72 65 2d 67 65 ce current re-ge
6080: 6e 20 69 6e 20 66 6c 69 67 68 74 2c 20 64 65 6c n in flight, del
6090: 61 79 20 61 20 6c 69 74 74 6c 65 20 61 6e 64 20 ay a little and
60a0: 74 72 79 20 61 67 61 69 6e 0a 09 09 20 20 20 20 try again...
60b0: 28 62 65 67 69 6e 0a 09 09 20 20 20 20 20 20 28 (begin... (
60c0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
60d0: 20 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 1 *default-log-
60e0: 70 6f 72 74 2a 20 22 57 61 69 74 69 6e 67 20 74 port* "Waiting t
60f0: 6f 20 75 70 64 61 74 65 20 22 20 6f 75 74 70 75 o update " outpu
6100: 74 66 69 6c 65 6e 61 6d 65 20 22 2c 20 61 6e 6f tfilename ", ano
6110: 74 68 65 72 20 74 65 73 74 20 63 75 72 72 65 6e ther test curren
6120: 74 6c 79 20 75 70 64 61 74 69 6e 67 20 69 74 22 tly updating it"
6130: 29 0a 09 09 20 20 20 20 20 20 28 74 68 72 65 61 )... (threa
6140: 64 2d 73 6c 65 65 70 21 20 28 2b 20 35 20 28 72 d-sleep! (+ 5 (r
6150: 61 6e 64 6f 6d 20 35 29 29 29 20 3b 3b 20 64 65 andom 5))) ;; de
6160: 6c 61 79 20 62 65 74 77 65 65 6e 20 35 20 61 6e lay between 5 an
6170: 64 20 31 30 20 73 65 63 6f 6e 64 73 0a 09 09 20 d 10 seconds...
6180: 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 6f 6d 6d (loop (comm
6190: 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 6c on:simple-file-l
61a0: 6f 63 6b 20 6c 6f 63 6b 66 29 29 29 29 29 29 29 ock lockf)))))))
61b0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 )))..(define (te
61c0: 73 74 73 3a 67 65 6e 65 72 61 74 65 2d 68 74 6d sts:generate-htm
61d0: 6c 2d 73 75 6d 6d 61 72 79 2d 66 6f 72 2d 69 74 l-summary-for-it
61e0: 65 72 61 74 65 64 2d 74 65 73 74 20 72 75 6e 2d erated-test run-
61f0: 69 64 20 74 65 73 74 2d 69 64 20 74 65 73 74 2d id test-id test-
6200: 6e 61 6d 65 20 6f 75 74 70 75 74 66 69 6c 65 6e name outputfilen
6210: 61 6d 65 29 0a 20 20 28 6c 65 74 20 28 28 63 6f ame). (let ((co
6220: 75 6e 74 73 20 20 20 20 20 20 20 20 20 20 20 20 unts
6230: 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 (make-hash-tab
6240: 6c 65 29 29 0a 09 28 73 74 61 74 65 63 6f 75 6e le))..(statecoun
6250: 74 73 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 ts (make
6260: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 09 28 -hash-table))..(
6270: 6f 75 74 74 78 74 20 20 20 20 20 20 20 20 20 20 outtxt
6280: 20 20 20 20 22 22 29 0a 09 28 74 6f 74 20 20 20 "")..(tot
6290: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 30 29 0)
62a0: 0a 09 28 74 65 73 74 64 61 74 20 20 20 20 20 20 ..(testdat
62b0: 20 20 20 20 20 20 20 28 72 6d 74 3a 74 65 73 74 (rmt:test
62c0: 2d 67 65 74 2d 72 65 63 6f 72 64 73 2d 66 6f 72 -get-records-for
62d0: 2d 69 6e 64 65 78 2d 66 69 6c 65 20 72 75 6e 2d -index-file run-
62e0: 69 64 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a id test-name))).
62f0: 20 20 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 (with-output
6300: 2d 74 6f 2d 66 69 6c 65 20 6f 75 74 70 75 74 66 -to-file outputf
6310: 69 6c 65 6e 61 6d 65 0a 20 20 20 20 20 20 28 6c ilename. (l
6320: 61 6d 62 64 61 20 28 29 0a 09 28 73 65 74 21 20 ambda ()..(set!
6330: 6f 75 74 74 78 74 20 28 63 6f 6e 63 20 6f 75 74 outtxt (conc out
6340: 74 78 74 20 22 3c 68 74 6d 6c 3e 3c 74 69 74 6c txt "<html><titl
6350: 65 3e 53 75 6d 6d 61 72 79 3a 20 22 20 74 65 73 e>Summary: " tes
6360: 74 2d 6e 61 6d 65 20 0a 09 09 09 20 20 20 22 3c t-name .... "<
6370: 2f 74 69 74 6c 65 3e 3c 62 6f 64 79 3e 3c 68 32 /title><body><h2
6380: 3e 53 75 6d 6d 61 72 79 20 66 6f 72 20 22 20 74 >Summary for " t
6390: 65 73 74 2d 6e 61 6d 65 20 22 3c 2f 68 32 3e 22 est-name "</h2>"
63a0: 29 29 0a 09 28 66 6f 72 2d 65 61 63 68 0a 09 20 ))..(for-each..
63b0: 28 6c 61 6d 62 64 61 20 28 74 65 73 74 72 65 63 (lambda (testrec
63c0: 6f 72 64 29 0a 09 20 20 20 28 6c 65 74 20 28 28 ord).. (let ((
63d0: 69 64 20 20 20 20 20 20 20 20 20 20 20 20 20 28 id (
63e0: 76 65 63 74 6f 72 2d 72 65 66 20 74 65 73 74 72 vector-ref testr
63f0: 65 63 6f 72 64 20 30 29 29 0a 09 09 20 28 69 74 ecord 0))... (it
6400: 65 6d 70 61 74 68 20 20 20 20 20 20 20 28 76 65 empath (ve
6410: 63 74 6f 72 2d 72 65 66 20 74 65 73 74 72 65 63 ctor-ref testrec
6420: 6f 72 64 20 31 29 29 0a 09 09 20 28 73 74 61 74 ord 1))... (stat
6430: 65 20 20 20 20 20 20 20 20 20 20 28 76 65 63 74 e (vect
6440: 6f 72 2d 72 65 66 20 74 65 73 74 72 65 63 6f 72 or-ref testrecor
6450: 64 20 32 29 29 0a 09 09 20 28 73 74 61 74 75 73 d 2))... (status
6460: 20 20 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 (vector
6470: 2d 72 65 66 20 74 65 73 74 72 65 63 6f 72 64 20 -ref testrecord
6480: 33 29 29 0a 09 09 20 28 72 75 6e 5f 64 75 72 61 3))... (run_dura
6490: 74 69 6f 6e 20 20 20 28 76 65 63 74 6f 72 2d 72 tion (vector-r
64a0: 65 66 20 74 65 73 74 72 65 63 6f 72 64 20 34 29 ef testrecord 4)
64b0: 29 0a 09 09 20 28 6c 6f 67 66 20 20 20 20 20 20 )... (logf
64c0: 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 (vector-ref
64d0: 20 74 65 73 74 72 65 63 6f 72 64 20 35 29 29 0a testrecord 5)).
64e0: 09 09 20 28 63 6f 6d 6d 65 6e 74 20 20 20 20 20 .. (comment
64f0: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 (vector-ref t
6500: 65 73 74 72 65 63 6f 72 64 20 36 29 29 29 0a 09 estrecord 6)))..
6510: 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
6520: 2d 73 65 74 21 20 63 6f 75 6e 74 73 20 73 74 61 -set! counts sta
6530: 74 75 73 20 28 2b 20 31 20 28 68 61 73 68 2d 74 tus (+ 1 (hash-t
6540: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
6550: 20 63 6f 75 6e 74 73 20 73 74 61 74 75 73 20 30 counts status 0
6560: 29 29 29 0a 09 20 20 20 20 20 28 68 61 73 68 2d ))).. (hash-
6570: 74 61 62 6c 65 2d 73 65 74 21 20 73 74 61 74 65 table-set! state
6580: 63 6f 75 6e 74 73 20 73 74 61 74 65 20 28 2b 20 counts state (+
6590: 31 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 1 (hash-table-re
65a0: 66 2f 64 65 66 61 75 6c 74 20 73 74 61 74 65 63 f/default statec
65b0: 6f 75 6e 74 73 20 73 74 61 74 65 20 30 29 29 29 ounts state 0)))
65c0: 0a 09 20 20 20 20 20 28 73 65 74 21 20 6f 75 74 .. (set! out
65d0: 74 78 74 20 28 63 6f 6e 63 20 6f 75 74 74 78 74 txt (conc outtxt
65e0: 20 22 3c 74 72 3e 22 0a 09 09 09 09 3b 3b 20 22 "<tr>".....;; "
65f0: 3c 74 64 3e 3c 61 20 68 72 65 66 3d 5c 22 22 20 <td><a href=\""
6600: 69 74 65 6d 70 61 74 68 20 22 2f 22 20 6c 6f 67 itempath "/" log
6610: 66 20 22 5c 22 3e 20 22 20 69 74 65 6d 70 61 74 f "\"> " itempat
6620: 68 20 22 3c 2f 61 3e 3c 2f 74 64 3e 22 20 0a 09 h "</a></td>" ..
6630: 09 09 09 22 3c 74 64 3e 3c 61 20 68 72 65 66 3d ..."<td><a href=
6640: 5c 22 22 20 69 74 65 6d 70 61 74 68 20 22 2f 74 \"" itempath "/t
6650: 65 73 74 2d 73 75 6d 6d 61 72 79 2e 68 74 6d 6c est-summary.html
6660: 5c 22 3e 20 22 20 69 74 65 6d 70 61 74 68 20 22 \"> " itempath "
6670: 3c 2f 61 3e 3c 2f 74 64 3e 22 20 0a 09 09 09 09 </a></td>" .....
6680: 22 3c 74 64 3e 22 20 73 74 61 74 65 20 20 20 20 "<td>" state
6690: 22 3c 2f 74 64 3e 22 20 0a 09 09 09 09 22 3c 74 "</td>" ....."<t
66a0: 64 3e 3c 66 6f 6e 74 20 63 6f 6c 6f 72 3d 22 20 d><font color="
66b0: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 6f 6c 6f (common:get-colo
66c0: 72 2d 66 72 6f 6d 2d 73 74 61 74 75 73 20 73 74 r-from-status st
66d0: 61 74 75 73 29 0a 09 09 09 09 22 3e 22 20 20 20 atus).....">"
66e0: 73 74 61 74 75 73 20 20 20 22 3c 2f 66 6f 6e 74 status "</font
66f0: 3e 3c 2f 74 64 3e 22 0a 09 09 09 09 22 3c 74 64 ></td>"....."<td
6700: 3e 22 20 28 69 66 20 28 65 71 75 61 6c 3f 20 63 >" (if (equal? c
6710: 6f 6d 6d 65 6e 74 20 22 22 29 0a 09 09 09 09 09 omment "")......
6720: 20 20 20 22 26 6e 62 73 70 3b 22 0a 09 09 09 09 " ".....
6730: 09 20 20 20 63 6f 6d 6d 65 6e 74 29 20 22 3c 2f . comment) "</
6740: 74 64 3e 22 0a 09 09 09 09 09 20 20 20 22 3c 2f td>"...... "</
6750: 74 72 3e 22 29 29 29 29 0a 09 20 28 69 66 20 28 tr>")))).. (if (
6760: 6c 69 73 74 3f 20 74 65 73 74 64 61 74 29 0a 09 list? testdat)..
6770: 20 20 20 20 20 74 65 73 74 64 61 74 0a 09 20 20 testdat..
6780: 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 (begin..
6790: 20 20 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a (print "ERROR:
67a0: 20 66 61 69 6c 65 64 20 74 6f 20 67 65 74 20 72 failed to get r
67b0: 65 63 6f 72 64 73 20 77 69 74 68 20 72 6d 74 3a ecords with rmt:
67c0: 74 65 73 74 2d 67 65 74 2d 72 65 63 6f 72 64 73 test-get-records
67d0: 2d 66 6f 72 2d 69 6e 64 65 78 2d 66 69 6c 65 20 -for-index-file
67e0: 72 75 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 64 20 run-id=" run-id
67f0: 22 74 65 73 74 2d 6e 61 6d 65 3d 22 20 74 65 73 "test-name=" tes
6800: 74 2d 6e 61 6d 65 29 0a 09 20 20 20 20 20 20 20 t-name)..
6810: 27 28 29 29 29 29 0a 09 0a 09 28 70 72 69 6e 74 '())))....(print
6820: 20 22 3c 74 61 62 6c 65 3e 3c 74 72 3e 3c 74 64 "<table><tr><td
6830: 20 76 61 6c 69 67 6e 3d 5c 22 74 6f 70 5c 22 3e valign=\"top\">
6840: 22 29 0a 09 3b 3b 20 50 72 69 6e 74 20 6f 75 74 ")..;; Print out
6850: 20 73 74 61 74 73 20 66 6f 72 20 73 74 61 74 75 stats for statu
6860: 73 0a 09 28 73 65 74 21 20 74 6f 74 20 30 29 0a s..(set! tot 0).
6870: 09 28 70 72 69 6e 74 20 22 3c 74 61 62 6c 65 20 .(print "<table
6880: 63 65 6c 6c 73 70 61 63 69 6e 67 3d 5c 22 30 5c cellspacing=\"0\
6890: 22 20 62 6f 72 64 65 72 3d 5c 22 31 5c 22 3e 3c " border=\"1\"><
68a0: 74 72 3e 3c 74 64 20 63 6f 6c 73 70 61 6e 3d 5c tr><td colspan=\
68b0: 22 32 5c 22 3e 3c 68 32 3e 53 74 61 74 65 20 73 "2\"><h2>State s
68c0: 74 61 74 73 3c 2f 68 32 3e 3c 2f 74 64 3e 3c 2f tats</h2></td></
68d0: 74 72 3e 22 29 0a 09 28 66 6f 72 2d 65 61 63 68 tr>")..(for-each
68e0: 20 28 6c 61 6d 62 64 61 20 28 73 74 61 74 65 29 (lambda (state)
68f0: 0a 09 09 20 20 20 20 28 73 65 74 21 20 74 6f 74 ... (set! tot
6900: 20 28 2b 20 74 6f 74 20 28 68 61 73 68 2d 74 61 (+ tot (hash-ta
6910: 62 6c 65 2d 72 65 66 20 73 74 61 74 65 63 6f 75 ble-ref statecou
6920: 6e 74 73 20 73 74 61 74 65 29 29 29 0a 09 09 20 nts state)))...
6930: 20 20 20 28 70 72 69 6e 74 20 22 3c 74 72 3e 3c (print "<tr><
6940: 74 64 3e 22 20 73 74 61 74 65 20 22 3c 2f 74 64 td>" state "</td
6950: 3e 3c 74 64 3e 22 20 28 68 61 73 68 2d 74 61 62 ><td>" (hash-tab
6960: 6c 65 2d 72 65 66 20 73 74 61 74 65 63 6f 75 6e le-ref statecoun
6970: 74 73 20 73 74 61 74 65 29 20 22 3c 2f 74 64 3e ts state) "</td>
6980: 3c 2f 74 72 3e 22 29 29 0a 09 09 20 20 28 68 61 </tr>"))... (ha
6990: 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 73 74 sh-table-keys st
69a0: 61 74 65 63 6f 75 6e 74 73 29 29 0a 09 28 70 72 atecounts))..(pr
69b0: 69 6e 74 20 22 3c 74 72 3e 3c 74 64 3e 54 6f 74 int "<tr><td>Tot
69c0: 61 6c 3c 2f 74 64 3e 3c 74 64 3e 22 20 74 6f 74 al</td><td>" tot
69d0: 20 22 3c 2f 74 64 3e 3c 2f 74 72 3e 3c 2f 74 61 "</td></tr></ta
69e0: 62 6c 65 3e 22 29 0a 09 28 70 72 69 6e 74 20 22 ble>")..(print "
69f0: 3c 2f 74 64 3e 3c 74 64 20 76 61 6c 69 67 6e 3d </td><td valign=
6a00: 5c 22 74 6f 70 5c 22 3e 22 29 0a 09 3b 3b 20 50 \"top\">")..;; P
6a10: 72 69 6e 74 20 6f 75 74 20 73 74 61 74 73 20 66 rint out stats f
6a20: 6f 72 20 73 74 61 74 65 0a 09 28 73 65 74 21 20 or state..(set!
6a30: 74 6f 74 20 30 29 0a 09 28 70 72 69 6e 74 20 22 tot 0)..(print "
6a40: 3c 74 61 62 6c 65 20 63 65 6c 6c 73 70 61 63 69 <table cellspaci
6a50: 6e 67 3d 5c 22 30 5c 22 20 62 6f 72 64 65 72 3d ng=\"0\" border=
6a60: 5c 22 31 5c 22 3e 3c 74 72 3e 3c 74 64 20 63 6f \"1\"><tr><td co
6a70: 6c 73 70 61 6e 3d 5c 22 32 5c 22 3e 3c 68 32 3e lspan=\"2\"><h2>
6a80: 53 74 61 74 75 73 20 73 74 61 74 73 3c 2f 68 32 Status stats</h2
6a90: 3e 3c 2f 74 64 3e 3c 2f 74 72 3e 22 29 0a 09 28 ></td></tr>")..(
6aa0: 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 for-each (lambda
6ab0: 20 28 73 74 61 74 75 73 29 0a 09 09 20 20 20 20 (status)...
6ac0: 28 73 65 74 21 20 74 6f 74 20 28 2b 20 74 6f 74 (set! tot (+ tot
6ad0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
6ae0: 20 63 6f 75 6e 74 73 20 73 74 61 74 75 73 29 29 counts status))
6af0: 29 0a 09 09 20 20 20 20 28 70 72 69 6e 74 20 22 )... (print "
6b00: 3c 74 72 3e 3c 74 64 3e 3c 66 6f 6e 74 20 63 6f <tr><td><font co
6b10: 6c 6f 72 3d 5c 22 22 20 28 63 6f 6d 6d 6f 6e 3a lor=\"" (common:
6b20: 67 65 74 2d 63 6f 6c 6f 72 2d 66 72 6f 6d 2d 73 get-color-from-s
6b30: 74 61 74 75 73 20 73 74 61 74 75 73 29 20 22 5c tatus status) "\
6b40: 22 3e 22 20 73 74 61 74 75 73 0a 09 09 09 20 20 ">" status....
6b50: 20 22 3c 2f 66 6f 6e 74 3e 3c 2f 74 64 3e 3c 74 "</font></td><t
6b60: 64 3e 22 20 28 68 61 73 68 2d 74 61 62 6c 65 2d d>" (hash-table-
6b70: 72 65 66 20 63 6f 75 6e 74 73 20 73 74 61 74 75 ref counts statu
6b80: 73 29 20 22 3c 2f 74 64 3e 3c 2f 74 72 3e 22 29 s) "</td></tr>")
6b90: 29 0a 09 09 20 20 28 68 61 73 68 2d 74 61 62 6c )... (hash-tabl
6ba0: 65 2d 6b 65 79 73 20 63 6f 75 6e 74 73 29 29 0a e-keys counts)).
6bb0: 09 28 70 72 69 6e 74 20 22 3c 74 72 3e 3c 74 64 .(print "<tr><td
6bc0: 3e 54 6f 74 61 6c 3c 2f 74 64 3e 3c 74 64 3e 22 >Total</td><td>"
6bd0: 20 74 6f 74 20 22 3c 2f 74 64 3e 3c 2f 74 72 3e tot "</td></tr>
6be0: 3c 2f 74 61 62 6c 65 3e 22 29 0a 09 28 70 72 69 </table>")..(pri
6bf0: 6e 74 20 22 3c 2f 74 64 3e 3c 2f 74 64 3e 3c 2f nt "</td></td></
6c00: 74 72 3e 3c 2f 74 61 62 6c 65 3e 22 29 0a 09 0a tr></table>")...
6c10: 09 28 70 72 69 6e 74 20 22 3c 74 61 62 6c 65 20 .(print "<table
6c20: 63 65 6c 6c 73 70 61 63 69 6e 67 3d 5c 22 30 5c cellspacing=\"0\
6c30: 22 20 62 6f 72 64 65 72 3d 5c 22 31 5c 22 3e 22 " border=\"1\">"
6c40: 20 0a 09 20 20 20 20 20 20 20 22 3c 74 72 3e 3c .. "<tr><
6c50: 74 64 3e 49 74 65 6d 3c 2f 74 64 3e 3c 74 64 3e td>Item</td><td>
6c60: 53 74 61 74 65 3c 2f 74 64 3e 3c 74 64 3e 53 74 State</td><td>St
6c70: 61 74 75 73 3c 2f 74 64 3e 3c 74 64 3e 43 6f 6d atus</td><td>Com
6c80: 6d 65 6e 74 3c 2f 74 64 3e 22 0a 09 20 20 20 20 ment</td>"..
6c90: 20 20 20 6f 75 74 74 78 74 20 22 3c 2f 74 61 62 outtxt "</tab
6ca0: 6c 65 3e 3c 2f 62 6f 64 79 3e 3c 2f 68 74 6d 6c le></body></html
6cb0: 3e 22 29 0a 09 3b 3b 20 28 72 65 6c 65 61 73 65 >")..;; (release
6cc0: 2d 64 6f 74 2d 6c 6f 63 6b 20 6f 75 74 70 75 74 -dot-lock output
6cd0: 66 69 6c 65 6e 61 6d 65 29 0a 09 3b 3b 28 72 6d filename)..;;(rm
6ce0: 74 3a 75 70 64 61 74 65 2d 72 75 6e 2d 73 74 61 t:update-run-sta
6cf0: 74 73 20 0a 09 3b 3b 20 72 75 6e 2d 69 64 0a 09 ts ..;; run-id..
6d00: 3b 3b 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6d ;; (hash-table-m
6d10: 61 70 0a 09 3b 3b 20 20 73 74 61 74 65 2d 73 74 ap..;; state-st
6d20: 61 74 75 73 2d 63 6f 75 6e 74 73 0a 09 3b 3b 20 atus-counts..;;
6d30: 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 20 76 61 (lambda (key va
6d40: 6c 29 0a 09 3b 3b 09 28 61 70 70 65 6e 64 20 6b l)..;;.(append k
6d50: 65 79 20 28 6c 69 73 74 20 76 61 6c 29 29 29 29 ey (list val))))
6d60: 29 0a 09 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 )..))))..(define
6d70: 20 74 65 73 74 73 3a 63 73 73 2d 6a 73 63 72 69 tests:css-jscri
6d80: 70 74 2d 62 6c 6f 63 6b 0a 23 3c 3c 45 4f 46 0a pt-block.#<<EOF.
6d90: 3c 73 74 79 6c 65 20 74 79 70 65 3d 22 74 65 78 <style type="tex
6da0: 74 2f 63 73 73 22 3e 0a 75 6c 2e 4c 69 6e 6b 65 t/css">.ul.Linke
6db0: 64 4c 69 73 74 20 7b 20 64 69 73 70 6c 61 79 3a dList { display:
6dc0: 20 62 6c 6f 63 6b 3b 20 7d 0a 2f 2a 20 75 6c 2e block; }./* ul.
6dd0: 4c 69 6e 6b 65 64 4c 69 73 74 20 75 6c 20 7b 20 LinkedList ul {
6de0: 64 69 73 70 6c 61 79 3a 20 6e 6f 6e 65 3b 20 7d display: none; }
6df0: 20 2a 2f 0a 2e 48 61 6e 64 43 75 72 73 6f 72 53 */..HandCursorS
6e00: 74 79 6c 65 20 7b 20 63 75 72 73 6f 72 3a 20 70 tyle { cursor: p
6e10: 6f 69 6e 74 65 72 3b 20 63 75 72 73 6f 72 3a 20 ointer; cursor:
6e20: 68 61 6e 64 3b 20 7d 20 20 2f 2a 20 46 6f 72 20 hand; } /* For
6e30: 49 45 20 2a 2f 0a 74 68 20 7b 62 61 63 6b 67 72 IE */.th {backgr
6e40: 6f 75 6e 64 2d 63 6f 6c 6f 72 3a 20 23 38 63 38 ound-color: #8c8
6e50: 63 38 63 3b 7d 0a 74 64 2e 74 65 73 74 20 7b 62 c8c;}.td.test {b
6e60: 61 63 6b 67 72 6f 75 6e 64 2d 63 6f 6c 6f 72 3a ackground-color:
6e70: 20 23 64 39 64 62 64 64 3b 7d 0a 74 64 2e 50 41 #d9dbdd;}.td.PA
6e80: 53 53 20 7b 62 61 63 6b 67 72 6f 75 6e 64 2d 63 SS {background-c
6e90: 6f 6c 6f 72 3a 20 23 33 34 37 35 33 33 3b 7d 0a olor: #347533;}.
6ea0: 74 64 2e 46 41 49 4c 20 7b 62 61 63 6b 67 72 6f td.FAIL {backgro
6eb0: 75 6e 64 2d 63 6f 6c 6f 72 3a 20 23 63 63 32 38 und-color: #cc28
6ec0: 31 32 3b 7d 0a 74 64 2e 53 4b 49 50 7b 62 61 63 12;}.td.SKIP{bac
6ed0: 6b 67 72 6f 75 6e 64 2d 63 6f 6c 6f 72 3a 20 23 kground-color: #
6ee0: 46 46 44 37 33 33 3b 7d 0a 74 64 2e 57 41 52 4e FFD733;}.td.WARN
6ef0: 20 7b 62 61 63 6b 67 72 6f 75 6e 64 2d 63 6f 6c {background-col
6f00: 6f 72 3a 20 23 45 41 38 37 32 34 3b 7d 0a 74 64 or: #EA8724;}.td
6f10: 2e 57 41 49 56 45 44 20 7b 62 61 63 6b 67 72 6f .WAIVED {backgro
6f20: 75 6e 64 2d 63 6f 6c 6f 72 3a 20 23 38 33 38 41 und-color: #838A
6f30: 31 32 3b 7d 0a 74 64 2e 41 42 4f 52 54 7b 62 61 12;}.td.ABORT{ba
6f40: 63 6b 67 72 6f 75 6e 64 2d 63 6f 6c 6f 72 3a 20 ckground-color:
6f50: 23 45 41 32 34 42 37 3b 7d 0a 2e 50 41 53 53 20 #EA24B7;}..PASS
6f60: 2e 6c 69 6e 6b 2c 20 2e 53 4b 49 50 20 2e 6c 69 .link, .SKIP .li
6f70: 6e 6b 2c 20 2e 57 41 52 4e 20 2e 6c 69 6e 6b 2c nk, .WARN .link,
6f80: 2e 57 41 49 56 45 44 20 2e 6c 69 6e 6b 2c 2e 41 .WAIVED .link,.A
6f90: 42 4f 52 54 20 2e 6c 69 6e 6b 2c 20 2e 46 41 49 BORT .link, .FAI
6fa0: 4c 20 2e 6c 69 6e 6b 7b 63 6f 6c 6f 72 3a 20 23 L .link{color: #
6fb0: 46 46 46 46 46 46 3b 7d 0a 0a 0a 3c 2f 73 74 79 FFFFFF;}...</sty
6fc0: 6c 65 3e 0a 0a 0a 20 20 3c 73 63 72 69 70 74 20 le>... <script
6fd0: 74 79 70 65 3d 22 74 65 78 74 2f 4a 61 76 61 53 type="text/JavaS
6fe0: 63 72 69 70 74 22 3e 0a 0a 20 20 20 20 66 75 6e cript">.. fun
6ff0: 63 74 69 6f 6e 20 66 69 6c 74 65 72 73 6f 6d 65 ction filtersome
7000: 28 29 20 7b 0a 20 20 24 28 22 74 72 22 29 2e 73 () {. $("tr").s
7010: 68 6f 77 28 29 3b 0a 20 20 24 28 22 2e 74 65 73 how();. $(".tes
7020: 74 22 29 2e 66 69 6c 74 65 72 28 0a 20 20 20 20 t").filter(.
7030: 66 75 6e 63 74 69 6f 6e 28 29 20 7b 0a 20 20 20 function() {.
7040: 20 20 20 76 61 72 20 6e 61 6d 65 73 20 3d 20 24 var names = $
7050: 28 27 23 74 65 73 74 6e 61 6d 65 27 29 2e 76 61 ('#testname').va
7060: 6c 28 29 2e 73 70 6c 69 74 28 27 2c 27 29 3b 0a l().split(',');.
7070: 20 20 20 20 20 20 76 61 72 20 67 6f 6f 64 3d 31 var good=1
7080: 3b 0a 20 20 20 20 20 20 66 6f 72 20 28 76 61 72 ;. for (var
7090: 20 69 3d 30 2c 20 6c 65 6e 3d 6e 61 6d 65 73 2e i=0, len=names.
70a0: 6c 65 6e 67 74 68 3b 20 69 3c 6c 65 6e 3b 20 69 length; i<len; i
70b0: 2b 2b 29 20 7b 0a 20 20 20 20 20 20 20 20 76 61 ++) {. va
70c0: 72 20 75 6e 61 6d 65 3d 6e 61 6d 65 73 5b 69 5d r uname=names[i]
70d0: 3b 0a 20 20 20 20 20 20 20 20 63 6f 6e 73 6f 6c ;. consol
70e0: 65 2e 6c 6f 67 28 22 54 72 79 69 6e 67 20 74 6f e.log("Trying to
70f0: 20 63 68 65 63 6b 20 66 6f 72 20 22 20 2b 20 75 check for " + u
7100: 6e 61 6d 65 29 3b 20 0a 20 20 20 20 20 20 20 20 name); .
7110: 69 66 28 24 28 74 68 69 73 29 2e 74 65 78 74 28 if($(this).text(
7120: 29 2e 69 6e 64 65 78 4f 66 28 75 6e 61 6d 65 29 ).indexOf(uname)
7130: 20 21 3d 20 2d 31 29 20 7b 0a 20 20 20 20 20 20 != -1) {.
7140: 20 20 20 20 67 6f 6f 64 3d 20 30 3b 0a 20 20 20 good= 0;.
7150: 20 20 20 20 20 20 20 63 6f 6e 73 6f 6c 65 2e 6c console.l
7160: 6f 67 28 22 46 6f 75 6e 64 20 22 2b 75 6e 61 6d og("Found "+unam
7170: 65 29 3b 0a 20 20 20 20 20 20 20 20 7d 0a 20 20 e);. }.
7180: 20 20 20 20 7d 0a 20 20 20 20 20 20 72 65 74 75 }. retu
7190: 72 6e 20 67 6f 6f 64 3b 20 0a 20 20 20 20 7d 0a rn good; . }.
71a0: 20 20 29 2e 70 61 72 65 6e 74 28 29 2e 68 69 64 ).parent().hid
71b0: 65 28 29 3b 0a 2f 2f 20 20 24 28 22 2e 73 75 6d e();.// $(".sum
71c0: 22 29 2e 73 68 6f 77 28 29 3b 0a 7d 0a 20 20 0a ").show();.}. .
71d0: 20 20 20 20 2f 2f 20 41 64 64 20 74 68 69 73 20 // Add this
71e0: 74 6f 20 74 68 65 20 6f 6e 6c 6f 61 64 20 65 76 to the onload ev
71f0: 65 6e 74 20 6f 66 20 74 68 65 20 42 4f 44 59 20 ent of the BODY
7200: 65 6c 65 6d 65 6e 74 0a 20 20 20 20 66 75 6e 63 element. func
7210: 74 69 6f 6e 20 61 64 64 45 76 65 6e 74 73 28 29 tion addEvents()
7220: 20 7b 0a 20 20 20 20 20 20 61 63 74 69 76 61 74 {. activat
7230: 65 54 72 65 65 28 64 6f 63 75 6d 65 6e 74 2e 67 eTree(document.g
7240: 65 74 45 6c 65 6d 65 6e 74 42 79 49 64 28 22 4c etElementById("L
7250: 69 6e 6b 65 64 4c 69 73 74 31 22 29 29 3b 0a 20 inkedList1"));.
7260: 20 20 20 7d 0a 0a 20 20 20 20 2f 2f 20 54 68 69 }.. // Thi
7270: 73 20 66 75 6e 63 74 69 6f 6e 20 74 72 61 76 65 s function trave
7280: 72 73 65 73 20 74 68 65 20 6c 69 73 74 20 61 6e rses the list an
7290: 64 20 61 64 64 20 6c 69 6e 6b 73 20 0a 20 20 20 d add links .
72a0: 20 2f 2f 20 74 6f 20 6e 65 73 74 65 64 20 6c 69 // to nested li
72b0: 73 74 20 69 74 65 6d 73 0a 20 20 20 20 66 75 6e st items. fun
72c0: 63 74 69 6f 6e 20 61 63 74 69 76 61 74 65 54 72 ction activateTr
72d0: 65 65 28 6f 4c 69 73 74 29 20 7b 0a 20 20 20 20 ee(oList) {.
72e0: 20 20 2f 2f 20 43 6f 6c 6c 61 70 73 65 20 74 68 // Collapse th
72f0: 65 20 74 72 65 65 0a 20 20 20 20 20 20 66 6f 72 e tree. for
7300: 20 28 76 61 72 20 69 3d 30 3b 20 69 20 3c 20 6f (var i=0; i < o
7310: 4c 69 73 74 2e 67 65 74 45 6c 65 6d 65 6e 74 73 List.getElements
7320: 42 79 54 61 67 4e 61 6d 65 28 22 75 6c 22 29 2e ByTagName("ul").
7330: 6c 65 6e 67 74 68 3b 20 69 2b 2b 29 20 7b 0a 20 length; i++) {.
7340: 20 20 20 20 20 20 20 6f 4c 69 73 74 2e 67 65 74 oList.get
7350: 45 6c 65 6d 65 6e 74 73 42 79 54 61 67 4e 61 6d ElementsByTagNam
7360: 65 28 22 75 6c 22 29 5b 69 5d 2e 73 74 79 6c 65 e("ul")[i].style
7370: 2e 64 69 73 70 6c 61 79 3d 22 6e 6f 6e 65 22 3b .display="none";
7380: 20 20 20 20 20 20 20 20 20 20 20 20 0a 20 20 20 .
7390: 20 20 20 7d 20 20 20 20 20 20 20 20 20 20 20 20 }
73a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
73b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
73c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
73d0: 20 20 20 20 20 20 0a 20 20 20 20 20 20 2f 2f 20 . //
73e0: 41 64 64 20 74 68 65 20 63 6c 69 63 6b 2d 65 76 Add the click-ev
73f0: 65 6e 74 20 68 61 6e 64 6c 65 72 20 74 6f 20 74 ent handler to t
7400: 68 65 20 6c 69 73 74 20 69 74 65 6d 73 0a 20 20 he list items.
7410: 20 20 20 20 69 66 20 28 6f 4c 69 73 74 2e 61 64 if (oList.ad
7420: 64 45 76 65 6e 74 4c 69 73 74 65 6e 65 72 29 20 dEventListener)
7430: 7b 0a 20 20 20 20 20 20 20 20 6f 4c 69 73 74 2e {. oList.
7440: 61 64 64 45 76 65 6e 74 4c 69 73 74 65 6e 65 72 addEventListener
7450: 28 22 63 6c 69 63 6b 22 2c 20 74 6f 67 67 6c 65 ("click", toggle
7460: 42 72 61 6e 63 68 2c 20 66 61 6c 73 65 29 3b 0a Branch, false);.
7470: 20 20 20 20 20 20 7d 20 65 6c 73 65 20 69 66 20 } else if
7480: 28 6f 4c 69 73 74 2e 61 74 74 61 63 68 45 76 65 (oList.attachEve
7490: 6e 74 29 20 7b 20 2f 2f 20 46 6f 72 20 49 45 0a nt) { // For IE.
74a0: 20 20 20 20 20 20 20 20 6f 4c 69 73 74 2e 61 74 oList.at
74b0: 74 61 63 68 45 76 65 6e 74 28 22 6f 6e 63 6c 69 tachEvent("oncli
74c0: 63 6b 22 2c 20 74 6f 67 67 6c 65 42 72 61 6e 63 ck", toggleBranc
74d0: 68 29 3b 0a 20 20 20 20 20 20 7d 0a 20 20 20 20 h);. }.
74e0: 20 20 2f 2f 20 4d 61 6b 65 20 74 68 65 20 6e 65 // Make the ne
74f0: 73 74 65 64 20 69 74 65 6d 73 20 6c 6f 6f 6b 20 sted items look
7500: 6c 69 6b 65 20 6c 69 6e 6b 73 0a 20 20 20 20 20 like links.
7510: 20 61 64 64 4c 69 6e 6b 73 54 6f 42 72 61 6e 63 addLinksToBranc
7520: 68 65 73 28 6f 4c 69 73 74 29 3b 0a 20 20 20 20 hes(oList);.
7530: 7d 0a 0a 20 20 20 20 2f 2f 20 54 68 69 73 20 69 }.. // This i
7540: 73 20 74 68 65 20 63 6c 69 63 6b 2d 65 76 65 6e s the click-even
7550: 74 20 68 61 6e 64 6c 65 72 0a 20 20 20 20 66 75 t handler. fu
7560: 6e 63 74 69 6f 6e 20 74 6f 67 67 6c 65 42 72 61 nction toggleBra
7570: 6e 63 68 28 65 76 65 6e 74 29 20 7b 0a 20 20 20 nch(event) {.
7580: 20 20 20 76 61 72 20 6f 42 72 61 6e 63 68 2c 20 var oBranch,
7590: 63 53 75 62 42 72 61 6e 63 68 65 73 3b 0a 20 20 cSubBranches;.
75a0: 20 20 20 20 69 66 20 28 65 76 65 6e 74 2e 74 61 if (event.ta
75b0: 72 67 65 74 29 20 7b 0a 20 20 20 20 20 20 20 20 rget) {.
75c0: 6f 42 72 61 6e 63 68 20 3d 20 65 76 65 6e 74 2e oBranch = event.
75d0: 74 61 72 67 65 74 3b 0a 20 20 20 20 20 20 7d 20 target;. }
75e0: 65 6c 73 65 20 69 66 20 28 65 76 65 6e 74 2e 73 else if (event.s
75f0: 72 63 45 6c 65 6d 65 6e 74 29 20 7b 20 2f 2f 20 rcElement) { //
7600: 46 6f 72 20 49 45 0a 20 20 20 20 20 20 20 20 6f For IE. o
7610: 42 72 61 6e 63 68 20 3d 20 65 76 65 6e 74 2e 73 Branch = event.s
7620: 72 63 45 6c 65 6d 65 6e 74 3b 0a 20 20 20 20 20 rcElement;.
7630: 20 7d 0a 20 20 20 20 20 20 63 53 75 62 42 72 61 }. cSubBra
7640: 6e 63 68 65 73 20 3d 20 6f 42 72 61 6e 63 68 2e nches = oBranch.
7650: 67 65 74 45 6c 65 6d 65 6e 74 73 42 79 54 61 67 getElementsByTag
7660: 4e 61 6d 65 28 22 75 6c 22 29 3b 0a 20 20 20 20 Name("ul");.
7670: 20 20 69 66 20 28 63 53 75 62 42 72 61 6e 63 68 if (cSubBranch
7680: 65 73 2e 6c 65 6e 67 74 68 20 3e 20 30 29 20 7b es.length > 0) {
7690: 0a 20 20 20 20 20 20 20 20 69 66 20 28 63 53 75 . if (cSu
76a0: 62 42 72 61 6e 63 68 65 73 5b 30 5d 2e 73 74 79 bBranches[0].sty
76b0: 6c 65 2e 64 69 73 70 6c 61 79 20 3d 3d 20 22 62 le.display == "b
76c0: 6c 6f 63 6b 22 29 20 7b 0a 20 20 20 20 20 20 20 lock") {.
76d0: 20 20 20 63 53 75 62 42 72 61 6e 63 68 65 73 5b cSubBranches[
76e0: 30 5d 2e 73 74 79 6c 65 2e 64 69 73 70 6c 61 79 0].style.display
76f0: 20 3d 20 22 6e 6f 6e 65 22 3b 0a 20 20 20 20 20 = "none";.
7700: 20 20 20 7d 20 65 6c 73 65 20 7b 0a 20 20 20 20 } else {.
7710: 20 20 20 20 20 20 63 53 75 62 42 72 61 6e 63 68 cSubBranch
7720: 65 73 5b 30 5d 2e 73 74 79 6c 65 2e 64 69 73 70 es[0].style.disp
7730: 6c 61 79 20 3d 20 22 62 6c 6f 63 6b 22 3b 0a 20 lay = "block";.
7740: 20 20 20 20 20 20 20 7d 0a 20 20 20 20 20 20 7d }. }
7750: 0a 20 20 20 20 7d 0a 0a 20 20 20 20 2f 2f 20 54 . }.. // T
7760: 68 69 73 20 66 75 6e 63 74 69 6f 6e 20 6d 61 6b his function mak
7770: 65 73 20 6e 65 73 74 65 64 20 6c 69 73 74 20 69 es nested list i
7780: 74 65 6d 73 20 6c 6f 6f 6b 20 6c 69 6b 65 20 6c tems look like l
7790: 69 6e 6b 73 0a 20 20 20 20 66 75 6e 63 74 69 6f inks. functio
77a0: 6e 20 61 64 64 4c 69 6e 6b 73 54 6f 42 72 61 6e n addLinksToBran
77b0: 63 68 65 73 28 6f 4c 69 73 74 29 20 7b 0a 20 20 ches(oList) {.
77c0: 20 20 20 20 76 61 72 20 63 42 72 61 6e 63 68 65 var cBranche
77d0: 73 20 3d 20 6f 4c 69 73 74 2e 67 65 74 45 6c 65 s = oList.getEle
77e0: 6d 65 6e 74 73 42 79 54 61 67 4e 61 6d 65 28 22 mentsByTagName("
77f0: 6c 69 22 29 3b 0a 20 20 20 20 20 20 76 61 72 20 li");. var
7800: 69 2c 20 6e 2c 20 63 53 75 62 42 72 61 6e 63 68 i, n, cSubBranch
7810: 65 73 3b 0a 20 20 20 20 20 20 69 66 20 28 63 42 es;. if (cB
7820: 72 61 6e 63 68 65 73 2e 6c 65 6e 67 74 68 20 3e ranches.length >
7830: 20 30 29 20 7b 0a 20 20 20 20 20 20 20 20 66 6f 0) {. fo
7840: 72 20 28 69 3d 30 2c 20 6e 20 3d 20 63 42 72 61 r (i=0, n = cBra
7850: 6e 63 68 65 73 2e 6c 65 6e 67 74 68 3b 20 69 20 nches.length; i
7860: 3c 20 6e 3b 20 69 2b 2b 29 20 7b 0a 20 20 20 20 < n; i++) {.
7870: 20 20 20 20 20 20 63 53 75 62 42 72 61 6e 63 68 cSubBranch
7880: 65 73 20 3d 20 63 42 72 61 6e 63 68 65 73 5b 69 es = cBranches[i
7890: 5d 2e 67 65 74 45 6c 65 6d 65 6e 74 73 42 79 54 ].getElementsByT
78a0: 61 67 4e 61 6d 65 28 22 75 6c 22 29 3b 0a 20 20 agName("ul");.
78b0: 20 20 20 20 20 20 20 20 69 66 20 28 63 53 75 62 if (cSub
78c0: 42 72 61 6e 63 68 65 73 2e 6c 65 6e 67 74 68 20 Branches.length
78d0: 3e 20 30 29 20 7b 0a 20 20 20 20 20 20 20 20 20 > 0) {.
78e0: 20 20 20 61 64 64 4c 69 6e 6b 73 54 6f 42 72 61 addLinksToBra
78f0: 6e 63 68 65 73 28 63 53 75 62 42 72 61 6e 63 68 nches(cSubBranch
7900: 65 73 5b 30 5d 29 3b 0a 20 20 20 20 20 20 20 20 es[0]);.
7910: 20 20 20 20 63 42 72 61 6e 63 68 65 73 5b 69 5d cBranches[i]
7920: 2e 63 6c 61 73 73 4e 61 6d 65 20 3d 20 22 48 61 .className = "Ha
7930: 6e 64 43 75 72 73 6f 72 53 74 79 6c 65 22 3b 0a ndCursorStyle";.
7940: 20 20 20 20 20 20 20 20 20 20 20 20 63 42 72 61 cBra
7950: 6e 63 68 65 73 5b 69 5d 2e 73 74 79 6c 65 2e 63 nches[i].style.c
7960: 6f 6c 6f 72 20 3d 20 22 62 6c 75 65 22 3b 0a 20 olor = "blue";.
7970: 20 20 20 20 20 20 20 20 20 20 20 63 53 75 62 42 cSubB
7980: 72 61 6e 63 68 65 73 5b 30 5d 2e 73 74 79 6c 65 ranches[0].style
7990: 2e 63 6f 6c 6f 72 20 3d 20 22 62 6c 61 63 6b 22 .color = "black"
79a0: 3b 0a 20 20 20 20 20 20 20 20 20 20 20 20 63 53 ;. cS
79b0: 75 62 42 72 61 6e 63 68 65 73 5b 30 5d 2e 73 74 ubBranches[0].st
79c0: 79 6c 65 2e 63 75 72 73 6f 72 20 3d 20 22 61 75 yle.cursor = "au
79d0: 74 6f 22 3b 0a 20 20 20 20 20 20 20 20 20 20 7d to";. }
79e0: 0a 20 20 20 20 20 20 20 20 7d 0a 20 20 20 20 20 . }.
79f0: 20 7d 0a 20 20 20 20 7d 0a 20 20 3c 2f 73 63 72 }. }. </scr
7a00: 69 70 74 3e 0a 45 4f 46 0a 29 0a 0a 28 64 65 66 ipt>.EOF.)..(def
7a10: 69 6e 65 20 74 65 73 74 73 3a 63 73 73 2d 6a 73 ine tests:css-js
7a20: 63 72 69 70 74 2d 62 6c 6f 63 6b 2d 64 79 6e 61 cript-block-dyna
7a30: 6d 69 63 20 0a 23 3c 3c 45 4f 46 0a 20 20 20 20 mic .#<<EOF.
7a40: 20 20 20 20 20 20 20 3c 73 63 72 69 70 74 20 73 <script s
7a50: 72 63 3d 20 2e 2f 6a 71 75 65 72 79 33 2e 31 2e rc= ./jquery3.1.
7a60: 30 2e 6a 73 3e 3c 2f 73 63 72 69 70 74 3e 20 0a 0.js></script> .
7a70: 45 4f 46 0a 29 0a 0a 28 64 65 66 69 6e 65 20 20 EOF.)..(define
7a80: 28 74 65 73 74 3a 6a 73 2d 62 6c 6f 63 6b 20 6a (test:js-block j
7a90: 61 76 61 73 63 72 69 70 74 2d 6c 69 62 29 0a 20 avascript-lib).
7aa0: 20 20 28 63 6f 6e 63 20 20 22 3c 73 63 72 69 70 (conc "<scrip
7ab0: 74 20 73 72 63 3d 22 20 6a 61 76 61 73 63 72 69 t src=" javascri
7ac0: 70 74 2d 6c 69 62 20 22 3e 3c 2f 73 63 72 69 70 pt-lib "></scrip
7ad0: 74 3e 22 20 29 29 0a 0a 0a 28 64 65 66 69 6e 65 t>" ))...(define
7ae0: 20 74 65 73 74 73 3a 63 73 73 2d 6a 73 63 72 69 tests:css-jscri
7af0: 70 74 2d 62 6c 6f 63 6b 2d 73 74 61 74 69 63 20 pt-block-static
7b00: 28 74 65 73 74 3a 6a 73 2d 62 6c 6f 63 6b 20 2a (test:js-block *
7b10: 6a 61 76 61 2d 73 63 72 69 70 74 2d 6c 69 62 2a java-script-lib*
7b20: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 ))..(define (tes
7b30: 74 73 3a 63 73 73 2d 6a 73 63 72 69 70 74 2d 62 ts:css-jscript-b
7b40: 6c 6f 63 6b 2d 63 6f 6e 64 20 64 79 6e 61 6d 69 lock-cond dynami
7b50: 63 29 20 0a 20 20 20 20 20 20 28 69 66 20 28 65 c) . (if (e
7b60: 71 75 61 6c 3f 20 64 79 6e 61 6d 69 63 20 20 23 qual? dynamic #
7b70: 74 29 0a 20 20 20 20 20 20 20 74 65 73 74 73 3a t). tests:
7b80: 63 73 73 2d 6a 73 63 72 69 70 74 2d 62 6c 6f 63 css-jscript-bloc
7b90: 6b 2d 64 79 6e 61 6d 69 63 0a 20 20 20 20 20 20 k-dynamic.
7ba0: 20 74 65 73 74 73 3a 63 73 73 2d 6a 73 63 72 69 tests:css-jscri
7bb0: 70 74 2d 62 6c 6f 63 6b 2d 73 74 61 74 69 63 29 pt-block-static)
7bc0: 29 0a 0a 20 20 20 20 20 20 20 0a 28 64 65 66 69 ).. .(defi
7bd0: 6e 65 20 28 74 65 73 74 73 3a 72 75 6e 2d 72 65 ne (tests:run-re
7be0: 63 6f 72 64 2d 3e 74 65 73 74 2d 70 61 74 68 20 cord->test-path
7bf0: 72 75 6e 20 6e 75 6d 6b 65 79 73 29 0a 20 20 20 run numkeys).
7c00: 28 61 70 70 65 6e 64 20 28 74 61 6b 65 20 28 76 (append (take (v
7c10: 65 63 74 6f 72 2d 3e 6c 69 73 74 20 72 75 6e 29 ector->list run)
7c20: 20 6e 75 6d 6b 65 79 73 29 0a 09 20 20 20 28 6c numkeys).. (l
7c30: 69 73 74 20 28 76 65 63 74 6f 72 2d 72 65 66 20 ist (vector-ref
7c40: 72 75 6e 20 28 2b 20 31 20 6e 75 6d 6b 65 79 73 run (+ 1 numkeys
7c50: 29 29 29 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 )))))...(define
7c60: 28 74 65 73 74 73 3a 67 65 74 2d 72 65 73 74 2d (tests:get-rest-
7c70: 64 61 74 61 20 72 75 6e 73 20 68 65 61 64 65 72 data runs header
7c80: 20 6e 75 6d 6b 65 79 73 29 0a 20 20 20 28 6c 65 numkeys). (le
7c90: 74 20 28 28 72 65 73 68 20 28 6d 61 6b 65 2d 68 t ((resh (make-h
7ca0: 61 73 68 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 ash-table))).
7cb0: 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 (for-each. (
7cc0: 6c 61 6d 62 64 61 20 28 72 75 6e 29 0a 20 20 20 lambda (run).
7cd0: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 72 75 6e (let* ((run
7ce0: 2d 69 64 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 -id (db:get-valu
7cf0: 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 e-by-header run
7d00: 68 65 61 64 65 72 20 22 69 64 22 29 29 0a 20 20 header "id")).
7d10: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 75 (ru
7d20: 6e 2d 64 69 72 20 20 20 20 20 20 28 74 65 73 74 n-dir (test
7d30: 73 3a 72 75 6e 2d 72 65 63 6f 72 64 2d 3e 74 65 s:run-record->te
7d40: 73 74 2d 70 61 74 68 20 72 75 6e 20 6e 75 6d 6b st-path run numk
7d50: 65 79 73 29 29 0a 09 20 20 20 20 20 20 20 28 74 eys)).. (t
7d60: 65 73 74 2d 64 61 74 61 20 20 20 20 28 72 6d 74 est-data (rmt
7d70: 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 :get-tests-for-r
7d80: 75 6e 0a 09 09 09 09 20 20 20 72 75 6e 2d 69 64 un..... run-id
7d90: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
7da0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7db0: 20 20 20 20 22 25 22 20 20 20 20 20 20 20 3b 3b "%" ;;
7dc0: 20 74 65 73 74 6e 61 6d 65 70 61 74 74 0a 09 09 testnamepatt...
7dd0: 09 09 20 20 20 27 28 29 20 20 20 20 20 20 20 20 .. '()
7de0: 3b 3b 20 73 74 61 74 65 73 0a 09 09 09 09 20 20 ;; states.....
7df0: 20 27 28 29 20 20 20 20 20 20 20 20 3b 3b 20 73 '() ;; s
7e00: 74 61 74 75 73 65 73 0a 09 09 09 09 20 20 20 23 tatuses..... #
7e10: 66 20 20 20 20 20 20 20 20 20 3b 3b 20 6f 66 66 f ;; off
7e20: 73 65 74 0a 09 09 09 09 20 20 20 23 66 20 20 20 set..... #f
7e30: 20 20 20 20 20 20 3b 3b 20 6e 75 6d 2d 74 6f 2d ;; num-to-
7e40: 67 65 74 0a 09 09 09 09 20 20 20 23 66 20 20 20 get..... #f
7e50: 20 20 20 20 20 20 3b 3b 20 68 69 64 65 2f 6e 6f ;; hide/no
7e60: 74 2d 68 69 64 65 0a 09 09 09 09 20 20 20 23 66 t-hide..... #f
7e70: 20 20 20 20 20 20 20 20 20 3b 3b 20 73 6f 72 74 ;; sort
7e80: 2d 62 79 0a 09 09 09 09 20 20 20 23 66 20 20 20 -by..... #f
7e90: 20 20 20 20 20 20 3b 3b 20 73 6f 72 74 2d 6f 72 ;; sort-or
7ea0: 64 65 72 0a 09 09 09 09 20 20 20 23 66 20 20 20 der..... #f
7eb0: 20 20 20 20 20 20 3b 3b 20 27 73 68 6f 72 74 6c ;; 'shortl
7ec0: 69 73 74 20 20 20 20 20 20 20 20 20 20 20 20 20 ist
7ed0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b ;;
7ee0: 20 71 72 79 74 79 70 65 0a 20 20 20 20 20 20 20 qrytype.
7ef0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7f00: 20 20 20 20 20 20 20 20 20 20 20 20 30 20 20 20 0
7f10: 20 20 20 20 20 20 3b 3b 20 6c 61 73 74 20 75 70 ;; last up
7f20: 64 61 74 65 0a 09 09 09 09 20 20 20 23 66 29 29 date..... #f))
7f30: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 0a 20 ). .
7f40: 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 70 20 (map
7f50: 28 6c 61 6d 62 64 61 20 28 74 65 73 74 29 0a 20 (lambda (test).
7f60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7f70: 28 6c 65 74 2a 20 28 28 74 65 73 74 2d 6e 61 6d (let* ((test-nam
7f80: 65 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 65 e (vector-ref te
7f90: 73 74 20 32 29 29 0a 20 20 20 20 20 20 20 20 20 st 2)).
7fa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
7fb0: 74 65 73 74 2d 68 74 6d 6c 2d 70 61 74 68 20 28 test-html-path (
7fc0: 63 6f 6e 63 20 28 76 65 63 74 6f 72 2d 72 65 66 conc (vector-ref
7fd0: 20 74 65 73 74 20 31 30 29 20 22 2f 22 20 28 76 test 10) "/" (v
7fe0: 65 63 74 6f 72 2d 72 65 66 20 74 65 73 74 20 31 ector-ref test 1
7ff0: 33 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 3))).
8000: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 74 65 (te
8010: 73 74 2d 69 74 65 6d 20 28 63 6f 6e 63 20 74 65 st-item (conc te
8020: 73 74 2d 6e 61 6d 65 20 22 3a 22 20 28 76 65 63 st-name ":" (vec
8030: 74 6f 72 2d 72 65 66 20 74 65 73 74 20 31 31 29 tor-ref test 11)
8040: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
8050: 20 20 20 20 20 20 20 20 20 20 20 28 74 65 73 74 (test
8060: 2d 73 74 61 74 75 73 20 28 76 65 63 74 6f 72 2d -status (vector-
8070: 72 65 66 20 74 65 73 74 20 34 29 29 29 0a 20 20 ref test 4))).
8080: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8090: 20 20 20 20 20 20 20 0a 20 20 20 20 20 20 20 20 .
80a0: 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 (if (not
80b0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
80c0: 2f 64 65 66 61 75 6c 74 20 72 65 73 68 20 74 65 /default resh te
80d0: 73 74 2d 6e 61 6d 65 20 20 23 66 29 29 0a 20 20 st-name #f)).
80e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
80f0: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
8100: 73 65 74 21 20 72 65 73 68 20 74 65 73 74 2d 6e set! resh test-n
8110: 61 6d 65 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 ame (make-hash
8120: 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 20 20 20 -table))).
8130: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e (if (n
8140: 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 ot (hash-table-r
8150: 65 66 2f 64 65 66 61 75 6c 74 20 28 68 61 73 68 ef/default (hash
8160: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
8170: 6c 74 20 72 65 73 68 20 74 65 73 74 2d 6e 61 6d lt resh test-nam
8180: 65 20 20 23 66 29 20 20 74 65 73 74 2d 69 74 65 e #f) test-ite
8190: 6d 20 20 23 66 29 29 0a 20 20 20 20 20 20 20 20 m #f)).
81a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
81b0: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
81c0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
81d0: 64 65 66 61 75 6c 74 20 72 65 73 68 20 74 65 73 default resh tes
81e0: 74 2d 6e 61 6d 65 20 20 23 66 29 20 74 65 73 74 t-name #f) test
81f0: 2d 69 74 65 6d 20 20 20 28 6d 61 6b 65 2d 68 61 -item (make-ha
8200: 73 68 2d 74 61 62 6c 65 29 29 29 20 0a 20 20 20 sh-table))) .
8210: 20 20 20 20 20 20 20 20 20 20 20 20 28 68 61 73 (has
8220: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 20 28 68 h-table-set! (h
8230: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
8240: 66 61 75 6c 74 20 28 68 61 73 68 2d 74 61 62 6c fault (hash-tabl
8250: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 72 65 e-ref/default re
8260: 73 68 20 74 65 73 74 2d 6e 61 6d 65 20 20 23 66 sh test-name #f
8270: 29 20 74 65 73 74 2d 69 74 65 6d 20 23 66 29 20 ) test-item #f)
8280: 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 74 65 73 run-id (list tes
8290: 74 2d 73 74 61 74 75 73 20 74 65 73 74 2d 68 74 t-status test-ht
82a0: 6d 6c 2d 70 61 74 68 29 29 29 29 20 0a 20 20 20 ml-path)))) .
82b0: 20 20 20 20 20 74 65 73 74 2d 64 61 74 61 29 29 test-data))
82c0: 29 0a 20 20 20 20 20 20 72 75 6e 73 29 0a 20 20 ). runs).
82d0: 20 72 65 73 68 29 29 0a 0a 0a 3b 3b 20 74 65 73 resh))...;; tes
82e0: 74 73 3a 67 65 6e 72 61 74 65 20 64 61 73 68 62 ts:genrate dashb
82f0: 6f 61 72 64 20 62 6f 64 79 20 0a 3b 3b 0a 0a 28 oard body .;;..(
8300: 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 64 61 define (tests:da
8310: 73 68 62 6f 61 72 64 2d 62 6f 64 79 20 70 61 67 shboard-body pag
8320: 65 20 70 67 2d 73 69 7a 65 20 6b 65 79 73 20 6e e pg-size keys n
8330: 75 6d 6b 65 79 73 20 20 74 6f 74 61 6c 2d 72 75 umkeys total-ru
8340: 6e 73 20 6c 69 6e 6b 74 72 65 65 20 61 72 65 61 ns linktree area
8350: 2d 6e 61 6d 65 20 67 65 74 2d 70 72 65 76 2d 6c -name get-prev-l
8360: 69 6e 6b 73 20 67 65 74 2d 6e 65 78 74 2d 6c 69 inks get-next-li
8370: 6e 6b 73 20 66 6c 61 67 20 72 75 6e 2d 70 61 74 nks flag run-pat
8380: 74 20 74 61 72 67 65 74 2d 70 61 74 74 29 0a 20 t target-patt).
8390: 20 28 6c 65 74 2a 20 28 28 73 74 61 72 74 20 28 (let* ((start (
83a0: 2a 20 70 61 67 65 20 70 67 2d 73 69 7a 65 29 29 * page pg-size))
83b0: 20 0a 09 09 09 09 09 3b 28 72 75 6e 73 64 61 74 ......;(runsdat
83c0: 20 20 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e 73 (rmt:get-runs
83d0: 20 22 25 22 20 70 67 2d 73 69 7a 65 20 73 74 61 "%" pg-size sta
83e0: 72 74 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 rt (map (lambda
83f0: 28 78 29 28 6c 69 73 74 20 78 20 22 25 22 29 29 (x)(list x "%"))
8400: 20 6b 65 79 73 29 29 29 0a 20 20 20 20 20 20 20 keys))).
8410: 20 20 28 72 75 6e 73 64 61 74 20 20 20 28 72 6d (runsdat (rm
8420: 74 3a 67 65 74 2d 72 75 6e 73 2d 62 79 2d 70 61 t:get-runs-by-pa
8430: 74 74 20 20 6b 65 79 73 20 72 75 6e 2d 70 61 74 tt keys run-pat
8440: 74 20 74 61 72 67 65 74 2d 70 61 74 74 20 73 74 t target-patt st
8450: 61 72 74 20 70 67 2d 73 69 7a 65 20 23 66 20 30 art pg-size #f 0
8460: 20 73 6f 72 74 2d 6f 72 64 65 72 3a 20 22 64 65 sort-order: "de
8470: 73 63 22 29 29 0a 09 09 09 09 09 3b 20 64 62 3a sc"))......; db:
8480: 67 65 74 2d 72 75 6e 73 2d 62 79 2d 70 61 74 74 get-runs-by-patt
8490: 20 20 20 6b 65 79 73 20 72 75 6e 6e 61 6d 65 70 keys runnamep
84a0: 61 74 74 20 74 61 72 67 70 61 74 74 20 6f 66 66 att targpatt off
84b0: 73 65 74 20 6c 69 6d 69 74 20 66 69 65 6c 64 73 set limit fields
84c0: 20 6c 61 73 74 2d 75 70 64 61 74 65 20 20 20 0a last-update .
84d0: 09 20 28 68 65 61 64 65 72 20 20 20 20 28 76 65 . (header (ve
84e0: 63 74 6f 72 2d 72 65 66 20 72 75 6e 73 64 61 74 ctor-ref runsdat
84f0: 20 30 29 29 0a 09 20 28 72 75 6e 73 20 20 20 20 0)).. (runs
8500: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 75 (vector-ref ru
8510: 6e 73 64 61 74 20 31 29 29 0a 20 20 20 20 20 20 nsdat 1)).
8520: 20 20 20 28 63 74 72 20 30 29 0a 20 20 20 20 20 (ctr 0).
8530: 20 20 20 20 28 74 65 73 74 2d 72 75 6e 73 2d 68 (test-runs-h
8540: 61 73 68 20 28 74 65 73 74 73 3a 67 65 74 2d 72 ash (tests:get-r
8550: 65 73 74 2d 64 61 74 61 20 72 75 6e 73 20 68 65 est-data runs he
8560: 61 64 65 72 20 6e 75 6d 6b 65 79 73 29 29 0a 20 ader numkeys)).
8570: 20 20 20 20 20 20 20 20 28 74 65 73 74 2d 6c 69 (test-li
8580: 73 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b st (hash-table-k
8590: 65 79 73 20 74 65 73 74 2d 72 75 6e 73 2d 68 61 eys test-runs-ha
85a0: 73 68 29 29 29 20 0a 20 20 20 20 0a 20 20 20 20 sh))) . .
85b0: 28 73 3a 68 74 6d 6c 20 74 65 73 74 73 3a 63 73 (s:html tests:cs
85c0: 73 2d 6a 73 63 72 69 70 74 2d 62 6c 6f 63 6b 20 s-jscript-block
85d0: 28 74 65 73 74 73 3a 63 73 73 2d 6a 73 63 72 69 (tests:css-jscri
85e0: 70 74 2d 62 6c 6f 63 6b 2d 63 6f 6e 64 20 66 6c pt-block-cond fl
85f0: 61 67 29 0a 09 20 20 20 20 28 73 3a 74 69 74 6c ag).. (s:titl
8600: 65 20 22 53 75 6d 6d 61 72 79 20 66 6f 72 20 22 e "Summary for "
8610: 20 61 72 65 61 2d 6e 61 6d 65 29 0a 09 20 20 20 area-name)..
8620: 20 28 73 3a 62 6f 64 79 20 27 6f 6e 6c 6f 61 64 (s:body 'onload
8630: 20 22 61 64 64 45 76 65 6e 74 73 28 29 3b 22 0a "addEvents();".
8640: 09 09 20 20 20 20 28 67 65 74 2d 70 72 65 76 2d .. (get-prev-
8650: 6c 69 6e 6b 73 20 70 61 67 65 20 6c 69 6e 6b 74 links page linkt
8660: 72 65 65 29 0a 09 09 20 20 20 20 28 67 65 74 2d ree)... (get-
8670: 6e 65 78 74 2d 6c 69 6e 6b 73 20 70 61 67 65 20 next-links page
8680: 6c 69 6e 6b 74 72 65 65 20 74 6f 74 61 6c 2d 72 linktree total-r
8690: 75 6e 73 29 0a 09 09 20 20 20 20 0a 09 09 20 20 uns)... ...
86a0: 20 20 28 73 3a 68 31 20 22 53 75 6d 6d 61 72 79 (s:h1 "Summary
86b0: 20 66 6f 72 20 22 20 61 72 65 61 2d 6e 61 6d 65 for " area-name
86c0: 29 0a 09 09 20 20 20 20 28 73 3a 68 33 20 22 46 )... (s:h3 "F
86d0: 69 6c 74 65 72 22 20 29 0a 09 09 20 20 20 20 28 ilter" )... (
86e0: 73 3a 69 6e 70 75 74 20 27 74 79 70 65 20 22 74 s:input 'type "t
86f0: 65 78 74 22 20 20 27 6e 61 6d 65 20 22 74 65 73 ext" 'name "tes
8700: 74 6e 61 6d 65 22 20 27 69 64 20 22 74 65 73 74 tname" 'id "test
8710: 6e 61 6d 65 22 20 27 6c 65 6e 67 74 68 20 22 33 name" 'length "3
8720: 30 22 20 27 6f 6e 6b 65 79 75 70 20 22 66 69 6c 0" 'onkeyup "fil
8730: 74 65 72 73 6f 6d 65 28 29 22 29 0a 09 09 20 20 tersome()")...
8740: 20 20 3b 3b 20 74 6f 70 20 6c 69 73 74 0a 09 09 ;; top list...
8750: 20 20 20 20 0a 09 09 20 20 20 20 28 73 3a 74 61 ... (s:ta
8760: 62 6c 65 20 27 69 64 20 22 4c 69 6e 6b 65 64 4c ble 'id "LinkedL
8770: 69 73 74 31 22 20 27 62 6f 72 64 65 72 20 22 31 ist1" 'border "1
8780: 22 20 27 63 65 6c 6c 73 70 61 63 69 6e 67 20 30 " 'cellspacing 0
8790: 0a 09 09 09 20 20 20 20 20 28 6d 61 70 20 28 6c .... (map (l
87a0: 61 6d 62 64 61 20 28 6b 65 79 29 0a 09 09 09 09 ambda (key).....
87b0: 20 20 20 20 28 6c 65 74 2a 20 28 28 72 65 73 20 (let* ((res
87c0: 28 73 3a 74 72 20 27 63 6c 61 73 73 20 22 73 6f (s:tr 'class "so
87d0: 6d 65 74 68 69 6e 67 22 20 0a 09 09 09 09 09 09 mething" .......
87e0: 20 20 20 20 20 20 28 73 3a 74 68 20 6b 65 79 20 (s:th key
87f0: 29 0a 09 09 09 09 09 09 20 20 20 20 20 20 28 6d )....... (m
8800: 61 70 20 28 6c 61 6d 62 64 61 20 28 72 75 6e 29 ap (lambda (run)
8810: 0a 09 09 09 09 09 09 09 20 20 20 20 20 28 73 3a ........ (s:
8820: 74 68 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 th (vector-ref
8830: 72 75 6e 20 63 74 72 29 29 29 0a 09 09 09 09 09 run ctr)))......
8840: 09 09 20 20 20 72 75 6e 73 29 29 29 29 0a 09 09 .. runs))))...
8850: 09 09 20 20 20 20 20 20 28 73 65 74 21 20 63 74 .. (set! ct
8860: 72 20 28 2b 20 63 74 72 20 31 29 29 0a 09 09 09 r (+ ctr 1))....
8870: 09 20 20 20 20 20 20 72 65 73 29 29 0a 09 09 09 . res))....
8880: 09 20 20 6b 65 79 73 29 0a 09 09 09 20 20 20 20 . keys)....
8890: 20 28 73 3a 74 72 0a 09 09 09 20 20 20 20 20 20 (s:tr....
88a0: 28 73 3a 74 68 20 22 52 75 6e 20 4e 61 6d 65 22 (s:th "Run Name"
88b0: 29 0a 09 09 09 20 20 20 20 20 20 28 6d 61 70 20 ).... (map
88c0: 28 6c 61 6d 62 64 61 20 28 72 75 6e 29 0a 09 09 (lambda (run)...
88d0: 09 09 20 20 20 20 20 28 73 3a 74 68 20 28 64 62 .. (s:th (db
88e0: 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 :get-value-by-he
88f0: 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 ader run header
8900: 22 72 75 6e 6e 61 6d 65 22 29 29 29 0a 09 09 09 "runname")))....
8910: 09 20 20 20 72 75 6e 73 29 29 0a 09 09 09 20 20 . runs))....
8920: 20 20 20 0a 09 09 09 20 20 20 20 20 28 6d 61 70 .... (map
8930: 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 2d 6e (lambda (test-n
8940: 61 6d 65 29 0a 09 09 09 09 20 20 20 20 28 6c 65 ame)..... (le
8950: 74 2a 20 28 28 69 74 65 6d 2d 68 61 73 68 20 28 t* ((item-hash (
8960: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
8970: 65 66 61 75 6c 74 20 74 65 73 74 2d 72 75 6e 73 efault test-runs
8980: 2d 68 61 73 68 20 74 65 73 74 2d 6e 61 6d 65 20 -hash test-name
8990: 20 23 66 29 29 0a 09 09 09 09 09 20 20 20 28 69 #f))...... (i
89a0: 74 65 6d 2d 6b 65 79 73 20 28 73 6f 72 74 20 28 tem-keys (sort (
89b0: 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 hash-table-keys
89c0: 69 74 65 6d 2d 68 61 73 68 29 20 73 74 72 69 6e item-hash) strin
89d0: 67 3c 3d 3f 29 29 29 20 0a 09 09 09 09 20 20 20 g<=?))) .....
89e0: 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 (map (lambda
89f0: 28 69 74 65 6d 2d 6e 61 6d 65 29 20 20 0a 20 20 (item-name) .
8a00: 09 09 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ..
8a10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
8a20: 6c 65 74 2a 20 28 28 72 65 73 20 28 73 3a 74 72 let* ((res (s:tr
8a30: 20 20 27 63 6c 61 73 73 20 69 74 65 6d 2d 6e 61 'class item-na
8a40: 6d 65 0a 09 09 09 09 09 09 09 09 28 73 3a 74 64 me.........(s:td
8a50: 20 20 69 74 65 6d 2d 6e 61 6d 65 20 27 63 6c 61 item-name 'cla
8a60: 73 73 20 22 74 65 73 74 22 20 29 0a 09 09 09 09 ss "test" ).....
8a70: 09 09 09 09 28 6d 61 70 20 28 6c 61 6d 62 64 61 ....(map (lambda
8a80: 20 28 72 75 6e 29 0a 09 09 09 09 09 09 09 09 20 (run).........
8a90: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 72 75 (let* ((ru
8aa0: 6e 2d 74 65 73 74 20 28 68 61 73 68 2d 74 61 62 n-test (hash-tab
8ab0: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 69 le-ref/default i
8ac0: 74 65 6d 2d 68 61 73 68 20 69 74 65 6d 2d 6e 61 tem-hash item-na
8ad0: 6d 65 20 20 23 66 29 29 0a 09 09 09 09 09 09 09 me #f))........
8ae0: 09 09 20 20 20 20 20 20 28 72 75 6e 2d 69 64 20 .. (run-id
8af0: 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 (db:get-value-by
8b00: 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 -header run head
8b10: 65 72 20 22 69 64 22 29 29 0a 09 09 09 09 09 09 er "id")).......
8b20: 09 09 09 20 20 20 20 20 20 28 72 65 73 75 6c 74 ... (result
8b30: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
8b40: 2f 64 65 66 61 75 6c 74 20 72 75 6e 2d 74 65 73 /default run-tes
8b50: 74 20 72 75 6e 2d 69 64 20 22 6e 2f 61 22 29 29 t run-id "n/a"))
8b60: 0a 09 09 09 09 09 3b 28 72 65 6c 61 74 69 76 65 ......;(relative
8b70: 2d 70 61 74 68 20 28 67 65 74 2d 72 65 6c 61 74 -path (get-relat
8b80: 69 76 65 2d 70 61 74 68 29 29 20 0a 09 09 09 09 ive-path)) .....
8b90: 09 09 09 09 09 20 20 20 20 20 20 28 73 74 61 74 ..... (stat
8ba0: 75 73 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 us (if (string?
8bb0: 72 65 73 75 6c 74 29 0a 09 09 09 09 09 09 09 09 result).........
8bc0: 09 09 09 20 20 72 65 73 75 6c 74 0a 09 09 09 09 ... result.....
8bd0: 09 09 09 09 09 09 09 20 20 28 63 61 72 20 72 65 ....... (car re
8be0: 73 75 6c 74 29 29 29 0a 09 09 09 09 09 09 09 09 sult))).........
8bf0: 09 20 20 20 20 20 20 28 6c 69 6e 6b 20 28 69 66 . (link (if
8c00: 20 28 73 74 72 69 6e 67 3f 20 72 65 73 75 6c 74 (string? result
8c10: 29 0a 09 09 09 09 09 09 09 09 09 09 09 72 65 73 )............res
8c20: 75 6c 74 0a 09 09 09 09 09 09 09 09 09 09 09 28 ult............(
8c30: 69 66 20 28 65 71 75 61 6c 3f 20 66 6c 61 67 20 if (equal? flag
8c40: 23 74 29 20 0a 09 09 09 09 09 09 09 09 09 09 09 #t) ............
8c50: 20 20 20 20 28 73 3a 61 20 28 63 61 72 20 72 65 (s:a (car re
8c60: 73 75 6c 74 29 20 27 68 72 65 66 20 28 63 6f 6e sult) 'href (con
8c70: 63 20 22 2e 2f 74 65 73 74 5f 6c 6f 67 3f 72 75 c "./test_log?ru
8c80: 6e 69 64 3d 22 20 72 75 6e 2d 69 64 20 22 26 74 nid=" run-id "&t
8c90: 65 73 74 6e 61 6d 65 3d 22 20 20 69 74 65 6d 2d estname=" item-
8ca0: 6e 61 6d 65 20 29 29 0a 09 09 09 09 09 09 09 09 name )).........
8cb0: 09 09 09 20 20 20 20 28 73 3a 61 20 28 63 61 72 ... (s:a (car
8cc0: 20 72 65 73 75 6c 74 29 20 27 68 72 65 66 20 28 result) 'href (
8cd0: 73 74 72 69 6e 67 2d 73 75 62 73 74 69 74 75 74 string-substitut
8ce0: 65 20 20 28 63 6f 6e 63 20 6c 69 6e 6b 74 72 65 e (conc linktre
8cf0: 65 20 22 2f 22 29 20 20 22 22 20 28 63 61 64 72 e "/") "" (cadr
8d00: 20 72 65 73 75 6c 74 29 20 20 22 2d 22 29 29 29 result) "-")))
8d10: 29 29 29 0a 09 09 09 09 09 09 09 09 09 20 28 73 ))).......... (s
8d20: 3a 74 64 20 20 6c 69 6e 6b 20 27 63 6c 61 73 73 :td link 'class
8d30: 20 73 74 61 74 75 73 29 29 29 0a 09 09 09 09 09 status)))......
8d40: 09 09 09 20 20 20 20 20 72 75 6e 73 29 29 29 29 ... runs))))
8d50: 0a 09 09 09 09 09 20 20 20 20 20 20 20 72 65 73 ...... res
8d60: 29 29 0a 09 09 09 09 09 20 20 20 69 74 65 6d 2d ))...... item-
8d70: 6b 65 79 73 29 29 29 0a 09 09 09 09 20 20 74 65 keys)))..... te
8d80: 73 74 2d 6c 69 73 74 29 29 29 29 29 29 20 0a 0a st-list)))))) ..
8d90: 3b 3b 20 28 74 65 73 74 73 3a 63 72 65 61 74 65 ;; (tests:create
8da0: 2d 68 74 6d 6c 2d 74 72 65 65 20 22 74 65 73 74 -html-tree "test
8db0: 2d 69 6e 64 65 78 2e 68 74 6d 6c 22 29 0a 3b 3b -index.html").;;
8dc0: 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a .(define (tests:
8dd0: 63 72 65 61 74 65 2d 68 74 6d 6c 2d 74 72 65 65 create-html-tree
8de0: 20 6f 75 74 66 29 0a 20 20 28 6c 65 74 2a 20 28 outf). (let* (
8df0: 28 6c 6f 63 6b 66 69 6c 65 20 20 28 63 6f 6e 63 (lockfile (conc
8e00: 20 6f 75 74 66 20 22 2e 6c 6f 63 6b 22 29 29 0a outf ".lock")).
8e10: 09 20 28 72 75 6e 73 2d 74 6f 2d 70 72 6f 63 65 . (runs-to-proce
8e20: 73 73 20 27 28 29 29 0a 20 20 20 20 20 20 20 20 ss '()).
8e30: 20 28 6c 69 6e 6b 74 72 65 65 20 20 28 63 6f 6d (linktree (com
8e40: 6d 6f 6e 3a 67 65 74 2d 6c 69 6e 6b 74 72 65 65 mon:get-linktree
8e50: 29 29 0a 20 20 20 20 20 20 20 20 20 28 61 72 65 )). (are
8e60: 61 2d 6e 61 6d 65 20 28 63 6f 6d 6d 6f 6e 3a 67 a-name (common:g
8e70: 65 74 2d 74 65 73 74 73 75 69 74 65 2d 6e 61 6d et-testsuite-nam
8e80: 65 29 29 0a 09 20 28 6b 65 79 73 20 20 20 20 20 e)).. (keys
8e90: 20 28 72 6d 74 3a 67 65 74 2d 6b 65 79 73 29 29 (rmt:get-keys))
8ea0: 0a 09 20 28 6e 75 6d 6b 65 79 73 20 20 20 28 6c .. (numkeys (l
8eb0: 65 6e 67 74 68 20 6b 65 79 73 29 29 0a 20 20 20 ength keys)).
8ec0: 20 20 20 20 20 20 28 72 75 6e 2d 70 61 74 74 20 (run-patt
8ed0: 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (or (args:get-ar
8ee0: 67 20 22 2d 72 75 6e 2d 70 61 74 74 22 29 0a 09 g "-run-patt")..
8ef0: 09 20 20 20 20 20 20 20 28 61 72 67 73 3a 67 65 . (args:ge
8f00: 74 2d 61 72 67 20 22 2d 72 75 6e 6e 61 6d 65 22 t-arg "-runname"
8f10: 29 0a 09 09 20 20 20 20 20 20 20 22 25 22 29 29 )... "%"))
8f20: 0a 20 20 20 20 20 20 20 20 20 28 74 61 72 67 65 . (targe
8f30: 74 20 28 6f 72 20 20 28 61 72 67 73 3a 67 65 74 t (or (args:get
8f40: 2d 61 72 67 20 22 2d 74 61 72 67 65 74 2d 70 61 -arg "-target-pa
8f50: 74 74 22 29 20 0a 09 09 20 20 20 20 20 20 28 61 tt") ... (a
8f60: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 rgs:get-arg "-ta
8f70: 72 67 65 74 22 29 0a 20 20 20 20 20 20 20 20 20 rget").
8f80: 20 20 20 20 20 20 20 20 20 20 20 20 20 22 25 22 "%"
8f90: 29 29 0a 20 20 20 20 20 20 20 20 20 28 74 61 72 )). (tar
8fa0: 67 6c 69 73 74 20 28 73 74 72 69 6e 67 2d 73 70 glist (string-sp
8fb0: 6c 69 74 20 74 61 72 67 65 74 20 22 2f 22 29 29 lit target "/"))
8fc0: 0a 20 20 20 20 20 20 20 20 20 28 6e 75 6d 74 61 . (numta
8fd0: 72 67 20 20 28 6c 65 6e 67 74 68 20 74 61 72 67 rg (length targ
8fe0: 6c 69 73 74 29 29 20 20 0a 20 20 20 20 20 20 20 list)) .
8ff0: 20 20 28 74 61 72 67 74 77 65 61 6b 65 64 20 28 (targtweaked (
9000: 69 66 20 28 3e 20 6e 75 6d 6b 65 79 73 20 6e 75 if (> numkeys nu
9010: 6d 74 61 72 67 29 0a 09 09 09 20 20 28 61 70 70 mtarg).... (app
9020: 65 6e 64 20 74 61 72 67 6c 69 73 74 20 28 6d 61 end targlist (ma
9030: 6b 65 2d 6c 69 73 74 20 28 2d 20 6e 75 6d 6b 65 ke-list (- numke
9040: 79 73 20 6e 75 6d 74 61 72 67 29 20 22 25 22 29 ys numtarg) "%")
9050: 29 0a 09 09 09 20 20 74 61 72 67 6c 69 73 74 29 ).... targlist)
9060: 29 0a 20 20 20 20 20 20 20 20 20 28 74 61 72 67 ). (targ
9070: 65 74 2d 70 61 74 74 20 28 73 74 72 69 6e 67 2d et-patt (string-
9080: 6a 6f 69 6e 20 74 61 72 67 74 77 65 61 6b 65 64 join targtweaked
9090: 20 22 2f 22 29 29 0a 09 09 09 09 09 3b 28 74 6f "/"))......;(to
90a0: 74 61 6c 2d 72 75 6e 73 20 20 28 72 6d 74 3a 67 tal-runs (rmt:g
90b0: 65 74 2d 6e 75 6d 2d 72 75 6e 73 20 22 25 22 29 et-num-runs "%")
90c0: 29 20 3b 3b 74 68 69 73 20 6e 65 65 64 73 20 74 ) ;;this needs t
90d0: 6f 20 62 65 20 63 68 61 6e 67 65 64 20 74 6f 20 o be changed to
90e0: 66 69 6c 74 65 72 20 62 79 20 74 61 72 67 65 74 filter by target
90f0: 0a 09 20 28 74 6f 74 61 6c 2d 72 75 6e 73 20 28 .. (total-runs (
9100: 72 6d 74 3a 67 65 74 2d 72 75 6e 73 2d 63 6e 74 rmt:get-runs-cnt
9110: 2d 62 79 2d 70 61 74 74 20 72 75 6e 2d 70 61 74 -by-patt run-pat
9120: 74 20 74 61 72 67 65 74 2d 70 61 74 74 20 6b 65 t target-patt ke
9130: 79 73 20 29 29 20 0a 20 20 20 20 20 20 20 20 20 ys )) .
9140: 28 70 67 2d 73 69 7a 65 20 31 30 29 29 0a 20 20 (pg-size 10)).
9150: 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 73 69 (if (common:si
9160: 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 20 6c mple-file-lock l
9170: 6f 63 6b 66 69 6c 65 29 0a 20 20 20 20 20 20 20 ockfile).
9180: 20 28 62 65 67 69 6e 0a 09 09 09 09 09 3b 28 70 (begin......;(p
9190: 72 69 6e 74 20 74 6f 74 61 6c 2d 72 75 6e 73 29 rint total-runs)
91a0: 20 20 20 20 0a 09 20 20 28 6c 65 74 20 6c 6f 6f .. (let loo
91b0: 70 20 28 28 70 61 67 65 20 30 29 29 0a 09 20 20 p ((page 0))..
91c0: 20 20 28 6c 65 74 2a 20 28 28 6f 75 70 20 20 20 (let* ((oup
91d0: 20 20 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 6f (open-o
91e0: 75 74 70 75 74 2d 66 69 6c 65 20 28 6f 72 20 6f utput-file (or o
91f0: 75 74 66 20 28 63 6f 6e 63 20 6c 69 6e 6b 74 72 utf (conc linktr
9200: 65 65 20 22 2f 70 61 67 65 22 20 70 61 67 65 20 ee "/page" page
9210: 22 2e 68 74 6d 6c 22 29 29 29 29 0a 09 09 20 20 ".html"))))...
9220: 20 28 67 65 74 2d 70 72 65 76 2d 6c 69 6e 6b 73 (get-prev-links
9230: 20 28 6c 61 6d 62 64 61 20 28 70 61 67 65 20 6c (lambda (page l
9240: 69 6e 6b 74 72 65 65 20 29 20 20 20 0a 09 09 09 inktree ) ....
9250: 09 20 20 20 20 20 28 6c 65 74 2a 20 28 28 6c 69 . (let* ((li
9260: 6e 6b 20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 nk (if (not (eq
9270: 3f 20 70 61 67 65 20 30 29 29 0a 09 09 09 09 09 ? page 0))......
9280: 09 20 20 20 20 20 20 20 28 73 3a 61 20 22 26 6c . (s:a "&l
9290: 74 3b 26 6c 74 3b 70 72 65 76 22 20 27 68 72 65 t;<prev" 'hre
92a0: 66 20 28 63 6f 6e 63 20 20 22 70 61 67 65 22 20 f (conc "page"
92b0: 28 2d 20 70 61 67 65 20 31 29 20 22 2e 68 74 6d (- page 1) ".htm
92c0: 6c 22 29 29 0a 09 09 09 09 09 09 20 20 20 20 20 l")).......
92d0: 20 20 28 73 3a 61 20 22 22 20 27 68 72 65 66 20 (s:a "" 'href
92e0: 28 63 6f 6e 63 20 20 20 22 70 61 67 65 22 20 20 (conc "page"
92f0: 70 61 67 65 20 22 2e 68 74 6d 6c 22 29 29 29 29 page ".html"))))
9300: 29 0a 09 09 09 09 20 20 20 20 20 20 20 6c 69 6e )..... lin
9310: 6b 29 29 29 0a 09 09 20 20 20 28 67 65 74 2d 6e k)))... (get-n
9320: 65 78 74 2d 6c 69 6e 6b 73 20 28 6c 61 6d 62 64 ext-links (lambd
9330: 61 20 28 70 61 67 65 20 6c 69 6e 6b 74 72 65 65 a (page linktree
9340: 20 74 6f 74 61 6c 2d 72 75 6e 73 29 20 20 20 0a total-runs) .
9350: 09 09 09 09 20 20 20 20 20 28 6c 65 74 2a 20 28 .... (let* (
9360: 28 6c 69 6e 6b 20 20 28 69 66 20 28 3e 20 74 6f (link (if (> to
9370: 74 61 6c 2d 72 75 6e 73 20 28 2b 20 31 30 20 28 tal-runs (+ 10 (
9380: 2a 20 70 61 67 65 20 70 67 2d 73 69 7a 65 29 29 * page pg-size))
9390: 29 0a 09 09 09 09 09 09 20 20 20 20 20 20 20 28 )....... (
93a0: 73 3a 61 20 22 6e 65 78 74 26 67 74 3b 26 67 74 s:a "next>>
93b0: 3b 22 20 27 68 72 65 66 20 28 63 6f 6e 63 20 20 ;" 'href (conc
93c0: 22 70 61 67 65 22 20 20 28 2b 20 70 61 67 65 20 "page" (+ page
93d0: 31 29 20 22 2e 68 74 6d 6c 22 29 29 0a 09 09 09 1) ".html"))....
93e0: 09 09 09 20 20 20 20 20 20 20 28 73 3a 61 20 22 ... (s:a "
93f0: 22 20 27 68 72 65 66 20 28 63 6f 6e 63 20 20 20 " 'href (conc
9400: 22 70 61 67 65 22 20 70 61 67 65 20 20 22 2e 68 "page" page ".h
9410: 74 6d 6c 22 29 29 29 29 29 0a 09 09 09 09 20 20 tml"))))).....
9420: 20 20 20 20 20 6c 69 6e 6b 29 29 29 20 29 0a 09 link))) )..
9430: 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 74 6f (print "to
9440: 74 61 6c 20 72 75 6e 73 3a 20 22 20 74 6f 74 61 tal runs: " tota
9450: 6c 2d 72 75 6e 73 29 20 0a 09 20 20 20 20 20 20 l-runs) ..
9460: 28 73 3a 6f 75 74 70 75 74 2d 6e 65 77 0a 09 20 (s:output-new..
9470: 20 20 20 20 20 20 6f 75 70 0a 09 20 20 20 20 20 oup..
9480: 20 20 28 74 65 73 74 73 3a 64 61 73 68 62 6f 61 (tests:dashboa
9490: 72 64 2d 62 6f 64 79 20 70 61 67 65 20 70 67 2d rd-body page pg-
94a0: 73 69 7a 65 20 6b 65 79 73 20 6e 75 6d 6b 65 79 size keys numkey
94b0: 73 20 74 6f 74 61 6c 2d 72 75 6e 73 20 6c 69 6e s total-runs lin
94c0: 6b 74 72 65 65 20 61 72 65 61 2d 6e 61 6d 65 20 ktree area-name
94d0: 67 65 74 2d 70 72 65 76 2d 6c 69 6e 6b 73 20 67 get-prev-links g
94e0: 65 74 2d 6e 65 78 74 2d 6c 69 6e 6b 73 20 23 66 et-next-links #f
94f0: 20 72 75 6e 2d 70 61 74 74 20 74 61 72 67 65 74 run-patt target
9500: 2d 70 61 74 74 29 29 20 3b 3b 20 75 70 64 61 74 -patt)) ;; updat
9510: 65 20 74 68 69 73 20 66 75 6e 63 74 69 6f 6e 0a e this function.
9520: 09 20 20 20 20 20 20 28 63 6c 6f 73 65 2d 6f 75 . (close-ou
9530: 74 70 75 74 2d 70 6f 72 74 20 6f 75 70 29 0a 09 tput-port oup)..
9540: 09 09 09 09 3b 20 28 73 65 74 21 20 70 61 67 65 ....; (set! page
9550: 20 28 2b 20 31 20 70 61 67 65 29 29 0a 09 20 20 (+ 1 page))..
9560: 20 20 20 20 28 69 66 20 28 3e 20 74 6f 74 61 6c (if (> total
9570: 2d 72 75 6e 73 20 28 2a 20 28 2b 20 31 20 70 61 -runs (* (+ 1 pa
9580: 67 65 29 20 70 67 2d 73 69 7a 65 29 29 0a 09 09 ge) pg-size))...
9590: 20 20 28 6c 6f 6f 70 20 28 2b 20 31 20 20 70 61 (loop (+ 1 pa
95a0: 67 65 29 29 29 29 29 0a 09 20 20 28 63 6f 6d 6d ge))))).. (comm
95b0: 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 72 on:simple-file-r
95c0: 65 6c 65 61 73 65 2d 6c 6f 63 6b 20 6c 6f 63 6b elease-lock lock
95d0: 66 69 6c 65 29 29 0a 09 28 62 65 67 69 6e 0a 09 file))..(begin..
95e0: 20 20 28 64 65 62 75 67 2d 70 72 69 6e 74 20 30 (debug-print 0
95f0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
9600: 72 74 2a 20 22 46 61 69 6c 65 64 20 74 6f 20 67 rt* "Failed to g
9610: 65 74 20 6c 6f 63 6b 20 6f 6e 20 66 69 6c 65 20 et lock on file
9620: 6f 75 74 66 2c 20 6c 6f 63 6b 66 69 6c 65 3a 20 outf, lockfile:
9630: 22 20 6c 6f 63 6b 66 69 6c 65 29 20 23 66 29 29 " lockfile) #f))
9640: 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 ))...(define (te
9650: 73 74 73 3a 72 65 61 64 6c 69 6e 65 73 20 66 69 sts:readlines fi
9660: 6c 65 6e 61 6d 65 29 0a 20 20 28 63 61 6c 6c 2d lename). (call-
9670: 77 69 74 68 2d 69 6e 70 75 74 2d 66 69 6c 65 20 with-input-file
9680: 66 69 6c 65 6e 61 6d 65 0a 20 20 20 20 28 6c 61 filename. (la
9690: 6d 62 64 61 20 28 70 29 0a 20 20 20 20 20 20 28 mbda (p). (
96a0: 6c 65 74 20 6c 6f 6f 70 20 28 28 6c 69 6e 65 20 let loop ((line
96b0: 28 72 65 61 64 2d 6c 69 6e 65 20 70 29 29 0a 20 (read-line p)).
96c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
96d0: 28 72 65 73 75 6c 74 20 27 28 29 29 29 0a 20 20 (result '())).
96e0: 20 20 20 20 20 20 28 69 66 20 28 65 6f 66 2d 6f (if (eof-o
96f0: 62 6a 65 63 74 3f 20 6c 69 6e 65 29 0a 20 20 20 bject? line).
9700: 20 20 20 20 20 20 20 20 20 28 72 65 76 65 72 73 (revers
9710: 65 20 72 65 73 75 6c 74 29 0a 20 20 20 20 20 20 e result).
9720: 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 72 65 61 (loop (rea
9730: 64 2d 6c 69 6e 65 20 70 29 20 28 63 6f 6e 73 20 d-line p) (cons
9740: 6c 69 6e 65 20 72 65 73 75 6c 74 29 29 29 29 29 line result)))))
9750: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 ))..(define (tes
9760: 74 73 3a 67 65 74 2d 74 65 73 74 2d 6c 6f 67 20 ts:get-test-log
9770: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
9780: 20 69 74 65 6d 2d 6e 61 6d 65 29 0a 20 20 28 6c item-name). (l
9790: 65 74 2a 20 28 28 74 65 73 74 2d 64 61 74 61 20 et* ((test-data
97a0: 20 20 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 (rmt:get-test
97b0: 73 2d 66 6f 72 2d 72 75 6e 0a 09 09 09 09 20 20 s-for-run.....
97c0: 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 (string->number
97d0: 20 72 75 6e 2d 69 64 29 0a 20 20 20 20 20 20 20 run-id).
97e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
97f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 74 65 73 tes
9800: 74 2d 6e 61 6d 65 20 20 20 20 20 20 3b 3b 20 74 t-name ;; t
9810: 65 73 74 6e 61 6d 65 70 61 74 74 0a 09 09 09 09 estnamepatt.....
9820: 20 20 20 27 28 29 20 20 20 20 20 20 20 20 3b 3b '() ;;
9830: 20 73 74 61 74 65 73 0a 09 09 09 09 20 20 20 27 states..... '
9840: 28 29 20 20 20 20 20 20 20 20 3b 3b 20 73 74 61 () ;; sta
9850: 74 75 73 65 73 0a 09 09 09 09 20 20 20 23 66 20 tuses..... #f
9860: 20 20 20 20 20 20 20 20 3b 3b 20 6f 66 66 73 65 ;; offse
9870: 74 0a 09 09 09 09 20 20 20 23 66 20 20 20 20 20 t..... #f
9880: 20 20 20 20 3b 3b 20 6e 75 6d 2d 74 6f 2d 67 65 ;; num-to-ge
9890: 74 0a 09 09 09 09 20 20 20 23 66 20 20 20 20 20 t..... #f
98a0: 20 20 20 20 3b 3b 20 68 69 64 65 2f 6e 6f 74 2d ;; hide/not-
98b0: 68 69 64 65 0a 09 09 09 09 20 20 20 23 66 20 20 hide..... #f
98c0: 20 20 20 20 20 20 20 3b 3b 20 73 6f 72 74 2d 62 ;; sort-b
98d0: 79 0a 09 09 09 09 20 20 20 23 66 20 20 20 20 20 y..... #f
98e0: 20 20 20 20 3b 3b 20 73 6f 72 74 2d 6f 72 64 65 ;; sort-orde
98f0: 72 0a 09 09 09 09 20 20 20 23 66 20 20 20 20 20 r..... #f
9900: 20 20 20 20 3b 3b 20 27 73 68 6f 72 74 6c 69 73 ;; 'shortlis
9910: 74 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 t
9920: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 71 ;; q
9930: 72 79 74 79 70 65 0a 20 20 20 20 20 20 20 20 20 rytype.
9940: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9950: 20 20 20 20 20 20 20 20 20 20 30 20 20 20 20 20 0
9960: 20 20 20 20 3b 3b 20 6c 61 73 74 20 75 70 64 61 ;; last upda
9970: 74 65 0a 09 09 09 09 20 20 20 23 66 29 29 0a 20 te..... #f)).
9980: 20 20 20 20 20 20 20 20 28 70 61 74 68 20 22 22 (path ""
9990: 29 0a 20 20 20 20 20 20 20 20 20 28 66 6f 75 6e ). (foun
99a0: 64 20 30 29 29 0a 20 20 20 20 28 64 65 62 75 67 d 0)). (debug
99b0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 :print-info 0 *d
99c0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
99d0: 20 22 66 6f 75 6e 64 3a 20 22 20 66 6f 75 6e 64 "found: " found
99e0: 20 29 0a 0a 20 20 20 28 6c 65 74 20 6c 6f 6f 70 ).. (let loop
99f0: 20 28 28 68 65 64 20 28 63 61 72 20 74 65 73 74 ((hed (car test
9a00: 2d 64 61 74 61 29 29 0a 09 09 20 28 74 61 6c 20 -data))... (tal
9a10: 28 63 64 72 20 74 65 73 74 2d 64 61 74 61 29 29 (cdr test-data))
9a20: 29 0a 20 20 20 20 20 20 20 20 20 20 28 64 65 62 ). (deb
9a30: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
9a40: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
9a50: 74 2a 20 22 69 74 65 6d 3a 20 22 20 28 76 65 63 t* "item: " (vec
9a60: 74 6f 72 2d 72 65 66 20 68 65 64 20 31 31 29 20 tor-ref hed 11)
9a70: 28 76 65 63 74 6f 72 2d 72 65 66 20 68 65 64 20 (vector-ref hed
9a80: 31 30 29 20 22 2f 22 20 28 76 65 63 74 6f 72 2d 10) "/" (vector-
9a90: 72 65 66 20 68 65 64 20 31 33 29 29 0a 0a 09 28 ref hed 13))...(
9aa0: 69 66 20 28 65 71 75 61 6c 3f 20 28 76 65 63 74 if (equal? (vect
9ab0: 6f 72 2d 72 65 66 20 68 65 64 20 31 31 29 20 69 or-ref hed 11) i
9ac0: 74 65 6d 2d 6e 61 6d 65 29 0a 20 20 20 20 20 20 tem-name).
9ad0: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 (begin.
9ae0: 20 20 20 20 20 20 20 20 20 20 20 28 73 65 74 21 (set!
9af0: 20 66 6f 75 6e 64 20 31 29 20 0a 09 20 20 20 20 found 1) ..
9b00: 20 20 28 73 65 74 21 20 70 61 74 68 20 28 63 6f (set! path (co
9b10: 6e 63 20 28 76 65 63 74 6f 72 2d 72 65 66 20 68 nc (vector-ref h
9b20: 65 64 20 31 30 29 20 22 2f 22 20 28 76 65 63 74 ed 10) "/" (vect
9b30: 6f 72 2d 72 65 66 20 68 65 64 20 31 33 29 29 29 or-ref hed 13)))
9b40: 29 29 0a 09 20 20 20 20 28 69 66 20 28 61 6e 64 )).. (if (and
9b50: 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c (not (null? tal
9b60: 29 29 20 28 65 71 75 61 6c 3f 20 66 6f 75 6e 64 )) (equal? found
9b70: 20 30 29 29 0a 09 09 28 6c 6f 6f 70 20 28 63 61 0))...(loop (ca
9b80: 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 29 r tal)(cdr tal))
9b90: 29 29 0a 20 20 20 28 69 66 20 28 65 71 75 61 6c )). (if (equal
9ba0: 3f 20 70 61 74 68 20 22 22 29 0a 20 20 20 20 20 ? path "").
9bb0: 22 3c 48 32 3e 44 61 74 61 20 6e 6f 74 20 66 6f "<H2>Data not fo
9bc0: 75 6e 64 3c 2f 48 32 3e 22 0a 20 20 20 20 20 28 und</H2>". (
9bd0: 73 74 72 69 6e 67 2d 6a 6f 69 6e 20 28 74 65 73 string-join (tes
9be0: 74 73 3a 72 65 61 64 6c 69 6e 65 73 20 70 61 74 ts:readlines pat
9bf0: 68 29 20 22 5c 6e 22 29 29 29 29 0a 0a 0a 28 64 h) "\n"))))...(d
9c00: 65 66 69 6e 65 20 28 74 65 73 74 73 3a 64 79 6e efine (tests:dyn
9c10: 61 6d 69 63 2d 64 62 6f 61 72 64 20 70 61 67 65 amic-dboard page
9c20: 29 0a 3b 28 64 65 66 69 6e 65 20 28 74 65 73 74 ).;(define (test
9c30: 73 3a 63 72 65 61 74 65 2d 68 74 6d 6c 2d 74 72 s:create-html-tr
9c40: 65 65 20 6f 29 0a 20 28 6c 65 74 2a 20 28 0a 3b ee o). (let* (.;
9c50: 28 70 61 67 65 20 22 31 22 29 0a 20 20 20 20 20 (page "1").
9c60: 20 20 20 20 20 28 6c 69 6e 6b 74 72 65 65 20 20 (linktree
9c70: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 69 6e 6b (common:get-link
9c80: 74 72 65 65 29 29 0a 20 20 20 20 20 20 20 20 20 tree)).
9c90: 28 61 72 65 61 2d 6e 61 6d 65 20 28 63 6f 6d 6d (area-name (comm
9ca0: 6f 6e 3a 67 65 74 2d 74 65 73 74 73 75 69 74 65 on:get-testsuite
9cb0: 2d 6e 61 6d 65 29 29 0a 09 20 20 20 20 20 20 20 -name))..
9cc0: 28 6b 65 79 73 20 20 20 20 20 20 28 72 6d 74 3a (keys (rmt:
9cd0: 67 65 74 2d 6b 65 79 73 29 29 0a 09 20 20 20 20 get-keys))..
9ce0: 20 20 20 28 6e 75 6d 6b 65 79 73 20 20 20 28 6c (numkeys (l
9cf0: 65 6e 67 74 68 20 6b 65 79 73 29 29 0a 20 20 20 ength keys)).
9d00: 20 20 20 20 20 20 28 74 61 72 67 74 77 65 61 6b (targtweak
9d10: 65 64 20 28 6d 61 6b 65 2d 6c 69 73 74 20 6e 75 ed (make-list nu
9d20: 6d 6b 65 79 73 20 22 25 22 29 29 0a 20 20 20 20 mkeys "%")).
9d30: 20 20 20 20 20 28 74 61 72 67 65 74 2d 70 61 74 (target-pat
9d40: 74 20 28 73 74 72 69 6e 67 2d 6a 6f 69 6e 20 74 t (string-join t
9d50: 61 72 67 74 77 65 61 6b 65 64 20 22 2f 22 29 29 argtweaked "/"))
9d60: 0a 20 20 20 20 20 20 20 20 20 28 74 6f 74 61 6c . (total
9d70: 2d 72 75 6e 73 20 20 28 72 6d 74 3a 67 65 74 2d -runs (rmt:get-
9d80: 6e 75 6d 2d 72 75 6e 73 20 22 25 22 29 29 0a 20 num-runs "%")).
9d90: 20 20 20 20 20 20 20 20 28 70 67 2d 73 69 7a 65 (pg-size
9da0: 20 31 30 29 0a 20 20 20 20 20 20 20 20 20 28 70 10). (p
9db0: 67 20 28 69 66 20 28 65 71 75 61 6c 3f 20 70 61 g (if (equal? pa
9dc0: 67 65 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 ge #f).
9dd0: 20 20 20 20 20 20 20 20 30 0a 20 20 20 20 20 20 0.
9de0: 20 20 20 20 20 20 20 20 20 20 20 28 2d 20 28 73 (- (s
9df0: 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 70 61 tring->number pa
9e00: 67 65 29 20 31 29 29 29 0a 20 20 20 20 20 20 20 ge) 1))).
9e10: 20 20 20 28 67 65 74 2d 70 72 65 76 2d 6c 69 6e (get-prev-lin
9e20: 6b 73 20 20 28 6c 61 6d 62 64 61 20 28 70 67 20 ks (lambda (pg
9e30: 6c 69 6e 6b 74 72 65 65 29 0a 20 20 20 20 20 20 linktree).
9e40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9e50: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
9e60: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
9e70: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 76 61 6c t-log-port* "val
9e80: 3a 20 22 20 28 2d 20 31 20 70 67 29 29 0a 20 20 : " (- 1 pg)).
9e90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9ea0: 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 (let* ((
9eb0: 6c 69 6e 6b 20 20 28 69 66 20 28 6e 6f 74 20 28 link (if (not (
9ec0: 65 71 3f 20 70 67 20 30 29 29 0a 20 20 20 20 20 eq? pg 0)).
9ed0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9ee0: 20 20 20 20 20 20 20 20 20 20 28 73 3a 61 20 20 (s:a
9ef0: 22 26 6c 74 3b 26 6c 74 3b 70 72 65 76 20 22 20 "<<prev "
9f00: 27 68 72 65 66 20 28 63 6f 6e 63 20 20 22 64 61 'href (conc "da
9f10: 73 68 62 6f 61 72 64 3f 70 61 67 65 3d 22 20 20 shboard?page="
9f20: 70 67 20 20 29 29 0a 20 20 20 20 20 20 20 20 20 pg )).
9f30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9f40: 20 20 20 20 20 20 28 73 3a 61 20 22 22 20 27 68 (s:a "" 'h
9f50: 72 65 66 20 28 63 6f 6e 63 20 20 22 64 61 73 68 ref (conc "dash
9f60: 62 6f 61 72 64 3f 70 61 67 65 3d 22 20 70 67 29 board?page=" pg)
9f70: 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 )))).
9f80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9f90: 20 20 20 20 6c 69 6e 6b 29 29 29 0a 20 20 20 20 link))).
9fa0: 20 20 20 20 20 20 28 67 65 74 2d 6e 65 78 74 2d (get-next-
9fb0: 6c 69 6e 6b 73 20 20 20 28 6c 61 6d 62 64 61 20 links (lambda
9fc0: 28 70 67 20 6c 69 6e 6b 74 72 65 65 20 74 6f 74 (pg linktree tot
9fd0: 61 6c 2d 72 75 6e 73 29 20 20 0a 20 20 20 20 20 al-runs) .
9fe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9ff0: 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 (debug:pr
a000: 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 int-info 0 *defa
a010: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 76 ult-log-port* "v
a020: 61 6c 3a 20 22 20 70 67 29 0a 20 20 20 20 20 20 al: " pg).
a030: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a040: 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 (debug:pr
a050: 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 int-info 0 *defa
a060: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 76 ult-log-port* "v
a070: 61 6c 3a 20 22 20 74 6f 74 61 6c 2d 72 75 6e 73 al: " total-runs
a080: 20 22 20 73 69 7a 65 22 20 70 67 2d 73 69 7a 65 " size" pg-size
a090: 29 0a 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 ). .
a0a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a0b0: 28 6c 65 74 2a 20 28 28 6c 69 6e 6b 20 20 28 69 (let* ((link (i
a0c0: 66 20 28 3e 20 74 6f 74 61 6c 2d 72 75 6e 73 20 f (> total-runs
a0d0: 28 2b 20 31 30 20 28 2a 20 70 67 20 70 67 2d 73 (+ 10 (* pg pg-s
a0e0: 69 7a 65 29 29 29 0a 20 20 20 20 20 20 20 20 20 ize))).
a0f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a100: 20 20 20 20 20 28 73 3a 61 20 20 22 6e 65 78 74 (s:a "next
a110: 26 67 74 3b 26 67 74 3b 20 22 20 20 27 68 72 65 >> " 'hre
a120: 66 20 28 63 6f 6e 63 20 20 22 64 61 73 68 62 6f f (conc "dashbo
a130: 61 72 64 3f 70 61 67 65 3d 22 20 20 28 2b 20 70 ard?page=" (+ p
a140: 67 20 32 29 20 20 29 29 0a 20 20 20 20 20 20 20 g 2) )).
a150: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a160: 20 20 20 20 20 20 28 73 3a 61 20 22 22 20 27 68 (s:a "" 'h
a170: 72 65 66 20 28 63 6f 6e 63 20 20 22 64 61 73 68 ref (conc "dash
a180: 62 6f 61 72 64 3f 70 61 67 65 3d 22 20 70 67 20 board?page=" pg
a190: 20 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 ))))).
a1a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a1b0: 20 20 20 20 6c 69 6e 6b 29 29 29 0a 20 20 20 20 link))).
a1c0: 20 20 20 20 20 28 68 74 6d 6c 2d 62 6f 64 79 20 (html-body
a1d0: 28 74 65 73 74 73 3a 64 61 73 68 62 6f 61 72 64 (tests:dashboard
a1e0: 2d 62 6f 64 79 20 70 67 20 70 67 2d 73 69 7a 65 -body pg pg-size
a1f0: 20 6b 65 79 73 20 6e 75 6d 6b 65 79 73 20 74 6f keys numkeys to
a200: 74 61 6c 2d 72 75 6e 73 20 6c 69 6e 6b 74 72 65 tal-runs linktre
a210: 65 20 61 72 65 61 2d 6e 61 6d 65 20 67 65 74 2d e area-name get-
a220: 70 72 65 76 2d 6c 69 6e 6b 73 20 67 65 74 2d 6e prev-links get-n
a230: 65 78 74 2d 6c 69 6e 6b 73 20 23 74 20 22 25 22 ext-links #t "%"
a240: 20 74 61 72 67 65 74 2d 70 61 74 74 29 29 29 20 target-patt)))
a250: 3b 3b 20 75 70 64 61 74 65 20 74 69 73 20 66 75 ;; update tis fu
a260: 6e 63 74 69 6f 6e 0a 20 20 20 20 20 20 20 20 68 nction. h
a270: 74 6d 6c 2d 62 6f 64 79 29 29 0a 0a 28 64 65 66 tml-body))..(def
a280: 69 6e 65 20 28 74 65 73 74 73 3a 63 72 65 61 74 ine (tests:creat
a290: 65 2d 68 74 6d 6c 2d 73 75 6d 6d 61 72 79 20 6f e-html-summary o
a2a0: 75 74 66 29 0a 20 28 6c 65 74 2a 20 28 28 6c 6f utf). (let* ((lo
a2b0: 63 6b 66 69 6c 65 20 20 28 63 6f 6e 63 20 6f 75 ckfile (conc ou
a2c0: 74 66 20 22 2e 6c 6f 63 6b 22 29 29 0a 20 20 20 tf ".lock")).
a2d0: 20 20 20 20 20 28 6c 69 6e 6b 74 72 65 65 20 20 (linktree
a2e0: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 69 6e 6b (common:get-link
a2f0: 74 72 65 65 29 29 0a 09 09 09 09 28 6b 65 79 73 tree)).....(keys
a300: 20 20 20 20 20 20 28 72 6d 74 3a 67 65 74 2d 6b (rmt:get-k
a310: 65 79 73 29 29 0a 20 20 20 20 20 20 20 20 28 61 eys)). (a
a320: 72 65 61 2d 6e 61 6d 65 20 28 63 6f 6d 6d 6f 6e rea-name (common
a330: 3a 67 65 74 2d 74 65 73 74 73 75 69 74 65 2d 6e :get-testsuite-n
a340: 61 6d 65 29 29 0a 20 20 20 20 20 20 20 20 28 72 ame)). (r
a350: 75 6e 2d 70 61 74 74 20 28 6f 72 20 28 61 72 67 un-patt (or (arg
a360: 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 75 6e 2d s:get-arg "-run-
a370: 70 61 74 74 22 29 0a 20 20 20 20 20 20 20 20 20 patt").
a380: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
a390: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 args:get-arg "-r
a3a0: 75 6e 6e 61 6d 65 22 29 0a 20 20 20 20 20 20 20 unname").
a3b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a3c0: 20 22 25 22 29 29 0a 20 20 20 20 20 20 20 20 28 "%")). (
a3d0: 74 61 72 67 65 74 20 28 6f 72 20 28 61 72 67 73 target (or (args
a3e0: 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 72 67 65 :get-arg "-targe
a3f0: 74 2d 70 61 74 74 22 29 0a 20 20 20 20 20 20 20 t-patt").
a400: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a410: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
a420: 2d 74 61 72 67 65 74 22 29 0a 20 20 20 20 20 20 -target").
a430: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a440: 20 20 22 25 22 29 29 0a 20 20 20 20 20 20 20 20 "%")).
a450: 20 28 74 61 72 67 6c 69 73 74 20 28 73 74 72 69 (targlist (stri
a460: 6e 67 2d 73 70 6c 69 74 20 74 61 72 67 65 74 20 ng-split target
a470: 22 2f 22 29 29 0a 20 20 20 20 20 20 20 20 20 28 "/")). (
a480: 6e 75 6d 6b 65 79 73 20 20 28 6c 65 6e 67 74 68 numkeys (length
a490: 20 6b 65 79 73 29 29 0a 09 20 20 20 20 20 20 20 keys))..
a4a0: 28 6e 75 6d 74 61 72 67 20 20 28 6c 65 6e 67 74 (numtarg (lengt
a4b0: 68 20 74 61 72 67 6c 69 73 74 29 29 20 20 0a 20 h targlist)) .
a4c0: 20 20 20 20 20 20 20 20 28 74 61 72 67 74 77 65 (targtwe
a4d0: 61 6b 65 64 20 28 69 66 20 28 3e 20 6e 75 6d 6b aked (if (> numk
a4e0: 65 79 73 20 6e 75 6d 74 61 72 67 29 0a 09 09 09 eys numtarg)....
a4f0: 20 20 20 09 09 09 09 09 09 09 09 28 61 70 70 65 ........(appe
a500: 6e 64 20 74 61 72 67 6c 69 73 74 20 28 6d 61 6b nd targlist (mak
a510: 65 2d 6c 69 73 74 20 28 2d 20 6e 75 6d 6b 65 79 e-list (- numkey
a520: 73 20 6e 75 6d 74 61 72 67 29 20 22 25 22 29 29 s numtarg) "%"))
a530: 0a 09 09 09 20 20 09 09 09 09 09 09 09 09 74 61 .... ........ta
a540: 72 67 6c 69 73 74 29 29 0a 20 20 20 20 20 20 20 rglist)).
a550: 20 28 74 61 72 67 65 74 2d 70 61 74 74 20 28 73 (target-patt (s
a560: 74 72 69 6e 67 2d 6a 6f 69 6e 20 74 61 72 67 74 tring-join targt
a570: 77 65 61 6b 65 64 20 22 2f 22 29 29 29 0a 20 20 weaked "/"))).
a580: 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 73 69 (if (common:si
a590: 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 20 6c mple-file-lock l
a5a0: 6f 63 6b 66 69 6c 65 29 0a 20 20 20 20 20 20 20 ockfile).
a5b0: 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 (begin.
a5c0: 20 20 28 6c 65 74 2a 20 28 3b 28 72 75 6e 73 64 (let* (;(runsd
a5d0: 61 74 31 20 20 20 28 72 6d 74 3a 67 65 74 2d 72 at1 (rmt:get-r
a5e0: 75 6e 73 20 72 75 6e 2d 70 61 74 74 20 23 66 20 uns run-patt #f
a5f0: 23 66 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 #f (map (lambda
a600: 28 78 29 28 6c 69 73 74 20 78 20 22 25 22 29 29 (x)(list x "%"))
a610: 20 6b 65 79 73 29 29 29 0a 20 20 20 20 20 20 20 keys))).
a620: 20 20 20 20 20 20 20 20 20 20 28 72 75 6e 73 64 (runsd
a630: 61 74 20 20 20 28 72 6d 74 3a 67 65 74 2d 72 75 at (rmt:get-ru
a640: 6e 73 2d 62 79 2d 70 61 74 74 20 20 6b 65 79 73 ns-by-patt keys
a650: 20 72 75 6e 2d 70 61 74 74 20 74 61 72 67 65 74 run-patt target
a660: 2d 70 61 74 74 20 23 66 20 23 66 20 23 66 20 30 -patt #f #f #f 0
a670: 29 29 0a 09 09 09 09 09 20 20 20 20 20 20 20 28 ))...... (
a680: 72 75 6e 73 20 20 20 20 20 20 28 76 65 63 74 6f runs (vecto
a690: 72 2d 72 65 66 20 72 75 6e 73 64 61 74 20 31 29 r-ref runsdat 1)
a6a0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
a6b0: 20 20 20 28 68 65 61 64 65 72 20 20 20 20 20 20 (header
a6c0: 28 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 73 (vector-ref runs
a6d0: 64 61 74 20 30 29 29 0a 20 20 20 20 20 20 20 20 dat 0)).
a6e0: 09 20 20 20 20 20 20 20 28 6f 75 70 20 20 20 20 . (oup
a6f0: 20 20 20 28 6f 70 65 6e 2d 6f 75 74 70 75 74 2d (open-output-
a700: 66 69 6c 65 20 28 6f 72 20 6f 75 74 66 20 28 63 file (or outf (c
a710: 6f 6e 63 20 6c 69 6e 6b 74 72 65 65 20 22 2f 74 onc linktree "/t
a720: 61 72 67 65 74 73 2e 68 74 6d 6c 22 29 29 29 29 argets.html"))))
a730: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
a740: 20 20 28 74 61 72 67 65 74 2d 68 61 73 68 20 28 (target-hash (
a750: 74 65 73 74 3a 63 72 65 61 74 65 2d 74 61 72 67 test:create-targ
a760: 65 74 2d 68 61 73 68 20 72 75 6e 73 20 68 65 61 et-hash runs hea
a770: 64 65 72 20 28 6c 65 6e 67 74 68 20 6b 65 79 73 der (length keys
a780: 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 )))).
a790: 28 74 65 73 74 3a 63 72 65 61 74 65 2d 74 61 72 (test:create-tar
a7a0: 67 65 74 2d 68 74 6d 6c 20 74 61 72 67 65 74 2d get-html target-
a7b0: 68 61 73 68 20 6f 75 70 20 61 72 65 61 2d 6e 61 hash oup area-na
a7c0: 6d 65 20 6c 69 6e 6b 74 72 65 65 29 0a 20 20 20 me linktree).
a7d0: 20 20 20 20 20 20 20 28 74 65 73 74 3a 63 72 65 (test:cre
a7e0: 61 74 65 2d 72 75 6e 2d 68 74 6d 6c 20 20 72 75 ate-run-html ru
a7f0: 6e 73 20 61 72 65 61 2d 6e 61 6d 65 20 6c 69 6e ns area-name lin
a800: 6b 74 72 65 65 20 28 6c 65 6e 67 74 68 20 6b 65 ktree (length ke
a810: 79 73 29 20 68 65 61 64 65 72 29 29 0a 09 20 20 ys) header))..
a820: 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 2d 66 (common:simple-f
a830: 69 6c 65 2d 72 65 6c 65 61 73 65 2d 6c 6f 63 6b ile-release-lock
a840: 20 6c 6f 63 6b 66 69 6c 65 29 29 0a 09 23 66 29 lockfile))..#f)
a850: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 ))..(define (tes
a860: 74 3a 67 65 74 2d 74 65 73 74 2d 68 61 73 68 20 t:get-test-hash
a870: 74 65 73 74 2d 64 61 74 61 29 0a 09 28 6c 65 74 test-data)..(let
a880: 20 28 28 72 65 73 68 20 28 6d 61 6b 65 2d 68 61 ((resh (make-ha
a890: 73 68 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 20 sh-table))).
a8a0: 09 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 74 .(map (lambda (t
a8b0: 65 73 74 29 0a 20 20 20 20 20 20 20 20 28 6c 65 est). (le
a8c0: 74 2a 20 28 28 74 65 73 74 2d 6e 61 6d 65 20 28 t* ((test-name (
a8d0: 76 65 63 74 6f 72 2d 72 65 66 20 74 65 73 74 20 vector-ref test
a8e0: 32 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 2)).
a8f0: 20 20 20 28 74 65 73 74 2d 68 74 6d 6c 2d 70 61 (test-html-pa
a900: 74 68 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 th (if (file-exi
a910: 73 74 73 3f 20 28 63 6f 6e 63 20 28 76 65 63 74 sts? (conc (vect
a920: 6f 72 2d 72 65 66 20 74 65 73 74 20 31 30 29 20 or-ref test 10)
a930: 22 2f 74 65 73 74 2d 73 75 6d 6d 61 72 79 2e 68 "/test-summary.h
a940: 74 6d 6c 22 29 29 0a 09 09 09 09 09 09 09 09 09 tml"))..........
a950: 09 09 09 09 09 09 09 20 28 63 6f 6e 63 20 28 76 ....... (conc (v
a960: 65 63 74 6f 72 2d 72 65 66 20 74 65 73 74 20 31 ector-ref test 1
a970: 30 29 20 22 2f 74 65 73 74 2d 73 75 6d 6d 61 72 0) "/test-summar
a980: 79 2e 68 74 6d 6c 22 20 29 0a 09 09 09 09 09 09 y.html" ).......
a990: 09 20 09 09 09 09 09 09 09 09 09 20 28 63 6f 6e . ......... (con
a9a0: 63 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 65 c (vector-ref te
a9b0: 73 74 20 31 30 29 20 22 2f 22 20 28 76 65 63 74 st 10) "/" (vect
a9c0: 6f 72 2d 72 65 66 20 74 65 73 74 20 31 33 29 29 or-ref test 13))
a9d0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
a9e0: 20 20 28 74 65 73 74 2d 69 74 65 6d 20 20 28 76 (test-item (v
a9f0: 65 63 74 6f 72 2d 72 65 66 20 74 65 73 74 20 31 ector-ref test 1
aa00: 31 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 1)).
aa10: 20 20 20 28 74 65 73 74 2d 73 74 61 74 75 73 20 (test-status
aa20: 28 76 65 63 74 6f 72 2d 72 65 66 20 74 65 73 74 (vector-ref test
aa30: 20 34 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 4))).
aa40: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 68 (if (not (h
aa50: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
aa60: 66 61 75 6c 74 20 72 65 73 68 20 74 65 73 74 2d fault resh test-
aa70: 69 74 65 6d 20 20 23 66 29 29 0a 20 20 20 20 20 item #f)).
aa80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 68 (h
aa90: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 72 ash-table-set! r
aaa0: 65 73 68 20 74 65 73 74 2d 69 74 65 6d 20 20 20 esh test-item
aab0: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
aac0: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
aad0: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 (hash-table-s
aae0: 65 74 21 20 28 68 61 73 68 2d 74 61 62 6c 65 2d et! (hash-table-
aaf0: 72 65 66 2f 64 65 66 61 75 6c 74 20 72 65 73 68 ref/default resh
ab00: 20 74 65 73 74 2d 69 74 65 6d 20 20 23 66 29 20 test-item #f)
ab10: 74 65 73 74 2d 6e 61 6d 65 20 28 6c 69 73 74 20 test-name (list
ab20: 74 65 73 74 2d 73 74 61 74 75 73 20 74 65 73 74 test-status test
ab30: 2d 68 74 6d 6c 2d 70 61 74 68 29 29 29 29 20 0a -html-path)))) .
ab40: 20 20 20 20 20 20 20 20 74 65 73 74 2d 64 61 74 test-dat
ab50: 61 29 0a 72 65 73 68 29 29 0a 0a 28 64 65 66 69 a).resh))..(defi
ab60: 6e 65 20 28 74 65 73 74 3a 67 65 74 2d 64 61 74 ne (test:get-dat
ab70: 61 2d 3e 62 2d 6b 65 79 73 20 6f 72 64 65 72 65 a->b-keys ordere
ab80: 64 2d 64 61 74 61 20 61 2d 6b 65 79 73 29 0a 20 d-data a-keys).
ab90: 20 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 (delete-duplica
aba0: 74 65 73 0a 20 20 20 28 73 6f 72 74 20 28 61 70 tes. (sort (ap
abb0: 70 6c 79 0a 09 20 20 61 70 70 65 6e 64 0a 09 20 ply.. append..
abc0: 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 73 (map (lambda (s
abd0: 75 62 2d 6b 65 79 29 0a 09 09 20 28 6c 65 74 20 ub-key)... (let
abe0: 28 28 73 75 62 64 61 74 20 28 68 61 73 68 2d 74 ((subdat (hash-t
abf0: 61 62 6c 65 2d 72 65 66 20 6f 72 64 65 72 65 64 able-ref ordered
ac00: 2d 64 61 74 61 20 73 75 62 2d 6b 65 79 29 29 29 -data sub-key)))
ac10: 0a 09 09 20 20 20 28 68 61 73 68 2d 74 61 62 6c ... (hash-tabl
ac20: 65 2d 6b 65 79 73 20 73 75 62 64 61 74 29 29 29 e-keys subdat)))
ac30: 0a 09 20 20 20 20 20 20 20 61 2d 6b 65 79 73 29 .. a-keys)
ac40: 29 0a 09 20 73 74 72 69 6e 67 3e 3d 3f 29 29 29 ).. string>=?)))
ac50: 0a 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 ...(define (test
ac60: 3a 63 72 65 61 74 65 2d 72 75 6e 2d 68 74 6d 6c :create-run-html
ac70: 20 72 75 6e 73 20 61 72 65 61 2d 6e 61 6d 65 20 runs area-name
ac80: 6c 69 6e 6b 74 72 65 65 20 6e 75 6d 6b 65 79 73 linktree numkeys
ac90: 20 68 65 61 64 65 72 29 0a 20 20 28 6d 61 70 20 header). (map
aca0: 28 6c 61 6d 62 64 61 20 28 72 75 6e 29 0a 09 09 (lambda (run)...
acb0: 20 28 6c 65 74 2a 20 28 28 74 61 72 67 65 74 20 (let* ((target
acc0: 28 73 74 72 69 6e 67 2d 6a 6f 69 6e 20 28 74 61 (string-join (ta
acd0: 6b 65 20 28 76 65 63 74 6f 72 2d 3e 6c 69 73 74 ke (vector->list
ace0: 20 72 75 6e 29 20 6e 75 6d 6b 65 79 73 29 20 22 run) numkeys) "
acf0: 2f 22 29 29 0a 09 09 09 09 09 09 28 72 75 6e 2d /")).......(run-
ad00: 6e 61 6d 65 20 28 64 62 3a 67 65 74 2d 76 61 6c name (db:get-val
ad10: 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e ue-by-header run
ad20: 20 68 65 61 64 65 72 20 22 72 75 6e 6e 61 6d 65 header "runname
ad30: 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ")).
ad40: 28 72 75 6e 2d 74 69 6d 65 20 28 73 65 63 6f 6e (run-time (secon
ad50: 64 73 2d 3e 77 6f 72 6b 2d 77 65 65 6b 2f 64 61 ds->work-week/da
ad60: 79 2d 74 69 6d 65 20 28 64 62 3a 67 65 74 2d 76 y-time (db:get-v
ad70: 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 alue-by-header r
ad80: 75 6e 20 68 65 61 64 65 72 20 22 65 76 65 6e 74 un header "event
ad90: 5f 74 69 6d 65 22 29 29 29 0a 09 09 09 09 09 09 _time"))).......
ada0: 28 6f 75 70 20 28 69 66 20 28 66 69 6c 65 2d 65 (oup (if (file-e
adb0: 78 69 73 74 73 3f 20 28 63 6f 6e 63 20 6c 69 6e xists? (conc lin
adc0: 6b 74 72 65 65 20 22 2f 22 20 74 61 72 67 65 74 ktree "/" target
add0: 20 22 2f 22 20 72 75 6e 2d 6e 61 6d 65 29 29 0a "/" run-name)).
ade0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
adf0: 20 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 6f 75 (open-ou
ae00: 74 70 75 74 2d 66 69 6c 65 20 28 63 6f 6e 63 20 tput-file (conc
ae10: 6c 69 6e 6b 74 72 65 65 20 22 2f 22 20 74 61 72 linktree "/" tar
ae20: 67 65 74 20 22 2f 22 20 72 75 6e 2d 6e 61 6d 65 get "/" run-name
ae30: 20 22 2f 72 75 6e 2e 68 74 6d 6c 22 29 29 0a 20 "/run.html")).
ae40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ae50: 20 20 20 20 20 20 20 20 23 66 29 29 0a 20 20 20 #f)).
ae60: 20 20 20 20 20 20 20 20 20 28 72 75 6e 2d 69 64 (run-id
ae70: 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 (db:get-value-b
ae80: 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 y-header run hea
ae90: 64 65 72 20 22 69 64 22 29 29 0a 20 20 20 20 20 der "id")).
aea0: 20 20 20 20 20 20 20 28 74 65 73 74 2d 64 61 74 (test-dat
aeb0: 61 20 20 20 20 28 72 6d 74 3a 67 65 74 2d 74 65 a (rmt:get-te
aec0: 73 74 73 2d 66 6f 72 2d 72 75 6e 0a 09 09 09 09 sts-for-run.....
aed0: 20 20 09 09 09 09 09 09 09 09 20 72 75 6e 2d 69 ........ run-i
aee0: 64 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 d.
aef0: 20 20 20 20 20 20 20 20 20 20 20 20 20 22 25 22 "%"
af00: 20 20 20 20 20 20 20 3b 3b 20 74 65 73 74 6e 61 ;; testna
af10: 6d 65 70 61 74 74 0a 09 09 09 09 20 20 09 09 09 mepatt..... ...
af20: 09 09 09 09 09 20 27 28 29 20 20 20 20 20 20 20 ..... '()
af30: 20 3b 3b 20 73 74 61 74 65 73 0a 09 09 09 09 20 ;; states.....
af40: 20 20 09 09 09 09 09 09 09 09 20 27 28 29 20 20 ........ '()
af50: 20 20 20 20 20 20 3b 3b 20 73 74 61 74 75 73 65 ;; statuse
af60: 73 0a 09 09 09 09 20 20 09 09 09 09 09 09 09 09 s..... ........
af70: 20 09 23 66 20 20 20 20 20 20 20 20 20 3b 3b 20 .#f ;;
af80: 6f 66 66 73 65 74 0a 09 09 09 09 20 20 09 09 09 offset..... ...
af90: 09 09 09 20 09 09 09 23 66 20 20 20 20 20 20 20 ... ...#f
afa0: 20 20 3b 3b 20 6e 75 6d 2d 74 6f 2d 67 65 74 0a ;; num-to-get.
afb0: 09 09 09 09 20 20 20 09 09 09 09 09 09 09 09 09 .... .........
afc0: 23 66 20 20 20 20 20 20 20 20 20 3b 3b 20 68 69 #f ;; hi
afd0: 64 65 2f 6e 6f 74 2d 68 69 64 65 0a 09 09 09 09 de/not-hide.....
afe0: 20 20 09 09 09 09 09 09 09 09 20 20 23 66 20 20 ........ #f
aff0: 20 20 20 20 20 20 20 3b 3b 20 73 6f 72 74 2d 62 ;; sort-b
b000: 79 0a 09 09 09 09 20 20 20 09 09 09 09 09 09 09 y..... .......
b010: 09 09 23 66 20 20 20 20 20 20 20 20 20 3b 3b 20 ..#f ;;
b020: 73 6f 72 74 2d 6f 72 64 65 72 0a 09 09 09 09 20 sort-order.....
b030: 20 20 09 09 09 09 09 09 09 09 09 23 66 20 20 20 .........#f
b040: 20 20 20 20 20 20 3b 3b 20 27 73 68 6f 72 74 6c ;; 'shortl
b050: 69 73 74 20 20 20 20 20 20 20 20 20 20 20 20 20 ist
b060: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b ;;
b070: 20 71 72 79 74 79 70 65 0a 20 20 20 20 20 20 20 qrytype.
b080: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b090: 20 20 20 20 20 30 20 20 20 20 20 20 20 20 20 3b 0 ;
b0a0: 3b 20 6c 61 73 74 20 75 70 64 61 74 65 0a 09 09 ; last update...
b0b0: 09 09 20 20 09 09 09 09 09 09 09 09 09 23 66 29 .. .........#f)
b0c0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 69 ). (i
b0d0: 74 65 6d 2d 74 65 73 74 2d 68 61 73 68 20 28 74 tem-test-hash (t
b0e0: 65 73 74 3a 67 65 74 2d 74 65 73 74 2d 68 61 73 est:get-test-has
b0f0: 68 20 74 65 73 74 2d 64 61 74 61 29 29 0a 20 20 h test-data)).
b100: 20 20 20 20 20 20 20 20 20 20 28 69 74 65 6d 73 (items
b110: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 (hash-table-ke
b120: 79 73 20 69 74 65 6d 2d 74 65 73 74 2d 68 61 73 ys item-test-has
b130: 68 29 29 0a 20 09 09 09 09 09 09 28 74 65 73 74 h)). ......(test
b140: 2d 6e 61 6d 65 73 20 28 74 65 73 74 3a 67 65 74 -names (test:get
b150: 2d 64 61 74 61 2d 3e 62 2d 6b 65 79 73 20 69 74 -data->b-keys it
b160: 65 6d 2d 74 65 73 74 2d 68 61 73 68 20 69 74 65 em-test-hash ite
b170: 6d 73 29 29 29 0a 20 20 20 20 28 69 66 20 6f 75 ms))). (if ou
b180: 70 0a 20 20 20 20 20 20 28 62 65 67 69 6e 20 0a p. (begin .
b190: 20 20 20 20 20 28 73 3a 6f 75 74 70 75 74 2d 6e (s:output-n
b1a0: 65 77 0a 09 20 20 20 6f 75 70 0a 09 20 20 20 28 ew.. oup.. (
b1b0: 73 3a 68 74 6d 6c 20 74 65 73 74 73 3a 63 73 73 s:html tests:css
b1c0: 2d 6a 73 63 72 69 70 74 2d 62 6c 6f 63 6b 20 28 -jscript-block (
b1d0: 74 65 73 74 73 3a 63 73 73 2d 6a 73 63 72 69 70 tests:css-jscrip
b1e0: 74 2d 62 6c 6f 63 6b 2d 63 6f 6e 64 20 23 66 29 t-block-cond #f)
b1f0: 0a 09 09 20 20 20 28 73 3a 74 69 74 6c 65 20 22 ... (s:title "
b200: 52 75 6e 73 20 56 69 65 77 20 22 20 72 75 6e 2d Runs View " run-
b210: 6e 61 6d 65 29 0a 09 09 20 20 20 28 73 3a 62 6f name)... (s:bo
b220: 64 79 0a 09 09 20 20 20 20 20 28 73 3a 68 31 20 dy... (s:h1
b230: 22 52 75 6e 73 20 56 69 65 77 20 22 20 29 0a 20 "Runs View " ).
b240: 20 20 20 20 20 20 20 20 28 73 3a 68 33 20 22 54 (s:h3 "T
b250: 61 72 67 65 74 22 20 74 61 72 67 65 74 29 0a 09 arget" target)..
b260: 09 09 09 20 28 73 3a 70 20 0a 09 09 09 09 09 28 ... (s:p ......(
b270: 73 3a 62 20 22 52 75 6e 20 6e 61 6d 65 22 20 29 s:b "Run name" )
b280: 20 72 75 6e 2d 6e 61 6d 65 29 0a 20 20 20 20 20 run-name).
b290: 20 20 20 20 28 73 3a 70 20 0a 09 09 09 09 09 28 (s:p ......(
b2a0: 73 3a 62 20 22 52 75 6e 20 44 61 74 65 22 20 29 s:b "Run Date" )
b2b0: 20 72 75 6e 2d 74 69 6d 65 29 0a 20 20 20 20 20 run-time).
b2c0: 20 20 20 20 28 73 3a 74 61 62 6c 65 20 27 62 6f (s:table 'bo
b2d0: 72 64 65 72 20 31 20 27 63 65 6c 6c 73 70 61 63 rder 1 'cellspac
b2e0: 69 6e 67 20 30 0a 20 20 20 20 20 20 20 20 20 20 ing 0.
b2f0: 20 28 73 3a 74 72 0a 20 20 20 20 20 20 20 20 20 (s:tr.
b300: 20 20 28 73 3a 74 68 20 22 49 74 65 6d 73 22 29 (s:th "Items")
b310: 0a 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 70 . (map
b320: 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 29 0a (lambda (test).
b330: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 3a 74 (s:t
b340: 68 20 74 65 73 74 29 29 0a 20 20 20 20 20 20 20 h test)).
b350: 20 20 20 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 test-names))
b360: 20 20 0a 20 20 20 20 20 20 20 20 20 20 20 28 6d . (m
b370: 61 70 20 28 6c 61 6d 62 64 61 20 28 69 74 65 6d ap (lambda (item
b380: 29 20 0a 09 09 09 09 09 20 20 28 6c 65 74 2a 20 ) ...... (let*
b390: 28 28 74 65 73 74 2d 68 61 73 68 20 28 68 61 73 ((test-hash (has
b3a0: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
b3b0: 75 6c 74 20 69 74 65 6d 2d 74 65 73 74 2d 68 61 ult item-test-ha
b3c0: 73 68 20 69 74 65 6d 20 20 23 66 29 29 29 0a 09 sh item #f)))..
b3d0: 09 09 09 09 09 09 09 20 28 69 66 20 74 65 73 74 ....... (if test
b3e0: 2d 68 61 73 68 0a 20 20 20 20 20 20 20 20 20 20 -hash.
b3f0: 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 (begin..
b400: 09 09 09 09 09 09 09 09 28 73 3a 74 72 0a 09 09 ........(s:tr...
b410: 09 09 09 20 20 09 09 09 28 73 3a 74 64 20 27 63 ... ...(s:td 'c
b420: 6c 61 73 73 20 22 74 65 73 74 22 20 69 74 65 6d lass "test" item
b430: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 09 09 ). ..
b440: 09 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 74 .(map (lambda (t
b450: 65 73 74 29 0a 09 09 09 09 09 09 20 20 09 09 28 est)....... ..(
b460: 6c 65 74 2a 20 28 28 74 65 73 74 2d 64 65 74 61 let* ((test-deta
b470: 69 6c 73 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ils (hash-table-
b480: 72 65 66 2f 64 65 66 61 75 6c 74 20 74 65 73 74 ref/default test
b490: 2d 68 61 73 68 20 74 65 73 74 20 20 23 66 29 29 -hash test #f))
b4a0: 0a 09 09 09 09 09 09 09 09 09 09 09 09 28 73 74 .............(st
b4b0: 61 74 75 73 20 28 69 66 20 74 65 73 74 2d 64 65 atus (if test-de
b4c0: 74 61 69 6c 73 0a 09 09 09 09 09 09 09 09 09 09 tails...........
b4d0: 09 09 09 09 09 09 28 63 61 72 20 74 65 73 74 2d ......(car test-
b4e0: 64 65 74 61 69 6c 73 29 29 29 0a 20 20 20 20 20 details))).
b4f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b500: 20 20 20 28 6c 69 6e 6b 20 28 69 66 20 74 65 73 (link (if tes
b510: 74 2d 64 65 74 61 69 6c 73 20 0a 09 09 09 09 09 t-details ......
b520: 09 09 09 09 09 09 09 09 09 28 73 74 72 69 6e 67 .........(string
b530: 2d 73 75 62 73 74 69 74 75 74 65 20 20 28 63 6f -substitute (co
b540: 6e 63 20 6c 69 6e 6b 74 72 65 65 20 22 2f 22 20 nc linktree "/"
b550: 74 61 72 67 65 74 20 22 2f 22 20 72 75 6e 2d 6e target "/" run-n
b560: 61 6d 65 20 22 2f 22 29 20 20 22 22 20 28 63 61 ame "/") "" (ca
b570: 64 72 20 74 65 73 74 2d 64 65 74 61 69 6c 73 29 dr test-details)
b580: 20 22 2d 22 29 29 29 29 0a 20 20 20 20 20 20 20 "-")))).
b590: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
b5a0: 74 65 73 74 2d 64 65 74 61 69 6c 73 0a 09 09 09 test-details....
b5b0: 09 09 09 09 09 09 09 09 28 73 3a 74 64 20 27 63 ........(s:td 'c
b5c0: 6c 61 73 73 20 73 74 61 74 75 73 0a 09 09 09 09 lass status.....
b5d0: 09 09 09 09 09 09 09 09 28 73 3a 61 20 27 63 6c ........(s:a 'cl
b5e0: 61 73 73 20 22 6c 69 6e 6b 22 20 27 68 72 65 66 ass "link" 'href
b5f0: 20 6c 69 6e 6b 20 73 74 61 74 75 73 20 29 29 0a link status )).
b600: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b610: 20 20 20 20 20 20 28 73 3a 74 64 20 22 22 29 29 (s:td ""))
b620: 29 29 20 09 09 09 0a 09 09 09 09 09 09 09 09 09 )) .............
b630: 74 65 73 74 2d 6e 61 6d 65 73 29 29 29 29 29 29 test-names))))))
b640: 0a 09 09 09 09 20 20 28 73 6f 72 74 20 69 74 65 ..... (sort ite
b650: 6d 73 20 73 74 72 69 6e 67 3c 3d 3f 29 29 29 29 ms string<=?))))
b660: 29 29 0a 09 09 28 63 6c 6f 73 65 2d 6f 75 74 70 ))...(close-outp
b670: 75 74 2d 70 6f 72 74 20 6f 75 70 29 29 0a 20 20 ut-port oup)).
b680: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
b690: 6e 66 6f 20 30 20 22 53 6b 69 70 3a 20 44 69 72 nfo 0 "Skip: Dir
b6a0: 63 74 6f 72 79 20 73 74 72 75 63 74 75 72 65 20 ctory structure
b6b0: 22 20 6c 69 6e 6b 74 72 65 65 20 22 2f 22 20 74 " linktree "/" t
b6c0: 61 72 67 65 74 20 22 2f 22 20 72 75 6e 2d 6e 61 arget "/" run-na
b6d0: 6d 65 20 22 20 64 6f 65 73 20 6e 6f 74 20 65 78 me " does not ex
b6e0: 69 73 74 2e 20 4d 65 67 61 74 65 73 74 20 77 69 ist. Megatest wi
b6f0: 6c 6c 20 6e 6f 74 20 63 72 65 61 74 65 20 72 75 ll not create ru
b700: 6e 2e 68 74 6d 6c 22 29 29 29 29 0a 72 75 6e 73 n.html")))).runs
b710: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 ))..(define (tes
b720: 74 3a 63 72 65 61 74 65 2d 74 61 72 67 65 74 2d t:create-target-
b730: 68 61 73 68 20 72 75 6e 73 20 68 65 61 64 65 72 hash runs header
b740: 20 6e 75 6d 6b 65 79 73 29 0a 20 20 28 6c 65 74 numkeys). (let
b750: 20 28 28 72 65 73 68 20 28 6d 61 6b 65 2d 68 61 ((resh (make-ha
b760: 73 68 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 28 sh-table))). (
b770: 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 6c for-each. (l
b780: 61 6d 62 64 61 20 28 72 75 6e 29 0a 20 20 20 20 ambda (run).
b790: 20 20 20 20 28 6c 65 74 2a 20 28 28 72 75 6e 2d (let* ((run-
b7a0: 6e 61 6d 65 20 28 64 62 3a 67 65 74 2d 76 61 6c name (db:get-val
b7b0: 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e ue-by-header run
b7c0: 20 68 65 61 64 65 72 20 22 72 75 6e 6e 61 6d 65 header "runname
b7d0: 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ")).
b7e0: 20 20 20 28 74 61 72 67 65 74 20 20 20 28 73 74 (target (st
b7f0: 72 69 6e 67 2d 6a 6f 69 6e 20 28 74 61 6b 65 20 ring-join (take
b800: 28 76 65 63 74 6f 72 2d 3e 6c 69 73 74 20 72 75 (vector->list ru
b810: 6e 29 20 6e 75 6d 6b 65 79 73 29 20 22 2f 22 29 n) numkeys) "/")
b820: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
b830: 20 28 72 75 6e 2d 6c 69 73 74 20 28 68 61 73 68 (run-list (hash
b840: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
b850: 6c 74 20 72 65 73 68 20 74 61 72 67 65 74 20 20 lt resh target
b860: 23 66 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 #f))).
b870: 20 20 20 20 20 0a 20 20 20 20 20 20 20 20 20 20 .
b880: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 72 75 (if (not ru
b890: 6e 2d 6c 69 73 74 29 0a 20 20 20 20 20 20 20 20 n-list).
b8a0: 20 20 20 20 20 20 20 20 20 20 20 28 68 61 73 68 (hash
b8b0: 2d 74 61 62 6c 65 2d 73 65 74 21 20 72 65 73 68 -table-set! resh
b8c0: 20 74 61 72 67 65 74 20 20 20 28 6c 69 73 74 20 target (list
b8d0: 72 75 6e 2d 6e 61 6d 65 29 29 0a 20 20 20 20 20 run-name)).
b8e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 68 (h
b8f0: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 72 ash-table-set! r
b900: 65 73 68 20 74 61 72 67 65 74 20 20 20 28 63 6f esh target (co
b910: 6e 73 20 72 75 6e 2d 6e 61 6d 65 20 72 75 6e 2d ns run-name run-
b920: 6c 69 73 74 29 29 29 29 29 0a 20 20 20 20 20 20 list))))).
b930: 72 75 6e 73 29 0a 20 20 20 72 65 73 68 29 29 0a runs). resh)).
b940: 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 3a 67 .(define (test:g
b950: 65 74 2d 6d 61 78 2d 72 75 6e 2d 63 6e 74 20 74 et-max-run-cnt t
b960: 61 72 67 65 74 2d 68 61 73 68 20 74 61 72 67 65 arget-hash targe
b970: 74 73 29 0a 20 20 20 28 6c 65 74 2a 20 28 28 63 ts). (let* ((c
b980: 6e 74 20 30 20 29 29 0a 20 20 20 28 6d 61 70 20 nt 0 )). (map
b990: 28 6c 61 6d 62 64 61 20 28 74 61 72 67 65 74 29 (lambda (target)
b9a0: 0a 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 . (let* (
b9b0: 28 72 75 6e 73 20 20 28 68 61 73 68 2d 74 61 62 (runs (hash-tab
b9c0: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 le-ref/default t
b9d0: 61 72 67 65 74 2d 68 61 73 68 20 74 61 72 67 65 arget-hash targe
b9e0: 74 20 20 23 66 29 29 0a 20 20 20 20 20 20 20 20 t #f)).
b9f0: 20 20 20 20 20 20 20 28 72 75 6e 2d 6c 65 6e 67 (run-leng
ba00: 74 68 20 28 69 66 20 72 75 6e 73 0a 09 09 09 09 th (if runs.....
ba10: 09 09 09 09 09 09 09 09 09 09 09 09 28 6c 65 6e ............(len
ba20: 67 74 68 20 72 75 6e 73 29 0a 20 20 20 20 20 20 gth runs).
ba30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ba40: 20 20 20 20 20 20 20 20 20 20 20 30 29 29 29 0a 0))).
ba50: 20 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 .
ba60: 20 28 69 66 20 28 3c 20 63 6e 74 20 72 75 6e 2d (if (< cnt run-
ba70: 6c 65 6e 67 74 68 29 0a 20 20 20 20 20 20 20 20 length).
ba80: 20 20 20 20 20 20 20 28 73 65 74 21 20 63 6e 74 (set! cnt
ba90: 20 20 72 75 6e 2d 6c 65 6e 67 74 68 29 29 29 29 run-length))))
baa0: 20 0a 09 09 74 61 72 67 65 74 73 29 20 0a 63 6e ...targets) .cn
bab0: 74 29 29 0a 20 0a 28 64 65 66 69 6e 65 20 28 74 t)). .(define (t
bac0: 65 73 74 3a 70 61 64 2d 72 75 6e 73 20 74 61 72 est:pad-runs tar
bad0: 67 65 74 2d 68 61 73 68 20 74 61 72 67 65 74 73 get-hash targets
bae0: 20 6d 61 78 2d 72 6f 77 2d 6c 65 6e 67 74 68 29 max-row-length)
baf0: 0a 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 . (map (lambda (
bb00: 74 61 72 67 65 74 29 0a 20 20 20 20 20 20 20 20 target).
bb10: 28 6c 65 74 20 6c 6f 6f 70 20 28 28 72 75 6e 2d (let loop ((run-
bb20: 6c 69 73 74 20 20 28 68 61 73 68 2d 74 61 62 6c list (hash-tabl
bb30: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 61 e-ref/default ta
bb40: 72 67 65 74 2d 68 61 73 68 20 74 61 72 67 65 74 rget-hash target
bb50: 20 20 23 66 29 29 29 0a 20 20 20 20 20 20 20 20 #f))).
bb60: 20 20 20 20 20 20 20 28 69 66 20 28 3c 20 28 6c (if (< (l
bb70: 65 6e 67 74 68 20 72 75 6e 2d 6c 69 73 74 29 20 ength run-list)
bb80: 6d 61 78 2d 72 6f 77 2d 6c 65 6e 67 74 68 29 0a max-row-length).
bb90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bba0: 20 28 62 65 67 69 6e 20 20 0a 20 20 20 20 20 20 (begin .
bbb0: 20 20 20 20 20 20 20 20 20 09 09 20 28 68 61 73 .. (has
bbc0: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 61 72 h-table-set! tar
bbd0: 67 65 74 2d 68 61 73 68 20 74 61 72 67 65 74 20 get-hash target
bbe0: 20 20 28 63 6f 6e 73 20 22 22 20 72 75 6e 2d 6c (cons "" run-l
bbf0: 69 73 74 29 29 0a 20 20 20 20 20 20 20 20 20 20 ist)).
bc00: 20 20 20 20 20 09 09 20 28 6c 6f 6f 70 20 28 68 .. (loop (h
bc10: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
bc20: 66 61 75 6c 74 20 74 61 72 67 65 74 2d 68 61 73 fault target-has
bc30: 68 20 74 61 72 67 65 74 20 20 23 66 29 20 29 29 h target #f) ))
bc40: 29 29 29 20 0a 09 09 74 61 72 67 65 74 73 29 0a ))) ...targets).
bc50: 20 20 20 74 61 72 67 65 74 2d 68 61 73 68 29 0a target-hash).
bc60: 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 3a 63 .(define (test:c
bc70: 72 65 61 74 65 2d 74 61 72 67 65 74 2d 68 74 6d reate-target-htm
bc80: 6c 20 74 61 72 67 65 74 2d 68 61 73 68 20 6f 75 l target-hash ou
bc90: 70 20 61 72 65 61 2d 6e 61 6d 65 20 6c 69 6e 6b p area-name link
bca0: 74 72 65 65 29 0a 20 20 28 6c 65 74 2a 20 28 28 tree). (let* ((
bcb0: 74 61 72 67 65 74 73 20 28 68 61 73 68 2d 74 61 targets (hash-ta
bcc0: 62 6c 65 2d 6b 65 79 73 20 74 61 72 67 65 74 2d ble-keys target-
bcd0: 68 61 73 68 29 29 0a 20 20 20 20 20 20 20 20 20 hash)).
bce0: 28 6d 61 78 2d 72 6f 77 2d 6c 65 6e 67 74 68 20 (max-row-length
bcf0: 28 74 65 73 74 3a 67 65 74 2d 6d 61 78 2d 72 75 (test:get-max-ru
bd00: 6e 2d 63 6e 74 20 74 61 72 67 65 74 2d 68 61 73 n-cnt target-has
bd10: 68 20 74 61 72 67 65 74 73 29 29 0a 20 20 20 20 h targets)).
bd20: 20 20 20 20 20 28 70 61 64 2d 72 75 6e 73 2d 68 (pad-runs-h
bd30: 61 73 68 20 28 74 65 73 74 3a 70 61 64 2d 72 75 ash (test:pad-ru
bd40: 6e 73 20 74 61 72 67 65 74 2d 68 61 73 68 20 74 ns target-hash t
bd50: 61 72 67 65 74 73 20 6d 61 78 2d 72 6f 77 2d 6c argets max-row-l
bd60: 65 6e 67 74 68 29 29 29 0a 20 20 20 28 73 3a 6f ength))). (s:o
bd70: 75 74 70 75 74 2d 6e 65 77 0a 09 20 20 20 6f 75 utput-new.. ou
bd80: 70 0a 09 20 20 20 28 73 3a 68 74 6d 6c 20 74 65 p.. (s:html te
bd90: 73 74 73 3a 63 73 73 2d 6a 73 63 72 69 70 74 2d sts:css-jscript-
bda0: 62 6c 6f 63 6b 20 28 74 65 73 74 73 3a 63 73 73 block (tests:css
bdb0: 2d 6a 73 63 72 69 70 74 2d 62 6c 6f 63 6b 2d 63 -jscript-block-c
bdc0: 6f 6e 64 20 23 66 29 0a 0a 09 09 20 20 20 28 73 ond #f).... (s
bdd0: 3a 74 69 74 6c 65 20 22 54 61 72 67 65 74 20 56 :title "Target V
bde0: 69 65 77 20 22 20 61 72 65 61 2d 6e 61 6d 65 29 iew " area-name)
bdf0: 0a 09 09 20 20 20 28 73 3a 62 6f 64 79 0a 09 09 ... (s:body...
be00: 20 20 20 28 73 3a 68 31 20 22 54 61 72 67 65 74 (s:h1 "Target
be10: 20 56 69 65 77 20 22 20 61 72 65 61 2d 6e 61 6d View " area-nam
be20: 65 29 0a 09 09 09 09 09 28 73 3a 74 61 62 6c 65 e)......(s:table
be30: 20 27 69 64 20 22 4c 69 6e 6b 65 64 4c 69 73 74 'id "LinkedList
be40: 31 22 20 27 62 6f 72 64 65 72 20 22 31 22 20 27 1" 'border "1" '
be50: 63 65 6c 6c 73 70 61 63 69 6e 67 20 30 0a 20 20 cellspacing 0.
be60: 20 20 20 20 20 20 20 20 20 20 20 28 73 3a 74 72 (s:tr
be70: 20 27 63 6c 61 73 73 20 22 73 6f 6d 65 74 68 69 'class "somethi
be80: 6e 67 22 20 0a 20 20 20 20 20 20 20 20 20 20 20 ng" .
be90: 20 20 20 20 28 73 3a 74 68 20 22 54 61 72 67 65 (s:th "Targe
bea0: 74 22 29 0a 09 09 09 09 09 09 09 09 28 73 3a 74 t").........(s:t
beb0: 68 20 27 63 6f 6c 73 70 61 6e 20 6d 61 78 2d 72 h 'colspan max-r
bec0: 6f 77 2d 6c 65 6e 67 74 68 20 22 52 75 6e 73 22 ow-length "Runs"
bed0: 29 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ))
bee0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bef0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bf00: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
bf10: 20 28 6c 65 74 2a 20 28 28 74 62 6c 20 28 6d 61 (let* ((tbl (ma
bf20: 70 20 28 6c 61 6d 62 64 61 20 28 74 61 72 67 65 p (lambda (targe
bf30: 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 t).
bf40: 20 20 20 20 20 20 20 20 20 28 73 3a 74 72 0a 20 (s:tr.
bf50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bf60: 20 20 20 20 20 28 73 3a 74 64 20 27 63 6c 61 73 (s:td 'clas
bf70: 73 20 22 74 65 73 74 22 20 74 61 72 67 65 74 29 s "test" target)
bf80: 0a 09 09 09 09 09 09 09 09 09 09 20 20 28 6c 65 ........... (le
bf90: 74 2a 20 28 28 72 75 6e 73 20 20 28 68 61 73 68 t* ((runs (hash
bfa0: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
bfb0: 6c 74 20 74 61 72 67 65 74 2d 68 61 73 68 20 74 lt target-hash t
bfc0: 61 72 67 65 74 20 20 23 66 29 29 0a 09 09 09 09 arget #f)).....
bfd0: 09 09 09 09 09 09 09 09 09 09 20 28 72 65 73 74 .......... (rest
bfe0: 2d 72 6f 77 20 28 6d 61 70 20 28 6c 61 6d 62 64 -row (map (lambd
bff0: 61 20 28 72 75 6e 29 0a 09 09 09 09 09 09 09 09 a (run).........
c000: 09 09 09 09 09 09 09 09 09 09 09 09 28 69 66 20 ............(if
c010: 28 65 71 75 61 6c 3f 20 72 75 6e 20 22 22 29 0a (equal? run "").
c020: 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 ................
c030: 09 09 09 09 09 09 28 73 3a 74 64 20 72 75 6e 29 ......(s:td run)
c040: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
c050: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c060: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
c070: 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 28 63 (file-exists?(c
c080: 6f 6e 63 20 6c 69 6e 6b 74 72 65 65 20 22 2f 22 onc linktree "/"
c090: 20 74 61 72 67 65 74 20 22 2f 22 20 72 75 6e 20 target "/" run
c0a0: 29 29 0a 09 09 09 09 09 09 09 09 09 09 09 09 09 ))..............
c0b0: 09 09 09 09 09 09 09 09 09 28 62 65 67 69 6e 20 .........(begin
c0c0: 0a 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 ................
c0d0: 09 09 09 09 09 09 09 09 28 73 3a 74 64 20 0a 09 ........(s:td ..
c0e0: 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 ................
c0f0: 09 09 09 09 09 09 28 73 3a 61 20 27 68 72 65 66 ......(s:a 'href
c100: 20 28 63 6f 6e 63 20 20 74 61 72 67 65 74 20 22 (conc target "
c110: 2f 22 20 72 75 6e 20 22 2f 72 75 6e 2e 68 74 6d /" run "/run.htm
c120: 6c 22 29 20 72 75 6e 29 29 29 29 29 29 0a 09 09 l") run))))))...
c130: 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 ................
c140: 09 09 28 72 65 76 65 72 73 65 20 72 75 6e 73 29 ..(reverse runs)
c150: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
c160: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c170: 20 20 72 65 73 74 2d 72 6f 77 29 29 29 0a 20 20 rest-row))).
c180: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c190: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c1a0: 20 74 61 72 67 65 74 73 29 29 29 0a 20 20 20 20 targets))).
c1b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c1c0: 20 20 20 20 20 20 20 74 62 6c 29 29 29 29 29 0a tbl))))).
c1d0: 20 20 20 20 20 20 20 20 20 20 28 63 6c 6f 73 65 (close
c1e0: 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 6f 75 70 -output-port oup
c1f0: 29 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 74 )))...(define (t
c200: 65 73 74 73 3a 63 72 65 61 74 65 2d 68 74 6d 6c ests:create-html
c210: 2d 74 72 65 65 2d 6f 6c 64 20 6f 75 74 66 29 0a -tree-old outf).
c220: 20 20 20 28 6c 65 74 2a 20 28 28 6c 6f 63 6b 66 (let* ((lockf
c230: 69 6c 65 20 20 28 63 6f 6e 63 20 6f 75 74 66 20 ile (conc outf
c240: 22 2e 6c 6f 63 6b 22 29 29 0a 09 20 28 72 75 6e ".lock")).. (run
c250: 73 2d 74 6f 2d 70 72 6f 63 65 73 73 20 27 28 29 s-to-process '()
c260: 29 29 0a 20 20 20 20 28 69 66 20 28 63 6f 6d 6d )). (if (comm
c270: 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 6c on:simple-file-l
c280: 6f 63 6b 20 6c 6f 63 6b 66 69 6c 65 29 0a 09 28 ock lockfile)..(
c290: 6c 65 74 2a 20 28 28 6c 69 6e 6b 74 72 65 65 20 let* ((linktree
c2a0: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 69 6e (common:get-lin
c2b0: 6b 74 72 65 65 29 29 0a 09 20 20 20 20 20 20 20 ktree))..
c2c0: 28 6f 75 70 20 20 20 20 20 20 20 28 6f 70 65 6e (oup (open
c2d0: 2d 6f 75 74 70 75 74 2d 66 69 6c 65 20 28 6f 72 -output-file (or
c2e0: 20 6f 75 74 66 20 28 63 6f 6e 63 20 6c 69 6e 6b outf (conc link
c2f0: 74 72 65 65 20 22 2f 72 75 6e 73 2d 69 6e 64 65 tree "/runs-inde
c300: 78 2e 68 74 6d 6c 22 29 29 29 29 0a 09 20 20 20 x.html"))))..
c310: 20 20 20 20 28 61 72 65 61 2d 6e 61 6d 65 20 28 (area-name (
c320: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 74 65 73 74 73 common:get-tests
c330: 75 69 74 65 2d 6e 61 6d 65 29 29 0a 09 20 20 20 uite-name))..
c340: 20 20 20 20 28 6b 65 79 73 20 20 20 20 20 20 28 (keys (
c350: 72 6d 74 3a 67 65 74 2d 6b 65 79 73 29 29 0a 09 rmt:get-keys))..
c360: 20 20 20 20 20 20 20 28 6e 75 6d 6b 65 79 73 20 (numkeys
c370: 20 20 28 6c 65 6e 67 74 68 20 6b 65 79 73 29 29 (length keys))
c380: 0a 09 20 20 20 20 20 20 20 28 72 75 6e 73 64 61 .. (runsda
c390: 74 20 20 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e t (rmt:get-run
c3a0: 73 20 22 25 22 20 23 66 20 23 66 20 28 6d 61 70 s "%" #f #f (map
c3b0: 20 28 6c 61 6d 62 64 61 20 28 78 29 28 6c 69 73 (lambda (x)(lis
c3c0: 74 20 78 20 22 25 22 29 29 20 6b 65 79 73 29 29 t x "%")) keys))
c3d0: 29 0a 09 20 20 20 20 20 20 20 28 68 65 61 64 65 ).. (heade
c3e0: 72 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 r (vector-ref
c3f0: 20 72 75 6e 73 64 61 74 20 30 29 29 0a 09 20 20 runsdat 0))..
c400: 20 20 20 20 20 28 72 75 6e 73 20 20 20 20 20 20 (runs
c410: 28 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 73 (vector-ref runs
c420: 64 61 74 20 31 29 29 0a 09 20 20 20 20 20 20 20 dat 1))..
c430: 28 72 75 6e 74 72 65 65 64 61 74 20 28 6d 61 70 (runtreedat (map
c440: 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 09 09 (lambda (x)....
c450: 09 20 20 28 74 65 73 74 73 3a 72 75 6e 2d 72 65 . (tests:run-re
c460: 63 6f 72 64 2d 3e 74 65 73 74 2d 70 61 74 68 20 cord->test-path
c470: 78 20 6e 75 6d 6b 65 79 73 29 29 0a 09 09 09 09 x numkeys)).....
c480: 72 75 6e 73 29 29 0a 09 20 20 20 20 20 20 20 28 runs)).. (
c490: 72 75 6e 73 2d 68 74 72 65 65 20 28 63 6f 6d 6d runs-htree (comm
c4a0: 6f 6e 3a 6c 69 73 74 2d 3e 68 74 72 65 65 20 72 on:list->htree r
c4b0: 75 6e 74 72 65 65 64 61 74 29 29 29 0a 09 20 20 untreedat)))..
c4c0: 28 73 65 74 21 20 72 75 6e 73 2d 74 6f 2d 70 72 (set! runs-to-pr
c4d0: 6f 63 65 73 73 20 72 75 6e 73 29 0a 09 20 20 28 ocess runs).. (
c4e0: 73 3a 6f 75 74 70 75 74 2d 6e 65 77 0a 09 20 20 s:output-new..
c4f0: 20 6f 75 70 0a 09 20 20 20 28 73 3a 68 74 6d 6c oup.. (s:html
c500: 20 74 65 73 74 73 3a 63 73 73 2d 6a 73 63 72 69 tests:css-jscri
c510: 70 74 2d 62 6c 6f 63 6b 0a 09 09 20 20 20 28 73 pt-block... (s
c520: 3a 74 69 74 6c 65 20 22 53 75 6d 6d 61 72 79 20 :title "Summary
c530: 66 6f 72 20 22 20 61 72 65 61 2d 6e 61 6d 65 29 for " area-name)
c540: 0a 09 09 20 20 20 28 73 3a 62 6f 64 79 20 27 6f ... (s:body 'o
c550: 6e 6c 6f 61 64 20 22 61 64 64 45 76 65 6e 74 73 nload "addEvents
c560: 28 29 3b 22 0a 09 09 09 20 20 20 28 73 3a 68 31 ();".... (s:h1
c570: 20 22 53 75 6d 6d 61 72 79 20 66 6f 72 20 22 20 "Summary for "
c580: 61 72 65 61 2d 6e 61 6d 65 29 0a 09 09 09 20 20 area-name)....
c590: 20 3b 3b 20 74 6f 70 20 6c 69 73 74 0a 09 09 09 ;; top list....
c5a0: 20 20 20 28 73 3a 75 6c 20 27 69 64 20 22 4c 69 (s:ul 'id "Li
c5b0: 6e 6b 65 64 4c 69 73 74 31 22 20 27 63 6c 61 73 nkedList1" 'clas
c5c0: 73 20 22 4c 69 6e 6b 65 64 4c 69 73 74 22 0a 09 s "LinkedList"..
c5d0: 09 09 09 20 28 73 3a 6c 69 0a 09 09 09 09 20 20 ... (s:li.....
c5e0: 22 52 75 6e 73 22 0a 09 09 09 09 20 20 28 63 6f "Runs"..... (co
c5f0: 6d 6d 6f 6e 3a 68 74 72 65 65 2d 3e 68 74 6d 6c mmon:htree->html
c600: 20 72 75 6e 73 2d 68 74 72 65 65 0a 09 09 09 09 runs-htree.....
c610: 09 09 20 20 20 20 20 20 27 28 29 0a 09 09 09 09 .. '().....
c620: 09 09 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 .. (lambda
c630: 28 78 20 70 29 0a 09 09 09 09 09 09 09 28 6c 65 (x p)........(le
c640: 74 2a 20 28 28 74 61 72 67 2d 70 61 74 68 20 28 t* ((targ-path (
c650: 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
c660: 73 65 20 70 20 22 2f 22 29 29 0a 20 20 20 20 20 se p "/")).
c670: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c680: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c690: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c6a0: 20 20 20 20 20 20 20 20 20 20 28 66 75 6c 6c 2d (full-
c6b0: 70 61 74 68 20 28 63 6f 6e 63 20 6c 69 6e 6b 74 path (conc linkt
c6c0: 72 65 65 20 22 2f 22 20 74 61 72 67 2d 70 61 74 ree "/" targ-pat
c6d0: 68 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 h)).
c6e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c6f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c700: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c710: 20 20 20 28 72 75 6e 2d 6e 61 6d 65 20 20 28 63 (run-name (c
c720: 61 72 20 28 72 65 76 65 72 73 65 20 70 29 29 29 ar (reverse p)))
c730: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
c740: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c750: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c760: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
c770: 28 61 6e 64 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c (and (common:fil
c780: 65 2d 65 78 69 73 74 73 3f 20 66 75 6c 6c 2d 70 e-exists? full-p
c790: 61 74 68 29 0a 20 20 20 20 20 20 20 20 20 20 20 ath).
c7a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c7b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c7c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c7d0: 20 20 20 20 20 20 20 20 28 64 69 72 65 63 74 6f (directo
c7e0: 72 79 3f 20 20 20 66 75 6c 6c 2d 70 61 74 68 29 ry? full-path)
c7f0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
c800: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c810: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c820: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c830: 20 20 20 20 28 66 69 6c 65 2d 77 72 69 74 65 2d (file-write-
c840: 61 63 63 65 73 73 3f 20 66 75 6c 6c 2d 70 61 74 access? full-pat
c850: 68 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 h)).
c860: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c870: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c880: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c890: 20 20 28 73 3a 61 20 72 75 6e 2d 6e 61 6d 65 20 (s:a run-name
c8a0: 27 68 72 65 66 20 28 63 6f 6e 63 20 74 61 72 67 'href (conc targ
c8b0: 2d 70 61 74 68 20 22 2f 72 75 6e 2d 73 75 6d 6d -path "/run-summ
c8c0: 61 72 79 2e 68 74 6d 6c 22 29 29 0a 20 20 20 20 ary.html")).
c8d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c8e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c8f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c900: 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e (begin
c910: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
c920: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c930: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c940: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c950: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
c960: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
c970: 74 2a 20 22 49 4e 46 4f 3a 20 43 61 6e 27 74 20 t* "INFO: Can't
c980: 63 72 65 61 74 65 20 22 20 74 61 72 67 2d 70 61 create " targ-pa
c990: 74 68 20 22 2f 72 75 6e 2d 73 75 6d 6d 61 72 79 th "/run-summary
c9a0: 2e 68 74 6d 6c 22 29 0a 20 20 20 20 20 20 20 20 .html").
c9b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c9c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c9d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c9e0: 20 20 20 20 20 20 20 20 28 63 6f 6e 63 20 72 75 (conc ru
c9f0: 6e 2d 6e 61 6d 65 20 22 20 28 4e 6f 74 20 61 62 n-name " (Not ab
ca00: 6c 65 20 74 6f 20 63 72 65 61 74 65 20 73 75 6d le to create sum
ca10: 6d 61 72 79 20 61 74 20 22 20 74 61 72 67 2d 70 mary at " targ-p
ca20: 61 74 68 20 22 29 22 29 29 29 29 29 29 29 29 29 ath ")")))))))))
ca30: 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 63 6c )). (cl
ca40: 6f 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 ose-output-port
ca50: 6f 75 70 29 0a 09 20 20 28 63 6f 6d 6d 6f 6e 3a oup).. (common:
ca60: 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 72 65 6c 65 simple-file-rele
ca70: 61 73 65 2d 6c 6f 63 6b 20 6c 6f 63 6b 66 69 6c ase-lock lockfil
ca80: 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 e).
ca90: 20 20 0a 09 20 20 28 66 6f 72 2d 65 61 63 68 0a .. (for-each.
caa0: 09 20 20 20 28 6c 61 6d 62 64 61 20 28 72 75 6e . (lambda (run
cab0: 29 0a 09 20 20 20 20 20 28 6c 65 74 2a 20 28 28 ).. (let* ((
cac0: 74 65 73 74 2d 73 75 62 70 61 74 68 20 28 74 65 test-subpath (te
cad0: 73 74 73 3a 72 75 6e 2d 72 65 63 6f 72 64 2d 3e sts:run-record->
cae0: 74 65 73 74 2d 70 61 74 68 20 72 75 6e 20 6e 75 test-path run nu
caf0: 6d 6b 65 79 73 29 29 0a 09 09 20 20 20 20 28 72 mkeys))... (r
cb00: 75 6e 2d 69 64 20 20 20 20 20 20 20 28 64 62 3a un-id (db:
cb10: 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 get-value-by-hea
cb20: 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 der run header "
cb30: 69 64 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 id")).
cb40: 20 20 20 20 20 20 20 20 20 20 28 72 75 6e 2d 64 (run-d
cb50: 69 72 20 20 20 20 20 20 28 74 65 73 74 73 3a 72 ir (tests:r
cb60: 75 6e 2d 72 65 63 6f 72 64 2d 3e 74 65 73 74 2d un-record->test-
cb70: 70 61 74 68 20 72 75 6e 20 6e 75 6d 6b 65 79 73 path run numkeys
cb80: 29 29 0a 09 09 20 20 20 20 28 74 65 73 74 2d 64 ))... (test-d
cb90: 61 74 73 20 20 20 20 28 72 6d 74 3a 67 65 74 2d ats (rmt:get-
cba0: 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 0a 09 09 tests-for-run...
cbb0: 09 09 20 20 20 72 75 6e 2d 69 64 0a 20 20 20 20 .. run-id.
cbc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cbd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 22 "
cbe0: 25 2f 22 20 20 20 20 20 20 20 3b 3b 20 74 65 73 %/" ;; tes
cbf0: 74 6e 61 6d 65 70 61 74 74 0a 09 09 09 09 20 20 tnamepatt.....
cc00: 20 27 28 29 20 20 20 20 20 20 20 20 3b 3b 20 73 '() ;; s
cc10: 74 61 74 65 73 0a 09 09 09 09 20 20 20 27 28 29 tates..... '()
cc20: 20 20 20 20 20 20 20 20 3b 3b 20 73 74 61 74 75 ;; statu
cc30: 73 65 73 0a 09 09 09 09 20 20 20 23 66 20 20 20 ses..... #f
cc40: 20 20 20 20 20 20 3b 3b 20 6f 66 66 73 65 74 0a ;; offset.
cc50: 09 09 09 09 20 20 20 23 66 20 20 20 20 20 20 20 .... #f
cc60: 20 20 3b 3b 20 6e 75 6d 2d 74 6f 2d 67 65 74 0a ;; num-to-get.
cc70: 09 09 09 09 20 20 20 23 66 20 20 20 20 20 20 20 .... #f
cc80: 20 20 3b 3b 20 68 69 64 65 2f 6e 6f 74 2d 68 69 ;; hide/not-hi
cc90: 64 65 0a 09 09 09 09 20 20 20 23 66 20 20 20 20 de..... #f
cca0: 20 20 20 20 20 3b 3b 20 73 6f 72 74 2d 62 79 0a ;; sort-by.
ccb0: 09 09 09 09 20 20 20 23 66 20 20 20 20 20 20 20 .... #f
ccc0: 20 20 3b 3b 20 73 6f 72 74 2d 6f 72 64 65 72 0a ;; sort-order.
ccd0: 09 09 09 09 20 20 20 23 66 20 20 20 20 20 20 20 .... #f
cce0: 20 20 3b 3b 20 27 73 68 6f 72 74 6c 69 73 74 20 ;; 'shortlist
ccf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cd00: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 71 72 79 ;; qry
cd10: 74 79 70 65 0a 20 20 20 20 20 20 20 20 20 20 20 type.
cd20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cd30: 20 20 20 20 20 20 20 20 30 20 20 20 20 20 20 20 0
cd40: 20 20 3b 3b 20 6c 61 73 74 20 75 70 64 61 74 65 ;; last update
cd50: 0a 09 09 09 09 20 20 20 23 66 29 29 0a 20 20 20 ..... #f)).
cd60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cd70: 20 28 74 65 73 74 73 2d 74 72 65 65 2d 64 61 74 (tests-tree-dat
cd80: 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 74 (map (lambda (t
cd90: 65 73 74 2d 64 61 74 29 0a 20 20 20 20 20 20 20 est-dat).
cda0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cdb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cdc0: 20 20 3b 3b 20 28 74 65 73 74 73 3a 72 75 6e 2d ;; (tests:run-
cdd0: 72 65 63 6f 72 64 2d 3e 74 65 73 74 2d 70 61 74 record->test-pat
cde0: 68 20 78 20 6e 75 6d 6b 65 79 73 29 29 0a 20 20 h x numkeys)).
cdf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ce00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ce10: 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 (let* ((t
ce20: 65 73 74 2d 6e 61 6d 65 20 20 28 64 62 3a 74 65 est-name (db:te
ce30: 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 st-get-testname
ce40: 74 65 73 74 2d 64 61 74 29 29 0a 20 20 20 20 20 test-dat)).
ce50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ce60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ce70: 20 20 20 20 20 20 20 20 20 20 20 28 69 74 65 6d (item
ce80: 2d 70 61 74 68 20 20 28 64 62 3a 74 65 73 74 2d -path (db:test-
ce90: 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 65 get-item-path te
cea0: 73 74 2d 64 61 74 29 29 0a 20 20 20 20 20 20 20 st-dat)).
ceb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cec0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ced0: 20 20 20 20 20 20 20 20 20 28 66 75 6c 6c 2d 6e (full-n
cee0: 61 6d 65 20 20 28 64 62 3a 74 65 73 74 2d 6d 61 ame (db:test-ma
cef0: 6b 65 2d 66 75 6c 6c 2d 6e 61 6d 65 20 74 65 73 ke-full-name tes
cf00: 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 t-name item-path
cf10: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
cf20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cf30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cf40: 20 20 20 28 70 61 74 68 2d 70 61 72 74 73 20 28 (path-parts (
cf50: 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 66 75 6c string-split ful
cf60: 6c 2d 6e 61 6d 65 29 29 29 0a 20 20 20 20 20 20 l-name))).
cf70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cf80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cf90: 20 20 20 20 20 70 61 74 68 2d 70 61 72 74 73 29 path-parts)
cfa0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
cfb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cfc0: 20 20 20 20 20 20 20 20 20 74 65 73 74 2d 64 61 test-da
cfd0: 74 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 ts)).
cfe0: 20 20 20 20 20 20 20 20 20 28 74 65 73 74 73 2d (tests-
cff0: 68 74 72 65 65 20 28 63 6f 6d 6d 6f 6e 3a 6c 69 htree (common:li
d000: 73 74 2d 3e 68 74 72 65 65 20 74 65 73 74 73 2d st->htree tests-
d010: 74 72 65 65 2d 64 61 74 29 29 0a 20 20 20 20 20 tree-dat)).
d020: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
d030: 68 74 6d 6c 2d 64 69 72 20 20 20 20 28 63 6f 6e html-dir (con
d040: 63 20 6c 69 6e 6b 74 72 65 65 20 22 2f 22 20 28 c linktree "/" (
d050: 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
d060: 73 65 20 72 75 6e 2d 64 69 72 20 22 2f 22 29 29 se run-dir "/"))
d070: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
d080: 20 20 20 20 20 20 28 68 74 6d 6c 2d 70 61 74 68 (html-path
d090: 20 20 20 28 63 6f 6e 63 20 68 74 6d 6c 2d 64 69 (conc html-di
d0a0: 72 20 22 2f 72 75 6e 2d 73 75 6d 6d 61 72 79 2e r "/run-summary.
d0b0: 68 74 6d 6c 22 29 29 0a 20 20 20 20 20 20 20 20 html")).
d0c0: 20 20 20 20 20 20 20 20 20 20 20 20 28 6f 75 70 (oup
d0d0: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 61 6e (if (an
d0e0: 64 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 d (common:file-e
d0f0: 78 69 73 74 73 3f 20 68 74 6d 6c 2d 64 69 72 29 xists? html-dir)
d100: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
d110: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d120: 20 20 20 20 20 20 20 20 20 20 20 28 64 69 72 65 (dire
d130: 63 74 6f 72 79 3f 20 20 20 68 74 6d 6c 2d 64 69 ctory? html-di
d140: 72 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 r).
d150: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d160: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 66 69 (fi
d170: 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 73 73 3f le-write-access?
d180: 20 68 74 6d 6c 2d 64 69 72 29 29 0a 20 20 20 20 html-dir)).
d190: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d1a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d1b0: 20 28 6f 70 65 6e 2d 6f 75 74 70 75 74 2d 66 69 (open-output-fi
d1c0: 6c 65 20 20 68 74 6d 6c 2d 70 61 74 68 29 0a 20 le html-path).
d1d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d1e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d1f0: 20 20 20 20 23 66 29 29 29 0a 20 20 20 20 20 20 #f))).
d200: 20 20 20 20 20 20 20 20 20 3b 3b 20 28 70 72 69 ;; (pri
d210: 6e 74 20 22 72 75 6e 2d 64 69 72 3a 20 22 20 72 nt "run-dir: " r
d220: 75 6e 2d 64 69 72 20 22 2c 20 74 65 73 74 73 2d un-dir ", tests-
d230: 74 72 65 65 2d 64 61 74 3a 20 22 20 74 65 73 74 tree-dat: " test
d240: 73 2d 74 72 65 65 2d 64 61 74 29 0a 20 20 20 20 s-tree-dat).
d250: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 6f (if o
d260: 75 70 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 up.
d270: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 (begin.
d280: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d290: 20 20 28 73 3a 6f 75 74 70 75 74 2d 6e 65 77 0a (s:output-new.
d2a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d2b0: 20 20 20 20 20 20 6f 75 70 0a 20 20 20 20 20 20 oup.
d2c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d2d0: 28 73 3a 68 74 6d 6c 20 74 65 73 74 73 3a 63 73 (s:html tests:cs
d2e0: 73 2d 6a 73 63 72 69 70 74 2d 62 6c 6f 63 6b 0a s-jscript-block.
d2f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d300: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s
d310: 3a 74 69 74 6c 65 20 22 53 75 6d 6d 61 72 79 20 :title "Summary
d320: 66 6f 72 20 22 20 61 72 65 61 2d 6e 61 6d 65 29 for " area-name)
d330: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
d340: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
d350: 73 3a 62 6f 64 79 20 27 6f 6e 6c 6f 61 64 20 22 s:body 'onload "
d360: 61 64 64 45 76 65 6e 74 73 28 29 3b 22 0a 20 20 addEvents();".
d370: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d380: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d390: 20 20 20 20 28 73 3a 68 31 20 22 53 75 6d 6d 61 (s:h1 "Summa
d3a0: 72 79 20 66 6f 72 20 22 20 28 73 74 72 69 6e 67 ry for " (string
d3b0: 2d 69 6e 74 65 72 73 70 65 72 73 65 20 72 75 6e -intersperse run
d3c0: 2d 64 69 72 20 22 2f 22 29 29 0a 20 20 20 20 20 -dir "/")).
d3d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d3e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d3f0: 20 3b 3b 20 74 6f 70 20 6c 69 73 74 0a 20 20 20 ;; top list.
d400: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d410: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d420: 20 20 20 28 73 3a 75 6c 20 27 69 64 20 22 4c 69 (s:ul 'id "Li
d430: 6e 6b 65 64 4c 69 73 74 31 22 20 27 63 6c 61 73 nkedList1" 'clas
d440: 73 20 22 4c 69 6e 6b 65 64 4c 69 73 74 22 0a 20 s "LinkedList".
d450: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d460: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d470: 20 20 20 20 20 20 20 20 20 20 20 28 73 3a 6c 69 (s:li
d480: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
d490: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d4a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 22 54 "T
d4b0: 65 73 74 73 22 0a 20 20 20 20 20 20 20 20 20 20 ests".
d4c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d4d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d4e0: 20 20 20 28 63 6f 6d 6d 6f 6e 3a 68 74 72 65 65 (common:htree
d4f0: 2d 3e 68 74 6d 6c 20 74 65 73 74 73 2d 68 74 72 ->html tests-htr
d500: 65 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ee.
d510: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d520: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d530: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d540: 20 20 20 20 27 28 29 0a 20 20 20 20 20 20 20 20 '().
d550: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d560: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d570: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d580: 20 20 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 (lambda
d590: 20 28 78 20 70 29 0a 20 20 20 20 20 20 20 20 20 (x p).
d5a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d5b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d5c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d5d0: 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 (let*
d5e0: 28 28 74 61 72 67 2d 70 61 74 68 20 28 73 74 72 ((targ-path (str
d5f0: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
d600: 70 20 22 2f 22 29 29 0a 20 20 20 20 20 20 20 20 p "/")).
d610: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d620: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d630: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d640: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d650: 20 20 28 74 65 73 74 2d 6e 61 6d 65 20 28 63 61 (test-name (ca
d660: 72 20 70 29 29 0a 20 20 20 20 20 20 20 20 20 20 r p)).
d670: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d680: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d690: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d6a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d6b0: 28 69 74 65 6d 2d 70 61 74 68 20 3b 3b 20 28 69 (item-path ;; (i
d6c0: 66 20 28 3e 20 28 6c 65 6e 67 74 68 20 70 29 20 f (> (length p)
d6d0: 32 29 20 3b 3b 20 74 65 73 74 2d 6e 61 6d 65 20 2) ;; test-name
d6e0: 2b 20 72 75 6e 2d 6e 61 6d 65 0a 20 20 20 20 20 + run-name.
d6f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d700: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d710: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d720: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d730: 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 69 6e (string-in
d740: 74 65 72 73 70 65 72 73 65 20 70 20 22 2f 22 29 tersperse p "/")
d750: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
d760: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d770: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d780: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d790: 20 20 20 20 20 20 20 20 20 20 20 20 28 66 75 6c (ful
d7a0: 6c 2d 74 61 72 67 20 28 63 6f 6e 63 20 68 74 6d l-targ (conc htm
d7b0: 6c 2d 64 69 72 20 22 2f 22 20 74 61 72 67 2d 70 l-dir "/" targ-p
d7c0: 61 74 68 29 29 0a 20 20 20 20 20 20 20 20 20 20 ath)).
d7d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d7e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d7f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d800: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d810: 28 73 74 64 2d 66 69 6c 65 20 20 28 63 6f 6e 63 (std-file (conc
d820: 20 66 75 6c 6c 2d 74 61 72 67 20 22 2f 74 65 73 full-targ "/tes
d830: 74 2d 73 75 6d 6d 61 72 79 2e 68 74 6d 6c 22 29 t-summary.html")
d840: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
d850: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d860: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d870: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d880: 20 20 20 20 20 20 20 20 20 20 20 20 28 61 6c 74 (alt
d890: 2d 66 69 6c 65 20 20 28 63 6f 6e 63 20 66 75 6c -file (conc ful
d8a0: 6c 2d 74 61 72 67 20 22 2f 6d 65 67 61 74 65 73 l-targ "/megates
d8b0: 74 2d 72 6f 6c 6c 75 70 2d 22 20 74 65 73 74 2d t-rollup-" test-
d8c0: 6e 61 6d 65 20 22 2e 68 74 6d 6c 22 29 29 0a 20 name ".html")).
d8d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d8e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d8f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d900: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d910: 20 20 20 20 20 20 20 20 20 28 68 74 6d 6c 2d 66 (html-f
d920: 69 6c 65 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a ile (if (common:
d930: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 61 6c 74 file-exists? alt
d940: 2d 66 69 6c 65 29 0a 20 20 20 20 20 20 20 20 20 -file).
d950: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d960: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d970: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d980: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d990: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d9a0: 61 6c 74 2d 66 69 6c 65 0a 20 20 20 20 20 20 20 alt-file.
d9b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d9c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d9d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d9e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d9f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
da00: 20 20 73 74 64 2d 66 69 6c 65 29 29 0a 20 20 20 std-file)).
da10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
da20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
da30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
da40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
da50: 20 20 20 20 20 20 20 28 72 75 6e 2d 6e 61 6d 65 (run-name
da60: 20 20 28 63 61 72 20 28 72 65 76 65 72 73 65 20 (car (reverse
da70: 70 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 p)))).
da80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
da90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
daa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dab0: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 (if (
dac0: 61 6e 64 20 28 6e 6f 74 20 28 63 6f 6d 6d 6f 6e and (not (common
dad0: 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 66 75 :file-exists? fu
dae0: 6c 6c 2d 74 61 72 67 29 29 0a 20 20 20 20 20 20 ll-targ)).
daf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
db00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
db10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
db20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
db30: 20 20 20 20 20 20 20 20 28 64 69 72 65 63 74 6f (directo
db40: 72 79 3f 20 66 75 6c 6c 2d 74 61 72 67 29 0a 20 ry? full-targ).
db50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
db60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
db70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
db80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
db90: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 66 69 (fi
dba0: 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 73 73 3f le-write-access?
dbb0: 20 66 75 6c 6c 2d 74 61 72 67 29 29 0a 20 20 20 full-targ)).
dbc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dbd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dbe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dbf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dc00: 20 20 20 20 20 20 28 74 65 73 74 73 3a 73 75 6d (tests:sum
dc10: 6d 61 72 69 7a 65 2d 74 65 73 74 20 0a 20 20 20 marize-test .
dc20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dc30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dc40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dc50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dc60: 20 20 20 20 20 20 20 72 75 6e 2d 69 64 20 0a 20 run-id .
dc70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dc80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dc90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dca0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dcb0: 20 20 20 20 20 20 20 20 20 28 72 6d 74 3a 67 65 (rmt:ge
dcc0: 74 2d 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 t-test-id run-id
dcd0: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item-
dce0: 70 61 74 68 29 29 29 0a 20 20 20 20 20 20 20 20 path))).
dcf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dd00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dd10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dd20: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
dd30: 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 (common:file-ex
dd40: 69 73 74 73 3f 20 66 75 6c 6c 2d 74 61 72 67 29 ists? full-targ)
dd50: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
dd60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dd70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dd80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dd90: 20 20 20 20 20 20 20 20 20 20 28 73 3a 61 20 72 (s:a r
dda0: 75 6e 2d 6e 61 6d 65 20 27 68 72 65 66 20 68 74 un-name 'href ht
ddb0: 6d 6c 2d 66 69 6c 65 29 0a 20 20 20 20 20 20 20 ml-file).
ddc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ddd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dde0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ddf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
de00: 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 (begin.
de10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
de20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
de30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
de40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
de50: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
de60: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
de70: 70 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 63 61 port* "ERROR: ca
de80: 6e 27 74 20 61 63 63 65 73 73 20 22 20 66 75 6c n't access " ful
de90: 6c 2d 74 61 72 67 29 0a 20 20 20 20 20 20 20 20 l-targ).
dea0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
deb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dec0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ded0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dee0: 20 20 20 28 63 6f 6e 63 20 22 4e 6f 20 73 75 6d (conc "No sum
def0: 6d 61 72 79 20 66 6f 72 20 22 20 72 75 6e 2d 6e mary for " run-n
df00: 61 6d 65 29 29 29 29 29 0a 20 20 20 20 20 20 20 ame))))).
df10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
df20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
df30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
df40: 20 20 20 20 20 20 20 20 20 20 29 29 29 29 29 29 ))))))
df50: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
df60: 20 20 20 20 20 20 28 63 6c 6f 73 65 2d 6f 75 74 (close-out
df70: 70 75 74 2d 70 6f 72 74 20 6f 75 70 29 29 29 29 put-port oup))))
df80: 29 0a 20 20 20 20 20 20 20 20 20 20 20 72 75 6e ). run
df90: 73 29 0a 20 20 20 20 20 20 20 20 20 20 23 74 29 s). #t)
dfa0: 0a 09 23 66 29 29 29 0a 0a 0a 0a 0a 0a 0a 0a 3b ..#f)))........;
dfb0: 3b 20 43 48 45 43 4b 20 2d 20 57 41 53 20 54 48 ; CHECK - WAS TH
dfc0: 49 53 20 41 44 44 45 44 20 4f 52 20 52 45 4d 4f IS ADDED OR REMO
dfd0: 56 45 44 3f 20 4d 41 4e 55 41 4c 20 4d 45 52 47 VED? MANUAL MERG
dfe0: 45 20 57 49 54 48 20 41 50 49 20 53 54 55 46 46 E WITH API STUFF
dff0: 21 21 21 0a 3b 3b 0a 3b 3b 20 67 65 74 20 61 20 !!!.;;.;; get a
e000: 70 72 65 74 74 79 20 74 61 62 6c 65 20 74 6f 20 pretty table to
e010: 73 75 6d 6d 61 72 69 7a 65 20 73 74 65 70 73 0a summarize steps.
e020: 3b 3b 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 64 ;;.;; (define (d
e030: 63 6f 6d 6d 6f 6e 3a 70 72 6f 63 65 73 73 2d 73 common:process-s
e040: 74 65 70 73 2d 74 61 62 6c 65 20 73 74 65 70 73 teps-table steps
e050: 29 3b 3b 20 64 62 20 74 65 73 74 2d 69 64 20 23 );; db test-id #
e060: 21 6b 65 79 20 28 77 6f 72 6b 2d 61 72 65 61 20 !key (work-area
e070: 23 66 29 29 0a 28 64 65 66 69 6e 65 20 28 74 65 #f)).(define (te
e080: 73 74 73 3a 70 72 6f 63 65 73 73 2d 73 74 65 70 sts:process-step
e090: 73 2d 74 61 62 6c 65 20 73 74 65 70 73 29 3b 3b s-table steps);;
e0a0: 20 64 62 20 74 65 73 74 2d 69 64 20 23 21 6b 65 db test-id #!ke
e0b0: 79 20 28 77 6f 72 6b 2d 61 72 65 61 20 23 66 29 y (work-area #f)
e0c0: 29 0a 3b 3b 20 20 28 6c 65 74 20 28 28 73 74 65 ).;; (let ((ste
e0d0: 70 73 20 20 20 28 64 62 3a 67 65 74 2d 73 74 65 ps (db:get-ste
e0e0: 70 73 2d 66 6f 72 2d 74 65 73 74 20 64 62 20 74 ps-for-test db t
e0f0: 65 73 74 2d 69 64 20 77 6f 72 6b 2d 61 72 65 61 est-id work-area
e100: 3a 20 77 6f 72 6b 2d 61 72 65 61 29 29 29 0a 20 : work-area))).
e110: 20 20 20 3b 3b 20 6f 72 67 61 6e 69 73 65 20 74 ;; organise t
e120: 68 65 20 73 74 65 70 73 20 66 6f 72 20 62 65 74 he steps for bet
e130: 74 65 72 20 72 65 61 64 61 62 69 6c 69 74 79 0a ter readability.
e140: 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 20 28 (let ((res (
e150: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
e160: 29 29 0a 20 20 20 20 20 20 28 66 6f 72 2d 65 61 )). (for-ea
e170: 63 68 20 0a 20 20 20 20 20 20 20 28 6c 61 6d 62 ch . (lamb
e180: 64 61 20 28 73 74 65 70 29 0a 09 20 28 64 65 62 da (step).. (deb
e190: 75 67 3a 70 72 69 6e 74 20 36 20 2a 64 65 66 61 ug:print 6 *defa
e1a0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 ult-log-port* "s
e1b0: 74 65 70 3d 22 20 73 74 65 70 29 0a 09 20 28 6c tep=" step).. (l
e1c0: 65 74 20 28 28 72 65 63 6f 72 64 20 28 68 61 73 et ((record (has
e1d0: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
e1e0: 75 6c 74 20 0a 09 09 09 72 65 73 20 0a 09 09 09 ult ....res ....
e1f0: 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 (tdb:step-get-st
e200: 65 70 6e 61 6d 65 20 73 74 65 70 29 0a 09 09 09 epname step)....
e210: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 30 20 20 ;; 0
e220: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e230: 20 20 20 20 31 20 20 20 20 32 20 20 20 20 33 20 1 2 3
e240: 20 20 20 20 20 20 34 20 20 20 20 20 20 20 20 20 4
e250: 35 20 20 20 20 20 20 20 36 20 20 20 20 20 20 20 5 6
e260: 37 0a 09 09 09 3b 3b 20 20 20 20 20 20 20 20 73 7....;; s
e270: 74 65 70 6e 61 6d 65 20 20 20 20 20 20 20 20 20 tepname
e280: 20 20 20 20 20 20 20 73 74 61 72 74 20 65 6e 64 start end
e290: 20 73 74 61 74 75 73 20 44 75 72 61 74 69 6f 6e status Duration
e2a0: 20 20 4c 6f 67 66 69 6c 65 20 43 6f 6d 6d 65 6e Logfile Commen
e2b0: 74 20 20 66 69 72 73 74 2d 69 64 0a 09 09 09 28 t first-id....(
e2c0: 76 65 63 74 6f 72 20 28 74 64 62 3a 73 74 65 70 vector (tdb:step
e2d0: 2d 67 65 74 2d 73 74 65 70 6e 61 6d 65 20 73 74 -get-stepname st
e2e0: 65 70 29 20 22 22 20 20 20 22 22 20 22 22 20 20 ep) "" "" ""
e2f0: 20 20 20 22 22 20 20 20 20 20 20 20 20 22 22 20 "" ""
e300: 20 20 20 20 22 22 20 20 20 20 20 20 20 23 66 29 "" #f)
e310: 29 29 29 0a 09 20 20 20 28 64 65 62 75 67 3a 70 ))).. (debug:p
e320: 72 69 6e 74 20 36 20 2a 64 65 66 61 75 6c 74 2d rint 6 *default-
e330: 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 65 63 6f 72 log-port* "recor
e340: 64 28 62 65 66 6f 72 65 29 20 3d 20 22 20 72 65 d(before) = " re
e350: 63 6f 72 64 20 0a 09 09 09 22 5c 6e 69 64 3a 20 cord ...."\nid:
e360: 20 20 20 20 20 20 22 20 28 74 64 62 3a 73 74 65 " (tdb:ste
e370: 70 2d 67 65 74 2d 69 64 20 73 74 65 70 29 0a 09 p-get-id step)..
e380: 09 09 22 5c 6e 73 74 65 70 6e 61 6d 65 3a 20 22 .."\nstepname: "
e390: 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 (tdb:step-get-s
e3a0: 74 65 70 6e 61 6d 65 20 73 74 65 70 29 0a 09 09 tepname step)...
e3b0: 09 22 5c 6e 73 74 61 74 65 3a 20 20 20 20 22 20 ."\nstate: "
e3c0: 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 (tdb:step-get-st
e3d0: 61 74 65 20 73 74 65 70 29 0a 09 09 09 22 5c 6e ate step)...."\n
e3e0: 73 74 61 74 75 73 3a 20 20 20 22 20 28 74 64 62 status: " (tdb
e3f0: 3a 73 74 65 70 2d 67 65 74 2d 73 74 61 74 75 73 :step-get-status
e400: 20 73 74 65 70 29 0a 09 09 09 22 5c 6e 74 69 6d step)...."\ntim
e410: 65 3a 20 20 20 20 20 22 20 28 74 64 62 3a 73 74 e: " (tdb:st
e420: 65 70 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 6d ep-get-event_tim
e430: 65 20 73 74 65 70 29 29 0a 09 20 20 20 28 69 66 e step)).. (if
e440: 20 28 6e 6f 74 20 28 76 65 63 74 6f 72 2d 72 65 (not (vector-re
e450: 66 20 72 65 63 6f 72 64 20 37 29 29 28 76 65 63 f record 7))(vec
e460: 74 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 64 20 tor-set! record
e470: 37 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 7 (tdb:step-get-
e480: 69 64 20 73 74 65 70 29 29 29 20 3b 3b 20 64 6f id step))) ;; do
e490: 20 6e 6f 74 20 63 6c 6f 62 62 65 72 20 74 68 65 not clobber the
e4a0: 20 69 64 20 69 66 20 70 72 65 76 69 6f 75 73 6c id if previousl
e4b0: 79 20 73 65 74 0a 09 20 20 20 28 63 61 73 65 20 y set.. (case
e4c0: 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 (string->symbol
e4d0: 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 (tdb:step-get-st
e4e0: 61 74 65 20 73 74 65 70 29 29 0a 09 20 20 20 20 ate step))..
e4f0: 20 28 28 73 74 61 72 74 29 28 76 65 63 74 6f 72 ((start)(vector
e500: 2d 73 65 74 21 20 72 65 63 6f 72 64 20 31 20 28 -set! record 1 (
e510: 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 65 76 65 tdb:step-get-eve
e520: 6e 74 5f 74 69 6d 65 20 73 74 65 70 29 29 0a 09 nt_time step))..
e530: 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 73 65 (vector-se
e540: 74 21 20 72 65 63 6f 72 64 20 33 20 28 69 66 20 t! record 3 (if
e550: 28 65 71 75 61 6c 3f 20 28 76 65 63 74 6f 72 2d (equal? (vector-
e560: 72 65 66 20 72 65 63 6f 72 64 20 33 29 20 22 22 ref record 3) ""
e570: 29 0a 09 09 09 09 09 28 74 64 62 3a 73 74 65 70 )......(tdb:step
e580: 2d 67 65 74 2d 73 74 61 74 75 73 20 73 74 65 70 -get-status step
e590: 29 29 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 ))).. (if (
e5a0: 3e 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 > (string-length
e5b0: 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 6c (tdb:step-get-l
e5c0: 6f 67 66 69 6c 65 20 73 74 65 70 29 29 0a 09 09 ogfile step))...
e5d0: 20 20 20 20 20 30 29 0a 09 09 20 20 28 76 65 63 0)... (vec
e5e0: 74 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 64 20 tor-set! record
e5f0: 35 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 5 (tdb:step-get-
e600: 6c 6f 67 66 69 6c 65 20 73 74 65 70 29 29 29 29 logfile step))))
e610: 0a 09 20 20 20 20 20 28 28 65 6e 64 29 20 20 0a .. ((end) .
e620: 09 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 73 . (vector-s
e630: 65 74 21 20 72 65 63 6f 72 64 20 32 20 28 61 6e et! record 2 (an
e640: 79 2d 3e 6e 75 6d 62 65 72 20 28 74 64 62 3a 73 y->number (tdb:s
e650: 74 65 70 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 tep-get-event_ti
e660: 6d 65 20 73 74 65 70 29 29 29 0a 09 20 20 20 20 me step)))..
e670: 20 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 72 (vector-set! r
e680: 65 63 6f 72 64 20 33 20 28 74 64 62 3a 73 74 65 ecord 3 (tdb:ste
e690: 70 2d 67 65 74 2d 73 74 61 74 75 73 20 73 74 65 p-get-status ste
e6a0: 70 29 29 0a 09 20 20 20 20 20 20 28 76 65 63 74 p)).. (vect
e6b0: 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 64 20 34 or-set! record 4
e6c0: 20 28 6c 65 74 20 28 28 73 74 61 72 74 74 20 28 (let ((startt (
e6d0: 61 6e 79 2d 3e 6e 75 6d 62 65 72 20 28 76 65 63 any->number (vec
e6e0: 74 6f 72 2d 72 65 66 20 72 65 63 6f 72 64 20 31 tor-ref record 1
e6f0: 29 29 29 0a 09 09 09 09 09 20 20 28 65 6e 64 74 )))...... (endt
e700: 20 20 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 20 (any->number
e710: 28 76 65 63 74 6f 72 2d 72 65 66 20 72 65 63 6f (vector-ref reco
e720: 72 64 20 32 29 29 29 29 0a 09 09 09 09 20 20 20 rd 2)))).....
e730: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
e740: 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 4 *default-log-p
e750: 6f 72 74 2a 20 22 72 65 63 6f 72 64 5b 31 5d 3d ort* "record[1]=
e760: 22 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 65 " (vector-ref re
e770: 63 6f 72 64 20 31 29 20 0a 09 09 09 09 09 09 20 cord 1) .......
e780: 20 20 22 2c 20 73 74 61 72 74 74 3d 22 20 73 74 ", startt=" st
e790: 61 72 74 74 20 22 2c 20 65 6e 64 74 3d 22 20 65 artt ", endt=" e
e7a0: 6e 64 74 0a 09 09 09 09 09 09 20 20 20 22 2c 20 ndt....... ",
e7b0: 67 65 74 2d 73 74 61 74 75 73 3a 20 22 20 28 74 get-status: " (t
e7c0: 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 61 74 db:step-get-stat
e7d0: 75 73 20 73 74 65 70 29 29 0a 09 09 09 09 20 20 us step)).....
e7e0: 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 6e 75 (if (and (nu
e7f0: 6d 62 65 72 3f 20 73 74 61 72 74 74 29 28 6e 75 mber? startt)(nu
e800: 6d 62 65 72 3f 20 65 6e 64 74 29 29 0a 09 09 09 mber? endt))....
e810: 09 09 20 20 28 73 65 63 6f 6e 64 73 2d 3e 68 72 .. (seconds->hr
e820: 2d 6d 69 6e 2d 73 65 63 20 28 2d 20 65 6e 64 74 -min-sec (- endt
e830: 20 73 74 61 72 74 74 29 29 20 22 2d 31 22 29 29 startt)) "-1"))
e840: 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 3e 20 ).. (if (>
e850: 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 28 (string-length (
e860: 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 6c 6f 67 tdb:step-get-log
e870: 66 69 6c 65 20 73 74 65 70 29 29 0a 09 09 20 20 file step))...
e880: 20 20 20 30 29 0a 09 09 20 20 28 76 65 63 74 6f 0)... (vecto
e890: 72 2d 73 65 74 21 20 72 65 63 6f 72 64 20 35 20 r-set! record 5
e8a0: 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 6c 6f (tdb:step-get-lo
e8b0: 67 66 69 6c 65 20 73 74 65 70 29 29 29 0a 09 20 gfile step)))..
e8c0: 20 20 20 20 20 28 69 66 20 28 3e 20 28 73 74 72 (if (> (str
e8d0: 69 6e 67 2d 6c 65 6e 67 74 68 20 28 74 64 62 3a ing-length (tdb:
e8e0: 73 74 65 70 2d 67 65 74 2d 63 6f 6d 6d 65 6e 74 step-get-comment
e8f0: 20 73 74 65 70 29 29 0a 09 09 20 20 20 20 20 30 step))... 0
e900: 29 0a 09 09 20 20 28 76 65 63 74 6f 72 2d 73 65 )... (vector-se
e910: 74 21 20 72 65 63 6f 72 64 20 36 20 28 74 64 62 t! record 6 (tdb
e920: 3a 73 74 65 70 2d 67 65 74 2d 63 6f 6d 6d 65 6e :step-get-commen
e930: 74 20 73 74 65 70 29 29 29 29 0a 09 20 20 20 20 t step))))..
e940: 20 28 65 6c 73 65 0a 09 20 20 20 20 20 20 28 76 (else.. (v
e950: 65 63 74 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 ector-set! recor
e960: 64 20 32 20 28 74 64 62 3a 73 74 65 70 2d 67 65 d 2 (tdb:step-ge
e970: 74 2d 73 74 61 74 65 20 73 74 65 70 29 29 0a 09 t-state step))..
e980: 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 73 65 (vector-se
e990: 74 21 20 72 65 63 6f 72 64 20 33 20 28 74 64 62 t! record 3 (tdb
e9a0: 3a 73 74 65 70 2d 67 65 74 2d 73 74 61 74 75 73 :step-get-status
e9b0: 20 73 74 65 70 29 29 0a 09 20 20 20 20 20 20 28 step)).. (
e9c0: 76 65 63 74 6f 72 2d 73 65 74 21 20 72 65 63 6f vector-set! reco
e9d0: 72 64 20 34 20 28 74 64 62 3a 73 74 65 70 2d 67 rd 4 (tdb:step-g
e9e0: 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 73 74 et-event_time st
e9f0: 65 70 29 29 0a 09 20 20 20 20 20 20 28 76 65 63 ep)).. (vec
ea00: 74 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 64 20 tor-set! record
ea10: 36 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 6 (tdb:step-get-
ea20: 63 6f 6d 6d 65 6e 74 20 73 74 65 70 29 29 29 29 comment step))))
ea30: 0a 09 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 .. (hash-table
ea40: 2d 73 65 74 21 20 72 65 73 20 28 74 64 62 3a 73 -set! res (tdb:s
ea50: 74 65 70 2d 67 65 74 2d 73 74 65 70 6e 61 6d 65 tep-get-stepname
ea60: 20 73 74 65 70 29 20 72 65 63 6f 72 64 29 0a 09 step) record)..
ea70: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
ea80: 36 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6 *default-log-p
ea90: 6f 72 74 2a 20 22 72 65 63 6f 72 64 28 61 66 74 ort* "record(aft
eaa0: 65 72 29 20 20 3d 20 22 20 72 65 63 6f 72 64 20 er) = " record
eab0: 0a 09 09 09 22 5c 6e 69 64 3a 20 20 20 20 20 20 ...."\nid:
eac0: 20 22 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 " (tdb:step-get
ead0: 2d 69 64 20 73 74 65 70 29 0a 09 09 09 22 5c 6e -id step)...."\n
eae0: 73 74 65 70 6e 61 6d 65 3a 20 22 20 28 74 64 62 stepname: " (tdb
eaf0: 3a 73 74 65 70 2d 67 65 74 2d 73 74 65 70 6e 61 :step-get-stepna
eb00: 6d 65 20 73 74 65 70 29 0a 09 09 09 22 5c 6e 73 me step)...."\ns
eb10: 74 61 74 65 3a 20 20 20 20 22 20 28 74 64 62 3a tate: " (tdb:
eb20: 73 74 65 70 2d 67 65 74 2d 73 74 61 74 65 20 73 step-get-state s
eb30: 74 65 70 29 0a 09 09 09 22 5c 6e 73 74 61 74 75 tep)...."\nstatu
eb40: 73 3a 20 20 20 22 20 28 74 64 62 3a 73 74 65 70 s: " (tdb:step
eb50: 2d 67 65 74 2d 73 74 61 74 75 73 20 73 74 65 70 -get-status step
eb60: 29 0a 09 09 09 22 5c 6e 74 69 6d 65 3a 20 20 20 )...."\ntime:
eb70: 20 20 22 20 28 74 64 62 3a 73 74 65 70 2d 67 65 " (tdb:step-ge
eb80: 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 73 74 65 t-event_time ste
eb90: 70 29 29 29 29 0a 20 20 20 20 20 20 20 3b 3b 20 p)))). ;;
eba0: 28 65 6c 73 65 20 20 20 28 76 65 63 74 6f 72 2d (else (vector-
ebb0: 73 65 74 21 20 72 65 63 6f 72 64 20 31 20 28 74 set! record 1 (t
ebc0: 64 62 3a 73 74 65 70 2d 67 65 74 2d 65 76 65 6e db:step-get-even
ebd0: 74 5f 74 69 6d 65 20 73 74 65 70 29 29 29 0a 20 t_time step))).
ebe0: 20 20 20 20 20 20 28 73 6f 72 74 20 73 74 65 70 (sort step
ebf0: 73 20 28 6c 61 6d 62 64 61 20 28 61 20 62 29 0a s (lambda (a b).
ec00: 09 09 20 20 20 20 20 28 63 6f 6e 64 0a 09 09 20 .. (cond...
ec10: 20 20 20 20 20 28 28 3c 20 20 20 28 74 64 62 3a ((< (tdb:
ec20: 73 74 65 70 2d 67 65 74 2d 65 76 65 6e 74 5f 74 step-get-event_t
ec30: 69 6d 65 20 61 29 28 74 64 62 3a 73 74 65 70 2d ime a)(tdb:step-
ec40: 67 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 62 get-event_time b
ec50: 29 29 20 23 74 29 0a 09 09 20 20 20 20 20 20 28 )) #t)... (
ec60: 28 65 71 3f 20 28 74 64 62 3a 73 74 65 70 2d 67 (eq? (tdb:step-g
ec70: 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 61 29 et-event_time a)
ec80: 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 65 76 (tdb:step-get-ev
ec90: 65 6e 74 5f 74 69 6d 65 20 62 29 29 20 0a 09 09 ent_time b)) ...
eca0: 20 20 20 20 20 20 20 28 3c 20 20 20 28 74 64 62 (< (tdb
ecb0: 3a 73 74 65 70 2d 67 65 74 2d 69 64 20 61 29 20 :step-get-id a)
ecc0: 20 20 20 20 20 20 20 28 74 64 62 3a 73 74 65 70 (tdb:step
ecd0: 2d 67 65 74 2d 69 64 20 62 29 29 29 0a 09 09 20 -get-id b)))...
ece0: 20 20 20 20 20 28 65 6c 73 65 20 23 66 29 29 29 (else #f)))
ecf0: 29 29 0a 20 20 20 20 20 20 72 65 73 29 29 0a 0a )). res))..
ed00: 3b 3b 20 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 ;; .;;.(define (
ed10: 74 65 73 74 73 3a 67 65 74 2d 63 6f 6d 70 72 65 tests:get-compre
ed20: 73 73 65 64 2d 73 74 65 70 73 20 72 75 6e 2d 69 ssed-steps run-i
ed30: 64 20 74 65 73 74 2d 69 64 29 0a 20 20 28 6c 65 d test-id). (le
ed40: 74 2a 20 28 28 73 74 65 70 73 2d 64 61 74 61 20 t* ((steps-data
ed50: 20 28 72 6d 74 3a 67 65 74 2d 73 74 65 70 73 2d (rmt:get-steps-
ed60: 66 6f 72 2d 74 65 73 74 20 72 75 6e 2d 69 64 20 for-test run-id
ed70: 74 65 73 74 2d 69 64 29 29 20 3b 3b 20 20 20 20 test-id)) ;;
ed80: 20 20 30 20 20 20 20 20 20 20 31 20 20 20 20 32 0 1 2
ed90: 20 20 20 20 33 20 20 20 20 20 20 20 34 20 20 20 3 4
eda0: 20 20 20 20 35 20 20 20 20 20 20 20 36 20 20 20 5 6
edb0: 20 20 20 37 20 20 20 20 20 20 20 0a 09 20 28 63 7 .. (c
edc0: 6f 6d 70 72 73 74 65 70 73 20 20 28 74 65 73 74 omprsteps (test
edd0: 73 3a 70 72 6f 63 65 73 73 2d 73 74 65 70 73 2d s:process-steps-
ede0: 74 61 62 6c 65 20 73 74 65 70 73 2d 64 61 74 61 table steps-data
edf0: 29 29 29 20 3b 3b 20 23 3c 73 74 65 70 6e 61 6d ))) ;; #<stepnam
ee00: 65 20 73 74 61 72 74 20 65 6e 64 20 73 74 61 74 e start end stat
ee10: 75 73 20 44 75 72 61 74 69 6f 6e 20 4c 6f 67 66 us Duration Logf
ee20: 69 6c 65 20 43 6f 6d 6d 65 6e 74 20 69 64 3e 0a ile Comment id>.
ee30: 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 (map (lambda
ee40: 20 28 78 29 0a 09 20 20 20 3b 3b 20 74 61 6b 65 (x).. ;; take
ee50: 20 61 64 76 61 6e 74 61 67 65 20 6f 66 20 74 68 advantage of th
ee60: 65 20 5c 6e 20 6f 6e 20 74 69 6d 65 2d 3e 73 74 e \n on time->st
ee70: 72 69 6e 67 0a 09 20 20 20 28 76 65 63 74 6f 72 ring.. (vector
ee80: 20 20 20 20 3b 3b 20 77 65 20 61 72 65 20 63 6f ;; we are co
ee90: 6e 73 74 72 75 63 74 69 6e 67 20 62 61 73 69 63 nstructing basic
eea0: 61 6c 6c 79 20 74 68 65 20 6f 72 69 67 69 6e 61 ally the origina
eeb0: 6c 20 76 65 63 74 6f 72 20 62 75 74 20 63 6f 6c l vector but col
eec0: 6c 61 70 73 69 6e 67 20 73 74 61 72 74 20 65 6e lapsing start en
eed0: 64 20 72 65 63 6f 72 64 73 0a 09 20 20 20 20 28 d records.. (
eee0: 76 65 63 74 6f 72 2d 72 65 66 20 78 20 30 29 20 vector-ref x 0)
eef0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ef00: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ;;
ef10: 69 64 20 20 20 20 20 20 20 20 30 0a 09 20 20 20 id 0..
ef20: 20 28 6c 65 74 20 28 28 73 20 28 76 65 63 74 6f (let ((s (vecto
ef30: 72 2d 72 65 66 20 78 20 31 29 29 29 0a 09 20 20 r-ref x 1)))..
ef40: 20 20 20 20 28 69 66 20 28 6e 75 6d 62 65 72 3f (if (number?
ef50: 20 73 29 28 73 65 63 6f 6e 64 73 2d 3e 74 69 6d s)(seconds->tim
ef60: 65 2d 73 74 72 69 6e 67 20 73 29 20 73 29 29 20 e-string s) s))
ef70: 3b 3b 20 73 74 61 72 74 74 69 6d 65 20 31 0a 09 ;; starttime 1..
ef80: 20 20 20 20 28 6c 65 74 20 28 28 73 20 28 76 65 (let ((s (ve
ef90: 63 74 6f 72 2d 72 65 66 20 78 20 32 29 29 29 0a ctor-ref x 2))).
efa0: 09 20 20 20 20 20 20 28 69 66 20 28 6e 75 6d 62 . (if (numb
efb0: 65 72 3f 20 73 29 28 73 65 63 6f 6e 64 73 2d 3e er? s)(seconds->
efc0: 74 69 6d 65 2d 73 74 72 69 6e 67 20 73 29 20 73 time-string s) s
efd0: 29 29 20 3b 3b 20 65 6e 64 74 69 6d 65 20 20 20 )) ;; endtime
efe0: 32 0a 09 20 20 20 20 28 76 65 63 74 6f 72 2d 72 2.. (vector-r
eff0: 65 66 20 78 20 33 29 20 20 20 20 20 20 20 20 20 ef x 3)
f000: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
f010: 20 20 20 20 20 3b 3b 20 73 74 61 74 75 73 20 20 ;; status
f020: 20 20 33 20 20 20 20 0a 09 20 20 20 20 28 76 65 3 .. (ve
f030: 63 74 6f 72 2d 72 65 66 20 78 20 34 29 20 20 20 ctor-ref x 4)
f040: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
f050: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 64 75 ;; du
f060: 72 61 74 69 6f 6e 20 20 34 0a 09 20 20 20 20 28 ration 4.. (
f070: 76 65 63 74 6f 72 2d 72 65 66 20 78 20 35 29 20 vector-ref x 5)
f080: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
f090: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ;;
f0a0: 6c 6f 67 66 69 6c 65 20 20 20 35 0a 09 20 20 20 logfile 5..
f0b0: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 78 20 36 (vector-ref x 6
f0c0: 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 )
f0d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
f0e0: 3b 20 63 6f 6d 6d 65 6e 74 20 20 20 36 0a 09 20 ; comment 6..
f0f0: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 78 (vector-ref x
f100: 20 37 29 29 29 20 20 20 20 20 20 20 20 20 20 20 7)))
f110: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
f120: 20 3b 3b 20 69 64 20 20 20 20 20 20 20 20 37 0a ;; id 7.
f130: 09 20 28 73 6f 72 74 20 28 68 61 73 68 2d 74 61 . (sort (hash-ta
f140: 62 6c 65 2d 76 61 6c 75 65 73 20 63 6f 6d 70 72 ble-values compr
f150: 73 74 65 70 73 29 0a 09 20 20 20 20 20 20 20 28 steps).. (
f160: 6c 61 6d 62 64 61 20 28 61 20 62 29 0a 09 09 20 lambda (a b)...
f170: 28 6c 65 74 20 28 28 74 69 6d 65 2d 61 20 28 76 (let ((time-a (v
f180: 65 63 74 6f 72 2d 72 65 66 20 61 20 31 29 29 0a ector-ref a 1)).
f190: 09 09 20 20 20 20 20 20 20 28 74 69 6d 65 2d 62 .. (time-b
f1a0: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 62 20 31 (vector-ref b 1
f1b0: 29 29 0a 09 09 20 20 20 20 20 20 20 28 69 64 2d ))... (id-
f1c0: 61 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 a (vector-ref
f1d0: 61 20 37 29 29 0a 09 09 20 20 20 20 20 20 20 28 a 7))... (
f1e0: 69 64 2d 62 20 20 20 28 76 65 63 74 6f 72 2d 72 id-b (vector-r
f1f0: 65 66 20 62 20 37 29 29 29 0a 09 09 20 20 20 28 ef b 7)))... (
f200: 69 66 20 28 61 6e 64 20 28 6e 75 6d 62 65 72 3f if (and (number?
f210: 20 74 69 6d 65 2d 61 29 28 6e 75 6d 62 65 72 3f time-a)(number?
f220: 20 74 69 6d 65 2d 62 29 29 0a 09 09 20 20 20 20 time-b))...
f230: 20 20 20 28 69 66 20 28 3c 20 74 69 6d 65 2d 61 (if (< time-a
f240: 20 74 69 6d 65 2d 62 29 0a 09 09 09 20 20 20 23 time-b).... #
f250: 74 0a 09 09 09 20 20 20 28 69 66 20 28 65 71 3f t.... (if (eq?
f260: 20 74 69 6d 65 2d 61 20 74 69 6d 65 2d 62 29 0a time-a time-b).
f270: 09 09 09 20 20 20 20 20 20 20 28 3c 20 69 64 2d ... (< id-
f280: 61 20 69 64 2d 62 29 0a 09 09 09 20 20 20 20 20 a id-b)....
f290: 20 20 3b 3b 20 28 73 74 72 69 6e 67 3c 3f 20 28 ;; (string<? (
f2a0: 63 6f 6e 63 20 28 76 65 63 74 6f 72 2d 72 65 66 conc (vector-ref
f2b0: 20 61 20 32 29 29 0a 09 09 09 20 20 20 20 20 20 a 2))....
f2c0: 20 3b 3b 09 20 20 20 20 28 63 6f 6e 63 20 28 76 ;;. (conc (v
f2d0: 65 63 74 6f 72 2d 72 65 66 20 62 20 32 29 29 29 ector-ref b 2)))
f2e0: 0a 09 09 09 20 20 20 20 20 20 20 23 66 29 29 0a .... #f)).
f2f0: 09 09 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 .. (string
f300: 3c 3f 20 28 63 6f 6e 63 20 74 69 6d 65 2d 61 29 <? (conc time-a)
f310: 28 63 6f 6e 63 20 74 69 6d 65 2d 62 29 29 29 29 (conc time-b))))
f320: 29 29 29 29 29 0a 0a 0a 3b 3b 20 53 61 76 65 20 )))))...;; Save
f330: 74 65 73 74 20 73 74 61 74 65 20 61 6e 64 20 73 test state and s
f340: 74 61 74 75 73 20 69 6e 20 74 6f 20 61 20 66 69 tatus in to a fi
f350: 6c 65 20 2e 66 69 6e 61 6c 2d 73 74 61 74 75 73 le .final-status
f360: 20 69 6e 20 74 68 65 20 74 65 73 74 20 64 69 72 in the test dir
f370: 65 63 74 6f 72 79 0a 3b 3b 0a 28 64 65 66 69 6e ectory.;;.(defin
f380: 65 20 28 74 65 73 74 73 3a 73 61 76 65 2d 66 69 e (tests:save-fi
f390: 6e 61 6c 2d 73 74 61 74 75 73 20 72 75 6e 2d 69 nal-status run-i
f3a0: 64 20 74 65 73 74 2d 69 64 29 0a 20 20 28 6c 65 d test-id). (le
f3b0: 74 2a 20 28 28 74 65 73 74 2d 64 61 74 20 20 28 t* ((test-dat (
f3c0: 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 rmt:get-test-inf
f3d0: 6f 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 74 o-by-id run-id t
f3e0: 65 73 74 2d 69 64 29 29 0a 09 20 28 6f 75 74 2d est-id)).. (out-
f3f0: 64 69 72 20 20 20 28 64 62 3a 74 65 73 74 2d 67 dir (db:test-g
f400: 65 74 2d 72 75 6e 64 69 72 20 74 65 73 74 2d 64 et-rundir test-d
f410: 61 74 29 29 0a 09 20 28 73 74 61 74 75 73 2d 66 at)).. (status-f
f420: 69 6c 65 20 20 28 63 6f 6e 63 20 6f 75 74 2d 64 ile (conc out-d
f430: 69 72 20 22 2f 2e 66 69 6e 61 6c 2d 73 74 61 74 ir "/.final-stat
f440: 75 73 22 29 29 0a 20 20 20 29 0a 20 20 20 20 3b us")). ). ;
f450: 3b 20 66 69 72 73 74 20 76 65 72 69 66 79 20 77 ; first verify w
f460: 65 20 61 72 65 20 61 62 6c 65 20 74 6f 20 77 72 e are able to wr
f470: 69 74 65 20 74 68 65 20 6f 75 74 70 75 74 20 66 ite the output f
f480: 69 6c 65 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 ile. (if (not
f490: 20 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 (file-write-acc
f4a0: 65 73 73 3f 20 6f 75 74 2d 64 69 72 29 29 0a 09 ess? out-dir))..
f4b0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
f4c0: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
f4d0: 70 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 63 61 port* "ERROR: ca
f4e0: 6e 6e 6f 74 20 77 72 69 74 65 20 2e 66 69 6e 61 nnot write .fina
f4f0: 6c 2d 73 74 61 74 75 73 20 74 6f 20 22 20 6f 75 l-status to " ou
f500: 74 2d 64 69 72 29 0a 09 20 20 20 20 28 6c 65 74 t-dir).. (let
f510: 2a 20 0a 20 20 20 20 20 20 20 20 20 28 28 6f 75 * . ((ou
f520: 74 70 20 20 20 20 20 20 28 6f 70 65 6e 2d 6f 75 tp (open-ou
f530: 74 70 75 74 2d 66 69 6c 65 20 73 74 61 74 75 73 tput-file status
f540: 2d 66 69 6c 65 29 29 0a 09 20 20 20 20 20 20 20 -file))..
f550: 28 73 74 61 74 75 73 20 20 20 20 28 64 62 3a 74 (status (db:t
f560: 65 73 74 2d 67 65 74 2d 73 74 61 74 75 73 20 20 est-get-status
f570: 20 74 65 73 74 2d 64 61 74 29 29 0a 20 20 20 20 test-dat)).
f580: 20 20 20 20 20 28 73 74 61 74 65 20 20 20 20 20 (state
f590: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 (db:test-get-sta
f5a0: 74 65 20 20 20 20 74 65 73 74 2d 64 61 74 29 29 te test-dat))
f5b0: 29 0a 20 20 20 20 20 20 20 20 28 66 70 72 69 6e ). (fprin
f5c0: 74 66 20 6f 75 74 70 20 22 7e 53 5c 6e 22 20 73 tf outp "~S\n" s
f5d0: 74 61 74 65 29 20 0a 20 20 20 20 20 20 20 20 28 tate) . (
f5e0: 66 70 72 69 6e 74 66 20 6f 75 74 70 20 22 7e 53 fprintf outp "~S
f5f0: 5c 6e 22 20 73 74 61 74 75 73 29 20 0a 20 20 20 \n" status) .
f600: 20 20 20 20 20 28 63 6c 6f 73 65 2d 6f 75 74 70 (close-outp
f610: 75 74 2d 70 6f 72 74 20 6f 75 74 70 29 29 29 29 ut-port outp))))
f620: 29 0a 0a 0a 3b 3b 20 73 75 6d 6d 61 72 69 7a 65 )...;; summarize
f630: 20 74 65 73 74 20 69 6e 20 74 6f 20 61 20 66 69 test in to a fi
f640: 6c 65 20 74 65 73 74 2d 73 75 6d 6d 61 72 79 2e le test-summary.
f650: 68 74 6d 6c 20 69 6e 20 74 68 65 20 74 65 73 74 html in the test
f660: 20 64 69 72 65 63 74 6f 72 79 0a 3b 3b 0a 28 64 directory.;;.(d
f670: 65 66 69 6e 65 20 28 74 65 73 74 73 3a 73 75 6d efine (tests:sum
f680: 6d 61 72 69 7a 65 2d 74 65 73 74 20 72 75 6e 2d marize-test run-
f690: 69 64 20 74 65 73 74 2d 69 64 29 0a 20 20 28 6c id test-id). (l
f6a0: 65 74 2a 20 28 28 74 65 73 74 2d 64 61 74 20 20 et* ((test-dat
f6b0: 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 6e (rmt:get-test-in
f6c0: 66 6f 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 fo-by-id run-id
f6d0: 74 65 73 74 2d 69 64 29 29 0a 09 20 28 6f 75 74 test-id)).. (out
f6e0: 2d 64 69 72 20 20 20 28 64 62 3a 74 65 73 74 2d -dir (db:test-
f6f0: 67 65 74 2d 72 75 6e 64 69 72 20 74 65 73 74 2d get-rundir test-
f700: 64 61 74 29 29 0a 09 20 28 6f 75 74 2d 66 69 6c dat)).. (out-fil
f710: 65 20 20 28 63 6f 6e 63 20 6f 75 74 2d 64 69 72 e (conc out-dir
f720: 20 22 2f 74 65 73 74 2d 73 75 6d 6d 61 72 79 2e "/test-summary.
f730: 68 74 6d 6c 22 29 29 29 0a 20 20 20 20 3b 3b 20 html"))). ;;
f740: 66 69 72 73 74 20 76 65 72 69 66 79 20 77 65 20 first verify we
f750: 61 72 65 20 61 62 6c 65 20 74 6f 20 77 72 69 74 are able to writ
f760: 65 20 74 68 65 20 6f 75 74 70 75 74 20 66 69 6c e the output fil
f770: 65 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 e. (if (not (
f780: 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 73 file-write-acces
f790: 73 3f 20 6f 75 74 2d 64 69 72 29 29 0a 09 28 64 s? out-dir))..(d
f7a0: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
f7b0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
f7c0: 22 45 52 52 4f 52 3a 20 63 61 6e 6e 6f 74 20 77 "ERROR: cannot w
f7d0: 72 69 74 65 20 74 65 73 74 2d 73 75 6d 6d 61 72 rite test-summar
f7e0: 79 2e 68 74 6d 6c 20 74 6f 20 22 20 6f 75 74 2d y.html to " out-
f7f0: 64 69 72 29 0a 09 28 6c 65 74 2a 20 28 3b 3b 20 dir)..(let* (;;
f800: 28 73 74 65 70 73 2d 64 61 74 20 28 72 6d 74 3a (steps-dat (rmt:
f810: 67 65 74 2d 73 74 65 70 73 2d 66 6f 72 2d 74 65 get-steps-for-te
f820: 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 st run-id test-i
f830: 64 29 29 0a 09 20 20 20 20 20 20 20 28 74 65 73 d)).. (tes
f840: 74 2d 6e 61 6d 65 20 28 64 62 3a 74 65 73 74 2d t-name (db:test-
f850: 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 get-testname tes
f860: 74 2d 64 61 74 29 29 0a 09 20 20 20 20 20 20 20 t-dat))..
f870: 28 69 74 65 6d 2d 70 61 74 68 20 28 64 62 3a 74 (item-path (db:t
f880: 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 est-get-item-pat
f890: 68 20 74 65 73 74 2d 64 61 74 29 29 0a 09 20 20 h test-dat))..
f8a0: 20 20 20 20 20 28 66 75 6c 6c 2d 6e 61 6d 65 20 (full-name
f8b0: 28 64 62 3a 74 65 73 74 2d 6d 61 6b 65 2d 66 75 (db:test-make-fu
f8c0: 6c 6c 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d ll-name test-nam
f8d0: 65 20 69 74 65 6d 2d 70 61 74 68 29 29 0a 09 20 e item-path))..
f8e0: 20 20 20 20 20 20 28 6f 75 70 20 20 20 20 20 20 (oup
f8f0: 20 28 6f 70 65 6e 2d 6f 75 74 70 75 74 2d 66 69 (open-output-fi
f900: 6c 65 20 6f 75 74 2d 66 69 6c 65 29 29 0a 09 20 le out-file))..
f910: 20 20 20 20 20 20 28 73 74 61 74 75 73 20 20 20 (status
f920: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 (db:test-get-st
f930: 61 74 75 73 20 20 20 74 65 73 74 2d 64 61 74 29 atus test-dat)
f940: 29 0a 09 20 20 20 20 20 20 20 28 63 6f 6c 6f 72 ).. (color
f950: 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 (common:get
f960: 2d 63 6f 6c 6f 72 2d 66 72 6f 6d 2d 73 74 61 74 -color-from-stat
f970: 75 73 20 73 74 61 74 75 73 29 29 0a 09 20 20 20 us status))..
f980: 20 20 20 20 28 6c 6f 67 66 20 20 20 20 20 20 28 (logf (
f990: 64 62 3a 74 65 73 74 2d 67 65 74 2d 66 69 6e 61 db:test-get-fina
f9a0: 6c 5f 6c 6f 67 66 20 74 65 73 74 2d 64 61 74 29 l_logf test-dat)
f9b0: 29 0a 09 20 20 20 20 20 20 20 28 73 74 65 70 73 ).. (steps
f9c0: 2d 64 61 74 20 28 74 65 73 74 73 3a 67 65 74 2d -dat (tests:get-
f9d0: 63 6f 6d 70 72 65 73 73 65 64 2d 73 74 65 70 73 compressed-steps
f9e0: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 run-id test-id)
f9f0: 29 29 0a 09 20 20 3b 3b 20 28 64 63 6f 6d 6d 6f )).. ;; (dcommo
fa00: 6e 3a 67 65 74 2d 63 6f 6d 70 72 65 73 73 65 64 n:get-compressed
fa10: 2d 73 74 65 70 73 20 23 66 20 31 20 33 30 30 34 -steps #f 1 3004
fa20: 35 29 0a 09 20 20 3b 3b 20 28 23 28 22 77 61 73 5).. ;; (#("was
fa30: 74 69 6e 67 5f 74 69 6d 65 22 20 22 32 33 3a 33 ting_time" "23:3
fa40: 36 3a 31 33 22 20 22 32 33 3a 33 36 3a 32 31 22 6:13" "23:36:21"
fa50: 20 22 30 22 20 22 38 2e 30 73 22 20 22 77 61 73 "0" "8.0s" "was
fa60: 74 69 6e 67 5f 74 69 6d 65 2e 6c 6f 67 22 29 29 ting_time.log"))
fa70: 0a 09 0a 09 20 20 28 73 3a 6f 75 74 70 75 74 2d .... (s:output-
fa80: 6e 65 77 0a 09 20 20 20 6f 75 70 0a 09 20 20 20 new.. oup..
fa90: 28 73 3a 68 74 6d 6c 0a 09 20 20 20 20 28 73 3a (s:html.. (s:
faa0: 74 69 74 6c 65 20 22 53 75 6d 6d 61 72 79 20 66 title "Summary f
fab0: 6f 72 20 22 20 66 75 6c 6c 2d 6e 61 6d 65 29 0a or " full-name).
fac0: 09 20 20 20 20 28 73 3a 62 6f 64 79 20 0a 09 20 . (s:body ..
fad0: 20 20 20 20 28 73 3a 68 32 20 22 53 75 6d 6d 61 (s:h2 "Summa
fae0: 72 79 20 66 6f 72 20 22 20 66 75 6c 6c 2d 6e 61 ry for " full-na
faf0: 6d 65 29 0a 09 20 20 20 20 20 28 73 3a 74 61 62 me).. (s:tab
fb00: 6c 65 20 27 63 65 6c 6c 73 70 61 63 69 6e 67 20 le 'cellspacing
fb10: 22 30 22 20 27 62 6f 72 64 65 72 20 22 31 22 0a "0" 'border "1".
fb20: 09 09 20 20 20 20 20 20 28 73 3a 74 72 20 28 73 .. (s:tr (s
fb30: 3a 74 64 20 22 72 75 6e 20 69 64 22 29 20 20 20 :td "run id")
fb40: 28 73 3a 74 64 20 28 64 62 3a 74 65 73 74 2d 67 (s:td (db:test-g
fb50: 65 74 2d 72 75 6e 5f 69 64 20 20 20 74 65 73 74 et-run_id test
fb60: 2d 64 61 74 29 29 0a 09 09 09 20 20 20 20 28 73 -dat)).... (s
fb70: 3a 74 64 20 22 74 65 73 74 20 69 64 22 29 20 20 :td "test id")
fb80: 28 73 3a 74 64 20 28 64 62 3a 74 65 73 74 2d 67 (s:td (db:test-g
fb90: 65 74 2d 69 64 20 20 20 20 20 20 20 74 65 73 74 et-id test
fba0: 2d 64 61 74 29 29 29 0a 09 09 20 20 20 20 20 20 -dat)))...
fbb0: 28 73 3a 74 72 20 28 73 3a 74 64 20 22 74 65 73 (s:tr (s:td "tes
fbc0: 74 6e 61 6d 65 22 29 20 28 73 3a 74 64 20 74 65 tname") (s:td te
fbd0: 73 74 2d 6e 61 6d 65 29 0a 09 09 09 20 20 20 20 st-name)....
fbe0: 28 73 3a 74 64 20 22 69 74 65 6d 70 61 74 68 22 (s:td "itempath"
fbf0: 29 20 28 73 3a 74 64 20 69 74 65 6d 2d 70 61 74 ) (s:td item-pat
fc00: 68 29 29 0a 09 09 20 20 20 20 20 20 28 73 3a 74 h))... (s:t
fc10: 72 20 28 73 3a 74 64 20 22 73 74 61 74 65 22 29 r (s:td "state")
fc20: 20 20 20 20 28 73 3a 74 64 20 28 64 62 3a 74 65 (s:td (db:te
fc30: 73 74 2d 67 65 74 2d 73 74 61 74 65 20 20 20 20 st-get-state
fc40: 74 65 73 74 2d 64 61 74 29 29 0a 09 09 09 20 20 test-dat))....
fc50: 20 20 28 73 3a 74 64 20 22 73 74 61 74 75 73 22 (s:td "status"
fc60: 29 20 20 20 28 73 3a 74 64 20 28 73 3a 61 20 27 ) (s:td (s:a '
fc70: 68 72 65 66 20 6c 6f 67 66 20 28 73 3a 66 6f 6e href logf (s:fon
fc80: 74 20 27 63 6f 6c 6f 72 20 63 6f 6c 6f 72 20 73 t 'color color s
fc90: 74 61 74 75 73 29 29 29 29 0a 09 09 20 20 20 20 tatus))))...
fca0: 20 20 28 73 3a 74 72 20 28 73 3a 74 64 20 22 54 (s:tr (s:td "T
fcb0: 65 73 74 44 61 74 65 22 29 20 28 73 3a 74 64 20 estDate") (s:td
fcc0: 28 73 65 63 6f 6e 64 73 2d 3e 77 6f 72 6b 2d 77 (seconds->work-w
fcd0: 65 65 6b 2f 64 61 79 2d 74 69 6d 65 20 0a 09 09 eek/day-time ...
fce0: 09 09 09 09 20 20 20 20 20 28 64 62 3a 74 65 73 .... (db:tes
fcf0: 74 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 t-get-event_time
fd00: 20 74 65 73 74 2d 64 61 74 29 29 29 0a 09 09 09 test-dat)))....
fd10: 20 20 20 20 28 73 3a 74 64 20 22 44 75 72 61 74 (s:td "Durat
fd20: 69 6f 6e 22 29 20 28 73 3a 74 64 20 28 73 65 63 ion") (s:td (sec
fd30: 6f 6e 64 73 2d 3e 68 72 2d 6d 69 6e 2d 73 65 63 onds->hr-min-sec
fd40: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 (db:test-get-ru
fd50: 6e 5f 64 75 72 61 74 69 6f 6e 20 74 65 73 74 2d n_duration test-
fd60: 64 61 74 29 29 29 29 29 0a 09 20 20 20 20 20 28 dat))))).. (
fd70: 73 3a 68 33 20 22 4c 6f 67 20 66 69 6c 65 73 22 s:h3 "Log files"
fd80: 29 0a 09 20 20 20 20 20 28 73 3a 74 61 62 6c 65 ).. (s:table
fd90: 20 0a 09 20 20 20 20 20 20 27 63 65 6c 6c 73 70 .. 'cellsp
fda0: 61 63 69 6e 67 20 22 30 22 20 27 62 6f 72 64 65 acing "0" 'borde
fdb0: 72 20 22 31 22 0a 09 20 20 20 20 20 20 28 73 3a r "1".. (s:
fdc0: 74 72 20 28 73 3a 74 64 20 22 46 69 6e 61 6c 20 tr (s:td "Final
fdd0: 6c 6f 67 22 29 28 73 3a 74 64 20 28 73 3a 61 20 log")(s:td (s:a
fde0: 27 68 72 65 66 20 6c 6f 67 66 20 6c 6f 67 66 29 'href logf logf)
fdf0: 29 29 29 0a 09 20 20 20 20 20 28 73 3a 74 61 62 ))).. (s:tab
fe00: 6c 65 0a 09 20 20 20 20 20 20 27 63 65 6c 6c 73 le.. 'cells
fe10: 70 61 63 69 6e 67 20 22 30 22 20 27 62 6f 72 64 pacing "0" 'bord
fe20: 65 72 20 22 31 22 0a 09 20 20 20 20 20 20 28 73 er "1".. (s
fe30: 3a 74 72 20 28 73 3a 74 64 20 22 53 74 65 70 20 :tr (s:td "Step
fe40: 4e 61 6d 65 22 29 28 73 3a 74 64 20 22 53 74 61 Name")(s:td "Sta
fe50: 72 74 22 29 28 73 3a 74 64 20 22 45 6e 64 22 29 rt")(s:td "End")
fe60: 28 73 3a 74 64 20 22 53 74 61 74 75 73 22 29 28 (s:td "Status")(
fe70: 73 3a 74 64 20 22 44 75 72 61 74 69 6f 6e 22 29 s:td "Duration")
fe80: 28 73 3a 74 64 20 22 4c 6f 67 20 46 69 6c 65 22 (s:td "Log File"
fe90: 29 29 0a 09 20 20 20 20 20 20 28 6d 61 70 20 28 )).. (map (
fea0: 6c 61 6d 62 64 61 20 28 73 74 65 70 2d 64 61 74 lambda (step-dat
feb0: 29 0a 09 09 20 20 20 20 20 28 73 3a 74 72 20 28 )... (s:tr (
fec0: 73 3a 74 64 20 28 74 64 62 3a 73 74 65 70 73 2d s:td (tdb:steps-
fed0: 74 61 62 6c 65 2d 67 65 74 2d 73 74 65 70 6e 61 table-get-stepna
fee0: 6d 65 20 73 74 65 70 2d 64 61 74 29 29 0a 09 09 me step-dat))...
fef0: 09 20 20 20 28 73 3a 74 64 20 28 74 64 62 3a 73 . (s:td (tdb:s
ff00: 74 65 70 73 2d 74 61 62 6c 65 2d 67 65 74 2d 73 teps-table-get-s
ff10: 74 61 72 74 20 20 20 20 73 74 65 70 2d 64 61 74 tart step-dat
ff20: 29 29 0a 09 09 09 20 20 20 28 73 3a 74 64 20 28 )).... (s:td (
ff30: 74 64 62 3a 73 74 65 70 73 2d 74 61 62 6c 65 2d tdb:steps-table-
ff40: 67 65 74 2d 65 6e 64 20 20 20 20 20 20 73 74 65 get-end ste
ff50: 70 2d 64 61 74 29 29 0a 09 09 09 20 20 20 28 73 p-dat)).... (s
ff60: 3a 74 64 20 28 74 64 62 3a 73 74 65 70 73 2d 74 :td (tdb:steps-t
ff70: 61 62 6c 65 2d 67 65 74 2d 73 74 61 74 75 73 20 able-get-status
ff80: 20 20 73 74 65 70 2d 64 61 74 29 29 0a 09 09 09 step-dat))....
ff90: 20 20 20 28 73 3a 74 64 20 28 74 64 62 3a 73 74 (s:td (tdb:st
ffa0: 65 70 73 2d 74 61 62 6c 65 2d 67 65 74 2d 72 75 eps-table-get-ru
ffb0: 6e 74 69 6d 65 20 20 73 74 65 70 2d 64 61 74 29 ntime step-dat)
ffc0: 29 0a 09 09 09 20 20 20 28 73 3a 74 64 20 28 6c ).... (s:td (l
ffd0: 65 74 20 28 28 73 74 65 70 2d 6c 6f 67 20 28 74 et ((step-log (t
ffe0: 64 62 3a 73 74 65 70 73 2d 74 61 62 6c 65 2d 67 db:steps-table-g
fff0: 65 74 2d 6c 6f 67 2d 66 69 6c 65 20 73 74 65 70 et-log-file step
10000 2d 64 61 74 29 29 29 0a 09 09 09 09 20 20 20 28 -dat)))..... (
10010 73 3a 61 20 27 68 72 65 66 20 73 74 65 70 2d 6c s:a 'href step-l
10020 6f 67 20 73 74 65 70 2d 6c 6f 67 29 29 29 29 29 og step-log)))))
10030 0a 09 09 20 20 20 73 74 65 70 73 2d 64 61 74 29 ... steps-dat)
10040 29 0a 09 20 20 20 20 20 29 29 29 0a 09 20 20 28 ).. ))).. (
10050 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 close-output-por
10060 74 20 6f 75 70 29 29 29 29 29 0a 09 20 20 0a 09 t oup))))).. ..
10070 20 20 0a 3b 3b 20 4d 55 53 54 20 42 45 20 43 41 .;; MUST BE CA
10080 4c 4c 45 44 20 6c 6f 63 61 6c 21 0a 3b 3b 0a 28 LLED local!.;;.(
10090 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 74 65 define (tests:te
100a0 73 74 2d 67 65 74 2d 70 61 74 68 73 2d 6d 61 74 st-get-paths-mat
100b0 63 68 69 6e 67 20 6b 65 79 6e 61 6d 65 73 20 74 ching keynames t
100c0 61 72 67 65 74 20 66 6e 61 6d 65 70 61 74 74 20 arget fnamepatt
100d0 23 21 6b 65 79 20 28 72 65 73 20 27 28 29 29 29 #!key (res '()))
100e0 0a 20 20 3b 3b 20 42 55 47 3a 20 4d 6f 76 65 20 . ;; BUG: Move
100f0 74 68 65 20 76 61 6c 75 65 73 20 64 65 72 69 76 the values deriv
10100 65 64 20 66 72 6f 6d 20 61 72 67 73 20 74 6f 20 ed from args to
10110 70 61 72 61 6d 65 74 65 72 73 20 61 6e 64 20 70 parameters and p
10120 75 73 68 20 74 6f 20 6d 65 67 61 74 65 73 74 2e ush to megatest.
10130 73 63 6d 0a 20 20 28 6c 65 74 2a 20 28 28 74 65 scm. (let* ((te
10140 73 74 70 61 74 74 20 20 20 28 6f 72 20 28 61 72 stpatt (or (ar
10150 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 65 73 gs:get-arg "-tes
10160 74 70 61 74 74 22 29 28 61 72 67 73 3a 67 65 74 tpatt")(args:get
10170 2d 61 72 67 20 22 2d 74 65 73 74 70 61 74 74 22 -arg "-testpatt"
10180 29 20 22 25 22 29 29 0a 09 20 28 73 74 61 74 65 ) "%")).. (state
10190 70 61 74 74 20 20 28 6f 72 20 28 61 72 67 73 3a patt (or (args:
101a0 67 65 74 2d 61 72 67 20 22 2d 73 74 61 74 65 22 get-arg "-state"
101b0 29 20 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 ) (args:get-ar
101c0 67 20 22 3a 73 74 61 74 65 22 29 20 20 20 20 22 g ":state") "
101d0 25 22 29 29 0a 09 20 28 73 74 61 74 75 73 70 61 %")).. (statuspa
101e0 74 74 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 tt (or (args:get
101f0 2d 61 72 67 20 22 2d 73 74 61 74 75 73 22 29 20 -arg "-status")
10200 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
10210 3a 73 74 61 74 75 73 22 29 20 20 20 22 25 22 29 :status") "%")
10220 29 0a 09 20 28 72 75 6e 6e 61 6d 65 20 20 20 20 ).. (runname
10230 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (or (args:get-ar
10240 67 20 22 2d 72 75 6e 6e 61 6d 65 22 29 20 28 61 g "-runname") (a
10250 72 67 73 3a 67 65 74 2d 61 72 67 20 22 3a 72 75 rgs:get-arg ":ru
10260 6e 6e 61 6d 65 22 29 20 20 22 25 22 29 29 0a 09 nname") "%"))..
10270 20 28 70 61 74 68 73 2d 66 72 6f 6d 2d 64 62 20 (paths-from-db
10280 28 72 6d 74 3a 74 65 73 74 2d 67 65 74 2d 70 61 (rmt:test-get-pa
10290 74 68 73 2d 6d 61 74 63 68 69 6e 67 2d 6b 65 79 ths-matching-key
102a0 6e 61 6d 65 73 2d 74 61 72 67 65 74 2d 6e 65 77 names-target-new
102b0 20 6b 65 79 6e 61 6d 65 73 20 74 61 72 67 65 74 keynames target
102c0 20 72 65 73 0a 09 09 09 09 09 74 65 73 74 70 61 res......testpa
102d0 74 74 0a 09 09 09 09 09 73 74 61 74 65 70 61 74 tt......statepat
102e0 74 0a 09 09 09 09 09 73 74 61 74 75 73 70 61 74 t......statuspat
102f0 74 0a 09 09 09 09 09 72 75 6e 6e 61 6d 65 29 29 t......runname))
10300 29 0a 20 20 20 20 28 69 66 20 66 6e 61 6d 65 70 ). (if fnamep
10310 61 74 74 0a 09 28 61 70 70 6c 79 20 61 70 70 65 att..(apply appe
10320 6e 64 20 0a 09 20 20 20 20 20 20 20 28 6d 61 70 nd .. (map
10330 20 28 6c 61 6d 62 64 61 20 28 70 29 0a 09 09 20 (lambda (p)...
10340 20 20 20 20 20 28 69 66 20 28 64 69 72 65 63 74 (if (direct
10350 6f 72 79 2d 65 78 69 73 74 73 3f 20 70 29 0a 09 ory-exists? p)..
10360 09 09 20 20 28 6c 65 74 20 28 28 67 6c 6f 62 2d .. (let ((glob-
10370 71 75 65 72 79 20 28 63 6f 6e 63 20 70 20 22 2f query (conc p "/
10380 22 20 66 6e 61 6d 65 70 61 74 74 29 29 29 0a 09 " fnamepatt)))..
10390 09 09 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 .. (handle-ex
103a0 63 65 70 74 69 6f 6e 73 0a 09 09 09 09 65 78 6e ceptions.....exn
103b0 0a 09 09 09 20 20 20 20 20 20 28 62 65 67 69 6e .... (begin
103c0 0a 09 09 09 09 28 70 72 69 6e 74 20 22 62 75 69 .....(print "bui
103d0 6c 74 2d 69 6e 20 67 6c 6f 62 20 6f 6e 20 22 20 lt-in glob on "
103e0 67 6c 6f 62 2d 71 75 65 72 79 20 22 2c 20 66 61 glob-query ", fa
103f0 69 6c 65 64 2c 20 74 72 79 20 75 73 69 6e 67 20 iled, try using
10400 74 68 65 20 73 68 65 6c 6c 2e 20 65 78 6e 3d 22 the shell. exn="
10410 20 65 78 6e 29 0a 09 09 09 09 28 77 69 74 68 2d exn).....(with-
10420 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 0a input-from-pipe.
10430 09 09 09 09 20 28 63 6f 6e 63 20 22 65 63 68 6f .... (conc "echo
10440 20 22 20 67 6c 6f 62 2d 71 75 65 72 79 29 0a 09 " glob-query)..
10450 09 09 09 20 72 65 61 64 2d 6c 69 6e 65 73 29 29 ... read-lines))
10460 20 20 3b 3b 20 77 65 20 61 72 65 6e 27 74 20 67 ;; we aren't g
10470 6f 69 6e 67 20 74 6f 20 74 72 79 20 74 6f 6f 20 oing to try too
10480 68 61 72 64 2e 20 49 66 20 67 6c 6f 62 20 62 72 hard. If glob br
10490 65 61 6b 73 20 69 74 20 69 73 20 6c 69 6b 65 6c eaks it is likel
104a0 79 20 62 65 63 61 75 73 65 20 73 6f 6d 65 6f 6e y because someon
104b0 65 20 74 72 69 65 64 20 74 6f 20 64 6f 20 2a 2f e tried to do */
104c0 2a 2f 2a 2e 6c 6f 67 20 6f 72 20 73 69 6d 69 6c */*.log or simil
104d0 61 72 0a 09 09 09 20 20 20 20 20 20 28 67 6c 6f ar.... (glo
104e0 62 20 67 6c 6f 62 2d 71 75 65 72 79 29 29 29 0a b glob-query))).
104f0 09 09 09 20 20 27 28 29 29 29 0a 09 09 20 20 20 ... '()))...
10500 20 70 61 74 68 73 2d 66 72 6f 6d 2d 64 62 29 29 paths-from-db))
10510 0a 09 70 61 74 68 73 2d 66 72 6f 6d 2d 64 62 29 ..paths-from-db)
10520 29 29 0a 0a 09 09 09 20 20 20 20 20 20 0a 3b 3b ))..... .;;
10530 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10540 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10550 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10560 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10570 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 47 61 74 68 65 72 ======.;; Gather
10580 20 64 61 74 61 20 66 72 6f 6d 20 74 65 73 74 2f data from test/
10590 74 61 73 6b 20 73 70 65 63 69 66 69 63 61 74 69 task specificati
105a0 6f 6e 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ons.;;==========
105b0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
105c0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
105d0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
105e0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b ============..;;
105f0 20 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a (define (tests:
10600 67 65 74 2d 76 61 6c 69 64 2d 74 65 73 74 73 20 get-valid-tests
10610 74 65 73 74 73 64 69 72 20 74 65 73 74 2d 70 61 testsdir test-pa
10620 74 74 73 29 20 3b 3b 20 20 23 21 6b 65 79 20 28 tts) ;; #!key (
10630 74 65 73 74 2d 6e 61 6d 65 73 20 27 28 29 29 29 test-names '()))
10640 0a 3b 3b 20 20 20 28 6c 65 74 20 28 28 74 65 73 .;; (let ((tes
10650 74 73 20 28 67 6c 6f 62 20 28 63 6f 6e 63 20 74 ts (glob (conc t
10660 65 73 74 73 64 69 72 20 22 2f 74 65 73 74 73 2f estsdir "/tests/
10670 2a 22 29 29 29 29 20 3b 3b 20 22 20 28 73 74 72 *")))) ;; " (str
10680 69 6e 67 2d 74 72 61 6e 73 6c 61 74 65 20 70 61 ing-translate pa
10690 74 74 20 22 25 22 20 22 2a 22 29 29 29 29 29 0a tt "%" "*"))))).
106a0 3b 3b 20 20 20 20 20 28 73 65 74 21 20 74 65 73 ;; (set! tes
106b0 74 73 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 ts (filter (lamb
106c0 64 61 20 28 74 65 73 74 29 28 63 6f 6d 6d 6f 6e da (test)(common
106d0 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 28 63 :file-exists? (c
106e0 6f 6e 63 20 74 65 73 74 20 22 2f 74 65 73 74 63 onc test "/testc
106f0 6f 6e 66 69 67 22 29 29 29 20 74 65 73 74 73 29 onfig"))) tests)
10700 29 0a 3b 3b 20 20 20 20 20 28 64 65 6c 65 74 65 ).;; (delete
10710 2d 64 75 70 6c 69 63 61 74 65 73 0a 3b 3b 20 20 -duplicates.;;
10720 20 20 20 20 28 66 69 6c 74 65 72 20 28 6c 61 6d (filter (lam
10730 62 64 61 20 28 74 65 73 74 6e 61 6d 65 29 0a 3b bda (testname).;
10740 3b 20 09 20 20 20 20 20 20 20 28 74 65 73 74 73 ; . (tests
10750 3a 6d 61 74 63 68 20 74 65 73 74 2d 70 61 74 74 :match test-patt
10760 73 20 74 65 73 74 6e 61 6d 65 20 23 66 29 29 0a s testname #f)).
10770 3b 3b 20 09 20 20 20 20 20 28 6d 61 70 20 28 6c ;; . (map (l
10780 61 6d 62 64 61 20 28 74 65 73 74 70 29 0a 3b 3b ambda (testp).;;
10790 20 09 09 20 20 20 20 28 6c 61 73 74 20 28 73 74 .. (last (st
107a0 72 69 6e 67 2d 73 70 6c 69 74 20 74 65 73 74 70 ring-split testp
107b0 20 22 2f 22 29 29 29 0a 3b 3b 20 09 09 20 20 74 "/"))).;; .. t
107c0 65 73 74 73 29 29 29 29 29 0a 0a 28 64 65 66 69 ests)))))..(defi
107d0 6e 65 20 28 74 65 73 74 73 3a 67 65 74 2d 74 65 ne (tests:get-te
107e0 73 74 2d 70 61 74 68 2d 66 72 6f 6d 2d 65 6e 76 st-path-from-env
107f0 69 72 6f 6e 6d 65 6e 74 29 0a 20 20 28 69 66 20 ironment). (if
10800 28 61 6e 64 20 28 67 65 74 65 6e 76 20 22 4d 54 (and (getenv "MT
10810 5f 4c 49 4e 4b 54 52 45 45 22 29 0a 09 20 20 20 _LINKTREE")..
10820 28 67 65 74 65 6e 76 20 22 4d 54 5f 54 41 52 47 (getenv "MT_TARG
10830 45 54 22 29 0a 09 20 20 20 28 67 65 74 65 6e 76 ET").. (getenv
10840 20 22 4d 54 5f 52 55 4e 4e 41 4d 45 22 29 0a 09 "MT_RUNNAME")..
10850 20 20 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 54 (getenv "MT_T
10860 45 53 54 5f 4e 41 4d 45 22 29 0a 09 20 20 20 28 EST_NAME").. (
10870 67 65 74 65 6e 76 20 22 4d 54 5f 49 54 45 4d 50 getenv "MT_ITEMP
10880 41 54 48 22 29 29 0a 20 20 20 20 20 20 28 63 6f ATH")). (co
10890 6e 63 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 4c nc (getenv "MT_L
108a0 49 4e 4b 54 52 45 45 22 29 20 20 22 2f 22 0a 09 INKTREE") "/"..
108b0 20 20 20 20 28 67 65 74 65 6e 76 20 22 4d 54 5f (getenv "MT_
108c0 54 41 52 47 45 54 22 29 20 20 20 20 22 2f 22 0a TARGET") "/".
108d0 09 20 20 20 20 28 67 65 74 65 6e 76 20 22 4d 54 . (getenv "MT
108e0 5f 52 55 4e 4e 41 4d 45 22 29 20 20 20 22 2f 22 _RUNNAME") "/"
108f0 0a 09 20 20 20 20 28 67 65 74 65 6e 76 20 22 4d .. (getenv "M
10900 54 5f 54 45 53 54 5f 4e 41 4d 45 22 29 0a 09 20 T_TEST_NAME")..
10910 20 20 20 28 69 66 20 28 61 6e 64 20 28 67 65 74 (if (and (get
10920 65 6e 76 20 22 4d 54 5f 49 54 45 4d 50 41 54 48 env "MT_ITEMPATH
10930 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ").
10940 20 20 20 20 20 20 20 20 28 6e 6f 74 20 28 73 74 (not (st
10950 72 69 6e 67 3d 3f 20 22 22 20 28 67 65 74 65 6e ring=? "" (geten
10960 76 20 22 4d 54 5f 49 54 45 4d 50 41 54 48 22 29 v "MT_ITEMPATH")
10970 29 29 29 0a 09 09 28 63 6f 6e 63 20 22 2f 22 20 )))...(conc "/"
10980 28 67 65 74 65 6e 76 20 22 4d 54 5f 49 54 45 4d (getenv "MT_ITEM
10990 50 41 54 48 22 29 29 0a 20 20 20 20 20 20 20 20 PATH")).
109a0 20 20 20 20 20 20 20 20 22 22 29 29 0a 20 20 20 "")).
109b0 20 20 20 23 66 29 29 0a 0a 3b 3b 20 69 66 20 2e #f))..;; if .
109c0 74 65 73 74 63 6f 6e 66 69 67 20 65 78 69 73 74 testconfig exist
109d0 73 20 69 6e 20 74 65 73 74 20 64 69 72 65 63 74 s in test direct
109e0 6f 72 79 20 72 65 61 64 20 61 6e 64 20 72 65 74 ory read and ret
109f0 75 72 6e 20 69 74 0a 3b 3b 20 65 6c 73 65 20 69 urn it.;; else i
10a00 66 20 68 61 76 65 20 63 61 63 68 65 64 20 63 6f f have cached co
10a10 70 79 20 69 6e 20 2a 74 65 73 74 63 6f 6e 66 69 py in *testconfi
10a20 67 73 2a 20 72 65 74 75 72 6e 20 69 74 20 49 46 gs* return it IF
10a30 46 20 74 68 65 72 65 20 69 73 20 61 20 73 65 63 F there is a sec
10a40 74 69 6f 6e 20 22 68 61 76 65 20 66 75 6c 6c 64 tion "have fulld
10a50 61 74 61 22 0a 3b 3b 20 65 6c 73 65 20 72 65 61 ata".;; else rea
10a60 64 20 74 68 65 20 74 65 73 74 63 6f 6e 66 69 67 d the testconfig
10a70 20 66 69 6c 65 0a 3b 3b 20 20 20 69 66 20 68 61 file.;; if ha
10a80 76 65 20 70 61 74 68 20 74 6f 20 74 65 73 74 20 ve path to test
10a90 64 69 72 65 63 74 6f 72 79 20 73 61 76 65 20 74 directory save t
10aa0 68 65 20 63 6f 6e 66 69 67 20 61 73 20 2e 74 65 he config as .te
10ab0 73 74 63 6f 6e 66 69 67 20 61 6e 64 20 72 65 74 stconfig and ret
10ac0 75 72 6e 20 69 74 0a 3b 3b 0a 28 64 65 66 69 6e urn it.;;.(defin
10ad0 65 20 28 74 65 73 74 73 3a 67 65 74 2d 74 65 73 e (tests:get-tes
10ae0 74 63 6f 6e 66 69 67 20 74 65 73 74 2d 6e 61 6d tconfig test-nam
10af0 65 20 69 74 65 6d 2d 70 61 74 68 20 74 65 73 74 e item-path test
10b00 2d 72 65 67 69 73 74 72 79 20 73 79 73 74 65 6d -registry system
10b10 2d 61 6c 6c 6f 77 65 64 20 23 21 6b 65 79 20 28 -allowed #!key (
10b20 66 6f 72 63 65 2d 63 72 65 61 74 65 20 23 66 29 force-create #f)
10b30 28 61 6c 6c 6f 77 2d 77 72 69 74 65 2d 63 61 63 (allow-write-cac
10b40 68 65 20 23 74 29 28 77 61 69 74 2d 61 2d 6d 69 he #t)(wait-a-mi
10b50 6e 75 74 65 20 23 66 29 29 0a 20 20 28 6c 65 74 nute #f)). (let
10b60 2a 20 28 28 75 73 65 2d 63 61 63 68 65 20 20 20 * ((use-cache
10b70 20 28 63 6f 6d 6d 6f 6e 3a 75 73 65 2d 63 61 63 (common:use-cac
10b80 68 65 3f 29 29 0a 09 20 28 63 61 63 68 65 2d 70 he?)).. (cache-p
10b90 61 74 68 20 20 20 28 74 65 73 74 73 3a 67 65 74 ath (tests:get
10ba0 2d 74 65 73 74 2d 70 61 74 68 2d 66 72 6f 6d 2d -test-path-from-
10bb0 65 6e 76 69 72 6f 6e 6d 65 6e 74 29 29 0a 09 20 environment))..
10bc0 28 63 61 63 68 65 2d 66 69 6c 65 20 20 20 28 61 (cache-file (a
10bd0 6e 64 20 63 61 63 68 65 2d 70 61 74 68 20 28 63 nd cache-path (c
10be0 6f 6e 63 20 63 61 63 68 65 2d 70 61 74 68 20 22 onc cache-path "
10bf0 2f 2e 74 65 73 74 63 6f 6e 66 69 67 22 29 29 29 /.testconfig")))
10c00 0a 09 20 28 63 61 63 68 65 2d 65 78 69 73 74 73 .. (cache-exists
10c10 20 28 61 6e 64 20 63 61 63 68 65 2d 66 69 6c 65 (and cache-file
10c20 0a 09 09 09 20 20 20 20 28 6e 6f 74 20 66 6f 72 .... (not for
10c30 63 65 2d 63 72 65 61 74 65 29 20 20 3b 3b 20 69 ce-create) ;; i
10c40 66 20 66 6f 72 63 65 2d 63 72 65 61 74 65 20 74 f force-create t
10c50 68 65 6e 20 70 72 65 74 65 6e 64 20 74 68 65 72 hen pretend ther
10c60 65 20 69 73 20 6e 6f 20 63 61 63 68 65 20 74 6f e is no cache to
10c70 20 72 65 61 64 0a 09 09 09 20 20 20 20 28 63 6f read.... (co
10c80 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 mmon:file-exists
10c90 3f 20 63 61 63 68 65 2d 66 69 6c 65 29 29 29 0a ? cache-file))).
10ca0 09 20 28 63 61 63 68 65 64 2d 64 61 74 20 20 20 . (cached-dat
10cb0 28 69 66 20 28 61 6e 64 20 28 6e 6f 74 20 66 6f (if (and (not fo
10cc0 72 63 65 2d 63 72 65 61 74 65 29 0a 09 09 09 09 rce-create).....
10cd0 63 61 63 68 65 2d 65 78 69 73 74 73 0a 09 09 09 cache-exists....
10ce0 09 75 73 65 2d 63 61 63 68 65 29 0a 09 09 09 20 .use-cache)....
10cf0 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 (handle-except
10d00 69 6f 6e 73 0a 09 09 09 20 20 20 20 20 20 20 65 ions.... e
10d10 78 6e 0a 09 09 09 20 20 20 20 20 28 62 65 67 69 xn.... (begi
10d20 6e 0a 09 09 09 20 20 20 20 20 20 20 28 64 65 62 n.... (deb
10d30 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
10d40 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 66 ult-log-port* "f
10d50 61 69 6c 65 64 20 74 6f 20 72 65 61 64 20 22 20 ailed to read "
10d60 63 61 63 68 65 2d 66 69 6c 65 20 22 2c 20 65 78 cache-file ", ex
10d70 6e 3d 22 20 65 78 6e 29 0a 09 09 09 20 20 20 20 n=" exn)....
10d80 20 20 20 23 66 29 20 3b 3b 20 61 6e 79 20 69 73 #f) ;; any is
10d90 73 75 65 73 2c 20 6a 75 73 74 20 67 69 76 65 20 sues, just give
10da0 75 70 20 77 69 74 68 20 74 68 65 20 63 61 63 68 up with the cach
10db0 65 64 20 76 65 72 73 69 6f 6e 20 61 6e 64 20 72 ed version and r
10dc0 65 2d 72 65 61 64 0a 09 09 09 20 20 20 20 20 28 e-read.... (
10dd0 63 6f 6e 66 69 67 66 3a 72 65 61 64 2d 61 6c 69 configf:read-ali
10de0 73 74 20 63 61 63 68 65 2d 66 69 6c 65 29 29 0a st cache-file)).
10df0 09 09 09 20 20 20 23 66 29 29 0a 20 20 20 20 20 ... #f)).
10e00 20 20 20 20 28 74 65 73 74 2d 66 75 6c 6c 2d 6e (test-full-n
10e10 61 6d 65 20 28 69 66 20 28 61 6e 64 20 69 74 65 ame (if (and ite
10e20 6d 2d 70 61 74 68 20 28 6e 6f 74 20 28 73 74 72 m-path (not (str
10e30 69 6e 67 2d 6e 75 6c 6c 3f 20 69 74 65 6d 2d 70 ing-null? item-p
10e40 61 74 68 29 29 29 0a 20 20 20 20 20 20 20 20 20 ath))).
10e50 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
10e60 20 20 20 20 28 63 6f 6e 63 20 74 65 73 74 2d 6e (conc test-n
10e70 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 ame "/" item-pat
10e80 68 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 h).
10e90 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
10ea0 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a 20 20 20 test-name))).
10eb0 20 28 69 66 20 63 61 63 68 65 64 2d 64 61 74 0a (if cached-dat.
10ec0 09 63 61 63 68 65 64 2d 64 61 74 0a 09 28 6c 65 .cached-dat..(le
10ed0 74 20 28 28 64 61 74 20 28 68 61 73 68 2d 74 61 t ((dat (hash-ta
10ee0 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
10ef0 2a 74 65 73 74 63 6f 6e 66 69 67 73 2a 20 74 65 *testconfigs* te
10f00 73 74 2d 66 75 6c 6c 2d 6e 61 6d 65 20 23 66 29 st-full-name #f)
10f10 29 29 0a 09 20 20 28 69 66 20 28 61 6e 64 20 20 )).. (if (and
10f20 64 61 74 20 3b 3b 20 68 61 76 65 20 61 20 6c 6f dat ;; have a lo
10f30 63 61 6c 6c 79 20 63 61 63 68 65 64 20 76 65 72 cally cached ver
10f40 73 69 6f 6e 0a 09 09 20 20 20 20 28 68 61 73 68 sion... (hash
10f50 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
10f60 6c 74 20 64 61 74 20 22 68 61 76 65 20 66 75 6c lt dat "have ful
10f70 6c 64 61 74 61 22 20 23 66 29 29 20 3b 3b 20 6d ldata" #f)) ;; m
10f80 61 72 6b 65 64 20 61 73 20 67 6f 6f 64 20 64 61 arked as good da
10f90 74 61 3f 0a 09 20 20 20 20 20 20 64 61 74 0a 09 ta?.. dat..
10fa0 20 20 20 20 20 20 3b 3b 20 6e 6f 20 63 61 63 68 ;; no cach
10fb0 65 64 20 64 61 74 61 20 61 76 61 69 6c 61 62 6c ed data availabl
10fc0 65 0a 09 20 20 20 20 20 20 28 6c 65 74 2a 20 28 e.. (let* (
10fd0 28 74 72 65 67 20 20 20 20 20 20 20 20 20 28 6f (treg (o
10fe0 72 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 0a r test-registry.
10ff0 09 09 09 09 20 20 20 20 20 20 20 28 74 65 73 74 .... (test
11000 73 3a 67 65 74 2d 61 6c 6c 29 29 29 0a 09 09 20 s:get-all)))...
11010 20 20 20 20 28 74 65 73 74 2d 70 61 74 68 20 20 (test-path
11020 20 20 28 6f 72 20 28 68 61 73 68 2d 74 61 62 6c (or (hash-tabl
11030 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 72 e-ref/default tr
11040 65 67 20 74 65 73 74 2d 6e 61 6d 65 20 23 66 29 eg test-name #f)
11050 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
11060 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11070 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 (let* ((
11080 6c 6f 63 61 6c 2d 74 63 64 69 72 20 28 63 6f 6e local-tcdir (con
11090 63 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 4c 49 c (getenv "MT_LI
110a0 4e 4b 54 52 45 45 22 29 20 22 2f 22 0a 20 20 20 NKTREE") "/".
110b0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
110c0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
110d0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
110e0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 67 (g
110f0 65 74 65 6e 76 20 22 4d 54 5f 54 41 52 47 45 54 etenv "MT_TARGET
11100 22 29 20 22 2f 22 0a 20 20 20 20 20 20 20 20 20 ") "/".
11110 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11120 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11130 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11140 20 20 20 20 20 20 20 20 28 67 65 74 65 6e 76 20 (getenv
11150 22 4d 54 5f 52 55 4e 4e 41 4d 45 22 29 20 22 2f "MT_RUNNAME") "/
11160 22 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ".
11170 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11180 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11190 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
111a0 20 20 20 74 65 73 74 2d 6e 61 6d 65 20 22 2f 22 test-name "/"
111b0 20 69 74 65 6d 2d 70 61 74 68 29 29 0a 20 20 20 item-path)).
111c0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
111d0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
111e0 20 20 20 20 20 20 20 20 20 20 20 28 6c 6f 63 61 (loca
111f0 6c 2d 74 63 66 67 20 28 63 6f 6e 63 20 6c 6f 63 l-tcfg (conc loc
11200 61 6c 2d 74 63 64 69 72 20 22 2f 74 65 73 74 63 al-tcdir "/testc
11210 6f 6e 66 69 67 22 29 29 29 0a 20 20 20 20 20 20 onfig"))).
11220 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11230 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11240 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 66 (if (common:f
11250 69 6c 65 2d 65 78 69 73 74 73 3f 20 6c 6f 63 61 ile-exists? loca
11260 6c 2d 74 63 66 67 29 0a 20 20 20 20 20 20 20 20 l-tcfg).
11270 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11280 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11290 20 20 20 20 20 6c 6f 63 61 6c 2d 74 63 64 69 72 local-tcdir
112a0 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
112b0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
112c0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 23 66 #f
112d0 29 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 63 ))..... (c
112e0 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f onc *toppath* "/
112f0 74 65 73 74 73 2f 22 20 74 65 73 74 2d 6e 61 6d tests/" test-nam
11300 65 29 29 29 0a 09 09 20 20 20 20 20 28 74 65 73 e)))... (tes
11310 74 2d 63 6f 6e 66 69 67 66 20 28 63 6f 6e 63 20 t-configf (conc
11320 74 65 73 74 2d 70 61 74 68 20 22 2f 74 65 73 74 test-path "/test
11330 63 6f 6e 66 69 67 22 29 29 0a 09 09 20 20 20 20 config"))...
11340 20 28 74 65 73 74 65 78 69 73 74 73 20 20 20 28 (testexists (
11350 6c 65 74 20 6c 6f 6f 70 61 20 28 28 74 72 69 65 let loopa ((trie
11360 73 2d 6c 65 66 74 20 33 30 29 29 0a 20 20 20 20 s-left 30)).
11370 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11380 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11390 20 28 63 6f 6e 64 0a 20 20 20 20 20 20 20 20 20 (cond.
113a0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
113b0 20 20 20 20 20 20 20 20 20 20 20 20 20 28 0a 20 (.
113c0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
113d0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
113e0 20 20 20 20 20 20 28 61 6e 64 20 28 63 6f 6d 6d (and (comm
113f0 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 on:file-exists?
11400 74 65 73 74 2d 63 6f 6e 66 69 67 66 29 28 66 69 test-configf)(fi
11410 6c 65 2d 72 65 61 64 2d 61 63 63 65 73 73 3f 20 le-read-access?
11420 74 65 73 74 2d 63 6f 6e 66 69 67 66 29 29 0a 20 test-configf)).
11430 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11440 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11450 20 20 20 20 20 20 23 74 29 0a 20 20 20 20 20 20 #t).
11460 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11470 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11480 28 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 (.
11490 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
114a0 20 20 20 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e (common
114b0 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 74 65 :file-exists? te
114c0 73 74 2d 63 6f 6e 66 69 67 66 29 0a 20 20 20 20 st-configf).
114d0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
114e0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
114f0 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
11500 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
11510 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 43 ort* "WARNING: C
11520 61 6e 6e 6f 74 20 72 65 61 64 20 74 65 73 74 63 annot read testc
11530 6f 6e 66 69 67 20 66 69 6c 65 3a 20 22 74 65 73 onfig file: "tes
11540 74 2d 63 6f 6e 66 69 67 66 29 0a 20 20 20 20 20 t-configf).
11550 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11560 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11570 20 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 #f).
11580 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11590 20 20 20 20 20 20 20 20 20 20 20 20 28 0a 20 20 (.
115a0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
115b0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
115c0 20 20 20 20 20 28 61 6e 64 20 77 61 69 74 2d 61 (and wait-a
115d0 2d 6d 69 6e 75 74 65 20 28 3e 20 74 72 69 65 73 -minute (> tries
115e0 2d 6c 65 66 74 20 30 29 29 0a 20 20 20 20 20 20 -left 0)).
115f0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11600 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11610 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
11620 31 30 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 10).
11630 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11640 20 20 20 20 20 20 20 20 20 20 20 28 64 65 62 75 (debu
11650 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
11660 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 lt-log-port* "WA
11670 52 4e 49 4e 47 3a 20 74 65 73 74 63 6f 6e 66 69 RNING: testconfi
11680 67 20 66 69 6c 65 20 64 6f 65 73 20 6e 6f 74 20 g file does not
11690 65 78 69 73 74 3a 20 22 74 65 73 74 2d 63 6f 6e exist: "test-con
116a0 66 69 67 66 22 20 77 69 6c 6c 20 72 65 74 72 79 figf" will retry
116b0 20 69 6e 20 31 30 20 73 65 63 6f 6e 64 73 2e 20 in 10 seconds.
116c0 20 54 72 69 65 73 20 6c 65 66 74 3a 20 22 74 72 Tries left: "tr
116d0 69 65 73 2d 6c 65 66 74 29 20 3b 3b 20 42 42 3a ies-left) ;; BB:
116e0 20 74 68 69 73 20 66 69 72 65 73 0a 20 20 20 20 this fires.
116f0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11700 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11710 20 20 20 28 6c 6f 6f 70 61 20 28 73 75 62 31 20 (loopa (sub1
11720 74 72 69 65 73 2d 6c 65 66 74 29 29 29 0a 20 20 tries-left))).
11730 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11740 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11750 20 20 20 20 28 65 6c 73 65 0a 20 20 20 20 20 20 (else.
11760 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11770 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11780 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
11790 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
117a0 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 74 65 73 t* "WARNING: tes
117b0 74 63 6f 6e 66 69 67 20 66 69 6c 65 20 64 6f 65 tconfig file doe
117c0 73 20 6e 6f 74 20 65 78 69 73 74 3a 20 22 74 65 s not exist: "te
117d0 73 74 2d 63 6f 6e 66 69 67 66 29 20 3b 3b 20 42 st-configf) ;; B
117e0 42 3a 20 74 68 69 73 20 66 69 72 65 73 0a 20 20 B: this fires.
117f0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11800 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11810 20 20 20 20 20 23 66 29 29 29 29 0a 09 09 20 20 #f))))...
11820 20 20 20 28 74 63 66 67 20 20 20 20 20 20 20 20 (tcfg
11830 20 28 69 66 20 74 65 73 74 65 78 69 73 74 73 0a (if testexists.
11840 09 09 09 09 20 20 20 20 20 20 20 28 72 65 61 64 .... (read
11850 2d 63 6f 6e 66 69 67 20 74 65 73 74 2d 63 6f 6e -config test-con
11860 66 69 67 66 20 23 66 20 73 79 73 74 65 6d 2d 61 figf #f system-a
11870 6c 6c 6f 77 65 64 0a 09 09 09 09 09 09 20 20 20 llowed.......
11880 20 65 6e 76 69 72 6f 6e 2d 70 61 74 74 3a 20 28 environ-patt: (
11890 69 66 20 73 79 73 74 65 6d 2d 61 6c 6c 6f 77 65 if system-allowe
118a0 64 0a 09 09 09 09 09 09 09 09 20 20 20 20 20 20 d.........
118b0 22 70 72 65 2d 6c 61 75 6e 63 68 2d 65 6e 76 2d "pre-launch-env-
118c0 76 61 72 73 22 0a 09 09 09 09 09 09 09 09 20 20 vars".........
118d0 20 20 20 20 23 66 29 29 0a 09 09 09 09 20 20 20 #f)).....
118e0 20 20 20 20 23 66 29 29 29 0a 09 09 28 69 66 20 #f)))...(if
118f0 28 61 6e 64 20 74 63 66 67 20 63 61 63 68 65 2d (and tcfg cache-
11900 66 69 6c 65 29 20 28 68 61 73 68 2d 74 61 62 6c file) (hash-tabl
11910 65 2d 73 65 74 21 20 74 63 66 67 20 22 68 61 76 e-set! tcfg "hav
11920 65 20 66 75 6c 6c 64 61 74 61 22 20 23 74 29 29 e fulldata" #t))
11930 20 3b 3b 20 6d 61 72 6b 20 74 68 69 73 20 61 73 ;; mark this as
11940 20 66 75 6c 6c 79 20 72 65 61 64 20 64 61 74 61 fully read data
11950 0a 09 09 28 69 66 20 74 63 66 67 20 28 68 61 73 ...(if tcfg (has
11960 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a 74 65 h-table-set! *te
11970 73 74 63 6f 6e 66 69 67 73 2a 20 74 65 73 74 2d stconfigs* test-
11980 66 75 6c 6c 2d 6e 61 6d 65 20 74 63 66 67 29 29 full-name tcfg))
11990 0a 09 09 28 69 66 20 28 61 6e 64 20 74 65 73 74 ...(if (and test
119a0 65 78 69 73 74 73 0a 09 09 09 20 63 61 63 68 65 exists.... cache
119b0 2d 66 69 6c 65 0a 09 09 09 20 28 66 69 6c 65 2d -file.... (file-
119c0 77 72 69 74 65 2d 61 63 63 65 73 73 3f 20 63 61 write-access? ca
119d0 63 68 65 2d 70 61 74 68 29 0a 09 09 09 20 61 6c che-path).... al
119e0 6c 6f 77 2d 77 72 69 74 65 2d 63 61 63 68 65 29 low-write-cache)
119f0 0a 09 09 20 20 20 20 28 6c 65 74 20 28 28 74 70 ... (let ((tp
11a00 61 74 68 20 28 63 6f 6e 63 20 63 61 63 68 65 2d ath (conc cache-
11a10 70 61 74 68 20 22 2f 2e 74 65 73 74 63 6f 6e 66 path "/.testconf
11a20 69 67 22 29 29 29 0a 09 09 20 20 20 20 20 20 28 ig")))... (
11a30 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
11a40 20 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 1 *default-log-
11a50 70 6f 72 74 2a 20 22 43 61 63 68 69 6e 67 20 74 port* "Caching t
11a60 65 73 74 63 6f 6e 66 69 67 20 66 6f 72 20 22 20 estconfig for "
11a70 74 65 73 74 2d 6e 61 6d 65 20 22 20 69 6e 20 22 test-name " in "
11a80 20 74 70 61 74 68 29 0a 20 20 20 20 20 20 20 20 tpath).
11a90 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i
11aa0 66 20 28 61 6e 64 20 74 63 66 67 20 28 6e 6f 74 f (and tcfg (not
11ab0 20 28 63 6f 6d 6d 6f 6e 3a 69 6e 2d 72 75 6e 6e (common:in-runn
11ac0 69 6e 67 2d 74 65 73 74 3f 29 29 29 0a 20 20 20 ing-test?))).
11ad0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11ae0 20 20 20 20 20 20 20 28 63 6f 6e 66 69 67 66 3a (configf:
11af0 77 72 69 74 65 2d 61 6c 69 73 74 20 74 63 66 67 write-alist tcfg
11b00 20 74 70 61 74 68 29 29 29 29 0a 09 09 74 63 66 tpath))))...tcf
11b10 67 29 29 29 29 29 29 0a 20 20 0a 3b 3b 20 73 6f g)))))). .;; so
11b20 72 74 20 74 65 73 74 73 20 62 79 20 70 72 69 6f rt tests by prio
11b30 72 69 74 79 20 61 6e 64 20 77 61 69 74 6f 6e 0a rity and waiton.
11b40 3b 3b 20 4d 6f 76 65 20 74 65 73 74 20 73 70 65 ;; Move test spe
11b50 63 69 66 69 63 20 73 74 75 66 66 20 74 6f 20 61 cific stuff to a
11b60 20 74 65 73 74 20 75 6e 69 74 20 46 49 58 4d 45 test unit FIXME
11b70 20 6f 6e 65 20 6f 66 20 74 68 65 73 65 20 64 61 one of these da
11b80 79 73 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 ys.(define (test
11b90 73 3a 73 6f 72 74 2d 62 79 2d 70 72 69 6f 72 69 s:sort-by-priori
11ba0 74 79 2d 61 6e 64 2d 77 61 69 74 6f 6e 20 74 65 ty-and-waiton te
11bb0 73 74 2d 72 65 63 6f 72 64 73 29 0a 20 20 28 69 st-records). (i
11bc0 66 20 28 65 71 3f 20 28 68 61 73 68 2d 74 61 62 f (eq? (hash-tab
11bd0 6c 65 2d 73 69 7a 65 20 74 65 73 74 2d 72 65 63 le-size test-rec
11be0 6f 72 64 73 29 20 30 29 0a 20 20 20 20 20 20 27 ords) 0). '
11bf0 28 29 0a 20 20 20 20 20 20 28 6c 65 74 2a 20 28 (). (let* (
11c00 28 6d 75 6e 67 65 70 72 69 6f 72 69 74 79 20 28 (mungepriority (
11c10 6c 61 6d 62 64 61 20 28 70 72 69 6f 72 69 74 79 lambda (priority
11c20 29 0a 09 09 09 20 20 20 20 20 20 28 69 66 20 70 ).... (if p
11c30 72 69 6f 72 69 74 79 0a 09 09 09 09 20 20 28 6c riority..... (l
11c40 65 74 20 28 28 74 6d 70 20 28 61 6e 79 2d 3e 6e et ((tmp (any->n
11c50 75 6d 62 65 72 20 70 72 69 6f 72 69 74 79 29 29 umber priority))
11c60 29 0a 09 09 09 09 20 20 20 20 28 69 66 20 74 6d )..... (if tm
11c70 70 20 74 6d 70 20 28 62 65 67 69 6e 20 28 64 65 p tmp (begin (de
11c80 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 bug:print-error
11c90 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
11ca0 6f 72 74 2a 20 22 62 61 64 20 70 72 69 6f 72 69 ort* "bad priori
11cb0 74 79 20 76 61 6c 75 65 20 22 20 70 72 69 6f 72 ty value " prior
11cc0 69 74 79 20 22 2c 20 75 73 69 6e 67 20 30 22 29 ity ", using 0")
11cd0 20 30 29 29 29 0a 09 09 09 09 20 20 30 29 29 29 0)))..... 0)))
11ce0 0a 09 20 20 20 20 20 28 61 6c 6c 2d 74 65 73 74 .. (all-test
11cf0 73 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 s (hash-tab
11d00 6c 65 2d 6b 65 79 73 20 74 65 73 74 2d 72 65 63 le-keys test-rec
11d10 6f 72 64 73 29 29 0a 09 20 20 20 20 20 28 61 6c ords)).. (al
11d20 6c 2d 77 61 69 74 65 64 2d 6f 6e 20 20 28 6c 65 l-waited-on (le
11d30 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 61 t loop ((hed (ca
11d40 72 20 61 6c 6c 2d 74 65 73 74 73 29 29 0a 09 09 r all-tests))...
11d50 09 09 09 28 74 61 6c 20 28 63 64 72 20 61 6c 6c ...(tal (cdr all
11d60 2d 74 65 73 74 73 29 29 0a 09 09 09 09 09 28 72 -tests))......(r
11d70 65 73 20 27 28 29 29 29 0a 09 09 09 20 20 20 20 es '()))....
11d80 20 20 20 28 6c 65 74 2a 20 28 28 74 72 65 63 20 (let* ((trec
11d90 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 (hash-table-r
11da0 65 66 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 ef test-records
11db0 68 65 64 29 29 0a 09 09 09 09 20 20 20 20 20 20 hed)).....
11dc0 28 77 61 69 74 6f 6e 73 20 28 6f 72 20 28 74 65 (waitons (or (te
11dd0 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 sts:testqueue-ge
11de0 74 2d 77 61 69 74 6f 6e 73 20 74 72 65 63 29 20 t-waitons trec)
11df0 27 28 29 29 29 29 0a 09 09 09 09 20 28 69 66 20 '())))..... (if
11e00 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 09 09 (null? tal).....
11e10 20 20 20 20 20 28 61 70 70 65 6e 64 20 72 65 73 (append res
11e20 20 77 61 69 74 6f 6e 73 29 0a 09 09 09 09 20 20 waitons).....
11e30 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 (loop (car ta
11e40 6c 29 28 63 64 72 20 74 61 6c 29 28 61 70 70 65 l)(cdr tal)(appe
11e50 6e 64 20 72 65 73 20 77 61 69 74 6f 6e 73 29 29 nd res waitons))
11e60 29 29 29 29 0a 09 20 20 20 20 20 28 73 6f 72 74 )))).. (sort
11e70 2d 66 6e 31 20 0a 09 20 20 20 20 20 20 28 6c 61 -fn1 .. (la
11e80 6d 62 64 61 20 28 61 20 62 29 0a 09 09 28 6c 65 mbda (a b)...(le
11e90 74 2a 20 28 28 61 2d 72 65 63 6f 72 64 20 20 20 t* ((a-record
11ea0 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 (hash-table-ref
11eb0 74 65 73 74 2d 72 65 63 6f 72 64 73 20 61 29 29 test-records a))
11ec0 0a 09 09 20 20 20 20 20 20 20 28 62 2d 72 65 63 ... (b-rec
11ed0 6f 72 64 20 20 20 28 68 61 73 68 2d 74 61 62 6c ord (hash-tabl
11ee0 65 2d 72 65 66 20 74 65 73 74 2d 72 65 63 6f 72 e-ref test-recor
11ef0 64 73 20 62 29 29 0a 09 09 20 20 20 20 20 20 20 ds b))...
11f00 28 61 2d 77 61 69 74 6f 6e 73 20 20 28 6f 72 20 (a-waitons (or
11f10 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 (tests:testqueue
11f20 2d 67 65 74 2d 77 61 69 74 6f 6e 73 20 61 2d 72 -get-waitons a-r
11f30 65 63 6f 72 64 29 20 27 28 29 29 29 0a 09 09 20 ecord) '()))...
11f40 20 20 20 20 20 20 28 62 2d 77 61 69 74 6f 6e 73 (b-waitons
11f50 20 20 28 6f 72 20 28 74 65 73 74 73 3a 74 65 73 (or (tests:tes
11f60 74 71 75 65 75 65 2d 67 65 74 2d 77 61 69 74 6f tqueue-get-waito
11f70 6e 73 20 62 2d 72 65 63 6f 72 64 29 20 27 28 29 ns b-record) '()
11f80 29 29 0a 09 09 20 20 20 20 20 20 20 28 61 2d 63 ))... (a-c
11f90 6f 6e 66 69 67 20 20 20 28 74 65 73 74 73 3a 74 onfig (tests:t
11fa0 65 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 73 estqueue-get-tes
11fb0 74 63 6f 6e 66 69 67 20 20 61 2d 72 65 63 6f 72 tconfig a-recor
11fc0 64 29 29 0a 09 09 20 20 20 20 20 20 20 28 62 2d d))... (b-
11fd0 63 6f 6e 66 69 67 20 20 20 28 74 65 73 74 73 3a config (tests:
11fe0 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 testqueue-get-te
11ff0 73 74 63 6f 6e 66 69 67 20 20 62 2d 72 65 63 6f stconfig b-reco
12000 72 64 29 29 0a 09 09 20 20 20 20 20 20 20 28 61 rd))... (a
12010 2d 72 61 77 2d 70 72 69 20 20 28 63 6f 6e 66 69 -raw-pri (confi
12020 67 66 3a 6c 6f 6f 6b 75 70 20 61 2d 63 6f 6e 66 gf:lookup a-conf
12030 69 67 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 ig "requirements
12040 22 20 22 70 72 69 6f 72 69 74 79 22 29 29 0a 09 " "priority"))..
12050 09 20 20 20 20 20 20 20 28 62 2d 72 61 77 2d 70 . (b-raw-p
12060 72 69 20 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f ri (configf:loo
12070 6b 75 70 20 62 2d 63 6f 6e 66 69 67 20 22 72 65 kup b-config "re
12080 71 75 69 72 65 6d 65 6e 74 73 22 20 22 70 72 69 quirements" "pri
12090 6f 72 69 74 79 22 29 29 0a 09 09 20 20 20 20 20 ority"))...
120a0 20 20 28 61 2d 70 72 69 6f 72 69 74 79 20 28 6d (a-priority (m
120b0 75 6e 67 65 70 72 69 6f 72 69 74 79 20 61 2d 72 ungepriority a-r
120c0 61 77 2d 70 72 69 29 29 0a 09 09 20 20 20 20 20 aw-pri))...
120d0 20 20 28 62 2d 70 72 69 6f 72 69 74 79 20 28 6d (b-priority (m
120e0 75 6e 67 65 70 72 69 6f 72 69 74 79 20 62 2d 72 ungepriority b-r
120f0 61 77 2d 70 72 69 29 29 29 0a 09 09 20 20 28 74 aw-pri)))... (t
12100 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 73 ests:testqueue-s
12110 65 74 2d 70 72 69 6f 72 69 74 79 21 20 61 2d 72 et-priority! a-r
12120 65 63 6f 72 64 20 61 2d 70 72 69 6f 72 69 74 79 ecord a-priority
12130 29 0a 09 09 20 20 28 74 65 73 74 73 3a 74 65 73 )... (tests:tes
12140 74 71 75 65 75 65 2d 73 65 74 2d 70 72 69 6f 72 tqueue-set-prior
12150 69 74 79 21 20 62 2d 72 65 63 6f 72 64 20 62 2d ity! b-record b-
12160 70 72 69 6f 72 69 74 79 29 0a 09 09 20 20 3b 3b priority)... ;;
12170 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
12180 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
12190 74 2a 20 22 61 3d 22 20 61 20 22 2c 20 62 3d 22 t* "a=" a ", b="
121a0 20 62 20 22 2c 20 61 2d 77 61 69 74 6f 6e 73 3d b ", a-waitons=
121b0 22 20 61 2d 77 61 69 74 6f 6e 73 20 22 2c 20 62 " a-waitons ", b
121c0 2d 77 61 69 74 6f 6e 73 3d 22 20 62 2d 77 61 69 -waitons=" b-wai
121d0 74 6f 6e 73 29 0a 09 09 20 20 28 63 6f 6e 64 0a tons)... (cond.
121e0 09 09 20 20 20 3b 3b 20 69 73 20 0a 09 09 20 20 .. ;; is ...
121f0 20 28 28 6d 65 6d 62 65 72 20 61 20 62 2d 77 61 ((member a b-wa
12200 69 74 6f 6e 73 29 20 20 20 20 20 20 20 20 20 20 itons)
12210 3b 3b 20 69 73 20 62 20 77 61 69 74 69 6e 67 20 ;; is b waiting
12220 6f 6e 20 61 3f 0a 09 09 20 20 20 20 3b 3b 20 28 on a?... ;; (
12230 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
12240 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
12250 20 22 63 61 73 65 31 22 29 0a 09 09 20 20 20 20 "case1")...
12260 23 74 29 0a 09 09 20 20 20 28 28 6d 65 6d 62 65 #t)... ((membe
12270 72 20 62 20 61 2d 77 61 69 74 6f 6e 73 29 20 20 r b a-waitons)
12280 20 20 20 20 20 20 20 20 3b 3b 20 69 73 20 61 20 ;; is a
12290 77 61 69 74 69 6e 67 20 6f 6e 20 62 3f 0a 09 09 waiting on b?...
122a0 20 20 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 ;; (debug:pr
122b0 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
122c0 6f 67 2d 70 6f 72 74 2a 20 22 63 61 73 65 32 22 og-port* "case2"
122d0 29 0a 09 09 20 20 20 20 23 66 29 0a 09 09 20 20 )... #f)...
122e0 20 28 28 61 6e 64 20 28 6e 6f 74 20 28 6e 75 6c ((and (not (nul
122f0 6c 3f 20 61 2d 77 61 69 74 6f 6e 73 29 29 20 20 l? a-waitons))
12300 3b 3b 20 62 6f 74 68 20 68 61 76 65 20 77 61 69 ;; both have wai
12310 74 6f 6e 73 20 2d 20 64 6f 20 6e 6f 74 20 64 69 tons - do not di
12320 73 74 75 72 62 0a 09 09 09 20 28 6e 6f 74 20 28 sturb.... (not (
12330 6e 75 6c 6c 3f 20 62 2d 77 61 69 74 6f 6e 73 29 null? b-waitons)
12340 29 29 0a 09 09 20 20 20 20 3b 3b 20 28 64 65 62 ))... ;; (deb
12350 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
12360 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 63 ult-log-port* "c
12370 61 73 65 32 2e 31 22 29 0a 09 09 20 20 20 20 23 ase2.1")... #
12380 74 29 0a 09 09 20 20 20 28 28 61 6e 64 20 28 6e t)... ((and (n
12390 75 6c 6c 3f 20 61 2d 77 61 69 74 6f 6e 73 29 20 ull? a-waitons)
123a0 20 20 20 20 20 20 20 3b 3b 20 6e 6f 20 77 61 69 ;; no wai
123b0 74 6f 6e 73 20 66 6f 72 20 61 20 62 75 74 20 62 tons for a but b
123c0 20 68 61 73 20 77 61 69 74 6f 6e 73 0a 09 09 09 has waitons....
123d0 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 62 2d 77 (not (null? b-w
123e0 61 69 74 6f 6e 73 29 29 29 0a 09 09 20 20 20 20 aitons)))...
123f0 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 ;; (debug:print
12400 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
12410 6f 72 74 2a 20 22 63 61 73 65 33 22 29 0a 09 09 ort* "case3")...
12420 20 20 20 20 23 66 29 0a 09 09 20 20 20 28 28 61 #f)... ((a
12430 6e 64 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 61 nd (not (null? a
12440 2d 77 61 69 74 6f 6e 73 29 29 20 20 3b 3b 20 61 -waitons)) ;; a
12450 20 68 61 73 20 77 61 69 74 6f 6e 73 20 62 75 74 has waitons but
12460 20 62 20 64 6f 65 73 20 6e 6f 74 0a 09 09 09 20 b does not....
12470 28 6e 75 6c 6c 3f 20 62 2d 77 61 69 74 6f 6e 73 (null? b-waitons
12480 29 29 20 0a 09 09 20 20 20 20 3b 3b 20 28 64 65 )) ... ;; (de
12490 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
124a0 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
124b0 63 61 73 65 34 22 29 0a 09 09 20 20 20 20 23 74 case4")... #t
124c0 29 0a 09 09 20 20 20 28 28 6e 6f 74 20 28 65 71 )... ((not (eq
124d0 3f 20 61 2d 70 72 69 6f 72 69 74 79 20 62 2d 70 ? a-priority b-p
124e0 72 69 6f 72 69 74 79 29 29 20 3b 3b 20 75 73 65 riority)) ;; use
124f0 0a 09 09 20 20 20 20 28 3e 20 61 2d 70 72 69 6f ... (> a-prio
12500 72 69 74 79 20 62 2d 70 72 69 6f 72 69 74 79 29 rity b-priority)
12510 29 0a 09 09 20 20 20 28 65 6c 73 65 0a 09 09 20 )... (else...
12520 20 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 ;; (debug:pri
12530 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
12540 67 2d 70 6f 72 74 2a 20 22 63 61 73 65 35 22 29 g-port* "case5")
12550 0a 09 09 20 20 20 20 28 73 74 72 69 6e 67 3e 3f ... (string>?
12560 20 61 20 62 29 29 29 29 29 29 0a 09 20 20 20 20 a b))))))..
12570 20 0a 09 20 20 20 20 20 28 73 6f 72 74 2d 66 6e .. (sort-fn
12580 32 0a 09 20 20 20 20 20 20 28 6c 61 6d 62 64 61 2.. (lambda
12590 20 28 61 20 62 29 0a 09 09 28 3e 20 28 6d 75 6e (a b)...(> (mun
125a0 67 65 70 72 69 6f 72 69 74 79 20 28 74 65 73 74 gepriority (test
125b0 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d s:testqueue-get-
125c0 70 72 69 6f 72 69 74 79 20 28 68 61 73 68 2d 74 priority (hash-t
125d0 61 62 6c 65 2d 72 65 66 20 74 65 73 74 2d 72 65 able-ref test-re
125e0 63 6f 72 64 73 20 61 29 29 29 0a 09 09 20 20 20 cords a)))...
125f0 28 6d 75 6e 67 65 70 72 69 6f 72 69 74 79 20 28 (mungepriority (
12600 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d tests:testqueue-
12610 67 65 74 2d 70 72 69 6f 72 69 74 79 20 28 68 61 get-priority (ha
12620 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 74 65 73 sh-table-ref tes
12630 74 2d 72 65 63 6f 72 64 73 20 62 29 29 29 29 29 t-records b)))))
12640 29 29 0a 09 3b 3b 20 28 6c 65 74 20 28 28 64 6f ))..;; (let ((do
12650 74 2d 72 65 73 20 28 74 65 73 74 73 3a 72 75 6e t-res (tests:run
12660 2d 64 6f 74 20 28 74 65 73 74 73 3a 74 65 73 74 -dot (tests:test
12670 73 2d 3e 64 6f 74 20 74 65 73 74 2d 72 65 63 6f s->dot test-reco
12680 72 64 73 29 20 22 70 6c 61 69 6e 22 29 29 29 0a rds) "plain"))).
12690 09 3b 3b 20 20 20 28 64 65 62 75 67 3a 70 72 69 .;; (debug:pri
126a0 6e 74 20 22 64 6f 74 2d 72 65 73 3d 22 20 64 6f nt "dot-res=" do
126b0 74 2d 72 65 73 29 29 0a 09 3b 3b 20 28 6c 65 74 t-res))..;; (let
126c0 20 28 28 64 61 74 61 20 28 6d 61 70 20 63 64 72 ((data (map cdr
126d0 20 28 66 69 6c 74 65 72 0a 09 3b 3b 20 20 20 20 (filter..;;
126e0 20 09 09 20 20 28 6c 61 6d 62 64 61 20 28 78 29 .. (lambda (x)
126f0 28 65 71 75 61 6c 3f 20 22 6e 6f 64 65 22 20 28 (equal? "node" (
12700 63 61 72 20 78 29 29 29 0a 09 3b 3b 20 20 20 20 car x)))..;;
12710 20 09 09 20 20 28 6d 61 70 20 73 74 72 69 6e 67 .. (map string
12720 2d 73 70 6c 69 74 20 28 74 65 73 74 73 3a 65 61 -split (tests:ea
12730 73 79 2d 64 6f 74 20 74 65 73 74 2d 72 65 63 6f sy-dot test-reco
12740 72 64 73 20 22 70 6c 61 69 6e 22 29 29 29 29 29 rds "plain")))))
12750 29 0a 09 3b 3b 20 20 20 28 6d 61 70 20 63 61 72 )..;; (map car
12760 20 28 73 6f 72 74 20 64 61 74 61 20 28 6c 61 6d (sort data (lam
12770 62 64 61 20 28 61 20 62 29 0a 09 3b 3b 20 20 20 bda (a b)..;;
12780 20 20 09 09 20 20 20 20 28 3e 20 28 73 74 72 69 .. (> (stri
12790 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 63 61 64 64 ng->number (cadd
127a0 72 20 61 29 29 28 73 74 72 69 6e 67 2d 3e 6e 75 r a))(string->nu
127b0 6d 62 65 72 20 28 63 61 64 64 72 20 62 29 29 29 mber (caddr b)))
127c0 29 29 29 29 0a 09 3b 3b 20 29 29 0a 09 28 73 6f ))))..;; ))..(so
127d0 72 74 20 61 6c 6c 2d 74 65 73 74 73 20 73 6f 72 rt all-tests sor
127e0 74 2d 66 6e 31 29 29 29 29 20 3b 3b 20 61 76 6f t-fn1)))) ;; avo
127f0 69 64 20 64 65 61 6c 69 6e 67 20 77 69 74 68 20 id dealing with
12800 64 65 6c 65 74 65 64 20 74 65 73 74 73 2c 20 6c deleted tests, l
12810 6f 6f 6b 20 61 74 20 74 68 65 20 68 61 73 68 20 ook at the hash
12820 74 61 62 6c 65 0a 0a 3b 3b 20 6c 6f 6f 6b 20 75 table..;; look u
12830 70 20 61 6c 6c 20 77 61 69 74 6f 6e 73 20 74 68 p all waitons th
12840 61 74 20 61 72 65 20 72 65 6c 61 74 65 64 20 74 at are related t
12850 6f 20 74 65 73 74 20 22 74 65 73 74 6e 61 6d 65 o test "testname
12860 22 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 65 ".;;.(define (te
12870 73 74 73 3a 67 65 74 2d 6d 74 2d 77 61 69 74 6f sts:get-mt-waito
12880 6e 73 20 74 65 73 74 6e 61 6d 65 20 66 6c 61 74 ns testname flat
12890 74 65 6e 29 0a 20 20 28 6c 65 74 2a 20 28 28 6d ten). (let* ((m
128a0 74 2d 77 61 69 74 6f 6e 73 20 20 20 20 28 63 6f t-waitons (co
128b0 6e 66 69 67 66 3a 67 65 74 2d 73 65 63 74 69 6f nfigf:get-sectio
128c0 6e 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 77 n *configdat* "w
128d0 61 69 74 6f 6e 73 22 29 29 0a 09 20 28 6d 79 2d aitons")).. (my-
128e0 77 61 69 74 6f 6e 73 20 20 20 20 28 66 69 6c 74 waitons (filt
128f0 65 72 0a 09 09 09 20 28 6c 61 6d 62 64 61 20 28 er.... (lambda (
12900 78 29 0a 09 09 09 20 20 20 28 73 74 72 69 6e 67 x).... (string
12910 2d 6d 61 74 63 68 20 28 63 6f 6e 63 20 22 5e 28 -match (conc "^(
12920 22 20 74 65 73 74 6e 61 6d 65 20 22 7c 22 20 74 " testname "|" t
12930 65 73 74 6e 61 6d 65 22 2f 2e 2a 29 24 22 29 20 estname"/.*)$")
12940 28 63 61 72 20 78 29 29 29 0a 09 09 09 20 6d 74 (car x))).... mt
12950 2d 77 61 69 74 6f 6e 73 29 29 29 0a 20 20 20 20 -waitons))).
12960 28 69 66 20 66 6c 61 74 74 65 6e 0a 09 28 6d 61 (if flatten..(ma
12970 70 20 28 6c 61 6d 62 64 61 20 28 77 29 0a 09 20 p (lambda (w)..
12980 20 20 20 20 20 20 28 63 61 72 20 28 73 74 72 69 (car (stri
12990 6e 67 2d 73 70 6c 69 74 20 77 20 22 2f 22 29 29 ng-split w "/"))
129a0 29 0a 09 20 20 20 20 20 28 61 70 70 6c 79 20 61 ).. (apply a
129b0 70 70 65 6e 64 20 28 6d 61 70 20 28 6c 61 6d 62 ppend (map (lamb
129c0 64 61 20 28 78 29 0a 09 09 09 09 20 20 28 73 74 da (x)..... (st
129d0 72 69 6e 67 2d 73 70 6c 69 74 20 28 63 61 64 72 ring-split (cadr
129e0 20 78 29 29 29 0a 09 09 09 09 6d 79 2d 77 61 69 x))).....my-wai
129f0 74 6f 6e 73 29 29 29 0a 09 6d 79 2d 77 61 69 74 tons)))..my-wait
12a00 6f 6e 73 29 29 29 0a 0a 3b 3b 20 4e 4f 54 20 55 ons)))..;; NOT U
12a10 53 45 44 0a 28 64 65 66 69 6e 65 20 28 74 65 73 SED.(define (tes
12a20 74 73 3a 65 61 73 79 2d 64 6f 74 20 74 65 73 74 ts:easy-dot test
12a30 2d 72 65 63 6f 72 64 73 20 6f 75 74 74 79 70 65 -records outtype
12a40 29 0a 20 20 28 6c 65 74 2d 76 61 6c 75 65 73 20 ). (let-values
12a50 28 28 28 66 64 20 74 65 6d 70 2d 70 61 74 68 29 (((fd temp-path)
12a60 20 28 66 69 6c 65 2d 6d 6b 73 74 65 6d 70 20 28 (file-mkstemp (
12a70 63 6f 6e 63 20 22 2f 74 6d 70 2f 22 20 28 63 75 conc "/tmp/" (cu
12a80 72 72 65 6e 74 2d 75 73 65 72 2d 6e 61 6d 65 29 rrent-user-name)
12a90 20 22 2e 58 58 58 58 58 58 22 29 29 29 29 0a 20 ".XXXXXX")))).
12aa0 20 20 20 28 6c 65 74 20 28 28 61 6c 6c 2d 74 65 (let ((all-te
12ab0 73 74 6e 61 6d 65 73 20 28 68 61 73 68 2d 74 61 stnames (hash-ta
12ac0 62 6c 65 2d 6b 65 79 73 20 74 65 73 74 2d 72 65 ble-keys test-re
12ad0 63 6f 72 64 73 29 29 0a 09 20 20 28 74 65 6d 70 cords)).. (temp
12ae0 2d 70 6f 72 74 20 20 20 20 20 28 6f 70 65 6e 2d -port (open-
12af0 6f 75 74 70 75 74 2d 66 69 6c 65 2a 20 66 64 29 output-file* fd)
12b00 29 29 0a 20 20 20 20 20 20 3b 3b 20 28 66 6f 72 )). ;; (for
12b10 6d 61 74 20 74 65 6d 70 2d 70 6f 72 74 20 22 54 mat temp-port "T
12b20 68 69 73 20 66 69 6c 65 20 69 73 20 7e 41 2e 7e his file is ~A.~
12b30 25 22 20 74 65 6d 70 2d 70 61 74 68 29 0a 20 20 %" temp-path).
12b40 20 20 20 20 28 66 6f 72 6d 61 74 20 74 65 6d 70 (format temp
12b50 2d 70 6f 72 74 20 22 64 69 67 72 61 70 68 20 74 -port "digraph t
12b60 65 73 74 73 20 7b 5c 6e 22 29 0a 20 20 20 20 20 ests {\n").
12b70 20 28 66 6f 72 6d 61 74 20 74 65 6d 70 2d 70 6f (format temp-po
12b80 72 74 20 22 20 20 73 69 7a 65 3d 34 2c 38 5c 6e rt " size=4,8\n
12b90 22 29 0a 20 20 20 20 20 20 3b 3b 20 28 66 6f 72 "). ;; (for
12ba0 6d 61 74 20 74 65 6d 70 2d 70 6f 72 74 20 22 20 mat temp-port "
12bb0 20 20 73 70 6c 69 6e 65 73 3d 6e 6f 6e 65 5c 6e splines=none\n
12bc0 22 29 0a 20 20 20 20 20 20 28 66 6f 72 2d 65 61 "). (for-ea
12bd0 63 68 0a 20 20 20 20 20 20 20 28 6c 61 6d 62 64 ch. (lambd
12be0 61 20 28 74 65 73 74 6e 61 6d 65 29 0a 09 20 28 a (testname).. (
12bf0 6c 65 74 2a 20 28 28 74 65 73 74 72 65 63 20 28 let* ((testrec (
12c00 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 74 hash-table-ref t
12c10 65 73 74 2d 72 65 63 6f 72 64 73 20 74 65 73 74 est-records test
12c20 6e 61 6d 65 29 29 0a 09 09 28 77 61 69 74 6f 6e name))...(waiton
12c30 73 20 28 6f 72 20 28 74 65 73 74 73 3a 74 65 73 s (or (tests:tes
12c40 74 71 75 65 75 65 2d 67 65 74 2d 77 61 69 74 6f tqueue-get-waito
12c50 6e 73 20 74 65 73 74 72 65 63 29 20 27 28 29 29 ns testrec) '())
12c60 29 0a 09 09 28 6d 79 2d 6d 74 2d 77 61 69 74 6f )...(my-mt-waito
12c70 6e 73 20 28 74 65 73 74 73 3a 67 65 74 2d 6d 74 ns (tests:get-mt
12c80 2d 77 61 69 74 6f 6e 73 20 74 65 73 74 6e 61 6d -waitons testnam
12c90 65 20 23 74 29 29 29 0a 09 20 20 20 3b 3b 20 28 e #t))).. ;; (
12ca0 70 72 69 6e 74 20 22 6d 79 2d 6d 74 2d 77 61 69 print "my-mt-wai
12cb0 74 6f 6e 73 3d 22 20 6d 79 2d 6d 74 2d 77 61 69 tons=" my-mt-wai
12cc0 74 6f 6e 73 29 0a 09 20 20 20 28 66 6f 72 2d 65 tons).. (for-e
12cd0 61 63 68 0a 09 20 20 20 20 28 6c 61 6d 62 64 61 ach.. (lambda
12ce0 20 28 77 61 69 74 6f 6e 29 0a 09 20 20 20 20 20 (waiton)..
12cf0 20 28 66 6f 72 6d 61 74 20 74 65 6d 70 2d 70 6f (format temp-po
12d00 72 74 20 28 63 6f 6e 63 20 22 20 20 20 22 20 77 rt (conc " " w
12d10 61 69 74 6f 6e 20 22 20 2d 3e 20 22 20 74 65 73 aiton " -> " tes
12d20 74 6e 61 6d 65 20 22 20 5b 73 70 6c 69 6e 65 73 tname " [splines
12d30 3d 6f 72 74 68 6f 5d 5c 6e 22 29 29 29 0a 09 20 =ortho]\n")))..
12d40 20 20 20 28 61 70 70 65 6e 64 20 77 61 69 74 6f (append waito
12d50 6e 73 20 6d 79 2d 6d 74 2d 77 61 69 74 6f 6e 73 ns my-mt-waitons
12d60 29 29 29 29 0a 20 20 20 20 20 20 20 61 6c 6c 2d )))). all-
12d70 74 65 73 74 6e 61 6d 65 73 29 0a 20 20 20 20 20 testnames).
12d80 20 28 66 6f 72 6d 61 74 20 74 65 6d 70 2d 70 6f (format temp-po
12d90 72 74 20 22 7d 5c 6e 22 29 0a 20 20 20 20 20 20 rt "}\n").
12da0 28 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d 70 6f (close-output-po
12db0 72 74 20 74 65 6d 70 2d 70 6f 72 74 29 0a 20 20 rt temp-port).
12dc0 20 20 20 20 28 77 69 74 68 2d 69 6e 70 75 74 2d (with-input-
12dd0 66 72 6f 6d 2d 70 69 70 65 0a 20 20 20 20 20 20 from-pipe.
12de0 20 28 63 6f 6e 63 20 22 65 6e 76 20 2d 69 20 50 (conc "env -i P
12df0 41 54 48 3d 24 50 41 54 48 20 64 6f 74 20 2d 54 ATH=$PATH dot -T
12e00 22 20 6f 75 74 74 79 70 65 20 22 20 3c 20 22 20 " outtype " < "
12e10 74 65 6d 70 2d 70 61 74 68 29 0a 20 20 20 20 20 temp-path).
12e20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 20 28 (lambda ().. (
12e30 6c 65 74 20 28 28 72 65 73 20 28 72 65 61 64 2d let ((res (read-
12e40 6c 69 6e 65 73 29 29 29 0a 09 20 20 20 3b 3b 20 lines))).. ;;
12e50 28 64 65 6c 65 74 65 2d 66 69 6c 65 20 74 65 6d (delete-file tem
12e60 70 2d 70 61 74 68 29 0a 09 20 20 20 72 65 73 29 p-path).. res)
12e70 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 )))))..(define (
12e80 74 65 73 74 73 3a 77 72 69 74 65 2d 64 6f 74 2d tests:write-dot-
12e90 66 69 6c 65 20 74 65 73 74 2d 72 65 63 6f 72 64 file test-record
12ea0 73 20 66 6e 61 6d 65 20 73 69 7a 65 78 20 73 69 s fname sizex si
12eb0 7a 65 79 29 0a 20 20 28 69 66 20 28 66 69 6c 65 zey). (if (file
12ec0 2d 77 72 69 74 65 2d 61 63 63 65 73 73 3f 20 28 -write-access? (
12ed0 70 61 74 68 6e 61 6d 65 2d 64 69 72 65 63 74 6f pathname-directo
12ee0 72 79 20 66 6e 61 6d 65 29 29 0a 20 20 20 20 20 ry fname)).
12ef0 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f (with-output-to
12f00 2d 66 69 6c 65 20 66 6e 61 6d 65 0a 09 28 6c 61 -file fname..(la
12f10 6d 62 64 61 20 28 29 0a 09 20 20 28 6d 61 70 20 mbda ().. (map
12f20 70 72 69 6e 74 20 28 74 65 73 74 73 3a 74 65 73 print (tests:tes
12f30 74 73 2d 3e 64 6f 74 20 74 65 73 74 2d 72 65 63 ts->dot test-rec
12f40 6f 72 64 73 20 73 69 7a 65 78 20 73 69 7a 65 79 ords sizex sizey
12f50 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ))))))..(define
12f60 28 74 65 73 74 73 3a 74 65 73 74 73 2d 3e 64 6f (tests:tests->do
12f70 74 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 73 t test-records s
12f80 69 7a 65 78 20 73 69 7a 65 79 29 0a 20 20 28 6c izex sizey). (l
12f90 65 74 20 28 28 61 6c 6c 2d 74 65 73 74 6e 61 6d et ((all-testnam
12fa0 65 73 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b es (hash-table-k
12fb0 65 79 73 20 74 65 73 74 2d 72 65 63 6f 72 64 73 eys test-records
12fc0 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 75 6c ))). (if (nul
12fd0 6c 3f 20 61 6c 6c 2d 74 65 73 74 6e 61 6d 65 73 l? all-testnames
12fe0 29 0a 09 27 28 29 0a 09 28 6c 65 74 20 6c 6f 6f )..'()..(let loo
12ff0 70 20 28 28 68 65 64 20 28 63 61 72 20 61 6c 6c p ((hed (car all
13000 2d 74 65 73 74 6e 61 6d 65 73 29 29 0a 09 09 20 -testnames))...
13010 20 20 28 74 61 6c 20 28 63 64 72 20 61 6c 6c 2d (tal (cdr all-
13020 74 65 73 74 6e 61 6d 65 73 29 29 0a 09 09 20 20 testnames))...
13030 20 28 72 65 73 20 28 6c 69 73 74 20 22 64 69 67 (res (list "dig
13040 72 61 70 68 20 74 65 73 74 73 20 7b 22 0a 09 09 raph tests {"...
13050 09 20 20 20 20 20 20 28 63 6f 6e 63 20 22 20 73 . (conc " s
13060 69 7a 65 3d 5c 22 22 20 28 6f 72 20 73 69 7a 65 ize=\"" (or size
13070 78 20 31 31 29 20 22 2c 22 20 28 6f 72 20 73 69 x 11) "," (or si
13080 7a 65 79 20 31 31 29 20 22 5c 22 3b 22 29 0a 09 zey 11) "\";")..
13090 09 09 20 20 20 20 20 20 22 20 72 61 74 69 6f 3d .. " ratio=
130a0 30 2e 39 35 3b 22 0a 09 09 09 20 20 20 20 20 20 0.95;"....
130b0 29 29 29 0a 09 20 20 28 6c 65 74 2a 20 28 28 74 ))).. (let* ((t
130c0 65 73 74 72 65 63 20 28 68 61 73 68 2d 74 61 62 estrec (hash-tab
130d0 6c 65 2d 72 65 66 20 74 65 73 74 2d 72 65 63 6f le-ref test-reco
130e0 72 64 73 20 68 65 64 29 29 0a 09 09 20 28 77 61 rds hed))... (wa
130f0 69 74 6f 6e 73 20 28 6f 72 20 28 74 65 73 74 73 itons (or (tests
13100 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 77 :testqueue-get-w
13110 61 69 74 6f 6e 73 20 74 65 73 74 72 65 63 29 20 aitons testrec)
13120 27 28 29 29 29 0a 09 09 20 28 6d 79 2d 6d 74 2d '()))... (my-mt-
13130 77 61 69 74 6f 6e 73 20 28 74 65 73 74 73 3a 67 waitons (tests:g
13140 65 74 2d 6d 74 2d 77 61 69 74 6f 6e 73 20 68 65 et-mt-waitons he
13150 64 20 23 74 29 29 0a 09 09 20 28 61 6c 6c 2d 77 d #t))... (all-w
13160 61 69 74 6f 6e 73 20 20 20 28 64 65 6c 65 74 65 aitons (delete
13170 2d 64 75 70 6c 69 63 61 74 65 73 20 28 61 70 70 -duplicates (app
13180 65 6e 64 20 77 61 69 74 6f 6e 73 20 6d 79 2d 6d end waitons my-m
13190 74 2d 77 61 69 74 6f 6e 73 29 29 29 0a 09 09 20 t-waitons)))...
131a0 28 6e 65 77 72 65 73 20 20 28 61 70 70 65 6e 64 (newres (append
131b0 20 72 65 73 0a 09 09 09 09 20 20 28 69 66 20 28 res..... (if (
131c0 6e 75 6c 6c 3f 20 61 6c 6c 2d 77 61 69 74 6f 6e null? all-waiton
131d0 73 29 0a 09 09 09 09 20 20 20 20 20 20 28 6c 69 s)..... (li
131e0 73 74 20 28 63 6f 6e 63 20 22 20 20 20 5c 22 22 st (conc " \""
131f0 20 68 65 64 20 22 5c 22 20 5b 73 68 61 70 65 3d hed "\" [shape=
13200 62 6f 78 5d 3b 22 29 29 0a 09 09 09 09 20 20 20 box];")).....
13210 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 (map (lambda
13220 28 77 61 69 74 6f 6e 29 0a 09 09 09 09 09 20 20 (waiton)......
13230 20 20 20 28 63 6f 6e 63 20 22 20 20 20 5c 22 22 (conc " \""
13240 20 77 61 69 74 6f 6e 20 22 5c 22 20 2d 3e 20 5c waiton "\" -> \
13250 22 22 20 68 65 64 20 22 5c 22 20 5b 73 68 61 70 "" hed "\" [shap
13260 65 3d 62 6f 78 5d 3b 22 29 29 0a 09 09 09 09 09 e=box];"))......
13270 20 20 20 61 6c 6c 2d 77 61 69 74 6f 6e 73 29 29 all-waitons))
13280 29 29 29 0a 09 20 20 20 20 3b 3b 20 28 64 65 62 ))).. ;; (deb
13290 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
132a0 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 46 ult-log-port* "F
132b0 6f 72 20 74 65 73 74 20 22 68 65 64 22 20 67 6f or test "hed" go
132c0 74 20 22 61 6c 6c 2d 77 61 69 74 6f 6e 73 29 0a t "all-waitons).
132d0 09 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 . (if (null?
132e0 74 61 6c 29 0a 09 09 28 61 70 70 65 6e 64 20 6e tal)...(append n
132f0 65 77 72 65 73 20 28 6c 69 73 74 20 22 7d 22 29 ewres (list "}")
13300 29 0a 09 09 28 6c 6f 6f 70 20 28 63 61 72 20 74 )...(loop (car t
13310 61 6c 29 28 63 64 72 20 74 61 6c 29 20 6e 65 77 al)(cdr tal) new
13320 72 65 73 29 0a 09 09 29 29 29 29 29 29 0a 0a 3b res)...))))))..;
13330 3b 20 28 74 65 73 74 73 3a 72 75 6e 2d 64 6f 74 ; (tests:run-dot
13340 20 28 6c 69 73 74 20 22 64 69 67 72 61 70 68 20 (list "digraph
13350 74 65 73 74 73 20 7b 22 20 22 61 20 2d 3e 20 62 tests {" "a -> b
13360 22 20 22 7d 22 29 20 22 70 6c 61 69 6e 22 29 0a " "}") "plain").
13370 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a .(define (tests:
13380 72 75 6e 2d 64 6f 74 20 69 6e 64 61 74 20 6f 75 run-dot indat ou
13390 74 74 79 70 65 29 20 3b 3b 20 6f 75 74 74 79 70 ttype) ;; outtyp
133a0 65 20 69 73 20 70 6c 61 69 6e 2c 20 66 69 67 2c e is plain, fig,
133b0 20 64 6f 74 2c 20 65 74 63 2e 20 68 74 74 70 3a dot, etc. http:
133c0 2f 2f 77 77 77 2e 67 72 61 70 68 76 69 7a 2e 6f //www.graphviz.o
133d0 72 67 2f 63 6f 6e 74 65 6e 74 2f 6f 75 74 70 75 rg/content/outpu
133e0 74 2d 66 6f 72 6d 61 74 73 0a 20 20 28 6c 65 74 t-formats. (let
133f0 2d 76 61 6c 75 65 73 20 28 28 28 69 6e 70 20 6f -values (((inp o
13400 75 70 20 70 69 64 29 28 70 72 6f 63 65 73 73 20 up pid)(process
13410 22 65 6e 76 20 2d 69 20 50 41 54 48 3d 24 50 41 "env -i PATH=$PA
13420 54 48 20 64 6f 74 22 20 28 6c 69 73 74 20 22 2d TH dot" (list "-
13430 54 22 20 6f 75 74 74 79 70 65 29 29 29 29 0a 20 T" outtype)))).
13440 20 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d (with-output-
13450 74 6f 2d 70 6f 72 74 20 6f 75 70 0a 20 20 20 20 to-port oup.
13460 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 28 6d (lambda ()..(m
13470 61 70 20 70 72 69 6e 74 20 69 6e 64 61 74 29 29 ap print indat))
13480 29 0a 20 20 20 20 28 63 6c 6f 73 65 2d 6f 75 74 ). (close-out
13490 70 75 74 2d 70 6f 72 74 20 6f 75 70 29 0a 20 20 put-port oup).
134a0 20 20 28 6c 65 74 20 28 28 72 65 73 20 28 77 69 (let ((res (wi
134b0 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 6f th-input-from-po
134c0 72 74 20 69 6e 70 0a 09 09 20 28 6c 61 6d 62 64 rt inp... (lambd
134d0 61 20 28 29 0a 09 09 20 20 20 28 72 65 61 64 2d a ()... (read-
134e0 6c 69 6e 65 73 29 29 29 29 29 0a 20 20 20 20 20 lines))))).
134f0 20 28 63 6c 6f 73 65 2d 69 6e 70 75 74 2d 70 6f (close-input-po
13500 72 74 20 69 6e 70 29 0a 20 20 20 20 20 20 72 65 rt inp). re
13510 73 29 29 29 0a 0a 3b 3b 20 72 65 61 64 20 64 61 s)))..;; read da
13520 74 61 20 66 72 6f 6d 20 74 6d 70 20 66 69 6c 65 ta from tmp file
13530 20 6f 72 20 63 72 65 61 74 65 20 69 66 20 6e 6f or create if no
13540 74 20 65 78 69 73 74 73 0a 3b 3b 20 69 66 20 65 t exists.;; if e
13550 78 69 73 74 73 20 72 65 67 65 6e 20 69 6e 20 62 xists regen in b
13560 61 63 6b 67 72 6f 75 6e 64 0a 3b 3b 20 6d 6f 64 ackground.;; mod
13570 65 3a 20 72 61 77 20 28 72 65 74 75 72 6e 20 64 e: raw (return d
13580 61 74 61 20 61 73 20 72 65 61 64 29 20 6f 72 20 ata as read) or
13590 6d 75 6e 67 65 64 20 28 63 6f 6e 76 65 72 74 20 munged (convert
135a0 74 6f 20 6c 69 73 74 20 6f 66 20 6c 69 73 74 73 to list of lists
135b0 20 61 6e 64 20 72 65 6d 6f 76 65 20 22 20 66 72 and remove " fr
135c0 6f 6d 20 73 74 72 69 6e 67 73 29 0a 3b 3b 0a 28 om strings).;;.(
135d0 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 6c 61 define (tests:la
135e0 7a 79 2d 64 6f 74 20 74 65 73 74 72 65 63 6f 72 zy-dot testrecor
135f0 64 73 20 20 6f 75 74 74 79 70 65 20 73 69 7a 65 ds outtype size
13600 78 20 73 69 7a 65 79 20 6d 6f 64 65 29 0a 20 20 x sizey mode).
13610 28 6c 65 74 20 28 28 64 66 69 6c 65 20 28 63 6f (let ((dfile (co
13620 6e 63 20 22 2f 74 6d 70 2f 2e 22 20 28 63 75 72 nc "/tmp/." (cur
13630 72 65 6e 74 2d 75 73 65 72 2d 6e 61 6d 65 29 20 rent-user-name)
13640 22 2d 22 20 28 73 65 72 76 65 72 3a 6d 6b 2d 73 "-" (server:mk-s
13650 69 67 6e 61 74 75 72 65 29 20 22 2e 64 6f 74 22 ignature) ".dot"
13660 29 29 0a 09 28 66 6e 61 6d 65 20 28 63 6f 6e 63 ))..(fname (conc
13670 20 22 2f 74 6d 70 2f 2e 22 20 28 63 75 72 72 65 "/tmp/." (curre
13680 6e 74 2d 75 73 65 72 2d 6e 61 6d 65 29 20 22 2d nt-user-name) "-
13690 22 20 28 73 65 72 76 65 72 3a 6d 6b 2d 73 69 67 " (server:mk-sig
136a0 6e 61 74 75 72 65 29 20 22 2e 64 6f 74 64 61 74 nature) ".dotdat
136b0 22 29 29 29 0a 20 20 20 20 28 74 65 73 74 73 3a "))). (tests:
136c0 77 72 69 74 65 2d 64 6f 74 2d 66 69 6c 65 20 74 write-dot-file t
136d0 65 73 74 72 65 63 6f 72 64 73 20 64 66 69 6c 65 estrecords dfile
136e0 20 73 69 7a 65 78 20 73 69 7a 65 79 29 0a 20 20 sizex sizey).
136f0 20 20 28 6c 65 74 20 28 28 64 61 74 61 20 28 69 (let ((data (i
13700 66 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 f (common:file-e
13710 78 69 73 74 73 3f 20 66 6e 61 6d 65 29 0a 09 09 xists? fname)...
13720 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 20 28 (let ((res (
13730 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d with-input-from-
13740 66 69 6c 65 20 66 6e 61 6d 65 0a 09 09 09 09 20 file fname.....
13750 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 09 20 (lambda ().....
13760 20 20 28 72 65 61 64 2d 6c 69 6e 65 73 29 29 29 (read-lines)))
13770 29 29 0a 09 09 20 20 20 20 20 20 28 73 79 73 74 ))... (syst
13780 65 6d 20 28 63 6f 6e 63 20 22 65 6e 76 20 2d 69 em (conc "env -i
13790 20 50 41 54 48 3d 24 50 41 54 48 20 64 6f 74 20 PATH=$PATH dot
137a0 2d 54 20 22 20 6f 75 74 74 79 70 65 20 22 20 3c -T " outtype " <
137b0 20 22 20 64 66 69 6c 65 20 22 20 3e 20 22 20 66 " dfile " > " f
137c0 6e 61 6d 65 20 22 26 22 29 29 0a 09 09 20 20 20 name "&"))...
137d0 20 20 20 72 65 73 29 0a 09 09 20 20 20 20 28 62 res)... (b
137e0 65 67 69 6e 0a 09 09 20 20 20 20 20 20 28 73 79 egin... (sy
137f0 73 74 65 6d 20 28 63 6f 6e 63 20 22 65 6e 76 20 stem (conc "env
13800 2d 69 20 50 41 54 48 3d 24 50 41 54 48 20 64 6f -i PATH=$PATH do
13810 74 20 2d 54 20 22 20 6f 75 74 74 79 70 65 20 22 t -T " outtype "
13820 20 3c 20 22 20 64 66 69 6c 65 20 22 20 3e 20 22 < " dfile " > "
13830 20 66 6e 61 6d 65 29 29 0a 09 09 20 20 20 20 20 fname))...
13840 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f (with-input-fro
13850 6d 2d 66 69 6c 65 20 66 6e 61 6d 65 0a 09 09 09 m-file fname....
13860 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 20 20 (lambda ()....
13870 28 72 65 61 64 2d 6c 69 6e 65 73 29 29 29 29 29 (read-lines)))))
13880 29 29 0a 20 20 20 20 20 20 28 69 66 20 28 65 71 )). (if (eq
13890 3f 20 6d 6f 64 65 20 27 72 61 77 29 0a 09 20 20 ? mode 'raw)..
138a0 64 61 74 61 0a 09 20 20 28 6d 61 70 20 28 6c 61 data.. (map (la
138b0 6d 62 64 61 20 28 69 6e 6c 29 0a 09 09 20 28 6d mbda (inl)... (m
138c0 61 70 20 28 6c 61 6d 62 64 61 20 28 73 29 0a 09 ap (lambda (s)..
138d0 09 09 28 73 74 72 69 6e 67 2d 73 75 62 73 74 69 ..(string-substi
138e0 74 75 74 65 20 22 5c 22 22 20 22 22 20 73 20 23 tute "\"" "" s #
138f0 74 29 29 0a 09 09 20 20 20 20 20 20 28 73 74 72 t))... (str
13900 69 6e 67 2d 73 70 6c 69 74 20 69 6e 6c 29 29 29 ing-split inl)))
13910 0a 09 20 20 20 20 20 20 20 64 61 74 61 29 29 29 .. data)))
13920 29 29 0a 0a 3b 3b 20 66 6f 72 20 65 61 63 68 20 ))..;; for each
13930 74 65 73 74 3a 0a 3b 3b 20 20 20 0a 28 64 65 66 test:.;; .(def
13940 69 6e 65 20 28 74 65 73 74 73 3a 66 69 6c 74 65 ine (tests:filte
13950 72 2d 6e 6f 6e 2d 72 75 6e 6e 61 62 6c 65 20 72 r-non-runnable r
13960 75 6e 2d 69 64 20 74 65 73 74 6b 65 79 6e 61 6d un-id testkeynam
13970 65 73 20 74 65 73 74 72 65 63 6f 72 64 73 68 61 es testrecordsha
13980 73 68 29 0a 20 20 28 6c 65 74 20 28 28 72 75 6e sh). (let ((run
13990 6e 61 62 6c 65 73 20 27 28 29 29 29 0a 20 20 20 nables '())).
139a0 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 (for-each.
139b0 28 6c 61 6d 62 64 61 20 28 74 65 73 74 6b 65 79 (lambda (testkey
139c0 6e 61 6d 65 29 0a 20 20 20 20 20 20 20 28 6c 65 name). (le
139d0 74 2a 20 28 28 74 65 73 74 2d 72 65 63 6f 72 64 t* ((test-record
139e0 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
139f0 20 74 65 73 74 72 65 63 6f 72 64 73 68 61 73 68 testrecordshash
13a00 20 74 65 73 74 6b 65 79 6e 61 6d 65 29 29 0a 09 testkeyname))..
13a10 20 20 20 20 20 20 28 74 65 73 74 2d 6e 61 6d 65 (test-name
13a20 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 (tests:testqu
13a30 65 75 65 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 eue-get-testname
13a40 20 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a test-record)).
13a50 09 20 20 20 20 20 20 28 69 74 65 6d 64 61 74 20 . (itemdat
13a60 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 (tests:testq
13a70 75 65 75 65 2d 67 65 74 2d 69 74 65 6d 64 61 74 ueue-get-itemdat
13a80 20 20 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 test-record))
13a90 0a 09 20 20 20 20 20 20 28 69 74 65 6d 2d 70 61 .. (item-pa
13aa0 74 68 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 th (tests:test
13ab0 71 75 65 75 65 2d 67 65 74 2d 69 74 65 6d 5f 70 queue-get-item_p
13ac0 61 74 68 20 74 65 73 74 2d 72 65 63 6f 72 64 29 ath test-record)
13ad0 29 0a 09 20 20 20 20 20 20 28 77 61 69 74 6f 6e ).. (waiton
13ae0 73 20 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 s (tests:tes
13af0 74 71 75 65 75 65 2d 67 65 74 2d 77 61 69 74 6f tqueue-get-waito
13b00 6e 73 20 20 20 74 65 73 74 2d 72 65 63 6f 72 64 ns test-record
13b10 29 29 0a 09 20 20 20 20 20 20 28 6b 65 65 70 2d )).. (keep-
13b20 74 65 73 74 20 20 20 23 74 29 0a 09 20 20 20 20 test #t)..
13b30 20 20 28 74 65 73 74 2d 69 64 20 20 20 20 20 28 (test-id (
13b40 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 64 20 rmt:get-test-id
13b50 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
13b60 20 69 74 65 6d 2d 70 61 74 68 29 29 0a 09 20 20 item-path))..
13b70 20 20 20 20 28 74 64 61 74 20 20 20 20 20 20 20 (tdat
13b80 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 69 6e (rmt:get-testin
13b90 66 6f 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 fo-state-status
13ba0 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 29 run-id test-id))
13bb0 29 20 3b 3b 20 28 63 64 62 3a 67 65 74 2d 74 65 ) ;; (cdb:get-te
13bc0 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 2a 72 st-info-by-id *r
13bd0 75 6e 72 65 6d 6f 74 65 2a 20 74 65 73 74 2d 69 unremote* test-i
13be0 64 29 29 29 0a 09 20 28 69 66 20 74 64 61 74 0a d))).. (if tdat.
13bf0 09 20 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 . (begin..
13c00 20 20 20 20 20 3b 3b 20 4c 6f 6f 6b 20 61 74 20 ;; Look at
13c10 74 68 65 20 74 65 73 74 20 73 74 61 74 65 20 61 the test state a
13c20 6e 64 20 73 74 61 74 75 73 0a 09 20 20 20 20 20 nd status..
13c30 20 20 28 69 66 20 28 6f 72 20 28 61 6e 64 20 28 (if (or (and (
13c40 6d 65 6d 62 65 72 20 28 64 62 3a 74 65 73 74 2d member (db:test-
13c50 67 65 74 2d 73 74 61 74 75 73 20 74 64 61 74 29 get-status tdat)
13c60 20 0a 09 09 09 09 20 20 20 20 27 28 22 50 41 53 ..... '("PAS
13c70 53 22 20 22 57 41 52 4e 22 20 22 57 41 49 56 45 S" "WARN" "WAIVE
13c80 44 22 20 22 43 48 45 43 4b 22 20 22 53 4b 49 50 D" "CHECK" "SKIP
13c90 22 29 29 0a 09 09 09 20 20 20 20 28 65 71 75 61 ")).... (equa
13ca0 6c 3f 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d l? (db:test-get-
13cb0 73 74 61 74 65 20 74 64 61 74 29 20 22 43 4f 4d state tdat) "COM
13cc0 50 4c 45 54 45 44 22 29 29 0a 09 09 20 20 20 20 PLETED"))...
13cd0 20 20 20 28 6d 65 6d 62 65 72 20 28 64 62 3a 74 (member (db:t
13ce0 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 74 64 est-get-state td
13cf0 61 74 29 0a 09 09 09 09 20 20 20 20 27 28 22 49 at)..... '("I
13d00 4e 43 4f 4d 50 4c 45 54 45 22 20 22 4b 49 4c 4c NCOMPLETE" "KILL
13d10 45 44 22 29 29 29 0a 09 09 20 20 20 28 73 65 74 ED")))... (set
13d20 21 20 6b 65 65 70 2d 74 65 73 74 20 23 66 29 29 ! keep-test #f))
13d30 0a 0a 09 20 20 20 20 20 20 20 3b 3b 20 65 78 61 ... ;; exa
13d40 6d 69 6e 65 20 77 61 69 74 6f 6e 73 20 66 6f 72 mine waitons for
13d50 20 61 6e 79 20 66 61 69 6c 73 2e 20 49 66 20 69 any fails. If i
13d60 74 20 69 73 20 46 41 49 4c 20 6f 72 20 49 4e 43 t is FAIL or INC
13d70 4f 4d 50 4c 45 54 45 20 74 68 65 6e 20 65 6c 69 OMPLETE then eli
13d80 6d 69 6e 61 74 65 20 74 68 69 73 20 74 65 73 74 minate this test
13d90 0a 09 20 20 20 20 20 20 20 3b 3b 20 66 72 6f 6d .. ;; from
13da0 20 74 68 65 20 72 75 6e 6e 61 62 6c 65 20 6c 69 the runnable li
13db0 73 74 0a 09 20 20 20 20 20 20 20 28 69 66 20 6b st.. (if k
13dc0 65 65 70 2d 74 65 73 74 0a 09 09 20 20 20 28 66 eep-test... (f
13dd0 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 or-each (lambda
13de0 28 77 61 69 74 6f 6e 29 0a 09 09 09 20 20 20 20 (waiton)....
13df0 20 20 20 3b 3b 20 66 6f 72 20 6e 6f 77 20 77 65 ;; for now we
13e00 20 61 72 65 20 77 61 69 74 69 6e 67 20 6f 6e 6c are waiting onl
13e10 79 20 6f 6e 20 74 68 65 20 70 61 72 65 6e 74 20 y on the parent
13e20 74 65 73 74 0a 09 09 09 20 20 20 20 20 20 20 28 test.... (
13e30 6c 65 74 2a 20 28 28 70 61 72 65 6e 74 2d 74 65 let* ((parent-te
13e40 73 74 2d 69 64 20 28 72 6d 74 3a 67 65 74 2d 74 st-id (rmt:get-t
13e50 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 77 61 est-id run-id wa
13e60 69 74 6f 6e 20 22 22 29 29 0a 09 09 09 09 20 20 iton "")).....
13e70 20 20 20 20 28 77 74 64 61 74 20 20 20 20 20 20 (wtdat
13e80 20 20 20 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 (rmt:get-tes
13e90 74 69 6e 66 6f 2d 73 74 61 74 65 2d 73 74 61 74 tinfo-state-stat
13ea0 75 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 us run-id test-i
13eb0 64 29 29 29 20 3b 3b 20 28 63 64 62 3a 67 65 74 d))) ;; (cdb:get
13ec0 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 -test-info-by-id
13ed0 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 74 65 73 *runremote* tes
13ee0 74 2d 69 64 29 29 29 0a 09 09 09 09 20 28 69 66 t-id)))..... (if
13ef0 20 28 6f 72 20 28 61 6e 64 20 28 65 71 75 61 6c (or (and (equal
13f00 3f 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 ? (db:test-get-s
13f10 74 61 74 65 20 77 74 64 61 74 29 20 22 43 4f 4d tate wtdat) "COM
13f20 50 4c 45 54 45 44 22 29 0a 09 09 09 09 09 20 20 PLETED")......
13f30 20 20 20 20 28 6d 65 6d 62 65 72 20 28 64 62 3a (member (db:
13f40 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 73 20 test-get-status
13f50 77 74 64 61 74 29 20 27 28 22 46 41 49 4c 22 20 wtdat) '("FAIL"
13f60 22 41 42 4f 52 54 22 29 29 29 0a 09 09 09 09 09 "ABORT")))......
13f70 20 28 6d 65 6d 62 65 72 20 28 64 62 3a 74 65 73 (member (db:tes
13f80 74 2d 67 65 74 2d 73 74 61 74 75 73 20 77 74 64 t-get-status wtd
13f90 61 74 29 20 20 27 28 22 4b 49 4c 4c 45 44 22 29 at) '("KILLED")
13fa0 29 0a 09 09 09 09 09 20 28 6d 65 6d 62 65 72 20 )...... (member
13fb0 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 (db:test-get-sta
13fc0 74 65 20 77 74 64 61 74 29 20 20 20 27 28 22 49 te wtdat) '("I
13fd0 4e 43 4f 4d 50 45 54 45 22 29 29 29 0a 09 09 09 NCOMPETE")))....
13fe0 09 20 3b 3b 20 28 69 66 20 28 6f 72 20 28 6d 65 . ;; (if (or (me
13ff0 6d 62 65 72 20 28 64 62 3a 74 65 73 74 2d 67 65 mber (db:test-ge
14000 74 2d 73 74 61 74 75 73 20 77 74 64 61 74 29 0a t-status wtdat).
14010 09 09 09 09 20 3b 3b 20 20 20 20 20 20 20 20 09 .... ;; .
14020 20 27 28 22 46 41 49 4c 22 20 22 4b 49 4c 4c 45 '("FAIL" "KILLE
14030 44 22 29 29 0a 09 09 09 09 20 3b 3b 20 20 20 20 D"))..... ;;
14040 20 20 20 20 20 28 6d 65 6d 62 65 72 20 28 64 62 (member (db
14050 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 :test-get-state
14060 77 74 64 61 74 29 0a 09 09 09 09 20 3b 3b 20 20 wtdat)..... ;;
14070 20 20 20 20 20 20 09 20 27 28 22 49 4e 43 4f 4d . '("INCOM
14080 50 45 54 45 22 29 29 29 0a 09 09 09 09 20 20 20 PETE"))).....
14090 20 20 28 73 65 74 21 20 6b 65 65 70 2d 74 65 73 (set! keep-tes
140a0 74 20 23 66 29 29 29 29 20 3b 3b 20 6e 6f 20 70 t #f)))) ;; no p
140b0 6f 69 6e 74 20 69 6e 20 72 75 6e 6e 69 6e 67 20 oint in running
140c0 74 68 69 73 20 6f 6e 65 20 61 67 61 69 6e 0a 09 this one again..
140d0 09 09 20 20 20 20 20 77 61 69 74 6f 6e 73 29 29 .. waitons))
140e0 29 29 0a 09 20 28 69 66 20 6b 65 65 70 2d 74 65 )).. (if keep-te
140f0 73 74 20 28 73 65 74 21 20 72 75 6e 6e 61 62 6c st (set! runnabl
14100 65 73 20 28 63 6f 6e 73 20 74 65 73 74 6b 65 79 es (cons testkey
14110 6e 61 6d 65 20 72 75 6e 6e 61 62 6c 65 73 29 29 name runnables))
14120 29 29 29 0a 20 20 20 20 20 74 65 73 74 6b 65 79 ))). testkey
14130 6e 61 6d 65 73 29 0a 20 20 20 20 72 75 6e 6e 61 names). runna
14140 62 6c 65 73 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d bles))..;;======
14150 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14160 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14170 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14180 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14190 0a 3b 3b 20 72 65 66 61 63 74 6f 72 69 6e 67 20 .;; refactoring
141a0 74 68 69 73 20 62 6c 6f 63 6b 20 69 6e 74 6f 20 this block into
141b0 74 65 73 74 73 3a 67 65 74 2d 66 75 6c 6c 2d 64 tests:get-full-d
141c0 61 74 61 20 66 72 6f 6d 20 6c 69 6e 65 20 32 36 ata from line 26
141d0 33 20 6f 66 20 72 75 6e 73 2e 73 63 6d 0a 3b 3b 3 of runs.scm.;;
141e0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
141f0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14200 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14210 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14220 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 68 65 64 20 69 73 ======.;; hed is
14230 20 74 68 65 20 74 65 73 74 20 6e 61 6d 65 0a 3b the test name.;
14240 3b 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 69 ; test-records i
14250 73 20 61 20 68 61 73 68 20 6f 66 20 74 65 73 74 s a hash of test
14260 2d 6e 61 6d 65 20 3d 3e 20 74 65 73 74 20 72 65 -name => test re
14270 63 6f 72 64 0a 28 64 65 66 69 6e 65 20 28 74 65 cord.(define (te
14280 73 74 73 3a 67 65 74 2d 66 75 6c 6c 2d 64 61 74 sts:get-full-dat
14290 61 20 74 65 73 74 2d 6e 61 6d 65 73 20 74 65 73 a test-names tes
142a0 74 2d 72 65 63 6f 72 64 73 20 72 65 71 75 69 72 t-records requir
142b0 65 64 2d 74 65 73 74 73 20 61 6c 6c 2d 74 65 73 ed-tests all-tes
142c0 74 73 2d 72 65 67 69 73 74 72 79 29 0a 20 20 28 ts-registry). (
142d0 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 if (not (null? t
142e0 65 73 74 2d 6e 61 6d 65 73 29 29 0a 20 20 20 20 est-names)).
142f0 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 (let loop ((he
14300 64 20 28 63 61 72 20 74 65 73 74 2d 6e 61 6d 65 d (car test-name
14310 73 29 29 0a 09 09 20 28 74 61 6c 20 28 63 64 72 s))... (tal (cdr
14320 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 29 20 20 test-names)))
14330 20 20 20 20 20 20 20 3b 3b 20 27 72 65 74 75 72 ;; 'retur
14340 6e 2d 70 72 6f 63 73 20 74 65 6c 6c 73 20 74 68 n-procs tells th
14350 65 20 63 6f 6e 66 69 67 20 72 65 61 64 65 72 20 e config reader
14360 74 6f 20 70 72 65 70 20 72 75 6e 6e 69 6e 67 20 to prep running
14370 73 79 73 74 65 6d 20 62 75 74 20 72 65 74 75 72 system but retur
14380 6e 20 61 20 70 72 6f 63 0a 09 28 64 65 62 75 67 n a proc..(debug
14390 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 2a 64 :print-info 4 *d
143a0 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
143b0 20 22 68 65 64 3d 22 20 68 65 64 20 22 20 61 74 "hed=" hed " at
143c0 20 74 6f 70 20 6f 66 20 6c 6f 6f 70 22 29 0a 20 top of loop").
143d0 20 20 20 20 20 20 20 3b 3b 20 64 6f 6e 27 74 20 ;; don't
143e0 6b 6e 6f 77 20 69 74 65 6d 2d 70 61 74 68 20 61 know item-path a
143f0 74 20 74 68 69 73 20 74 69 6d 65 2c 20 6c 65 74 t this time, let
14400 20 74 68 65 20 74 65 73 74 63 6f 6e 66 69 67 20 the testconfig
14410 67 65 74 20 74 68 65 20 74 6f 70 20 6c 65 76 65 get the top leve
14420 6c 20 74 65 73 74 63 6f 6e 66 69 67 0a 09 28 6c l testconfig..(l
14430 65 74 2a 20 28 28 63 6f 6e 66 69 67 20 20 28 74 et* ((config (t
14440 65 73 74 73 3a 67 65 74 2d 74 65 73 74 63 6f 6e ests:get-testcon
14450 66 69 67 20 68 65 64 20 23 66 20 61 6c 6c 2d 74 fig hed #f all-t
14460 65 73 74 73 2d 72 65 67 69 73 74 72 79 20 27 72 ests-registry 'r
14470 65 74 75 72 6e 2d 70 72 6f 63 73 29 29 0a 09 20 eturn-procs))..
14480 20 20 20 20 20 20 28 77 61 69 74 6f 6e 73 20 28 (waitons (
14490 6c 65 74 20 28 28 69 6e 73 74 72 20 28 69 66 20 let ((instr (if
144a0 63 6f 6e 66 69 67 20 0a 09 09 09 09 09 20 28 63 config ...... (c
144b0 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 63 6f onfigf:lookup co
144c0 6e 66 69 67 20 22 72 65 71 75 69 72 65 6d 65 6e nfig "requiremen
144d0 74 73 22 20 22 77 61 69 74 6f 6e 22 29 0a 09 09 ts" "waiton")...
144e0 09 09 09 20 28 62 65 67 69 6e 20 3b 3b 20 4e 6f ... (begin ;; No
144f0 20 63 6f 6e 66 69 67 20 6d 65 61 6e 73 20 74 68 config means th
14500 69 73 20 69 73 20 61 20 6e 6f 6e 2d 65 78 69 73 is is a non-exis
14510 74 61 6e 74 20 74 65 73 74 0a 09 09 09 09 09 20 tant test......
14520 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 (debug:print-e
14530 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d rror 0 *default-
14540 6c 6f 67 2d 70 6f 72 74 2a 20 22 6e 6f 6e 2d 65 log-port* "non-e
14550 78 69 73 74 65 6e 74 20 72 65 71 75 69 72 65 64 xistent required
14560 20 74 65 73 74 20 5c 22 22 20 68 65 64 20 22 5c test \"" hed "\
14570 22 2c 20 67 72 65 70 20 74 68 72 6f 75 67 68 20 ", grep through
14580 79 6f 75 72 20 74 65 73 74 63 6f 6e 66 69 67 73 your testconfigs
14590 20 74 6f 20 66 69 6e 64 20 61 6e 64 20 72 65 6d to find and rem
145a0 6f 76 65 20 6f 72 20 63 72 65 61 74 65 20 74 68 ove or create th
145b0 65 20 74 65 73 74 2e 20 44 69 73 63 61 72 64 69 e test. Discardi
145c0 6e 67 20 61 6e 64 20 63 6f 6e 74 69 6e 75 69 6e ng and continuin
145d0 67 2e 22 29 0a 09 09 09 09 09 20 20 20 20 20 22 g.")...... "
145e0 22 29 29 29 29 0a 09 09 09 20 20 28 64 65 62 75 ")))).... (debu
145f0 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 38 20 2a g:print-info 8 *
14600 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
14610 2a 20 22 77 61 69 74 6f 6e 73 20 73 74 72 69 6e * "waitons strin
14620 67 20 69 73 20 22 20 69 6e 73 74 72 29 0a 09 09 g is " instr)...
14630 09 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 . (string-split
14640 20 28 63 6f 6e 64 0a 09 09 09 09 09 20 28 28 70 (cond...... ((p
14650 72 6f 63 65 64 75 72 65 3f 20 69 6e 73 74 72 29 rocedure? instr)
14660 0a 09 09 09 09 09 20 20 28 6c 65 74 20 28 28 72 ...... (let ((r
14670 65 73 20 28 69 6e 73 74 72 29 29 29 0a 09 09 09 es (instr)))....
14680 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
14690 6e 74 2d 69 6e 66 6f 20 38 20 2a 64 65 66 61 75 nt-info 8 *defau
146a0 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 77 61 lt-log-port* "wa
146b0 69 74 6f 6e 20 70 72 6f 63 65 64 75 72 65 20 72 iton procedure r
146c0 65 73 75 6c 74 73 20 69 6e 20 73 74 72 69 6e 67 esults in string
146d0 20 22 20 72 65 73 20 22 20 66 6f 72 20 74 65 73 " res " for tes
146e0 74 20 22 20 68 65 64 29 0a 09 09 09 09 09 20 20 t " hed)......
146f0 20 20 72 65 73 29 29 0a 09 09 09 09 09 20 28 28 res))...... ((
14700 73 74 72 69 6e 67 3f 20 69 6e 73 74 72 29 20 20 string? instr)
14710 20 20 20 69 6e 73 74 72 29 0a 09 09 09 09 09 20 instr)......
14720 28 65 6c 73 65 20 0a 09 09 09 09 09 20 20 3b 3b (else ...... ;;
14730 20 4e 4f 54 45 3a 20 54 68 69 73 20 69 73 20 61 NOTE: This is a
14740 63 74 75 61 6c 6c 79 20 74 68 65 20 63 61 73 65 ctually the case
14750 20 6f 66 20 2a 6e 6f 2a 20 77 61 69 74 6f 6e 73 of *no* waitons
14760 21 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e ! ;; (debug:prin
14770 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 t-error 0 *defau
14780 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 6f lt-log-port* "so
14790 6d 65 74 68 69 6e 67 20 77 65 6e 74 20 77 72 6f mething went wro
147a0 6e 67 20 69 6e 20 70 72 6f 63 65 73 73 69 6e 67 ng in processing
147b0 20 77 61 69 74 6f 6e 73 20 66 6f 72 20 74 65 73 waitons for tes
147c0 74 20 22 20 68 65 64 29 0a 09 09 09 09 09 20 20 t " hed)......
147d0 22 22 29 29 29 29 29 29 0a 09 20 20 28 69 66 20 "")))))).. (if
147e0 28 6e 6f 74 20 63 6f 6e 66 69 67 29 20 3b 3b 20 (not config) ;;
147f0 74 68 69 73 20 69 73 20 61 20 6e 6f 6e 2d 65 78 this is a non-ex
14800 69 73 74 61 6e 74 20 74 65 73 74 20 63 61 6c 6c istant test call
14810 65 64 20 69 6e 20 61 20 77 61 69 74 6f 6e 2e 20 ed in a waiton.
14820 0a 09 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c .. (if (nul
14830 6c 3f 20 74 61 6c 29 0a 09 09 20 20 74 65 73 74 l? tal)... test
14840 2d 72 65 63 6f 72 64 73 0a 09 09 20 20 28 6c 6f -records... (lo
14850 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 op (car tal)(cdr
14860 20 74 61 6c 29 29 29 0a 09 20 20 20 20 20 20 28 tal))).. (
14870 62 65 67 69 6e 0a 09 09 28 64 65 62 75 67 3a 70 begin...(debug:p
14880 72 69 6e 74 2d 69 6e 66 6f 20 38 20 2a 64 65 66 rint-info 8 *def
14890 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
148a0 77 61 69 74 6f 6e 73 3a 20 22 20 77 61 69 74 6f waitons: " waito
148b0 6e 73 29 0a 09 09 3b 3b 20 63 68 65 63 6b 20 66 ns)...;; check f
148c0 6f 72 20 68 65 64 20 69 6e 20 77 61 69 74 6f 6e or hed in waiton
148d0 73 20 3d 3e 20 74 68 69 73 20 77 6f 75 6c 64 20 s => this would
148e0 62 65 20 63 69 72 63 75 6c 61 72 2c 20 72 65 6d be circular, rem
148f0 6f 76 65 20 69 74 20 61 6e 64 20 69 73 73 75 65 ove it and issue
14900 20 61 6e 0a 09 09 3b 3b 20 65 72 72 6f 72 0a 09 an...;; error..
14910 09 28 69 66 20 28 6d 65 6d 62 65 72 20 68 65 64 .(if (member hed
14920 20 77 61 69 74 6f 6e 73 29 0a 09 09 20 20 20 20 waitons)...
14930 28 62 65 67 69 6e 0a 09 09 20 20 20 20 20 20 28 (begin... (
14940 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f debug:print-erro
14950 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 r 0 *default-log
14960 2d 70 6f 72 74 2a 20 22 74 65 73 74 20 22 20 68 -port* "test " h
14970 65 64 20 22 20 68 61 73 20 6c 69 73 74 65 64 20 ed " has listed
14980 69 74 73 65 6c 66 20 61 73 20 61 20 77 61 69 74 itself as a wait
14990 6f 6e 2c 20 70 6c 65 61 73 65 20 63 6f 72 72 65 on, please corre
149a0 63 74 20 74 68 69 73 21 22 29 0a 09 09 20 20 20 ct this!")...
149b0 20 20 20 28 73 65 74 21 20 77 61 69 74 6f 6e 73 (set! waitons
149c0 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 (filter (lambda
149d0 20 28 78 29 28 6e 6f 74 20 28 65 71 75 61 6c 3f (x)(not (equal?
149e0 20 78 20 68 65 64 29 29 29 20 77 61 69 74 6f 6e x hed))) waiton
149f0 73 29 29 29 29 0a 09 09 0a 09 09 3b 3b 20 28 69 s))))......;; (i
14a00 74 65 6d 73 20 20 20 28 69 74 65 6d 73 3a 67 65 tems (items:ge
14a10 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e t-items-from-con
14a20 66 69 67 20 63 6f 6e 66 69 67 29 29 29 0a 09 09 fig config)))...
14a30 28 69 66 20 28 6e 6f 74 20 28 68 61 73 68 2d 74 (if (not (hash-t
14a40 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
14a50 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 68 65 test-records he
14a60 64 20 23 66 29 29 0a 09 09 20 20 20 20 28 68 61 d #f))... (ha
14a70 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 65 sh-table-set! te
14a80 73 74 2d 72 65 63 6f 72 64 73 0a 09 09 09 09 20 st-records.....
14a90 20 20 20 20 68 65 64 20 28 76 65 63 74 6f 72 20 hed (vector
14aa0 68 65 64 20 20 20 20 20 3b 3b 20 30 0a 09 09 09 hed ;; 0....
14ab0 09 09 09 20 63 6f 6e 66 69 67 20 20 3b 3b 20 31 ... config ;; 1
14ac0 0a 09 09 09 09 09 09 20 77 61 69 74 6f 6e 73 20 ....... waitons
14ad0 3b 3b 20 32 0a 09 09 09 09 09 09 20 28 63 6f 6e ;; 2....... (con
14ae0 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 figf:lookup conf
14af0 69 67 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 ig "requirements
14b00 22 20 22 70 72 69 6f 72 69 74 79 22 29 20 20 20 " "priority")
14b10 20 20 3b 3b 20 70 72 69 6f 72 69 74 79 20 33 0a ;; priority 3.
14b20 09 09 09 09 09 09 20 28 6c 65 74 20 28 28 69 74 ...... (let ((it
14b30 65 6d 73 20 20 20 20 20 20 28 68 61 73 68 2d 74 ems (hash-t
14b40 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
14b50 20 63 6f 6e 66 69 67 20 22 69 74 65 6d 73 22 20 config "items"
14b60 23 66 29 29 20 3b 3b 20 69 74 65 6d 73 20 34 0a #f)) ;; items 4.
14b70 09 09 09 09 09 09 20 20 20 20 20 20 20 28 69 74 ...... (it
14b80 65 6d 73 74 61 62 6c 65 20 28 68 61 73 68 2d 74 emstable (hash-t
14b90 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
14ba0 20 63 6f 6e 66 69 67 20 22 69 74 65 6d 73 74 61 config "itemsta
14bb0 62 6c 65 22 20 23 66 29 29 29 20 0a 09 09 09 09 ble" #f))) .....
14bc0 09 09 20 20 20 3b 3b 20 69 66 20 65 69 74 68 65 .. ;; if eithe
14bd0 72 20 69 74 65 6d 73 20 6f 72 20 69 74 65 6d 73 r items or items
14be0 20 74 61 62 6c 65 20 69 73 20 61 20 70 72 6f 63 table is a proc
14bf0 20 72 65 74 75 72 6e 20 69 74 20 73 6f 20 74 65 return it so te
14c00 73 74 20 72 75 6e 6e 69 6e 67 0a 09 09 09 09 09 st running......
14c10 09 20 20 20 3b 3b 20 70 72 6f 63 65 73 73 20 63 . ;; process c
14c20 61 6e 20 6b 6e 6f 77 20 74 6f 20 63 61 6c 6c 20 an know to call
14c30 69 74 65 6d 73 3a 67 65 74 2d 69 74 65 6d 73 2d items:get-items-
14c40 66 72 6f 6d 2d 63 6f 6e 66 69 67 0a 09 09 09 09 from-config.....
14c50 09 09 20 20 20 3b 3b 20 69 66 20 65 69 74 68 65 .. ;; if eithe
14c60 72 20 69 73 20 61 20 6c 69 73 74 20 61 6e 64 20 r is a list and
14c70 6e 6f 6e 65 20 69 73 20 61 20 70 72 6f 63 20 67 none is a proc g
14c80 6f 20 61 68 65 61 64 20 61 6e 64 20 63 61 6c 6c o ahead and call
14c90 20 67 65 74 2d 69 74 65 6d 73 0a 09 09 09 09 09 get-items......
14ca0 09 20 20 20 3b 3b 20 6f 74 68 65 72 77 69 73 65 . ;; otherwise
14cb0 20 72 65 74 75 72 6e 20 23 66 20 2d 20 74 68 69 return #f - thi
14cc0 73 20 69 73 20 6e 6f 74 20 61 6e 20 69 74 65 72 s is not an iter
14cd0 61 74 65 64 20 74 65 73 74 0a 09 09 09 09 09 09 ated test.......
14ce0 20 20 20 28 63 6f 6e 64 0a 09 09 09 09 09 09 20 (cond.......
14cf0 20 20 20 28 28 70 72 6f 63 65 64 75 72 65 3f 20 ((procedure?
14d00 69 74 65 6d 73 29 20 20 20 20 20 20 0a 09 09 09 items) ....
14d10 09 09 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 ... (debug:p
14d20 72 69 6e 74 2d 69 6e 66 6f 20 34 20 2a 64 65 66 rint-info 4 *def
14d30 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
14d40 69 74 65 6d 73 20 69 73 20 61 20 70 72 6f 63 65 items is a proce
14d50 64 75 72 65 2c 20 77 69 6c 6c 20 63 61 6c 63 20 dure, will calc
14d60 6c 61 74 65 72 22 29 0a 09 09 09 09 09 09 20 20 later").......
14d70 20 20 20 69 74 65 6d 73 29 20 20 20 20 20 20 20 items)
14d80 20 20 20 20 20 3b 3b 20 63 61 6c 63 20 6c 61 74 ;; calc lat
14d90 65 72 0a 09 09 09 09 09 09 20 20 20 20 28 28 70 er....... ((p
14da0 72 6f 63 65 64 75 72 65 3f 20 69 74 65 6d 73 74 rocedure? itemst
14db0 61 62 6c 65 29 0a 09 09 09 09 09 09 20 20 20 20 able).......
14dc0 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
14dd0 66 6f 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 4 *default-lo
14de0 67 2d 70 6f 72 74 2a 20 22 69 74 65 6d 73 74 61 g-port* "itemsta
14df0 62 6c 65 20 69 73 20 61 20 70 72 6f 63 65 64 75 ble is a procedu
14e00 72 65 2c 20 77 69 6c 6c 20 63 61 6c 63 20 6c 61 re, will calc la
14e10 74 65 72 22 29 0a 09 09 09 09 09 09 20 20 20 20 ter").......
14e20 20 69 74 65 6d 73 74 61 62 6c 65 29 20 20 20 20 itemstable)
14e30 20 20 20 3b 3b 20 63 61 6c 63 20 6c 61 74 65 72 ;; calc later
14e40 0a 09 09 09 09 09 09 20 20 20 20 28 28 66 69 6c ....... ((fil
14e50 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 0a ter (lambda (x).
14e60 09 09 09 09 09 09 09 20 20 20 20 20 20 20 28 6c ....... (l
14e70 65 74 20 28 28 76 61 6c 20 28 63 61 72 20 78 29 et ((val (car x)
14e80 29 29 0a 09 09 09 09 09 09 09 09 20 28 69 66 20 ))......... (if
14e90 28 70 72 6f 63 65 64 75 72 65 3f 20 76 61 6c 29 (procedure? val)
14ea0 20 76 61 6c 20 23 66 29 29 29 0a 09 09 09 09 09 val #f)))......
14eb0 09 09 20 20 20 20 20 28 61 70 70 65 6e 64 20 28 .. (append (
14ec0 69 66 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 if (list? items)
14ed0 20 69 74 65 6d 73 20 27 28 29 29 0a 09 09 09 09 items '()).....
14ee0 09 09 09 09 20 20 20 20 20 28 69 66 20 28 6c 69 .... (if (li
14ef0 73 74 3f 20 69 74 65 6d 73 74 61 62 6c 65 29 20 st? itemstable)
14f00 69 74 65 6d 73 74 61 62 6c 65 20 27 28 29 29 29 itemstable '()))
14f10 29 0a 09 09 09 09 09 09 20 20 20 20 20 27 68 61 )....... 'ha
14f20 76 65 2d 70 72 6f 63 65 64 75 72 65 29 0a 09 09 ve-procedure)...
14f30 09 09 09 09 20 20 20 20 28 28 6f 72 20 28 6c 69 .... ((or (li
14f40 73 74 3f 20 69 74 65 6d 73 29 28 6c 69 73 74 3f st? items)(list?
14f50 20 69 74 65 6d 73 74 61 62 6c 65 29 29 20 3b 3b itemstable)) ;;
14f60 20 63 61 6c 63 20 6e 6f 77 0a 09 09 09 09 09 09 calc now.......
14f70 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
14f80 74 2d 69 6e 66 6f 20 34 20 2a 64 65 66 61 75 6c t-info 4 *defaul
14f90 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 69 74 65 t-log-port* "ite
14fa0 6d 73 20 61 6e 64 20 69 74 65 6d 73 74 61 62 6c ms and itemstabl
14fb0 65 20 61 72 65 20 6c 69 73 74 73 2c 20 63 61 6c e are lists, cal
14fc0 63 20 6e 6f 77 5c 6e 22 0a 09 09 09 09 09 09 09 c now\n"........
14fd0 09 20 20 20 20 20 20 20 22 20 20 20 20 69 74 65 . " ite
14fe0 6d 73 3a 20 22 20 69 74 65 6d 73 20 22 20 69 74 ms: " items " it
14ff0 65 6d 73 74 61 62 6c 65 3a 20 22 20 69 74 65 6d emstable: " item
15000 73 74 61 62 6c 65 29 0a 09 09 09 09 09 09 20 20 stable).......
15010 20 20 20 28 69 74 65 6d 73 3a 67 65 74 2d 69 74 (items:get-it
15020 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 20 ems-from-config
15030 63 6f 6e 66 69 67 29 29 0a 09 09 09 09 09 09 20 config)).......
15040 20 20 20 28 65 6c 73 65 20 23 66 29 29 29 20 20 (else #f)))
15050 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
15060 20 20 20 20 20 20 20 20 20 3b 3b 20 6e 6f 74 20 ;; not
15070 69 74 65 72 61 74 65 64 0a 09 09 09 09 09 09 20 iterated.......
15080 23 66 20 20 20 20 20 20 3b 3b 20 69 74 65 6d 73 #f ;; items
15090 64 61 74 20 35 0a 09 09 09 09 09 09 20 23 66 20 dat 5....... #f
150a0 20 20 20 20 20 3b 3b 20 73 70 61 72 65 20 2d 20 ;; spare -
150b0 75 73 65 64 20 66 6f 72 20 69 74 65 6d 2d 70 61 used for item-pa
150c0 74 68 0a 09 09 09 09 09 09 20 29 29 29 0a 09 09 th....... )))...
150d0 28 66 6f 72 2d 65 61 63 68 20 0a 09 09 20 28 6c (for-each ... (l
150e0 61 6d 62 64 61 20 28 77 61 69 74 6f 6e 29 0a 09 ambda (waiton)..
150f0 09 20 20 20 28 69 66 20 28 61 6e 64 20 77 61 69 . (if (and wai
15100 74 6f 6e 20 28 6e 6f 74 20 28 6d 65 6d 62 65 72 ton (not (member
15110 20 77 61 69 74 6f 6e 20 74 65 73 74 2d 6e 61 6d waiton test-nam
15120 65 73 29 29 29 0a 09 09 20 20 20 20 20 20 20 28 es)))... (
15130 62 65 67 69 6e 0a 09 09 09 20 28 73 65 74 21 20 begin.... (set!
15140 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 20 28 required-tests (
15150 63 6f 6e 73 20 77 61 69 74 6f 6e 20 72 65 71 75 cons waiton requ
15160 69 72 65 64 2d 74 65 73 74 73 29 29 0a 09 09 09 ired-tests))....
15170 20 28 73 65 74 21 20 74 65 73 74 2d 6e 61 6d 65 (set! test-name
15180 73 20 28 63 6f 6e 73 20 77 61 69 74 6f 6e 20 74 s (cons waiton t
15190 65 73 74 2d 6e 61 6d 65 73 29 29 29 29 29 20 3b est-names))))) ;
151a0 3b 20 77 61 73 20 61 6e 20 61 70 70 65 6e 64 2c ; was an append,
151b0 20 6e 6f 77 20 61 20 63 6f 6e 73 0a 09 09 20 77 now a cons... w
151c0 61 69 74 6f 6e 73 29 0a 09 09 28 6c 65 74 20 28 aitons)...(let (
151d0 28 72 65 6d 74 65 73 74 73 20 28 64 65 6c 65 74 (remtests (delet
151e0 65 2d 64 75 70 6c 69 63 61 74 65 73 20 28 61 70 e-duplicates (ap
151f0 70 65 6e 64 20 77 61 69 74 6f 6e 73 20 74 61 6c pend waitons tal
15200 29 29 29 29 0a 09 09 20 20 28 69 66 20 28 6e 6f ))))... (if (no
15210 74 20 28 6e 75 6c 6c 3f 20 72 65 6d 74 65 73 74 t (null? remtest
15220 73 29 29 0a 09 09 20 20 20 20 20 20 28 6c 6f 6f s))... (loo
15230 70 20 28 63 61 72 20 72 65 6d 74 65 73 74 73 29 p (car remtests)
15240 28 63 64 72 20 72 65 6d 74 65 73 74 73 29 29 0a (cdr remtests)).
15250 09 09 20 20 20 20 20 20 74 65 73 74 2d 72 65 63 .. test-rec
15260 6f 72 64 73 29 29 29 29 29 29 29 29 0a 0a 3b 3b ords))))))))..;;
15270 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15280 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15290 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
152a0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
152b0 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 74 65 73 74 20 73 ======.;; test s
152c0 74 65 70 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d teps.;;=========
152d0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
152e0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
152f0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15300 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b =============..;
15310 3b 20 74 65 73 74 73 74 65 70 2d 73 65 74 2d 73 ; teststep-set-s
15320 74 61 74 75 73 21 20 75 73 65 64 20 74 6f 20 62 tatus! used to b
15330 65 20 68 65 72 65 0a 0a 28 64 65 66 69 6e 65 20 e here..(define
15340 28 74 65 73 74 2d 67 65 74 2d 6b 69 6c 6c 2d 72 (test-get-kill-r
15350 65 71 75 65 73 74 20 72 75 6e 2d 69 64 20 74 65 equest run-id te
15360 73 74 2d 69 64 29 20 3b 3b 20 72 75 6e 2d 69 64 st-id) ;; run-id
15370 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 64 test-name itemd
15380 61 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 74 65 at). (let* ((te
15390 73 74 64 61 74 20 20 20 28 72 6d 74 3a 67 65 74 stdat (rmt:get
153a0 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 -test-info-by-id
153b0 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 run-id test-id)
153c0 29 29 0a 20 20 20 20 28 61 6e 64 20 74 65 73 74 )). (and test
153d0 64 61 74 0a 09 20 28 65 71 75 61 6c 3f 20 28 74 dat.. (equal? (t
153e0 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 est:get-state te
153f0 73 74 64 61 74 29 20 22 4b 49 4c 4c 52 45 51 22 stdat) "KILLREQ"
15400 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 ))))..(define (t
15410 65 73 74 3a 74 64 62 2d 67 65 74 2d 72 75 6e 64 est:tdb-get-rund
15420 61 74 2d 63 6f 75 6e 74 20 74 64 62 29 0a 20 20 at-count tdb).
15430 28 69 66 20 74 64 62 0a 20 20 20 20 20 20 28 6c (if tdb. (l
15440 65 74 20 28 28 72 65 73 20 30 29 29 0a 09 28 73 et ((res 0))..(s
15450 71 6c 69 74 65 33 3a 66 6f 72 2d 65 61 63 68 2d qlite3:for-each-
15460 72 6f 77 0a 09 20 28 6c 61 6d 62 64 61 20 28 63 row.. (lambda (c
15470 6f 75 6e 74 29 0a 09 20 20 20 28 73 65 74 21 20 ount).. (set!
15480 72 65 73 20 63 6f 75 6e 74 29 29 0a 09 20 74 64 res count)).. td
15490 62 0a 09 20 22 53 45 4c 45 43 54 20 63 6f 75 6e b.. "SELECT coun
154a0 74 28 69 64 29 20 46 52 4f 4d 20 74 65 73 74 5f t(id) FROM test_
154b0 72 75 6e 64 61 74 3b 22 29 0a 09 72 65 73 29 29 rundat;")..res))
154c0 0a 20 20 30 29 0a 0a 3b 3b 20 0a 28 64 65 66 69 . 0)..;; .(defi
154d0 6e 65 20 28 74 65 73 74 73 3a 75 70 64 61 74 65 ne (tests:update
154e0 2d 63 65 6e 74 72 61 6c 2d 6d 65 74 61 2d 69 6e -central-meta-in
154f0 66 6f 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 fo run-id test-i
15500 64 20 63 70 75 6c 6f 61 64 20 64 69 73 6b 66 72 d cpuload diskfr
15510 65 65 20 6d 69 6e 75 74 65 73 20 75 6e 61 6d 65 ee minutes uname
15520 20 68 6f 73 74 6e 61 6d 65 20 23 21 6b 65 79 20 hostname #!key
15530 28 75 70 64 61 74 65 2d 64 62 20 23 66 29 28 74 (update-db #f)(t
15540 6d 70 66 72 65 65 20 23 66 29 29 0a 20 20 28 69 mpfree #f)). (i
15550 66 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 f (get-environme
15560 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 4d 54 5f nt-variable "MT_
15570 54 45 53 54 5f 52 55 4e 5f 44 49 52 22 29 0a 20 TEST_RUN_DIR").
15580 20 20 20 20 20 28 6c 65 74 2a 20 28 28 64 65 73 (let* ((des
15590 74 2d 64 69 72 20 28 63 6f 6e 63 20 28 67 65 74 t-dir (conc (get
155a0 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 -environment-var
155b0 69 61 62 6c 65 20 22 4d 54 5f 54 45 53 54 5f 52 iable "MT_TEST_R
155c0 55 4e 5f 44 49 52 22 29 20 22 2f 2e 6d 74 5f 64 UN_DIR") "/.mt_d
155d0 61 74 61 22 29 29 0a 09 20 20 20 20 20 28 6f 72 ata")).. (or
155e0 2d 64 61 73 68 20 20 28 6c 61 6d 62 64 61 20 28 -dash (lambda (
155f0 69 6e 73 74 72 29 0a 09 09 09 20 28 63 6f 6e 64 instr).... (cond
15600 0a 09 09 09 20 20 28 28 6e 6f 74 20 69 6e 73 74 .... ((not inst
15610 72 29 20 22 22 29 20 3b 3b 20 23 66 20 2d 3e 20 r) "") ;; #f ->
15620 62 6c 61 6e 6b 2c 20 69 6e 64 69 63 61 74 65 73 blank, indicates
15630 20 76 61 6c 75 65 20 75 6e 63 68 61 6e 67 65 64 value unchanged
15640 20 73 69 6e 63 65 20 6c 61 73 74 20 6d 65 61 73 since last meas
15650 75 72 65 6d 65 6e 74 20 74 61 6b 65 6e 0a 09 09 urement taken...
15660 09 20 20 28 28 73 74 72 69 6e 67 3f 20 69 6e 73 . ((string? ins
15670 74 72 29 28 69 66 20 28 73 74 72 69 6e 67 2d 73 tr)(if (string-s
15680 65 61 72 63 68 20 22 20 22 20 69 6e 73 74 72 29 earch " " instr)
15690 20 28 63 6f 6e 63 20 22 5c 22 22 20 69 6e 73 74 (conc "\"" inst
156a0 72 20 22 5c 22 22 29 20 69 6e 73 74 72 29 29 0a r "\"") instr)).
156b0 09 09 09 20 20 28 65 6c 73 65 20 69 6e 73 74 72 ... (else instr
156c0 29 29 29 29 0a 09 20 20 20 20 20 28 66 69 6c 65 )))).. (file
156d0 2d 6e 65 77 20 28 6e 6f 74 20 28 64 69 72 65 63 -new (not (direc
156e0 74 6f 72 79 2d 65 78 69 73 74 73 3f 20 64 65 73 tory-exists? des
156f0 74 2d 64 69 72 29 29 29 29 0a 09 28 69 66 20 66 t-dir))))..(if f
15700 69 6c 65 2d 6e 65 77 20 28 63 72 65 61 74 65 2d ile-new (create-
15710 64 69 72 65 63 74 6f 72 79 20 64 65 73 74 2d 64 directory dest-d
15720 69 72 20 23 74 29 29 0a 09 28 6c 65 74 2a 20 28 ir #t))..(let* (
15730 28 6f 75 74 70 20 28 6f 70 65 6e 2d 6f 75 74 70 (outp (open-outp
15740 75 74 2d 66 69 6c 65 20 28 63 6f 6e 63 20 64 65 ut-file (conc de
15750 73 74 2d 64 69 72 20 22 2f 74 65 73 74 2d 72 75 st-dir "/test-ru
15760 6e 2e 64 61 74 22 29 20 23 3a 61 70 70 65 6e 64 n.dat") #:append
15770 29 29 29 0a 09 20 20 28 77 69 74 68 2d 6f 75 74 ))).. (with-out
15780 70 75 74 2d 74 6f 2d 70 6f 72 74 20 6f 75 74 70 put-to-port outp
15790 0a 09 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 .. (lambda ()
157a0 0a 09 20 20 20 20 20 20 28 69 66 20 66 69 6c 65 .. (if file
157b0 2d 6e 65 77 0a 09 09 20 20 28 70 72 69 6e 74 20 -new... (print
157c0 22 65 70 6f 63 68 5f 74 69 6d 65 2c 72 75 6e 5f "epoch_time,run_
157d0 69 64 2c 74 65 73 74 5f 69 64 2c 63 70 75 6c 6f id,test_id,cpulo
157e0 61 64 2c 64 69 73 6b 66 72 65 65 2c 74 6d 70 66 ad,diskfree,tmpf
157f0 72 65 65 2c 72 75 6e 5f 6d 69 6e 75 74 65 73 2c ree,run_minutes,
15800 68 6f 73 74 6e 61 6d 65 2c 75 6e 61 6d 65 22 29 hostname,uname")
15810 29 0a 09 20 20 20 20 20 20 28 70 72 69 6e 74 20 ).. (print
15820 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
15830 29 20 22 2c 22 20 28 6f 72 2d 64 61 73 68 20 72 ) "," (or-dash r
15840 75 6e 2d 69 64 29 20 20 20 22 2c 22 20 28 6f 72 un-id) "," (or
15850 2d 64 61 73 68 20 74 65 73 74 2d 69 64 29 20 20 -dash test-id)
15860 22 2c 22 0a 09 09 20 20 20 20 20 28 6f 72 2d 64 ","... (or-d
15870 61 73 68 20 63 70 75 6c 6f 61 64 29 20 22 2c 22 ash cpuload) ","
15880 20 28 6f 72 2d 64 61 73 68 20 64 69 73 6b 66 72 (or-dash diskfr
15890 65 65 29 20 22 2c 22 20 28 6f 72 2d 64 61 73 68 ee) "," (or-dash
158a0 20 74 6d 70 66 72 65 65 29 20 20 22 2c 22 0a 09 tmpfree) ","..
158b0 09 20 20 20 20 20 28 6f 72 2d 64 61 73 68 20 6d . (or-dash m
158c0 69 6e 75 74 65 73 29 20 22 2c 22 20 28 6f 72 2d inutes) "," (or-
158d0 64 61 73 68 20 68 6f 73 74 6e 61 6d 65 29 20 22 dash hostname) "
158e0 2c 22 0a 09 09 20 20 20 20 20 28 6f 72 2d 64 61 ,"... (or-da
158f0 73 68 20 75 6e 61 6d 65 29 29 29 29 20 3b 3b 20 sh uname)))) ;;
15900 70 75 74 20 75 6e 61 6d 65 20 6c 61 73 74 20 61 put uname last a
15910 73 20 69 74 20 68 61 73 20 73 70 61 63 65 73 20 s it has spaces
15920 69 6e 20 69 74 0a 09 20 20 28 63 6c 6f 73 65 2d in it.. (close-
15930 6f 75 74 70 75 74 2d 70 6f 72 74 20 6f 75 74 70 output-port outp
15940 29 29 29 0a 20 20 20 20 20 20 28 62 65 67 69 6e ))). (begin
15950 0a 09 28 72 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 ..(rmt:general-c
15960 61 6c 6c 20 27 75 70 64 61 74 65 2d 74 65 73 74 all 'update-test
15970 2d 72 75 6e 64 61 74 20 72 75 6e 2d 69 64 20 74 -rundat run-id t
15980 65 73 74 2d 69 64 20 28 63 75 72 72 65 6e 74 2d est-id (current-
15990 73 65 63 6f 6e 64 73 29 20 28 6f 72 20 63 70 75 seconds) (or cpu
159a0 6c 6f 61 64 20 2d 31 29 28 6f 72 20 64 69 73 6b load -1)(or disk
159b0 66 72 65 65 20 2d 31 29 20 2d 31 20 28 6f 72 20 free -1) -1 (or
159c0 6d 69 6e 75 74 65 73 20 2d 31 29 29 29 29 0a 20 minutes -1)))).
159d0 20 28 69 66 20 75 70 64 61 74 65 2d 64 62 0a 20 (if update-db.
159e0 20 20 20 20 20 28 62 65 67 69 6e 0a 09 28 69 66 (begin..(if
159f0 20 28 61 6e 64 20 63 70 75 6c 6f 61 64 20 64 69 (and cpuload di
15a00 73 6b 66 72 65 65 29 0a 09 20 20 20 20 28 72 6d skfree).. (rm
15a10 74 3a 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 t:general-call '
15a20 75 70 64 61 74 65 2d 63 70 75 6c 6f 61 64 2d 64 update-cpuload-d
15a30 69 73 6b 66 72 65 65 20 72 75 6e 2d 69 64 20 63 iskfree run-id c
15a40 70 75 6c 6f 61 64 20 64 69 73 6b 66 72 65 65 20 puload diskfree
15a50 74 65 73 74 2d 69 64 29 29 0a 09 28 69 66 20 6d test-id))..(if m
15a60 69 6e 75 74 65 73 20 0a 09 20 20 20 20 28 72 6d inutes .. (rm
15a70 74 3a 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 t:general-call '
15a80 75 70 64 61 74 65 2d 72 75 6e 2d 64 75 72 61 74 update-run-durat
15a90 69 6f 6e 20 72 75 6e 2d 69 64 20 6d 69 6e 75 74 ion run-id minut
15aa0 65 73 20 74 65 73 74 2d 69 64 29 29 0a 09 28 69 es test-id))..(i
15ab0 66 20 28 61 6e 64 20 75 6e 61 6d 65 20 68 6f 73 f (and uname hos
15ac0 74 6e 61 6d 65 29 0a 09 20 20 20 20 28 72 6d 74 tname).. (rmt
15ad0 3a 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 75 :general-call 'u
15ae0 70 64 61 74 65 2d 75 6e 61 6d 65 2d 68 6f 73 74 pdate-uname-host
15af0 20 72 75 6e 2d 69 64 20 75 6e 61 6d 65 20 68 6f run-id uname ho
15b00 73 74 6e 61 6d 65 20 74 65 73 74 2d 69 64 29 29 stname test-id))
15b10 29 29 29 0a 20 20 0a 3b 3b 20 54 68 69 73 20 6f ))). .;; This o
15b20 6e 65 20 69 73 20 66 6f 72 20 72 75 6e 6e 69 6e ne is for runnin
15b30 67 20 77 69 74 68 20 6e 6f 20 64 62 20 61 63 63 g with no db acc
15b40 65 73 73 20 28 69 2e 65 2e 20 76 69 61 20 72 6d ess (i.e. via rm
15b50 74 3a 20 69 6e 74 65 72 6e 61 6c 6c 79 29 0a 28 t: internally).(
15b60 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 73 65 define (tests:se
15b70 74 2d 66 75 6c 6c 2d 6d 65 74 61 2d 69 6e 66 6f t-full-meta-info
15b80 20 64 62 20 74 65 73 74 2d 69 64 20 72 75 6e 2d db test-id run-
15b90 69 64 20 6d 69 6e 75 74 65 73 20 77 6f 72 6b 2d id minutes work-
15ba0 61 72 65 61 20 72 65 6d 74 72 69 65 73 20 23 21 area remtries #!
15bb0 6b 65 79 20 28 75 70 64 61 74 65 2d 64 62 20 23 key (update-db #
15bc0 66 29 29 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 f)).;; (define (
15bd0 74 65 73 74 73 3a 73 65 74 2d 66 75 6c 6c 2d 6d tests:set-full-m
15be0 65 74 61 2d 69 6e 66 6f 20 74 65 73 74 2d 69 64 eta-info test-id
15bf0 20 72 75 6e 2d 69 64 20 6d 69 6e 75 74 65 73 20 run-id minutes
15c00 77 6f 72 6b 2d 61 72 65 61 29 0a 3b 3b 20 20 28 work-area).;; (
15c10 6c 65 74 20 28 28 72 65 6d 74 72 69 65 73 20 31 let ((remtries 1
15c20 30 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 63 70 0)). (let* ((cp
15c30 75 6c 6f 61 64 20 20 28 67 65 74 2d 63 70 75 2d uload (get-cpu-
15c40 6c 6f 61 64 29 29 0a 09 20 28 64 69 73 6b 66 72 load)).. (diskfr
15c50 65 65 20 28 67 65 74 2d 64 66 20 28 63 75 72 72 ee (get-df (curr
15c60 65 6e 74 2d 64 69 72 65 63 74 6f 72 79 29 29 29 ent-directory)))
15c70 0a 09 20 28 74 6d 70 66 72 65 65 20 20 28 67 65 .. (tmpfree (ge
15c80 74 2d 64 66 20 22 2f 74 6d 70 22 29 29 0a 09 20 t-df "/tmp"))..
15c90 28 75 6e 61 6d 65 20 20 20 20 28 67 65 74 2d 75 (uname (get-u
15ca0 6e 61 6d 65 20 22 2d 73 72 76 70 69 6f 22 29 29 name "-srvpio"))
15cb0 0a 09 20 28 68 6f 73 74 6e 61 6d 65 20 28 67 65 .. (hostname (ge
15cc0 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 29 0a 20 t-host-name))).
15cd0 20 20 20 28 74 65 73 74 73 3a 75 70 64 61 74 65 (tests:update
15ce0 2d 63 65 6e 74 72 61 6c 2d 6d 65 74 61 2d 69 6e -central-meta-in
15cf0 66 6f 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 fo run-id test-i
15d00 64 20 63 70 75 6c 6f 61 64 20 64 69 73 6b 66 72 d cpuload diskfr
15d10 65 65 20 6d 69 6e 75 74 65 73 20 75 6e 61 6d 65 ee minutes uname
15d20 20 68 6f 73 74 6e 61 6d 65 20 75 70 64 61 74 65 hostname update
15d30 2d 64 62 3a 20 75 70 64 61 74 65 2d 64 62 20 74 -db: update-db t
15d40 6d 70 66 72 65 65 3a 20 74 6d 70 66 72 65 65 29 mpfree: tmpfree)
15d50 29 29 0a 20 20 20 20 0a 09 20 0a 3b 3b 3d 3d 3d )). .. .;;===
15d60 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15d70 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15d80 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15d90 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15da0 3d 3d 3d 0a 3b 3b 20 41 20 52 20 43 20 48 20 49 ===.;; A R C H I
15db0 20 56 20 49 20 4e 20 47 0a 3b 3b 3d 3d 3d 3d 3d V I N G.;;=====
15dc0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15dd0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15de0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15df0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15e00 3d 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 =..(define (test
15e10 3a 61 72 63 68 69 76 65 20 64 62 20 74 65 73 74 :archive db test
15e20 2d 69 64 29 0a 20 20 23 66 29 0a 0a 28 64 65 66 -id). #f)..(def
15e30 69 6e 65 20 28 74 65 73 74 3a 61 72 63 68 69 76 ine (test:archiv
15e40 65 2d 74 65 73 74 73 20 64 62 20 6b 65 79 6e 61 e-tests db keyna
15e50 6d 65 73 20 74 61 72 67 65 74 29 0a 20 20 23 66 mes target). #f
15e60 29 0a 0a )..