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: 72 65 71 75 69 72 65 2d 6c 69 62 72 61 72 79 20 require-library
05e0: 73 74 6d 6c 29 0a 0a 28 69 6e 63 6c 75 64 65 20 stml)..(include
05f0: 22 63 6f 6d 6d 6f 6e 5f 72 65 63 6f 72 64 73 2e "common_records.
0600: 73 63 6d 22 29 0a 28 69 6e 63 6c 75 64 65 20 22 scm").(include "
0610: 6b 65 79 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 key_records.scm"
0620: 29 0a 28 69 6e 63 6c 75 64 65 20 22 64 62 5f 72 ).(include "db_r
0630: 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a 28 69 6e ecords.scm").(in
0640: 63 6c 75 64 65 20 22 72 75 6e 5f 72 65 63 6f 72 clude "run_recor
0650: 64 73 2e 73 63 6d 22 29 0a 28 69 6e 63 6c 75 64 ds.scm").(includ
0660: 65 20 22 74 65 73 74 5f 72 65 63 6f 72 64 73 2e e "test_records.
0670: 73 63 6d 22 29 0a 28 69 6e 63 6c 75 64 65 20 22 scm").(include "
0680: 6a 73 2d 70 61 74 68 2e 73 63 6d 22 29 0a 0a 28 js-path.scm")..(
0690: 64 65 66 69 6e 65 20 28 69 6e 69 74 2d 6a 61 76 define (init-jav
06a0: 61 2d 73 63 72 69 70 74 2d 6c 69 62 29 0a 20 20 a-script-lib).
06b0: 28 73 65 74 21 20 2a 6a 61 76 61 2d 73 63 72 69 (set! *java-scri
06c0: 70 74 2d 6c 69 62 2a 20 28 63 6f 6e 63 20 20 28 pt-lib* (conc (
06d0: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 69 6e 73 74 61 common:get-insta
06e0: 6c 6c 2d 61 72 65 61 29 20 22 2f 73 68 61 72 65 ll-area) "/share
06f0: 2f 6a 73 2f 6a 71 75 65 72 79 2d 33 2e 31 2e 30 /js/jquery-3.1.0
0700: 2e 73 6c 69 6d 2e 6d 69 6e 2e 6a 73 22 29 29 0a .slim.min.js")).
0710: 20 20 29 0a 0a 3b 3b 20 43 61 6c 6c 20 74 68 69 )..;; Call thi
0720: 73 20 6f 6e 65 20 74 6f 20 64 6f 20 61 6c 6c 20 s one to do all
0730: 74 68 65 20 77 6f 72 6b 20 61 6e 64 20 67 65 74 the work and get
0740: 20 61 20 73 74 61 6e 64 61 72 64 69 7a 65 64 20 a standardized
0750: 6c 69 73 74 20 6f 66 20 74 65 73 74 73 0a 3b 3b list of tests.;;
0760: 20 20 20 67 65 74 73 20 70 61 74 68 73 20 66 72 gets paths fr
0770: 6f 6d 20 63 6f 6e 66 69 67 73 20 61 6e 64 20 66 om configs and f
0780: 69 6e 64 73 20 76 61 6c 69 64 20 74 65 73 74 73 inds valid tests
0790: 20 0a 3b 3b 20 20 20 72 65 74 75 72 6e 73 20 68 .;; returns h
07a0: 61 73 68 20 6f 66 20 74 65 73 74 6e 61 6d 65 20 ash of testname
07b0: 2d 2d 3e 20 66 75 6c 6c 70 61 74 68 0a 3b 3b 0a --> fullpath.;;.
07c0: 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 67 (define (tests:g
07d0: 65 74 2d 61 6c 6c 29 0a 20 20 28 6c 65 74 2a 20 et-all). (let*
07e0: 28 28 74 65 73 74 2d 73 65 61 72 63 68 2d 70 61 ((test-search-pa
07f0: 74 68 20 20 20 28 74 65 73 74 73 3a 67 65 74 2d th (tests:get-
0800: 74 65 73 74 73 2d 73 65 61 72 63 68 2d 70 61 74 tests-search-pat
0810: 68 20 2a 63 6f 6e 66 69 67 64 61 74 2a 29 29 29 h *configdat*)))
0820: 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
0830: 74 20 38 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 8 *default-log
0840: 2d 70 6f 72 74 2a 20 22 74 65 73 74 2d 73 65 61 -port* "test-sea
0850: 72 63 68 2d 70 61 74 68 3a 20 22 20 74 65 73 74 rch-path: " test
0860: 2d 73 65 61 72 63 68 2d 70 61 74 68 29 0a 20 20 -search-path).
0870: 20 20 28 74 65 73 74 73 3a 67 65 74 2d 76 61 6c (tests:get-val
0880: 69 64 2d 74 65 73 74 73 20 28 6d 61 6b 65 2d 68 id-tests (make-h
0890: 61 73 68 2d 74 61 62 6c 65 29 20 74 65 73 74 2d ash-table) test-
08a0: 73 65 61 72 63 68 2d 70 61 74 68 29 29 29 0a 0a search-path)))..
08b0: 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 67 (define (tests:g
08c0: 65 74 2d 74 65 73 74 73 2d 73 65 61 72 63 68 2d et-tests-search-
08d0: 70 61 74 68 20 63 66 67 64 61 74 29 0a 20 20 28 path cfgdat). (
08e0: 6c 65 74 20 28 28 70 61 74 68 73 20 28 6c 65 74 let ((paths (let
08f0: 20 28 28 73 65 63 74 69 6f 6e 20 28 69 66 20 63 ((section (if c
0900: 66 67 64 61 74 0a 09 09 09 09 20 20 28 63 6f 6e fgdat..... (con
0910: 66 69 67 66 3a 67 65 74 2d 73 65 63 74 69 6f 6e figf:get-section
0920: 20 63 66 67 64 61 74 20 22 74 65 73 74 73 2d 70 cfgdat "tests-p
0930: 61 74 68 73 22 29 0a 09 09 09 09 20 20 23 66 29 aths")..... #f)
0940: 29 29 0a 09 09 20 28 69 66 20 73 65 63 74 69 6f ))... (if sectio
0950: 6e 0a 09 09 20 20 20 20 20 28 6d 61 70 20 63 61 n... (map ca
0960: 64 72 20 73 65 63 74 69 6f 6e 29 0a 09 09 20 20 dr section)...
0970: 20 20 20 27 28 29 29 29 29 29 0a 20 20 20 20 28 '())))). (
0980: 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 filter (lambda (
0990: 64 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 64 d).. (if (d
09a0: 69 72 65 63 74 6f 72 79 2d 65 78 69 73 74 73 3f irectory-exists?
09b0: 20 64 29 0a 09 09 20 20 64 0a 09 09 20 20 28 62 d)... d... (b
09c0: 65 67 69 6e 0a 09 09 20 20 20 20 3b 3b 20 28 69 egin... ;; (i
09d0: 66 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f f (common:low-no
09e0: 69 73 65 2d 70 72 69 6e 74 20 36 30 20 22 74 65 ise-print 60 "te
09f0: 73 74 73 3a 67 65 74 2d 74 65 73 74 73 2d 73 65 sts:get-tests-se
0a00: 61 72 63 68 2d 70 61 74 68 22 20 64 29 0a 09 09 arch-path" d)...
0a10: 20 20 20 20 3b 3b 09 28 64 65 62 75 67 3a 70 72 ;;.(debug:pr
0a20: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
0a30: 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e og-port* "WARNIN
0a40: 47 3a 20 70 72 6f 62 6c 65 6d 20 77 69 74 68 20 G: problem with
0a50: 64 69 72 65 63 74 6f 72 79 20 22 20 64 20 22 2c directory " d ",
0a60: 20 64 72 6f 70 70 69 6e 67 20 69 74 20 66 72 6f dropping it fro
0a70: 6d 20 74 65 73 74 73 20 70 61 74 68 22 29 29 0a m tests path")).
0a80: 09 09 20 20 20 20 23 66 29 29 29 0a 09 20 20 20 .. #f)))..
0a90: 20 28 61 70 70 65 6e 64 20 70 61 74 68 73 20 28 (append paths (
0aa0: 6c 69 73 74 20 28 63 6f 6e 63 20 2a 74 6f 70 70 list (conc *topp
0ab0: 61 74 68 2a 20 22 2f 74 65 73 74 73 22 29 29 29 ath* "/tests")))
0ac0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 )))..(define (te
0ad0: 73 74 73 3a 67 65 74 2d 76 61 6c 69 64 2d 74 65 sts:get-valid-te
0ae0: 73 74 73 20 74 65 73 74 2d 72 65 67 69 73 74 72 sts test-registr
0af0: 79 20 74 65 73 74 73 2d 70 61 74 68 73 29 0a 20 y tests-paths).
0b00: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 65 73 74 (if (null? test
0b10: 73 2d 70 61 74 68 73 29 20 0a 20 20 20 20 20 20 s-paths) .
0b20: 74 65 73 74 2d 72 65 67 69 73 74 72 79 0a 20 20 test-registry.
0b30: 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 (let loop ((
0b40: 68 65 64 20 28 63 61 72 20 74 65 73 74 73 2d 70 hed (car tests-p
0b50: 61 74 68 73 29 29 0a 09 09 20 28 74 61 6c 20 28 aths))... (tal (
0b60: 63 64 72 20 74 65 73 74 73 2d 70 61 74 68 73 29 cdr tests-paths)
0b70: 29 29 0a 09 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a ))..(if (common:
0b80: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 68 65 64 file-exists? hed
0b90: 29 0a 09 20 20 20 20 28 66 6f 72 2d 65 61 63 68 ).. (for-each
0ba0: 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 2d 70 (lambda (test-p
0bb0: 61 74 68 29 0a 09 09 09 28 6c 65 74 2a 20 28 28 ath)....(let* ((
0bc0: 74 6e 61 6d 65 20 20 20 28 6c 61 73 74 20 28 73 tname (last (s
0bd0: 74 72 69 6e 67 2d 73 70 6c 69 74 20 74 65 73 74 tring-split test
0be0: 2d 70 61 74 68 20 22 2f 22 29 29 29 0a 09 09 09 -path "/")))....
0bf0: 20 20 20 20 20 20 20 28 74 63 6f 6e 66 69 67 20 (tconfig
0c00: 28 63 6f 6e 63 20 74 65 73 74 2d 70 61 74 68 20 (conc test-path
0c10: 22 2f 74 65 73 74 63 6f 6e 66 69 67 22 29 29 29 "/testconfig")))
0c20: 0a 09 09 09 20 20 28 69 66 20 28 61 6e 64 20 28 .... (if (and (
0c30: 6e 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d not (hash-table-
0c40: 72 65 66 2f 64 65 66 61 75 6c 74 20 74 65 73 74 ref/default test
0c50: 2d 72 65 67 69 73 74 72 79 20 74 6e 61 6d 65 20 -registry tname
0c60: 23 66 29 29 0a 09 09 09 09 20 20 20 28 63 6f 6d #f))..... (com
0c70: 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f mon:file-exists?
0c80: 20 74 63 6f 6e 66 69 67 29 29 0a 09 09 09 20 20 tconfig))....
0c90: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
0ca0: 73 65 74 21 20 74 65 73 74 2d 72 65 67 69 73 74 set! test-regist
0cb0: 72 79 20 74 6e 61 6d 65 20 74 65 73 74 2d 70 61 ry tname test-pa
0cc0: 74 68 29 29 29 29 0a 09 09 20 20 20 20 20 20 28 th))))... (
0cd0: 67 6c 6f 62 20 28 63 6f 6e 63 20 68 65 64 20 22 glob (conc hed "
0ce0: 2f 2a 22 29 29 29 29 0a 09 28 69 66 20 28 6e 75 /*"))))..(if (nu
0cf0: 6c 6c 3f 20 74 61 6c 29 0a 09 20 20 20 20 74 65 ll? tal).. te
0d00: 73 74 2d 72 65 67 69 73 74 72 79 0a 09 20 20 20 st-registry..
0d10: 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 (loop (car tal)
0d20: 28 63 64 72 20 74 61 6c 29 29 29 29 29 29 0a 0a (cdr tal))))))..
0d30: 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 66 (define (tests:f
0d40: 69 6c 74 65 72 2d 74 65 73 74 2d 6e 61 6d 65 73 ilter-test-names
0d50: 2d 6e 6f 74 2d 6d 61 74 63 68 65 64 20 74 65 73 -not-matched tes
0d60: 74 2d 6e 61 6d 65 73 20 74 65 73 74 2d 70 61 74 t-names test-pat
0d70: 74 73 29 0a 20 20 28 64 65 6c 65 74 65 2d 64 75 ts). (delete-du
0d80: 70 6c 69 63 61 74 65 73 0a 20 20 20 28 66 69 6c plicates. (fil
0d90: 74 65 72 20 28 6c 61 6d 62 64 61 20 28 74 65 73 ter (lambda (tes
0da0: 74 6e 61 6d 65 29 0a 09 20 20 20 20 20 28 6e 6f tname).. (no
0db0: 74 20 28 74 65 73 74 73 3a 6d 61 74 63 68 20 74 t (tests:match t
0dc0: 65 73 74 2d 70 61 74 74 73 20 74 65 73 74 6e 61 est-patts testna
0dd0: 6d 65 20 23 66 29 29 29 0a 09 20 20 20 74 65 73 me #f))).. tes
0de0: 74 2d 6e 61 6d 65 73 29 29 29 0a 0a 0a 28 64 65 t-names)))...(de
0df0: 66 69 6e 65 20 28 74 65 73 74 73 3a 66 69 6c 74 fine (tests:filt
0e00: 65 72 2d 74 65 73 74 2d 6e 61 6d 65 73 20 74 65 er-test-names te
0e10: 73 74 2d 6e 61 6d 65 73 20 74 65 73 74 2d 70 61 st-names test-pa
0e20: 74 74 73 29 0a 20 20 28 64 65 6c 65 74 65 2d 64 tts). (delete-d
0e30: 75 70 6c 69 63 61 74 65 73 0a 20 20 20 28 66 69 uplicates. (fi
0e40: 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 74 65 lter (lambda (te
0e50: 73 74 6e 61 6d 65 29 0a 09 20 20 20 20 20 28 74 stname).. (t
0e60: 65 73 74 73 3a 6d 61 74 63 68 20 74 65 73 74 2d ests:match test-
0e70: 70 61 74 74 73 20 74 65 73 74 6e 61 6d 65 20 23 patts testname #
0e80: 66 29 29 0a 09 20 20 20 74 65 73 74 2d 6e 61 6d f)).. test-nam
0e90: 65 73 29 29 29 0a 0a 3b 3b 20 69 74 65 6d 6d 61 es)))..;; itemma
0ea0: 70 20 69 73 20 61 20 6c 69 73 74 20 6f 66 20 74 p is a list of t
0eb0: 65 73 74 6e 61 6d 65 20 70 61 74 74 65 72 6e 73 estname patterns
0ec0: 20 74 6f 20 6d 61 70 73 0a 3b 3b 20 20 20 20 20 to maps.;;
0ed0: 74 65 73 74 31 20 2e 2a 2f 62 61 72 2f 28 5c 64 test1 .*/bar/(\d
0ee0: 2b 29 20 66 6f 6f 2f 5c 31 0a 3b 3b 20 20 20 20 +) foo/\1.;;
0ef0: 20 25 20 20 20 20 20 66 6f 6f 2f 28 5b 5e 2f 5d % foo/([^/]
0f00: 2b 29 20 20 5c 31 2f 62 61 72 0a 3b 3b 0a 3b 3b +) \1/bar.;;.;;
0f10: 20 23 20 4e 4f 54 45 3a 20 74 68 65 20 6c 69 6e # NOTE: the lin
0f20: 65 20 77 69 74 68 20 74 68 65 20 73 69 6e 67 6c e with the singl
0f30: 65 20 25 20 63 6f 75 6c 64 20 62 65 20 74 68 65 e % could be the
0f40: 20 72 65 73 75 6c 74 20 6f 66 0a 3b 3b 20 23 20 result of.;; #
0f50: 20 20 20 20 20 20 69 74 65 6d 6d 61 70 20 65 6e itemmap en
0f60: 74 72 79 20 69 6e 20 72 65 71 75 69 72 65 6d 65 try in requireme
0f70: 6e 74 73 20 28 6c 65 67 61 63 79 29 2e 20 54 68 nts (legacy). Th
0f80: 65 20 69 74 65 6d 6d 61 70 0a 3b 3b 20 23 20 20 e itemmap.;; #
0f90: 20 20 20 20 20 72 65 71 75 69 72 65 6d 65 6e 74 requirement
0fa0: 73 20 65 6e 74 72 79 20 69 73 20 64 65 70 72 65 s entry is depre
0fb0: 63 61 74 65 64 0a 3b 3b 0a 28 64 65 66 69 6e 65 cated.;;.(define
0fc0: 20 28 74 65 73 74 73 3a 67 65 74 2d 69 74 65 6d (tests:get-item
0fd0: 6d 61 70 73 20 74 63 6f 6e 66 69 67 29 0a 20 20 maps tconfig).
0fe0: 28 6c 65 74 20 28 28 62 61 73 65 2d 69 74 65 6d (let ((base-item
0ff0: 6d 61 70 20 20 28 63 6f 6e 66 69 67 66 3a 6c 6f map (configf:lo
1000: 6f 6b 75 70 20 74 63 6f 6e 66 69 67 20 22 72 65 okup tconfig "re
1010: 71 75 69 72 65 6d 65 6e 74 73 22 20 22 69 74 65 quirements" "ite
1020: 6d 6d 61 70 22 29 29 0a 09 28 69 74 65 6d 6d 61 mmap"))..(itemma
1030: 70 2d 74 61 62 6c 65 20 28 63 6f 6e 66 69 67 66 p-table (configf
1040: 3a 67 65 74 2d 73 65 63 74 69 6f 6e 20 74 63 6f :get-section tco
1050: 6e 66 69 67 20 22 69 74 65 6d 6d 61 70 22 29 29 nfig "itemmap"))
1060: 29 0a 20 20 20 20 28 61 70 70 65 6e 64 20 28 69 ). (append (i
1070: 66 20 62 61 73 65 2d 69 74 65 6d 6d 61 70 0a 09 f base-itemmap..
1080: 09 28 6c 69 73 74 20 28 6c 69 73 74 20 22 25 22 .(list (list "%"
1090: 20 62 61 73 65 2d 69 74 65 6d 6d 61 70 29 29 0a base-itemmap)).
10a0: 09 09 27 28 29 29 0a 09 20 20 20 20 28 69 66 20 ..'()).. (if
10b0: 69 74 65 6d 6d 61 70 2d 74 61 62 6c 65 0a 09 09 itemmap-table...
10c0: 69 74 65 6d 6d 61 70 2d 74 61 62 6c 65 0a 09 09 itemmap-table...
10d0: 27 28 29 29 29 29 29 0a 0a 3b 3b 20 67 69 76 65 '()))))..;; give
10e0: 6e 20 61 20 6c 69 73 74 20 6f 66 20 69 74 65 6d n a list of item
10f0: 6d 61 70 73 20 28 74 65 73 74 6e 61 6d 65 20 2e maps (testname .
1100: 20 6d 61 70 29 2c 20 72 65 74 75 72 6e 20 74 68 map), return th
1110: 65 20 66 69 72 73 74 20 6d 61 74 63 68 0a 3b 3b e first match.;;
1120: 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a .(define (tests:
1130: 6c 6f 6f 6b 75 70 2d 69 74 65 6d 6d 61 70 20 69 lookup-itemmap i
1140: 74 65 6d 6d 61 70 73 20 74 65 73 74 6e 61 6d 65 temmaps testname
1150: 29 0a 20 20 28 6c 65 74 20 28 28 62 65 73 74 2d ). (let ((best-
1160: 6d 61 74 63 68 65 73 20 28 66 69 6c 74 65 72 20 matches (filter
1170: 28 6c 61 6d 62 64 61 20 28 69 74 65 6d 6d 61 70 (lambda (itemmap
1180: 29 0a 09 09 09 09 28 74 65 73 74 73 3a 6d 61 74 ).....(tests:mat
1190: 63 68 20 28 63 61 72 20 69 74 65 6d 6d 61 70 29 ch (car itemmap)
11a0: 20 74 65 73 74 6e 61 6d 65 20 23 66 29 29 0a 09 testname #f))..
11b0: 09 09 20 20 20 20 20 20 69 74 65 6d 6d 61 70 73 .. itemmaps
11c0: 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 75 6c ))). (if (nul
11d0: 6c 3f 20 62 65 73 74 2d 6d 61 74 63 68 65 73 29 l? best-matches)
11e0: 0a 09 23 66 0a 09 28 6c 65 74 20 28 28 72 65 73 ..#f..(let ((res
11f0: 20 28 63 61 72 20 62 65 73 74 2d 6d 61 74 63 68 (car best-match
1200: 65 73 29 29 29 0a 09 20 20 3b 3b 20 28 64 65 62 es))).. ;; (deb
1210: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
1220: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 ult-log-port* "r
1230: 65 73 3d 22 20 72 65 73 29 0a 09 20 20 28 63 6f es=" res).. (co
1240: 6e 64 0a 09 20 20 20 28 28 73 74 72 69 6e 67 3f nd.. ((string?
1250: 20 72 65 73 29 20 72 65 73 29 20 3b 3b 3b 20 46 res) res) ;;; F
1260: 49 58 20 54 48 45 20 52 4f 4f 54 20 43 41 55 53 IX THE ROOT CAUS
1270: 45 20 48 45 52 45 20 2e 2e 2e 2e 0a 09 20 20 20 E HERE ......
1280: 28 28 6e 75 6c 6c 3f 20 72 65 73 29 20 20 20 23 ((null? res) #
1290: 66 29 0a 09 20 20 20 28 28 73 74 72 69 6e 67 3f f).. ((string?
12a0: 20 28 63 64 72 20 72 65 73 29 29 20 28 63 64 72 (cdr res)) (cdr
12b0: 20 72 65 73 29 29 20 20 3b 3b 20 69 74 20 69 73 res)) ;; it is
12c0: 20 61 20 70 61 69 72 0a 09 20 20 20 28 28 73 74 a pair.. ((st
12d0: 72 69 6e 67 3f 20 28 63 61 64 72 20 72 65 73 29 ring? (cadr res)
12e0: 29 28 63 61 64 72 20 72 65 73 29 29 20 3b 3b 20 )(cadr res)) ;;
12f0: 69 74 20 69 73 20 61 20 6c 69 73 74 0a 09 20 20 it is a list..
1300: 20 28 65 6c 73 65 20 63 61 64 72 20 72 65 73 29 (else cadr res)
1310: 29 29 29 29 29 0a 0a 3b 3b 20 72 65 74 75 72 6e )))))..;; return
1320: 20 69 74 65 6d 73 20 67 69 76 65 6e 20 63 6f 6e items given con
1330: 66 69 67 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 fig.;;.(define (
1340: 74 65 73 74 73 3a 67 65 74 2d 69 74 65 6d 73 20 tests:get-items
1350: 74 63 6f 6e 66 69 67 29 0a 20 20 28 6c 65 74 20 tconfig). (let
1360: 28 28 69 74 65 6d 73 20 20 20 20 20 20 28 68 61 ((items (ha
1370: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
1380: 61 75 6c 74 20 74 63 6f 6e 66 69 67 20 22 69 74 ault tconfig "it
1390: 65 6d 73 22 20 23 66 29 29 20 3b 3b 20 69 74 65 ems" #f)) ;; ite
13a0: 6d 73 20 34 0a 09 28 69 74 65 6d 73 74 61 62 6c ms 4..(itemstabl
13b0: 65 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 e (hash-table-re
13c0: 66 2f 64 65 66 61 75 6c 74 20 74 63 6f 6e 66 69 f/default tconfi
13d0: 67 20 22 69 74 65 6d 73 74 61 62 6c 65 22 20 23 g "itemstable" #
13e0: 66 29 29 29 20 0a 20 20 20 20 3b 3b 20 69 66 20 f))) . ;; if
13f0: 65 69 74 68 65 72 20 69 74 65 6d 73 20 6f 72 20 either items or
1400: 69 74 65 6d 73 20 74 61 62 6c 65 20 69 73 20 61 items table is a
1410: 20 70 72 6f 63 20 72 65 74 75 72 6e 20 69 74 20 proc return it
1420: 73 6f 20 74 65 73 74 20 72 75 6e 6e 69 6e 67 0a so test running.
1430: 20 20 20 20 3b 3b 20 70 72 6f 63 65 73 73 20 63 ;; process c
1440: 61 6e 20 6b 6e 6f 77 20 74 6f 20 63 61 6c 6c 20 an know to call
1450: 69 74 65 6d 73 3a 67 65 74 2d 69 74 65 6d 73 2d items:get-items-
1460: 66 72 6f 6d 2d 63 6f 6e 66 69 67 0a 20 20 20 20 from-config.
1470: 3b 3b 20 69 66 20 65 69 74 68 65 72 20 69 73 20 ;; if either is
1480: 61 20 6c 69 73 74 20 61 6e 64 20 6e 6f 6e 65 20 a list and none
1490: 69 73 20 61 20 70 72 6f 63 20 67 6f 20 61 68 65 is a proc go ahe
14a0: 61 64 20 61 6e 64 20 63 61 6c 6c 20 67 65 74 2d ad and call get-
14b0: 69 74 65 6d 73 0a 20 20 20 20 3b 3b 20 6f 74 68 items. ;; oth
14c0: 65 72 77 69 73 65 20 72 65 74 75 72 6e 20 23 66 erwise return #f
14d0: 20 2d 20 74 68 69 73 20 69 73 20 6e 6f 74 20 61 - this is not a
14e0: 6e 20 69 74 65 72 61 74 65 64 20 74 65 73 74 0a n iterated test.
14f0: 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 28 (cond. (
1500: 28 70 72 6f 63 65 64 75 72 65 3f 20 69 74 65 6d (procedure? item
1510: 73 29 20 20 20 20 20 20 0a 20 20 20 20 20 20 28 s) . (
1520: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
1530: 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 4 *default-log-
1540: 70 6f 72 74 2a 20 22 69 74 65 6d 73 20 69 73 20 port* "items is
1550: 61 20 70 72 6f 63 65 64 75 72 65 2c 20 77 69 6c a procedure, wil
1560: 6c 20 63 61 6c 63 20 6c 61 74 65 72 22 29 0a 20 l calc later").
1570: 20 20 20 20 20 69 74 65 6d 73 29 20 20 20 20 20 items)
1580: 20 20 20 20 20 20 20 3b 3b 20 63 61 6c 63 20 6c ;; calc l
1590: 61 74 65 72 0a 20 20 20 20 20 28 28 70 72 6f 63 ater. ((proc
15a0: 65 64 75 72 65 3f 20 69 74 65 6d 73 74 61 62 6c edure? itemstabl
15b0: 65 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a e). (debug:
15c0: 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 2a 64 65 print-info 4 *de
15d0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
15e0: 22 69 74 65 6d 73 74 61 62 6c 65 20 69 73 20 61 "itemstable is a
15f0: 20 70 72 6f 63 65 64 75 72 65 2c 20 77 69 6c 6c procedure, will
1600: 20 63 61 6c 63 20 6c 61 74 65 72 22 29 0a 20 20 calc later").
1610: 20 20 20 20 69 74 65 6d 73 74 61 62 6c 65 29 20 itemstable)
1620: 20 20 20 20 20 20 3b 3b 20 63 61 6c 63 20 6c 61 ;; calc la
1630: 74 65 72 0a 20 20 20 20 20 28 28 66 69 6c 74 65 ter. ((filte
1640: 72 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 09 r (lambda (x)...
1650: 28 6c 65 74 20 28 28 76 61 6c 20 28 63 61 72 20 (let ((val (car
1660: 78 29 29 29 0a 09 09 20 20 28 69 66 20 28 70 72 x)))... (if (pr
1670: 6f 63 65 64 75 72 65 3f 20 76 61 6c 29 20 76 61 ocedure? val) va
1680: 6c 20 23 66 29 29 29 0a 09 20 20 20 20 20 20 28 l #f))).. (
1690: 61 70 70 65 6e 64 20 28 69 66 20 28 6c 69 73 74 append (if (list
16a0: 3f 20 69 74 65 6d 73 29 20 69 74 65 6d 73 20 27 ? items) items '
16b0: 28 29 29 0a 09 09 20 20 20 20 20 20 28 69 66 20 ())... (if
16c0: 28 6c 69 73 74 3f 20 69 74 65 6d 73 74 61 62 6c (list? itemstabl
16d0: 65 29 20 69 74 65 6d 73 74 61 62 6c 65 20 27 28 e) itemstable '(
16e0: 29 29 29 29 0a 20 20 20 20 20 20 27 68 61 76 65 )))). 'have
16f0: 2d 70 72 6f 63 65 64 75 72 65 29 0a 20 20 20 20 -procedure).
1700: 20 28 28 6f 72 20 28 6c 69 73 74 3f 20 69 74 65 ((or (list? ite
1710: 6d 73 29 28 6c 69 73 74 3f 20 69 74 65 6d 73 74 ms)(list? itemst
1720: 61 62 6c 65 29 29 20 3b 3b 20 63 61 6c 63 20 6e able)) ;; calc n
1730: 6f 77 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a ow. (debug:
1740: 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 2a 64 65 print-info 4 *de
1750: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
1760: 22 69 74 65 6d 73 20 61 6e 64 20 69 74 65 6d 73 "items and items
1770: 74 61 62 6c 65 20 61 72 65 20 6c 69 73 74 73 2c table are lists,
1780: 20 63 61 6c 63 20 6e 6f 77 5c 6e 22 0a 09 09 09 calc now\n"....
1790: 22 20 20 20 20 69 74 65 6d 73 3a 20 22 20 69 74 " items: " it
17a0: 65 6d 73 20 22 20 69 74 65 6d 73 74 61 62 6c 65 ems " itemstable
17b0: 3a 20 22 20 69 74 65 6d 73 74 61 62 6c 65 29 0a : " itemstable).
17c0: 20 20 20 20 20 20 28 69 74 65 6d 73 3a 67 65 74 (items:get
17d0: 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 -items-from-conf
17e0: 69 67 20 74 63 6f 6e 66 69 67 29 29 0a 20 20 20 ig tconfig)).
17f0: 20 20 28 65 6c 73 65 20 23 66 29 29 29 29 20 20 (else #f))))
1800: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1810: 20 20 20 20 20 20 20 20 20 3b 3b 20 6e 6f 74 20 ;; not
1820: 69 74 65 72 61 74 65 64 0a 0a 0a 3b 3b 20 72 65 iterated...;; re
1830: 74 75 72 6e 73 20 77 61 69 74 6f 6e 73 20 77 61 turns waitons wa
1840: 69 74 6f 72 73 20 74 63 6f 6e 66 69 67 64 61 74 itors tconfigdat
1850: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 65 73 .;;.(define (tes
1860: 74 73 3a 67 65 74 2d 77 61 69 74 6f 6e 73 20 74 ts:get-waitons t
1870: 65 73 74 2d 6e 61 6d 65 20 61 6c 6c 2d 74 65 73 est-name all-tes
1880: 74 73 2d 72 65 67 69 73 74 72 79 29 0a 20 20 20 ts-registry).
1890: 28 6c 65 74 2a 20 28 28 63 6f 6e 66 69 67 20 20 (let* ((config
18a0: 28 74 65 73 74 73 3a 67 65 74 2d 74 65 73 74 63 (tests:get-testc
18b0: 6f 6e 66 69 67 20 74 65 73 74 2d 6e 61 6d 65 20 onfig test-name
18c0: 23 66 20 61 6c 6c 2d 74 65 73 74 73 2d 72 65 67 #f all-tests-reg
18d0: 69 73 74 72 79 20 27 72 65 74 75 72 6e 2d 70 72 istry 'return-pr
18e0: 6f 63 73 29 29 29 20 3b 3b 20 61 73 73 75 6d 69 ocs))) ;; assumi
18f0: 6e 67 20 6e 6f 20 70 72 6f 62 6c 65 6d 73 20 77 ng no problems w
1900: 69 74 68 20 69 6d 6d 65 64 69 61 74 65 20 65 76 ith immediate ev
1910: 61 6c 75 61 74 69 6f 6e 2c 20 74 68 69 73 20 63 aluation, this c
1920: 6f 75 6c 64 20 62 65 20 73 69 6d 70 6c 69 66 69 ould be simplifi
1930: 65 64 20 28 27 72 65 74 75 72 6e 2d 70 72 6f 63 ed ('return-proc
1940: 73 20 2d 3e 20 23 74 29 0a 20 20 20 20 20 28 6c s -> #t). (l
1950: 65 74 20 28 28 69 6e 73 74 72 20 28 69 66 20 63 et ((instr (if c
1960: 6f 6e 66 69 67 20 0a 09 09 20 20 20 20 20 20 28 onfig ... (
1970: 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 63 configf:lookup c
1980: 6f 6e 66 69 67 20 22 72 65 71 75 69 72 65 6d 65 onfig "requireme
1990: 6e 74 73 22 20 22 77 61 69 74 6f 6e 22 29 0a 09 nts" "waiton")..
19a0: 09 20 20 20 20 20 20 28 62 65 67 69 6e 20 3b 3b . (begin ;;
19b0: 20 4e 6f 20 63 6f 6e 66 69 67 20 6d 65 61 6e 73 No config means
19c0: 20 74 68 69 73 20 69 73 20 61 20 6e 6f 6e 2d 65 this is a non-e
19d0: 78 69 73 74 61 6e 74 20 74 65 73 74 0a 09 09 09 xistant test....
19e0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 (debug:print-err
19f0: 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f or 0 *default-lo
1a00: 67 2d 70 6f 72 74 2a 20 22 6e 6f 6e 2d 65 78 69 g-port* "non-exi
1a10: 73 74 65 6e 74 20 72 65 71 75 69 72 65 64 20 74 stent required t
1a20: 65 73 74 20 5c 22 22 20 74 65 73 74 2d 6e 61 6d est \"" test-nam
1a30: 65 20 22 5c 22 22 29 0a 09 09 09 28 65 78 69 74 e "\"")....(exit
1a40: 20 31 29 29 29 29 0a 09 20 20 20 28 69 6e 73 74 1)))).. (inst
1a50: 72 32 20 28 69 66 20 63 6f 6e 66 69 67 0a 09 09 r2 (if config...
1a60: 20 20 20 20 20 20 20 28 63 6f 6e 66 69 67 66 3a (configf:
1a70: 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 20 22 72 lookup config "r
1a80: 65 71 75 69 72 65 6d 65 6e 74 73 22 20 22 77 61 equirements" "wa
1a90: 69 74 6f 72 22 29 0a 09 09 20 20 20 20 20 20 20 itor")...
1aa0: 22 22 29 29 29 0a 20 20 20 20 20 20 20 28 64 65 ""))). (de
1ab0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 38 bug:print-info 8
1ac0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
1ad0: 72 74 2a 20 22 77 61 69 74 6f 6e 73 20 73 74 72 rt* "waitons str
1ae0: 69 6e 67 20 69 73 20 22 20 69 6e 73 74 72 20 22 ing is " instr "
1af0: 2c 20 77 61 69 74 6f 72 73 20 73 74 72 69 6e 67 , waitors string
1b00: 20 69 73 20 22 20 69 6e 73 74 72 32 29 0a 20 20 is " instr2).
1b10: 20 20 20 20 20 28 6c 65 74 20 28 28 6e 65 77 77 (let ((neww
1b20: 61 69 74 6f 6e 73 0a 09 20 20 20 20 20 20 28 73 aitons.. (s
1b30: 74 72 69 6e 67 2d 73 70 6c 69 74 20 28 63 6f 6e tring-split (con
1b40: 64 0a 09 09 09 20 20 20 20 20 28 28 70 72 6f 63 d.... ((proc
1b50: 65 64 75 72 65 3f 20 69 6e 73 74 72 29 20 3b 3b edure? instr) ;;
1b60: 20 68 65 72 65 20 0a 09 09 09 20 20 20 20 20 20 here ....
1b70: 28 6c 65 74 20 28 28 72 65 73 20 28 69 6e 73 74 (let ((res (inst
1b80: 72 29 29 29 0a 09 09 09 09 28 64 65 62 75 67 3a r))).....(debug:
1b90: 70 72 69 6e 74 2d 69 6e 66 6f 20 38 20 2a 64 65 print-info 8 *de
1ba0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
1bb0: 22 77 61 69 74 6f 6e 20 70 72 6f 63 65 64 75 72 "waiton procedur
1bc0: 65 20 72 65 73 75 6c 74 73 20 69 6e 20 73 74 72 e results in str
1bd0: 69 6e 67 20 22 20 72 65 73 20 22 20 66 6f 72 20 ing " res " for
1be0: 74 65 73 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 test " test-name
1bf0: 29 0a 09 09 09 09 72 65 73 29 29 0a 09 09 09 20 ).....res))....
1c00: 20 20 20 20 28 28 73 74 72 69 6e 67 3f 20 69 6e ((string? in
1c10: 73 74 72 29 20 20 20 20 20 69 6e 73 74 72 29 0a str) instr).
1c20: 09 09 09 20 20 20 20 20 28 65 6c 73 65 20 0a 09 ... (else ..
1c30: 09 09 20 20 20 20 20 20 3b 3b 20 4e 4f 54 45 3a .. ;; NOTE:
1c40: 20 54 68 69 73 20 69 73 20 61 63 74 75 61 6c 6c This is actuall
1c50: 79 20 74 68 65 20 63 61 73 65 20 6f 66 20 2a 6e y the case of *n
1c60: 6f 2a 20 77 61 69 74 6f 6e 73 21 20 3b 3b 20 28 o* waitons! ;; (
1c70: 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f debug:print-erro
1c80: 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 r 0 *default-log
1c90: 2d 70 6f 72 74 2a 20 22 73 6f 6d 65 74 68 69 6e -port* "somethin
1ca0: 67 20 77 65 6e 74 20 77 72 6f 6e 67 20 69 6e 20 g went wrong in
1cb0: 70 72 6f 63 65 73 73 69 6e 67 20 77 61 69 74 6f processing waito
1cc0: 6e 73 20 66 6f 72 20 74 65 73 74 20 22 20 74 65 ns for test " te
1cd0: 73 74 2d 6e 61 6d 65 29 0a 09 09 09 20 20 20 20 st-name)....
1ce0: 20 20 22 22 29 29 29 29 0a 09 20 20 20 20 20 28 "")))).. (
1cf0: 6e 65 77 77 61 69 74 6f 72 73 0a 09 20 20 20 20 newwaitors..
1d00: 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 (string-split
1d10: 28 63 6f 6e 64 0a 09 09 09 20 20 20 20 20 28 28 (cond.... ((
1d20: 70 72 6f 63 65 64 75 72 65 3f 20 69 6e 73 74 72 procedure? instr
1d30: 32 29 0a 09 09 09 20 20 20 20 20 20 28 6c 65 74 2).... (let
1d40: 20 28 28 72 65 73 20 28 69 6e 73 74 72 32 29 29 ((res (instr2))
1d50: 29 0a 09 09 09 09 28 64 65 62 75 67 3a 70 72 69 ).....(debug:pri
1d60: 6e 74 2d 69 6e 66 6f 20 38 20 2a 64 65 66 61 75 nt-info 8 *defau
1d70: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 77 61 lt-log-port* "wa
1d80: 69 74 6f 72 20 70 72 6f 63 65 64 75 72 65 20 72 itor procedure r
1d90: 65 73 75 6c 74 73 20 69 6e 20 73 74 72 69 6e 67 esults in string
1da0: 20 22 20 72 65 73 20 22 20 66 6f 72 20 74 65 73 " res " for tes
1db0: 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 29 0a 09 t " test-name)..
1dc0: 09 09 09 72 65 73 29 29 0a 09 09 09 20 20 20 20 ...res))....
1dd0: 20 28 28 73 74 72 69 6e 67 3f 20 69 6e 73 74 72 ((string? instr
1de0: 32 29 20 20 20 20 20 69 6e 73 74 72 32 29 0a 09 2) instr2)..
1df0: 09 09 20 20 20 20 20 28 65 6c 73 65 20 0a 09 09 .. (else ...
1e00: 09 20 20 20 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 . ;; NOTE:
1e10: 54 68 69 73 20 69 73 20 61 63 74 75 61 6c 6c 79 This is actually
1e20: 20 74 68 65 20 63 61 73 65 20 6f 66 20 2a 6e 6f the case of *no
1e30: 2a 20 77 61 69 74 6f 6e 73 21 20 3b 3b 20 28 64 * waitons! ;; (d
1e40: 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 ebug:print-error
1e50: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
1e60: 70 6f 72 74 2a 20 22 73 6f 6d 65 74 68 69 6e 67 port* "something
1e70: 20 77 65 6e 74 20 77 72 6f 6e 67 20 69 6e 20 70 went wrong in p
1e80: 72 6f 63 65 73 73 69 6e 67 20 77 61 69 74 6f 6e rocessing waiton
1e90: 73 20 66 6f 72 20 74 65 73 74 20 22 20 74 65 73 s for test " tes
1ea0: 74 2d 6e 61 6d 65 29 0a 09 09 09 20 20 20 20 20 t-name)....
1eb0: 20 22 22 29 29 29 29 29 0a 09 20 28 76 61 6c 75 ""))))).. (valu
1ec0: 65 73 0a 09 20 20 3b 3b 20 74 68 65 20 77 61 69 es.. ;; the wai
1ed0: 74 6f 6e 73 0a 09 20 20 28 66 69 6c 74 65 72 20 tons.. (filter
1ee0: 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 09 20 20 (lambda (x)...
1ef0: 20 20 28 69 66 20 28 68 61 73 68 2d 74 61 62 6c (if (hash-tabl
1f00: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 61 6c e-ref/default al
1f10: 6c 2d 74 65 73 74 73 2d 72 65 67 69 73 74 72 79 l-tests-registry
1f20: 20 78 20 23 66 29 0a 09 09 09 23 74 0a 09 09 09 x #f)....#t....
1f30: 28 62 65 67 69 6e 0a 09 09 09 20 20 28 64 65 62 (begin.... (deb
1f40: 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 ug:print-error 0
1f50: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
1f60: 72 74 2a 20 22 74 65 73 74 20 22 20 74 65 73 74 rt* "test " test
1f70: 2d 6e 61 6d 65 20 22 20 68 61 73 20 75 6e 72 65 -name " has unre
1f80: 63 6f 67 6e 69 73 65 64 20 77 61 69 74 6f 6e 20 cognised waiton
1f90: 74 65 73 74 6e 61 6d 65 20 22 20 78 29 0a 09 09 testname " x)...
1fa0: 09 20 20 23 66 29 29 29 0a 09 09 20 20 6e 65 77 . #f)))... new
1fb0: 77 61 69 74 6f 6e 73 29 0a 09 20 20 28 66 69 6c waitons).. (fil
1fc0: 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 0a ter (lambda (x).
1fd0: 09 09 20 20 20 20 28 69 66 20 28 68 61 73 68 2d .. (if (hash-
1fe0: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
1ff0: 74 20 61 6c 6c 2d 74 65 73 74 73 2d 72 65 67 69 t all-tests-regi
2000: 73 74 72 79 20 78 20 23 66 29 0a 09 09 09 23 74 stry x #f)....#t
2010: 0a 09 09 09 28 62 65 67 69 6e 0a 09 09 09 20 20 ....(begin....
2020: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 (debug:print-err
2030: 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f or 0 *default-lo
2040: 67 2d 70 6f 72 74 2a 20 22 74 65 73 74 20 22 20 g-port* "test "
2050: 74 65 73 74 2d 6e 61 6d 65 20 22 20 68 61 73 20 test-name " has
2060: 75 6e 72 65 63 6f 67 6e 69 73 65 64 20 77 61 69 unrecognised wai
2070: 74 6f 6e 20 74 65 73 74 6e 61 6d 65 20 22 20 78 ton testname " x
2080: 29 0a 09 09 09 20 20 23 66 29 29 29 0a 09 09 20 ).... #f)))...
2090: 20 6e 65 77 77 61 69 74 6f 72 73 29 0a 09 20 20 newwaitors)..
20a0: 63 6f 6e 66 69 67 29 29 29 29 29 0a 09 09 09 09 config))))).....
20b0: 09 20 20 20 20 20 0a 3b 3b 20 67 69 76 65 6e 20 . .;; given
20c0: 77 61 69 74 69 6e 67 2d 74 65 73 74 20 74 68 61 waiting-test tha
20d0: 74 20 69 73 20 77 61 69 74 69 6e 67 20 6f 6e 20 t is waiting on
20e0: 77 61 69 74 6f 6e 2d 74 65 73 74 20 65 78 74 65 waiton-test exte
20f0: 6e 64 20 74 65 73 74 2d 70 61 74 74 20 61 70 70 nd test-patt app
2100: 72 6f 70 72 69 61 74 65 6c 79 0a 3b 3b 0a 3b 3b ropriately.;;.;;
2110: 20 20 67 65 6e 6c 69 62 2f 74 65 73 74 63 6f 6e genlib/testcon
2120: 66 69 67 20 20 20 20 20 20 20 20 20 20 20 20 20 fig
2130: 20 20 73 69 6d 2f 74 65 73 74 63 6f 6e 66 69 67 sim/testconfig
2140: 0a 3b 3b 20 20 67 65 6e 6c 69 62 2f 73 63 68 20 .;; genlib/sch
2150: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2160: 20 20 20 20 20 73 69 6d 2f 73 63 68 2f 63 65 6c sim/sch/cel
2170: 6c 31 0a 3b 3b 0a 3b 3b 20 20 5b 72 65 71 75 69 l1.;;.;; [requi
2180: 72 65 6d 65 6e 74 73 5d 20 20 20 20 20 20 20 20 rements]
2190: 20 20 20 20 20 20 20 20 20 20 5b 72 65 71 75 69 [requi
21a0: 72 65 6d 65 6e 74 73 5d 0a 3b 3b 20 20 20 20 20 rements].;;
21b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
21c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 6d 6f 64 mod
21d0: 65 20 69 74 65 6d 77 61 69 74 0a 3b 3b 20 20 20 e itemwait.;;
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 20 20 20 20 20 23 #
2200: 20 74 72 69 6d 20 6f 66 66 20 74 68 65 20 63 65 trim off the ce
2210: 6c 6c 20 74 6f 20 64 65 74 65 72 6d 69 6e 65 20 ll to determine
2220: 77 68 61 74 20 74 6f 20 72 75 6e 20 66 6f 72 20 what to run for
2230: 67 65 6e 6c 69 62 0a 3b 3b 20 20 20 20 20 20 20 genlib.;;
2240: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2250: 20 20 20 20 20 20 20 20 20 20 20 69 74 65 6d 6d itemm
2260: 61 70 20 2f 2e 2a 0a 3b 3b 0a 3b 3b 20 20 20 20 ap /.*.;;.;;
2270: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2280: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 77 61 wa
2290: 69 74 69 6e 67 2d 74 65 73 74 20 69 73 20 77 61 iting-test is wa
22a0: 69 74 69 6e 67 20 6f 6e 20 77 61 69 74 6f 6e 2d iting on waiton-
22b0: 74 65 73 74 20 73 6f 20 77 65 20 6e 65 65 64 20 test so we need
22c0: 74 6f 20 63 72 65 61 74 65 20 61 20 70 61 74 74 to create a patt
22d0: 65 72 6e 20 66 6f 72 20 77 61 69 74 6f 6e 2d 74 ern for waiton-t
22e0: 65 73 74 20 67 69 76 65 6e 20 77 61 69 74 69 6e est given waitin
22f0: 67 2d 74 65 73 74 20 61 6e 64 20 69 74 65 6d 6d g-test and itemm
2300: 61 70 0a 3b 3b 20 42 42 3e 20 28 74 65 73 74 73 ap.;; BB> (tests
2310: 3a 65 78 74 65 6e 64 2d 74 65 73 74 2d 70 61 74 :extend-test-pat
2320: 74 73 20 22 6e 6f 72 6d 61 6c 2d 73 65 63 6f 6e ts "normal-secon
2330: 64 2f 32 22 20 22 6e 6f 72 6d 61 6c 2d 73 65 63 d/2" "normal-sec
2340: 6f 6e 64 22 20 22 6e 6f 72 6d 61 6c 2d 66 69 72 ond" "normal-fir
2350: 73 74 22 20 27 28 29 29 0a 3b 3b 20 6f 62 73 65 st" '()).;; obse
2360: 72 76 65 64 20 2d 3e 20 22 6e 6f 72 6d 61 6c 2d rved -> "normal-
2370: 66 69 72 73 74 2f 32 2c 6e 6f 72 6d 61 6c 2d 66 first/2,normal-f
2380: 69 72 73 74 2f 2c 6e 6f 72 6d 61 6c 2d 73 65 63 irst/,normal-sec
2390: 6f 6e 64 2f 32 2c 6e 6f 72 6d 61 6c 2d 73 65 63 ond/2,normal-sec
23a0: 6f 6e 64 2f 22 0a 3b 3b 20 65 78 70 65 63 74 65 ond/".;; expecte
23b0: 64 20 2d 3e 20 22 6e 6f 72 6d 61 6c 2d 66 69 72 d -> "normal-fir
23c0: 73 74 2c 6e 6f 72 6d 61 6c 2d 73 65 63 6f 6e 64 st,normal-second
23d0: 2f 32 2c 6e 6f 72 6d 61 6c 2d 73 65 63 6f 6e 64 /2,normal-second
23e0: 2f 22 0a 3b 3b 20 74 65 73 74 70 61 74 74 20 3d /".;; testpatt =
23f0: 20 6e 6f 72 6d 61 6c 2d 73 65 63 6f 6e 64 2f 32 normal-second/2
2400: 0a 3b 3b 20 77 61 69 74 69 6e 67 2d 74 65 73 74 .;; waiting-test
2410: 20 3d 20 6e 6f 72 6d 61 6c 2d 73 65 63 6f 6e 64 = normal-second
2420: 0a 3b 3b 20 77 61 69 74 6f 6e 2d 74 65 73 74 20 .;; waiton-test
2430: 3d 20 6e 6f 72 6d 61 6c 2d 66 69 72 73 74 0a 3b = normal-first.;
2440: 3b 20 69 74 65 6d 6d 61 70 73 20 3d 20 28 29 0a ; itemmaps = ().
2450: 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a .(define (tests:
2460: 65 78 74 65 6e 64 2d 74 65 73 74 2d 70 61 74 74 extend-test-patt
2470: 73 20 74 65 73 74 2d 70 61 74 74 20 77 61 69 74 s test-patt wait
2480: 69 6e 67 2d 74 65 73 74 20 77 61 69 74 6f 6e 2d ing-test waiton-
2490: 74 65 73 74 20 69 74 65 6d 6d 61 70 73 20 69 74 test itemmaps it
24a0: 65 6d 69 7a 65 64 2d 77 61 69 74 6f 6e 29 0a 20 emized-waiton).
24b0: 20 28 63 6f 6e 64 0a 20 20 20 28 69 74 65 6d 69 (cond. (itemi
24c0: 7a 65 64 2d 77 61 69 74 6f 6e 0a 20 20 20 20 28 zed-waiton. (
24d0: 6c 65 74 2a 20 28 28 69 74 65 6d 6d 61 70 20 20 let* ((itemmap
24e0: 20 20 20 20 20 20 20 20 28 74 65 73 74 73 3a 6c (tests:l
24f0: 6f 6f 6b 75 70 2d 69 74 65 6d 6d 61 70 20 69 74 ookup-itemmap it
2500: 65 6d 6d 61 70 73 20 77 61 69 74 6f 6e 2d 74 65 emmaps waiton-te
2510: 73 74 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 st)).
2520: 28 70 61 74 74 73 20 20 20 20 20 20 20 20 20 20 (patts
2530: 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 (string-split
2540: 74 65 73 74 2d 70 61 74 74 20 22 2c 22 29 29 0a test-patt ",")).
2550: 20 20 20 20 20 20 20 20 20 20 20 28 77 61 69 74 (wait
2560: 69 6e 67 2d 74 65 73 74 2d 6c 65 6e 20 28 2b 20 ing-test-len (+
2570: 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 77 (string-length w
2580: 61 69 74 69 6e 67 2d 74 65 73 74 29 20 31 29 29 aiting-test) 1))
2590: 0a 20 20 20 20 20 20 20 20 20 20 20 28 70 61 74 . (pat
25a0: 74 73 2d 77 61 69 74 6f 6e 20 20 20 20 20 28 6d ts-waiton (m
25b0: 61 70 20 28 6c 61 6d 62 64 61 20 28 78 29 20 20 ap (lambda (x)
25c0: 3b 3b 20 66 6f 72 20 65 61 63 68 20 69 6e 63 6f ;; for each inco
25d0: 6d 69 6e 67 20 70 61 74 74 20 74 68 61 74 20 6d ming patt that m
25e0: 61 74 63 68 65 73 20 74 68 65 20 77 61 69 74 69 atches the waiti
25f0: 6e 67 20 74 65 73 74 0a 20 20 20 20 20 20 20 20 ng test.
2600: 20 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 28 6c 65 74 (let
2620: 2a 20 28 28 6d 6f 64 70 61 74 74 20 28 69 66 20 * ((modpatt (if
2630: 69 74 65 6d 6d 61 70 20 28 64 62 3a 63 6f 6e 76 itemmap (db:conv
2640: 65 72 74 2d 74 65 73 74 2d 69 74 65 6d 70 61 74 ert-test-itempat
2650: 68 20 78 20 69 74 65 6d 6d 61 70 29 20 78 29 29 h x itemmap) x))
2660: 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
2670: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2680: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6e 65 (ne
2690: 77 70 61 74 74 20 28 63 6f 6e 63 20 77 61 69 74 wpatt (conc wait
26a0: 6f 6e 2d 74 65 73 74 20 22 2f 22 20 28 73 75 62 on-test "/" (sub
26b0: 73 74 72 69 6e 67 20 6d 6f 64 70 61 74 74 20 77 string modpatt w
26c0: 61 69 74 69 6e 67 2d 74 65 73 74 2d 6c 65 6e 20 aiting-test-len
26d0: 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 6d (string-length m
26e0: 6f 64 70 61 74 74 29 29 29 29 29 0a 20 20 20 20 odpatt))))).
26f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2700: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2710: 20 20 3b 3b 20 28 63 6f 6e 63 20 77 61 69 74 69 ;; (conc waiti
2720: 6e 67 2d 74 65 73 74 20 22 2f 2c 22 20 77 61 69 ng-test "/," wai
2730: 74 69 6e 67 2d 74 65 73 74 20 22 2f 22 20 28 73 ting-test "/" (s
2740: 75 62 73 74 72 69 6e 67 20 6d 6f 64 70 61 74 74 ubstring modpatt
2750: 20 77 61 69 74 6f 6e 2d 74 65 73 74 2d 6c 65 6e waiton-test-len
2760: 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 (string-length
2770: 6d 6f 64 70 61 74 74 29 29 29 29 29 0a 20 20 20 modpatt))))).
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 20 20 20 20 20 20 20 20 20
27a0: 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 69 6e ;; (print "in
27b0: 20 6d 61 70 2c 20 78 3d 22 20 78 20 22 2c 20 6e map, x=" x ", n
27c0: 65 77 70 61 74 74 3d 22 20 6e 65 77 70 61 74 74 ewpatt=" newpatt
27d0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
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 6e 65 77 70 61 74 74 29 newpatt)
2800: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
2810: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2820: 20 20 20 20 28 66 69 6c 74 65 72 20 28 6c 61 6d (filter (lam
2830: 62 64 61 20 28 78 29 0a 20 20 20 20 20 20 20 20 bda (x).
2840: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2850: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2860: 20 20 20 20 28 65 71 3f 20 28 73 75 62 73 74 72 (eq? (substr
2870: 69 6e 67 2d 69 6e 64 65 78 20 28 63 6f 6e 63 20 ing-index (conc
2880: 77 61 69 74 69 6e 67 2d 74 65 73 74 20 22 2f 22 waiting-test "/"
2890: 29 20 78 29 20 30 29 29 20 3b 3b 20 69 73 20 74 ) x) 0)) ;; is t
28a0: 68 69 73 20 70 61 74 74 20 70 65 72 74 69 6e 65 his patt pertine
28b0: 6e 74 20 74 6f 20 74 68 65 20 77 61 69 74 69 6e nt to the waitin
28c0: 67 20 74 65 73 74 0a 20 20 20 20 20 20 20 20 20 g test.
28d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
28e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
28f0: 20 70 61 74 74 73 29 29 29 0a 20 20 20 20 20 20 patts))).
2900: 20 20 20 20 20 28 65 78 74 65 6e 64 65 64 2d 74 (extended-t
2910: 65 73 74 2d 70 61 74 74 20 20 20 28 61 70 70 65 est-patt (appe
2920: 6e 64 20 70 61 74 74 73 20 28 69 66 20 28 6e 75 nd patts (if (nu
2930: 6c 6c 3f 20 70 61 74 74 73 2d 77 61 69 74 6f 6e ll? patts-waiton
2940: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
2950: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2960: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2970: 20 20 20 20 20 28 6c 69 73 74 20 28 63 6f 6e 63 (list (conc
2980: 20 77 61 69 74 6f 6e 2d 74 65 73 74 20 22 2f 25 waiton-test "/%
2990: 22 29 29 20 3b 3b 20 72 65 61 6c 6c 79 20 73 68 ")) ;; really sh
29a0: 6f 75 6c 64 6e 27 74 20 61 64 64 20 74 68 65 20 ouldn't add the
29b0: 77 61 69 74 6f 6e 20 66 6f 72 63 65 66 75 6c 6c waiton forcefull
29c0: 79 20 6c 69 6b 65 20 74 68 69 73 0a 20 20 20 20 y like this.
29d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
29e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
29f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 70 p
2a00: 61 74 74 73 2d 77 61 69 74 6f 6e 29 29 29 0a 20 atts-waiton))).
2a10: 20 20 20 20 20 20 20 20 20 20 28 65 78 74 65 6e (exten
2a20: 64 65 64 2d 74 65 73 74 2d 70 61 74 74 2d 77 69 ded-test-patt-wi
2a30: 74 68 2d 74 6f 70 6c 65 76 65 6c 73 0a 20 20 20 th-toplevels.
2a40: 20 20 20 20 20 20 20 20 20 28 66 6f 6c 64 20 28 (fold (
2a50: 6c 61 6d 62 64 61 20 28 74 65 73 74 70 61 74 74 lambda (testpatt
2a60: 2d 69 74 65 6d 20 61 63 63 75 6d 20 29 0a 20 20 -item accum ).
2a70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2a80: 20 20 28 6c 65 74 20 28 28 6d 79 2d 6d 61 74 63 (let ((my-matc
2a90: 68 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 h (string-match
2aa0: 22 5e 28 5b 5e 25 5c 5c 2f 5d 2b 29 5c 5c 2f 2e "^([^%\\/]+)\\/.
2ab0: 2b 24 22 20 74 65 73 74 70 61 74 74 2d 69 74 65 +$" testpatt-ite
2ac0: 6d 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 m))).
2ad0: 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 73 (cons
2ae0: 20 74 65 73 74 70 61 74 74 2d 69 74 65 6d 0a 20 testpatt-item.
2af0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2b00: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 6d (if m
2b10: 79 2d 6d 61 74 63 68 0a 20 20 20 20 20 20 20 20 y-match.
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 28 63 6f 6e 73 0a 20 20 (cons.
2b40: 20 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 28 (
2b60: 63 6f 6e 63 20 28 63 61 64 72 20 6d 79 2d 6d 61 conc (cadr my-ma
2b70: 74 63 68 29 20 22 2f 22 29 0a 20 20 20 20 20 20 tch) "/").
2b80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2b90: 20 20 20 20 20 20 20 20 20 20 20 61 63 63 75 6d accum
2ba0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
2bb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2bc0: 20 20 61 63 63 75 6d 29 29 29 29 0a 20 20 20 20 accum)))).
2bd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 27 28 '(
2be0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
2bf0: 20 20 20 20 65 78 74 65 6e 64 65 64 2d 74 65 73 extended-tes
2c00: 74 2d 70 61 74 74 29 29 29 0a 20 20 20 20 20 20 t-patt))).
2c10: 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 (string-interspe
2c20: 72 73 65 20 28 64 65 6c 65 74 65 2d 64 75 70 6c rse (delete-dupl
2c30: 69 63 61 74 65 73 20 65 78 74 65 6e 64 65 64 2d icates extended-
2c40: 74 65 73 74 2d 70 61 74 74 2d 77 69 74 68 2d 74 test-patt-with-t
2c50: 6f 70 6c 65 76 65 6c 73 29 20 22 2c 22 29 29 29 oplevels) ",")))
2c60: 0a 20 20 20 28 65 6c 73 65 20 3b 3b 20 6e 6f 74 . (else ;; not
2c70: 20 77 61 69 74 69 6e 67 20 6f 6e 20 69 74 65 6d waiting on item
2c80: 73 2c 20 77 61 69 74 69 6e 67 20 6f 6e 20 65 6e s, waiting on en
2c90: 74 69 72 65 20 77 61 69 74 6f 6e 20 74 65 73 74 tire waiton test
2ca0: 2e 0a 20 20 20 20 28 6c 65 74 2a 20 28 28 70 61 .. (let* ((pa
2cb0: 74 74 73 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 tts (string-spli
2cc0: 74 20 74 65 73 74 2d 70 61 74 74 20 22 2c 22 29 t test-patt ",")
2cd0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 6e 65 ). (ne
2ce0: 77 2d 70 61 74 74 73 20 28 69 66 20 28 6d 65 6d w-patts (if (mem
2cf0: 62 65 72 20 77 61 69 74 6f 6e 2d 74 65 73 74 20 ber waiton-test
2d00: 70 61 74 74 73 29 0a 20 20 20 20 20 20 20 20 20 patts).
2d10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2d20: 20 70 61 74 74 73 0a 20 20 20 20 20 20 20 20 20 patts.
2d30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2d40: 20 28 63 6f 6e 73 20 77 61 69 74 6f 6e 2d 74 65 (cons waiton-te
2d50: 73 74 20 70 61 74 74 73 29 29 29 29 0a 20 20 20 st patts)))).
2d60: 20 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 (string-inter
2d70: 73 70 65 72 73 65 20 28 64 65 6c 65 74 65 2d 64 sperse (delete-d
2d80: 75 70 6c 69 63 61 74 65 73 20 6e 65 77 2d 70 61 uplicates new-pa
2d90: 74 74 73 29 20 22 2c 22 29 29 29 29 29 0a 0a 28 tts) ",")))))..(
2da0: 64 65 66 69 6e 65 20 2a 67 6c 6f 62 2d 6c 69 6b define *glob-lik
2db0: 65 2d 6d 61 74 63 68 2d 63 61 63 68 65 2a 20 28 e-match-cache* (
2dc0: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
2dd0: 29 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 ).(define (tests
2de0: 3a 63 61 63 68 65 2d 72 65 67 65 78 70 20 73 74 :cache-regexp st
2df0: 72 2d 69 6e 20 66 6c 61 67 29 0a 20 20 28 6c 65 r-in flag). (le
2e00: 74 2a 20 28 28 6b 65 79 20 28 63 6f 6e 63 20 73 t* ((key (conc s
2e10: 74 72 2d 69 6e 20 66 6c 61 67 29 29 29 0a 20 20 tr-in flag))).
2e20: 20 20 28 6f 72 20 28 68 61 73 68 2d 74 61 62 6c (or (hash-tabl
2e30: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 67 e-ref/default *g
2e40: 6c 6f 62 2d 6c 69 6b 65 2d 6d 61 74 63 68 2d 63 lob-like-match-c
2e50: 61 63 68 65 2a 20 6b 65 79 20 23 66 29 0a 09 28 ache* key #f)..(
2e60: 6c 65 74 2a 20 28 28 6e 65 77 72 78 20 28 72 65 let* ((newrx (re
2e70: 67 65 78 70 20 73 74 72 2d 69 6e 20 66 6c 61 67 gexp str-in flag
2e80: 29 29 29 0a 09 20 20 28 68 61 73 68 2d 74 61 62 ))).. (hash-tab
2e90: 6c 65 2d 73 65 74 21 20 2a 67 6c 6f 62 2d 6c 69 le-set! *glob-li
2ea0: 6b 65 2d 6d 61 74 63 68 2d 63 61 63 68 65 2a 20 ke-match-cache*
2eb0: 6b 65 79 20 6e 65 77 72 78 29 0a 09 20 20 6e 65 key newrx).. ne
2ec0: 77 72 78 29 29 29 29 0a 0a 3b 3b 20 74 65 73 74 wrx))))..;; test
2ed0: 73 3a 67 6c 6f 62 2d 6c 69 6b 65 2d 6d 61 74 63 s:glob-like-matc
2ee0: 68 20 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 h .(define (test
2ef0: 73 3a 67 6c 6f 62 2d 6c 69 6b 65 2d 6d 61 74 63 s:glob-like-matc
2f00: 68 20 70 61 74 74 20 73 74 72 29 20 0a 20 20 28 h patt str) . (
2f10: 6c 65 74 2a 20 28 28 6c 69 6b 65 20 20 20 20 20 let* ((like
2f20: 28 73 75 62 73 74 72 69 6e 67 2d 69 6e 64 65 78 (substring-index
2f30: 20 22 25 22 20 70 61 74 74 29 29 0a 09 20 28 6e "%" patt)).. (n
2f40: 6f 74 70 61 74 74 20 20 28 65 71 75 61 6c 3f 20 otpatt (equal?
2f50: 28 73 75 62 73 74 72 69 6e 67 2d 69 6e 64 65 78 (substring-index
2f60: 20 22 7e 22 20 70 61 74 74 29 20 30 29 29 0a 09 "~" patt) 0))..
2f70: 20 28 6e 65 77 70 61 74 74 20 20 28 69 66 20 6e (newpatt (if n
2f80: 6f 74 70 61 74 74 20 28 73 75 62 73 74 72 69 6e otpatt (substrin
2f90: 67 20 70 61 74 74 20 31 29 20 70 61 74 74 29 29 g patt 1) patt))
2fa0: 0a 09 20 28 66 69 6e 70 61 74 74 20 20 28 69 66 .. (finpatt (if
2fb0: 20 6c 69 6b 65 0a 09 09 20 20 20 20 20 20 20 28 like... (
2fc0: 73 74 72 69 6e 67 2d 73 75 62 73 74 69 74 75 74 string-substitut
2fd0: 65 20 28 72 65 67 65 78 70 20 22 25 22 29 20 22 e (regexp "%") "
2fe0: 2e 2a 22 20 6e 65 77 70 61 74 74 20 23 66 29 0a .*" newpatt #f).
2ff0: 09 09 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 .. (string
3000: 2d 73 75 62 73 74 69 74 75 74 65 20 28 72 65 67 -substitute (reg
3010: 65 78 70 20 22 5c 5c 2a 22 29 20 22 2e 2a 22 20 exp "\\*") ".*"
3020: 6e 65 77 70 61 74 74 20 23 66 29 29 29 0a 09 20 newpatt #f)))..
3030: 28 72 78 20 20 20 20 20 20 20 28 74 65 73 74 73 (rx (tests
3040: 3a 63 61 63 68 65 2d 72 65 67 65 78 70 20 66 69 :cache-regexp fi
3050: 6e 70 61 74 74 20 28 69 66 20 6c 69 6b 65 20 23 npatt (if like #
3060: 74 20 23 66 29 29 29 0a 09 20 28 72 65 73 20 20 t #f))).. (res
3070: 20 20 20 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 (string-matc
3080: 68 20 72 78 20 73 74 72 29 29 29 0a 20 20 20 20 h rx str))).
3090: 28 69 66 20 6e 6f 74 70 61 74 74 20 28 6e 6f 74 (if notpatt (not
30a0: 20 72 65 73 29 20 72 65 73 29 29 29 0a 0a 3b 3b res) res)))..;;
30b0: 20 69 66 20 69 74 65 6d 70 61 74 68 20 69 73 20 if itempath is
30c0: 23 66 20 74 68 65 6e 20 6c 6f 6f 6b 20 6f 6e 6c #f then look onl
30d0: 79 20 61 74 20 74 68 65 20 74 65 73 74 6e 61 6d y at the testnam
30e0: 65 20 70 61 72 74 0a 3b 3b 0a 28 64 65 66 69 6e e part.;;.(defin
30f0: 65 20 28 74 65 73 74 73 3a 6d 61 74 63 68 20 70 e (tests:match p
3100: 61 74 74 65 72 6e 73 20 74 65 73 74 6e 61 6d 65 atterns testname
3110: 20 69 74 65 6d 70 61 74 68 20 23 21 6b 65 79 20 itempath #!key
3120: 28 72 65 71 75 69 72 65 64 20 27 28 29 29 29 0a (required '())).
3130: 20 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 70 (if (string? p
3140: 61 74 74 65 72 6e 73 29 0a 20 20 20 20 20 20 28 atterns). (
3150: 6c 65 74 20 28 28 70 61 74 74 73 20 28 61 70 70 let ((patts (app
3160: 65 6e 64 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 end (string-spli
3170: 74 20 70 61 74 74 65 72 6e 73 20 22 2c 22 29 20 t patterns ",")
3180: 72 65 71 75 69 72 65 64 29 29 29 0a 09 28 69 66 required)))..(if
3190: 20 28 6e 75 6c 6c 3f 20 70 61 74 74 73 29 20 3b (null? patts) ;
31a0: 3b 3b 20 6e 6f 20 70 61 74 74 65 72 6e 28 73 29 ;; no pattern(s)
31b0: 20 6d 65 61 6e 73 20 6e 6f 20 6d 61 74 63 68 0a means no match.
31c0: 09 20 20 20 20 23 66 0a 09 20 20 20 20 28 6c 65 . #f.. (le
31d0: 74 20 6c 6f 6f 70 20 28 28 70 61 74 74 20 28 63 t loop ((patt (c
31e0: 61 72 20 70 61 74 74 73 29 29 0a 09 09 20 20 20 ar patts))...
31f0: 20 20 20 20 28 74 61 6c 20 20 28 63 64 72 20 70 (tal (cdr p
3200: 61 74 74 73 29 29 29 0a 09 20 20 20 20 20 20 3b atts))).. ;
3210: 3b 20 28 70 72 69 6e 74 20 22 6c 6f 6f 70 3a 20 ; (print "loop:
3220: 70 61 74 74 3a 20 22 20 70 61 74 74 20 22 2c 20 patt: " patt ",
3230: 74 61 6c 20 22 20 74 61 6c 29 0a 09 20 20 20 20 tal " tal)..
3240: 20 20 28 69 66 20 28 73 74 72 69 6e 67 3d 3f 20 (if (string=?
3250: 70 61 74 74 20 22 22 29 0a 09 09 20 20 23 66 20 patt "")... #f
3260: 3b 3b 20 6e 6f 74 68 69 6e 67 20 65 76 65 72 20 ;; nothing ever
3270: 6d 61 74 63 68 65 73 20 65 6d 70 74 79 20 73 74 matches empty st
3280: 72 69 6e 67 20 2d 20 70 6f 6c 69 63 79 0a 09 09 ring - policy...
3290: 20 20 28 6c 65 74 2a 20 28 28 70 61 74 74 2d 70 (let* ((patt-p
32a0: 61 72 74 73 20 28 73 74 72 69 6e 67 2d 6d 61 74 arts (string-mat
32b0: 63 68 20 28 72 65 67 65 78 70 20 22 5e 28 5b 5e ch (regexp "^([^
32c0: 5c 5c 2f 5d 2a 29 28 5c 5c 2f 28 2e 2a 29 7c 29 \\/]*)(\\/(.*)|)
32d0: 24 22 29 20 70 61 74 74 29 29 0a 09 09 09 20 28 $") patt)).... (
32e0: 74 65 73 74 2d 70 61 74 74 20 20 28 63 61 64 72 test-patt (cadr
32f0: 20 70 61 74 74 2d 70 61 72 74 73 29 29 0a 09 09 patt-parts))...
3300: 09 20 28 69 74 65 6d 2d 70 61 74 74 20 20 28 63 . (item-patt (c
3310: 61 64 64 64 72 20 70 61 74 74 2d 70 61 72 74 73 adddr patt-parts
3320: 29 29 29 0a 09 09 20 20 20 20 3b 3b 20 73 70 65 )))... ;; spe
3330: 63 69 61 6c 20 63 61 73 65 3a 20 74 65 73 74 20 cial case: test
3340: 76 73 2e 20 74 65 73 74 2f 0a 09 09 20 20 20 20 vs. test/...
3350: 3b 3b 20 20 20 74 65 73 74 20 20 3d 3e 20 22 74 ;; test => "t
3360: 65 73 74 22 20 22 25 22 0a 09 09 20 20 20 20 3b est" "%"... ;
3370: 3b 20 20 20 74 65 73 74 2f 20 3d 3e 20 22 74 65 ; test/ => "te
3380: 73 74 22 20 22 22 0a 09 09 20 20 20 20 28 69 66 st" ""... (if
3390: 20 28 61 6e 64 20 28 6e 6f 74 20 28 73 75 62 73 (and (not (subs
33a0: 74 72 69 6e 67 2d 69 6e 64 65 78 20 22 2f 22 20 tring-index "/"
33b0: 70 61 74 74 29 29 20 3b 3b 20 6e 6f 20 73 6c 61 patt)) ;; no sla
33c0: 73 68 20 69 6e 20 74 68 65 20 6f 72 69 67 69 6e sh in the origin
33d0: 61 6c 0a 09 09 09 20 20 20 20 20 28 6f 72 20 28 al.... (or (
33e0: 6e 6f 74 20 69 74 65 6d 2d 70 61 74 74 29 0a 09 not item-patt)..
33f0: 09 09 09 20 28 65 71 75 61 6c 3f 20 69 74 65 6d ... (equal? item
3400: 2d 70 61 74 74 20 22 22 29 29 29 20 20 20 20 20 -patt "")))
3410: 20 3b 3b 20 73 68 6f 75 6c 64 20 61 6c 77 61 79 ;; should alway
3420: 73 20 62 65 20 74 72 75 65 20 74 68 61 74 20 69 s be true that i
3430: 74 65 6d 2d 70 61 74 74 20 69 73 20 22 22 0a 09 tem-patt is ""..
3440: 09 09 28 73 65 74 21 20 69 74 65 6d 2d 70 61 74 ..(set! item-pat
3450: 74 20 22 25 22 29 29 0a 09 09 20 20 20 20 3b 3b t "%"))... ;;
3460: 20 28 70 72 69 6e 74 20 22 74 65 73 74 73 3a 6d (print "tests:m
3470: 61 74 63 68 20 3d 3e 20 70 61 74 74 2d 70 61 72 atch => patt-par
3480: 74 73 3a 20 22 20 70 61 74 74 2d 70 61 72 74 73 ts: " patt-parts
3490: 20 22 2c 20 74 65 73 74 2d 70 61 74 74 3a 20 22 ", test-patt: "
34a0: 20 74 65 73 74 2d 70 61 74 74 20 22 2c 20 69 74 test-patt ", it
34b0: 65 6d 2d 70 61 74 74 3a 20 22 20 69 74 65 6d 2d em-patt: " item-
34c0: 70 61 74 74 29 0a 09 09 20 20 20 20 28 69 66 20 patt)... (if
34d0: 28 61 6e 64 20 28 74 65 73 74 73 3a 67 6c 6f 62 (and (tests:glob
34e0: 2d 6c 69 6b 65 2d 6d 61 74 63 68 20 74 65 73 74 -like-match test
34f0: 2d 70 61 74 74 20 74 65 73 74 6e 61 6d 65 29 0a -patt testname).
3500: 09 09 09 20 20 20 20 20 28 6f 72 20 28 6e 6f 74 ... (or (not
3510: 20 69 74 65 6d 70 61 74 68 29 0a 09 09 09 09 20 itempath).....
3520: 28 74 65 73 74 73 3a 67 6c 6f 62 2d 6c 69 6b 65 (tests:glob-like
3530: 2d 6d 61 74 63 68 20 28 69 66 20 69 74 65 6d 2d -match (if item-
3540: 70 61 74 74 20 69 74 65 6d 2d 70 61 74 74 20 22 patt item-patt "
3550: 22 29 20 69 74 65 6d 70 61 74 68 29 29 29 0a 09 ") itempath)))..
3560: 09 09 23 74 0a 09 09 09 28 69 66 20 28 6e 75 6c ..#t....(if (nul
3570: 6c 3f 20 74 61 6c 29 0a 09 09 09 20 20 20 20 23 l? tal).... #
3580: 66 0a 09 09 09 20 20 20 20 28 6c 6f 6f 70 20 28 f.... (loop (
3590: 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c car tal)(cdr tal
35a0: 29 29 29 29 29 29 29 29 29 29 29 0a 0a 3b 3b 20 )))))))))))..;;
35b0: 69 66 20 69 74 65 6d 70 61 74 68 20 69 73 20 23 if itempath is #
35c0: 66 20 74 68 65 6e 20 6c 6f 6f 6b 20 6f 6e 6c 79 f then look only
35d0: 20 61 74 20 74 68 65 20 74 65 73 74 6e 61 6d 65 at the testname
35e0: 20 70 61 72 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 part.;;.(define
35f0: 20 28 74 65 73 74 73 3a 6d 61 74 63 68 2d 3e 73 (tests:match->s
3600: 71 6c 71 72 79 20 70 61 74 74 65 72 6e 73 29 0a qlqry patterns).
3610: 20 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 70 (if (string? p
3620: 61 74 74 65 72 6e 73 29 0a 20 20 20 20 20 20 28 atterns). (
3630: 6c 65 74 20 28 28 70 61 74 74 73 20 28 73 74 72 let ((patts (str
3640: 69 6e 67 2d 73 70 6c 69 74 20 70 61 74 74 65 72 ing-split patter
3650: 6e 73 20 22 2c 22 29 29 29 0a 09 28 69 66 20 28 ns ",")))..(if (
3660: 6e 75 6c 6c 3f 20 70 61 74 74 73 29 20 3b 3b 3b null? patts) ;;;
3670: 20 6e 6f 20 70 61 74 74 65 72 6e 28 73 29 20 6d no pattern(s) m
3680: 65 61 6e 73 20 6e 6f 20 6d 61 74 63 68 2c 20 77 eans no match, w
3690: 65 20 77 69 6c 6c 20 64 6f 20 6e 6f 20 71 75 65 e will do no que
36a0: 72 79 0a 09 20 20 20 20 23 66 0a 09 20 20 20 20 ry.. #f..
36b0: 28 6c 65 74 20 6c 6f 6f 70 20 28 28 70 61 74 74 (let loop ((patt
36c0: 20 28 63 61 72 20 70 61 74 74 73 29 29 0a 09 09 (car patts))...
36d0: 20 20 20 20 20 20 20 28 74 61 6c 20 20 28 63 64 (tal (cd
36e0: 72 20 70 61 74 74 73 29 29 0a 09 09 20 20 20 20 r patts))...
36f0: 20 20 20 28 72 65 73 20 20 27 28 29 29 29 0a 09 (res '()))..
3700: 20 20 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 ;; (print
3710: 22 6c 6f 6f 70 3a 20 70 61 74 74 3a 20 22 20 70 "loop: patt: " p
3720: 61 74 74 20 22 2c 20 74 61 6c 20 22 20 74 61 6c att ", tal " tal
3730: 29 0a 09 20 20 20 20 20 20 28 6c 65 74 2a 20 28 ).. (let* (
3740: 28 70 61 74 74 2d 70 61 72 74 73 20 28 73 74 72 (patt-parts (str
3750: 69 6e 67 2d 6d 61 74 63 68 20 28 72 65 67 65 78 ing-match (regex
3760: 70 20 22 5e 28 5b 5e 5c 5c 2f 5d 2a 29 28 5c 5c p "^([^\\/]*)(\\
3770: 2f 28 2e 2a 29 7c 29 24 22 29 20 70 61 74 74 29 /(.*)|)$") patt)
3780: 29 0a 09 09 20 20 20 20 20 28 74 65 73 74 2d 70 )... (test-p
3790: 61 74 74 20 20 28 63 61 64 72 20 70 61 74 74 2d att (cadr patt-
37a0: 70 61 72 74 73 29 29 0a 09 09 20 20 20 20 20 28 parts))... (
37b0: 69 74 65 6d 2d 70 61 74 74 20 20 28 63 61 64 64 item-patt (cadd
37c0: 64 72 20 70 61 74 74 2d 70 61 72 74 73 29 29 0a dr patt-parts)).
37d0: 09 09 20 20 20 20 20 28 74 65 73 74 2d 71 72 79 .. (test-qry
37e0: 20 20 20 28 64 62 3a 70 61 74 74 2d 3e 6c 69 6b (db:patt->lik
37f0: 65 20 22 74 65 73 74 6e 61 6d 65 22 20 74 65 73 e "testname" tes
3800: 74 2d 70 61 74 74 29 29 0a 09 09 20 20 20 20 20 t-patt))...
3810: 28 69 74 65 6d 2d 71 72 79 20 20 20 28 64 62 3a (item-qry (db:
3820: 70 61 74 74 2d 3e 6c 69 6b 65 20 22 69 74 65 6d patt->like "item
3830: 5f 70 61 74 68 22 20 69 74 65 6d 2d 70 61 74 74 _path" item-patt
3840: 29 29 0a 09 09 20 20 20 20 20 28 71 72 79 20 20 ))... (qry
3850: 20 20 20 20 20 20 28 63 6f 6e 63 20 22 28 22 20 (conc "("
3860: 74 65 73 74 2d 71 72 79 20 22 20 41 4e 44 20 22 test-qry " AND "
3870: 20 69 74 65 6d 2d 71 72 79 20 22 29 22 29 29 29 item-qry ")")))
3880: 0a 09 09 3b 3b 20 28 70 72 69 6e 74 20 22 74 65 ...;; (print "te
3890: 73 74 73 3a 6d 61 74 63 68 20 3d 3e 20 70 61 74 sts:match => pat
38a0: 74 2d 70 61 72 74 73 3a 20 22 20 70 61 74 74 2d t-parts: " patt-
38b0: 70 61 72 74 73 20 22 2c 20 74 65 73 74 2d 70 61 parts ", test-pa
38c0: 74 74 3a 20 22 20 74 65 73 74 2d 70 61 74 74 20 tt: " test-patt
38d0: 22 2c 20 69 74 65 6d 2d 70 61 74 74 3a 20 22 20 ", item-patt: "
38e0: 69 74 65 6d 2d 70 61 74 74 29 0a 09 09 28 69 66 item-patt)...(if
38f0: 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 20 (null? tal)...
3900: 20 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 (string-inter
3910: 73 70 65 72 73 65 20 28 61 70 70 65 6e 64 20 28 sperse (append (
3920: 72 65 76 65 72 73 65 20 72 65 73 29 28 6c 69 73 reverse res)(lis
3930: 74 20 71 72 79 29 29 20 22 20 4f 52 20 22 29 0a t qry)) " OR ").
3940: 09 09 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 .. (loop (car
3950: 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 28 63 tal)(cdr tal)(c
3960: 6f 6e 73 20 71 72 79 20 72 65 73 29 29 29 29 29 ons qry res)))))
3970: 29 29 0a 20 20 20 20 20 20 23 66 29 29 0a 0a 3b )). #f))..;
3980: 3b 20 43 68 65 63 6b 20 66 6f 72 20 77 61 69 76 ; Check for waiv
3990: 65 72 20 65 6c 69 67 69 62 69 6c 69 74 79 0a 3b er eligibility.;
39a0: 3b 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 ;.(define (tests
39b0: 3a 63 68 65 63 6b 2d 77 61 69 76 65 72 2d 65 6c :check-waiver-el
39c0: 69 67 69 62 69 6c 69 74 79 20 74 65 73 74 64 61 igibility testda
39d0: 74 20 70 72 65 76 2d 74 65 73 74 64 61 74 29 0a t prev-testdat).
39e0: 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 2d 72 (let* ((test-r
39f0: 65 67 69 73 74 72 79 20 28 6d 61 6b 65 2d 68 61 egistry (make-ha
3a00: 73 68 2d 74 61 62 6c 65 29 29 0a 09 20 28 74 65 sh-table)).. (te
3a10: 73 74 63 6f 6e 66 69 67 20 20 28 74 65 73 74 73 stconfig (tests
3a20: 3a 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 :get-testconfig
3a30: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 (db:test-get-tes
3a40: 74 6e 61 6d 65 20 74 65 73 74 64 61 74 29 20 28 tname testdat) (
3a50: 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 6d db:test-get-item
3a60: 2d 70 61 74 68 20 74 65 73 74 64 61 74 29 20 74 -path testdat) t
3a70: 65 73 74 2d 72 65 67 69 73 74 72 79 20 23 66 29 est-registry #f)
3a80: 29 0a 09 20 28 74 65 73 74 2d 72 75 6e 64 69 72 ).. (test-rundir
3a90: 20 3b 3b 20 28 73 64 62 3a 71 72 79 20 27 70 61 ;; (sdb:qry 'pa
3aa0: 73 73 73 74 72 20 0a 09 20 20 28 64 62 3a 74 65 ssstr .. (db:te
3ab0: 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 20 74 65 st-get-rundir te
3ac0: 73 74 64 61 74 29 29 20 3b 3b 20 29 0a 09 20 28 stdat)) ;; ).. (
3ad0: 70 72 65 76 2d 72 75 6e 64 69 72 20 3b 3b 20 28 prev-rundir ;; (
3ae0: 73 64 62 3a 71 72 79 20 27 70 61 73 73 73 74 72 sdb:qry 'passstr
3af0: 20 0a 09 20 20 28 64 62 3a 74 65 73 74 2d 67 65 .. (db:test-ge
3b00: 74 2d 72 75 6e 64 69 72 20 70 72 65 76 2d 74 65 t-rundir prev-te
3b10: 73 74 64 61 74 29 29 20 3b 3b 20 29 0a 09 20 28 stdat)) ;; ).. (
3b20: 77 61 69 76 65 72 73 20 20 20 20 20 28 69 66 20 waivers (if
3b30: 74 65 73 74 63 6f 6e 66 69 67 20 28 63 6f 6e 66 testconfig (conf
3b40: 69 67 66 3a 73 65 63 74 69 6f 6e 2d 76 61 72 73 igf:section-vars
3b50: 20 74 65 73 74 63 6f 6e 66 69 67 20 22 77 61 69 testconfig "wai
3b60: 76 65 72 73 22 29 20 27 28 29 29 29 0a 09 20 28 vers") '())).. (
3b70: 77 61 69 76 65 72 2d 72 78 20 20 20 28 72 65 67 waiver-rx (reg
3b80: 65 78 70 20 22 5e 28 5c 5c 53 2b 29 5c 5c 73 2b exp "^(\\S+)\\s+
3b90: 28 2e 2a 29 24 22 29 29 0a 09 20 28 64 69 66 66 (.*)$")).. (diff
3ba0: 2d 72 75 6c 65 20 20 20 22 64 69 66 66 20 25 66 -rule "diff %f
3bb0: 69 6c 65 31 25 20 25 66 69 6c 65 32 25 22 29 0a ile1% %file2%").
3bc0: 09 20 28 6c 6f 67 70 72 6f 2d 72 75 6c 65 20 22 . (logpro-rule "
3bd0: 64 69 66 66 20 25 66 69 6c 65 31 25 20 25 66 69 diff %file1% %fi
3be0: 6c 65 32 25 20 7c 20 6c 6f 67 70 72 6f 20 25 77 le2% | logpro %w
3bf0: 61 69 76 65 72 6e 61 6d 65 25 2e 6c 6f 67 70 72 aivername%.logpr
3c00: 6f 20 25 77 61 69 76 65 72 6e 61 6d 65 25 2e 68 o %waivername%.h
3c10: 74 6d 6c 22 29 29 0a 20 20 20 20 28 69 66 20 28 tml")). (if (
3c20: 6e 6f 74 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 not (common:file
3c30: 2d 65 78 69 73 74 73 3f 20 74 65 73 74 2d 72 75 -exists? test-ru
3c40: 6e 64 69 72 29 29 0a 09 28 62 65 67 69 6e 0a 09 ndir))..(begin..
3c50: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 (debug:print-e
3c60: 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d rror 0 *default-
3c70: 6c 6f 67 2d 70 6f 72 74 2a 20 22 74 65 73 74 20 log-port* "test
3c80: 72 75 6e 20 64 69 72 65 63 74 6f 72 79 20 69 73 run directory is
3c90: 20 67 6f 6e 65 2c 20 63 61 6e 6e 6f 74 20 70 72 gone, cannot pr
3ca0: 6f 70 61 67 61 74 65 20 77 61 69 76 65 72 22 29 opagate waiver")
3cb0: 0a 09 20 20 23 66 29 0a 09 28 62 65 67 69 6e 0a .. #f)..(begin.
3cc0: 09 20 20 28 70 75 73 68 2d 64 69 72 65 63 74 6f . (push-directo
3cd0: 72 79 20 74 65 73 74 2d 72 75 6e 64 69 72 29 0a ry test-rundir).
3ce0: 09 20 20 28 6c 65 74 20 28 28 72 65 73 75 6c 74 . (let ((result
3cf0: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 77 61 69 76 (if (null? waiv
3d00: 65 72 73 29 0a 09 09 09 20 20 20 20 23 66 0a 09 ers).... #f..
3d10: 09 09 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 .. (let loop
3d20: 28 28 68 65 64 20 28 63 61 72 20 77 61 69 76 65 ((hed (car waive
3d30: 72 73 29 29 0a 09 09 09 09 20 20 20 20 20 20 20 rs)).....
3d40: 28 74 61 6c 20 28 63 64 72 20 77 61 69 76 65 72 (tal (cdr waiver
3d50: 73 29 29 29 0a 09 09 09 20 20 20 20 20 20 28 64 s))).... (d
3d60: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
3d70: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
3d80: 22 49 4e 46 4f 3a 20 41 70 70 6c 79 69 6e 67 20 "INFO: Applying
3d90: 77 61 69 76 65 72 20 72 75 6c 65 20 5c 22 22 20 waiver rule \""
3da0: 68 65 64 20 22 5c 22 22 29 0a 09 09 09 20 20 20 hed "\"")....
3db0: 20 20 20 28 6c 65 74 2a 20 28 28 77 61 69 76 65 (let* ((waive
3dc0: 72 20 20 20 20 20 20 28 63 6f 6e 66 69 67 66 3a r (configf:
3dd0: 6c 6f 6f 6b 75 70 20 74 65 73 74 63 6f 6e 66 69 lookup testconfi
3de0: 67 20 22 77 61 69 76 65 72 73 22 20 68 65 64 29 g "waivers" hed)
3df0: 29 0a 09 09 09 09 20 20 20 20 20 28 77 70 61 72 )..... (wpar
3e00: 74 73 20 20 20 20 20 20 28 69 66 20 77 61 69 76 ts (if waiv
3e10: 65 72 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 er (string-match
3e20: 20 77 61 69 76 65 72 2d 72 78 20 77 61 69 76 65 waiver-rx waive
3e30: 72 29 20 23 66 29 29 0a 09 09 09 09 20 20 20 20 r) #f)).....
3e40: 20 28 77 61 69 76 65 72 2d 72 75 6c 65 20 28 69 (waiver-rule (i
3e50: 66 20 77 70 61 72 74 73 20 28 63 61 64 72 20 77 f wparts (cadr w
3e60: 70 61 72 74 73 29 20 20 23 66 29 29 0a 09 09 09 parts) #f))....
3e70: 09 20 20 20 20 20 28 77 61 69 76 65 72 2d 67 6c . (waiver-gl
3e80: 6f 62 20 28 69 66 20 77 70 61 72 74 73 20 28 63 ob (if wparts (c
3e90: 61 64 64 72 20 77 70 61 72 74 73 29 20 23 66 29 addr wparts) #f)
3ea0: 29 0a 09 09 09 09 20 20 20 20 20 28 6c 6f 67 70 )..... (logp
3eb0: 72 6f 2d 66 69 6c 65 20 28 69 66 20 77 61 69 76 ro-file (if waiv
3ec0: 65 72 0a 09 09 09 09 09 09 20 20 20 20 20 20 28 er....... (
3ed0: 6c 65 74 20 28 28 66 6e 61 6d 65 20 28 63 6f 6e let ((fname (con
3ee0: 63 20 68 65 64 20 22 2e 6c 6f 67 70 72 6f 22 29 c hed ".logpro")
3ef0: 29 29 0a 09 09 09 09 09 09 09 28 69 66 20 28 63 ))........(if (c
3f00: 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 ommon:file-exist
3f10: 73 3f 20 66 6e 61 6d 65 29 0a 09 09 09 09 09 09 s? fname).......
3f20: 09 20 20 20 20 66 6e 61 6d 65 20 0a 09 09 09 09 . fname .....
3f30: 09 09 09 20 20 20 20 28 62 65 67 69 6e 0a 09 09 ... (begin...
3f40: 09 09 09 09 09 20 20 20 20 20 20 28 64 65 62 75 ..... (debu
3f50: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
3f60: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 4e lt-log-port* "IN
3f70: 46 4f 3a 20 4e 6f 20 6c 6f 67 70 72 6f 20 66 69 FO: No logpro fi
3f80: 6c 65 20 22 20 66 6e 61 6d 65 20 22 20 66 61 6c le " fname " fal
3f90: 6c 69 6e 67 20 62 61 63 6b 20 74 6f 20 64 69 66 ling back to dif
3fa0: 66 22 29 0a 09 09 09 09 09 09 09 20 20 20 20 20 f")........
3fb0: 20 23 66 29 29 29 0a 09 09 09 09 09 09 20 20 20 #f))).......
3fc0: 20 20 20 23 66 29 29 0a 09 09 09 09 20 20 20 20 #f)).....
3fd0: 20 3b 3b 20 69 66 20 72 75 6c 65 20 62 79 20 6e ;; if rule by n
3fe0: 61 6d 65 20 6f 66 20 77 61 69 76 65 72 2d 72 75 ame of waiver-ru
3ff0: 6c 65 20 69 73 20 66 6f 75 6e 64 20 69 6e 20 74 le is found in t
4000: 65 73 74 63 6f 6e 66 69 67 20 2d 20 75 73 65 20 estconfig - use
4010: 69 74 0a 09 09 09 09 20 20 20 20 20 3b 3b 20 65 it..... ;; e
4020: 6c 73 65 20 69 66 20 77 61 69 76 65 72 6e 61 6d lse if waivernam
4030: 65 2e 6c 6f 67 70 72 6f 20 65 78 69 73 74 73 20 e.logpro exists
4040: 75 73 65 20 6c 6f 67 70 72 6f 2d 72 75 6c 65 0a use logpro-rule.
4050: 09 09 09 09 20 20 20 20 20 3b 3b 20 65 6c 73 65 .... ;; else
4060: 20 64 65 66 61 75 6c 74 20 74 6f 20 64 69 66 66 default to diff
4070: 2d 72 75 6c 65 0a 09 09 09 09 20 20 20 20 20 28 -rule..... (
4080: 72 75 6c 65 2d 73 74 72 69 6e 67 20 28 6c 65 74 rule-string (let
4090: 20 28 28 72 75 6c 65 20 28 63 6f 6e 66 69 67 66 ((rule (configf
40a0: 3a 6c 6f 6f 6b 75 70 20 74 65 73 74 63 6f 6e 66 :lookup testconf
40b0: 69 67 20 22 77 61 69 76 65 72 5f 72 75 6c 65 73 ig "waiver_rules
40c0: 22 20 77 61 69 76 65 72 2d 72 75 6c 65 29 29 29 " waiver-rule)))
40d0: 0a 09 09 09 09 09 09 20 20 20 20 28 69 66 20 72 ....... (if r
40e0: 75 6c 65 0a 09 09 09 09 09 09 09 72 75 6c 65 0a ule........rule.
40f0: 09 09 09 09 09 09 09 28 69 66 20 6c 6f 67 70 72 .......(if logpr
4100: 6f 2d 66 69 6c 65 0a 09 09 09 09 09 09 09 20 20 o-file........
4110: 20 20 6c 6f 67 70 72 6f 2d 72 75 6c 65 0a 09 09 logpro-rule...
4120: 09 09 09 09 09 20 20 20 20 28 62 65 67 69 6e 0a ..... (begin.
4130: 09 09 09 09 09 09 09 20 20 20 20 20 20 28 64 65 ....... (de
4140: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
4150: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
4160: 49 4e 46 4f 3a 20 4e 6f 20 6c 6f 67 70 72 6f 20 INFO: No logpro
4170: 66 69 6c 65 20 22 20 6c 6f 67 70 72 6f 2d 66 69 file " logpro-fi
4180: 6c 65 20 22 20 66 6f 75 6e 64 2c 20 75 73 69 6e le " found, usin
4190: 67 20 64 69 66 66 20 72 75 6c 65 22 29 0a 09 09 g diff rule")...
41a0: 09 09 09 09 09 20 20 20 20 20 20 64 69 66 66 2d ..... diff-
41b0: 72 75 6c 65 29 29 29 29 29 0a 09 09 09 09 20 20 rule))))).....
41c0: 20 20 20 3b 3b 20 28 73 74 72 69 6e 67 2d 73 75 ;; (string-su
41d0: 62 73 74 69 74 75 74 65 20 22 25 66 69 6c 65 31 bstitute "%file1
41e0: 25 22 20 22 66 6f 6f 66 6f 6f 2e 74 78 74 22 20 %" "foofoo.txt"
41f0: 22 54 68 69 73 20 69 73 20 25 66 69 6c 65 31 25 "This is %file1%
4200: 20 61 6e 64 20 73 6f 20 69 73 20 74 68 69 73 20 and so is this
4210: 25 66 69 6c 65 31 25 2e 22 20 23 74 29 0a 09 09 %file1%." #t)...
4220: 09 09 20 20 20 20 20 28 70 72 6f 63 65 73 73 65 .. (processe
4230: 64 2d 63 6d 64 20 28 73 74 72 69 6e 67 2d 73 75 d-cmd (string-su
4240: 62 73 74 69 74 75 74 65 20 0a 09 09 09 09 09 09 bstitute .......
4250: 20 20 20 20 20 22 25 66 69 6c 65 31 25 22 20 28 "%file1%" (
4260: 63 6f 6e 63 20 74 65 73 74 2d 72 75 6e 64 69 72 conc test-rundir
4270: 20 22 2f 22 20 77 61 69 76 65 72 2d 67 6c 6f 62 "/" waiver-glob
4280: 29 0a 09 09 09 09 09 09 20 20 20 20 20 28 73 74 )....... (st
4290: 72 69 6e 67 2d 73 75 62 73 74 69 74 75 74 65 0a ring-substitute.
42a0: 09 09 09 09 09 09 20 20 20 20 20 20 22 25 66 69 ...... "%fi
42b0: 6c 65 32 25 22 20 28 63 6f 6e 63 20 70 72 65 76 le2%" (conc prev
42c0: 2d 72 75 6e 64 69 72 20 22 2f 22 20 77 61 69 76 -rundir "/" waiv
42d0: 65 72 2d 67 6c 6f 62 29 0a 09 09 09 09 09 09 20 er-glob).......
42e0: 20 20 20 20 20 28 73 74 72 69 6e 67 2d 73 75 62 (string-sub
42f0: 73 74 69 74 75 74 65 0a 09 09 09 09 09 09 20 20 stitute.......
4300: 20 20 20 20 20 22 25 77 61 69 76 65 72 6e 61 6d "%waivernam
4310: 65 25 22 20 68 65 64 20 72 75 6c 65 2d 73 74 72 e%" hed rule-str
4320: 69 6e 67 20 23 74 29 20 23 74 29 20 23 74 29 29 ing #t) #t) #t))
4330: 0a 09 09 09 09 20 20 20 20 20 28 72 65 73 20 20 ..... (res
4340: 20 20 20 20 20 20 20 20 20 20 23 66 29 29 0a 09 #f))..
4350: 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 ...(debug:print
4360: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
4370: 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 77 61 69 76 ort* "INFO: waiv
4380: 65 72 20 63 6f 6d 6d 61 6e 64 20 69 73 20 5c 22 er command is \"
4390: 22 20 70 72 6f 63 65 73 73 65 64 2d 63 6d 64 20 " processed-cmd
43a0: 22 5c 22 22 29 0a 09 09 09 09 28 69 66 20 28 65 "\"").....(if (e
43b0: 71 3f 20 28 73 79 73 74 65 6d 20 70 72 6f 63 65 q? (system proce
43c0: 73 73 65 64 2d 63 6d 64 29 20 30 29 0a 09 09 09 ssed-cmd) 0)....
43d0: 09 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 . (if (null?
43e0: 74 61 6c 29 0a 09 09 09 09 09 23 74 0a 09 09 09 tal)......#t....
43f0: 09 09 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c ..(loop (car tal
4400: 29 28 63 64 72 20 74 61 6c 29 29 29 0a 09 09 09 )(cdr tal)))....
4410: 09 20 20 20 20 23 66 29 29 29 29 29 29 0a 09 20 . #f))))))..
4420: 20 20 20 28 70 6f 70 2d 64 69 72 65 63 74 6f 72 (pop-director
4430: 79 29 0a 09 20 20 20 20 72 65 73 75 6c 74 29 29 y).. result))
4440: 29 29 29 0a 0a 3b 3b 20 44 6f 20 6e 6f 74 20 72 )))..;; Do not r
4450: 70 63 20 74 68 69 73 20 6f 6e 65 2c 20 64 6f 20 pc this one, do
4460: 74 68 65 20 75 6e 64 65 72 6c 79 69 6e 67 20 63 the underlying c
4470: 61 6c 6c 73 21 21 21 0a 28 64 65 66 69 6e 65 20 alls!!!.(define
4480: 28 74 65 73 74 73 3a 74 65 73 74 2d 73 65 74 2d (tests:test-set-
4490: 73 74 61 74 75 73 21 20 72 75 6e 2d 69 64 20 74 status! run-id t
44a0: 65 73 74 2d 69 64 20 73 74 61 74 65 20 73 74 61 est-id state sta
44b0: 74 75 73 20 63 6f 6d 6d 65 6e 74 20 64 61 74 20 tus comment dat
44c0: 23 21 6b 65 79 20 28 77 6f 72 6b 2d 61 72 65 61 #!key (work-area
44d0: 20 23 66 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 #f)). (let* ((
44e0: 72 65 61 6c 2d 73 74 61 74 75 73 20 73 74 61 74 real-status stat
44f0: 75 73 29 0a 09 20 28 6f 74 68 65 72 64 61 74 20 us).. (otherdat
4500: 20 20 20 28 69 66 20 64 61 74 20 64 61 74 20 28 (if dat dat (
4510: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
4520: 29 29 0a 09 20 28 74 65 73 74 64 61 74 20 20 20 )).. (testdat
4530: 20 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d (rmt:get-test-
4540: 69 6e 66 6f 2d 62 79 2d 69 64 20 72 75 6e 2d 69 info-by-id run-i
4550: 64 20 74 65 73 74 2d 69 64 29 29 0a 09 20 28 74 d test-id)).. (t
4560: 65 73 74 2d 6e 61 6d 65 20 20 20 28 64 62 3a 74 est-name (db:t
4570: 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 est-get-testname
4580: 20 20 74 65 73 74 64 61 74 29 29 0a 09 20 28 69 testdat)).. (i
4590: 74 65 6d 2d 70 61 74 68 20 20 20 28 64 62 3a 74 tem-path (db:t
45a0: 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 est-get-item-pat
45b0: 68 20 74 65 73 74 64 61 74 29 29 0a 09 20 3b 3b h testdat)).. ;;
45c0: 20 62 65 66 6f 72 65 20 70 72 6f 63 65 65 64 69 before proceedi
45d0: 6e 67 20 77 65 20 6d 75 73 74 20 66 69 6e 64 20 ng we must find
45e0: 6f 75 74 20 69 66 20 74 68 65 20 70 72 65 76 69 out if the previ
45f0: 6f 75 73 20 74 65 73 74 20 28 77 68 65 72 65 20 ous test (where
4600: 61 6c 6c 20 6b 65 79 73 20 6d 61 74 63 68 65 64 all keys matched
4610: 20 65 78 63 65 70 74 20 72 75 6e 6e 61 6d 65 29 except runname)
4620: 0a 09 20 3b 3b 20 77 61 73 20 57 41 49 56 45 44 .. ;; was WAIVED
4630: 20 69 66 20 74 68 69 73 20 74 65 73 74 20 69 73 if this test is
4640: 20 46 41 49 4c 0a 0a 09 20 3b 3b 20 4e 4f 54 45 FAIL... ;; NOTE
4650: 53 3a 0a 09 20 3b 3b 20 20 31 2e 20 49 73 20 74 S:.. ;; 1. Is t
4660: 68 65 20 63 61 6c 6c 20 74 6f 20 74 65 73 74 3a he call to test:
4670: 67 65 74 2d 70 72 65 76 69 6f 75 73 2d 72 75 6e get-previous-run
4680: 2d 72 65 63 6f 72 64 20 72 65 6d 6f 74 69 66 69 -record remotifi
4690: 65 64 3f 0a 09 20 3b 3b 20 20 32 2e 20 41 64 64 ed?.. ;; 2. Add
46a0: 20 74 65 73 74 20 66 6f 72 20 74 65 73 74 63 6f test for testco
46b0: 6e 66 69 67 20 77 61 69 76 65 72 20 70 72 6f 70 nfig waiver prop
46c0: 61 67 61 74 69 6f 6e 20 63 6f 6e 74 72 6f 6c 20 agation control
46d0: 68 65 72 65 0a 09 20 3b 3b 0a 09 20 28 70 72 65 here.. ;;.. (pre
46e0: 76 2d 74 65 73 74 20 20 20 28 69 66 20 28 65 71 v-test (if (eq
46f0: 75 61 6c 3f 20 73 74 61 74 75 73 20 22 46 41 49 ual? status "FAI
4700: 4c 22 29 0a 09 09 09 20 20 28 72 6d 74 3a 67 65 L").... (rmt:ge
4710: 74 2d 70 72 65 76 69 6f 75 73 2d 74 65 73 74 2d t-previous-test-
4720: 72 75 6e 2d 72 65 63 6f 72 64 20 72 75 6e 2d 69 run-record run-i
4730: 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d d test-name item
4740: 2d 70 61 74 68 29 0a 09 09 09 20 20 23 66 29 29 -path).... #f))
4750: 0a 09 20 28 77 61 69 76 65 64 20 20 20 28 69 66 .. (waived (if
4760: 20 70 72 65 76 2d 74 65 73 74 0a 09 09 20 20 20 prev-test...
4770: 20 20 20 20 28 69 66 20 70 72 65 76 2d 74 65 73 (if prev-tes
4780: 74 20 3b 3b 20 74 72 75 65 20 69 66 20 77 65 20 t ;; true if we
4790: 66 6f 75 6e 64 20 61 20 70 72 65 76 69 6f 75 73 found a previous
47a0: 20 74 65 73 74 20 69 6e 20 74 68 69 73 20 72 75 test in this ru
47b0: 6e 20 73 65 72 69 65 73 0a 09 09 09 20 20 20 28 n series.... (
47c0: 6c 65 74 20 28 28 70 72 65 76 2d 73 74 61 74 75 let ((prev-statu
47d0: 73 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d s (db:test-get-
47e0: 73 74 61 74 75 73 20 20 70 72 65 76 2d 74 65 73 status prev-tes
47f0: 74 29 29 0a 09 09 09 09 20 28 70 72 65 76 2d 73 t))..... (prev-s
4800: 74 61 74 65 20 20 20 28 64 62 3a 74 65 73 74 2d tate (db:test-
4810: 67 65 74 2d 73 74 61 74 65 20 20 20 70 72 65 76 get-state prev
4820: 2d 74 65 73 74 29 29 0a 09 09 09 09 20 28 70 72 -test))..... (pr
4830: 65 76 2d 63 6f 6d 6d 65 6e 74 20 28 64 62 3a 74 ev-comment (db:t
4840: 65 73 74 2d 67 65 74 2d 63 6f 6d 6d 65 6e 74 20 est-get-comment
4850: 70 72 65 76 2d 74 65 73 74 29 29 29 0a 09 09 09 prev-test)))....
4860: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
4870: 74 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 4 *default-log
4880: 2d 70 6f 72 74 2a 20 22 70 72 65 76 2d 73 74 61 -port* "prev-sta
4890: 74 75 73 20 22 20 70 72 65 76 2d 73 74 61 74 75 tus " prev-statu
48a0: 73 20 22 2c 20 70 72 65 76 2d 73 74 61 74 65 20 s ", prev-state
48b0: 22 20 70 72 65 76 2d 73 74 61 74 65 20 22 2c 20 " prev-state ",
48c0: 70 72 65 76 2d 63 6f 6d 6d 65 6e 74 20 22 20 70 prev-comment " p
48d0: 72 65 76 2d 63 6f 6d 6d 65 6e 74 29 0a 09 09 09 rev-comment)....
48e0: 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 65 (if (and (e
48f0: 71 75 61 6c 3f 20 70 72 65 76 2d 73 74 61 74 65 qual? prev-state
4900: 20 20 22 43 4f 4d 50 4c 45 54 45 44 22 29 0a 09 "COMPLETED")..
4910: 09 09 09 20 20 20 20 20 20 28 65 71 75 61 6c 3f ... (equal?
4920: 20 70 72 65 76 2d 73 74 61 74 75 73 20 22 57 41 prev-status "WA
4930: 49 56 45 44 22 29 29 0a 09 09 09 09 20 28 69 66 IVED"))..... (if
4940: 20 63 6f 6d 6d 65 6e 74 0a 09 09 09 09 20 20 20 comment.....
4950: 20 20 63 6f 6d 6d 65 6e 74 0a 09 09 09 09 20 20 comment.....
4960: 20 20 20 70 72 65 76 2d 63 6f 6d 6d 65 6e 74 29 prev-comment)
4970: 20 3b 3b 20 77 61 69 76 65 64 20 69 73 20 65 69 ;; waived is ei
4980: 74 68 65 72 20 74 68 65 20 63 6f 6d 6d 65 6e 74 ther the comment
4990: 20 6f 72 20 23 66 0a 09 09 09 09 20 23 66 29 29 or #f..... #f))
49a0: 0a 09 09 09 20 20 20 23 66 29 0a 09 09 20 20 20 .... #f)...
49b0: 20 20 20 20 23 66 29 29 29 0a 20 20 20 20 28 69 #f))). (i
49c0: 66 20 28 61 6e 64 20 77 61 69 76 65 64 20 0a 09 f (and waived ..
49d0: 20 20 20 20 20 28 74 65 73 74 73 3a 63 68 65 63 (tests:chec
49e0: 6b 2d 77 61 69 76 65 72 2d 65 6c 69 67 69 62 69 k-waiver-eligibi
49f0: 6c 69 74 79 20 74 65 73 74 64 61 74 20 70 72 65 lity testdat pre
4a00: 76 2d 74 65 73 74 29 29 0a 09 28 73 65 74 21 20 v-test))..(set!
4a10: 72 65 61 6c 2d 73 74 61 74 75 73 20 22 57 41 49 real-status "WAI
4a20: 56 45 44 22 29 29 0a 0a 20 20 20 20 28 64 65 62 VED")).. (deb
4a30: 75 67 3a 70 72 69 6e 74 20 34 20 2a 64 65 66 61 ug:print 4 *defa
4a40: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 ult-log-port* "r
4a50: 65 61 6c 2d 73 74 61 74 75 73 20 22 20 72 65 61 eal-status " rea
4a60: 6c 2d 73 74 61 74 75 73 20 22 2c 20 77 61 69 76 l-status ", waiv
4a70: 65 64 20 22 20 77 61 69 76 65 64 20 22 2c 20 73 ed " waived ", s
4a80: 74 61 74 75 73 20 22 20 73 74 61 74 75 73 29 0a tatus " status).
4a90: 0a 20 20 20 20 3b 3b 20 75 70 64 61 74 65 20 74 . ;; update t
4aa0: 68 65 20 70 72 69 6d 61 72 79 20 72 65 63 6f 72 he primary recor
4ab0: 64 20 49 46 20 73 74 61 74 65 20 41 4e 44 20 73 d IF state AND s
4ac0: 74 61 74 75 73 20 61 72 65 20 64 65 66 69 6e 65 tatus are define
4ad0: 64 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 73 d. (if (and s
4ae0: 74 61 74 65 20 73 74 61 74 75 73 29 0a 09 28 62 tate status)..(b
4af0: 65 67 69 6e 0a 09 20 20 28 72 6d 74 3a 73 65 74 egin.. (rmt:set
4b00: 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d 61 6e -state-status-an
4b10: 64 2d 72 6f 6c 6c 2d 75 70 2d 69 74 65 6d 73 20 d-roll-up-items
4b20: 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 69 run-id test-id i
4b30: 74 65 6d 2d 70 61 74 68 20 73 74 61 74 65 20 72 tem-path state r
4b40: 65 61 6c 2d 73 74 61 74 75 73 20 28 69 66 20 77 eal-status (if w
4b50: 61 69 76 65 64 20 77 61 69 76 65 64 20 63 6f 6d aived waived com
4b60: 6d 65 6e 74 29 29 0a 09 20 20 3b 3b 20 28 6d 74 ment)).. ;; (mt
4b70: 3a 70 72 6f 63 65 73 73 2d 74 72 69 67 67 65 72 :process-trigger
4b80: 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 s run-id test-id
4b90: 20 73 74 61 74 65 20 72 65 61 6c 2d 73 74 61 74 state real-stat
4ba0: 75 73 29 20 3b 3b 20 74 72 69 67 67 65 72 73 20 us) ;; triggers
4bb0: 61 72 65 20 63 61 6c 6c 65 64 20 69 6e 20 74 65 are called in te
4bc0: 73 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 st-set-state-sta
4bd0: 74 75 73 0a 09 20 20 29 29 0a 20 20 20 20 0a 20 tus.. )). .
4be0: 20 20 20 3b 3b 20 69 66 20 73 74 61 74 75 73 20 ;; if status
4bf0: 69 73 20 22 41 55 54 4f 22 20 74 68 65 6e 20 63 is "AUTO" then c
4c00: 61 6c 6c 20 72 6f 6c 6c 75 70 20 28 6e 6f 74 65 all rollup (note
4c10: 2c 20 74 68 69 73 20 6f 6e 65 20 6d 6f 64 69 66 , this one modif
4c20: 69 65 73 20 64 61 74 61 20 69 6e 20 74 65 73 74 ies data in test
4c30: 0a 20 20 20 20 3b 3b 20 72 75 6e 20 61 72 65 61 . ;; run area
4c40: 2c 20 69 74 20 64 6f 65 73 20 72 65 6d 6f 74 65 , it does remote
4c50: 20 63 61 6c 6c 73 20 75 6e 64 65 72 20 74 68 65 calls under the
4c60: 20 68 6f 6f 64 2e 0a 20 20 20 20 3b 3b 20 28 69 hood.. ;; (i
4c70: 66 20 28 61 6e 64 20 74 65 73 74 2d 69 64 20 73 f (and test-id s
4c80: 74 61 74 65 20 73 74 61 74 75 73 20 28 65 71 75 tate status (equ
4c90: 61 6c 3f 20 73 74 61 74 75 73 20 22 41 55 54 4f al? status "AUTO
4ca0: 22 29 29 20 0a 20 20 20 20 3b 3b 20 09 28 72 6d ")) . ;; .(rm
4cb0: 74 3a 74 65 73 74 2d 64 61 74 61 2d 72 6f 6c 6c t:test-data-roll
4cc0: 75 70 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 up run-id test-i
4cd0: 64 20 73 74 61 74 75 73 29 29 0a 0a 20 20 20 20 d status))..
4ce0: 3b 3b 20 61 64 64 20 6d 65 74 61 64 61 74 61 20 ;; add metadata
4cf0: 28 6e 65 65 64 20 74 6f 20 64 6f 20 74 68 69 73 (need to do this
4d00: 20 77 61 79 20 74 6f 20 61 76 6f 69 64 20 53 51 way to avoid SQ
4d10: 4c 20 69 6e 6a 65 63 74 69 6f 6e 20 69 73 73 75 L injection issu
4d20: 65 73 29 0a 0a 20 20 20 20 3b 3b 20 3a 66 69 72 es).. ;; :fir
4d30: 73 74 5f 65 72 72 0a 20 20 20 20 3b 3b 20 28 6c st_err. ;; (l
4d40: 65 74 20 28 28 76 61 6c 20 28 68 61 73 68 2d 74 et ((val (hash-t
4d50: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
4d60: 20 6f 74 68 65 72 64 61 74 20 22 3a 66 69 72 73 otherdat ":firs
4d70: 74 5f 65 72 72 22 20 23 66 29 29 29 0a 20 20 20 t_err" #f))).
4d80: 20 3b 3b 20 20 20 28 69 66 20 76 61 6c 0a 20 20 ;; (if val.
4d90: 20 20 3b 3b 20 20 20 20 20 20 20 28 73 71 6c 69 ;; (sqli
4da0: 74 65 33 3a 65 78 65 63 75 74 65 20 64 62 20 22 te3:execute db "
4db0: 55 50 44 41 54 45 20 74 65 73 74 73 20 53 45 54 UPDATE tests SET
4dc0: 20 66 69 72 73 74 5f 65 72 72 3d 3f 20 57 48 45 first_err=? WHE
4dd0: 52 45 20 72 75 6e 5f 69 64 3d 3f 20 41 4e 44 20 RE run_id=? AND
4de0: 74 65 73 74 6e 61 6d 65 3d 3f 20 41 4e 44 20 69 testname=? AND i
4df0: 74 65 6d 5f 70 61 74 68 3d 3f 3b 22 20 76 61 6c tem_path=?;" val
4e00: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
4e10: 65 20 69 74 65 6d 2d 70 61 74 68 29 29 29 0a 20 e item-path))).
4e20: 20 20 20 3b 3b 20 0a 20 20 20 20 3b 3b 20 3b 3b ;; . ;; ;;
4e30: 20 3a 66 69 72 73 74 5f 77 61 72 6e 0a 20 20 20 :first_warn.
4e40: 20 3b 3b 20 28 6c 65 74 20 28 28 76 61 6c 20 28 ;; (let ((val (
4e50: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
4e60: 65 66 61 75 6c 74 20 6f 74 68 65 72 64 61 74 20 efault otherdat
4e70: 22 3a 66 69 72 73 74 5f 77 61 72 6e 22 20 23 66 ":first_warn" #f
4e80: 29 29 29 0a 20 20 20 20 3b 3b 20 20 20 28 69 66 ))). ;; (if
4e90: 20 76 61 6c 0a 20 20 20 20 3b 3b 20 20 20 20 20 val. ;;
4ea0: 20 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 (sqlite3:execu
4eb0: 74 65 20 64 62 20 22 55 50 44 41 54 45 20 74 65 te db "UPDATE te
4ec0: 73 74 73 20 53 45 54 20 66 69 72 73 74 5f 77 61 sts SET first_wa
4ed0: 72 6e 3d 3f 20 57 48 45 52 45 20 72 75 6e 5f 69 rn=? WHERE run_i
4ee0: 64 3d 3f 20 41 4e 44 20 74 65 73 74 6e 61 6d 65 d=? AND testname
4ef0: 3d 3f 20 41 4e 44 20 69 74 65 6d 5f 70 61 74 68 =? AND item_path
4f00: 3d 3f 3b 22 20 76 61 6c 20 72 75 6e 2d 69 64 20 =?;" val run-id
4f10: 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 test-name item-p
4f20: 61 74 68 29 29 29 0a 0a 20 20 20 20 28 6c 65 74 ath))).. (let
4f30: 20 28 28 63 61 74 65 67 6f 72 79 20 28 68 61 73 ((category (has
4f40: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
4f50: 75 6c 74 20 6f 74 68 65 72 64 61 74 20 22 3a 63 ult otherdat ":c
4f60: 61 74 65 67 6f 72 79 22 20 22 22 29 29 0a 09 20 ategory" ""))..
4f70: 20 28 76 61 72 69 61 62 6c 65 20 28 68 61 73 68 (variable (hash
4f80: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
4f90: 6c 74 20 6f 74 68 65 72 64 61 74 20 22 3a 76 61 lt otherdat ":va
4fa0: 72 69 61 62 6c 65 22 20 22 22 29 29 0a 09 20 20 riable" ""))..
4fb0: 28 76 61 6c 75 65 20 20 20 20 28 68 61 73 68 2d (value (hash-
4fc0: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
4fd0: 74 20 6f 74 68 65 72 64 61 74 20 22 3a 76 61 6c t otherdat ":val
4fe0: 75 65 22 20 20 20 20 23 66 29 29 0a 09 20 20 28 ue" #f)).. (
4ff0: 65 78 70 65 63 74 65 64 20 28 68 61 73 68 2d 74 expected (hash-t
5000: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
5010: 20 6f 74 68 65 72 64 61 74 20 22 3a 65 78 70 65 otherdat ":expe
5020: 63 74 65 64 22 20 22 6e 2f 61 22 29 29 0a 09 20 cted" "n/a"))..
5030: 20 28 74 6f 6c 20 20 20 20 20 20 28 68 61 73 68 (tol (hash
5040: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
5050: 6c 74 20 6f 74 68 65 72 64 61 74 20 22 3a 74 6f lt otherdat ":to
5060: 6c 22 20 20 20 20 20 20 22 6e 2f 61 22 29 29 0a l" "n/a")).
5070: 09 20 20 28 75 6e 69 74 73 20 20 20 20 28 68 61 . (units (ha
5080: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
5090: 61 75 6c 74 20 6f 74 68 65 72 64 61 74 20 22 3a ault otherdat ":
50a0: 75 6e 69 74 73 22 20 20 20 20 22 22 29 29 0a 09 units" ""))..
50b0: 20 20 28 74 79 70 65 20 20 20 20 20 28 68 61 73 (type (has
50c0: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
50d0: 75 6c 74 20 6f 74 68 65 72 64 61 74 20 22 3a 74 ult otherdat ":t
50e0: 79 70 65 22 20 20 20 20 20 22 22 29 29 0a 09 20 ype" ""))..
50f0: 20 28 64 63 6f 6d 6d 65 6e 74 20 28 68 61 73 68 (dcomment (hash
5100: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
5110: 6c 74 20 6f 74 68 65 72 64 61 74 20 22 3a 63 6f lt otherdat ":co
5120: 6d 6d 65 6e 74 22 20 20 22 22 29 29 29 0a 20 20 mment" ""))).
5130: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
5140: 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 4 *default-log-
5150: 70 6f 72 74 2a 20 0a 09 09 20 20 20 22 63 61 74 port* ... "cat
5160: 65 67 6f 72 79 3a 20 22 20 63 61 74 65 67 6f 72 egory: " categor
5170: 79 20 22 2c 20 76 61 72 69 61 62 6c 65 3a 20 22 y ", variable: "
5180: 20 76 61 72 69 61 62 6c 65 20 22 2c 20 76 61 6c variable ", val
5190: 75 65 3a 20 22 20 76 61 6c 75 65 0a 09 09 20 20 ue: " value...
51a0: 20 22 2c 20 65 78 70 65 63 74 65 64 3a 20 22 20 ", expected: "
51b0: 65 78 70 65 63 74 65 64 20 22 2c 20 74 6f 6c 3a expected ", tol:
51c0: 20 22 20 74 6f 6c 20 22 2c 20 75 6e 69 74 73 3a " tol ", units:
51d0: 20 22 20 75 6e 69 74 73 29 0a 20 20 20 20 20 20 " units).
51e0: 28 69 66 20 28 61 6e 64 20 76 61 6c 75 65 29 20 (if (and value)
51f0: 3b 3b 20 72 65 71 75 69 72 65 20 6f 6e 6c 79 20 ;; require only
5200: 76 61 6c 75 65 3b 20 42 42 20 77 61 73 2d 20 61 value; BB was- a
5210: 6c 6c 20 74 68 72 65 65 20 72 65 71 75 69 72 65 ll three require
5220: 64 0a 09 20 20 28 6c 65 74 20 28 28 64 61 74 20 d.. (let ((dat
5230: 28 63 6f 6e 63 20 63 61 74 65 67 6f 72 79 20 22 (conc category "
5240: 2c 22 0a 09 09 09 20 20 20 76 61 72 69 61 62 6c ,".... variabl
5250: 65 20 22 2c 22 0a 09 09 09 20 20 20 76 61 6c 75 e ",".... valu
5260: 65 20 20 20 20 22 2c 22 0a 09 09 09 20 20 20 65 e ",".... e
5270: 78 70 65 63 74 65 64 20 22 2c 22 0a 09 09 09 20 xpected ","....
5280: 20 20 74 6f 6c 20 20 20 20 20 20 22 2c 22 0a 09 tol ","..
5290: 09 09 20 20 20 75 6e 69 74 73 20 20 20 20 22 2c .. units ",
52a0: 22 0a 09 09 09 20 20 20 64 63 6f 6d 6d 65 6e 74 ".... dcomment
52b0: 20 22 2c 2c 22 20 3b 3b 20 65 78 74 72 61 20 63 ",," ;; extra c
52c0: 6f 6d 6d 61 20 66 6f 72 20 73 74 61 74 75 73 0a omma for status.
52d0: 09 09 09 20 20 20 74 79 70 65 20 20 20 20 20 29 ... type )
52e0: 29 29 0a 09 20 20 20 20 3b 3b 20 54 68 69 73 20 )).. ;; This
52f0: 77 61 73 20 72 75 6e 20 72 65 6d 6f 74 65 2c 20 was run remote,
5300: 64 6f 6e 27 74 20 74 68 69 6e 6b 20 74 68 61 74 don't think that
5310: 20 6d 61 6b 65 73 20 73 65 6e 73 65 2e 20 50 65 makes sense. Pe
5320: 72 68 61 70 73 20 6e 6f 74 2c 20 62 75 74 20 74 rhaps not, but t
5330: 68 61 74 20 69 73 20 74 68 65 20 65 61 73 69 65 hat is the easie
5340: 73 74 20 70 61 74 68 20 66 6f 72 20 74 68 65 20 st path for the
5350: 6d 6f 6d 65 6e 74 2e 0a 09 20 20 20 20 28 72 6d moment... (rm
5360: 74 3a 63 73 76 2d 3e 74 65 73 74 2d 64 61 74 61 t:csv->test-data
5370: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 0a run-id test-id.
5380: 09 09 09 09 64 61 74 29 0a 09 20 20 20 20 3b 3b ....dat).. ;;
5390: 20 54 68 69 73 20 77 61 73 20 61 64 64 65 64 20 This was added
53a0: 69 6e 20 63 68 65 63 6b 2d 69 6e 20 61 35 61 64 in check-in a5ad
53b0: 66 61 33 66 39 61 2e 20 4d 65 73 73 61 67 65 20 fa3f9a. Message
53c0: 77 61 73 3a 20 22 2e 2e 2e 61 64 64 65 64 20 64 was: "...added d
53d0: 65 6c 61 79 20 69 6e 20 73 65 74 2d 76 61 6c 75 elay in set-valu
53e0: 65 73 20 74 6f 20 61 6c 6c 6f 77 20 66 6f 72 20 es to allow for
53f0: 64 65 6c 61 79 65 64 20 77 72 69 74 65 20 6f 6e delayed write on
5400: 20 73 65 72 76 65 72 20 73 74 61 72 74 22 0a 09 server start"..
5410: 20 20 20 20 3b 3b 20 49 27 6d 20 69 6e 73 65 72 ;; I'm inser
5420: 74 69 6e 67 20 61 6e 20 61 72 62 69 74 72 61 72 ting an arbitrar
5430: 79 20 72 6d 74 3a 20 63 61 6c 6c 20 74 6f 20 66 y rmt: call to f
5440: 6f 72 63 65 2f 65 6e 73 75 72 65 20 74 68 61 74 orce/ensure that
5450: 20 74 68 65 20 73 65 72 76 65 72 20 69 73 20 61 the server is a
5460: 76 61 69 6c 61 62 6c 65 20 74 6f 20 28 68 6f 70 vailable to (hop
5470: 65 66 75 6c 6c 79 29 20 70 72 65 76 65 6e 74 20 efully) prevent
5480: 61 20 63 6f 6d 6d 75 6e 69 63 61 74 69 6f 6e 20 a communication
5490: 69 73 73 75 65 2e 0a 09 20 20 20 20 28 72 6d 74 issue... (rmt
54a0: 3a 67 65 74 2d 76 61 72 20 22 4d 45 47 41 54 45 :get-var "MEGATE
54b0: 53 54 5f 56 45 52 53 49 4f 4e 22 29 20 3b 3b 20 ST_VERSION") ;;
54c0: 74 68 69 73 20 64 6f 65 73 20 4e 4f 54 48 49 4e this does NOTHIN
54d0: 47 20 62 75 74 20 65 6e 73 75 72 65 20 74 68 65 G but ensure the
54e0: 20 73 65 72 76 65 72 20 69 73 20 72 65 61 63 68 server is reach
54f0: 61 62 6c 65 2e 20 54 68 69 73 20 69 73 20 61 6c able. This is al
5500: 6d 6f 73 74 20 63 65 72 74 61 69 6e 6c 79 20 4e most certainly N
5510: 4f 54 20 6e 65 65 64 65 64 20 3a 29 0a 20 20 20 OT needed :).
5520: 20 20 20 20 20 20 20 20 20 3b 3b 20 42 42 20 2d ;; BB -
5530: 20 63 6f 6d 6d 65 6e 74 69 6f 6e 67 20 6f 75 74 commentiong out
5540: 20 61 72 62 69 74 72 61 72 79 20 31 30 20 73 65 arbitrary 10 se
5550: 63 6f 6e 64 20 77 61 69 74 20 28 74 68 72 65 61 cond wait (threa
5560: 64 2d 73 6c 65 65 70 21 20 31 30 29 20 3b 3b 20 d-sleep! 10) ;;
5570: 61 64 64 20 31 30 20 73 65 63 6f 6e 64 20 64 65 add 10 second de
5580: 6c 61 79 20 62 65 66 6f 72 65 20 71 75 69 74 20 lay before quit
5590: 69 6e 63 61 73 65 20 72 6d 74 20 6e 65 65 64 73 incase rmt needs
55a0: 20 74 69 6d 65 20 74 6f 20 73 74 61 72 74 20 61 time to start a
55b0: 20 73 65 72 76 65 72 2e 0a 20 20 20 20 20 20 20 server..
55c0: 20 20 20 20 20 29 29 29 0a 20 20 20 20 20 20 0a ))). .
55d0: 20 20 20 20 3b 3b 20 6e 65 65 64 20 74 6f 20 75 ;; need to u
55e0: 70 64 61 74 65 20 74 68 65 20 74 6f 70 20 74 65 pdate the top te
55f0: 73 74 20 72 65 63 6f 72 64 20 69 66 20 50 41 53 st record if PAS
5600: 53 20 6f 72 20 46 41 49 4c 20 61 6e 64 20 74 68 S or FAIL and th
5610: 69 73 20 69 73 20 61 20 73 75 62 74 65 73 74 0a is is a subtest.
5620: 20 20 20 20 3b 3b 3b 3b 3b 3b 20 28 69 66 20 28 ;;;;;; (if (
5630: 6e 6f 74 20 28 65 71 75 61 6c 3f 20 69 74 65 6d not (equal? item
5640: 2d 70 61 74 68 20 22 22 29 29 0a 20 20 20 20 3b -path "")). ;
5650: 3b 3b 3b 3b 3b 20 20 20 20 20 28 72 6d 74 3a 73 ;;;;; (rmt:s
5660: 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d et-state-status-
5670: 61 6e 64 2d 72 6f 6c 6c 2d 75 70 2d 69 74 65 6d and-roll-up-item
5680: 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 s run-id test-na
5690: 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 73 74 61 me item-path sta
56a0: 74 65 20 73 74 61 74 75 73 20 23 66 29 20 3b 3b te status #f) ;;
56b0: 3b 3b 3b 29 0a 0a 20 20 20 20 28 69 66 20 28 6f ;;;).. (if (o
56c0: 72 20 28 61 6e 64 20 28 73 74 72 69 6e 67 3f 20 r (and (string?
56d0: 63 6f 6d 6d 65 6e 74 29 0a 09 09 20 28 73 74 72 comment)... (str
56e0: 69 6e 67 2d 6d 61 74 63 68 20 28 72 65 67 65 78 ing-match (regex
56f0: 70 20 22 5c 5c 53 2b 22 29 20 63 6f 6d 6d 65 6e p "\\S+") commen
5700: 74 29 29 0a 09 20 20 20 20 77 61 69 76 65 64 29 t)).. waived)
5710: 0a 09 28 6c 65 74 20 28 28 63 6d 74 20 20 28 69 ..(let ((cmt (i
5720: 66 20 77 61 69 76 65 64 20 77 61 69 76 65 64 20 f waived waived
5730: 63 6f 6d 6d 65 6e 74 29 29 29 0a 09 20 20 28 72 comment))).. (r
5740: 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 mt:general-call
5750: 27 73 65 74 2d 74 65 73 74 2d 63 6f 6d 6d 65 6e 'set-test-commen
5760: 74 20 72 75 6e 2d 69 64 20 63 6d 74 20 74 65 73 t run-id cmt tes
5770: 74 2d 69 64 29 29 29 29 29 0a 0a 28 64 65 66 69 t-id)))))..(defi
5780: 6e 65 20 28 74 65 73 74 73 3a 74 65 73 74 2d 73 ne (tests:test-s
5790: 65 74 2d 74 6f 70 6c 6f 67 21 20 72 75 6e 2d 69 et-toplog! run-i
57a0: 64 20 74 65 73 74 2d 6e 61 6d 65 20 6c 6f 67 66 d test-name logf
57b0: 29 20 0a 20 20 28 72 6d 74 3a 67 65 6e 65 72 61 ) . (rmt:genera
57c0: 6c 2d 63 61 6c 6c 20 27 74 65 73 74 73 3a 74 65 l-call 'tests:te
57d0: 73 74 2d 73 65 74 2d 74 6f 70 6c 6f 67 20 72 75 st-set-toplog ru
57e0: 6e 2d 69 64 20 6c 6f 67 66 20 72 75 6e 2d 69 64 n-id logf run-id
57f0: 20 74 65 73 74 2d 6e 61 6d 65 29 29 0a 0a 28 64 test-name))..(d
5800: 65 66 69 6e 65 20 28 74 65 73 74 73 3a 73 75 6d efine (tests:sum
5810: 6d 61 72 69 7a 65 2d 69 74 65 6d 73 20 72 75 6e marize-items run
5820: 2d 69 64 20 74 65 73 74 2d 69 64 20 74 65 73 74 -id test-id test
5830: 2d 6e 61 6d 65 20 66 6f 72 63 65 29 0a 20 20 3b -name force). ;
5840: 3b 20 69 66 20 6e 6f 74 20 66 6f 72 63 65 20 74 ; if not force t
5850: 68 65 6e 20 6f 6e 6c 79 20 75 70 64 61 74 65 20 hen only update
5860: 74 68 65 20 72 65 63 6f 72 64 20 69 66 20 6f 6e the record if on
5870: 65 20 6f 66 20 74 68 65 73 65 20 69 73 20 74 72 e of these is tr
5880: 75 65 3a 0a 20 20 3b 3b 20 20 20 31 2e 20 6c 6f ue:. ;; 1. lo
5890: 67 66 20 69 73 20 22 6c 6f 67 2f 66 69 6e 61 6c gf is "log/final
58a0: 2e 6c 6f 67 0a 20 20 3b 3b 20 20 20 32 2e 20 6c .log. ;; 2. l
58b0: 6f 67 66 20 69 73 20 73 61 6d 65 20 61 73 20 6f ogf is same as o
58c0: 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 0a 20 20 utputfilename.
58d0: 28 6c 65 74 2a 20 28 28 6f 75 74 70 75 74 66 69 (let* ((outputfi
58e0: 6c 65 6e 61 6d 65 20 28 63 6f 6e 63 20 22 6d 65 lename (conc "me
58f0: 67 61 74 65 73 74 2d 72 6f 6c 6c 75 70 2d 22 20 gatest-rollup-"
5900: 74 65 73 74 2d 6e 61 6d 65 20 22 2e 68 74 6d 6c test-name ".html
5910: 22 29 29 0a 09 20 28 6f 72 69 67 2d 64 69 72 20 ")).. (orig-dir
5920: 20 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d 64 (current-d
5930: 69 72 65 63 74 6f 72 79 29 29 0a 09 20 28 6c 6f irectory)).. (lo
5940: 67 66 2d 69 6e 66 6f 20 20 20 20 20 20 28 72 6d gf-info (rm
5950: 74 3a 74 65 73 74 2d 67 65 74 2d 6c 6f 67 66 69 t:test-get-logfi
5960: 6c 65 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 20 74 le-info run-id t
5970: 65 73 74 2d 6e 61 6d 65 29 29 0a 09 20 28 6c 6f est-name)).. (lo
5980: 67 66 20 20 20 20 20 20 20 20 20 20 20 28 69 66 gf (if
5990: 20 6c 6f 67 66 2d 69 6e 66 6f 20 28 63 61 64 72 logf-info (cadr
59a0: 20 6c 6f 67 66 2d 69 6e 66 6f 29 20 23 66 29 29 logf-info) #f))
59b0: 0a 09 20 28 70 61 74 68 20 20 20 20 20 20 20 20 .. (path
59c0: 20 20 20 28 69 66 20 6c 6f 67 66 2d 69 6e 66 6f (if logf-info
59d0: 20 28 63 61 72 20 20 6c 6f 67 66 2d 69 6e 66 6f (car logf-info
59e0: 29 20 23 66 29 29 29 0a 20 20 20 20 3b 3b 20 54 ) #f))). ;; T
59f0: 68 69 73 20 71 75 65 72 79 20 66 69 6e 64 73 20 his query finds
5a00: 74 68 65 20 70 61 74 68 20 61 6e 64 20 63 68 61 the path and cha
5a10: 6e 67 65 73 20 74 68 65 20 64 69 72 65 63 74 6f nges the directo
5a20: 72 79 20 74 6f 20 69 74 20 66 6f 72 20 74 68 65 ry to it for the
5a30: 20 74 65 73 74 0a 20 20 20 20 28 69 66 20 28 61 test. (if (a
5a40: 6e 64 20 28 73 74 72 69 6e 67 3f 20 70 61 74 68 nd (string? path
5a50: 29 0a 09 20 20 20 20 20 28 64 69 72 65 63 74 6f ).. (directo
5a60: 72 79 3f 20 70 61 74 68 29 29 20 3b 3b 20 63 61 ry? path)) ;; ca
5a70: 6e 20 67 65 74 20 23 66 20 68 65 72 65 20 75 6e n get #f here un
5a80: 64 65 72 20 73 6f 6d 65 20 77 69 65 72 64 20 63 der some wierd c
5a90: 6f 6e 64 69 74 69 6f 6e 73 2e 20 77 68 79 2c 20 onditions. why,
5aa0: 75 6e 6b 6e 6f 77 6e 20 2e 2e 2e 0a 09 28 62 65 unknown .....(be
5ab0: 67 69 6e 0a 09 20 20 28 64 65 62 75 67 3a 70 72 gin.. (debug:pr
5ac0: 69 6e 74 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c int 4 *default-l
5ad0: 6f 67 2d 70 6f 72 74 2a 20 22 46 6f 75 6e 64 20 og-port* "Found
5ae0: 70 61 74 68 3a 20 22 20 70 61 74 68 29 0a 09 20 path: " path)..
5af0: 20 28 63 68 61 6e 67 65 2d 64 69 72 65 63 74 6f (change-directo
5b00: 72 79 20 70 61 74 68 29 29 0a 09 3b 3b 20 28 73 ry path))..;; (s
5b10: 65 74 21 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 et! outputfilena
5b20: 6d 65 20 28 63 6f 6e 63 20 70 61 74 68 20 22 2f me (conc path "/
5b30: 22 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 " outputfilename
5b40: 29 29 29 0a 09 28 64 65 62 75 67 3a 70 72 69 6e )))..(debug:prin
5b50: 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 t-error 0 *defau
5b60: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 75 lt-log-port* "su
5b70: 6d 6d 61 72 69 7a 65 2d 69 74 65 6d 73 20 66 6f mmarize-items fo
5b80: 72 20 72 75 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 r run-id=" run-i
5b90: 64 20 22 2c 20 74 65 73 74 2d 6e 61 6d 65 3d 22 d ", test-name="
5ba0: 20 74 65 73 74 2d 6e 61 6d 65 20 22 2c 20 6e 6f test-name ", no
5bb0: 20 73 75 63 68 20 70 61 74 68 3a 20 22 20 70 61 such path: " pa
5bc0: 74 68 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a th)). (debug:
5bd0: 70 72 69 6e 74 20 34 20 2a 64 65 66 61 75 6c 74 print 4 *default
5be0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 75 6d 6d -log-port* "summ
5bf0: 61 72 69 7a 65 2d 69 74 65 6d 73 20 77 69 74 68 arize-items with
5c00: 20 6c 6f 67 66 20 22 20 6c 6f 67 66 20 22 2c 20 logf " logf ",
5c10: 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 20 22 outputfilename "
5c20: 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 20 outputfilename
5c30: 22 20 61 6e 64 20 66 6f 72 63 65 20 22 20 66 6f " and force " fo
5c40: 72 63 65 29 0a 20 20 20 20 28 69 66 20 28 6f 72 rce). (if (or
5c50: 20 28 65 71 75 61 6c 3f 20 6c 6f 67 66 20 22 6c (equal? logf "l
5c60: 6f 67 73 2f 66 69 6e 61 6c 2e 6c 6f 67 22 29 0a ogs/final.log").
5c70: 09 20 20 20 20 28 65 71 75 61 6c 3f 20 6c 6f 67 . (equal? log
5c80: 66 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 f outputfilename
5c90: 29 0a 09 20 20 20 20 66 6f 72 63 65 29 0a 09 28 ).. force)..(
5ca0: 6c 65 74 20 28 28 6d 79 2d 73 74 61 72 74 2d 74 let ((my-start-t
5cb0: 69 6d 65 20 28 63 75 72 72 65 6e 74 2d 73 65 63 ime (current-sec
5cc0: 6f 6e 64 73 29 29 0a 09 20 20 20 20 20 20 28 6c onds)).. (l
5cd0: 6f 63 6b 66 20 20 20 20 20 20 20 20 20 28 63 6f ockf (co
5ce0: 6e 63 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d nc outputfilenam
5cf0: 65 20 22 2e 6c 6f 63 6b 22 29 29 29 0a 09 20 20 e ".lock")))..
5d00: 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 61 76 65 (let loop ((have
5d10: 2d 6c 6f 63 6b 20 20 28 63 6f 6d 6d 6f 6e 3a 73 -lock (common:s
5d20: 69 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 20 imple-file-lock
5d30: 6c 6f 63 6b 66 29 29 29 0a 09 20 20 20 20 28 69 lockf))).. (i
5d40: 66 20 68 61 76 65 2d 6c 6f 63 6b 0a 09 09 28 6c f have-lock...(l
5d50: 65 74 20 28 28 73 63 72 69 70 74 20 28 63 6f 6e et ((script (con
5d60: 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e figf:lookup *con
5d70: 66 69 67 64 61 74 2a 20 22 74 65 73 74 72 6f 6c figdat* "testrol
5d80: 6c 75 70 22 20 74 65 73 74 2d 6e 61 6d 65 29 29 lup" test-name))
5d90: 29 0a 09 09 20 20 28 70 72 69 6e 74 20 22 4f 62 )... (print "Ob
5da0: 74 61 69 6e 65 64 20 6c 6f 63 6b 20 66 6f 72 20 tained lock for
5db0: 22 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 " outputfilename
5dc0: 29 0a 09 09 20 20 28 72 6d 74 3a 73 65 74 2d 73 )... (rmt:set-s
5dd0: 74 61 74 65 2d 73 74 61 74 75 73 2d 61 6e 64 2d tate-status-and-
5de0: 72 6f 6c 6c 2d 75 70 2d 69 74 65 6d 73 20 72 75 roll-up-items ru
5df0: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 22 n-id test-name "
5e00: 22 20 23 66 20 23 66 20 23 66 29 0a 09 09 20 20 " #f #f #f)...
5e10: 28 69 66 20 73 63 72 69 70 74 0a 09 09 20 20 20 (if script...
5e20: 20 20 20 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 (system (conc
5e30: 20 73 63 72 69 70 74 20 22 20 3e 20 22 20 6f 75 script " > " ou
5e40: 74 70 75 74 66 69 6c 65 6e 61 6d 65 20 22 20 26 tputfilename " &
5e50: 20 22 29 29 0a 09 09 20 20 20 20 20 20 28 74 65 "))... (te
5e60: 73 74 73 3a 67 65 6e 65 72 61 74 65 2d 68 74 6d sts:generate-htm
5e70: 6c 2d 73 75 6d 6d 61 72 79 2d 66 6f 72 2d 69 74 l-summary-for-it
5e80: 65 72 61 74 65 64 2d 74 65 73 74 20 72 75 6e 2d erated-test run-
5e90: 69 64 20 74 65 73 74 2d 69 64 20 74 65 73 74 2d id test-id test-
5ea0: 6e 61 6d 65 20 6f 75 74 70 75 74 66 69 6c 65 6e name outputfilen
5eb0: 61 6d 65 29 29 0a 09 09 20 20 28 63 6f 6d 6d 6f ame))... (commo
5ec0: 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 72 65 n:simple-file-re
5ed0: 6c 65 61 73 65 2d 6c 6f 63 6b 20 6c 6f 63 6b 66 lease-lock lockf
5ee0: 29 0a 09 09 20 20 28 63 68 61 6e 67 65 2d 64 69 )... (change-di
5ef0: 72 65 63 74 6f 72 79 20 6f 72 69 67 2d 64 69 72 rectory orig-dir
5f00: 29 0a 09 09 20 20 3b 3b 20 4e 42 2f 2f 20 74 65 )... ;; NB// te
5f10: 73 74 73 3a 74 65 73 74 2d 73 65 74 2d 74 6f 70 sts:test-set-top
5f20: 6c 6f 67 21 20 69 73 20 72 65 6d 6f 74 65 20 69 log! is remote i
5f30: 6e 74 65 72 6e 61 6c 2e 2e 2e 0a 09 09 20 20 28 nternal...... (
5f40: 74 65 73 74 73 3a 74 65 73 74 2d 73 65 74 2d 74 tests:test-set-t
5f50: 6f 70 6c 6f 67 21 20 72 75 6e 2d 69 64 20 74 65 oplog! run-id te
5f60: 73 74 2d 6e 61 6d 65 20 6f 75 74 70 75 74 66 69 st-name outputfi
5f70: 6c 65 6e 61 6d 65 29 29 0a 09 09 3b 3b 20 64 69 lename))...;; di
5f80: 64 6e 27 74 20 67 65 74 20 74 68 65 20 6c 6f 63 dn't get the loc
5f90: 6b 2c 20 63 68 65 63 6b 20 74 6f 20 73 65 65 20 k, check to see
5fa0: 69 66 20 63 75 72 72 65 6e 74 20 75 70 64 61 74 if current updat
5fb0: 65 20 73 74 61 72 74 65 64 20 6c 61 74 65 72 20 e started later
5fc0: 74 68 61 6e 20 74 68 69 73 20 0a 09 09 3b 3b 20 than this ...;;
5fd0: 75 70 64 61 74 65 2c 20 69 66 20 73 6f 20 77 65 update, if so we
5fe0: 20 63 61 6e 20 65 78 69 74 20 77 69 74 68 6f 75 can exit withou
5ff0: 74 20 64 6f 69 6e 67 20 61 6e 79 20 77 6f 72 6b t doing any work
6000: 0a 09 09 28 69 66 20 28 3e 20 6d 79 2d 73 74 61 ...(if (> my-sta
6010: 72 74 2d 74 69 6d 65 20 28 68 61 6e 64 6c 65 2d rt-time (handle-
6020: 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 09 09 09 exceptions......
6030: 20 65 78 6e 0a 09 09 09 09 20 20 20 20 20 20 20 exn.....
6040: 28 62 65 67 69 6e 0a 09 09 09 09 09 20 28 70 72 (begin...... (pr
6050: 69 6e 74 20 22 66 61 69 6c 65 64 20 74 6f 20 67 int "failed to g
6060: 65 74 20 6d 6f 64 20 74 69 6d 65 20 6f 6e 20 22 et mod time on "
6070: 20 6c 6f 63 6b 66 20 22 2c 20 65 78 6e 3d 22 20 lockf ", exn="
6080: 65 78 6e 29 0a 09 09 09 09 09 20 30 29 0a 09 09 exn)...... 0)...
6090: 09 09 20 20 20 20 20 20 20 28 66 69 6c 65 2d 6d .. (file-m
60a0: 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 odification-time
60b0: 20 6c 6f 63 6b 66 29 29 29 0a 09 09 20 20 20 20 lockf)))...
60c0: 3b 3b 20 77 65 20 73 74 61 72 74 65 64 20 73 69 ;; we started si
60d0: 6e 63 65 20 63 75 72 72 65 6e 74 20 72 65 2d 67 nce current re-g
60e0: 65 6e 20 69 6e 20 66 6c 69 67 68 74 2c 20 64 65 en in flight, de
60f0: 6c 61 79 20 61 20 6c 69 74 74 6c 65 20 61 6e 64 lay a little and
6100: 20 74 72 79 20 61 67 61 69 6e 0a 09 09 20 20 20 try again...
6110: 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 20 20 (begin...
6120: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
6130: 6f 20 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 1 *default-log
6140: 2d 70 6f 72 74 2a 20 22 57 61 69 74 69 6e 67 20 -port* "Waiting
6150: 74 6f 20 75 70 64 61 74 65 20 22 20 6f 75 74 70 to update " outp
6160: 75 74 66 69 6c 65 6e 61 6d 65 20 22 2c 20 61 6e utfilename ", an
6170: 6f 74 68 65 72 20 74 65 73 74 20 63 75 72 72 65 other test curre
6180: 6e 74 6c 79 20 75 70 64 61 74 69 6e 67 20 69 74 ntly updating it
6190: 22 29 0a 09 09 20 20 20 20 20 20 28 74 68 72 65 ")... (thre
61a0: 61 64 2d 73 6c 65 65 70 21 20 28 2b 20 35 20 28 ad-sleep! (+ 5 (
61b0: 72 61 6e 64 6f 6d 20 35 29 29 29 20 3b 3b 20 64 random 5))) ;; d
61c0: 65 6c 61 79 20 62 65 74 77 65 65 6e 20 35 20 61 elay between 5 a
61d0: 6e 64 20 31 30 20 73 65 63 6f 6e 64 73 0a 09 09 nd 10 seconds...
61e0: 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 6f 6d (loop (com
61f0: 6d 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d mon:simple-file-
6200: 6c 6f 63 6b 20 6c 6f 63 6b 66 29 29 29 29 29 29 lock lockf))))))
6210: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 ))))..(define (t
6220: 65 73 74 73 3a 67 65 6e 65 72 61 74 65 2d 68 74 ests:generate-ht
6230: 6d 6c 2d 73 75 6d 6d 61 72 79 2d 66 6f 72 2d 69 ml-summary-for-i
6240: 74 65 72 61 74 65 64 2d 74 65 73 74 20 72 75 6e terated-test run
6250: 2d 69 64 20 74 65 73 74 2d 69 64 20 74 65 73 74 -id test-id test
6260: 2d 6e 61 6d 65 20 6f 75 74 70 75 74 66 69 6c 65 -name outputfile
6270: 6e 61 6d 65 29 0a 20 20 28 6c 65 74 20 28 28 63 name). (let ((c
6280: 6f 75 6e 74 73 20 20 20 20 20 20 20 20 20 20 20 ounts
6290: 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 (make-hash-ta
62a0: 62 6c 65 29 29 0a 09 28 73 74 61 74 65 63 6f 75 ble))..(statecou
62b0: 6e 74 73 20 20 20 20 20 20 20 20 20 28 6d 61 6b nts (mak
62c0: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 09 e-hash-table))..
62d0: 28 6f 75 74 74 78 74 20 20 20 20 20 20 20 20 20 (outtxt
62e0: 20 20 20 20 20 22 22 29 0a 09 28 74 6f 74 20 20 "")..(tot
62f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 30 0
6300: 29 0a 09 28 74 65 73 74 64 61 74 20 20 20 20 20 )..(testdat
6310: 20 20 20 20 20 20 20 20 28 72 6d 74 3a 74 65 73 (rmt:tes
6320: 74 2d 67 65 74 2d 72 65 63 6f 72 64 73 2d 66 6f t-get-records-fo
6330: 72 2d 69 6e 64 65 78 2d 66 69 6c 65 20 72 75 6e r-index-file run
6340: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 -id test-name)))
6350: 0a 20 20 20 20 28 77 69 74 68 2d 6f 75 74 70 75 . (with-outpu
6360: 74 2d 74 6f 2d 66 69 6c 65 20 6f 75 74 70 75 74 t-to-file output
6370: 66 69 6c 65 6e 61 6d 65 0a 20 20 20 20 20 20 28 filename. (
6380: 6c 61 6d 62 64 61 20 28 29 0a 09 28 73 65 74 21 lambda ()..(set!
6390: 20 6f 75 74 74 78 74 20 28 63 6f 6e 63 20 6f 75 outtxt (conc ou
63a0: 74 74 78 74 20 22 3c 68 74 6d 6c 3e 3c 74 69 74 ttxt "<html><tit
63b0: 6c 65 3e 53 75 6d 6d 61 72 79 3a 20 22 20 74 65 le>Summary: " te
63c0: 73 74 2d 6e 61 6d 65 20 0a 09 09 09 20 20 20 22 st-name .... "
63d0: 3c 2f 74 69 74 6c 65 3e 3c 62 6f 64 79 3e 3c 68 </title><body><h
63e0: 32 3e 53 75 6d 6d 61 72 79 20 66 6f 72 20 22 20 2>Summary for "
63f0: 74 65 73 74 2d 6e 61 6d 65 20 22 3c 2f 68 32 3e test-name "</h2>
6400: 22 29 29 0a 09 28 66 6f 72 2d 65 61 63 68 0a 09 "))..(for-each..
6410: 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 72 65 (lambda (testre
6420: 63 6f 72 64 29 0a 09 20 20 20 28 6c 65 74 20 28 cord).. (let (
6430: 28 69 64 20 20 20 20 20 20 20 20 20 20 20 20 20 (id
6440: 28 76 65 63 74 6f 72 2d 72 65 66 20 74 65 73 74 (vector-ref test
6450: 72 65 63 6f 72 64 20 30 29 29 0a 09 09 20 28 69 record 0))... (i
6460: 74 65 6d 70 61 74 68 20 20 20 20 20 20 20 28 76 tempath (v
6470: 65 63 74 6f 72 2d 72 65 66 20 74 65 73 74 72 65 ector-ref testre
6480: 63 6f 72 64 20 31 29 29 0a 09 09 20 28 73 74 61 cord 1))... (sta
6490: 74 65 20 20 20 20 20 20 20 20 20 20 28 76 65 63 te (vec
64a0: 74 6f 72 2d 72 65 66 20 74 65 73 74 72 65 63 6f tor-ref testreco
64b0: 72 64 20 32 29 29 0a 09 09 20 28 73 74 61 74 75 rd 2))... (statu
64c0: 73 20 20 20 20 20 20 20 20 20 28 76 65 63 74 6f s (vecto
64d0: 72 2d 72 65 66 20 74 65 73 74 72 65 63 6f 72 64 r-ref testrecord
64e0: 20 33 29 29 0a 09 09 20 28 72 75 6e 5f 64 75 72 3))... (run_dur
64f0: 61 74 69 6f 6e 20 20 20 28 76 65 63 74 6f 72 2d ation (vector-
6500: 72 65 66 20 74 65 73 74 72 65 63 6f 72 64 20 34 ref testrecord 4
6510: 29 29 0a 09 09 20 28 6c 6f 67 66 20 20 20 20 20 ))... (logf
6520: 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 (vector-re
6530: 66 20 74 65 73 74 72 65 63 6f 72 64 20 35 29 29 f testrecord 5))
6540: 0a 09 09 20 28 63 6f 6d 6d 65 6e 74 20 20 20 20 ... (comment
6550: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
6560: 74 65 73 74 72 65 63 6f 72 64 20 36 29 29 29 0a testrecord 6))).
6570: 09 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c . (hash-tabl
6580: 65 2d 73 65 74 21 20 63 6f 75 6e 74 73 20 73 74 e-set! counts st
6590: 61 74 75 73 20 28 2b 20 31 20 28 68 61 73 68 2d atus (+ 1 (hash-
65a0: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
65b0: 74 20 63 6f 75 6e 74 73 20 73 74 61 74 75 73 20 t counts status
65c0: 30 29 29 29 0a 09 20 20 20 20 20 28 68 61 73 68 0))).. (hash
65d0: 2d 74 61 62 6c 65 2d 73 65 74 21 20 73 74 61 74 -table-set! stat
65e0: 65 63 6f 75 6e 74 73 20 73 74 61 74 65 20 28 2b ecounts state (+
65f0: 20 31 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 1 (hash-table-r
6600: 65 66 2f 64 65 66 61 75 6c 74 20 73 74 61 74 65 ef/default state
6610: 63 6f 75 6e 74 73 20 73 74 61 74 65 20 30 29 29 counts state 0))
6620: 29 0a 09 20 20 20 20 20 28 73 65 74 21 20 6f 75 ).. (set! ou
6630: 74 74 78 74 20 28 63 6f 6e 63 20 6f 75 74 74 78 ttxt (conc outtx
6640: 74 20 22 3c 74 72 3e 22 0a 09 09 09 09 3b 3b 20 t "<tr>".....;;
6650: 22 3c 74 64 3e 3c 61 20 68 72 65 66 3d 5c 22 22 "<td><a href=\""
6660: 20 69 74 65 6d 70 61 74 68 20 22 2f 22 20 6c 6f itempath "/" lo
6670: 67 66 20 22 5c 22 3e 20 22 20 69 74 65 6d 70 61 gf "\"> " itempa
6680: 74 68 20 22 3c 2f 61 3e 3c 2f 74 64 3e 22 20 0a th "</a></td>" .
6690: 09 09 09 09 22 3c 74 64 3e 3c 61 20 68 72 65 66 ...."<td><a href
66a0: 3d 5c 22 22 20 69 74 65 6d 70 61 74 68 20 22 2f =\"" itempath "/
66b0: 74 65 73 74 2d 73 75 6d 6d 61 72 79 2e 68 74 6d test-summary.htm
66c0: 6c 5c 22 3e 20 22 20 69 74 65 6d 70 61 74 68 20 l\"> " itempath
66d0: 22 3c 2f 61 3e 3c 2f 74 64 3e 22 20 0a 09 09 09 "</a></td>" ....
66e0: 09 22 3c 74 64 3e 22 20 73 74 61 74 65 20 20 20 ."<td>" state
66f0: 20 22 3c 2f 74 64 3e 22 20 0a 09 09 09 09 22 3c "</td>" ....."<
6700: 74 64 3e 3c 66 6f 6e 74 20 63 6f 6c 6f 72 3d 22 td><font color="
6710: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 6f 6c (common:get-col
6720: 6f 72 2d 66 72 6f 6d 2d 73 74 61 74 75 73 20 73 or-from-status s
6730: 74 61 74 75 73 29 0a 09 09 09 09 22 3e 22 20 20 tatus).....">"
6740: 20 73 74 61 74 75 73 20 20 20 22 3c 2f 66 6f 6e status "</fon
6750: 74 3e 3c 2f 74 64 3e 22 0a 09 09 09 09 22 3c 74 t></td>"....."<t
6760: 64 3e 22 20 28 69 66 20 28 65 71 75 61 6c 3f 20 d>" (if (equal?
6770: 63 6f 6d 6d 65 6e 74 20 22 22 29 0a 09 09 09 09 comment "").....
6780: 09 20 20 20 22 26 6e 62 73 70 3b 22 0a 09 09 09 . " "....
6790: 09 09 20 20 20 63 6f 6d 6d 65 6e 74 29 20 22 3c .. comment) "<
67a0: 2f 74 64 3e 22 0a 09 09 09 09 09 20 20 20 22 3c /td>"...... "<
67b0: 2f 74 72 3e 22 29 29 29 29 0a 09 20 28 69 66 20 /tr>")))).. (if
67c0: 28 6c 69 73 74 3f 20 74 65 73 74 64 61 74 29 0a (list? testdat).
67d0: 09 20 20 20 20 20 74 65 73 74 64 61 74 0a 09 20 . testdat..
67e0: 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 (begin..
67f0: 20 20 20 28 70 72 69 6e 74 20 22 45 52 52 4f 52 (print "ERROR
6800: 3a 20 66 61 69 6c 65 64 20 74 6f 20 67 65 74 20 : failed to get
6810: 72 65 63 6f 72 64 73 20 77 69 74 68 20 72 6d 74 records with rmt
6820: 3a 74 65 73 74 2d 67 65 74 2d 72 65 63 6f 72 64 :test-get-record
6830: 73 2d 66 6f 72 2d 69 6e 64 65 78 2d 66 69 6c 65 s-for-index-file
6840: 20 72 75 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 64 run-id=" run-id
6850: 20 22 74 65 73 74 2d 6e 61 6d 65 3d 22 20 74 65 "test-name=" te
6860: 73 74 2d 6e 61 6d 65 29 0a 09 20 20 20 20 20 20 st-name)..
6870: 20 27 28 29 29 29 29 0a 09 0a 09 28 70 72 69 6e '())))....(prin
6880: 74 20 22 3c 74 61 62 6c 65 3e 3c 74 72 3e 3c 74 t "<table><tr><t
6890: 64 20 76 61 6c 69 67 6e 3d 5c 22 74 6f 70 5c 22 d valign=\"top\"
68a0: 3e 22 29 0a 09 3b 3b 20 50 72 69 6e 74 20 6f 75 >")..;; Print ou
68b0: 74 20 73 74 61 74 73 20 66 6f 72 20 73 74 61 74 t stats for stat
68c0: 75 73 0a 09 28 73 65 74 21 20 74 6f 74 20 30 29 us..(set! tot 0)
68d0: 0a 09 28 70 72 69 6e 74 20 22 3c 74 61 62 6c 65 ..(print "<table
68e0: 20 63 65 6c 6c 73 70 61 63 69 6e 67 3d 5c 22 30 cellspacing=\"0
68f0: 5c 22 20 62 6f 72 64 65 72 3d 5c 22 31 5c 22 3e \" border=\"1\">
6900: 3c 74 72 3e 3c 74 64 20 63 6f 6c 73 70 61 6e 3d <tr><td colspan=
6910: 5c 22 32 5c 22 3e 3c 68 32 3e 53 74 61 74 65 20 \"2\"><h2>State
6920: 73 74 61 74 73 3c 2f 68 32 3e 3c 2f 74 64 3e 3c stats</h2></td><
6930: 2f 74 72 3e 22 29 0a 09 28 66 6f 72 2d 65 61 63 /tr>")..(for-eac
6940: 68 20 28 6c 61 6d 62 64 61 20 28 73 74 61 74 65 h (lambda (state
6950: 29 0a 09 09 20 20 20 20 28 73 65 74 21 20 74 6f )... (set! to
6960: 74 20 28 2b 20 74 6f 74 20 28 68 61 73 68 2d 74 t (+ tot (hash-t
6970: 61 62 6c 65 2d 72 65 66 20 73 74 61 74 65 63 6f able-ref stateco
6980: 75 6e 74 73 20 73 74 61 74 65 29 29 29 0a 09 09 unts state)))...
6990: 20 20 20 20 28 70 72 69 6e 74 20 22 3c 74 72 3e (print "<tr>
69a0: 3c 74 64 3e 22 20 73 74 61 74 65 20 22 3c 2f 74 <td>" state "</t
69b0: 64 3e 3c 74 64 3e 22 20 28 68 61 73 68 2d 74 61 d><td>" (hash-ta
69c0: 62 6c 65 2d 72 65 66 20 73 74 61 74 65 63 6f 75 ble-ref statecou
69d0: 6e 74 73 20 73 74 61 74 65 29 20 22 3c 2f 74 64 nts state) "</td
69e0: 3e 3c 2f 74 72 3e 22 29 29 0a 09 09 20 20 28 68 ></tr>"))... (h
69f0: 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 73 ash-table-keys s
6a00: 74 61 74 65 63 6f 75 6e 74 73 29 29 0a 09 28 70 tatecounts))..(p
6a10: 72 69 6e 74 20 22 3c 74 72 3e 3c 74 64 3e 54 6f rint "<tr><td>To
6a20: 74 61 6c 3c 2f 74 64 3e 3c 74 64 3e 22 20 74 6f tal</td><td>" to
6a30: 74 20 22 3c 2f 74 64 3e 3c 2f 74 72 3e 3c 2f 74 t "</td></tr></t
6a40: 61 62 6c 65 3e 22 29 0a 09 28 70 72 69 6e 74 20 able>")..(print
6a50: 22 3c 2f 74 64 3e 3c 74 64 20 76 61 6c 69 67 6e "</td><td valign
6a60: 3d 5c 22 74 6f 70 5c 22 3e 22 29 0a 09 3b 3b 20 =\"top\">")..;;
6a70: 50 72 69 6e 74 20 6f 75 74 20 73 74 61 74 73 20 Print out stats
6a80: 66 6f 72 20 73 74 61 74 65 0a 09 28 73 65 74 21 for state..(set!
6a90: 20 74 6f 74 20 30 29 0a 09 28 70 72 69 6e 74 20 tot 0)..(print
6aa0: 22 3c 74 61 62 6c 65 20 63 65 6c 6c 73 70 61 63 "<table cellspac
6ab0: 69 6e 67 3d 5c 22 30 5c 22 20 62 6f 72 64 65 72 ing=\"0\" border
6ac0: 3d 5c 22 31 5c 22 3e 3c 74 72 3e 3c 74 64 20 63 =\"1\"><tr><td c
6ad0: 6f 6c 73 70 61 6e 3d 5c 22 32 5c 22 3e 3c 68 32 olspan=\"2\"><h2
6ae0: 3e 53 74 61 74 75 73 20 73 74 61 74 73 3c 2f 68 >Status stats</h
6af0: 32 3e 3c 2f 74 64 3e 3c 2f 74 72 3e 22 29 0a 09 2></td></tr>")..
6b00: 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 (for-each (lambd
6b10: 61 20 28 73 74 61 74 75 73 29 0a 09 09 20 20 20 a (status)...
6b20: 20 28 73 65 74 21 20 74 6f 74 20 28 2b 20 74 6f (set! tot (+ to
6b30: 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 t (hash-table-re
6b40: 66 20 63 6f 75 6e 74 73 20 73 74 61 74 75 73 29 f counts status)
6b50: 29 29 0a 09 09 20 20 20 20 28 70 72 69 6e 74 20 ))... (print
6b60: 22 3c 74 72 3e 3c 74 64 3e 3c 66 6f 6e 74 20 63 "<tr><td><font c
6b70: 6f 6c 6f 72 3d 5c 22 22 20 28 63 6f 6d 6d 6f 6e olor=\"" (common
6b80: 3a 67 65 74 2d 63 6f 6c 6f 72 2d 66 72 6f 6d 2d :get-color-from-
6b90: 73 74 61 74 75 73 20 73 74 61 74 75 73 29 20 22 status status) "
6ba0: 5c 22 3e 22 20 73 74 61 74 75 73 0a 09 09 09 20 \">" status....
6bb0: 20 20 22 3c 2f 66 6f 6e 74 3e 3c 2f 74 64 3e 3c "</font></td><
6bc0: 74 64 3e 22 20 28 68 61 73 68 2d 74 61 62 6c 65 td>" (hash-table
6bd0: 2d 72 65 66 20 63 6f 75 6e 74 73 20 73 74 61 74 -ref counts stat
6be0: 75 73 29 20 22 3c 2f 74 64 3e 3c 2f 74 72 3e 22 us) "</td></tr>"
6bf0: 29 29 0a 09 09 20 20 28 68 61 73 68 2d 74 61 62 ))... (hash-tab
6c00: 6c 65 2d 6b 65 79 73 20 63 6f 75 6e 74 73 29 29 le-keys counts))
6c10: 0a 09 28 70 72 69 6e 74 20 22 3c 74 72 3e 3c 74 ..(print "<tr><t
6c20: 64 3e 54 6f 74 61 6c 3c 2f 74 64 3e 3c 74 64 3e d>Total</td><td>
6c30: 22 20 74 6f 74 20 22 3c 2f 74 64 3e 3c 2f 74 72 " tot "</td></tr
6c40: 3e 3c 2f 74 61 62 6c 65 3e 22 29 0a 09 28 70 72 ></table>")..(pr
6c50: 69 6e 74 20 22 3c 2f 74 64 3e 3c 2f 74 64 3e 3c int "</td></td><
6c60: 2f 74 72 3e 3c 2f 74 61 62 6c 65 3e 22 29 0a 09 /tr></table>")..
6c70: 0a 09 28 70 72 69 6e 74 20 22 3c 74 61 62 6c 65 ..(print "<table
6c80: 20 63 65 6c 6c 73 70 61 63 69 6e 67 3d 5c 22 30 cellspacing=\"0
6c90: 5c 22 20 62 6f 72 64 65 72 3d 5c 22 31 5c 22 3e \" border=\"1\">
6ca0: 22 20 0a 09 20 20 20 20 20 20 20 22 3c 74 72 3e " .. "<tr>
6cb0: 3c 74 64 3e 49 74 65 6d 3c 2f 74 64 3e 3c 74 64 <td>Item</td><td
6cc0: 3e 53 74 61 74 65 3c 2f 74 64 3e 3c 74 64 3e 53 >State</td><td>S
6cd0: 74 61 74 75 73 3c 2f 74 64 3e 3c 74 64 3e 43 6f tatus</td><td>Co
6ce0: 6d 6d 65 6e 74 3c 2f 74 64 3e 22 0a 09 20 20 20 mment</td>"..
6cf0: 20 20 20 20 6f 75 74 74 78 74 20 22 3c 2f 74 61 outtxt "</ta
6d00: 62 6c 65 3e 3c 2f 62 6f 64 79 3e 3c 2f 68 74 6d ble></body></htm
6d10: 6c 3e 22 29 0a 09 3b 3b 20 28 72 65 6c 65 61 73 l>")..;; (releas
6d20: 65 2d 64 6f 74 2d 6c 6f 63 6b 20 6f 75 74 70 75 e-dot-lock outpu
6d30: 74 66 69 6c 65 6e 61 6d 65 29 0a 09 3b 3b 28 72 tfilename)..;;(r
6d40: 6d 74 3a 75 70 64 61 74 65 2d 72 75 6e 2d 73 74 mt:update-run-st
6d50: 61 74 73 20 0a 09 3b 3b 20 72 75 6e 2d 69 64 0a ats ..;; run-id.
6d60: 09 3b 3b 20 28 68 61 73 68 2d 74 61 62 6c 65 2d .;; (hash-table-
6d70: 6d 61 70 0a 09 3b 3b 20 20 73 74 61 74 65 2d 73 map..;; state-s
6d80: 74 61 74 75 73 2d 63 6f 75 6e 74 73 0a 09 3b 3b tatus-counts..;;
6d90: 20 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 20 76 (lambda (key v
6da0: 61 6c 29 0a 09 3b 3b 09 28 61 70 70 65 6e 64 20 al)..;;.(append
6db0: 6b 65 79 20 28 6c 69 73 74 20 76 61 6c 29 29 29 key (list val)))
6dc0: 29 29 0a 09 29 29 29 29 0a 0a 28 64 65 66 69 6e ))..))))..(defin
6dd0: 65 20 74 65 73 74 73 3a 63 73 73 2d 6a 73 63 72 e tests:css-jscr
6de0: 69 70 74 2d 62 6c 6f 63 6b 0a 23 3c 3c 45 4f 46 ipt-block.#<<EOF
6df0: 0a 3c 73 74 79 6c 65 20 74 79 70 65 3d 22 74 65 .<style type="te
6e00: 78 74 2f 63 73 73 22 3e 0a 75 6c 2e 4c 69 6e 6b xt/css">.ul.Link
6e10: 65 64 4c 69 73 74 20 7b 20 64 69 73 70 6c 61 79 edList { display
6e20: 3a 20 62 6c 6f 63 6b 3b 20 7d 0a 2f 2a 20 75 6c : block; }./* ul
6e30: 2e 4c 69 6e 6b 65 64 4c 69 73 74 20 75 6c 20 7b .LinkedList ul {
6e40: 20 64 69 73 70 6c 61 79 3a 20 6e 6f 6e 65 3b 20 display: none;
6e50: 7d 20 2a 2f 0a 2e 48 61 6e 64 43 75 72 73 6f 72 } */..HandCursor
6e60: 53 74 79 6c 65 20 7b 20 63 75 72 73 6f 72 3a 20 Style { cursor:
6e70: 70 6f 69 6e 74 65 72 3b 20 63 75 72 73 6f 72 3a pointer; cursor:
6e80: 20 68 61 6e 64 3b 20 7d 20 20 2f 2a 20 46 6f 72 hand; } /* For
6e90: 20 49 45 20 2a 2f 0a 74 68 20 7b 62 61 63 6b 67 IE */.th {backg
6ea0: 72 6f 75 6e 64 2d 63 6f 6c 6f 72 3a 20 23 38 63 round-color: #8c
6eb0: 38 63 38 63 3b 7d 0a 74 64 2e 74 65 73 74 20 7b 8c8c;}.td.test {
6ec0: 62 61 63 6b 67 72 6f 75 6e 64 2d 63 6f 6c 6f 72 background-color
6ed0: 3a 20 23 64 39 64 62 64 64 3b 7d 0a 74 64 2e 50 : #d9dbdd;}.td.P
6ee0: 41 53 53 20 7b 62 61 63 6b 67 72 6f 75 6e 64 2d ASS {background-
6ef0: 63 6f 6c 6f 72 3a 20 23 33 34 37 35 33 33 3b 7d color: #347533;}
6f00: 0a 74 64 2e 46 41 49 4c 20 7b 62 61 63 6b 67 72 .td.FAIL {backgr
6f10: 6f 75 6e 64 2d 63 6f 6c 6f 72 3a 20 23 63 63 32 ound-color: #cc2
6f20: 38 31 32 3b 7d 0a 74 64 2e 53 4b 49 50 7b 62 61 812;}.td.SKIP{ba
6f30: 63 6b 67 72 6f 75 6e 64 2d 63 6f 6c 6f 72 3a 20 ckground-color:
6f40: 23 46 46 44 37 33 33 3b 7d 0a 74 64 2e 57 41 52 #FFD733;}.td.WAR
6f50: 4e 20 7b 62 61 63 6b 67 72 6f 75 6e 64 2d 63 6f N {background-co
6f60: 6c 6f 72 3a 20 23 45 41 38 37 32 34 3b 7d 0a 74 lor: #EA8724;}.t
6f70: 64 2e 57 41 49 56 45 44 20 7b 62 61 63 6b 67 72 d.WAIVED {backgr
6f80: 6f 75 6e 64 2d 63 6f 6c 6f 72 3a 20 23 38 33 38 ound-color: #838
6f90: 41 31 32 3b 7d 0a 74 64 2e 41 42 4f 52 54 7b 62 A12;}.td.ABORT{b
6fa0: 61 63 6b 67 72 6f 75 6e 64 2d 63 6f 6c 6f 72 3a ackground-color:
6fb0: 20 23 45 41 32 34 42 37 3b 7d 0a 2e 50 41 53 53 #EA24B7;}..PASS
6fc0: 20 2e 6c 69 6e 6b 2c 20 2e 53 4b 49 50 20 2e 6c .link, .SKIP .l
6fd0: 69 6e 6b 2c 20 2e 57 41 52 4e 20 2e 6c 69 6e 6b ink, .WARN .link
6fe0: 2c 2e 57 41 49 56 45 44 20 2e 6c 69 6e 6b 2c 2e ,.WAIVED .link,.
6ff0: 41 42 4f 52 54 20 2e 6c 69 6e 6b 2c 20 2e 46 41 ABORT .link, .FA
7000: 49 4c 20 2e 6c 69 6e 6b 7b 63 6f 6c 6f 72 3a 20 IL .link{color:
7010: 23 46 46 46 46 46 46 3b 7d 0a 0a 0a 3c 2f 73 74 #FFFFFF;}...</st
7020: 79 6c 65 3e 0a 0a 0a 20 20 3c 73 63 72 69 70 74 yle>... <script
7030: 20 74 79 70 65 3d 22 74 65 78 74 2f 4a 61 76 61 type="text/Java
7040: 53 63 72 69 70 74 22 3e 0a 0a 20 20 20 20 66 75 Script">.. fu
7050: 6e 63 74 69 6f 6e 20 66 69 6c 74 65 72 73 6f 6d nction filtersom
7060: 65 28 29 20 7b 0a 20 20 24 28 22 74 72 22 29 2e e() {. $("tr").
7070: 73 68 6f 77 28 29 3b 0a 20 20 24 28 22 2e 74 65 show();. $(".te
7080: 73 74 22 29 2e 66 69 6c 74 65 72 28 0a 20 20 20 st").filter(.
7090: 20 66 75 6e 63 74 69 6f 6e 28 29 20 7b 0a 20 20 function() {.
70a0: 20 20 20 20 76 61 72 20 6e 61 6d 65 73 20 3d 20 var names =
70b0: 24 28 27 23 74 65 73 74 6e 61 6d 65 27 29 2e 76 $('#testname').v
70c0: 61 6c 28 29 2e 73 70 6c 69 74 28 27 2c 27 29 3b al().split(',');
70d0: 0a 20 20 20 20 20 20 76 61 72 20 67 6f 6f 64 3d . var good=
70e0: 31 3b 0a 20 20 20 20 20 20 66 6f 72 20 28 76 61 1;. for (va
70f0: 72 20 69 3d 30 2c 20 6c 65 6e 3d 6e 61 6d 65 73 r i=0, len=names
7100: 2e 6c 65 6e 67 74 68 3b 20 69 3c 6c 65 6e 3b 20 .length; i<len;
7110: 69 2b 2b 29 20 7b 0a 20 20 20 20 20 20 20 20 76 i++) {. v
7120: 61 72 20 75 6e 61 6d 65 3d 6e 61 6d 65 73 5b 69 ar uname=names[i
7130: 5d 3b 0a 20 20 20 20 20 20 20 20 63 6f 6e 73 6f ];. conso
7140: 6c 65 2e 6c 6f 67 28 22 54 72 79 69 6e 67 20 74 le.log("Trying t
7150: 6f 20 63 68 65 63 6b 20 66 6f 72 20 22 20 2b 20 o check for " +
7160: 75 6e 61 6d 65 29 3b 20 0a 20 20 20 20 20 20 20 uname); .
7170: 20 69 66 28 24 28 74 68 69 73 29 2e 74 65 78 74 if($(this).text
7180: 28 29 2e 69 6e 64 65 78 4f 66 28 75 6e 61 6d 65 ().indexOf(uname
7190: 29 20 21 3d 20 2d 31 29 20 7b 0a 20 20 20 20 20 ) != -1) {.
71a0: 20 20 20 20 20 67 6f 6f 64 3d 20 30 3b 0a 20 20 good= 0;.
71b0: 20 20 20 20 20 20 20 20 63 6f 6e 73 6f 6c 65 2e console.
71c0: 6c 6f 67 28 22 46 6f 75 6e 64 20 22 2b 75 6e 61 log("Found "+una
71d0: 6d 65 29 3b 0a 20 20 20 20 20 20 20 20 7d 0a 20 me);. }.
71e0: 20 20 20 20 20 7d 0a 20 20 20 20 20 20 72 65 74 }. ret
71f0: 75 72 6e 20 67 6f 6f 64 3b 20 0a 20 20 20 20 7d urn good; . }
7200: 0a 20 20 29 2e 70 61 72 65 6e 74 28 29 2e 68 69 . ).parent().hi
7210: 64 65 28 29 3b 0a 2f 2f 20 20 24 28 22 2e 73 75 de();.// $(".su
7220: 6d 22 29 2e 73 68 6f 77 28 29 3b 0a 7d 0a 20 20 m").show();.}.
7230: 0a 20 20 20 20 2f 2f 20 41 64 64 20 74 68 69 73 . // Add this
7240: 20 74 6f 20 74 68 65 20 6f 6e 6c 6f 61 64 20 65 to the onload e
7250: 76 65 6e 74 20 6f 66 20 74 68 65 20 42 4f 44 59 vent of the BODY
7260: 20 65 6c 65 6d 65 6e 74 0a 20 20 20 20 66 75 6e element. fun
7270: 63 74 69 6f 6e 20 61 64 64 45 76 65 6e 74 73 28 ction addEvents(
7280: 29 20 7b 0a 20 20 20 20 20 20 61 63 74 69 76 61 ) {. activa
7290: 74 65 54 72 65 65 28 64 6f 63 75 6d 65 6e 74 2e teTree(document.
72a0: 67 65 74 45 6c 65 6d 65 6e 74 42 79 49 64 28 22 getElementById("
72b0: 4c 69 6e 6b 65 64 4c 69 73 74 31 22 29 29 3b 0a LinkedList1"));.
72c0: 20 20 20 20 7d 0a 0a 20 20 20 20 2f 2f 20 54 68 }.. // Th
72d0: 69 73 20 66 75 6e 63 74 69 6f 6e 20 74 72 61 76 is function trav
72e0: 65 72 73 65 73 20 74 68 65 20 6c 69 73 74 20 61 erses the list a
72f0: 6e 64 20 61 64 64 20 6c 69 6e 6b 73 20 0a 20 20 nd add links .
7300: 20 20 2f 2f 20 74 6f 20 6e 65 73 74 65 64 20 6c // to nested l
7310: 69 73 74 20 69 74 65 6d 73 0a 20 20 20 20 66 75 ist items. fu
7320: 6e 63 74 69 6f 6e 20 61 63 74 69 76 61 74 65 54 nction activateT
7330: 72 65 65 28 6f 4c 69 73 74 29 20 7b 0a 20 20 20 ree(oList) {.
7340: 20 20 20 2f 2f 20 43 6f 6c 6c 61 70 73 65 20 74 // Collapse t
7350: 68 65 20 74 72 65 65 0a 20 20 20 20 20 20 66 6f he tree. fo
7360: 72 20 28 76 61 72 20 69 3d 30 3b 20 69 20 3c 20 r (var i=0; i <
7370: 6f 4c 69 73 74 2e 67 65 74 45 6c 65 6d 65 6e 74 oList.getElement
7380: 73 42 79 54 61 67 4e 61 6d 65 28 22 75 6c 22 29 sByTagName("ul")
7390: 2e 6c 65 6e 67 74 68 3b 20 69 2b 2b 29 20 7b 0a .length; i++) {.
73a0: 20 20 20 20 20 20 20 20 6f 4c 69 73 74 2e 67 65 oList.ge
73b0: 74 45 6c 65 6d 65 6e 74 73 42 79 54 61 67 4e 61 tElementsByTagNa
73c0: 6d 65 28 22 75 6c 22 29 5b 69 5d 2e 73 74 79 6c me("ul")[i].styl
73d0: 65 2e 64 69 73 70 6c 61 79 3d 22 6e 6f 6e 65 22 e.display="none"
73e0: 3b 20 20 20 20 20 20 20 20 20 20 20 20 0a 20 20 ; .
73f0: 20 20 20 20 7d 20 20 20 20 20 20 20 20 20 20 20 }
7400: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7410: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7420: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7430: 20 20 20 20 20 20 20 0a 20 20 20 20 20 20 2f 2f . //
7440: 20 41 64 64 20 74 68 65 20 63 6c 69 63 6b 2d 65 Add the click-e
7450: 76 65 6e 74 20 68 61 6e 64 6c 65 72 20 74 6f 20 vent handler to
7460: 74 68 65 20 6c 69 73 74 20 69 74 65 6d 73 0a 20 the list items.
7470: 20 20 20 20 20 69 66 20 28 6f 4c 69 73 74 2e 61 if (oList.a
7480: 64 64 45 76 65 6e 74 4c 69 73 74 65 6e 65 72 29 ddEventListener)
7490: 20 7b 0a 20 20 20 20 20 20 20 20 6f 4c 69 73 74 {. oList
74a0: 2e 61 64 64 45 76 65 6e 74 4c 69 73 74 65 6e 65 .addEventListene
74b0: 72 28 22 63 6c 69 63 6b 22 2c 20 74 6f 67 67 6c r("click", toggl
74c0: 65 42 72 61 6e 63 68 2c 20 66 61 6c 73 65 29 3b eBranch, false);
74d0: 0a 20 20 20 20 20 20 7d 20 65 6c 73 65 20 69 66 . } else if
74e0: 20 28 6f 4c 69 73 74 2e 61 74 74 61 63 68 45 76 (oList.attachEv
74f0: 65 6e 74 29 20 7b 20 2f 2f 20 46 6f 72 20 49 45 ent) { // For IE
7500: 0a 20 20 20 20 20 20 20 20 6f 4c 69 73 74 2e 61 . oList.a
7510: 74 74 61 63 68 45 76 65 6e 74 28 22 6f 6e 63 6c ttachEvent("oncl
7520: 69 63 6b 22 2c 20 74 6f 67 67 6c 65 42 72 61 6e ick", toggleBran
7530: 63 68 29 3b 0a 20 20 20 20 20 20 7d 0a 20 20 20 ch);. }.
7540: 20 20 20 2f 2f 20 4d 61 6b 65 20 74 68 65 20 6e // Make the n
7550: 65 73 74 65 64 20 69 74 65 6d 73 20 6c 6f 6f 6b ested items look
7560: 20 6c 69 6b 65 20 6c 69 6e 6b 73 0a 20 20 20 20 like links.
7570: 20 20 61 64 64 4c 69 6e 6b 73 54 6f 42 72 61 6e addLinksToBran
7580: 63 68 65 73 28 6f 4c 69 73 74 29 3b 0a 20 20 20 ches(oList);.
7590: 20 7d 0a 0a 20 20 20 20 2f 2f 20 54 68 69 73 20 }.. // This
75a0: 69 73 20 74 68 65 20 63 6c 69 63 6b 2d 65 76 65 is the click-eve
75b0: 6e 74 20 68 61 6e 64 6c 65 72 0a 20 20 20 20 66 nt handler. f
75c0: 75 6e 63 74 69 6f 6e 20 74 6f 67 67 6c 65 42 72 unction toggleBr
75d0: 61 6e 63 68 28 65 76 65 6e 74 29 20 7b 0a 20 20 anch(event) {.
75e0: 20 20 20 20 76 61 72 20 6f 42 72 61 6e 63 68 2c var oBranch,
75f0: 20 63 53 75 62 42 72 61 6e 63 68 65 73 3b 0a 20 cSubBranches;.
7600: 20 20 20 20 20 69 66 20 28 65 76 65 6e 74 2e 74 if (event.t
7610: 61 72 67 65 74 29 20 7b 0a 20 20 20 20 20 20 20 arget) {.
7620: 20 6f 42 72 61 6e 63 68 20 3d 20 65 76 65 6e 74 oBranch = event
7630: 2e 74 61 72 67 65 74 3b 0a 20 20 20 20 20 20 7d .target;. }
7640: 20 65 6c 73 65 20 69 66 20 28 65 76 65 6e 74 2e else if (event.
7650: 73 72 63 45 6c 65 6d 65 6e 74 29 20 7b 20 2f 2f srcElement) { //
7660: 20 46 6f 72 20 49 45 0a 20 20 20 20 20 20 20 20 For IE.
7670: 6f 42 72 61 6e 63 68 20 3d 20 65 76 65 6e 74 2e oBranch = event.
7680: 73 72 63 45 6c 65 6d 65 6e 74 3b 0a 20 20 20 20 srcElement;.
7690: 20 20 7d 0a 20 20 20 20 20 20 63 53 75 62 42 72 }. cSubBr
76a0: 61 6e 63 68 65 73 20 3d 20 6f 42 72 61 6e 63 68 anches = oBranch
76b0: 2e 67 65 74 45 6c 65 6d 65 6e 74 73 42 79 54 61 .getElementsByTa
76c0: 67 4e 61 6d 65 28 22 75 6c 22 29 3b 0a 20 20 20 gName("ul");.
76d0: 20 20 20 69 66 20 28 63 53 75 62 42 72 61 6e 63 if (cSubBranc
76e0: 68 65 73 2e 6c 65 6e 67 74 68 20 3e 20 30 29 20 hes.length > 0)
76f0: 7b 0a 20 20 20 20 20 20 20 20 69 66 20 28 63 53 {. if (cS
7700: 75 62 42 72 61 6e 63 68 65 73 5b 30 5d 2e 73 74 ubBranches[0].st
7710: 79 6c 65 2e 64 69 73 70 6c 61 79 20 3d 3d 20 22 yle.display == "
7720: 62 6c 6f 63 6b 22 29 20 7b 0a 20 20 20 20 20 20 block") {.
7730: 20 20 20 20 63 53 75 62 42 72 61 6e 63 68 65 73 cSubBranches
7740: 5b 30 5d 2e 73 74 79 6c 65 2e 64 69 73 70 6c 61 [0].style.displa
7750: 79 20 3d 20 22 6e 6f 6e 65 22 3b 0a 20 20 20 20 y = "none";.
7760: 20 20 20 20 7d 20 65 6c 73 65 20 7b 0a 20 20 20 } else {.
7770: 20 20 20 20 20 20 20 63 53 75 62 42 72 61 6e 63 cSubBranc
7780: 68 65 73 5b 30 5d 2e 73 74 79 6c 65 2e 64 69 73 hes[0].style.dis
7790: 70 6c 61 79 20 3d 20 22 62 6c 6f 63 6b 22 3b 0a play = "block";.
77a0: 20 20 20 20 20 20 20 20 7d 0a 20 20 20 20 20 20 }.
77b0: 7d 0a 20 20 20 20 7d 0a 0a 20 20 20 20 2f 2f 20 }. }.. //
77c0: 54 68 69 73 20 66 75 6e 63 74 69 6f 6e 20 6d 61 This function ma
77d0: 6b 65 73 20 6e 65 73 74 65 64 20 6c 69 73 74 20 kes nested list
77e0: 69 74 65 6d 73 20 6c 6f 6f 6b 20 6c 69 6b 65 20 items look like
77f0: 6c 69 6e 6b 73 0a 20 20 20 20 66 75 6e 63 74 69 links. functi
7800: 6f 6e 20 61 64 64 4c 69 6e 6b 73 54 6f 42 72 61 on addLinksToBra
7810: 6e 63 68 65 73 28 6f 4c 69 73 74 29 20 7b 0a 20 nches(oList) {.
7820: 20 20 20 20 20 76 61 72 20 63 42 72 61 6e 63 68 var cBranch
7830: 65 73 20 3d 20 6f 4c 69 73 74 2e 67 65 74 45 6c es = oList.getEl
7840: 65 6d 65 6e 74 73 42 79 54 61 67 4e 61 6d 65 28 ementsByTagName(
7850: 22 6c 69 22 29 3b 0a 20 20 20 20 20 20 76 61 72 "li");. var
7860: 20 69 2c 20 6e 2c 20 63 53 75 62 42 72 61 6e 63 i, n, cSubBranc
7870: 68 65 73 3b 0a 20 20 20 20 20 20 69 66 20 28 63 hes;. if (c
7880: 42 72 61 6e 63 68 65 73 2e 6c 65 6e 67 74 68 20 Branches.length
7890: 3e 20 30 29 20 7b 0a 20 20 20 20 20 20 20 20 66 > 0) {. f
78a0: 6f 72 20 28 69 3d 30 2c 20 6e 20 3d 20 63 42 72 or (i=0, n = cBr
78b0: 61 6e 63 68 65 73 2e 6c 65 6e 67 74 68 3b 20 69 anches.length; i
78c0: 20 3c 20 6e 3b 20 69 2b 2b 29 20 7b 0a 20 20 20 < n; i++) {.
78d0: 20 20 20 20 20 20 20 63 53 75 62 42 72 61 6e 63 cSubBranc
78e0: 68 65 73 20 3d 20 63 42 72 61 6e 63 68 65 73 5b hes = cBranches[
78f0: 69 5d 2e 67 65 74 45 6c 65 6d 65 6e 74 73 42 79 i].getElementsBy
7900: 54 61 67 4e 61 6d 65 28 22 75 6c 22 29 3b 0a 20 TagName("ul");.
7910: 20 20 20 20 20 20 20 20 20 69 66 20 28 63 53 75 if (cSu
7920: 62 42 72 61 6e 63 68 65 73 2e 6c 65 6e 67 74 68 bBranches.length
7930: 20 3e 20 30 29 20 7b 0a 20 20 20 20 20 20 20 20 > 0) {.
7940: 20 20 20 20 61 64 64 4c 69 6e 6b 73 54 6f 42 72 addLinksToBr
7950: 61 6e 63 68 65 73 28 63 53 75 62 42 72 61 6e 63 anches(cSubBranc
7960: 68 65 73 5b 30 5d 29 3b 0a 20 20 20 20 20 20 20 hes[0]);.
7970: 20 20 20 20 20 63 42 72 61 6e 63 68 65 73 5b 69 cBranches[i
7980: 5d 2e 63 6c 61 73 73 4e 61 6d 65 20 3d 20 22 48 ].className = "H
7990: 61 6e 64 43 75 72 73 6f 72 53 74 79 6c 65 22 3b andCursorStyle";
79a0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 63 42 72 . cBr
79b0: 61 6e 63 68 65 73 5b 69 5d 2e 73 74 79 6c 65 2e anches[i].style.
79c0: 63 6f 6c 6f 72 20 3d 20 22 62 6c 75 65 22 3b 0a color = "blue";.
79d0: 20 20 20 20 20 20 20 20 20 20 20 20 63 53 75 62 cSub
79e0: 42 72 61 6e 63 68 65 73 5b 30 5d 2e 73 74 79 6c Branches[0].styl
79f0: 65 2e 63 6f 6c 6f 72 20 3d 20 22 62 6c 61 63 6b e.color = "black
7a00: 22 3b 0a 20 20 20 20 20 20 20 20 20 20 20 20 63 ";. c
7a10: 53 75 62 42 72 61 6e 63 68 65 73 5b 30 5d 2e 73 SubBranches[0].s
7a20: 74 79 6c 65 2e 63 75 72 73 6f 72 20 3d 20 22 61 tyle.cursor = "a
7a30: 75 74 6f 22 3b 0a 20 20 20 20 20 20 20 20 20 20 uto";.
7a40: 7d 0a 20 20 20 20 20 20 20 20 7d 0a 20 20 20 20 }. }.
7a50: 20 20 7d 0a 20 20 20 20 7d 0a 20 20 3c 2f 73 63 }. }. </sc
7a60: 72 69 70 74 3e 0a 45 4f 46 0a 29 0a 0a 28 64 65 ript>.EOF.)..(de
7a70: 66 69 6e 65 20 74 65 73 74 73 3a 63 73 73 2d 6a fine tests:css-j
7a80: 73 63 72 69 70 74 2d 62 6c 6f 63 6b 2d 64 79 6e script-block-dyn
7a90: 61 6d 69 63 20 0a 23 3c 3c 45 4f 46 0a 20 20 20 amic .#<<EOF.
7aa0: 20 20 20 20 20 20 20 20 3c 73 63 72 69 70 74 20 <script
7ab0: 73 72 63 3d 20 2e 2f 6a 71 75 65 72 79 33 2e 31 src= ./jquery3.1
7ac0: 2e 30 2e 6a 73 3e 3c 2f 73 63 72 69 70 74 3e 20 .0.js></script>
7ad0: 0a 45 4f 46 0a 29 0a 0a 28 64 65 66 69 6e 65 20 .EOF.)..(define
7ae0: 20 28 74 65 73 74 3a 6a 73 2d 62 6c 6f 63 6b 20 (test:js-block
7af0: 6a 61 76 61 73 63 72 69 70 74 2d 6c 69 62 29 0a javascript-lib).
7b00: 20 20 20 28 63 6f 6e 63 20 20 22 3c 73 63 72 69 (conc "<scri
7b10: 70 74 20 73 72 63 3d 22 20 6a 61 76 61 73 63 72 pt src=" javascr
7b20: 69 70 74 2d 6c 69 62 20 22 3e 3c 2f 73 63 72 69 ipt-lib "></scri
7b30: 70 74 3e 22 20 29 29 0a 0a 0a 28 64 65 66 69 6e pt>" ))...(defin
7b40: 65 20 74 65 73 74 73 3a 63 73 73 2d 6a 73 63 72 e tests:css-jscr
7b50: 69 70 74 2d 62 6c 6f 63 6b 2d 73 74 61 74 69 63 ipt-block-static
7b60: 20 28 74 65 73 74 3a 6a 73 2d 62 6c 6f 63 6b 20 (test:js-block
7b70: 2a 6a 61 76 61 2d 73 63 72 69 70 74 2d 6c 69 62 *java-script-lib
7b80: 2a 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 *))..(define (te
7b90: 73 74 73 3a 63 73 73 2d 6a 73 63 72 69 70 74 2d sts:css-jscript-
7ba0: 62 6c 6f 63 6b 2d 63 6f 6e 64 20 64 79 6e 61 6d block-cond dynam
7bb0: 69 63 29 20 0a 20 20 20 20 20 20 28 69 66 20 28 ic) . (if (
7bc0: 65 71 75 61 6c 3f 20 64 79 6e 61 6d 69 63 20 20 equal? dynamic
7bd0: 23 74 29 0a 20 20 20 20 20 20 20 74 65 73 74 73 #t). tests
7be0: 3a 63 73 73 2d 6a 73 63 72 69 70 74 2d 62 6c 6f :css-jscript-blo
7bf0: 63 6b 2d 64 79 6e 61 6d 69 63 0a 20 20 20 20 20 ck-dynamic.
7c00: 20 20 74 65 73 74 73 3a 63 73 73 2d 6a 73 63 72 tests:css-jscr
7c10: 69 70 74 2d 62 6c 6f 63 6b 2d 73 74 61 74 69 63 ipt-block-static
7c20: 29 29 0a 0a 20 20 20 20 20 20 20 0a 28 64 65 66 )).. .(def
7c30: 69 6e 65 20 28 74 65 73 74 73 3a 72 75 6e 2d 72 ine (tests:run-r
7c40: 65 63 6f 72 64 2d 3e 74 65 73 74 2d 70 61 74 68 ecord->test-path
7c50: 20 72 75 6e 20 6e 75 6d 6b 65 79 73 29 0a 20 20 run numkeys).
7c60: 20 28 61 70 70 65 6e 64 20 28 74 61 6b 65 20 28 (append (take (
7c70: 76 65 63 74 6f 72 2d 3e 6c 69 73 74 20 72 75 6e vector->list run
7c80: 29 20 6e 75 6d 6b 65 79 73 29 0a 09 20 20 20 28 ) numkeys).. (
7c90: 6c 69 73 74 20 28 76 65 63 74 6f 72 2d 72 65 66 list (vector-ref
7ca0: 20 72 75 6e 20 28 2b 20 31 20 6e 75 6d 6b 65 79 run (+ 1 numkey
7cb0: 73 29 29 29 29 29 0a 0a 0a 28 64 65 66 69 6e 65 s)))))...(define
7cc0: 20 28 74 65 73 74 73 3a 67 65 74 2d 72 65 73 74 (tests:get-rest
7cd0: 2d 64 61 74 61 20 72 75 6e 73 20 68 65 61 64 65 -data runs heade
7ce0: 72 20 6e 75 6d 6b 65 79 73 29 0a 20 20 20 28 6c r numkeys). (l
7cf0: 65 74 20 28 28 72 65 73 68 20 28 6d 61 6b 65 2d et ((resh (make-
7d00: 68 61 73 68 2d 74 61 62 6c 65 29 29 29 0a 20 20 hash-table))).
7d10: 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 (for-each.
7d20: 28 6c 61 6d 62 64 61 20 28 72 75 6e 29 0a 20 20 (lambda (run).
7d30: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 72 75 (let* ((ru
7d40: 6e 2d 69 64 20 28 64 62 3a 67 65 74 2d 76 61 6c n-id (db:get-val
7d50: 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e ue-by-header run
7d60: 20 68 65 61 64 65 72 20 22 69 64 22 29 29 0a 20 header "id")).
7d70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 (r
7d80: 75 6e 2d 64 69 72 20 20 20 20 20 20 28 74 65 73 un-dir (tes
7d90: 74 73 3a 72 75 6e 2d 72 65 63 6f 72 64 2d 3e 74 ts:run-record->t
7da0: 65 73 74 2d 70 61 74 68 20 72 75 6e 20 6e 75 6d est-path run num
7db0: 6b 65 79 73 29 29 0a 09 20 20 20 20 20 20 20 28 keys)).. (
7dc0: 74 65 73 74 2d 64 61 74 61 20 20 20 20 28 72 6d test-data (rm
7dd0: 74 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d t:get-tests-for-
7de0: 72 75 6e 0a 09 09 09 09 20 20 20 72 75 6e 2d 69 run..... run-i
7df0: 64 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 d.
7e00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7e10: 20 20 20 20 20 22 25 22 20 20 20 20 20 20 20 3b "%" ;
7e20: 3b 20 74 65 73 74 6e 61 6d 65 70 61 74 74 0a 09 ; testnamepatt..
7e30: 09 09 09 20 20 20 27 28 29 20 20 20 20 20 20 20 ... '()
7e40: 20 3b 3b 20 73 74 61 74 65 73 0a 09 09 09 09 20 ;; states.....
7e50: 20 20 27 28 29 20 20 20 20 20 20 20 20 3b 3b 20 '() ;;
7e60: 73 74 61 74 75 73 65 73 0a 09 09 09 09 20 20 20 statuses.....
7e70: 23 66 20 20 20 20 20 20 20 20 20 3b 3b 20 6f 66 #f ;; of
7e80: 66 73 65 74 0a 09 09 09 09 20 20 20 23 66 20 20 fset..... #f
7e90: 20 20 20 20 20 20 20 3b 3b 20 6e 75 6d 2d 74 6f ;; num-to
7ea0: 2d 67 65 74 0a 09 09 09 09 20 20 20 23 66 20 20 -get..... #f
7eb0: 20 20 20 20 20 20 20 3b 3b 20 68 69 64 65 2f 6e ;; hide/n
7ec0: 6f 74 2d 68 69 64 65 0a 09 09 09 09 20 20 20 23 ot-hide..... #
7ed0: 66 20 20 20 20 20 20 20 20 20 3b 3b 20 73 6f 72 f ;; sor
7ee0: 74 2d 62 79 0a 09 09 09 09 20 20 20 23 66 20 20 t-by..... #f
7ef0: 20 20 20 20 20 20 20 3b 3b 20 73 6f 72 74 2d 6f ;; sort-o
7f00: 72 64 65 72 0a 09 09 09 09 20 20 20 23 66 20 20 rder..... #f
7f10: 20 20 20 20 20 20 20 3b 3b 20 27 73 68 6f 72 74 ;; 'short
7f20: 6c 69 73 74 20 20 20 20 20 20 20 20 20 20 20 20 list
7f30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
7f40: 3b 20 71 72 79 74 79 70 65 0a 20 20 20 20 20 20 ; qrytype.
7f50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7f60: 20 20 20 20 20 20 20 20 20 20 20 20 20 30 20 20 0
7f70: 20 20 20 20 20 20 20 3b 3b 20 6c 61 73 74 20 75 ;; last u
7f80: 70 64 61 74 65 0a 09 09 09 09 20 20 20 23 66 29 pdate..... #f)
7f90: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 0a )). .
7fa0: 20 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 70 (map
7fb0: 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 29 0a (lambda (test).
7fc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7fd0: 20 28 6c 65 74 2a 20 28 28 74 65 73 74 2d 6e 61 (let* ((test-na
7fe0: 6d 65 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 me (vector-ref t
7ff0: 65 73 74 20 32 29 29 0a 20 20 20 20 20 20 20 20 est 2)).
8000: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8010: 28 74 65 73 74 2d 68 74 6d 6c 2d 70 61 74 68 20 (test-html-path
8020: 28 63 6f 6e 63 20 28 76 65 63 74 6f 72 2d 72 65 (conc (vector-re
8030: 66 20 74 65 73 74 20 31 30 29 20 22 2f 22 20 28 f test 10) "/" (
8040: 76 65 63 74 6f 72 2d 72 65 66 20 74 65 73 74 20 vector-ref test
8050: 31 33 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 13))).
8060: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 74 (t
8070: 65 73 74 2d 69 74 65 6d 20 28 63 6f 6e 63 20 74 est-item (conc t
8080: 65 73 74 2d 6e 61 6d 65 20 22 3a 22 20 28 76 65 est-name ":" (ve
8090: 63 74 6f 72 2d 72 65 66 20 74 65 73 74 20 31 31 ctor-ref test 11
80a0: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
80b0: 20 20 20 20 20 20 20 20 20 20 20 20 28 74 65 73 (tes
80c0: 74 2d 73 74 61 74 75 73 20 28 76 65 63 74 6f 72 t-status (vector
80d0: 2d 72 65 66 20 74 65 73 74 20 34 29 29 29 0a 20 -ref test 4))).
80e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
80f0: 20 20 20 20 20 20 20 20 0a 20 20 20 20 20 20 20 .
8100: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f (if (no
8110: 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 t (hash-table-re
8120: 66 2f 64 65 66 61 75 6c 74 20 72 65 73 68 20 74 f/default resh t
8130: 65 73 74 2d 6e 61 6d 65 20 20 23 66 29 29 0a 20 est-name #f)).
8140: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8150: 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
8160: 2d 73 65 74 21 20 72 65 73 68 20 74 65 73 74 2d -set! resh test-
8170: 6e 61 6d 65 20 20 20 28 6d 61 6b 65 2d 68 61 73 name (make-has
8180: 68 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 20 20 h-table))).
8190: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 (if (
81a0: 6e 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d not (hash-table-
81b0: 72 65 66 2f 64 65 66 61 75 6c 74 20 28 68 61 73 ref/default (has
81c0: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
81d0: 75 6c 74 20 72 65 73 68 20 74 65 73 74 2d 6e 61 ult resh test-na
81e0: 6d 65 20 20 23 66 29 20 20 74 65 73 74 2d 69 74 me #f) test-it
81f0: 65 6d 20 20 23 66 29 29 0a 20 20 20 20 20 20 20 em #f)).
8200: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8210: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
8220: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
8230: 2f 64 65 66 61 75 6c 74 20 72 65 73 68 20 74 65 /default resh te
8240: 73 74 2d 6e 61 6d 65 20 20 23 66 29 20 74 65 73 st-name #f) tes
8250: 74 2d 69 74 65 6d 20 20 20 28 6d 61 6b 65 2d 68 t-item (make-h
8260: 61 73 68 2d 74 61 62 6c 65 29 29 29 20 0a 20 20 ash-table))) .
8270: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 68 61 (ha
8280: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 20 28 sh-table-set! (
8290: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
82a0: 65 66 61 75 6c 74 20 28 68 61 73 68 2d 74 61 62 efault (hash-tab
82b0: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 72 le-ref/default r
82c0: 65 73 68 20 74 65 73 74 2d 6e 61 6d 65 20 20 23 esh test-name #
82d0: 66 29 20 74 65 73 74 2d 69 74 65 6d 20 23 66 29 f) test-item #f)
82e0: 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 74 65 run-id (list te
82f0: 73 74 2d 73 74 61 74 75 73 20 74 65 73 74 2d 68 st-status test-h
8300: 74 6d 6c 2d 70 61 74 68 29 29 29 29 20 0a 20 20 tml-path)))) .
8310: 20 20 20 20 20 20 74 65 73 74 2d 64 61 74 61 29 test-data)
8320: 29 29 0a 20 20 20 20 20 20 72 75 6e 73 29 0a 20 )). runs).
8330: 20 20 72 65 73 68 29 29 0a 0a 0a 3b 3b 20 74 65 resh))...;; te
8340: 73 74 73 3a 67 65 6e 72 61 74 65 20 64 61 73 68 sts:genrate dash
8350: 62 6f 61 72 64 20 62 6f 64 79 20 0a 3b 3b 0a 0a board body .;;..
8360: 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 64 (define (tests:d
8370: 61 73 68 62 6f 61 72 64 2d 62 6f 64 79 20 70 61 ashboard-body pa
8380: 67 65 20 70 67 2d 73 69 7a 65 20 6b 65 79 73 20 ge pg-size keys
8390: 6e 75 6d 6b 65 79 73 20 20 74 6f 74 61 6c 2d 72 numkeys total-r
83a0: 75 6e 73 20 6c 69 6e 6b 74 72 65 65 20 61 72 65 uns linktree are
83b0: 61 2d 6e 61 6d 65 20 67 65 74 2d 70 72 65 76 2d a-name get-prev-
83c0: 6c 69 6e 6b 73 20 67 65 74 2d 6e 65 78 74 2d 6c links get-next-l
83d0: 69 6e 6b 73 20 66 6c 61 67 20 72 75 6e 2d 70 61 inks flag run-pa
83e0: 74 74 20 74 61 72 67 65 74 2d 70 61 74 74 29 0a tt target-patt).
83f0: 20 20 28 6c 65 74 2a 20 28 28 73 74 61 72 74 20 (let* ((start
8400: 28 2a 20 70 61 67 65 20 70 67 2d 73 69 7a 65 29 (* page pg-size)
8410: 29 20 0a 09 09 09 09 09 3b 28 72 75 6e 73 64 61 ) ......;(runsda
8420: 74 20 20 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e t (rmt:get-run
8430: 73 20 22 25 22 20 70 67 2d 73 69 7a 65 20 73 74 s "%" pg-size st
8440: 61 72 74 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 art (map (lambda
8450: 20 28 78 29 28 6c 69 73 74 20 78 20 22 25 22 29 (x)(list x "%")
8460: 29 20 6b 65 79 73 29 29 29 0a 20 20 20 20 20 20 ) keys))).
8470: 20 20 20 28 72 75 6e 73 64 61 74 20 20 20 28 72 (runsdat (r
8480: 6d 74 3a 67 65 74 2d 72 75 6e 73 2d 62 79 2d 70 mt:get-runs-by-p
8490: 61 74 74 20 20 6b 65 79 73 20 72 75 6e 2d 70 61 att keys run-pa
84a0: 74 74 20 74 61 72 67 65 74 2d 70 61 74 74 20 73 tt target-patt s
84b0: 74 61 72 74 20 70 67 2d 73 69 7a 65 20 23 66 20 tart pg-size #f
84c0: 30 20 73 6f 72 74 2d 6f 72 64 65 72 3a 20 22 64 0 sort-order: "d
84d0: 65 73 63 22 29 29 0a 09 09 09 09 09 3b 20 64 62 esc"))......; db
84e0: 3a 67 65 74 2d 72 75 6e 73 2d 62 79 2d 70 61 74 :get-runs-by-pat
84f0: 74 20 20 20 6b 65 79 73 20 72 75 6e 6e 61 6d 65 t keys runname
8500: 70 61 74 74 20 74 61 72 67 70 61 74 74 20 6f 66 patt targpatt of
8510: 66 73 65 74 20 6c 69 6d 69 74 20 66 69 65 6c 64 fset limit field
8520: 73 20 6c 61 73 74 2d 75 70 64 61 74 65 20 20 20 s last-update
8530: 0a 09 20 28 68 65 61 64 65 72 20 20 20 20 28 76 .. (header (v
8540: 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 73 64 61 ector-ref runsda
8550: 74 20 30 29 29 0a 09 20 28 72 75 6e 73 20 20 20 t 0)).. (runs
8560: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 (vector-ref r
8570: 75 6e 73 64 61 74 20 31 29 29 0a 20 20 20 20 20 unsdat 1)).
8580: 20 20 20 20 28 63 74 72 20 30 29 0a 20 20 20 20 (ctr 0).
8590: 20 20 20 20 20 28 74 65 73 74 2d 72 75 6e 73 2d (test-runs-
85a0: 68 61 73 68 20 28 74 65 73 74 73 3a 67 65 74 2d hash (tests:get-
85b0: 72 65 73 74 2d 64 61 74 61 20 72 75 6e 73 20 68 rest-data runs h
85c0: 65 61 64 65 72 20 6e 75 6d 6b 65 79 73 29 29 0a eader numkeys)).
85d0: 20 20 20 20 20 20 20 20 20 28 74 65 73 74 2d 6c (test-l
85e0: 69 73 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ist (hash-table-
85f0: 6b 65 79 73 20 74 65 73 74 2d 72 75 6e 73 2d 68 keys test-runs-h
8600: 61 73 68 29 29 29 20 0a 20 20 20 20 0a 20 20 20 ash))) . .
8610: 20 28 73 3a 68 74 6d 6c 20 74 65 73 74 73 3a 63 (s:html tests:c
8620: 73 73 2d 6a 73 63 72 69 70 74 2d 62 6c 6f 63 6b ss-jscript-block
8630: 20 28 74 65 73 74 73 3a 63 73 73 2d 6a 73 63 72 (tests:css-jscr
8640: 69 70 74 2d 62 6c 6f 63 6b 2d 63 6f 6e 64 20 66 ipt-block-cond f
8650: 6c 61 67 29 0a 09 20 20 20 20 28 73 3a 74 69 74 lag).. (s:tit
8660: 6c 65 20 22 53 75 6d 6d 61 72 79 20 66 6f 72 20 le "Summary for
8670: 22 20 61 72 65 61 2d 6e 61 6d 65 29 0a 09 20 20 " area-name)..
8680: 20 20 28 73 3a 62 6f 64 79 20 27 6f 6e 6c 6f 61 (s:body 'onloa
8690: 64 20 22 61 64 64 45 76 65 6e 74 73 28 29 3b 22 d "addEvents();"
86a0: 0a 09 09 20 20 20 20 28 67 65 74 2d 70 72 65 76 ... (get-prev
86b0: 2d 6c 69 6e 6b 73 20 70 61 67 65 20 6c 69 6e 6b -links page link
86c0: 74 72 65 65 29 0a 09 09 20 20 20 20 28 67 65 74 tree)... (get
86d0: 2d 6e 65 78 74 2d 6c 69 6e 6b 73 20 70 61 67 65 -next-links page
86e0: 20 6c 69 6e 6b 74 72 65 65 20 74 6f 74 61 6c 2d linktree total-
86f0: 72 75 6e 73 29 0a 09 09 20 20 20 20 0a 09 09 20 runs)... ...
8700: 20 20 20 28 73 3a 68 31 20 22 53 75 6d 6d 61 72 (s:h1 "Summar
8710: 79 20 66 6f 72 20 22 20 61 72 65 61 2d 6e 61 6d y for " area-nam
8720: 65 29 0a 09 09 20 20 20 20 28 73 3a 68 33 20 22 e)... (s:h3 "
8730: 46 69 6c 74 65 72 22 20 29 0a 09 09 20 20 20 20 Filter" )...
8740: 28 73 3a 69 6e 70 75 74 20 27 74 79 70 65 20 22 (s:input 'type "
8750: 74 65 78 74 22 20 20 27 6e 61 6d 65 20 22 74 65 text" 'name "te
8760: 73 74 6e 61 6d 65 22 20 27 69 64 20 22 74 65 73 stname" 'id "tes
8770: 74 6e 61 6d 65 22 20 27 6c 65 6e 67 74 68 20 22 tname" 'length "
8780: 33 30 22 20 27 6f 6e 6b 65 79 75 70 20 22 66 69 30" 'onkeyup "fi
8790: 6c 74 65 72 73 6f 6d 65 28 29 22 29 0a 09 09 20 ltersome()")...
87a0: 20 20 20 3b 3b 20 74 6f 70 20 6c 69 73 74 0a 09 ;; top list..
87b0: 09 20 20 20 20 0a 09 09 20 20 20 20 28 73 3a 74 . ... (s:t
87c0: 61 62 6c 65 20 27 69 64 20 22 4c 69 6e 6b 65 64 able 'id "Linked
87d0: 4c 69 73 74 31 22 20 27 62 6f 72 64 65 72 20 22 List1" 'border "
87e0: 31 22 20 27 63 65 6c 6c 73 70 61 63 69 6e 67 20 1" 'cellspacing
87f0: 30 0a 09 09 09 20 20 20 20 20 28 6d 61 70 20 28 0.... (map (
8800: 6c 61 6d 62 64 61 20 28 6b 65 79 29 0a 09 09 09 lambda (key)....
8810: 09 20 20 20 20 28 6c 65 74 2a 20 28 28 72 65 73 . (let* ((res
8820: 20 28 73 3a 74 72 20 27 63 6c 61 73 73 20 22 73 (s:tr 'class "s
8830: 6f 6d 65 74 68 69 6e 67 22 20 0a 09 09 09 09 09 omething" ......
8840: 09 20 20 20 20 20 20 28 73 3a 74 68 20 6b 65 79 . (s:th key
8850: 20 29 0a 09 09 09 09 09 09 20 20 20 20 20 20 28 )....... (
8860: 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 72 75 6e map (lambda (run
8870: 29 0a 09 09 09 09 09 09 09 20 20 20 20 20 28 73 )........ (s
8880: 3a 74 68 20 20 28 76 65 63 74 6f 72 2d 72 65 66 :th (vector-ref
8890: 20 72 75 6e 20 63 74 72 29 29 29 0a 09 09 09 09 run ctr))).....
88a0: 09 09 09 20 20 20 72 75 6e 73 29 29 29 29 0a 09 ... runs))))..
88b0: 09 09 09 20 20 20 20 20 20 28 73 65 74 21 20 63 ... (set! c
88c0: 74 72 20 28 2b 20 63 74 72 20 31 29 29 0a 09 09 tr (+ ctr 1))...
88d0: 09 09 20 20 20 20 20 20 72 65 73 29 29 0a 09 09 .. res))...
88e0: 09 09 20 20 6b 65 79 73 29 0a 09 09 09 20 20 20 .. keys)....
88f0: 20 20 28 73 3a 74 72 0a 09 09 09 20 20 20 20 20 (s:tr....
8900: 20 28 73 3a 74 68 20 22 52 75 6e 20 4e 61 6d 65 (s:th "Run Name
8910: 22 29 0a 09 09 09 20 20 20 20 20 20 28 6d 61 70 ").... (map
8920: 20 28 6c 61 6d 62 64 61 20 28 72 75 6e 29 0a 09 (lambda (run)..
8930: 09 09 09 20 20 20 20 20 28 73 3a 74 68 20 28 64 ... (s:th (d
8940: 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 b:get-value-by-h
8950: 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 eader run header
8960: 20 22 72 75 6e 6e 61 6d 65 22 29 29 29 0a 09 09 "runname")))...
8970: 09 09 20 20 20 72 75 6e 73 29 29 0a 09 09 09 20 .. runs))....
8980: 20 20 20 20 0a 09 09 09 20 20 20 20 20 28 6d 61 .... (ma
8990: 70 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 2d p (lambda (test-
89a0: 6e 61 6d 65 29 0a 09 09 09 09 20 20 20 20 28 6c name)..... (l
89b0: 65 74 2a 20 28 28 69 74 65 6d 2d 68 61 73 68 20 et* ((item-hash
89c0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
89d0: 64 65 66 61 75 6c 74 20 74 65 73 74 2d 72 75 6e default test-run
89e0: 73 2d 68 61 73 68 20 74 65 73 74 2d 6e 61 6d 65 s-hash test-name
89f0: 20 20 23 66 29 29 0a 09 09 09 09 09 20 20 20 28 #f))...... (
8a00: 69 74 65 6d 2d 6b 65 79 73 20 28 73 6f 72 74 20 item-keys (sort
8a10: 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 (hash-table-keys
8a20: 20 69 74 65 6d 2d 68 61 73 68 29 20 73 74 72 69 item-hash) stri
8a30: 6e 67 3c 3d 3f 29 29 29 20 0a 09 09 09 09 20 20 ng<=?))) .....
8a40: 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 (map (lambda
8a50: 20 28 69 74 65 6d 2d 6e 61 6d 65 29 20 20 0a 20 (item-name) .
8a60: 20 09 09 20 20 20 20 20 20 20 20 20 20 20 20 20 ..
8a70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8a80: 28 6c 65 74 2a 20 28 28 72 65 73 20 28 73 3a 74 (let* ((res (s:t
8a90: 72 20 20 27 63 6c 61 73 73 20 69 74 65 6d 2d 6e r 'class item-n
8aa0: 61 6d 65 0a 09 09 09 09 09 09 09 09 28 73 3a 74 ame.........(s:t
8ab0: 64 20 20 69 74 65 6d 2d 6e 61 6d 65 20 27 63 6c d item-name 'cl
8ac0: 61 73 73 20 22 74 65 73 74 22 20 29 0a 09 09 09 ass "test" )....
8ad0: 09 09 09 09 09 28 6d 61 70 20 28 6c 61 6d 62 64 .....(map (lambd
8ae0: 61 20 28 72 75 6e 29 0a 09 09 09 09 09 09 09 09 a (run).........
8af0: 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 72 (let* ((r
8b00: 75 6e 2d 74 65 73 74 20 28 68 61 73 68 2d 74 61 un-test (hash-ta
8b10: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
8b20: 69 74 65 6d 2d 68 61 73 68 20 69 74 65 6d 2d 6e item-hash item-n
8b30: 61 6d 65 20 20 23 66 29 29 0a 09 09 09 09 09 09 ame #f)).......
8b40: 09 09 09 20 20 20 20 20 20 28 72 75 6e 2d 69 64 ... (run-id
8b50: 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 (db:get-value-b
8b60: 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 y-header run hea
8b70: 64 65 72 20 22 69 64 22 29 29 0a 09 09 09 09 09 der "id"))......
8b80: 09 09 09 09 20 20 20 20 20 20 28 72 65 73 75 6c .... (resul
8b90: 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 t (hash-table-re
8ba0: 66 2f 64 65 66 61 75 6c 74 20 72 75 6e 2d 74 65 f/default run-te
8bb0: 73 74 20 72 75 6e 2d 69 64 20 22 6e 2f 61 22 29 st run-id "n/a")
8bc0: 29 0a 09 09 09 09 09 3b 28 72 65 6c 61 74 69 76 )......;(relativ
8bd0: 65 2d 70 61 74 68 20 28 67 65 74 2d 72 65 6c 61 e-path (get-rela
8be0: 74 69 76 65 2d 70 61 74 68 29 29 20 0a 09 09 09 tive-path)) ....
8bf0: 09 09 09 09 09 09 20 20 20 20 20 20 28 73 74 61 ...... (sta
8c00: 74 75 73 20 28 69 66 20 28 73 74 72 69 6e 67 3f tus (if (string?
8c10: 20 72 65 73 75 6c 74 29 0a 09 09 09 09 09 09 09 result)........
8c20: 09 09 09 09 20 20 72 65 73 75 6c 74 0a 09 09 09 .... result....
8c30: 09 09 09 09 09 09 09 09 20 20 28 63 61 72 20 72 ........ (car r
8c40: 65 73 75 6c 74 29 29 29 0a 09 09 09 09 09 09 09 esult)))........
8c50: 09 09 20 20 20 20 20 20 28 6c 69 6e 6b 20 28 69 .. (link (i
8c60: 66 20 28 73 74 72 69 6e 67 3f 20 72 65 73 75 6c f (string? resul
8c70: 74 29 0a 09 09 09 09 09 09 09 09 09 09 09 72 65 t)............re
8c80: 73 75 6c 74 0a 09 09 09 09 09 09 09 09 09 09 09 sult............
8c90: 28 69 66 20 28 65 71 75 61 6c 3f 20 66 6c 61 67 (if (equal? flag
8ca0: 20 23 74 29 20 0a 09 09 09 09 09 09 09 09 09 09 #t) ...........
8cb0: 09 20 20 20 20 28 73 3a 61 20 28 63 61 72 20 72 . (s:a (car r
8cc0: 65 73 75 6c 74 29 20 27 68 72 65 66 20 28 63 6f esult) 'href (co
8cd0: 6e 63 20 22 2e 2f 74 65 73 74 5f 6c 6f 67 3f 72 nc "./test_log?r
8ce0: 75 6e 69 64 3d 22 20 72 75 6e 2d 69 64 20 22 26 unid=" run-id "&
8cf0: 74 65 73 74 6e 61 6d 65 3d 22 20 20 69 74 65 6d testname=" item
8d00: 2d 6e 61 6d 65 20 29 29 0a 09 09 09 09 09 09 09 -name ))........
8d10: 09 09 09 09 20 20 20 20 28 73 3a 61 20 28 63 61 .... (s:a (ca
8d20: 72 20 72 65 73 75 6c 74 29 20 27 68 72 65 66 20 r result) 'href
8d30: 28 73 74 72 69 6e 67 2d 73 75 62 73 74 69 74 75 (string-substitu
8d40: 74 65 20 20 28 63 6f 6e 63 20 6c 69 6e 6b 74 72 te (conc linktr
8d50: 65 65 20 22 2f 22 29 20 20 22 22 20 28 63 61 64 ee "/") "" (cad
8d60: 72 20 72 65 73 75 6c 74 29 20 20 22 2d 22 29 29 r result) "-"))
8d70: 29 29 29 29 0a 09 09 09 09 09 09 09 09 09 20 28 )))).......... (
8d80: 73 3a 74 64 20 20 6c 69 6e 6b 20 27 63 6c 61 73 s:td link 'clas
8d90: 73 20 73 74 61 74 75 73 29 29 29 0a 09 09 09 09 s status))).....
8da0: 09 09 09 09 20 20 20 20 20 72 75 6e 73 29 29 29 .... runs)))
8db0: 29 0a 09 09 09 09 09 20 20 20 20 20 20 20 72 65 )...... re
8dc0: 73 29 29 0a 09 09 09 09 09 20 20 20 69 74 65 6d s))...... item
8dd0: 2d 6b 65 79 73 29 29 29 0a 09 09 09 09 20 20 74 -keys)))..... t
8de0: 65 73 74 2d 6c 69 73 74 29 29 29 29 29 29 20 0a est-list)))))) .
8df0: 0a 3b 3b 20 28 74 65 73 74 73 3a 63 72 65 61 74 .;; (tests:creat
8e00: 65 2d 68 74 6d 6c 2d 74 72 65 65 20 22 74 65 73 e-html-tree "tes
8e10: 74 2d 69 6e 64 65 78 2e 68 74 6d 6c 22 29 0a 3b t-index.html").;
8e20: 3b 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 ;.(define (tests
8e30: 3a 63 72 65 61 74 65 2d 68 74 6d 6c 2d 74 72 65 :create-html-tre
8e40: 65 20 6f 75 74 66 29 0a 20 20 28 6c 65 74 2a 20 e outf). (let*
8e50: 28 28 6c 6f 63 6b 66 69 6c 65 20 20 28 63 6f 6e ((lockfile (con
8e60: 63 20 6f 75 74 66 20 22 2e 6c 6f 63 6b 22 29 29 c outf ".lock"))
8e70: 0a 09 20 28 72 75 6e 73 2d 74 6f 2d 70 72 6f 63 .. (runs-to-proc
8e80: 65 73 73 20 27 28 29 29 0a 20 20 20 20 20 20 20 ess '()).
8e90: 20 20 28 6c 69 6e 6b 74 72 65 65 20 20 28 63 6f (linktree (co
8ea0: 6d 6d 6f 6e 3a 67 65 74 2d 6c 69 6e 6b 74 72 65 mmon:get-linktre
8eb0: 65 29 29 0a 20 20 20 20 20 20 20 20 20 28 61 72 e)). (ar
8ec0: 65 61 2d 6e 61 6d 65 20 28 63 6f 6d 6d 6f 6e 3a ea-name (common:
8ed0: 67 65 74 2d 74 65 73 74 73 75 69 74 65 2d 6e 61 get-testsuite-na
8ee0: 6d 65 29 29 0a 09 20 28 6b 65 79 73 20 20 20 20 me)).. (keys
8ef0: 20 20 28 72 6d 74 3a 67 65 74 2d 6b 65 79 73 29 (rmt:get-keys)
8f00: 29 0a 09 20 28 6e 75 6d 6b 65 79 73 20 20 20 28 ).. (numkeys (
8f10: 6c 65 6e 67 74 68 20 6b 65 79 73 29 29 0a 20 20 length keys)).
8f20: 20 20 20 20 20 20 20 28 72 75 6e 2d 70 61 74 74 (run-patt
8f30: 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 (or (args:get-a
8f40: 72 67 20 22 2d 72 75 6e 2d 70 61 74 74 22 29 0a rg "-run-patt").
8f50: 09 09 20 20 20 20 20 20 20 28 61 72 67 73 3a 67 .. (args:g
8f60: 65 74 2d 61 72 67 20 22 2d 72 75 6e 6e 61 6d 65 et-arg "-runname
8f70: 22 29 0a 09 09 20 20 20 20 20 20 20 22 25 22 29 ")... "%")
8f80: 29 0a 20 20 20 20 20 20 20 20 20 28 74 61 72 67 ). (targ
8f90: 65 74 20 28 6f 72 20 20 28 61 72 67 73 3a 67 65 et (or (args:ge
8fa0: 74 2d 61 72 67 20 22 2d 74 61 72 67 65 74 2d 70 t-arg "-target-p
8fb0: 61 74 74 22 29 20 0a 09 09 20 20 20 20 20 20 28 att") ... (
8fc0: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 args:get-arg "-t
8fd0: 61 72 67 65 74 22 29 0a 20 20 20 20 20 20 20 20 arget").
8fe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 22 25 "%
8ff0: 22 29 29 0a 20 20 20 20 20 20 20 20 20 28 74 61 ")). (ta
9000: 72 67 6c 69 73 74 20 28 73 74 72 69 6e 67 2d 73 rglist (string-s
9010: 70 6c 69 74 20 74 61 72 67 65 74 20 22 2f 22 29 plit target "/")
9020: 29 0a 20 20 20 20 20 20 20 20 20 28 6e 75 6d 74 ). (numt
9030: 61 72 67 20 20 28 6c 65 6e 67 74 68 20 74 61 72 arg (length tar
9040: 67 6c 69 73 74 29 29 20 20 0a 20 20 20 20 20 20 glist)) .
9050: 20 20 20 28 74 61 72 67 74 77 65 61 6b 65 64 20 (targtweaked
9060: 28 69 66 20 28 3e 20 6e 75 6d 6b 65 79 73 20 6e (if (> numkeys n
9070: 75 6d 74 61 72 67 29 0a 09 09 09 20 20 28 61 70 umtarg).... (ap
9080: 70 65 6e 64 20 74 61 72 67 6c 69 73 74 20 28 6d pend targlist (m
9090: 61 6b 65 2d 6c 69 73 74 20 28 2d 20 6e 75 6d 6b ake-list (- numk
90a0: 65 79 73 20 6e 75 6d 74 61 72 67 29 20 22 25 22 eys numtarg) "%"
90b0: 29 29 0a 09 09 09 20 20 74 61 72 67 6c 69 73 74 )).... targlist
90c0: 29 29 0a 20 20 20 20 20 20 20 20 20 28 74 61 72 )). (tar
90d0: 67 65 74 2d 70 61 74 74 20 28 73 74 72 69 6e 67 get-patt (string
90e0: 2d 6a 6f 69 6e 20 74 61 72 67 74 77 65 61 6b 65 -join targtweake
90f0: 64 20 22 2f 22 29 29 0a 09 09 09 09 09 3b 28 74 d "/"))......;(t
9100: 6f 74 61 6c 2d 72 75 6e 73 20 20 28 72 6d 74 3a otal-runs (rmt:
9110: 67 65 74 2d 6e 75 6d 2d 72 75 6e 73 20 22 25 22 get-num-runs "%"
9120: 29 29 20 3b 3b 74 68 69 73 20 6e 65 65 64 73 20 )) ;;this needs
9130: 74 6f 20 62 65 20 63 68 61 6e 67 65 64 20 74 6f to be changed to
9140: 20 66 69 6c 74 65 72 20 62 79 20 74 61 72 67 65 filter by targe
9150: 74 0a 09 20 28 74 6f 74 61 6c 2d 72 75 6e 73 20 t.. (total-runs
9160: 28 72 6d 74 3a 67 65 74 2d 72 75 6e 73 2d 63 6e (rmt:get-runs-cn
9170: 74 2d 62 79 2d 70 61 74 74 20 72 75 6e 2d 70 61 t-by-patt run-pa
9180: 74 74 20 74 61 72 67 65 74 2d 70 61 74 74 20 6b tt target-patt k
9190: 65 79 73 20 29 29 20 0a 20 20 20 20 20 20 20 20 eys )) .
91a0: 20 28 70 67 2d 73 69 7a 65 20 31 30 29 29 0a 20 (pg-size 10)).
91b0: 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 73 (if (common:s
91c0: 69 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 20 imple-file-lock
91d0: 6c 6f 63 6b 66 69 6c 65 29 0a 20 20 20 20 20 20 lockfile).
91e0: 20 20 28 62 65 67 69 6e 0a 09 09 09 09 09 3b 28 (begin......;(
91f0: 70 72 69 6e 74 20 74 6f 74 61 6c 2d 72 75 6e 73 print total-runs
9200: 29 20 20 20 20 0a 09 20 20 28 6c 65 74 20 6c 6f ) .. (let lo
9210: 6f 70 20 28 28 70 61 67 65 20 30 29 29 0a 09 20 op ((page 0))..
9220: 20 20 20 28 6c 65 74 2a 20 28 28 6f 75 70 20 20 (let* ((oup
9230: 20 20 20 20 20 20 20 20 20 20 28 6f 70 65 6e 2d (open-
9240: 6f 75 74 70 75 74 2d 66 69 6c 65 20 28 6f 72 20 output-file (or
9250: 6f 75 74 66 20 28 63 6f 6e 63 20 6c 69 6e 6b 74 outf (conc linkt
9260: 72 65 65 20 22 2f 70 61 67 65 22 20 70 61 67 65 ree "/page" page
9270: 20 22 2e 68 74 6d 6c 22 29 29 29 29 0a 09 09 20 ".html"))))...
9280: 20 20 28 67 65 74 2d 70 72 65 76 2d 6c 69 6e 6b (get-prev-link
9290: 73 20 28 6c 61 6d 62 64 61 20 28 70 61 67 65 20 s (lambda (page
92a0: 6c 69 6e 6b 74 72 65 65 20 29 20 20 20 0a 09 09 linktree ) ...
92b0: 09 09 20 20 20 20 20 28 6c 65 74 2a 20 28 28 6c .. (let* ((l
92c0: 69 6e 6b 20 20 28 69 66 20 28 6e 6f 74 20 28 65 ink (if (not (e
92d0: 71 3f 20 70 61 67 65 20 30 29 29 0a 09 09 09 09 q? page 0)).....
92e0: 09 09 20 20 20 20 20 20 20 28 73 3a 61 20 22 26 .. (s:a "&
92f0: 6c 74 3b 26 6c 74 3b 70 72 65 76 22 20 27 68 72 lt;<prev" 'hr
9300: 65 66 20 28 63 6f 6e 63 20 20 22 70 61 67 65 22 ef (conc "page"
9310: 20 28 2d 20 70 61 67 65 20 31 29 20 22 2e 68 74 (- page 1) ".ht
9320: 6d 6c 22 29 29 0a 09 09 09 09 09 09 20 20 20 20 ml")).......
9330: 20 20 20 28 73 3a 61 20 22 22 20 27 68 72 65 66 (s:a "" 'href
9340: 20 28 63 6f 6e 63 20 20 20 22 70 61 67 65 22 20 (conc "page"
9350: 20 70 61 67 65 20 22 2e 68 74 6d 6c 22 29 29 29 page ".html")))
9360: 29 29 0a 09 09 09 09 20 20 20 20 20 20 20 6c 69 ))..... li
9370: 6e 6b 29 29 29 0a 09 09 20 20 20 28 67 65 74 2d nk)))... (get-
9380: 6e 65 78 74 2d 6c 69 6e 6b 73 20 28 6c 61 6d 62 next-links (lamb
9390: 64 61 20 28 70 61 67 65 20 6c 69 6e 6b 74 72 65 da (page linktre
93a0: 65 20 74 6f 74 61 6c 2d 72 75 6e 73 29 20 20 20 e total-runs)
93b0: 0a 09 09 09 09 20 20 20 20 20 28 6c 65 74 2a 20 ..... (let*
93c0: 28 28 6c 69 6e 6b 20 20 28 69 66 20 28 3e 20 74 ((link (if (> t
93d0: 6f 74 61 6c 2d 72 75 6e 73 20 28 2b 20 31 30 20 otal-runs (+ 10
93e0: 28 2a 20 70 61 67 65 20 70 67 2d 73 69 7a 65 29 (* page pg-size)
93f0: 29 29 0a 09 09 09 09 09 09 20 20 20 20 20 20 20 )).......
9400: 28 73 3a 61 20 22 6e 65 78 74 26 67 74 3b 26 67 (s:a "next>&g
9410: 74 3b 22 20 27 68 72 65 66 20 28 63 6f 6e 63 20 t;" 'href (conc
9420: 20 22 70 61 67 65 22 20 20 28 2b 20 70 61 67 65 "page" (+ page
9430: 20 31 29 20 22 2e 68 74 6d 6c 22 29 29 0a 09 09 1) ".html"))...
9440: 09 09 09 09 20 20 20 20 20 20 20 28 73 3a 61 20 .... (s:a
9450: 22 22 20 27 68 72 65 66 20 28 63 6f 6e 63 20 20 "" 'href (conc
9460: 20 22 70 61 67 65 22 20 70 61 67 65 20 20 22 2e "page" page ".
9470: 68 74 6d 6c 22 29 29 29 29 29 0a 09 09 09 09 20 html"))))).....
9480: 20 20 20 20 20 20 6c 69 6e 6b 29 29 29 20 29 0a link))) ).
9490: 09 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 74 . (print "t
94a0: 6f 74 61 6c 20 72 75 6e 73 3a 20 22 20 74 6f 74 otal runs: " tot
94b0: 61 6c 2d 72 75 6e 73 29 20 0a 09 20 20 20 20 20 al-runs) ..
94c0: 20 28 73 3a 6f 75 74 70 75 74 2d 6e 65 77 0a 09 (s:output-new..
94d0: 20 20 20 20 20 20 20 6f 75 70 0a 09 20 20 20 20 oup..
94e0: 20 20 20 28 74 65 73 74 73 3a 64 61 73 68 62 6f (tests:dashbo
94f0: 61 72 64 2d 62 6f 64 79 20 70 61 67 65 20 70 67 ard-body page pg
9500: 2d 73 69 7a 65 20 6b 65 79 73 20 6e 75 6d 6b 65 -size keys numke
9510: 79 73 20 74 6f 74 61 6c 2d 72 75 6e 73 20 6c 69 ys total-runs li
9520: 6e 6b 74 72 65 65 20 61 72 65 61 2d 6e 61 6d 65 nktree area-name
9530: 20 67 65 74 2d 70 72 65 76 2d 6c 69 6e 6b 73 20 get-prev-links
9540: 67 65 74 2d 6e 65 78 74 2d 6c 69 6e 6b 73 20 23 get-next-links #
9550: 66 20 72 75 6e 2d 70 61 74 74 20 74 61 72 67 65 f run-patt targe
9560: 74 2d 70 61 74 74 29 29 20 3b 3b 20 75 70 64 61 t-patt)) ;; upda
9570: 74 65 20 74 68 69 73 20 66 75 6e 63 74 69 6f 6e te this function
9580: 0a 09 20 20 20 20 20 20 28 63 6c 6f 73 65 2d 6f .. (close-o
9590: 75 74 70 75 74 2d 70 6f 72 74 20 6f 75 70 29 0a utput-port oup).
95a0: 09 09 09 09 09 3b 20 28 73 65 74 21 20 70 61 67 .....; (set! pag
95b0: 65 20 28 2b 20 31 20 70 61 67 65 29 29 0a 09 20 e (+ 1 page))..
95c0: 20 20 20 20 20 28 69 66 20 28 3e 20 74 6f 74 61 (if (> tota
95d0: 6c 2d 72 75 6e 73 20 28 2a 20 28 2b 20 31 20 70 l-runs (* (+ 1 p
95e0: 61 67 65 29 20 70 67 2d 73 69 7a 65 29 29 0a 09 age) pg-size))..
95f0: 09 20 20 28 6c 6f 6f 70 20 28 2b 20 31 20 20 70 . (loop (+ 1 p
9600: 61 67 65 29 29 29 29 29 0a 09 20 20 28 63 6f 6d age))))).. (com
9610: 6d 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d mon:simple-file-
9620: 72 65 6c 65 61 73 65 2d 6c 6f 63 6b 20 6c 6f 63 release-lock loc
9630: 6b 66 69 6c 65 29 29 0a 09 28 62 65 67 69 6e 0a kfile))..(begin.
9640: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 . (debug:print
9650: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
9660: 6f 72 74 2a 20 22 46 61 69 6c 65 64 20 74 6f 20 ort* "Failed to
9670: 67 65 74 20 6c 6f 63 6b 20 6f 6e 20 66 69 6c 65 get lock on file
9680: 20 6f 75 74 66 2c 20 6c 6f 63 6b 66 69 6c 65 3a outf, lockfile:
9690: 20 22 20 6c 6f 63 6b 66 69 6c 65 29 20 23 66 29 " lockfile) #f)
96a0: 29 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 74 )))...(define (t
96b0: 65 73 74 73 3a 72 65 61 64 6c 69 6e 65 73 20 66 ests:readlines f
96c0: 69 6c 65 6e 61 6d 65 29 0a 20 20 28 63 61 6c 6c ilename). (call
96d0: 2d 77 69 74 68 2d 69 6e 70 75 74 2d 66 69 6c 65 -with-input-file
96e0: 20 66 69 6c 65 6e 61 6d 65 0a 20 20 20 20 28 6c filename. (l
96f0: 61 6d 62 64 61 20 28 70 29 0a 20 20 20 20 20 20 ambda (p).
9700: 28 6c 65 74 20 6c 6f 6f 70 20 28 28 6c 69 6e 65 (let loop ((line
9710: 20 28 72 65 61 64 2d 6c 69 6e 65 20 70 29 29 0a (read-line p)).
9720: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9730: 20 28 72 65 73 75 6c 74 20 27 28 29 29 29 0a 20 (result '())).
9740: 20 20 20 20 20 20 20 28 69 66 20 28 65 6f 66 2d (if (eof-
9750: 6f 62 6a 65 63 74 3f 20 6c 69 6e 65 29 0a 20 20 object? line).
9760: 20 20 20 20 20 20 20 20 20 20 28 72 65 76 65 72 (rever
9770: 73 65 20 72 65 73 75 6c 74 29 0a 20 20 20 20 20 se result).
9780: 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 72 65 (loop (re
9790: 61 64 2d 6c 69 6e 65 20 70 29 20 28 63 6f 6e 73 ad-line p) (cons
97a0: 20 6c 69 6e 65 20 72 65 73 75 6c 74 29 29 29 29 line result))))
97b0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 )))..(define (te
97c0: 73 74 73 3a 67 65 74 2d 74 65 73 74 2d 6c 6f 67 sts:get-test-log
97d0: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
97e0: 65 20 69 74 65 6d 2d 6e 61 6d 65 29 0a 20 20 28 e item-name). (
97f0: 6c 65 74 2a 20 28 28 74 65 73 74 2d 64 61 74 61 let* ((test-data
9800: 20 20 20 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 (rmt:get-tes
9810: 74 73 2d 66 6f 72 2d 72 75 6e 0a 09 09 09 09 20 ts-for-run.....
9820: 20 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 (string->numbe
9830: 72 20 72 75 6e 2d 69 64 29 0a 20 20 20 20 20 20 r run-id).
9840: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9850: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 74 65 te
9860: 73 74 2d 6e 61 6d 65 20 20 20 20 20 20 3b 3b 20 st-name ;;
9870: 74 65 73 74 6e 61 6d 65 70 61 74 74 0a 09 09 09 testnamepatt....
9880: 09 20 20 20 27 28 29 20 20 20 20 20 20 20 20 3b . '() ;
9890: 3b 20 73 74 61 74 65 73 0a 09 09 09 09 20 20 20 ; states.....
98a0: 27 28 29 20 20 20 20 20 20 20 20 3b 3b 20 73 74 '() ;; st
98b0: 61 74 75 73 65 73 0a 09 09 09 09 20 20 20 23 66 atuses..... #f
98c0: 20 20 20 20 20 20 20 20 20 3b 3b 20 6f 66 66 73 ;; offs
98d0: 65 74 0a 09 09 09 09 20 20 20 23 66 20 20 20 20 et..... #f
98e0: 20 20 20 20 20 3b 3b 20 6e 75 6d 2d 74 6f 2d 67 ;; num-to-g
98f0: 65 74 0a 09 09 09 09 20 20 20 23 66 20 20 20 20 et..... #f
9900: 20 20 20 20 20 3b 3b 20 68 69 64 65 2f 6e 6f 74 ;; hide/not
9910: 2d 68 69 64 65 0a 09 09 09 09 20 20 20 23 66 20 -hide..... #f
9920: 20 20 20 20 20 20 20 20 3b 3b 20 73 6f 72 74 2d ;; sort-
9930: 62 79 0a 09 09 09 09 20 20 20 23 66 20 20 20 20 by..... #f
9940: 20 20 20 20 20 3b 3b 20 73 6f 72 74 2d 6f 72 64 ;; sort-ord
9950: 65 72 0a 09 09 09 09 20 20 20 23 66 20 20 20 20 er..... #f
9960: 20 20 20 20 20 3b 3b 20 27 73 68 6f 72 74 6c 69 ;; 'shortli
9970: 73 74 20 20 20 20 20 20 20 20 20 20 20 20 20 20 st
9980: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ;;
9990: 71 72 79 74 79 70 65 0a 20 20 20 20 20 20 20 20 qrytype.
99a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
99b0: 20 20 20 20 20 20 20 20 20 20 20 30 20 20 20 20 0
99c0: 20 20 20 20 20 3b 3b 20 6c 61 73 74 20 75 70 64 ;; last upd
99d0: 61 74 65 0a 09 09 09 09 20 20 20 23 66 29 29 0a ate..... #f)).
99e0: 20 20 20 20 20 20 20 20 20 28 70 61 74 68 20 22 (path "
99f0: 22 29 0a 20 20 20 20 20 20 20 20 20 28 66 6f 75 "). (fou
9a00: 6e 64 20 30 29 29 0a 20 20 20 20 28 64 65 62 75 nd 0)). (debu
9a10: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a g:print-info 0 *
9a20: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
9a30: 2a 20 22 66 6f 75 6e 64 3a 20 22 20 66 6f 75 6e * "found: " foun
9a40: 64 20 29 0a 0a 20 20 20 28 6c 65 74 20 6c 6f 6f d ).. (let loo
9a50: 70 20 28 28 68 65 64 20 28 63 61 72 20 74 65 73 p ((hed (car tes
9a60: 74 2d 64 61 74 61 29 29 0a 09 09 20 28 74 61 6c t-data))... (tal
9a70: 20 28 63 64 72 20 74 65 73 74 2d 64 61 74 61 29 (cdr test-data)
9a80: 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 64 65 )). (de
9a90: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
9aa0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
9ab0: 72 74 2a 20 22 69 74 65 6d 3a 20 22 20 28 76 65 rt* "item: " (ve
9ac0: 63 74 6f 72 2d 72 65 66 20 68 65 64 20 31 31 29 ctor-ref hed 11)
9ad0: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 68 65 64 (vector-ref hed
9ae0: 20 31 30 29 20 22 2f 22 20 28 76 65 63 74 6f 72 10) "/" (vector
9af0: 2d 72 65 66 20 68 65 64 20 31 33 29 29 0a 0a 09 -ref hed 13))...
9b00: 28 69 66 20 28 65 71 75 61 6c 3f 20 28 76 65 63 (if (equal? (vec
9b10: 74 6f 72 2d 72 65 66 20 68 65 64 20 31 31 29 20 tor-ref hed 11)
9b20: 69 74 65 6d 2d 6e 61 6d 65 29 0a 20 20 20 20 20 item-name).
9b30: 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 (begin.
9b40: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 65 74 (set
9b50: 21 20 66 6f 75 6e 64 20 31 29 20 0a 09 20 20 20 ! found 1) ..
9b60: 20 20 20 28 73 65 74 21 20 70 61 74 68 20 28 63 (set! path (c
9b70: 6f 6e 63 20 28 76 65 63 74 6f 72 2d 72 65 66 20 onc (vector-ref
9b80: 68 65 64 20 31 30 29 20 22 2f 22 20 28 76 65 63 hed 10) "/" (vec
9b90: 74 6f 72 2d 72 65 66 20 68 65 64 20 31 33 29 29 tor-ref hed 13))
9ba0: 29 29 29 0a 09 20 20 20 20 28 69 66 20 28 61 6e ))).. (if (an
9bb0: 64 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 d (not (null? ta
9bc0: 6c 29 29 20 28 65 71 75 61 6c 3f 20 66 6f 75 6e l)) (equal? foun
9bd0: 64 20 30 29 29 0a 09 09 28 6c 6f 6f 70 20 28 63 d 0))...(loop (c
9be0: 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 ar tal)(cdr tal)
9bf0: 29 29 29 0a 20 20 20 28 69 66 20 28 65 71 75 61 ))). (if (equa
9c00: 6c 3f 20 70 61 74 68 20 22 22 29 0a 20 20 20 20 l? path "").
9c10: 20 22 3c 48 32 3e 44 61 74 61 20 6e 6f 74 20 66 "<H2>Data not f
9c20: 6f 75 6e 64 3c 2f 48 32 3e 22 0a 20 20 20 20 20 ound</H2>".
9c30: 28 73 74 72 69 6e 67 2d 6a 6f 69 6e 20 28 74 65 (string-join (te
9c40: 73 74 73 3a 72 65 61 64 6c 69 6e 65 73 20 70 61 sts:readlines pa
9c50: 74 68 29 20 22 5c 6e 22 29 29 29 29 0a 0a 0a 28 th) "\n"))))...(
9c60: 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 64 79 define (tests:dy
9c70: 6e 61 6d 69 63 2d 64 62 6f 61 72 64 20 70 61 67 namic-dboard pag
9c80: 65 29 0a 3b 28 64 65 66 69 6e 65 20 28 74 65 73 e).;(define (tes
9c90: 74 73 3a 63 72 65 61 74 65 2d 68 74 6d 6c 2d 74 ts:create-html-t
9ca0: 72 65 65 20 6f 29 0a 20 28 6c 65 74 2a 20 28 0a ree o). (let* (.
9cb0: 3b 28 70 61 67 65 20 22 31 22 29 0a 20 20 20 20 ;(page "1").
9cc0: 20 20 20 20 20 20 28 6c 69 6e 6b 74 72 65 65 20 (linktree
9cd0: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 69 6e (common:get-lin
9ce0: 6b 74 72 65 65 29 29 0a 20 20 20 20 20 20 20 20 ktree)).
9cf0: 20 28 61 72 65 61 2d 6e 61 6d 65 20 28 63 6f 6d (area-name (com
9d00: 6d 6f 6e 3a 67 65 74 2d 74 65 73 74 73 75 69 74 mon:get-testsuit
9d10: 65 2d 6e 61 6d 65 29 29 0a 09 20 20 20 20 20 20 e-name))..
9d20: 20 28 6b 65 79 73 20 20 20 20 20 20 28 72 6d 74 (keys (rmt
9d30: 3a 67 65 74 2d 6b 65 79 73 29 29 0a 09 20 20 20 :get-keys))..
9d40: 20 20 20 20 28 6e 75 6d 6b 65 79 73 20 20 20 28 (numkeys (
9d50: 6c 65 6e 67 74 68 20 6b 65 79 73 29 29 0a 20 20 length keys)).
9d60: 20 20 20 20 20 20 20 28 74 61 72 67 74 77 65 61 (targtwea
9d70: 6b 65 64 20 28 6d 61 6b 65 2d 6c 69 73 74 20 6e ked (make-list n
9d80: 75 6d 6b 65 79 73 20 22 25 22 29 29 0a 20 20 20 umkeys "%")).
9d90: 20 20 20 20 20 20 28 74 61 72 67 65 74 2d 70 61 (target-pa
9da0: 74 74 20 28 73 74 72 69 6e 67 2d 6a 6f 69 6e 20 tt (string-join
9db0: 74 61 72 67 74 77 65 61 6b 65 64 20 22 2f 22 29 targtweaked "/")
9dc0: 29 0a 20 20 20 20 20 20 20 20 20 28 74 6f 74 61 ). (tota
9dd0: 6c 2d 72 75 6e 73 20 20 28 72 6d 74 3a 67 65 74 l-runs (rmt:get
9de0: 2d 6e 75 6d 2d 72 75 6e 73 20 22 25 22 29 29 0a -num-runs "%")).
9df0: 20 20 20 20 20 20 20 20 20 28 70 67 2d 73 69 7a (pg-siz
9e00: 65 20 31 30 29 0a 20 20 20 20 20 20 20 20 20 28 e 10). (
9e10: 70 67 20 28 69 66 20 28 65 71 75 61 6c 3f 20 70 pg (if (equal? p
9e20: 61 67 65 20 23 66 29 0a 20 20 20 20 20 20 20 20 age #f).
9e30: 20 20 20 20 20 20 20 20 20 30 0a 20 20 20 20 20 0.
9e40: 20 20 20 20 20 20 20 20 20 20 20 20 28 2d 20 28 (- (
9e50: 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 70 string->number p
9e60: 61 67 65 29 20 31 29 29 29 0a 20 20 20 20 20 20 age) 1))).
9e70: 20 20 20 20 28 67 65 74 2d 70 72 65 76 2d 6c 69 (get-prev-li
9e80: 6e 6b 73 20 20 28 6c 61 6d 62 64 61 20 28 70 67 nks (lambda (pg
9e90: 20 6c 69 6e 6b 74 72 65 65 29 0a 20 20 20 20 20 linktree).
9ea0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9eb0: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
9ec0: 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 nt-info 0 *defau
9ed0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 76 61 lt-log-port* "va
9ee0: 6c 3a 20 22 20 28 2d 20 31 20 70 67 29 29 0a 20 l: " (- 1 pg)).
9ef0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9f00: 20 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 (let* (
9f10: 28 6c 69 6e 6b 20 20 28 69 66 20 28 6e 6f 74 20 (link (if (not
9f20: 28 65 71 3f 20 70 67 20 30 29 29 0a 20 20 20 20 (eq? pg 0)).
9f30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9f40: 20 20 20 20 20 20 20 20 20 20 20 28 73 3a 61 20 (s:a
9f50: 20 22 26 6c 74 3b 26 6c 74 3b 70 72 65 76 20 22 "<<prev "
9f60: 20 27 68 72 65 66 20 28 63 6f 6e 63 20 20 22 64 'href (conc "d
9f70: 61 73 68 62 6f 61 72 64 3f 70 61 67 65 3d 22 20 ashboard?page="
9f80: 20 70 67 20 20 29 29 0a 20 20 20 20 20 20 20 20 pg )).
9f90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9fa0: 20 20 20 20 20 20 20 28 73 3a 61 20 22 22 20 27 (s:a "" '
9fb0: 68 72 65 66 20 28 63 6f 6e 63 20 20 22 64 61 73 href (conc "das
9fc0: 68 62 6f 61 72 64 3f 70 61 67 65 3d 22 20 70 67 hboard?page=" pg
9fd0: 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 ))))).
9fe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9ff0: 20 20 20 20 20 6c 69 6e 6b 29 29 29 0a 20 20 20 link))).
a000: 20 20 20 20 20 20 20 28 67 65 74 2d 6e 65 78 74 (get-next
a010: 2d 6c 69 6e 6b 73 20 20 20 28 6c 61 6d 62 64 61 -links (lambda
a020: 20 28 70 67 20 6c 69 6e 6b 74 72 65 65 20 74 6f (pg linktree to
a030: 74 61 6c 2d 72 75 6e 73 29 20 20 0a 20 20 20 20 tal-runs) .
a040: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a050: 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 (debug:p
a060: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 rint-info 0 *def
a070: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
a080: 76 61 6c 3a 20 22 20 70 67 29 0a 20 20 20 20 20 val: " pg).
a090: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a0a0: 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 (debug:p
a0b0: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 rint-info 0 *def
a0c0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
a0d0: 76 61 6c 3a 20 22 20 74 6f 74 61 6c 2d 72 75 6e val: " total-run
a0e0: 73 20 22 20 73 69 7a 65 22 20 70 67 2d 73 69 7a s " size" pg-siz
a0f0: 65 29 0a 20 0a 20 20 20 20 20 20 20 20 20 20 20 e). .
a100: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a110: 20 28 6c 65 74 2a 20 28 28 6c 69 6e 6b 20 20 28 (let* ((link (
a120: 69 66 20 28 3e 20 74 6f 74 61 6c 2d 72 75 6e 73 if (> total-runs
a130: 20 28 2b 20 31 30 20 28 2a 20 70 67 20 70 67 2d (+ 10 (* pg pg-
a140: 73 69 7a 65 29 29 29 0a 20 20 20 20 20 20 20 20 size))).
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 20 22 6e 65 78 (s:a "nex
a170: 74 26 67 74 3b 26 67 74 3b 20 22 20 20 27 68 72 t>> " 'hr
a180: 65 66 20 28 63 6f 6e 63 20 20 22 64 61 73 68 62 ef (conc "dashb
a190: 6f 61 72 64 3f 70 61 67 65 3d 22 20 20 28 2b 20 oard?page=" (+
a1a0: 70 67 20 32 29 20 20 29 29 0a 20 20 20 20 20 20 pg 2) )).
a1b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a1c0: 20 20 20 20 20 20 20 28 73 3a 61 20 22 22 20 27 (s:a "" '
a1d0: 68 72 65 66 20 28 63 6f 6e 63 20 20 22 64 61 73 href (conc "das
a1e0: 68 62 6f 61 72 64 3f 70 61 67 65 3d 22 20 70 67 hboard?page=" pg
a1f0: 20 20 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 ))))).
a200: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a210: 20 20 20 20 20 6c 69 6e 6b 29 29 29 0a 20 20 20 link))).
a220: 20 20 20 20 20 20 28 68 74 6d 6c 2d 62 6f 64 79 (html-body
a230: 20 28 74 65 73 74 73 3a 64 61 73 68 62 6f 61 72 (tests:dashboar
a240: 64 2d 62 6f 64 79 20 70 67 20 70 67 2d 73 69 7a d-body pg pg-siz
a250: 65 20 6b 65 79 73 20 6e 75 6d 6b 65 79 73 20 74 e keys numkeys t
a260: 6f 74 61 6c 2d 72 75 6e 73 20 6c 69 6e 6b 74 72 otal-runs linktr
a270: 65 65 20 61 72 65 61 2d 6e 61 6d 65 20 67 65 74 ee area-name get
a280: 2d 70 72 65 76 2d 6c 69 6e 6b 73 20 67 65 74 2d -prev-links get-
a290: 6e 65 78 74 2d 6c 69 6e 6b 73 20 23 74 20 22 25 next-links #t "%
a2a0: 22 20 74 61 72 67 65 74 2d 70 61 74 74 29 29 29 " target-patt)))
a2b0: 20 3b 3b 20 75 70 64 61 74 65 20 74 69 73 20 66 ;; update tis f
a2c0: 75 6e 63 74 69 6f 6e 0a 20 20 20 20 20 20 20 20 unction.
a2d0: 68 74 6d 6c 2d 62 6f 64 79 29 29 0a 0a 28 64 65 html-body))..(de
a2e0: 66 69 6e 65 20 28 74 65 73 74 73 3a 63 72 65 61 fine (tests:crea
a2f0: 74 65 2d 68 74 6d 6c 2d 73 75 6d 6d 61 72 79 20 te-html-summary
a300: 6f 75 74 66 29 0a 20 28 6c 65 74 2a 20 28 28 6c outf). (let* ((l
a310: 6f 63 6b 66 69 6c 65 20 20 28 63 6f 6e 63 20 6f ockfile (conc o
a320: 75 74 66 20 22 2e 6c 6f 63 6b 22 29 29 0a 20 20 utf ".lock")).
a330: 20 20 20 20 20 20 28 6c 69 6e 6b 74 72 65 65 20 (linktree
a340: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 69 6e (common:get-lin
a350: 6b 74 72 65 65 29 29 0a 09 09 09 09 28 6b 65 79 ktree)).....(key
a360: 73 20 20 20 20 20 20 28 72 6d 74 3a 67 65 74 2d s (rmt:get-
a370: 6b 65 79 73 29 29 0a 20 20 20 20 20 20 20 20 28 keys)). (
a380: 61 72 65 61 2d 6e 61 6d 65 20 28 63 6f 6d 6d 6f area-name (commo
a390: 6e 3a 67 65 74 2d 74 65 73 74 73 75 69 74 65 2d n:get-testsuite-
a3a0: 6e 61 6d 65 29 29 0a 20 20 20 20 20 20 20 20 28 name)). (
a3b0: 72 75 6e 2d 70 61 74 74 20 28 6f 72 20 28 61 72 run-patt (or (ar
a3c0: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 75 6e gs:get-arg "-run
a3d0: 2d 70 61 74 74 22 29 0a 20 20 20 20 20 20 20 20 -patt").
a3e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a3f0: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
a400: 72 75 6e 6e 61 6d 65 22 29 0a 20 20 20 20 20 20 runname").
a410: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a420: 20 20 22 25 22 29 29 0a 20 20 20 20 20 20 20 20 "%")).
a430: 28 74 61 72 67 65 74 20 28 6f 72 20 28 61 72 67 (target (or (arg
a440: 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 72 67 s:get-arg "-targ
a450: 65 74 2d 70 61 74 74 22 29 0a 20 20 20 20 20 20 et-patt").
a460: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a470: 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 (args:get-arg
a480: 22 2d 74 61 72 67 65 74 22 29 0a 20 20 20 20 20 "-target").
a490: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a4a0: 20 20 20 22 25 22 29 29 0a 20 20 20 20 20 20 20 "%")).
a4b0: 20 20 28 74 61 72 67 6c 69 73 74 20 28 73 74 72 (targlist (str
a4c0: 69 6e 67 2d 73 70 6c 69 74 20 74 61 72 67 65 74 ing-split target
a4d0: 20 22 2f 22 29 29 0a 20 20 20 20 20 20 20 20 20 "/")).
a4e0: 28 6e 75 6d 6b 65 79 73 20 20 28 6c 65 6e 67 74 (numkeys (lengt
a4f0: 68 20 6b 65 79 73 29 29 0a 09 20 20 20 20 20 20 h keys))..
a500: 20 28 6e 75 6d 74 61 72 67 20 20 28 6c 65 6e 67 (numtarg (leng
a510: 74 68 20 74 61 72 67 6c 69 73 74 29 29 20 20 0a th targlist)) .
a520: 20 20 20 20 20 20 20 20 20 28 74 61 72 67 74 77 (targtw
a530: 65 61 6b 65 64 20 28 69 66 20 28 3e 20 6e 75 6d eaked (if (> num
a540: 6b 65 79 73 20 6e 75 6d 74 61 72 67 29 0a 09 09 keys numtarg)...
a550: 09 20 20 20 09 09 09 09 09 09 09 09 28 61 70 70 . ........(app
a560: 65 6e 64 20 74 61 72 67 6c 69 73 74 20 28 6d 61 end targlist (ma
a570: 6b 65 2d 6c 69 73 74 20 28 2d 20 6e 75 6d 6b 65 ke-list (- numke
a580: 79 73 20 6e 75 6d 74 61 72 67 29 20 22 25 22 29 ys numtarg) "%")
a590: 29 0a 09 09 09 20 20 09 09 09 09 09 09 09 09 74 ).... ........t
a5a0: 61 72 67 6c 69 73 74 29 29 0a 20 20 20 20 20 20 arglist)).
a5b0: 20 20 28 74 61 72 67 65 74 2d 70 61 74 74 20 28 (target-patt (
a5c0: 73 74 72 69 6e 67 2d 6a 6f 69 6e 20 74 61 72 67 string-join targ
a5d0: 74 77 65 61 6b 65 64 20 22 2f 22 29 29 29 0a 20 tweaked "/"))).
a5e0: 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 73 (if (common:s
a5f0: 69 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 20 imple-file-lock
a600: 6c 6f 63 6b 66 69 6c 65 29 0a 20 20 20 20 20 20 lockfile).
a610: 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 (begin.
a620: 20 20 20 28 6c 65 74 2a 20 28 3b 28 72 75 6e 73 (let* (;(runs
a630: 64 61 74 31 20 20 20 28 72 6d 74 3a 67 65 74 2d dat1 (rmt:get-
a640: 72 75 6e 73 20 72 75 6e 2d 70 61 74 74 20 23 66 runs run-patt #f
a650: 20 23 66 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 #f (map (lambda
a660: 20 28 78 29 28 6c 69 73 74 20 78 20 22 25 22 29 (x)(list x "%")
a670: 29 20 6b 65 79 73 29 29 29 0a 20 20 20 20 20 20 ) keys))).
a680: 20 20 20 20 20 20 20 20 20 20 20 28 72 75 6e 73 (runs
a690: 64 61 74 20 20 20 28 72 6d 74 3a 67 65 74 2d 72 dat (rmt:get-r
a6a0: 75 6e 73 2d 62 79 2d 70 61 74 74 20 20 6b 65 79 uns-by-patt key
a6b0: 73 20 72 75 6e 2d 70 61 74 74 20 74 61 72 67 65 s run-patt targe
a6c0: 74 2d 70 61 74 74 20 23 66 20 23 66 20 23 66 20 t-patt #f #f #f
a6d0: 30 29 29 0a 09 09 09 09 09 20 20 20 20 20 20 20 0))......
a6e0: 28 72 75 6e 73 20 20 20 20 20 20 28 76 65 63 74 (runs (vect
a6f0: 6f 72 2d 72 65 66 20 72 75 6e 73 64 61 74 20 31 or-ref runsdat 1
a700: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
a710: 20 20 20 20 28 68 65 61 64 65 72 20 20 20 20 20 (header
a720: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e (vector-ref run
a730: 73 64 61 74 20 30 29 29 0a 20 20 20 20 20 20 20 sdat 0)).
a740: 20 09 20 20 20 20 20 20 20 28 6f 75 70 20 20 20 . (oup
a750: 20 20 20 20 28 6f 70 65 6e 2d 6f 75 74 70 75 74 (open-output
a760: 2d 66 69 6c 65 20 28 6f 72 20 6f 75 74 66 20 28 -file (or outf (
a770: 63 6f 6e 63 20 6c 69 6e 6b 74 72 65 65 20 22 2f conc linktree "/
a780: 74 61 72 67 65 74 73 2e 68 74 6d 6c 22 29 29 29 targets.html")))
a790: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
a7a0: 20 20 20 28 74 61 72 67 65 74 2d 68 61 73 68 20 (target-hash
a7b0: 28 74 65 73 74 3a 63 72 65 61 74 65 2d 74 61 72 (test:create-tar
a7c0: 67 65 74 2d 68 61 73 68 20 72 75 6e 73 20 68 65 get-hash runs he
a7d0: 61 64 65 72 20 28 6c 65 6e 67 74 68 20 6b 65 79 ader (length key
a7e0: 73 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 s)))).
a7f0: 20 28 74 65 73 74 3a 63 72 65 61 74 65 2d 74 61 (test:create-ta
a800: 72 67 65 74 2d 68 74 6d 6c 20 74 61 72 67 65 74 rget-html target
a810: 2d 68 61 73 68 20 6f 75 70 20 61 72 65 61 2d 6e -hash oup area-n
a820: 61 6d 65 20 6c 69 6e 6b 74 72 65 65 29 0a 20 20 ame linktree).
a830: 20 20 20 20 20 20 20 20 28 74 65 73 74 3a 63 72 (test:cr
a840: 65 61 74 65 2d 72 75 6e 2d 68 74 6d 6c 20 20 72 eate-run-html r
a850: 75 6e 73 20 61 72 65 61 2d 6e 61 6d 65 20 6c 69 uns area-name li
a860: 6e 6b 74 72 65 65 20 28 6c 65 6e 67 74 68 20 6b nktree (length k
a870: 65 79 73 29 20 68 65 61 64 65 72 29 29 0a 09 20 eys) header))..
a880: 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 2d (common:simple-
a890: 66 69 6c 65 2d 72 65 6c 65 61 73 65 2d 6c 6f 63 file-release-loc
a8a0: 6b 20 6c 6f 63 6b 66 69 6c 65 29 29 0a 09 23 66 k lockfile))..#f
a8b0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 )))..(define (te
a8c0: 73 74 3a 67 65 74 2d 74 65 73 74 2d 68 61 73 68 st:get-test-hash
a8d0: 20 74 65 73 74 2d 64 61 74 61 29 0a 09 28 6c 65 test-data)..(le
a8e0: 74 20 28 28 72 65 73 68 20 28 6d 61 6b 65 2d 68 t ((resh (make-h
a8f0: 61 73 68 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 ash-table))).
a900: 20 09 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 .(map (lambda (
a910: 74 65 73 74 29 0a 20 20 20 20 20 20 20 20 28 6c test). (l
a920: 65 74 2a 20 28 28 74 65 73 74 2d 6e 61 6d 65 20 et* ((test-name
a930: 28 76 65 63 74 6f 72 2d 72 65 66 20 74 65 73 74 (vector-ref test
a940: 20 32 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 2)).
a950: 20 20 20 20 28 74 65 73 74 2d 68 74 6d 6c 2d 70 (test-html-p
a960: 61 74 68 20 28 69 66 20 28 66 69 6c 65 2d 65 78 ath (if (file-ex
a970: 69 73 74 73 3f 20 28 63 6f 6e 63 20 28 76 65 63 ists? (conc (vec
a980: 74 6f 72 2d 72 65 66 20 74 65 73 74 20 31 30 29 tor-ref test 10)
a990: 20 22 2f 74 65 73 74 2d 73 75 6d 6d 61 72 79 2e "/test-summary.
a9a0: 68 74 6d 6c 22 29 29 0a 09 09 09 09 09 09 09 09 html")).........
a9b0: 09 09 09 09 09 09 09 09 20 28 63 6f 6e 63 20 28 ........ (conc (
a9c0: 76 65 63 74 6f 72 2d 72 65 66 20 74 65 73 74 20 vector-ref test
a9d0: 31 30 29 20 22 2f 74 65 73 74 2d 73 75 6d 6d 61 10) "/test-summa
a9e0: 72 79 2e 68 74 6d 6c 22 20 29 0a 09 09 09 09 09 ry.html" )......
a9f0: 09 09 20 09 09 09 09 09 09 09 09 09 20 28 63 6f .. ......... (co
aa00: 6e 63 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 nc (vector-ref t
aa10: 65 73 74 20 31 30 29 20 22 2f 22 20 28 76 65 63 est 10) "/" (vec
aa20: 74 6f 72 2d 72 65 66 20 74 65 73 74 20 31 33 29 tor-ref test 13)
aa30: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
aa40: 20 20 20 28 74 65 73 74 2d 69 74 65 6d 20 20 28 (test-item (
aa50: 76 65 63 74 6f 72 2d 72 65 66 20 74 65 73 74 20 vector-ref test
aa60: 31 31 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 11)).
aa70: 20 20 20 20 28 74 65 73 74 2d 73 74 61 74 75 73 (test-status
aa80: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 65 73 (vector-ref tes
aa90: 74 20 34 29 29 29 0a 20 20 20 20 20 20 20 20 20 t 4))).
aaa0: 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 (if (not (
aab0: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
aac0: 65 66 61 75 6c 74 20 72 65 73 68 20 74 65 73 74 efault resh test
aad0: 2d 69 74 65 6d 20 20 23 66 29 29 0a 20 20 20 20 -item #f)).
aae0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
aaf0: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
ab00: 72 65 73 68 20 74 65 73 74 2d 69 74 65 6d 20 20 resh test-item
ab10: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
ab20: 65 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 e))).
ab30: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
ab40: 73 65 74 21 20 28 68 61 73 68 2d 74 61 62 6c 65 set! (hash-table
ab50: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 72 65 73 -ref/default res
ab60: 68 20 74 65 73 74 2d 69 74 65 6d 20 20 23 66 29 h test-item #f)
ab70: 20 74 65 73 74 2d 6e 61 6d 65 20 28 6c 69 73 74 test-name (list
ab80: 20 74 65 73 74 2d 73 74 61 74 75 73 20 74 65 73 test-status tes
ab90: 74 2d 68 74 6d 6c 2d 70 61 74 68 29 29 29 29 20 t-html-path))))
aba0: 0a 20 20 20 20 20 20 20 20 74 65 73 74 2d 64 61 . test-da
abb0: 74 61 29 0a 72 65 73 68 29 29 0a 0a 28 64 65 66 ta).resh))..(def
abc0: 69 6e 65 20 28 74 65 73 74 3a 67 65 74 2d 64 61 ine (test:get-da
abd0: 74 61 2d 3e 62 2d 6b 65 79 73 20 6f 72 64 65 72 ta->b-keys order
abe0: 65 64 2d 64 61 74 61 20 61 2d 6b 65 79 73 29 0a ed-data a-keys).
abf0: 20 20 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 (delete-duplic
ac00: 61 74 65 73 0a 20 20 20 28 73 6f 72 74 20 28 61 ates. (sort (a
ac10: 70 70 6c 79 0a 09 20 20 61 70 70 65 6e 64 0a 09 pply.. append..
ac20: 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 (map (lambda (
ac30: 73 75 62 2d 6b 65 79 29 0a 09 09 20 28 6c 65 74 sub-key)... (let
ac40: 20 28 28 73 75 62 64 61 74 20 28 68 61 73 68 2d ((subdat (hash-
ac50: 74 61 62 6c 65 2d 72 65 66 20 6f 72 64 65 72 65 table-ref ordere
ac60: 64 2d 64 61 74 61 20 73 75 62 2d 6b 65 79 29 29 d-data sub-key))
ac70: 29 0a 09 09 20 20 20 28 68 61 73 68 2d 74 61 62 )... (hash-tab
ac80: 6c 65 2d 6b 65 79 73 20 73 75 62 64 61 74 29 29 le-keys subdat))
ac90: 29 0a 09 20 20 20 20 20 20 20 61 2d 6b 65 79 73 ).. a-keys
aca0: 29 29 0a 09 20 73 74 72 69 6e 67 3e 3d 3f 29 29 )).. string>=?))
acb0: 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 )...(define (tes
acc0: 74 3a 63 72 65 61 74 65 2d 72 75 6e 2d 68 74 6d t:create-run-htm
acd0: 6c 20 72 75 6e 73 20 61 72 65 61 2d 6e 61 6d 65 l runs area-name
ace0: 20 6c 69 6e 6b 74 72 65 65 20 6e 75 6d 6b 65 79 linktree numkey
acf0: 73 20 68 65 61 64 65 72 29 0a 20 20 28 6d 61 70 s header). (map
ad00: 20 28 6c 61 6d 62 64 61 20 28 72 75 6e 29 0a 09 (lambda (run)..
ad10: 09 20 28 6c 65 74 2a 20 28 28 74 61 72 67 65 74 . (let* ((target
ad20: 20 28 73 74 72 69 6e 67 2d 6a 6f 69 6e 20 28 74 (string-join (t
ad30: 61 6b 65 20 28 76 65 63 74 6f 72 2d 3e 6c 69 73 ake (vector->lis
ad40: 74 20 72 75 6e 29 20 6e 75 6d 6b 65 79 73 29 20 t run) numkeys)
ad50: 22 2f 22 29 29 0a 09 09 09 09 09 09 28 72 75 6e "/")).......(run
ad60: 2d 6e 61 6d 65 20 28 64 62 3a 67 65 74 2d 76 61 -name (db:get-va
ad70: 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 lue-by-header ru
ad80: 6e 20 68 65 61 64 65 72 20 22 72 75 6e 6e 61 6d n header "runnam
ad90: 65 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 e")).
ada0: 20 28 72 75 6e 2d 74 69 6d 65 20 28 73 65 63 6f (run-time (seco
adb0: 6e 64 73 2d 3e 77 6f 72 6b 2d 77 65 65 6b 2f 64 nds->work-week/d
adc0: 61 79 2d 74 69 6d 65 20 28 64 62 3a 67 65 74 2d ay-time (db:get-
add0: 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 value-by-header
ade0: 72 75 6e 20 68 65 61 64 65 72 20 22 65 76 65 6e run header "even
adf0: 74 5f 74 69 6d 65 22 29 29 29 0a 09 09 09 09 09 t_time")))......
ae00: 09 28 6f 75 70 20 28 69 66 20 28 66 69 6c 65 2d .(oup (if (file-
ae10: 65 78 69 73 74 73 3f 20 28 63 6f 6e 63 20 6c 69 exists? (conc li
ae20: 6e 6b 74 72 65 65 20 22 2f 22 20 74 61 72 67 65 nktree "/" targe
ae30: 74 20 22 2f 22 20 72 75 6e 2d 6e 61 6d 65 29 29 t "/" run-name))
ae40: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
ae50: 20 20 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 6f (open-o
ae60: 75 74 70 75 74 2d 66 69 6c 65 20 28 63 6f 6e 63 utput-file (conc
ae70: 20 6c 69 6e 6b 74 72 65 65 20 22 2f 22 20 74 61 linktree "/" ta
ae80: 72 67 65 74 20 22 2f 22 20 72 75 6e 2d 6e 61 6d rget "/" run-nam
ae90: 65 20 22 2f 72 75 6e 2e 68 74 6d 6c 22 29 29 0a e "/run.html")).
aea0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
aeb0: 20 20 20 20 20 20 20 20 20 23 66 29 29 0a 20 20 #f)).
aec0: 20 20 20 20 20 20 20 20 20 20 28 72 75 6e 2d 69 (run-i
aed0: 64 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d d (db:get-value-
aee0: 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 by-header run he
aef0: 61 64 65 72 20 22 69 64 22 29 29 0a 20 20 20 20 ader "id")).
af00: 20 20 20 20 20 20 20 20 28 74 65 73 74 2d 64 61 (test-da
af10: 74 61 20 20 20 20 28 72 6d 74 3a 67 65 74 2d 74 ta (rmt:get-t
af20: 65 73 74 73 2d 66 6f 72 2d 72 75 6e 0a 09 09 09 ests-for-run....
af30: 09 20 20 09 09 09 09 09 09 09 09 20 72 75 6e 2d . ........ run-
af40: 69 64 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 id.
af50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 22 25 "%
af60: 22 20 20 20 20 20 20 20 3b 3b 20 74 65 73 74 6e " ;; testn
af70: 61 6d 65 70 61 74 74 0a 09 09 09 09 20 20 09 09 amepatt..... ..
af80: 09 09 09 09 09 09 20 27 28 29 20 20 20 20 20 20 ...... '()
af90: 20 20 3b 3b 20 73 74 61 74 65 73 0a 09 09 09 09 ;; states.....
afa0: 20 20 20 09 09 09 09 09 09 09 09 20 27 28 29 20 ........ '()
afb0: 20 20 20 20 20 20 20 3b 3b 20 73 74 61 74 75 73 ;; status
afc0: 65 73 0a 09 09 09 09 20 20 09 09 09 09 09 09 09 es..... .......
afd0: 09 20 09 23 66 20 20 20 20 20 20 20 20 20 3b 3b . .#f ;;
afe0: 20 6f 66 66 73 65 74 0a 09 09 09 09 20 20 09 09 offset..... ..
aff0: 09 09 09 09 20 09 09 09 23 66 20 20 20 20 20 20 .... ...#f
b000: 20 20 20 3b 3b 20 6e 75 6d 2d 74 6f 2d 67 65 74 ;; num-to-get
b010: 0a 09 09 09 09 20 20 20 09 09 09 09 09 09 09 09 ..... ........
b020: 09 23 66 20 20 20 20 20 20 20 20 20 3b 3b 20 68 .#f ;; h
b030: 69 64 65 2f 6e 6f 74 2d 68 69 64 65 0a 09 09 09 ide/not-hide....
b040: 09 20 20 09 09 09 09 09 09 09 09 20 20 23 66 20 . ........ #f
b050: 20 20 20 20 20 20 20 20 3b 3b 20 73 6f 72 74 2d ;; sort-
b060: 62 79 0a 09 09 09 09 20 20 20 09 09 09 09 09 09 by..... ......
b070: 09 09 09 23 66 20 20 20 20 20 20 20 20 20 3b 3b ...#f ;;
b080: 20 73 6f 72 74 2d 6f 72 64 65 72 0a 09 09 09 09 sort-order.....
b090: 20 20 20 09 09 09 09 09 09 09 09 09 23 66 20 20 .........#f
b0a0: 20 20 20 20 20 20 20 3b 3b 20 27 73 68 6f 72 74 ;; 'short
b0b0: 6c 69 73 74 20 20 20 20 20 20 20 20 20 20 20 20 list
b0c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
b0d0: 3b 20 71 72 79 74 79 70 65 0a 20 20 20 20 20 20 ; qrytype.
b0e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b0f0: 20 20 20 20 20 20 30 20 20 20 20 20 20 20 20 20 0
b100: 3b 3b 20 6c 61 73 74 20 75 70 64 61 74 65 0a 09 ;; last update..
b110: 09 09 09 20 20 09 09 09 09 09 09 09 09 09 23 66 ... .........#f
b120: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 )). (
b130: 69 74 65 6d 2d 74 65 73 74 2d 68 61 73 68 20 28 item-test-hash (
b140: 74 65 73 74 3a 67 65 74 2d 74 65 73 74 2d 68 61 test:get-test-ha
b150: 73 68 20 74 65 73 74 2d 64 61 74 61 29 29 0a 20 sh test-data)).
b160: 20 20 20 20 20 20 20 20 20 20 20 28 69 74 65 6d (item
b170: 73 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b s (hash-table-k
b180: 65 79 73 20 69 74 65 6d 2d 74 65 73 74 2d 68 61 eys item-test-ha
b190: 73 68 29 29 0a 20 09 09 09 09 09 09 28 74 65 73 sh)). ......(tes
b1a0: 74 2d 6e 61 6d 65 73 20 28 74 65 73 74 3a 67 65 t-names (test:ge
b1b0: 74 2d 64 61 74 61 2d 3e 62 2d 6b 65 79 73 20 69 t-data->b-keys i
b1c0: 74 65 6d 2d 74 65 73 74 2d 68 61 73 68 20 69 74 tem-test-hash it
b1d0: 65 6d 73 29 29 29 0a 20 20 20 20 28 69 66 20 6f ems))). (if o
b1e0: 75 70 0a 20 20 20 20 20 20 28 62 65 67 69 6e 20 up. (begin
b1f0: 0a 20 20 20 20 20 28 73 3a 6f 75 74 70 75 74 2d . (s:output-
b200: 6e 65 77 0a 09 20 20 20 6f 75 70 0a 09 20 20 20 new.. oup..
b210: 28 73 3a 68 74 6d 6c 20 74 65 73 74 73 3a 63 73 (s:html tests:cs
b220: 73 2d 6a 73 63 72 69 70 74 2d 62 6c 6f 63 6b 20 s-jscript-block
b230: 28 74 65 73 74 73 3a 63 73 73 2d 6a 73 63 72 69 (tests:css-jscri
b240: 70 74 2d 62 6c 6f 63 6b 2d 63 6f 6e 64 20 23 66 pt-block-cond #f
b250: 29 0a 09 09 20 20 20 28 73 3a 74 69 74 6c 65 20 )... (s:title
b260: 22 52 75 6e 73 20 56 69 65 77 20 22 20 72 75 6e "Runs View " run
b270: 2d 6e 61 6d 65 29 0a 09 09 20 20 20 28 73 3a 62 -name)... (s:b
b280: 6f 64 79 0a 09 09 20 20 20 20 20 28 73 3a 68 31 ody... (s:h1
b290: 20 22 52 75 6e 73 20 56 69 65 77 20 22 20 29 0a "Runs View " ).
b2a0: 20 20 20 20 20 20 20 20 20 28 73 3a 68 33 20 22 (s:h3 "
b2b0: 54 61 72 67 65 74 22 20 74 61 72 67 65 74 29 0a Target" target).
b2c0: 09 09 09 09 20 28 73 3a 70 20 0a 09 09 09 09 09 .... (s:p ......
b2d0: 28 73 3a 62 20 22 52 75 6e 20 6e 61 6d 65 22 20 (s:b "Run name"
b2e0: 29 20 72 75 6e 2d 6e 61 6d 65 29 0a 20 20 20 20 ) run-name).
b2f0: 20 20 20 20 20 28 73 3a 70 20 0a 09 09 09 09 09 (s:p ......
b300: 28 73 3a 62 20 22 52 75 6e 20 44 61 74 65 22 20 (s:b "Run Date"
b310: 29 20 72 75 6e 2d 74 69 6d 65 29 0a 20 20 20 20 ) run-time).
b320: 20 20 20 20 20 28 73 3a 74 61 62 6c 65 20 27 62 (s:table 'b
b330: 6f 72 64 65 72 20 31 20 27 63 65 6c 6c 73 70 61 order 1 'cellspa
b340: 63 69 6e 67 20 30 0a 20 20 20 20 20 20 20 20 20 cing 0.
b350: 20 20 28 73 3a 74 72 0a 20 20 20 20 20 20 20 20 (s:tr.
b360: 20 20 20 28 73 3a 74 68 20 22 49 74 65 6d 73 22 (s:th "Items"
b370: 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 ). (ma
b380: 70 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 29 p (lambda (test)
b390: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 73 3a . (s:
b3a0: 74 68 20 74 65 73 74 29 29 0a 20 20 20 20 20 20 th test)).
b3b0: 20 20 20 20 20 74 65 73 74 2d 6e 61 6d 65 73 29 test-names)
b3c0: 29 20 20 0a 20 20 20 20 20 20 20 20 20 20 20 28 ) . (
b3d0: 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 69 74 65 map (lambda (ite
b3e0: 6d 29 20 0a 09 09 09 09 09 20 20 28 6c 65 74 2a m) ...... (let*
b3f0: 20 28 28 74 65 73 74 2d 68 61 73 68 20 28 68 61 ((test-hash (ha
b400: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
b410: 61 75 6c 74 20 69 74 65 6d 2d 74 65 73 74 2d 68 ault item-test-h
b420: 61 73 68 20 69 74 65 6d 20 20 23 66 29 29 29 0a ash item #f))).
b430: 09 09 09 09 09 09 09 09 20 28 69 66 20 74 65 73 ........ (if tes
b440: 74 2d 68 61 73 68 0a 20 20 20 20 20 20 20 20 20 t-hash.
b450: 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a (begin.
b460: 09 09 09 09 09 09 09 09 09 28 73 3a 74 72 0a 09 .........(s:tr..
b470: 09 09 09 09 20 20 09 09 09 28 73 3a 74 64 20 27 .... ...(s:td '
b480: 63 6c 61 73 73 20 22 74 65 73 74 22 20 69 74 65 class "test" ite
b490: 6d 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 09 m). .
b4a0: 09 09 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 ..(map (lambda (
b4b0: 74 65 73 74 29 0a 09 09 09 09 09 09 20 20 09 09 test)....... ..
b4c0: 28 6c 65 74 2a 20 28 28 74 65 73 74 2d 64 65 74 (let* ((test-det
b4d0: 61 69 6c 73 20 28 68 61 73 68 2d 74 61 62 6c 65 ails (hash-table
b4e0: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 65 73 -ref/default tes
b4f0: 74 2d 68 61 73 68 20 74 65 73 74 20 20 23 66 29 t-hash test #f)
b500: 29 0a 09 09 09 09 09 09 09 09 09 09 09 09 28 73 ).............(s
b510: 74 61 74 75 73 20 28 69 66 20 74 65 73 74 2d 64 tatus (if test-d
b520: 65 74 61 69 6c 73 0a 09 09 09 09 09 09 09 09 09 etails..........
b530: 09 09 09 09 09 09 09 28 63 61 72 20 74 65 73 74 .......(car test
b540: 2d 64 65 74 61 69 6c 73 29 29 29 0a 20 20 20 20 -details))).
b550: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b560: 20 20 20 20 28 6c 69 6e 6b 20 28 69 66 20 74 65 (link (if te
b570: 73 74 2d 64 65 74 61 69 6c 73 20 0a 09 09 09 09 st-details .....
b580: 09 09 09 09 09 09 09 09 09 09 28 73 74 72 69 6e ..........(strin
b590: 67 2d 73 75 62 73 74 69 74 75 74 65 20 20 28 63 g-substitute (c
b5a0: 6f 6e 63 20 6c 69 6e 6b 74 72 65 65 20 22 2f 22 onc linktree "/"
b5b0: 20 74 61 72 67 65 74 20 22 2f 22 20 72 75 6e 2d target "/" run-
b5c0: 6e 61 6d 65 20 22 2f 22 29 20 20 22 22 20 28 63 name "/") "" (c
b5d0: 61 64 72 20 74 65 73 74 2d 64 65 74 61 69 6c 73 adr test-details
b5e0: 29 20 22 2d 22 29 29 29 29 0a 20 20 20 20 20 20 ) "-")))).
b5f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
b600: 20 74 65 73 74 2d 64 65 74 61 69 6c 73 0a 09 09 test-details...
b610: 09 09 09 09 09 09 09 09 09 28 73 3a 74 64 20 27 .........(s:td '
b620: 63 6c 61 73 73 20 73 74 61 74 75 73 0a 09 09 09 class status....
b630: 09 09 09 09 09 09 09 09 09 28 73 3a 61 20 27 63 .........(s:a 'c
b640: 6c 61 73 73 20 22 6c 69 6e 6b 22 20 27 68 72 65 lass "link" 'hre
b650: 66 20 6c 69 6e 6b 20 73 74 61 74 75 73 20 29 29 f link status ))
b660: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
b670: 20 20 20 20 20 20 20 28 73 3a 74 64 20 22 22 29 (s:td "")
b680: 29 29 29 20 09 09 09 0a 09 09 09 09 09 09 09 09 ))) ............
b690: 09 74 65 73 74 2d 6e 61 6d 65 73 29 29 29 29 29 .test-names)))))
b6a0: 29 0a 09 09 09 09 20 20 28 73 6f 72 74 20 69 74 )..... (sort it
b6b0: 65 6d 73 20 73 74 72 69 6e 67 3c 3d 3f 29 29 29 ems string<=?)))
b6c0: 29 29 29 0a 09 09 28 63 6c 6f 73 65 2d 6f 75 74 )))...(close-out
b6d0: 70 75 74 2d 70 6f 72 74 20 6f 75 70 29 29 0a 20 put-port oup)).
b6e0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
b6f0: 69 6e 66 6f 20 30 20 22 53 6b 69 70 3a 20 44 69 info 0 "Skip: Di
b700: 72 63 74 6f 72 79 20 73 74 72 75 63 74 75 72 65 rctory structure
b710: 20 22 20 6c 69 6e 6b 74 72 65 65 20 22 2f 22 20 " linktree "/"
b720: 74 61 72 67 65 74 20 22 2f 22 20 72 75 6e 2d 6e target "/" run-n
b730: 61 6d 65 20 22 20 64 6f 65 73 20 6e 6f 74 20 65 ame " does not e
b740: 78 69 73 74 2e 20 4d 65 67 61 74 65 73 74 20 77 xist. Megatest w
b750: 69 6c 6c 20 6e 6f 74 20 63 72 65 61 74 65 20 72 ill not create r
b760: 75 6e 2e 68 74 6d 6c 22 29 29 29 29 0a 72 75 6e un.html")))).run
b770: 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 s))..(define (te
b780: 73 74 3a 63 72 65 61 74 65 2d 74 61 72 67 65 74 st:create-target
b790: 2d 68 61 73 68 20 72 75 6e 73 20 68 65 61 64 65 -hash runs heade
b7a0: 72 20 6e 75 6d 6b 65 79 73 29 0a 20 20 28 6c 65 r numkeys). (le
b7b0: 74 20 28 28 72 65 73 68 20 28 6d 61 6b 65 2d 68 t ((resh (make-h
b7c0: 61 73 68 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 ash-table))).
b7d0: 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 (for-each. (
b7e0: 6c 61 6d 62 64 61 20 28 72 75 6e 29 0a 20 20 20 lambda (run).
b7f0: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 72 75 6e (let* ((run
b800: 2d 6e 61 6d 65 20 28 64 62 3a 67 65 74 2d 76 61 -name (db:get-va
b810: 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 lue-by-header ru
b820: 6e 20 68 65 61 64 65 72 20 22 72 75 6e 6e 61 6d n header "runnam
b830: 65 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 e")).
b840: 20 20 20 20 28 74 61 72 67 65 74 20 20 20 28 73 (target (s
b850: 74 72 69 6e 67 2d 6a 6f 69 6e 20 28 74 61 6b 65 tring-join (take
b860: 20 28 76 65 63 74 6f 72 2d 3e 6c 69 73 74 20 72 (vector->list r
b870: 75 6e 29 20 6e 75 6d 6b 65 79 73 29 20 22 2f 22 un) numkeys) "/"
b880: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
b890: 20 20 28 72 75 6e 2d 6c 69 73 74 20 28 68 61 73 (run-list (has
b8a0: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
b8b0: 75 6c 74 20 72 65 73 68 20 74 61 72 67 65 74 20 ult resh target
b8c0: 20 23 66 29 29 29 0a 20 20 20 20 20 20 20 20 20 #f))).
b8d0: 20 20 20 20 20 20 0a 20 20 20 20 20 20 20 20 20 .
b8e0: 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 72 (if (not r
b8f0: 75 6e 2d 6c 69 73 74 29 0a 20 20 20 20 20 20 20 un-list).
b900: 20 20 20 20 20 20 20 20 20 20 20 20 28 68 61 73 (has
b910: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 72 65 73 h-table-set! res
b920: 68 20 74 61 72 67 65 74 20 20 20 28 6c 69 73 74 h target (list
b930: 20 72 75 6e 2d 6e 61 6d 65 29 29 0a 20 20 20 20 run-name)).
b940: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
b950: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
b960: 72 65 73 68 20 74 61 72 67 65 74 20 20 20 28 63 resh target (c
b970: 6f 6e 73 20 72 75 6e 2d 6e 61 6d 65 20 72 75 6e ons run-name run
b980: 2d 6c 69 73 74 29 29 29 29 29 0a 20 20 20 20 20 -list))))).
b990: 20 72 75 6e 73 29 0a 20 20 20 72 65 73 68 29 29 runs). resh))
b9a0: 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 3a ..(define (test:
b9b0: 67 65 74 2d 6d 61 78 2d 72 75 6e 2d 63 6e 74 20 get-max-run-cnt
b9c0: 74 61 72 67 65 74 2d 68 61 73 68 20 74 61 72 67 target-hash targ
b9d0: 65 74 73 29 0a 20 20 20 28 6c 65 74 2a 20 28 28 ets). (let* ((
b9e0: 63 6e 74 20 30 20 29 29 0a 20 20 20 28 6d 61 70 cnt 0 )). (map
b9f0: 20 28 6c 61 6d 62 64 61 20 28 74 61 72 67 65 74 (lambda (target
ba00: 29 0a 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 ). (let*
ba10: 28 28 72 75 6e 73 20 20 28 68 61 73 68 2d 74 61 ((runs (hash-ta
ba20: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
ba30: 74 61 72 67 65 74 2d 68 61 73 68 20 74 61 72 67 target-hash targ
ba40: 65 74 20 20 23 66 29 29 0a 20 20 20 20 20 20 20 et #f)).
ba50: 20 20 20 20 20 20 20 20 28 72 75 6e 2d 6c 65 6e (run-len
ba60: 67 74 68 20 28 69 66 20 72 75 6e 73 0a 09 09 09 gth (if runs....
ba70: 09 09 09 09 09 09 09 09 09 09 09 09 09 28 6c 65 .............(le
ba80: 6e 67 74 68 20 72 75 6e 73 29 0a 20 20 20 20 20 ngth runs).
ba90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
baa0: 20 20 20 20 20 20 20 20 20 20 20 20 30 29 29 29 0)))
bab0: 0a 20 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 . .
bac0: 20 20 28 69 66 20 28 3c 20 63 6e 74 20 72 75 6e (if (< cnt run
bad0: 2d 6c 65 6e 67 74 68 29 0a 20 20 20 20 20 20 20 -length).
bae0: 20 20 20 20 20 20 20 20 28 73 65 74 21 20 63 6e (set! cn
baf0: 74 20 20 72 75 6e 2d 6c 65 6e 67 74 68 29 29 29 t run-length)))
bb00: 29 20 0a 09 09 74 61 72 67 65 74 73 29 20 0a 63 ) ...targets) .c
bb10: 6e 74 29 29 0a 20 0a 28 64 65 66 69 6e 65 20 28 nt)). .(define (
bb20: 74 65 73 74 3a 70 61 64 2d 72 75 6e 73 20 74 61 test:pad-runs ta
bb30: 72 67 65 74 2d 68 61 73 68 20 74 61 72 67 65 74 rget-hash target
bb40: 73 20 6d 61 78 2d 72 6f 77 2d 6c 65 6e 67 74 68 s max-row-length
bb50: 29 0a 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 ). (map (lambda
bb60: 28 74 61 72 67 65 74 29 0a 20 20 20 20 20 20 20 (target).
bb70: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 72 75 6e (let loop ((run
bb80: 2d 6c 69 73 74 20 20 28 68 61 73 68 2d 74 61 62 -list (hash-tab
bb90: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 le-ref/default t
bba0: 61 72 67 65 74 2d 68 61 73 68 20 74 61 72 67 65 arget-hash targe
bbb0: 74 20 20 23 66 29 29 29 0a 20 20 20 20 20 20 20 t #f))).
bbc0: 20 20 20 20 20 20 20 20 28 69 66 20 28 3c 20 28 (if (< (
bbd0: 6c 65 6e 67 74 68 20 72 75 6e 2d 6c 69 73 74 29 length run-list)
bbe0: 20 6d 61 78 2d 72 6f 77 2d 6c 65 6e 67 74 68 29 max-row-length)
bbf0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
bc00: 20 20 28 62 65 67 69 6e 20 20 0a 20 20 20 20 20 (begin .
bc10: 20 20 20 20 20 20 20 20 20 20 09 09 20 28 68 61 .. (ha
bc20: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 61 sh-table-set! ta
bc30: 72 67 65 74 2d 68 61 73 68 20 74 61 72 67 65 74 rget-hash target
bc40: 20 20 20 28 63 6f 6e 73 20 22 22 20 72 75 6e 2d (cons "" run-
bc50: 6c 69 73 74 29 29 0a 20 20 20 20 20 20 20 20 20 list)).
bc60: 20 20 20 20 20 20 09 09 20 28 6c 6f 6f 70 20 28 .. (loop (
bc70: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
bc80: 65 66 61 75 6c 74 20 74 61 72 67 65 74 2d 68 61 efault target-ha
bc90: 73 68 20 74 61 72 67 65 74 20 20 23 66 29 20 29 sh target #f) )
bca0: 29 29 29 29 20 0a 09 09 74 61 72 67 65 74 73 29 )))) ...targets)
bcb0: 0a 20 20 20 74 61 72 67 65 74 2d 68 61 73 68 29 . target-hash)
bcc0: 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 3a ..(define (test:
bcd0: 63 72 65 61 74 65 2d 74 61 72 67 65 74 2d 68 74 create-target-ht
bce0: 6d 6c 20 74 61 72 67 65 74 2d 68 61 73 68 20 6f ml target-hash o
bcf0: 75 70 20 61 72 65 61 2d 6e 61 6d 65 20 6c 69 6e up area-name lin
bd00: 6b 74 72 65 65 29 0a 20 20 28 6c 65 74 2a 20 28 ktree). (let* (
bd10: 28 74 61 72 67 65 74 73 20 28 68 61 73 68 2d 74 (targets (hash-t
bd20: 61 62 6c 65 2d 6b 65 79 73 20 74 61 72 67 65 74 able-keys target
bd30: 2d 68 61 73 68 29 29 0a 20 20 20 20 20 20 20 20 -hash)).
bd40: 20 28 6d 61 78 2d 72 6f 77 2d 6c 65 6e 67 74 68 (max-row-length
bd50: 20 28 74 65 73 74 3a 67 65 74 2d 6d 61 78 2d 72 (test:get-max-r
bd60: 75 6e 2d 63 6e 74 20 74 61 72 67 65 74 2d 68 61 un-cnt target-ha
bd70: 73 68 20 74 61 72 67 65 74 73 29 29 0a 20 20 20 sh targets)).
bd80: 20 20 20 20 20 20 28 70 61 64 2d 72 75 6e 73 2d (pad-runs-
bd90: 68 61 73 68 20 28 74 65 73 74 3a 70 61 64 2d 72 hash (test:pad-r
bda0: 75 6e 73 20 74 61 72 67 65 74 2d 68 61 73 68 20 uns target-hash
bdb0: 74 61 72 67 65 74 73 20 6d 61 78 2d 72 6f 77 2d targets max-row-
bdc0: 6c 65 6e 67 74 68 29 29 29 0a 20 20 20 28 73 3a length))). (s:
bdd0: 6f 75 74 70 75 74 2d 6e 65 77 0a 09 20 20 20 6f output-new.. o
bde0: 75 70 0a 09 20 20 20 28 73 3a 68 74 6d 6c 20 74 up.. (s:html t
bdf0: 65 73 74 73 3a 63 73 73 2d 6a 73 63 72 69 70 74 ests:css-jscript
be00: 2d 62 6c 6f 63 6b 20 28 74 65 73 74 73 3a 63 73 -block (tests:cs
be10: 73 2d 6a 73 63 72 69 70 74 2d 62 6c 6f 63 6b 2d s-jscript-block-
be20: 63 6f 6e 64 20 23 66 29 0a 0a 09 09 20 20 20 28 cond #f).... (
be30: 73 3a 74 69 74 6c 65 20 22 54 61 72 67 65 74 20 s:title "Target
be40: 56 69 65 77 20 22 20 61 72 65 61 2d 6e 61 6d 65 View " area-name
be50: 29 0a 09 09 20 20 20 28 73 3a 62 6f 64 79 0a 09 )... (s:body..
be60: 09 20 20 20 28 73 3a 68 31 20 22 54 61 72 67 65 . (s:h1 "Targe
be70: 74 20 56 69 65 77 20 22 20 61 72 65 61 2d 6e 61 t View " area-na
be80: 6d 65 29 0a 09 09 09 09 09 28 73 3a 74 61 62 6c me)......(s:tabl
be90: 65 20 27 69 64 20 22 4c 69 6e 6b 65 64 4c 69 73 e 'id "LinkedLis
bea0: 74 31 22 20 27 62 6f 72 64 65 72 20 22 31 22 20 t1" 'border "1"
beb0: 27 63 65 6c 6c 73 70 61 63 69 6e 67 20 30 0a 20 'cellspacing 0.
bec0: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 3a 74 (s:t
bed0: 72 20 27 63 6c 61 73 73 20 22 73 6f 6d 65 74 68 r 'class "someth
bee0: 69 6e 67 22 20 0a 20 20 20 20 20 20 20 20 20 20 ing" .
bef0: 20 20 20 20 20 28 73 3a 74 68 20 22 54 61 72 67 (s:th "Targ
bf00: 65 74 22 29 0a 09 09 09 09 09 09 09 09 28 73 3a et").........(s:
bf10: 74 68 20 27 63 6f 6c 73 70 61 6e 20 6d 61 78 2d th 'colspan max-
bf20: 72 6f 77 2d 6c 65 6e 67 74 68 20 22 52 75 6e 73 row-length "Runs
bf30: 22 29 29 20 20 20 20 20 20 20 20 20 20 20 20 20 "))
bf40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bf50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bf60: 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
bf70: 20 20 28 6c 65 74 2a 20 28 28 74 62 6c 20 28 6d (let* ((tbl (m
bf80: 61 70 20 28 6c 61 6d 62 64 61 20 28 74 61 72 67 ap (lambda (targ
bf90: 65 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 et).
bfa0: 20 20 20 20 20 20 20 20 20 20 28 73 3a 74 72 0a (s:tr.
bfb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bfc0: 20 20 20 20 20 20 28 73 3a 74 64 20 27 63 6c 61 (s:td 'cla
bfd0: 73 73 20 22 74 65 73 74 22 20 74 61 72 67 65 74 ss "test" target
bfe0: 29 0a 09 09 09 09 09 09 09 09 09 09 20 20 28 6c )........... (l
bff0: 65 74 2a 20 28 28 72 75 6e 73 20 20 28 68 61 73 et* ((runs (has
c000: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
c010: 75 6c 74 20 74 61 72 67 65 74 2d 68 61 73 68 20 ult target-hash
c020: 74 61 72 67 65 74 20 20 23 66 29 29 0a 09 09 09 target #f))....
c030: 09 09 09 09 09 09 09 09 09 09 09 20 28 72 65 73 ........... (res
c040: 74 2d 72 6f 77 20 28 6d 61 70 20 28 6c 61 6d 62 t-row (map (lamb
c050: 64 61 20 28 72 75 6e 29 0a 09 09 09 09 09 09 09 da (run)........
c060: 09 09 09 09 09 09 09 09 09 09 09 09 09 28 69 66 .............(if
c070: 20 28 65 71 75 61 6c 3f 20 72 75 6e 20 22 22 29 (equal? run "")
c080: 0a 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 ................
c090: 09 09 09 09 09 09 09 28 73 3a 74 64 20 72 75 6e .......(s:td run
c0a0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
c0b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c0c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i
c0d0: 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 28 f (file-exists?(
c0e0: 63 6f 6e 63 20 6c 69 6e 6b 74 72 65 65 20 22 2f conc linktree "/
c0f0: 22 20 74 61 72 67 65 74 20 22 2f 22 20 72 75 6e " target "/" run
c100: 20 29 29 0a 09 09 09 09 09 09 09 09 09 09 09 09 )).............
c110: 09 09 09 09 09 09 09 09 09 09 28 62 65 67 69 6e ..........(begin
c120: 20 0a 09 09 09 09 09 09 09 09 09 09 09 09 09 09 ...............
c130: 09 09 09 09 09 09 09 09 09 28 73 3a 74 64 20 0a .........(s:td .
c140: 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 ................
c150: 09 09 09 09 09 09 09 28 73 3a 61 20 27 68 72 65 .......(s:a 'hre
c160: 66 20 28 63 6f 6e 63 20 20 74 61 72 67 65 74 20 f (conc target
c170: 22 2f 22 20 72 75 6e 20 22 2f 72 75 6e 2e 68 74 "/" run "/run.ht
c180: 6d 6c 22 29 20 72 75 6e 29 29 29 29 29 29 0a 09 ml") run))))))..
c190: 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 ................
c1a0: 09 09 09 28 72 65 76 65 72 73 65 20 72 75 6e 73 ...(reverse runs
c1b0: 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 )))).
c1c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c1d0: 20 20 20 72 65 73 74 2d 72 6f 77 29 29 29 0a 20 rest-row))).
c1e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c1f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c200: 20 20 74 61 72 67 65 74 73 29 29 29 0a 20 20 20 targets))).
c210: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c220: 20 20 20 20 20 20 20 20 74 62 6c 29 29 29 29 29 tbl)))))
c230: 0a 20 20 20 20 20 20 20 20 20 20 28 63 6c 6f 73 . (clos
c240: 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 6f 75 e-output-port ou
c250: 70 29 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 p)))...(define (
c260: 74 65 73 74 73 3a 63 72 65 61 74 65 2d 68 74 6d tests:create-htm
c270: 6c 2d 74 72 65 65 2d 6f 6c 64 20 6f 75 74 66 29 l-tree-old outf)
c280: 0a 20 20 20 28 6c 65 74 2a 20 28 28 6c 6f 63 6b . (let* ((lock
c290: 66 69 6c 65 20 20 28 63 6f 6e 63 20 6f 75 74 66 file (conc outf
c2a0: 20 22 2e 6c 6f 63 6b 22 29 29 0a 09 20 28 72 75 ".lock")).. (ru
c2b0: 6e 73 2d 74 6f 2d 70 72 6f 63 65 73 73 20 27 28 ns-to-process '(
c2c0: 29 29 29 0a 20 20 20 20 28 69 66 20 28 63 6f 6d ))). (if (com
c2d0: 6d 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d mon:simple-file-
c2e0: 6c 6f 63 6b 20 6c 6f 63 6b 66 69 6c 65 29 0a 09 lock lockfile)..
c2f0: 28 6c 65 74 2a 20 28 28 6c 69 6e 6b 74 72 65 65 (let* ((linktree
c300: 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 69 (common:get-li
c310: 6e 6b 74 72 65 65 29 29 0a 09 20 20 20 20 20 20 nktree))..
c320: 20 28 6f 75 70 20 20 20 20 20 20 20 28 6f 70 65 (oup (ope
c330: 6e 2d 6f 75 74 70 75 74 2d 66 69 6c 65 20 28 6f n-output-file (o
c340: 72 20 6f 75 74 66 20 28 63 6f 6e 63 20 6c 69 6e r outf (conc lin
c350: 6b 74 72 65 65 20 22 2f 72 75 6e 73 2d 69 6e 64 ktree "/runs-ind
c360: 65 78 2e 68 74 6d 6c 22 29 29 29 29 0a 09 20 20 ex.html"))))..
c370: 20 20 20 20 20 28 61 72 65 61 2d 6e 61 6d 65 20 (area-name
c380: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 74 65 73 74 (common:get-test
c390: 73 75 69 74 65 2d 6e 61 6d 65 29 29 0a 09 20 20 suite-name))..
c3a0: 20 20 20 20 20 28 6b 65 79 73 20 20 20 20 20 20 (keys
c3b0: 28 72 6d 74 3a 67 65 74 2d 6b 65 79 73 29 29 0a (rmt:get-keys)).
c3c0: 09 20 20 20 20 20 20 20 28 6e 75 6d 6b 65 79 73 . (numkeys
c3d0: 20 20 20 28 6c 65 6e 67 74 68 20 6b 65 79 73 29 (length keys)
c3e0: 29 0a 09 20 20 20 20 20 20 20 28 72 75 6e 73 64 ).. (runsd
c3f0: 61 74 20 20 20 28 72 6d 74 3a 67 65 74 2d 72 75 at (rmt:get-ru
c400: 6e 73 20 22 25 22 20 23 66 20 23 66 20 28 6d 61 ns "%" #f #f (ma
c410: 70 20 28 6c 61 6d 62 64 61 20 28 78 29 28 6c 69 p (lambda (x)(li
c420: 73 74 20 78 20 22 25 22 29 29 20 6b 65 79 73 29 st x "%")) keys)
c430: 29 29 0a 09 20 20 20 20 20 20 20 28 68 65 61 64 )).. (head
c440: 65 72 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 er (vector-re
c450: 66 20 72 75 6e 73 64 61 74 20 30 29 29 0a 09 20 f runsdat 0))..
c460: 20 20 20 20 20 20 28 72 75 6e 73 20 20 20 20 20 (runs
c470: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e (vector-ref run
c480: 73 64 61 74 20 31 29 29 0a 09 20 20 20 20 20 20 sdat 1))..
c490: 20 28 72 75 6e 74 72 65 65 64 61 74 20 28 6d 61 (runtreedat (ma
c4a0: 70 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 09 p (lambda (x)...
c4b0: 09 09 20 20 28 74 65 73 74 73 3a 72 75 6e 2d 72 .. (tests:run-r
c4c0: 65 63 6f 72 64 2d 3e 74 65 73 74 2d 70 61 74 68 ecord->test-path
c4d0: 20 78 20 6e 75 6d 6b 65 79 73 29 29 0a 09 09 09 x numkeys))....
c4e0: 09 72 75 6e 73 29 29 0a 09 20 20 20 20 20 20 20 .runs))..
c4f0: 28 72 75 6e 73 2d 68 74 72 65 65 20 28 63 6f 6d (runs-htree (com
c500: 6d 6f 6e 3a 6c 69 73 74 2d 3e 68 74 72 65 65 20 mon:list->htree
c510: 72 75 6e 74 72 65 65 64 61 74 29 29 29 0a 09 20 runtreedat)))..
c520: 20 28 73 65 74 21 20 72 75 6e 73 2d 74 6f 2d 70 (set! runs-to-p
c530: 72 6f 63 65 73 73 20 72 75 6e 73 29 0a 09 20 20 rocess runs)..
c540: 28 73 3a 6f 75 74 70 75 74 2d 6e 65 77 0a 09 20 (s:output-new..
c550: 20 20 6f 75 70 0a 09 20 20 20 28 73 3a 68 74 6d oup.. (s:htm
c560: 6c 20 74 65 73 74 73 3a 63 73 73 2d 6a 73 63 72 l tests:css-jscr
c570: 69 70 74 2d 62 6c 6f 63 6b 0a 09 09 20 20 20 28 ipt-block... (
c580: 73 3a 74 69 74 6c 65 20 22 53 75 6d 6d 61 72 79 s:title "Summary
c590: 20 66 6f 72 20 22 20 61 72 65 61 2d 6e 61 6d 65 for " area-name
c5a0: 29 0a 09 09 20 20 20 28 73 3a 62 6f 64 79 20 27 )... (s:body '
c5b0: 6f 6e 6c 6f 61 64 20 22 61 64 64 45 76 65 6e 74 onload "addEvent
c5c0: 73 28 29 3b 22 0a 09 09 09 20 20 20 28 73 3a 68 s();".... (s:h
c5d0: 31 20 22 53 75 6d 6d 61 72 79 20 66 6f 72 20 22 1 "Summary for "
c5e0: 20 61 72 65 61 2d 6e 61 6d 65 29 0a 09 09 09 20 area-name)....
c5f0: 20 20 3b 3b 20 74 6f 70 20 6c 69 73 74 0a 09 09 ;; top list...
c600: 09 20 20 20 28 73 3a 75 6c 20 27 69 64 20 22 4c . (s:ul 'id "L
c610: 69 6e 6b 65 64 4c 69 73 74 31 22 20 27 63 6c 61 inkedList1" 'cla
c620: 73 73 20 22 4c 69 6e 6b 65 64 4c 69 73 74 22 0a ss "LinkedList".
c630: 09 09 09 09 20 28 73 3a 6c 69 0a 09 09 09 09 20 .... (s:li.....
c640: 20 22 52 75 6e 73 22 0a 09 09 09 09 20 20 28 63 "Runs"..... (c
c650: 6f 6d 6d 6f 6e 3a 68 74 72 65 65 2d 3e 68 74 6d ommon:htree->htm
c660: 6c 20 72 75 6e 73 2d 68 74 72 65 65 0a 09 09 09 l runs-htree....
c670: 09 09 09 20 20 20 20 20 20 27 28 29 0a 09 09 09 ... '()....
c680: 09 09 09 20 20 20 20 20 20 28 6c 61 6d 62 64 61 ... (lambda
c690: 20 28 78 20 70 29 0a 09 09 09 09 09 09 09 28 6c (x p)........(l
c6a0: 65 74 2a 20 28 28 74 61 72 67 2d 70 61 74 68 20 et* ((targ-path
c6b0: 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 (string-interspe
c6c0: 72 73 65 20 70 20 22 2f 22 29 29 0a 20 20 20 20 rse p "/")).
c6d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
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 28 66 75 6c 6c (full
c710: 2d 70 61 74 68 20 28 63 6f 6e 63 20 6c 69 6e 6b -path (conc link
c720: 74 72 65 65 20 22 2f 22 20 74 61 72 67 2d 70 61 tree "/" targ-pa
c730: 74 68 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 th)).
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 20 20 20 20
c770: 20 20 20 20 28 72 75 6e 2d 6e 61 6d 65 20 20 28 (run-name (
c780: 63 61 72 20 28 72 65 76 65 72 73 65 20 70 29 29 car (reverse p))
c790: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
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 28 69 66 (if
c7d0: 20 28 61 6e 64 20 28 63 6f 6d 6d 6f 6e 3a 66 69 (and (common:fi
c7e0: 6c 65 2d 65 78 69 73 74 73 3f 20 66 75 6c 6c 2d le-exists? full-
c7f0: 70 61 74 68 29 0a 20 20 20 20 20 20 20 20 20 20 path).
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 20 20 20 20 20 28 64 69 72 65 63 74 (direct
c840: 6f 72 79 3f 20 20 20 66 75 6c 6c 2d 70 61 74 68 ory? full-path
c850: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
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 20 20 20 28 66 69 6c 65 2d 77 72 69 74 65 (file-write
c8a0: 2d 61 63 63 65 73 73 3f 20 66 75 6c 6c 2d 70 61 -access? full-pa
c8b0: 74 68 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 th)).
c8c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
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 28 73 3a 61 20 72 75 6e 2d 6e 61 6d 65 (s:a run-name
c900: 20 27 68 72 65 66 20 28 63 6f 6e 63 20 74 61 72 'href (conc tar
c910: 67 2d 70 61 74 68 20 22 2f 72 75 6e 2d 73 75 6d g-path "/run-sum
c920: 6d 61 72 79 2e 68 74 6d 6c 22 29 29 0a 20 20 20 mary.html")).
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 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c960: 20 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 (begi
c970: 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 n.
c980: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c990: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c9a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c9b0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
c9c0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
c9d0: 72 74 2a 20 22 49 4e 46 4f 3a 20 43 61 6e 27 74 rt* "INFO: Can't
c9e0: 20 63 72 65 61 74 65 20 22 20 74 61 72 67 2d 70 create " targ-p
c9f0: 61 74 68 20 22 2f 72 75 6e 2d 73 75 6d 6d 61 72 ath "/run-summar
ca00: 79 2e 68 74 6d 6c 22 29 0a 20 20 20 20 20 20 20 y.html").
ca10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ca20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ca30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ca40: 20 20 20 20 20 20 20 20 20 28 63 6f 6e 63 20 72 (conc r
ca50: 75 6e 2d 6e 61 6d 65 20 22 20 28 4e 6f 74 20 61 un-name " (Not a
ca60: 62 6c 65 20 74 6f 20 63 72 65 61 74 65 20 73 75 ble to create su
ca70: 6d 6d 61 72 79 20 61 74 20 22 20 74 61 72 67 2d mmary at " targ-
ca80: 70 61 74 68 20 22 29 22 29 29 29 29 29 29 29 29 path ")"))))))))
ca90: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 63 ))). (c
caa0: 6c 6f 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 lose-output-port
cab0: 20 6f 75 70 29 0a 09 20 20 28 63 6f 6d 6d 6f 6e oup).. (common
cac0: 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 72 65 6c :simple-file-rel
cad0: 65 61 73 65 2d 6c 6f 63 6b 20 6c 6f 63 6b 66 69 ease-lock lockfi
cae0: 6c 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 le).
caf0: 20 20 20 0a 09 20 20 28 66 6f 72 2d 65 61 63 68 .. (for-each
cb00: 0a 09 20 20 20 28 6c 61 6d 62 64 61 20 28 72 75 .. (lambda (ru
cb10: 6e 29 0a 09 20 20 20 20 20 28 6c 65 74 2a 20 28 n).. (let* (
cb20: 28 74 65 73 74 2d 73 75 62 70 61 74 68 20 28 74 (test-subpath (t
cb30: 65 73 74 73 3a 72 75 6e 2d 72 65 63 6f 72 64 2d ests:run-record-
cb40: 3e 74 65 73 74 2d 70 61 74 68 20 72 75 6e 20 6e >test-path run n
cb50: 75 6d 6b 65 79 73 29 29 0a 09 09 20 20 20 20 28 umkeys))... (
cb60: 72 75 6e 2d 69 64 20 20 20 20 20 20 20 28 64 62 run-id (db
cb70: 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 :get-value-by-he
cb80: 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 ader run header
cb90: 22 69 64 22 29 29 0a 20 20 20 20 20 20 20 20 20 "id")).
cba0: 20 20 20 20 20 20 20 20 20 20 20 28 72 75 6e 2d (run-
cbb0: 64 69 72 20 20 20 20 20 20 28 74 65 73 74 73 3a dir (tests:
cbc0: 72 75 6e 2d 72 65 63 6f 72 64 2d 3e 74 65 73 74 run-record->test
cbd0: 2d 70 61 74 68 20 72 75 6e 20 6e 75 6d 6b 65 79 -path run numkey
cbe0: 73 29 29 0a 09 09 20 20 20 20 28 74 65 73 74 2d s))... (test-
cbf0: 64 61 74 73 20 20 20 20 28 72 6d 74 3a 67 65 74 dats (rmt:get
cc00: 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 0a 09 -tests-for-run..
cc10: 09 09 09 20 20 20 72 75 6e 2d 69 64 0a 20 20 20 ... run-id.
cc20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cc30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cc40: 22 25 2f 22 20 20 20 20 20 20 20 3b 3b 20 74 65 "%/" ;; te
cc50: 73 74 6e 61 6d 65 70 61 74 74 0a 09 09 09 09 20 stnamepatt.....
cc60: 20 20 27 28 29 20 20 20 20 20 20 20 20 3b 3b 20 '() ;;
cc70: 73 74 61 74 65 73 0a 09 09 09 09 20 20 20 27 28 states..... '(
cc80: 29 20 20 20 20 20 20 20 20 3b 3b 20 73 74 61 74 ) ;; stat
cc90: 75 73 65 73 0a 09 09 09 09 20 20 20 23 66 20 20 uses..... #f
cca0: 20 20 20 20 20 20 20 3b 3b 20 6f 66 66 73 65 74 ;; offset
ccb0: 0a 09 09 09 09 20 20 20 23 66 20 20 20 20 20 20 ..... #f
ccc0: 20 20 20 3b 3b 20 6e 75 6d 2d 74 6f 2d 67 65 74 ;; num-to-get
ccd0: 0a 09 09 09 09 20 20 20 23 66 20 20 20 20 20 20 ..... #f
cce0: 20 20 20 3b 3b 20 68 69 64 65 2f 6e 6f 74 2d 68 ;; hide/not-h
ccf0: 69 64 65 0a 09 09 09 09 20 20 20 23 66 20 20 20 ide..... #f
cd00: 20 20 20 20 20 20 3b 3b 20 73 6f 72 74 2d 62 79 ;; sort-by
cd10: 0a 09 09 09 09 20 20 20 23 66 20 20 20 20 20 20 ..... #f
cd20: 20 20 20 3b 3b 20 73 6f 72 74 2d 6f 72 64 65 72 ;; sort-order
cd30: 0a 09 09 09 09 20 20 20 23 66 20 20 20 20 20 20 ..... #f
cd40: 20 20 20 3b 3b 20 27 73 68 6f 72 74 6c 69 73 74 ;; 'shortlist
cd50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cd60: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 71 72 ;; qr
cd70: 79 74 79 70 65 0a 20 20 20 20 20 20 20 20 20 20 ytype.
cd80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cd90: 20 20 20 20 20 20 20 20 20 30 20 20 20 20 20 20 0
cda0: 20 20 20 3b 3b 20 6c 61 73 74 20 75 70 64 61 74 ;; last updat
cdb0: 65 0a 09 09 09 09 20 20 20 23 66 29 29 0a 20 20 e..... #f)).
cdc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cdd0: 20 20 28 74 65 73 74 73 2d 74 72 65 65 2d 64 61 (tests-tree-da
cde0: 74 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 t (map (lambda (
cdf0: 74 65 73 74 2d 64 61 74 29 0a 20 20 20 20 20 20 test-dat).
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 20 20 20 20 20 20 20 20 20
ce20: 20 20 20 3b 3b 20 28 74 65 73 74 73 3a 72 75 6e ;; (tests:run
ce30: 2d 72 65 63 6f 72 64 2d 3e 74 65 73 74 2d 70 61 -record->test-pa
ce40: 74 68 20 78 20 6e 75 6d 6b 65 79 73 29 29 0a 20 th x numkeys)).
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 28 6c 65 74 2a 20 28 28 (let* ((
ce80: 74 65 73 74 2d 6e 61 6d 65 20 20 28 64 62 3a 74 test-name (db:t
ce90: 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 est-get-testname
cea0: 20 74 65 73 74 2d 64 61 74 29 29 0a 20 20 20 20 test-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 20 20 20 28 69 74 65 (ite
cee0: 6d 2d 70 61 74 68 20 20 28 64 62 3a 74 65 73 74 m-path (db:test
cef0: 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 -get-item-path t
cf00: 65 73 74 2d 64 61 74 29 29 0a 20 20 20 20 20 20 est-dat)).
cf10: 20 20 20 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 28 66 75 6c 6c 2d (full-
cf40: 6e 61 6d 65 20 20 28 64 62 3a 74 65 73 74 2d 6d name (db:test-m
cf50: 61 6b 65 2d 66 75 6c 6c 2d 6e 61 6d 65 20 74 65 ake-full-name te
cf60: 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 st-name item-pat
cf70: 68 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 h)).
cf80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cf90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cfa0: 20 20 20 20 28 70 61 74 68 2d 70 61 72 74 73 20 (path-parts
cfb0: 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 66 75 (string-split fu
cfc0: 6c 6c 2d 6e 61 6d 65 29 29 29 0a 20 20 20 20 20 ll-name))).
cfd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cfe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cff0: 20 20 20 20 20 20 70 61 74 68 2d 70 61 72 74 73 path-parts
d000: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
d010: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d020: 20 20 20 20 20 20 20 20 20 20 74 65 73 74 2d 64 test-d
d030: 61 74 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 ats)).
d040: 20 20 20 20 20 20 20 20 20 20 28 74 65 73 74 73 (tests
d050: 2d 68 74 72 65 65 20 28 63 6f 6d 6d 6f 6e 3a 6c -htree (common:l
d060: 69 73 74 2d 3e 68 74 72 65 65 20 74 65 73 74 73 ist->htree tests
d070: 2d 74 72 65 65 2d 64 61 74 29 29 0a 20 20 20 20 -tree-dat)).
d080: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d090: 28 68 74 6d 6c 2d 64 69 72 20 20 20 20 28 63 6f (html-dir (co
d0a0: 6e 63 20 6c 69 6e 6b 74 72 65 65 20 22 2f 22 20 nc linktree "/"
d0b0: 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 (string-interspe
d0c0: 72 73 65 20 72 75 6e 2d 64 69 72 20 22 2f 22 29 rse run-dir "/")
d0d0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
d0e0: 20 20 20 20 20 20 20 28 68 74 6d 6c 2d 70 61 74 (html-pat
d0f0: 68 20 20 20 28 63 6f 6e 63 20 68 74 6d 6c 2d 64 h (conc html-d
d100: 69 72 20 22 2f 72 75 6e 2d 73 75 6d 6d 61 72 79 ir "/run-summary
d110: 2e 68 74 6d 6c 22 29 29 0a 20 20 20 20 20 20 20 .html")).
d120: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6f 75 (ou
d130: 70 20 20 20 20 20 20 20 20 20 28 69 66 20 28 61 p (if (a
d140: 6e 64 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d nd (common:file-
d150: 65 78 69 73 74 73 3f 20 68 74 6d 6c 2d 64 69 72 exists? html-dir
d160: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
d170: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d180: 20 20 20 20 20 20 20 20 20 20 20 20 28 64 69 72 (dir
d190: 65 63 74 6f 72 79 3f 20 20 20 68 74 6d 6c 2d 64 ectory? html-d
d1a0: 69 72 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ir).
d1b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d1c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 66 (f
d1d0: 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 73 73 ile-write-access
d1e0: 3f 20 68 74 6d 6c 2d 64 69 72 29 29 0a 20 20 20 ? html-dir)).
d1f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d200: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d210: 20 20 28 6f 70 65 6e 2d 6f 75 74 70 75 74 2d 66 (open-output-f
d220: 69 6c 65 20 20 68 74 6d 6c 2d 70 61 74 68 29 0a ile html-path).
d230: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d240: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d250: 20 20 20 20 20 23 66 29 29 29 0a 20 20 20 20 20 #f))).
d260: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 28 70 72 ;; (pr
d270: 69 6e 74 20 22 72 75 6e 2d 64 69 72 3a 20 22 20 int "run-dir: "
d280: 72 75 6e 2d 64 69 72 20 22 2c 20 74 65 73 74 73 run-dir ", tests
d290: 2d 74 72 65 65 2d 64 61 74 3a 20 22 20 74 65 73 -tree-dat: " tes
d2a0: 74 73 2d 74 72 65 65 2d 64 61 74 29 0a 20 20 20 ts-tree-dat).
d2b0: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
d2c0: 6f 75 70 0a 20 20 20 20 20 20 20 20 20 20 20 20 oup.
d2d0: 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 (begin.
d2e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d2f0: 20 20 20 28 73 3a 6f 75 74 70 75 74 2d 6e 65 77 (s:output-new
d300: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
d310: 20 20 20 20 20 20 20 6f 75 70 0a 20 20 20 20 20 oup.
d320: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d330: 20 28 73 3a 68 74 6d 6c 20 74 65 73 74 73 3a 63 (s:html tests:c
d340: 73 73 2d 6a 73 63 72 69 70 74 2d 62 6c 6f 63 6b ss-jscript-block
d350: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
d360: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
d370: 73 3a 74 69 74 6c 65 20 22 53 75 6d 6d 61 72 79 s:title "Summary
d380: 20 66 6f 72 20 22 20 61 72 65 61 2d 6e 61 6d 65 for " area-name
d390: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
d3a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d3b0: 28 73 3a 62 6f 64 79 20 27 6f 6e 6c 6f 61 64 20 (s:body 'onload
d3c0: 22 61 64 64 45 76 65 6e 74 73 28 29 3b 22 0a 20 "addEvents();".
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 20 20 20 20 28 73 3a 68 31 20 22 53 75 6d 6d (s:h1 "Summ
d400: 61 72 79 20 66 6f 72 20 22 20 28 73 74 72 69 6e ary for " (strin
d410: 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 72 75 g-intersperse ru
d420: 6e 2d 64 69 72 20 22 2f 22 29 29 0a 20 20 20 20 n-dir "/")).
d430: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d440: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d450: 20 20 3b 3b 20 74 6f 70 20 6c 69 73 74 0a 20 20 ;; top list.
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 20 20 20 20 20
d480: 20 20 20 20 28 73 3a 75 6c 20 27 69 64 20 22 4c (s:ul 'id "L
d490: 69 6e 6b 65 64 4c 69 73 74 31 22 20 27 63 6c 61 inkedList1" 'cla
d4a0: 73 73 20 22 4c 69 6e 6b 65 64 4c 69 73 74 22 0a ss "LinkedList".
d4b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
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 28 73 3a 6c (s:l
d4e0: 69 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 i.
d4f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d500: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 22 "
d510: 54 65 73 74 73 22 0a 20 20 20 20 20 20 20 20 20 Tests".
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 28 63 6f 6d 6d 6f 6e 3a 68 74 72 65 (common:htre
d550: 65 2d 3e 68 74 6d 6c 20 74 65 73 74 73 2d 68 74 e->html tests-ht
d560: 72 65 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 ree.
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 20 20 20 20 20 20 20
d590: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d5a0: 20 20 20 20 20 27 28 29 0a 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 20 20 20 20 20 20
d5e0: 20 20 20 20 20 20 20 20 20 20 28 6c 61 6d 62 64 (lambd
d5f0: 61 20 28 78 20 70 29 0a 20 20 20 20 20 20 20 20 a (x p).
d600: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
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 28 6c 65 74 2a (let*
d640: 20 28 28 74 61 72 67 2d 70 61 74 68 20 28 73 74 ((targ-path (st
d650: 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
d660: 20 70 20 22 2f 22 29 29 0a 20 20 20 20 20 20 20 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: 20 20 20 28 74 65 73 74 2d 6e 61 6d 65 20 28 63 (test-name (c
d6c0: 61 72 20 70 29 29 0a 20 20 20 20 20 20 20 20 20 ar p)).
d6d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d6e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
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 28 69 74 65 6d 2d 70 61 74 68 20 3b 3b 20 28 (item-path ;; (
d720: 69 66 20 28 3e 20 28 6c 65 6e 67 74 68 20 70 29 if (> (length p)
d730: 20 32 29 20 3b 3b 20 74 65 73 74 2d 6e 61 6d 65 2) ;; test-name
d740: 20 2b 20 72 75 6e 2d 6e 61 6d 65 0a 20 20 20 20 + run-name.
d750: 20 20 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 28 73 74 72 69 6e 67 2d 69 (string-i
d7a0: 6e 74 65 72 73 70 65 72 73 65 20 70 20 22 2f 22 ntersperse p "/"
d7b0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
d7c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
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 28 66 75 (fu
d800: 6c 6c 2d 74 61 72 67 20 28 63 6f 6e 63 20 68 74 ll-targ (conc ht
d810: 6d 6c 2d 64 69 72 20 22 2f 22 20 74 61 72 67 2d ml-dir "/" targ-
d820: 70 61 74 68 29 29 0a 20 20 20 20 20 20 20 20 20 path)).
d830: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d840: 20 20 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 28 73 74 64 2d 66 69 6c 65 20 20 28 63 6f 6e (std-file (con
d880: 63 20 66 75 6c 6c 2d 74 61 72 67 20 22 2f 74 65 c full-targ "/te
d890: 73 74 2d 73 75 6d 6d 61 72 79 2e 68 74 6d 6c 22 st-summary.html"
d8a0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
d8b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d8c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
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 28 61 6c (al
d8f0: 74 2d 66 69 6c 65 20 20 28 63 6f 6e 63 20 66 75 t-file (conc fu
d900: 6c 6c 2d 74 61 72 67 20 22 2f 6d 65 67 61 74 65 ll-targ "/megate
d910: 73 74 2d 72 6f 6c 6c 75 70 2d 22 20 74 65 73 74 st-rollup-" test
d920: 2d 6e 61 6d 65 20 22 2e 68 74 6d 6c 22 29 29 0a -name ".html")).
d930: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d940: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
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 28 68 74 6d 6c 2d (html-
d980: 66 69 6c 65 20 28 69 66 20 28 63 6f 6d 6d 6f 6e file (if (common
d990: 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 61 6c :file-exists? al
d9a0: 74 2d 66 69 6c 65 29 0a 20 20 20 20 20 20 20 20 t-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 61 6c 74 2d 66 69 6c 65 0a 20 20 20 20 20 20 alt-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 20 20 20 20 20 20 20 20 20
da60: 20 20 20 73 74 64 2d 66 69 6c 65 29 29 0a 20 20 std-file)).
da70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
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 28 72 75 6e 2d 6e 61 6d (run-nam
dac0: 65 20 20 28 63 61 72 20 28 72 65 76 65 72 73 65 e (car (reverse
dad0: 20 70 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 p)))).
dae0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
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 28 69 66 20 (if
db20: 28 61 6e 64 20 28 6e 6f 74 20 28 63 6f 6d 6d 6f (and (not (commo
db30: 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 66 n:file-exists? f
db40: 75 6c 6c 2d 74 61 72 67 29 29 0a 20 20 20 20 20 ull-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 28 64 69 72 65 63 74 (direct
dba0: 6f 72 79 3f 20 66 75 6c 6c 2d 74 61 72 67 29 0a ory? full-targ).
dbb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
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 28 66 (f
dc00: 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 73 73 ile-write-access
dc10: 3f 20 66 75 6c 6c 2d 74 61 72 67 29 29 0a 20 20 ? full-targ)).
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 28 74 65 73 74 73 3a 73 75 (tests:su
dc70: 6d 6d 61 72 69 7a 65 2d 74 65 73 74 20 0a 20 20 mmarize-test .
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 20 20 20 20 20 20 20
dcc0: 20 20 20 20 20 20 20 20 72 75 6e 2d 69 64 20 0a run-id .
dcd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dce0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
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 28 72 6d 74 3a 67 (rmt:g
dd20: 65 74 2d 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 et-test-id run-i
dd30: 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d d test-name item
dd40: 2d 70 61 74 68 29 29 29 0a 20 20 20 20 20 20 20 -path))).
dd50: 20 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 28 69 (i
dd90: 66 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 f (common:file-e
dda0: 78 69 73 74 73 3f 20 66 75 6c 6c 2d 74 61 72 67 xists? full-targ
ddb0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
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 28 73 3a 61 20 (s:a
de00: 72 75 6e 2d 6e 61 6d 65 20 27 68 72 65 66 20 68 run-name 'href h
de10: 74 6d 6c 2d 66 69 6c 65 29 0a 20 20 20 20 20 20 tml-file).
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 20 20 20 20 20 20 20 20 20 20 20 20
de60: 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 (begin.
de70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
de80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
de90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dea0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
deb0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
dec0: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
ded0: 2d 70 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 63 -port* "ERROR: c
dee0: 61 6e 27 74 20 61 63 63 65 73 73 20 22 20 66 75 an't access " fu
def0: 6c 6c 2d 74 61 72 67 29 0a 20 20 20 20 20 20 20 ll-targ).
df00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
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 28 63 6f 6e 63 20 22 4e 6f 20 73 75 (conc "No su
df50: 6d 6d 61 72 79 20 66 6f 72 20 22 20 72 75 6e 2d mmary for " run-
df60: 6e 61 6d 65 29 29 29 29 29 0a 20 20 20 20 20 20 name))))).
df70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
df80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
df90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dfa0: 20 20 20 20 20 20 20 20 20 20 20 29 29 29 29 29 )))))
dfb0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
dfc0: 20 20 20 20 20 20 20 28 63 6c 6f 73 65 2d 6f 75 (close-ou
dfd0: 74 70 75 74 2d 70 6f 72 74 20 6f 75 70 29 29 29 tput-port oup)))
dfe0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 72 75 )). ru
dff0: 6e 73 29 0a 20 20 20 20 20 20 20 20 20 20 23 74 ns). #t
e000: 29 0a 09 23 66 29 29 29 0a 0a 0a 0a 0a 0a 0a 0a )..#f)))........
e010: 3b 3b 20 43 48 45 43 4b 20 2d 20 57 41 53 20 54 ;; CHECK - WAS T
e020: 48 49 53 20 41 44 44 45 44 20 4f 52 20 52 45 4d HIS ADDED OR REM
e030: 4f 56 45 44 3f 20 4d 41 4e 55 41 4c 20 4d 45 52 OVED? MANUAL MER
e040: 47 45 20 57 49 54 48 20 41 50 49 20 53 54 55 46 GE WITH API STUF
e050: 46 21 21 21 0a 3b 3b 0a 3b 3b 20 67 65 74 20 61 F!!!.;;.;; get a
e060: 20 70 72 65 74 74 79 20 74 61 62 6c 65 20 74 6f pretty table to
e070: 20 73 75 6d 6d 61 72 69 7a 65 20 73 74 65 70 73 summarize steps
e080: 0a 3b 3b 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 .;;.;; (define (
e090: 64 63 6f 6d 6d 6f 6e 3a 70 72 6f 63 65 73 73 2d dcommon:process-
e0a0: 73 74 65 70 73 2d 74 61 62 6c 65 20 73 74 65 70 steps-table step
e0b0: 73 29 3b 3b 20 64 62 20 74 65 73 74 2d 69 64 20 s);; db test-id
e0c0: 23 21 6b 65 79 20 28 77 6f 72 6b 2d 61 72 65 61 #!key (work-area
e0d0: 20 23 66 29 29 0a 28 64 65 66 69 6e 65 20 28 74 #f)).(define (t
e0e0: 65 73 74 73 3a 70 72 6f 63 65 73 73 2d 73 74 65 ests:process-ste
e0f0: 70 73 2d 74 61 62 6c 65 20 73 74 65 70 73 29 3b ps-table steps);
e100: 3b 20 64 62 20 74 65 73 74 2d 69 64 20 23 21 6b ; db test-id #!k
e110: 65 79 20 28 77 6f 72 6b 2d 61 72 65 61 20 23 66 ey (work-area #f
e120: 29 29 0a 3b 3b 20 20 28 6c 65 74 20 28 28 73 74 )).;; (let ((st
e130: 65 70 73 20 20 20 28 64 62 3a 67 65 74 2d 73 74 eps (db:get-st
e140: 65 70 73 2d 66 6f 72 2d 74 65 73 74 20 64 62 20 eps-for-test db
e150: 74 65 73 74 2d 69 64 20 77 6f 72 6b 2d 61 72 65 test-id work-are
e160: 61 3a 20 77 6f 72 6b 2d 61 72 65 61 29 29 29 0a a: work-area))).
e170: 20 20 20 20 3b 3b 20 6f 72 67 61 6e 69 73 65 20 ;; organise
e180: 74 68 65 20 73 74 65 70 73 20 66 6f 72 20 62 65 the steps for be
e190: 74 74 65 72 20 72 65 61 64 61 62 69 6c 69 74 79 tter readability
e1a0: 0a 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 20 . (let ((res
e1b0: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
e1c0: 29 29 29 0a 20 20 20 20 20 20 28 66 6f 72 2d 65 ))). (for-e
e1d0: 61 63 68 20 0a 20 20 20 20 20 20 20 28 6c 61 6d ach . (lam
e1e0: 62 64 61 20 28 73 74 65 70 29 0a 09 20 28 64 65 bda (step).. (de
e1f0: 62 75 67 3a 70 72 69 6e 74 20 36 20 2a 64 65 66 bug:print 6 *def
e200: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
e210: 73 74 65 70 3d 22 20 73 74 65 70 29 0a 09 20 28 step=" step).. (
e220: 6c 65 74 20 28 28 72 65 63 6f 72 64 20 28 68 61 let ((record (ha
e230: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
e240: 61 75 6c 74 20 0a 09 09 09 72 65 73 20 0a 09 09 ault ....res ...
e250: 09 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 .(tdb:step-get-s
e260: 74 65 70 6e 61 6d 65 20 73 74 65 70 29 0a 09 09 tepname step)...
e270: 09 3b 3b 20 20 20 20 20 20 20 20 20 20 20 30 20 .;; 0
e280: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e290: 20 20 20 20 20 31 20 20 20 20 32 20 20 20 20 33 1 2 3
e2a0: 20 20 20 20 20 20 20 34 20 20 20 20 20 20 20 20 4
e2b0: 20 35 20 20 20 20 20 20 20 36 20 20 20 20 20 20 5 6
e2c0: 20 37 0a 09 09 09 3b 3b 20 20 20 20 20 20 20 20 7....;;
e2d0: 73 74 65 70 6e 61 6d 65 20 20 20 20 20 20 20 20 stepname
e2e0: 20 20 20 20 20 20 20 20 73 74 61 72 74 20 65 6e start en
e2f0: 64 20 73 74 61 74 75 73 20 44 75 72 61 74 69 6f d status Duratio
e300: 6e 20 20 4c 6f 67 66 69 6c 65 20 43 6f 6d 6d 65 n Logfile Comme
e310: 6e 74 20 20 66 69 72 73 74 2d 69 64 0a 09 09 09 nt first-id....
e320: 28 76 65 63 74 6f 72 20 28 74 64 62 3a 73 74 65 (vector (tdb:ste
e330: 70 2d 67 65 74 2d 73 74 65 70 6e 61 6d 65 20 73 p-get-stepname s
e340: 74 65 70 29 20 22 22 20 20 20 22 22 20 22 22 20 tep) "" "" ""
e350: 20 20 20 20 22 22 20 20 20 20 20 20 20 20 22 22 "" ""
e360: 20 20 20 20 20 22 22 20 20 20 20 20 20 20 23 66 "" #f
e370: 29 29 29 29 0a 09 20 20 20 28 64 65 62 75 67 3a )))).. (debug:
e380: 70 72 69 6e 74 20 36 20 2a 64 65 66 61 75 6c 74 print 6 *default
e390: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 65 63 6f -log-port* "reco
e3a0: 72 64 28 62 65 66 6f 72 65 29 20 3d 20 22 20 72 rd(before) = " r
e3b0: 65 63 6f 72 64 20 0a 09 09 09 22 5c 6e 69 64 3a ecord ...."\nid:
e3c0: 20 20 20 20 20 20 20 22 20 28 74 64 62 3a 73 74 " (tdb:st
e3d0: 65 70 2d 67 65 74 2d 69 64 20 73 74 65 70 29 0a ep-get-id step).
e3e0: 09 09 09 22 5c 6e 73 74 65 70 6e 61 6d 65 3a 20 ..."\nstepname:
e3f0: 22 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d " (tdb:step-get-
e400: 73 74 65 70 6e 61 6d 65 20 73 74 65 70 29 0a 09 stepname step)..
e410: 09 09 22 5c 6e 73 74 61 74 65 3a 20 20 20 20 22 .."\nstate: "
e420: 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 (tdb:step-get-s
e430: 74 61 74 65 20 73 74 65 70 29 0a 09 09 09 22 5c tate step)...."\
e440: 6e 73 74 61 74 75 73 3a 20 20 20 22 20 28 74 64 nstatus: " (td
e450: 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 61 74 75 b:step-get-statu
e460: 73 20 73 74 65 70 29 0a 09 09 09 22 5c 6e 74 69 s step)...."\nti
e470: 6d 65 3a 20 20 20 20 20 22 20 28 74 64 62 3a 73 me: " (tdb:s
e480: 74 65 70 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 tep-get-event_ti
e490: 6d 65 20 73 74 65 70 29 29 0a 09 20 20 20 28 69 me step)).. (i
e4a0: 66 20 28 6e 6f 74 20 28 76 65 63 74 6f 72 2d 72 f (not (vector-r
e4b0: 65 66 20 72 65 63 6f 72 64 20 37 29 29 28 76 65 ef record 7))(ve
e4c0: 63 74 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 64 ctor-set! record
e4d0: 20 37 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 7 (tdb:step-get
e4e0: 2d 69 64 20 73 74 65 70 29 29 29 20 3b 3b 20 64 -id step))) ;; d
e4f0: 6f 20 6e 6f 74 20 63 6c 6f 62 62 65 72 20 74 68 o not clobber th
e500: 65 20 69 64 20 69 66 20 70 72 65 76 69 6f 75 73 e id if previous
e510: 6c 79 20 73 65 74 0a 09 20 20 20 28 63 61 73 65 ly set.. (case
e520: 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c (string->symbol
e530: 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 (tdb:step-get-s
e540: 74 61 74 65 20 73 74 65 70 29 29 0a 09 20 20 20 tate step))..
e550: 20 20 28 28 73 74 61 72 74 29 28 76 65 63 74 6f ((start)(vecto
e560: 72 2d 73 65 74 21 20 72 65 63 6f 72 64 20 31 20 r-set! record 1
e570: 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 65 76 (tdb:step-get-ev
e580: 65 6e 74 5f 74 69 6d 65 20 73 74 65 70 29 29 0a ent_time step)).
e590: 09 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 73 . (vector-s
e5a0: 65 74 21 20 72 65 63 6f 72 64 20 33 20 28 69 66 et! record 3 (if
e5b0: 20 28 65 71 75 61 6c 3f 20 28 76 65 63 74 6f 72 (equal? (vector
e5c0: 2d 72 65 66 20 72 65 63 6f 72 64 20 33 29 20 22 -ref record 3) "
e5d0: 22 29 0a 09 09 09 09 09 28 74 64 62 3a 73 74 65 ")......(tdb:ste
e5e0: 70 2d 67 65 74 2d 73 74 61 74 75 73 20 73 74 65 p-get-status ste
e5f0: 70 29 29 29 0a 09 20 20 20 20 20 20 28 69 66 20 p))).. (if
e600: 28 3e 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 (> (string-lengt
e610: 68 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d h (tdb:step-get-
e620: 6c 6f 67 66 69 6c 65 20 73 74 65 70 29 29 0a 09 logfile step))..
e630: 09 20 20 20 20 20 30 29 0a 09 09 20 20 28 76 65 . 0)... (ve
e640: 63 74 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 64 ctor-set! record
e650: 20 35 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 5 (tdb:step-get
e660: 2d 6c 6f 67 66 69 6c 65 20 73 74 65 70 29 29 29 -logfile step)))
e670: 29 0a 09 20 20 20 20 20 28 28 65 6e 64 29 20 20 ).. ((end)
e680: 0a 09 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d .. (vector-
e690: 73 65 74 21 20 72 65 63 6f 72 64 20 32 20 28 61 set! record 2 (a
e6a0: 6e 79 2d 3e 6e 75 6d 62 65 72 20 28 74 64 62 3a ny->number (tdb:
e6b0: 73 74 65 70 2d 67 65 74 2d 65 76 65 6e 74 5f 74 step-get-event_t
e6c0: 69 6d 65 20 73 74 65 70 29 29 29 0a 09 20 20 20 ime step)))..
e6d0: 20 20 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 (vector-set!
e6e0: 72 65 63 6f 72 64 20 33 20 28 74 64 62 3a 73 74 record 3 (tdb:st
e6f0: 65 70 2d 67 65 74 2d 73 74 61 74 75 73 20 73 74 ep-get-status st
e700: 65 70 29 29 0a 09 20 20 20 20 20 20 28 76 65 63 ep)).. (vec
e710: 74 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 64 20 tor-set! record
e720: 34 20 28 6c 65 74 20 28 28 73 74 61 72 74 74 20 4 (let ((startt
e730: 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 20 28 76 65 (any->number (ve
e740: 63 74 6f 72 2d 72 65 66 20 72 65 63 6f 72 64 20 ctor-ref record
e750: 31 29 29 29 0a 09 09 09 09 09 20 20 28 65 6e 64 1)))...... (end
e760: 74 20 20 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 t (any->number
e770: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 65 63 (vector-ref rec
e780: 6f 72 64 20 32 29 29 29 29 0a 09 09 09 09 20 20 ord 2)))).....
e790: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
e7a0: 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 4 *default-log-
e7b0: 70 6f 72 74 2a 20 22 72 65 63 6f 72 64 5b 31 5d port* "record[1]
e7c0: 3d 22 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 =" (vector-ref r
e7d0: 65 63 6f 72 64 20 31 29 20 0a 09 09 09 09 09 09 ecord 1) .......
e7e0: 20 20 20 22 2c 20 73 74 61 72 74 74 3d 22 20 73 ", startt=" s
e7f0: 74 61 72 74 74 20 22 2c 20 65 6e 64 74 3d 22 20 tartt ", endt="
e800: 65 6e 64 74 0a 09 09 09 09 09 09 20 20 20 22 2c endt....... ",
e810: 20 67 65 74 2d 73 74 61 74 75 73 3a 20 22 20 28 get-status: " (
e820: 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 61 tdb:step-get-sta
e830: 74 75 73 20 73 74 65 70 29 29 0a 09 09 09 09 20 tus step)).....
e840: 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 6e (if (and (n
e850: 75 6d 62 65 72 3f 20 73 74 61 72 74 74 29 28 6e umber? startt)(n
e860: 75 6d 62 65 72 3f 20 65 6e 64 74 29 29 0a 09 09 umber? endt))...
e870: 09 09 09 20 20 28 73 65 63 6f 6e 64 73 2d 3e 68 ... (seconds->h
e880: 72 2d 6d 69 6e 2d 73 65 63 20 28 2d 20 65 6e 64 r-min-sec (- end
e890: 74 20 73 74 61 72 74 74 29 29 20 22 2d 31 22 29 t startt)) "-1")
e8a0: 29 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 3e )).. (if (>
e8b0: 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 (string-length
e8c0: 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 6c 6f (tdb:step-get-lo
e8d0: 67 66 69 6c 65 20 73 74 65 70 29 29 0a 09 09 20 gfile step))...
e8e0: 20 20 20 20 30 29 0a 09 09 20 20 28 76 65 63 74 0)... (vect
e8f0: 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 64 20 35 or-set! record 5
e900: 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 6c (tdb:step-get-l
e910: 6f 67 66 69 6c 65 20 73 74 65 70 29 29 29 0a 09 ogfile step)))..
e920: 20 20 20 20 20 20 28 69 66 20 28 3e 20 28 73 74 (if (> (st
e930: 72 69 6e 67 2d 6c 65 6e 67 74 68 20 28 74 64 62 ring-length (tdb
e940: 3a 73 74 65 70 2d 67 65 74 2d 63 6f 6d 6d 65 6e :step-get-commen
e950: 74 20 73 74 65 70 29 29 0a 09 09 20 20 20 20 20 t step))...
e960: 30 29 0a 09 09 20 20 28 76 65 63 74 6f 72 2d 73 0)... (vector-s
e970: 65 74 21 20 72 65 63 6f 72 64 20 36 20 28 74 64 et! record 6 (td
e980: 62 3a 73 74 65 70 2d 67 65 74 2d 63 6f 6d 6d 65 b:step-get-comme
e990: 6e 74 20 73 74 65 70 29 29 29 29 0a 09 20 20 20 nt step))))..
e9a0: 20 20 28 65 6c 73 65 0a 09 20 20 20 20 20 20 28 (else.. (
e9b0: 76 65 63 74 6f 72 2d 73 65 74 21 20 72 65 63 6f vector-set! reco
e9c0: 72 64 20 32 20 28 74 64 62 3a 73 74 65 70 2d 67 rd 2 (tdb:step-g
e9d0: 65 74 2d 73 74 61 74 65 20 73 74 65 70 29 29 0a et-state step)).
e9e0: 09 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 73 . (vector-s
e9f0: 65 74 21 20 72 65 63 6f 72 64 20 33 20 28 74 64 et! record 3 (td
ea00: 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 61 74 75 b:step-get-statu
ea10: 73 20 73 74 65 70 29 29 0a 09 20 20 20 20 20 20 s step))..
ea20: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 72 65 63 (vector-set! rec
ea30: 6f 72 64 20 34 20 28 74 64 62 3a 73 74 65 70 2d ord 4 (tdb:step-
ea40: 67 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 73 get-event_time s
ea50: 74 65 70 29 29 0a 09 20 20 20 20 20 20 28 76 65 tep)).. (ve
ea60: 63 74 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 64 ctor-set! record
ea70: 20 36 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 6 (tdb:step-get
ea80: 2d 63 6f 6d 6d 65 6e 74 20 73 74 65 70 29 29 29 -comment step)))
ea90: 29 0a 09 20 20 20 28 68 61 73 68 2d 74 61 62 6c ).. (hash-tabl
eaa0: 65 2d 73 65 74 21 20 72 65 73 20 28 74 64 62 3a e-set! res (tdb:
eab0: 73 74 65 70 2d 67 65 74 2d 73 74 65 70 6e 61 6d step-get-stepnam
eac0: 65 20 73 74 65 70 29 20 72 65 63 6f 72 64 29 0a e step) record).
ead0: 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 . (debug:print
eae0: 20 36 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 6 *default-log-
eaf0: 70 6f 72 74 2a 20 22 72 65 63 6f 72 64 28 61 66 port* "record(af
eb00: 74 65 72 29 20 20 3d 20 22 20 72 65 63 6f 72 64 ter) = " record
eb10: 20 0a 09 09 09 22 5c 6e 69 64 3a 20 20 20 20 20 ...."\nid:
eb20: 20 20 22 20 28 74 64 62 3a 73 74 65 70 2d 67 65 " (tdb:step-ge
eb30: 74 2d 69 64 20 73 74 65 70 29 0a 09 09 09 22 5c t-id step)...."\
eb40: 6e 73 74 65 70 6e 61 6d 65 3a 20 22 20 28 74 64 nstepname: " (td
eb50: 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 65 70 6e b:step-get-stepn
eb60: 61 6d 65 20 73 74 65 70 29 0a 09 09 09 22 5c 6e ame step)...."\n
eb70: 73 74 61 74 65 3a 20 20 20 20 22 20 28 74 64 62 state: " (tdb
eb80: 3a 73 74 65 70 2d 67 65 74 2d 73 74 61 74 65 20 :step-get-state
eb90: 73 74 65 70 29 0a 09 09 09 22 5c 6e 73 74 61 74 step)...."\nstat
eba0: 75 73 3a 20 20 20 22 20 28 74 64 62 3a 73 74 65 us: " (tdb:ste
ebb0: 70 2d 67 65 74 2d 73 74 61 74 75 73 20 73 74 65 p-get-status ste
ebc0: 70 29 0a 09 09 09 22 5c 6e 74 69 6d 65 3a 20 20 p)...."\ntime:
ebd0: 20 20 20 22 20 28 74 64 62 3a 73 74 65 70 2d 67 " (tdb:step-g
ebe0: 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 73 74 et-event_time st
ebf0: 65 70 29 29 29 29 0a 20 20 20 20 20 20 20 3b 3b ep)))). ;;
ec00: 20 28 65 6c 73 65 20 20 20 28 76 65 63 74 6f 72 (else (vector
ec10: 2d 73 65 74 21 20 72 65 63 6f 72 64 20 31 20 28 -set! record 1 (
ec20: 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 65 76 65 tdb:step-get-eve
ec30: 6e 74 5f 74 69 6d 65 20 73 74 65 70 29 29 29 0a nt_time step))).
ec40: 20 20 20 20 20 20 20 28 73 6f 72 74 20 73 74 65 (sort ste
ec50: 70 73 20 28 6c 61 6d 62 64 61 20 28 61 20 62 29 ps (lambda (a b)
ec60: 0a 09 09 20 20 20 20 20 28 63 6f 6e 64 0a 09 09 ... (cond...
ec70: 20 20 20 20 20 20 28 28 3c 20 20 20 28 74 64 62 ((< (tdb
ec80: 3a 73 74 65 70 2d 67 65 74 2d 65 76 65 6e 74 5f :step-get-event_
ec90: 74 69 6d 65 20 61 29 28 74 64 62 3a 73 74 65 70 time a)(tdb:step
eca0: 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 -get-event_time
ecb0: 62 29 29 20 23 74 29 0a 09 09 20 20 20 20 20 20 b)) #t)...
ecc0: 28 28 65 71 3f 20 28 74 64 62 3a 73 74 65 70 2d ((eq? (tdb:step-
ecd0: 67 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 61 get-event_time a
ece0: 29 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 65 )(tdb:step-get-e
ecf0: 76 65 6e 74 5f 74 69 6d 65 20 62 29 29 20 0a 09 vent_time b)) ..
ed00: 09 20 20 20 20 20 20 20 28 3c 20 20 20 28 74 64 . (< (td
ed10: 62 3a 73 74 65 70 2d 67 65 74 2d 69 64 20 61 29 b:step-get-id a)
ed20: 20 20 20 20 20 20 20 20 28 74 64 62 3a 73 74 65 (tdb:ste
ed30: 70 2d 67 65 74 2d 69 64 20 62 29 29 29 0a 09 09 p-get-id b)))...
ed40: 20 20 20 20 20 20 28 65 6c 73 65 20 23 66 29 29 (else #f))
ed50: 29 29 29 0a 20 20 20 20 20 20 72 65 73 29 29 0a ))). res)).
ed60: 0a 3b 3b 20 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 .;; .;;.(define
ed70: 28 74 65 73 74 73 3a 67 65 74 2d 63 6f 6d 70 72 (tests:get-compr
ed80: 65 73 73 65 64 2d 73 74 65 70 73 20 72 75 6e 2d essed-steps run-
ed90: 69 64 20 74 65 73 74 2d 69 64 29 0a 20 20 28 6c id test-id). (l
eda0: 65 74 2a 20 28 28 73 74 65 70 73 2d 64 61 74 61 et* ((steps-data
edb0: 20 20 28 72 6d 74 3a 67 65 74 2d 73 74 65 70 73 (rmt:get-steps
edc0: 2d 66 6f 72 2d 74 65 73 74 20 72 75 6e 2d 69 64 -for-test run-id
edd0: 20 74 65 73 74 2d 69 64 29 29 20 3b 3b 20 20 20 test-id)) ;;
ede0: 20 20 20 30 20 20 20 20 20 20 20 31 20 20 20 20 0 1
edf0: 32 20 20 20 20 33 20 20 20 20 20 20 20 34 20 20 2 3 4
ee00: 20 20 20 20 20 35 20 20 20 20 20 20 20 36 20 20 5 6
ee10: 20 20 20 20 37 20 20 20 20 20 20 20 0a 09 20 28 7 .. (
ee20: 63 6f 6d 70 72 73 74 65 70 73 20 20 28 74 65 73 comprsteps (tes
ee30: 74 73 3a 70 72 6f 63 65 73 73 2d 73 74 65 70 73 ts:process-steps
ee40: 2d 74 61 62 6c 65 20 73 74 65 70 73 2d 64 61 74 -table steps-dat
ee50: 61 29 29 29 20 3b 3b 20 23 3c 73 74 65 70 6e 61 a))) ;; #<stepna
ee60: 6d 65 20 73 74 61 72 74 20 65 6e 64 20 73 74 61 me start end sta
ee70: 74 75 73 20 44 75 72 61 74 69 6f 6e 20 4c 6f 67 tus Duration Log
ee80: 66 69 6c 65 20 43 6f 6d 6d 65 6e 74 20 69 64 3e file Comment id>
ee90: 0a 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 . (map (lambd
eea0: 61 20 28 78 29 0a 09 20 20 20 3b 3b 20 74 61 6b a (x).. ;; tak
eeb0: 65 20 61 64 76 61 6e 74 61 67 65 20 6f 66 20 74 e advantage of t
eec0: 68 65 20 5c 6e 20 6f 6e 20 74 69 6d 65 2d 3e 73 he \n on time->s
eed0: 74 72 69 6e 67 0a 09 20 20 20 28 76 65 63 74 6f tring.. (vecto
eee0: 72 20 20 20 20 3b 3b 20 77 65 20 61 72 65 20 63 r ;; we are c
eef0: 6f 6e 73 74 72 75 63 74 69 6e 67 20 62 61 73 69 onstructing basi
ef00: 63 61 6c 6c 79 20 74 68 65 20 6f 72 69 67 69 6e cally the origin
ef10: 61 6c 20 76 65 63 74 6f 72 20 62 75 74 20 63 6f al vector but co
ef20: 6c 6c 61 70 73 69 6e 67 20 73 74 61 72 74 20 65 llapsing start e
ef30: 6e 64 20 72 65 63 6f 72 64 73 0a 09 20 20 20 20 nd records..
ef40: 28 76 65 63 74 6f 72 2d 72 65 66 20 78 20 30 29 (vector-ref x 0)
ef50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ef60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b ;;
ef70: 20 69 64 20 20 20 20 20 20 20 20 30 0a 09 20 20 id 0..
ef80: 20 20 28 6c 65 74 20 28 28 73 20 28 76 65 63 74 (let ((s (vect
ef90: 6f 72 2d 72 65 66 20 78 20 31 29 29 29 0a 09 20 or-ref x 1)))..
efa0: 20 20 20 20 20 28 69 66 20 28 6e 75 6d 62 65 72 (if (number
efb0: 3f 20 73 29 28 73 65 63 6f 6e 64 73 2d 3e 74 69 ? s)(seconds->ti
efc0: 6d 65 2d 73 74 72 69 6e 67 20 73 29 20 73 29 29 me-string s) s))
efd0: 20 3b 3b 20 73 74 61 72 74 74 69 6d 65 20 31 0a ;; starttime 1.
efe0: 09 20 20 20 20 28 6c 65 74 20 28 28 73 20 28 76 . (let ((s (v
eff0: 65 63 74 6f 72 2d 72 65 66 20 78 20 32 29 29 29 ector-ref x 2)))
f000: 0a 09 20 20 20 20 20 20 28 69 66 20 28 6e 75 6d .. (if (num
f010: 62 65 72 3f 20 73 29 28 73 65 63 6f 6e 64 73 2d ber? s)(seconds-
f020: 3e 74 69 6d 65 2d 73 74 72 69 6e 67 20 73 29 20 >time-string s)
f030: 73 29 29 20 3b 3b 20 65 6e 64 74 69 6d 65 20 20 s)) ;; endtime
f040: 20 32 0a 09 20 20 20 20 28 76 65 63 74 6f 72 2d 2.. (vector-
f050: 72 65 66 20 78 20 33 29 20 20 20 20 20 20 20 20 ref x 3)
f060: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
f070: 20 20 20 20 20 20 3b 3b 20 73 74 61 74 75 73 20 ;; status
f080: 20 20 20 33 20 20 20 20 0a 09 20 20 20 20 28 76 3 .. (v
f090: 65 63 74 6f 72 2d 72 65 66 20 78 20 34 29 20 20 ector-ref x 4)
f0a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
f0b0: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 64 ;; d
f0c0: 75 72 61 74 69 6f 6e 20 20 34 0a 09 20 20 20 20 uration 4..
f0d0: 28 76 65 63 74 6f 72 2d 72 65 66 20 78 20 35 29 (vector-ref x 5)
f0e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
f0f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b ;;
f100: 20 6c 6f 67 66 69 6c 65 20 20 20 35 0a 09 20 20 logfile 5..
f110: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 78 20 (vector-ref x
f120: 36 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 6)
f130: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
f140: 3b 3b 20 63 6f 6d 6d 65 6e 74 20 20 20 36 0a 09 ;; comment 6..
f150: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
f160: 78 20 37 29 29 29 20 20 20 20 20 20 20 20 20 20 x 7)))
f170: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
f180: 20 20 3b 3b 20 69 64 20 20 20 20 20 20 20 20 37 ;; id 7
f190: 0a 09 20 28 73 6f 72 74 20 28 68 61 73 68 2d 74 .. (sort (hash-t
f1a0: 61 62 6c 65 2d 76 61 6c 75 65 73 20 63 6f 6d 70 able-values comp
f1b0: 72 73 74 65 70 73 29 0a 09 20 20 20 20 20 20 20 rsteps)..
f1c0: 28 6c 61 6d 62 64 61 20 28 61 20 62 29 0a 09 09 (lambda (a b)...
f1d0: 20 28 6c 65 74 20 28 28 74 69 6d 65 2d 61 20 28 (let ((time-a (
f1e0: 76 65 63 74 6f 72 2d 72 65 66 20 61 20 31 29 29 vector-ref a 1))
f1f0: 0a 09 09 20 20 20 20 20 20 20 28 74 69 6d 65 2d ... (time-
f200: 62 20 28 76 65 63 74 6f 72 2d 72 65 66 20 62 20 b (vector-ref b
f210: 31 29 29 0a 09 09 20 20 20 20 20 20 20 28 69 64 1))... (id
f220: 2d 61 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 -a (vector-ref
f230: 20 61 20 37 29 29 0a 09 09 20 20 20 20 20 20 20 a 7))...
f240: 28 69 64 2d 62 20 20 20 28 76 65 63 74 6f 72 2d (id-b (vector-
f250: 72 65 66 20 62 20 37 29 29 29 0a 09 09 20 20 20 ref b 7)))...
f260: 28 69 66 20 28 61 6e 64 20 28 6e 75 6d 62 65 72 (if (and (number
f270: 3f 20 74 69 6d 65 2d 61 29 28 6e 75 6d 62 65 72 ? time-a)(number
f280: 3f 20 74 69 6d 65 2d 62 29 29 0a 09 09 20 20 20 ? time-b))...
f290: 20 20 20 20 28 69 66 20 28 3c 20 74 69 6d 65 2d (if (< time-
f2a0: 61 20 74 69 6d 65 2d 62 29 0a 09 09 09 20 20 20 a time-b)....
f2b0: 23 74 0a 09 09 09 20 20 20 28 69 66 20 28 65 71 #t.... (if (eq
f2c0: 3f 20 74 69 6d 65 2d 61 20 74 69 6d 65 2d 62 29 ? time-a time-b)
f2d0: 0a 09 09 09 20 20 20 20 20 20 20 28 3c 20 69 64 .... (< id
f2e0: 2d 61 20 69 64 2d 62 29 0a 09 09 09 20 20 20 20 -a id-b)....
f2f0: 20 20 20 3b 3b 20 28 73 74 72 69 6e 67 3c 3f 20 ;; (string<?
f300: 28 63 6f 6e 63 20 28 76 65 63 74 6f 72 2d 72 65 (conc (vector-re
f310: 66 20 61 20 32 29 29 0a 09 09 09 20 20 20 20 20 f a 2))....
f320: 20 20 3b 3b 09 20 20 20 20 28 63 6f 6e 63 20 28 ;;. (conc (
f330: 76 65 63 74 6f 72 2d 72 65 66 20 62 20 32 29 29 vector-ref b 2))
f340: 29 0a 09 09 09 20 20 20 20 20 20 20 23 66 29 29 ).... #f))
f350: 0a 09 09 20 20 20 20 20 20 20 28 73 74 72 69 6e ... (strin
f360: 67 3c 3f 20 28 63 6f 6e 63 20 74 69 6d 65 2d 61 g<? (conc time-a
f370: 29 28 63 6f 6e 63 20 74 69 6d 65 2d 62 29 29 29 )(conc time-b)))
f380: 29 29 29 29 29 29 0a 0a 0a 3b 3b 20 53 61 76 65 ))))))...;; Save
f390: 20 74 65 73 74 20 73 74 61 74 65 20 61 6e 64 20 test state and
f3a0: 73 74 61 74 75 73 20 69 6e 20 74 6f 20 61 20 66 status in to a f
f3b0: 69 6c 65 20 2e 66 69 6e 61 6c 2d 73 74 61 74 75 ile .final-statu
f3c0: 73 20 69 6e 20 74 68 65 20 74 65 73 74 20 64 69 s in the test di
f3d0: 72 65 63 74 6f 72 79 0a 3b 3b 0a 28 64 65 66 69 rectory.;;.(defi
f3e0: 6e 65 20 28 74 65 73 74 73 3a 73 61 76 65 2d 66 ne (tests:save-f
f3f0: 69 6e 61 6c 2d 73 74 61 74 75 73 20 72 75 6e 2d inal-status run-
f400: 69 64 20 74 65 73 74 2d 69 64 29 0a 20 20 28 6c id test-id). (l
f410: 65 74 2a 20 28 28 74 65 73 74 2d 64 61 74 20 20 et* ((test-dat
f420: 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 6e (rmt:get-test-in
f430: 66 6f 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 fo-by-id run-id
f440: 74 65 73 74 2d 69 64 29 29 0a 09 20 28 6f 75 74 test-id)).. (out
f450: 2d 64 69 72 20 20 20 28 64 62 3a 74 65 73 74 2d -dir (db:test-
f460: 67 65 74 2d 72 75 6e 64 69 72 20 74 65 73 74 2d get-rundir test-
f470: 64 61 74 29 29 0a 09 20 28 73 74 61 74 75 73 2d dat)).. (status-
f480: 66 69 6c 65 20 20 28 63 6f 6e 63 20 6f 75 74 2d file (conc out-
f490: 64 69 72 20 22 2f 2e 66 69 6e 61 6c 2d 73 74 61 dir "/.final-sta
f4a0: 74 75 73 22 29 29 0a 20 20 20 29 0a 20 20 20 20 tus")). ).
f4b0: 3b 3b 20 66 69 72 73 74 20 76 65 72 69 66 79 20 ;; first verify
f4c0: 77 65 20 61 72 65 20 61 62 6c 65 20 74 6f 20 77 we are able to w
f4d0: 72 69 74 65 20 74 68 65 20 6f 75 74 70 75 74 20 rite the output
f4e0: 66 69 6c 65 0a 20 20 20 20 28 69 66 20 28 6e 6f file. (if (no
f4f0: 74 20 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 t (file-write-ac
f500: 63 65 73 73 3f 20 6f 75 74 2d 64 69 72 29 29 0a cess? out-dir)).
f510: 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
f520: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
f530: 2d 70 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 63 -port* "ERROR: c
f540: 61 6e 6e 6f 74 20 77 72 69 74 65 20 2e 66 69 6e annot write .fin
f550: 61 6c 2d 73 74 61 74 75 73 20 74 6f 20 22 20 6f al-status to " o
f560: 75 74 2d 64 69 72 29 0a 09 20 20 20 20 28 6c 65 ut-dir).. (le
f570: 74 2a 20 0a 20 20 20 20 20 20 20 20 20 28 28 6f t* . ((o
f580: 75 74 70 20 20 20 20 20 20 28 6f 70 65 6e 2d 6f utp (open-o
f590: 75 74 70 75 74 2d 66 69 6c 65 20 73 74 61 74 75 utput-file statu
f5a0: 73 2d 66 69 6c 65 29 29 0a 09 20 20 20 20 20 20 s-file))..
f5b0: 20 28 73 74 61 74 75 73 20 20 20 20 28 64 62 3a (status (db:
f5c0: 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 73 20 test-get-status
f5d0: 20 20 74 65 73 74 2d 64 61 74 29 29 0a 20 20 20 test-dat)).
f5e0: 20 20 20 20 20 20 28 73 74 61 74 65 20 20 20 20 (state
f5f0: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 (db:test-get-st
f600: 61 74 65 20 20 20 20 74 65 73 74 2d 64 61 74 29 ate test-dat)
f610: 29 29 0a 20 20 20 20 20 20 20 20 28 66 70 72 69 )). (fpri
f620: 6e 74 66 20 6f 75 74 70 20 22 7e 53 5c 6e 22 20 ntf outp "~S\n"
f630: 73 74 61 74 65 29 20 0a 20 20 20 20 20 20 20 20 state) .
f640: 28 66 70 72 69 6e 74 66 20 6f 75 74 70 20 22 7e (fprintf outp "~
f650: 53 5c 6e 22 20 73 74 61 74 75 73 29 20 0a 20 20 S\n" status) .
f660: 20 20 20 20 20 20 28 63 6c 6f 73 65 2d 6f 75 74 (close-out
f670: 70 75 74 2d 70 6f 72 74 20 6f 75 74 70 29 29 29 put-port outp)))
f680: 29 29 0a 0a 0a 3b 3b 20 73 75 6d 6d 61 72 69 7a ))...;; summariz
f690: 65 20 74 65 73 74 20 69 6e 20 74 6f 20 61 20 66 e test in to a f
f6a0: 69 6c 65 20 74 65 73 74 2d 73 75 6d 6d 61 72 79 ile test-summary
f6b0: 2e 68 74 6d 6c 20 69 6e 20 74 68 65 20 74 65 73 .html in the tes
f6c0: 74 20 64 69 72 65 63 74 6f 72 79 0a 3b 3b 0a 28 t directory.;;.(
f6d0: 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 73 75 define (tests:su
f6e0: 6d 6d 61 72 69 7a 65 2d 74 65 73 74 20 72 75 6e mmarize-test run
f6f0: 2d 69 64 20 74 65 73 74 2d 69 64 29 0a 20 20 28 -id test-id). (
f700: 6c 65 74 2a 20 28 28 74 65 73 74 2d 64 61 74 20 let* ((test-dat
f710: 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 (rmt:get-test-i
f720: 6e 66 6f 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 nfo-by-id run-id
f730: 20 74 65 73 74 2d 69 64 29 29 0a 09 20 28 6f 75 test-id)).. (ou
f740: 74 2d 64 69 72 20 20 20 28 64 62 3a 74 65 73 74 t-dir (db:test
f750: 2d 67 65 74 2d 72 75 6e 64 69 72 20 74 65 73 74 -get-rundir test
f760: 2d 64 61 74 29 29 0a 09 20 28 6f 75 74 2d 66 69 -dat)).. (out-fi
f770: 6c 65 20 20 28 63 6f 6e 63 20 6f 75 74 2d 64 69 le (conc out-di
f780: 72 20 22 2f 74 65 73 74 2d 73 75 6d 6d 61 72 79 r "/test-summary
f790: 2e 68 74 6d 6c 22 29 29 29 0a 20 20 20 20 3b 3b .html"))). ;;
f7a0: 20 66 69 72 73 74 20 76 65 72 69 66 79 20 77 65 first verify we
f7b0: 20 61 72 65 20 61 62 6c 65 20 74 6f 20 77 72 69 are able to wri
f7c0: 74 65 20 74 68 65 20 6f 75 74 70 75 74 20 66 69 te the output fi
f7d0: 6c 65 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 le. (if (not
f7e0: 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 (file-write-acce
f7f0: 73 73 3f 20 6f 75 74 2d 64 69 72 29 29 0a 09 28 ss? out-dir))..(
f800: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
f810: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
f820: 20 22 45 52 52 4f 52 3a 20 63 61 6e 6e 6f 74 20 "ERROR: cannot
f830: 77 72 69 74 65 20 74 65 73 74 2d 73 75 6d 6d 61 write test-summa
f840: 72 79 2e 68 74 6d 6c 20 74 6f 20 22 20 6f 75 74 ry.html to " out
f850: 2d 64 69 72 29 0a 09 28 6c 65 74 2a 20 28 3b 3b -dir)..(let* (;;
f860: 20 28 73 74 65 70 73 2d 64 61 74 20 28 72 6d 74 (steps-dat (rmt
f870: 3a 67 65 74 2d 73 74 65 70 73 2d 66 6f 72 2d 74 :get-steps-for-t
f880: 65 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d est run-id test-
f890: 69 64 29 29 0a 09 20 20 20 20 20 20 20 28 74 65 id)).. (te
f8a0: 73 74 2d 6e 61 6d 65 20 28 64 62 3a 74 65 73 74 st-name (db:test
f8b0: 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 -get-testname te
f8c0: 73 74 2d 64 61 74 29 29 0a 09 20 20 20 20 20 20 st-dat))..
f8d0: 20 28 69 74 65 6d 2d 70 61 74 68 20 28 64 62 3a (item-path (db:
f8e0: 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 test-get-item-pa
f8f0: 74 68 20 74 65 73 74 2d 64 61 74 29 29 0a 09 20 th test-dat))..
f900: 20 20 20 20 20 20 28 66 75 6c 6c 2d 6e 61 6d 65 (full-name
f910: 20 28 64 62 3a 74 65 73 74 2d 6d 61 6b 65 2d 66 (db:test-make-f
f920: 75 6c 6c 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 ull-name test-na
f930: 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 0a 09 me item-path))..
f940: 20 20 20 20 20 20 20 28 6f 75 70 20 20 20 20 20 (oup
f950: 20 20 28 6f 70 65 6e 2d 6f 75 74 70 75 74 2d 66 (open-output-f
f960: 69 6c 65 20 6f 75 74 2d 66 69 6c 65 29 29 0a 09 ile out-file))..
f970: 20 20 20 20 20 20 20 28 73 74 61 74 75 73 20 20 (status
f980: 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 (db:test-get-s
f990: 74 61 74 75 73 20 20 20 74 65 73 74 2d 64 61 74 tatus test-dat
f9a0: 29 29 0a 09 20 20 20 20 20 20 20 28 63 6f 6c 6f )).. (colo
f9b0: 72 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 r (common:ge
f9c0: 74 2d 63 6f 6c 6f 72 2d 66 72 6f 6d 2d 73 74 61 t-color-from-sta
f9d0: 74 75 73 20 73 74 61 74 75 73 29 29 0a 09 20 20 tus status))..
f9e0: 20 20 20 20 20 28 6c 6f 67 66 20 20 20 20 20 20 (logf
f9f0: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 66 69 6e (db:test-get-fin
fa00: 61 6c 5f 6c 6f 67 66 20 74 65 73 74 2d 64 61 74 al_logf test-dat
fa10: 29 29 0a 09 20 20 20 20 20 20 20 28 73 74 65 70 )).. (step
fa20: 73 2d 64 61 74 20 28 74 65 73 74 73 3a 67 65 74 s-dat (tests:get
fa30: 2d 63 6f 6d 70 72 65 73 73 65 64 2d 73 74 65 70 -compressed-step
fa40: 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 s run-id test-id
fa50: 29 29 29 0a 09 20 20 3b 3b 20 28 64 63 6f 6d 6d ))).. ;; (dcomm
fa60: 6f 6e 3a 67 65 74 2d 63 6f 6d 70 72 65 73 73 65 on:get-compresse
fa70: 64 2d 73 74 65 70 73 20 23 66 20 31 20 33 30 30 d-steps #f 1 300
fa80: 34 35 29 0a 09 20 20 3b 3b 20 28 23 28 22 77 61 45).. ;; (#("wa
fa90: 73 74 69 6e 67 5f 74 69 6d 65 22 20 22 32 33 3a sting_time" "23:
faa0: 33 36 3a 31 33 22 20 22 32 33 3a 33 36 3a 32 31 36:13" "23:36:21
fab0: 22 20 22 30 22 20 22 38 2e 30 73 22 20 22 77 61 " "0" "8.0s" "wa
fac0: 73 74 69 6e 67 5f 74 69 6d 65 2e 6c 6f 67 22 29 sting_time.log")
fad0: 29 0a 09 0a 09 20 20 28 73 3a 6f 75 74 70 75 74 ).... (s:output
fae0: 2d 6e 65 77 0a 09 20 20 20 6f 75 70 0a 09 20 20 -new.. oup..
faf0: 20 28 73 3a 68 74 6d 6c 0a 09 20 20 20 20 28 73 (s:html.. (s
fb00: 3a 74 69 74 6c 65 20 22 53 75 6d 6d 61 72 79 20 :title "Summary
fb10: 66 6f 72 20 22 20 66 75 6c 6c 2d 6e 61 6d 65 29 for " full-name)
fb20: 0a 09 20 20 20 20 28 73 3a 62 6f 64 79 20 0a 09 .. (s:body ..
fb30: 20 20 20 20 20 28 73 3a 68 32 20 22 53 75 6d 6d (s:h2 "Summ
fb40: 61 72 79 20 66 6f 72 20 22 20 66 75 6c 6c 2d 6e ary for " full-n
fb50: 61 6d 65 29 0a 09 20 20 20 20 20 28 73 3a 74 61 ame).. (s:ta
fb60: 62 6c 65 20 27 63 65 6c 6c 73 70 61 63 69 6e 67 ble 'cellspacing
fb70: 20 22 30 22 20 27 62 6f 72 64 65 72 20 22 31 22 "0" 'border "1"
fb80: 0a 09 09 20 20 20 20 20 20 28 73 3a 74 72 20 28 ... (s:tr (
fb90: 73 3a 74 64 20 22 72 75 6e 20 69 64 22 29 20 20 s:td "run id")
fba0: 20 28 73 3a 74 64 20 28 64 62 3a 74 65 73 74 2d (s:td (db:test-
fbb0: 67 65 74 2d 72 75 6e 5f 69 64 20 20 20 74 65 73 get-run_id tes
fbc0: 74 2d 64 61 74 29 29 0a 09 09 09 20 20 20 20 28 t-dat)).... (
fbd0: 73 3a 74 64 20 22 74 65 73 74 20 69 64 22 29 20 s:td "test id")
fbe0: 20 28 73 3a 74 64 20 28 64 62 3a 74 65 73 74 2d (s:td (db:test-
fbf0: 67 65 74 2d 69 64 20 20 20 20 20 20 20 74 65 73 get-id tes
fc00: 74 2d 64 61 74 29 29 29 0a 09 09 20 20 20 20 20 t-dat)))...
fc10: 20 28 73 3a 74 72 20 28 73 3a 74 64 20 22 74 65 (s:tr (s:td "te
fc20: 73 74 6e 61 6d 65 22 29 20 28 73 3a 74 64 20 74 stname") (s:td t
fc30: 65 73 74 2d 6e 61 6d 65 29 0a 09 09 09 20 20 20 est-name)....
fc40: 20 28 73 3a 74 64 20 22 69 74 65 6d 70 61 74 68 (s:td "itempath
fc50: 22 29 20 28 73 3a 74 64 20 69 74 65 6d 2d 70 61 ") (s:td item-pa
fc60: 74 68 29 29 0a 09 09 20 20 20 20 20 20 28 73 3a th))... (s:
fc70: 74 72 20 28 73 3a 74 64 20 22 73 74 61 74 65 22 tr (s:td "state"
fc80: 29 20 20 20 20 28 73 3a 74 64 20 28 64 62 3a 74 ) (s:td (db:t
fc90: 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 20 20 est-get-state
fca0: 20 74 65 73 74 2d 64 61 74 29 29 0a 09 09 09 20 test-dat))....
fcb0: 20 20 20 28 73 3a 74 64 20 22 73 74 61 74 75 73 (s:td "status
fcc0: 22 29 20 20 20 28 73 3a 74 64 20 28 73 3a 61 20 ") (s:td (s:a
fcd0: 27 68 72 65 66 20 6c 6f 67 66 20 28 73 3a 66 6f 'href logf (s:fo
fce0: 6e 74 20 27 63 6f 6c 6f 72 20 63 6f 6c 6f 72 20 nt 'color color
fcf0: 73 74 61 74 75 73 29 29 29 29 0a 09 09 20 20 20 status))))...
fd00: 20 20 20 28 73 3a 74 72 20 28 73 3a 74 64 20 22 (s:tr (s:td "
fd10: 54 65 73 74 44 61 74 65 22 29 20 28 73 3a 74 64 TestDate") (s:td
fd20: 20 28 73 65 63 6f 6e 64 73 2d 3e 77 6f 72 6b 2d (seconds->work-
fd30: 77 65 65 6b 2f 64 61 79 2d 74 69 6d 65 20 0a 09 week/day-time ..
fd40: 09 09 09 09 09 20 20 20 20 20 28 64 62 3a 74 65 ..... (db:te
fd50: 73 74 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 6d st-get-event_tim
fd60: 65 20 74 65 73 74 2d 64 61 74 29 29 29 0a 09 09 e test-dat)))...
fd70: 09 20 20 20 20 28 73 3a 74 64 20 22 44 75 72 61 . (s:td "Dura
fd80: 74 69 6f 6e 22 29 20 28 73 3a 74 64 20 28 73 65 tion") (s:td (se
fd90: 63 6f 6e 64 73 2d 3e 68 72 2d 6d 69 6e 2d 73 65 conds->hr-min-se
fda0: 63 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 c (db:test-get-r
fdb0: 75 6e 5f 64 75 72 61 74 69 6f 6e 20 74 65 73 74 un_duration test
fdc0: 2d 64 61 74 29 29 29 29 29 0a 09 20 20 20 20 20 -dat)))))..
fdd0: 28 73 3a 68 33 20 22 4c 6f 67 20 66 69 6c 65 73 (s:h3 "Log files
fde0: 22 29 0a 09 20 20 20 20 20 28 73 3a 74 61 62 6c ").. (s:tabl
fdf0: 65 20 0a 09 20 20 20 20 20 20 27 63 65 6c 6c 73 e .. 'cells
fe00: 70 61 63 69 6e 67 20 22 30 22 20 27 62 6f 72 64 pacing "0" 'bord
fe10: 65 72 20 22 31 22 0a 09 20 20 20 20 20 20 28 73 er "1".. (s
fe20: 3a 74 72 20 28 73 3a 74 64 20 22 46 69 6e 61 6c :tr (s:td "Final
fe30: 20 6c 6f 67 22 29 28 73 3a 74 64 20 28 73 3a 61 log")(s:td (s:a
fe40: 20 27 68 72 65 66 20 6c 6f 67 66 20 6c 6f 67 66 'href logf logf
fe50: 29 29 29 29 0a 09 20 20 20 20 20 28 73 3a 74 61 )))).. (s:ta
fe60: 62 6c 65 0a 09 20 20 20 20 20 20 27 63 65 6c 6c ble.. 'cell
fe70: 73 70 61 63 69 6e 67 20 22 30 22 20 27 62 6f 72 spacing "0" 'bor
fe80: 64 65 72 20 22 31 22 0a 09 20 20 20 20 20 20 28 der "1".. (
fe90: 73 3a 74 72 20 28 73 3a 74 64 20 22 53 74 65 70 s:tr (s:td "Step
fea0: 20 4e 61 6d 65 22 29 28 73 3a 74 64 20 22 53 74 Name")(s:td "St
feb0: 61 72 74 22 29 28 73 3a 74 64 20 22 45 6e 64 22 art")(s:td "End"
fec0: 29 28 73 3a 74 64 20 22 53 74 61 74 75 73 22 29 )(s:td "Status")
fed0: 28 73 3a 74 64 20 22 44 75 72 61 74 69 6f 6e 22 (s:td "Duration"
fee0: 29 28 73 3a 74 64 20 22 4c 6f 67 20 46 69 6c 65 )(s:td "Log File
fef0: 22 29 29 0a 09 20 20 20 20 20 20 28 6d 61 70 20 ")).. (map
ff00: 28 6c 61 6d 62 64 61 20 28 73 74 65 70 2d 64 61 (lambda (step-da
ff10: 74 29 0a 09 09 20 20 20 20 20 28 73 3a 74 72 20 t)... (s:tr
ff20: 28 73 3a 74 64 20 28 74 64 62 3a 73 74 65 70 73 (s:td (tdb:steps
ff30: 2d 74 61 62 6c 65 2d 67 65 74 2d 73 74 65 70 6e -table-get-stepn
ff40: 61 6d 65 20 73 74 65 70 2d 64 61 74 29 29 0a 09 ame step-dat))..
ff50: 09 09 20 20 20 28 73 3a 74 64 20 28 74 64 62 3a .. (s:td (tdb:
ff60: 73 74 65 70 73 2d 74 61 62 6c 65 2d 67 65 74 2d steps-table-get-
ff70: 73 74 61 72 74 20 20 20 20 73 74 65 70 2d 64 61 start step-da
ff80: 74 29 29 0a 09 09 09 20 20 20 28 73 3a 74 64 20 t)).... (s:td
ff90: 28 74 64 62 3a 73 74 65 70 73 2d 74 61 62 6c 65 (tdb:steps-table
ffa0: 2d 67 65 74 2d 65 6e 64 20 20 20 20 20 20 73 74 -get-end st
ffb0: 65 70 2d 64 61 74 29 29 0a 09 09 09 20 20 20 28 ep-dat)).... (
ffc0: 73 3a 74 64 20 28 74 64 62 3a 73 74 65 70 73 2d s:td (tdb:steps-
ffd0: 74 61 62 6c 65 2d 67 65 74 2d 73 74 61 74 75 73 table-get-status
ffe0: 20 20 20 73 74 65 70 2d 64 61 74 29 29 0a 09 09 step-dat))...
fff0: 09 20 20 20 28 73 3a 74 64 20 28 74 64 62 3a 73 . (s:td (tdb:s
10000 74 65 70 73 2d 74 61 62 6c 65 2d 67 65 74 2d 72 teps-table-get-r
10010 75 6e 74 69 6d 65 20 20 73 74 65 70 2d 64 61 74 untime step-dat
10020 29 29 0a 09 09 09 20 20 20 28 73 3a 74 64 20 28 )).... (s:td (
10030 6c 65 74 20 28 28 73 74 65 70 2d 6c 6f 67 20 28 let ((step-log (
10040 74 64 62 3a 73 74 65 70 73 2d 74 61 62 6c 65 2d tdb:steps-table-
10050 67 65 74 2d 6c 6f 67 2d 66 69 6c 65 20 73 74 65 get-log-file ste
10060 70 2d 64 61 74 29 29 29 0a 09 09 09 09 20 20 20 p-dat))).....
10070 28 73 3a 61 20 27 68 72 65 66 20 73 74 65 70 2d (s:a 'href step-
10080 6c 6f 67 20 73 74 65 70 2d 6c 6f 67 29 29 29 29 log step-log))))
10090 29 0a 09 09 20 20 20 73 74 65 70 73 2d 64 61 74 )... steps-dat
100a0 29 29 0a 09 20 20 20 20 20 29 29 29 0a 09 20 20 )).. )))..
100b0 28 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d 70 6f (close-output-po
100c0 72 74 20 6f 75 70 29 29 29 29 29 0a 09 20 20 0a rt oup))))).. .
100d0 09 20 20 0a 3b 3b 20 4d 55 53 54 20 42 45 20 43 . .;; MUST BE C
100e0 41 4c 4c 45 44 20 6c 6f 63 61 6c 21 0a 3b 3b 0a ALLED local!.;;.
100f0 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 74 (define (tests:t
10100 65 73 74 2d 67 65 74 2d 70 61 74 68 73 2d 6d 61 est-get-paths-ma
10110 74 63 68 69 6e 67 20 6b 65 79 6e 61 6d 65 73 20 tching keynames
10120 74 61 72 67 65 74 20 66 6e 61 6d 65 70 61 74 74 target fnamepatt
10130 20 23 21 6b 65 79 20 28 72 65 73 20 27 28 29 29 #!key (res '())
10140 29 0a 20 20 3b 3b 20 42 55 47 3a 20 4d 6f 76 65 ). ;; BUG: Move
10150 20 74 68 65 20 76 61 6c 75 65 73 20 64 65 72 69 the values deri
10160 76 65 64 20 66 72 6f 6d 20 61 72 67 73 20 74 6f ved from args to
10170 20 70 61 72 61 6d 65 74 65 72 73 20 61 6e 64 20 parameters and
10180 70 75 73 68 20 74 6f 20 6d 65 67 61 74 65 73 74 push to megatest
10190 2e 73 63 6d 0a 20 20 28 6c 65 74 2a 20 28 28 74 .scm. (let* ((t
101a0 65 73 74 70 61 74 74 20 20 20 28 6f 72 20 28 61 estpatt (or (a
101b0 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 65 rgs:get-arg "-te
101c0 73 74 70 61 74 74 22 29 28 61 72 67 73 3a 67 65 stpatt")(args:ge
101d0 74 2d 61 72 67 20 22 2d 74 65 73 74 70 61 74 74 t-arg "-testpatt
101e0 22 29 20 22 25 22 29 29 0a 09 20 28 73 74 61 74 ") "%")).. (stat
101f0 65 70 61 74 74 20 20 28 6f 72 20 28 61 72 67 73 epatt (or (args
10200 3a 67 65 74 2d 61 72 67 20 22 2d 73 74 61 74 65 :get-arg "-state
10210 22 29 20 20 20 28 61 72 67 73 3a 67 65 74 2d 61 ") (args:get-a
10220 72 67 20 22 3a 73 74 61 74 65 22 29 20 20 20 20 rg ":state")
10230 22 25 22 29 29 0a 09 20 28 73 74 61 74 75 73 70 "%")).. (statusp
10240 61 74 74 20 28 6f 72 20 28 61 72 67 73 3a 67 65 att (or (args:ge
10250 74 2d 61 72 67 20 22 2d 73 74 61 74 75 73 22 29 t-arg "-status")
10260 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 (args:get-arg
10270 22 3a 73 74 61 74 75 73 22 29 20 20 20 22 25 22 ":status") "%"
10280 29 29 0a 09 20 28 72 75 6e 6e 61 6d 65 20 20 20 )).. (runname
10290 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 (or (args:get-a
102a0 72 67 20 22 2d 72 75 6e 6e 61 6d 65 22 29 20 28 rg "-runname") (
102b0 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 3a 72 args:get-arg ":r
102c0 75 6e 6e 61 6d 65 22 29 20 20 22 25 22 29 29 0a unname") "%")).
102d0 09 20 28 70 61 74 68 73 2d 66 72 6f 6d 2d 64 62 . (paths-from-db
102e0 20 28 72 6d 74 3a 74 65 73 74 2d 67 65 74 2d 70 (rmt:test-get-p
102f0 61 74 68 73 2d 6d 61 74 63 68 69 6e 67 2d 6b 65 aths-matching-ke
10300 79 6e 61 6d 65 73 2d 74 61 72 67 65 74 2d 6e 65 ynames-target-ne
10310 77 20 6b 65 79 6e 61 6d 65 73 20 74 61 72 67 65 w keynames targe
10320 74 20 72 65 73 0a 09 09 09 09 09 74 65 73 74 70 t res......testp
10330 61 74 74 0a 09 09 09 09 09 73 74 61 74 65 70 61 att......statepa
10340 74 74 0a 09 09 09 09 09 73 74 61 74 75 73 70 61 tt......statuspa
10350 74 74 0a 09 09 09 09 09 72 75 6e 6e 61 6d 65 29 tt......runname)
10360 29 29 0a 20 20 20 20 28 69 66 20 66 6e 61 6d 65 )). (if fname
10370 70 61 74 74 0a 09 28 61 70 70 6c 79 20 61 70 70 patt..(apply app
10380 65 6e 64 20 0a 09 20 20 20 20 20 20 20 28 6d 61 end .. (ma
10390 70 20 28 6c 61 6d 62 64 61 20 28 70 29 0a 09 09 p (lambda (p)...
103a0 20 20 20 20 20 20 28 69 66 20 28 64 69 72 65 63 (if (direc
103b0 74 6f 72 79 2d 65 78 69 73 74 73 3f 20 70 29 0a tory-exists? p).
103c0 09 09 09 20 20 28 6c 65 74 20 28 28 67 6c 6f 62 ... (let ((glob
103d0 2d 71 75 65 72 79 20 28 63 6f 6e 63 20 70 20 22 -query (conc p "
103e0 2f 22 20 66 6e 61 6d 65 70 61 74 74 29 29 29 0a /" fnamepatt))).
103f0 09 09 09 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 ... (handle-e
10400 78 63 65 70 74 69 6f 6e 73 0a 09 09 09 09 65 78 xceptions.....ex
10410 6e 0a 09 09 09 20 20 20 20 20 20 28 62 65 67 69 n.... (begi
10420 6e 0a 09 09 09 09 28 70 72 69 6e 74 20 22 62 75 n.....(print "bu
10430 69 6c 74 2d 69 6e 20 67 6c 6f 62 20 6f 6e 20 22 ilt-in glob on "
10440 20 67 6c 6f 62 2d 71 75 65 72 79 20 22 2c 20 66 glob-query ", f
10450 61 69 6c 65 64 2c 20 74 72 79 20 75 73 69 6e 67 ailed, try using
10460 20 74 68 65 20 73 68 65 6c 6c 2e 20 65 78 6e 3d the shell. exn=
10470 22 20 65 78 6e 29 0a 09 09 09 09 28 77 69 74 68 " exn).....(with
10480 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 -input-from-pipe
10490 0a 09 09 09 09 20 28 63 6f 6e 63 20 22 65 63 68 ..... (conc "ech
104a0 6f 20 22 20 67 6c 6f 62 2d 71 75 65 72 79 29 0a o " glob-query).
104b0 09 09 09 09 20 72 65 61 64 2d 6c 69 6e 65 73 29 .... read-lines)
104c0 29 20 20 3b 3b 20 77 65 20 61 72 65 6e 27 74 20 ) ;; we aren't
104d0 67 6f 69 6e 67 20 74 6f 20 74 72 79 20 74 6f 6f going to try too
104e0 20 68 61 72 64 2e 20 49 66 20 67 6c 6f 62 20 62 hard. If glob b
104f0 72 65 61 6b 73 20 69 74 20 69 73 20 6c 69 6b 65 reaks it is like
10500 6c 79 20 62 65 63 61 75 73 65 20 73 6f 6d 65 6f ly because someo
10510 6e 65 20 74 72 69 65 64 20 74 6f 20 64 6f 20 2a ne tried to do *
10520 2f 2a 2f 2a 2e 6c 6f 67 20 6f 72 20 73 69 6d 69 /*/*.log or simi
10530 6c 61 72 0a 09 09 09 20 20 20 20 20 20 28 67 6c lar.... (gl
10540 6f 62 20 67 6c 6f 62 2d 71 75 65 72 79 29 29 29 ob glob-query)))
10550 0a 09 09 09 20 20 27 28 29 29 29 0a 09 09 20 20 .... '()))...
10560 20 20 70 61 74 68 73 2d 66 72 6f 6d 2d 64 62 29 paths-from-db)
10570 29 0a 09 70 61 74 68 73 2d 66 72 6f 6d 2d 64 62 )..paths-from-db
10580 29 29 29 0a 0a 09 09 09 20 20 20 20 20 20 0a 3b )))..... .;
10590 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
105a0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
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 0a 3b 3b 20 47 61 74 68 65 =======.;; Gathe
105e0 72 20 64 61 74 61 20 66 72 6f 6d 20 74 65 73 74 r data from test
105f0 2f 74 61 73 6b 20 73 70 65 63 69 66 69 63 61 74 /task specificat
10600 69 6f 6e 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d ions.;;=========
10610 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10620 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10630 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10640 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b =============..;
10650 3b 20 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 ; (define (tests
10660 3a 67 65 74 2d 76 61 6c 69 64 2d 74 65 73 74 73 :get-valid-tests
10670 20 74 65 73 74 73 64 69 72 20 74 65 73 74 2d 70 testsdir test-p
10680 61 74 74 73 29 20 3b 3b 20 20 23 21 6b 65 79 20 atts) ;; #!key
10690 28 74 65 73 74 2d 6e 61 6d 65 73 20 27 28 29 29 (test-names '())
106a0 29 0a 3b 3b 20 20 20 28 6c 65 74 20 28 28 74 65 ).;; (let ((te
106b0 73 74 73 20 28 67 6c 6f 62 20 28 63 6f 6e 63 20 sts (glob (conc
106c0 74 65 73 74 73 64 69 72 20 22 2f 74 65 73 74 73 testsdir "/tests
106d0 2f 2a 22 29 29 29 29 20 3b 3b 20 22 20 28 73 74 /*")))) ;; " (st
106e0 72 69 6e 67 2d 74 72 61 6e 73 6c 61 74 65 20 70 ring-translate p
106f0 61 74 74 20 22 25 22 20 22 2a 22 29 29 29 29 29 att "%" "*")))))
10700 0a 3b 3b 20 20 20 20 20 28 73 65 74 21 20 74 65 .;; (set! te
10710 73 74 73 20 28 66 69 6c 74 65 72 20 28 6c 61 6d sts (filter (lam
10720 62 64 61 20 28 74 65 73 74 29 28 63 6f 6d 6d 6f bda (test)(commo
10730 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 28 n:file-exists? (
10740 63 6f 6e 63 20 74 65 73 74 20 22 2f 74 65 73 74 conc test "/test
10750 63 6f 6e 66 69 67 22 29 29 29 20 74 65 73 74 73 config"))) tests
10760 29 29 0a 3b 3b 20 20 20 20 20 28 64 65 6c 65 74 )).;; (delet
10770 65 2d 64 75 70 6c 69 63 61 74 65 73 0a 3b 3b 20 e-duplicates.;;
10780 20 20 20 20 20 28 66 69 6c 74 65 72 20 28 6c 61 (filter (la
10790 6d 62 64 61 20 28 74 65 73 74 6e 61 6d 65 29 0a mbda (testname).
107a0 3b 3b 20 09 20 20 20 20 20 20 20 28 74 65 73 74 ;; . (test
107b0 73 3a 6d 61 74 63 68 20 74 65 73 74 2d 70 61 74 s:match test-pat
107c0 74 73 20 74 65 73 74 6e 61 6d 65 20 23 66 29 29 ts testname #f))
107d0 0a 3b 3b 20 09 20 20 20 20 20 28 6d 61 70 20 28 .;; . (map (
107e0 6c 61 6d 62 64 61 20 28 74 65 73 74 70 29 0a 3b lambda (testp).;
107f0 3b 20 09 09 20 20 20 20 28 6c 61 73 74 20 28 73 ; .. (last (s
10800 74 72 69 6e 67 2d 73 70 6c 69 74 20 74 65 73 74 tring-split test
10810 70 20 22 2f 22 29 29 29 0a 3b 3b 20 09 09 20 20 p "/"))).;; ..
10820 74 65 73 74 73 29 29 29 29 29 0a 0a 28 64 65 66 tests)))))..(def
10830 69 6e 65 20 28 74 65 73 74 73 3a 67 65 74 2d 74 ine (tests:get-t
10840 65 73 74 2d 70 61 74 68 2d 66 72 6f 6d 2d 65 6e est-path-from-en
10850 76 69 72 6f 6e 6d 65 6e 74 29 0a 20 20 28 69 66 vironment). (if
10860 20 28 61 6e 64 20 28 67 65 74 65 6e 76 20 22 4d (and (getenv "M
10870 54 5f 4c 49 4e 4b 54 52 45 45 22 29 0a 09 20 20 T_LINKTREE")..
10880 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 54 41 52 (getenv "MT_TAR
10890 47 45 54 22 29 0a 09 20 20 20 28 67 65 74 65 6e GET").. (geten
108a0 76 20 22 4d 54 5f 52 55 4e 4e 41 4d 45 22 29 0a v "MT_RUNNAME").
108b0 09 20 20 20 28 67 65 74 65 6e 76 20 22 4d 54 5f . (getenv "MT_
108c0 54 45 53 54 5f 4e 41 4d 45 22 29 0a 09 20 20 20 TEST_NAME")..
108d0 28 67 65 74 65 6e 76 20 22 4d 54 5f 49 54 45 4d (getenv "MT_ITEM
108e0 50 41 54 48 22 29 29 0a 20 20 20 20 20 20 28 63 PATH")). (c
108f0 6f 6e 63 20 28 67 65 74 65 6e 76 20 22 4d 54 5f onc (getenv "MT_
10900 4c 49 4e 4b 54 52 45 45 22 29 20 20 22 2f 22 0a LINKTREE") "/".
10910 09 20 20 20 20 28 67 65 74 65 6e 76 20 22 4d 54 . (getenv "MT
10920 5f 54 41 52 47 45 54 22 29 20 20 20 20 22 2f 22 _TARGET") "/"
10930 0a 09 20 20 20 20 28 67 65 74 65 6e 76 20 22 4d .. (getenv "M
10940 54 5f 52 55 4e 4e 41 4d 45 22 29 20 20 20 22 2f T_RUNNAME") "/
10950 22 0a 09 20 20 20 20 28 67 65 74 65 6e 76 20 22 ".. (getenv "
10960 4d 54 5f 54 45 53 54 5f 4e 41 4d 45 22 29 0a 09 MT_TEST_NAME")..
10970 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 67 65 (if (and (ge
10980 74 65 6e 76 20 22 4d 54 5f 49 54 45 4d 50 41 54 tenv "MT_ITEMPAT
10990 48 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 H").
109a0 20 20 20 20 20 20 20 20 20 28 6e 6f 74 20 28 73 (not (s
109b0 74 72 69 6e 67 3d 3f 20 22 22 20 28 67 65 74 65 tring=? "" (gete
109c0 6e 76 20 22 4d 54 5f 49 54 45 4d 50 41 54 48 22 nv "MT_ITEMPATH"
109d0 29 29 29 29 0a 09 09 28 63 6f 6e 63 20 22 2f 22 ))))...(conc "/"
109e0 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 49 54 45 (getenv "MT_ITE
109f0 4d 50 41 54 48 22 29 29 0a 20 20 20 20 20 20 20 MPATH")).
10a00 20 20 20 20 20 20 20 20 20 22 22 29 29 0a 20 20 "")).
10a10 20 20 20 20 23 66 29 29 0a 0a 3b 3b 20 69 66 20 #f))..;; if
10a20 2e 74 65 73 74 63 6f 6e 66 69 67 20 65 78 69 73 .testconfig exis
10a30 74 73 20 69 6e 20 74 65 73 74 20 64 69 72 65 63 ts in test direc
10a40 74 6f 72 79 20 72 65 61 64 20 61 6e 64 20 72 65 tory read and re
10a50 74 75 72 6e 20 69 74 0a 3b 3b 20 65 6c 73 65 20 turn it.;; else
10a60 69 66 20 68 61 76 65 20 63 61 63 68 65 64 20 63 if have cached c
10a70 6f 70 79 20 69 6e 20 2a 74 65 73 74 63 6f 6e 66 opy in *testconf
10a80 69 67 73 2a 20 72 65 74 75 72 6e 20 69 74 20 49 igs* return it I
10a90 46 46 20 74 68 65 72 65 20 69 73 20 61 20 73 65 FF there is a se
10aa0 63 74 69 6f 6e 20 22 68 61 76 65 20 66 75 6c 6c ction "have full
10ab0 64 61 74 61 22 0a 3b 3b 20 65 6c 73 65 20 72 65 data".;; else re
10ac0 61 64 20 74 68 65 20 74 65 73 74 63 6f 6e 66 69 ad the testconfi
10ad0 67 20 66 69 6c 65 0a 3b 3b 20 20 20 69 66 20 68 g file.;; if h
10ae0 61 76 65 20 70 61 74 68 20 74 6f 20 74 65 73 74 ave path to test
10af0 20 64 69 72 65 63 74 6f 72 79 20 73 61 76 65 20 directory save
10b00 74 68 65 20 63 6f 6e 66 69 67 20 61 73 20 2e 74 the config as .t
10b10 65 73 74 63 6f 6e 66 69 67 20 61 6e 64 20 72 65 estconfig and re
10b20 74 75 72 6e 20 69 74 0a 3b 3b 0a 28 64 65 66 69 turn it.;;.(defi
10b30 6e 65 20 28 74 65 73 74 73 3a 67 65 74 2d 74 65 ne (tests:get-te
10b40 73 74 63 6f 6e 66 69 67 20 74 65 73 74 2d 6e 61 stconfig test-na
10b50 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 74 65 73 me item-path tes
10b60 74 2d 72 65 67 69 73 74 72 79 20 73 79 73 74 65 t-registry syste
10b70 6d 2d 61 6c 6c 6f 77 65 64 20 23 21 6b 65 79 20 m-allowed #!key
10b80 28 66 6f 72 63 65 2d 63 72 65 61 74 65 20 23 66 (force-create #f
10b90 29 28 61 6c 6c 6f 77 2d 77 72 69 74 65 2d 63 61 )(allow-write-ca
10ba0 63 68 65 20 23 74 29 28 77 61 69 74 2d 61 2d 6d che #t)(wait-a-m
10bb0 69 6e 75 74 65 20 23 66 29 29 0a 20 20 28 6c 65 inute #f)). (le
10bc0 74 2a 20 28 28 75 73 65 2d 63 61 63 68 65 20 20 t* ((use-cache
10bd0 20 20 28 63 6f 6d 6d 6f 6e 3a 75 73 65 2d 63 61 (common:use-ca
10be0 63 68 65 3f 29 29 0a 09 20 28 63 61 63 68 65 2d che?)).. (cache-
10bf0 70 61 74 68 20 20 20 28 74 65 73 74 73 3a 67 65 path (tests:ge
10c00 74 2d 74 65 73 74 2d 70 61 74 68 2d 66 72 6f 6d t-test-path-from
10c10 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 29 29 0a 09 -environment))..
10c20 20 28 63 61 63 68 65 2d 66 69 6c 65 20 20 20 28 (cache-file (
10c30 61 6e 64 20 63 61 63 68 65 2d 70 61 74 68 20 28 and cache-path (
10c40 63 6f 6e 63 20 63 61 63 68 65 2d 70 61 74 68 20 conc cache-path
10c50 22 2f 2e 74 65 73 74 63 6f 6e 66 69 67 22 29 29 "/.testconfig"))
10c60 29 0a 09 20 28 63 61 63 68 65 2d 65 78 69 73 74 ).. (cache-exist
10c70 73 20 28 61 6e 64 20 63 61 63 68 65 2d 66 69 6c s (and cache-fil
10c80 65 0a 09 09 09 20 20 20 20 28 6e 6f 74 20 66 6f e.... (not fo
10c90 72 63 65 2d 63 72 65 61 74 65 29 20 20 3b 3b 20 rce-create) ;;
10ca0 69 66 20 66 6f 72 63 65 2d 63 72 65 61 74 65 20 if force-create
10cb0 74 68 65 6e 20 70 72 65 74 65 6e 64 20 74 68 65 then pretend the
10cc0 72 65 20 69 73 20 6e 6f 20 63 61 63 68 65 20 74 re is no cache t
10cd0 6f 20 72 65 61 64 0a 09 09 09 20 20 20 20 28 63 o read.... (c
10ce0 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 ommon:file-exist
10cf0 73 3f 20 63 61 63 68 65 2d 66 69 6c 65 29 29 29 s? cache-file)))
10d00 0a 09 20 28 63 61 63 68 65 64 2d 64 61 74 20 20 .. (cached-dat
10d10 20 28 69 66 20 28 61 6e 64 20 28 6e 6f 74 20 66 (if (and (not f
10d20 6f 72 63 65 2d 63 72 65 61 74 65 29 0a 09 09 09 orce-create)....
10d30 09 63 61 63 68 65 2d 65 78 69 73 74 73 0a 09 09 .cache-exists...
10d40 09 09 75 73 65 2d 63 61 63 68 65 29 0a 09 09 09 ..use-cache)....
10d50 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 (handle-excep
10d60 74 69 6f 6e 73 0a 09 09 09 20 20 20 20 20 20 20 tions....
10d70 65 78 6e 0a 09 09 09 20 20 20 20 20 28 62 65 67 exn.... (beg
10d80 69 6e 0a 09 09 09 20 20 20 20 20 20 20 28 64 65 in.... (de
10d90 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
10da0 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
10db0 66 61 69 6c 65 64 20 74 6f 20 72 65 61 64 20 22 failed to read "
10dc0 20 63 61 63 68 65 2d 66 69 6c 65 20 22 2c 20 65 cache-file ", e
10dd0 78 6e 3d 22 20 65 78 6e 29 0a 09 09 09 20 20 20 xn=" exn)....
10de0 20 20 20 20 23 66 29 20 3b 3b 20 61 6e 79 20 69 #f) ;; any i
10df0 73 73 75 65 73 2c 20 6a 75 73 74 20 67 69 76 65 ssues, just give
10e00 20 75 70 20 77 69 74 68 20 74 68 65 20 63 61 63 up with the cac
10e10 68 65 64 20 76 65 72 73 69 6f 6e 20 61 6e 64 20 hed version and
10e20 72 65 2d 72 65 61 64 0a 09 09 09 20 20 20 20 20 re-read....
10e30 28 63 6f 6e 66 69 67 66 3a 72 65 61 64 2d 61 6c (configf:read-al
10e40 69 73 74 20 63 61 63 68 65 2d 66 69 6c 65 29 29 ist cache-file))
10e50 0a 09 09 09 20 20 20 23 66 29 29 0a 20 20 20 20 .... #f)).
10e60 20 20 20 20 20 28 74 65 73 74 2d 66 75 6c 6c 2d (test-full-
10e70 6e 61 6d 65 20 28 69 66 20 28 61 6e 64 20 69 74 name (if (and it
10e80 65 6d 2d 70 61 74 68 20 28 6e 6f 74 20 28 73 74 em-path (not (st
10e90 72 69 6e 67 2d 6e 75 6c 6c 3f 20 69 74 65 6d 2d ring-null? item-
10ea0 70 61 74 68 29 29 29 0a 20 20 20 20 20 20 20 20 path))).
10eb0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
10ec0 20 20 20 20 20 28 63 6f 6e 63 20 74 65 73 74 2d (conc test-
10ed0 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 name "/" item-pa
10ee0 74 68 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 th).
10ef0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
10f00 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a 20 20 test-name))).
10f10 20 20 28 69 66 20 63 61 63 68 65 64 2d 64 61 74 (if cached-dat
10f20 0a 09 63 61 63 68 65 64 2d 64 61 74 0a 09 28 6c ..cached-dat..(l
10f30 65 74 20 28 28 64 61 74 20 28 68 61 73 68 2d 74 et ((dat (hash-t
10f40 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
10f50 20 2a 74 65 73 74 63 6f 6e 66 69 67 73 2a 20 74 *testconfigs* t
10f60 65 73 74 2d 66 75 6c 6c 2d 6e 61 6d 65 20 23 66 est-full-name #f
10f70 29 29 29 0a 09 20 20 28 69 66 20 28 61 6e 64 20 ))).. (if (and
10f80 20 64 61 74 20 3b 3b 20 68 61 76 65 20 61 20 6c dat ;; have a l
10f90 6f 63 61 6c 6c 79 20 63 61 63 68 65 64 20 76 65 ocally cached ve
10fa0 72 73 69 6f 6e 0a 09 09 20 20 20 20 28 68 61 73 rsion... (has
10fb0 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
10fc0 75 6c 74 20 64 61 74 20 22 68 61 76 65 20 66 75 ult dat "have fu
10fd0 6c 6c 64 61 74 61 22 20 23 66 29 29 20 3b 3b 20 lldata" #f)) ;;
10fe0 6d 61 72 6b 65 64 20 61 73 20 67 6f 6f 64 20 64 marked as good d
10ff0 61 74 61 3f 0a 09 20 20 20 20 20 20 64 61 74 0a ata?.. dat.
11000 09 20 20 20 20 20 20 3b 3b 20 6e 6f 20 63 61 63 . ;; no cac
11010 68 65 64 20 64 61 74 61 20 61 76 61 69 6c 61 62 hed data availab
11020 6c 65 0a 09 20 20 20 20 20 20 28 6c 65 74 2a 20 le.. (let*
11030 28 28 74 72 65 67 20 20 20 20 20 20 20 20 20 28 ((treg (
11040 6f 72 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 or test-registry
11050 0a 09 09 09 09 20 20 20 20 20 20 20 28 74 65 73 ..... (tes
11060 74 73 3a 67 65 74 2d 61 6c 6c 29 29 29 0a 09 09 ts:get-all)))...
11070 20 20 20 20 20 28 74 65 73 74 2d 70 61 74 68 20 (test-path
11080 20 20 20 28 6f 72 20 28 68 61 73 68 2d 74 61 62 (or (hash-tab
11090 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 le-ref/default t
110a0 72 65 67 20 74 65 73 74 2d 6e 61 6d 65 20 23 66 reg test-name #f
110b0 29 0a 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 28 6c 65 74 2a 20 28 (let* (
110e0 28 6c 6f 63 61 6c 2d 74 63 64 69 72 20 28 63 6f (local-tcdir (co
110f0 6e 63 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 4c nc (getenv "MT_L
11100 49 4e 4b 54 52 45 45 22 29 20 22 2f 22 0a 20 20 INKTREE") "/".
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 20 20 20 20 20 20 20 28 (
11150 67 65 74 65 6e 76 20 22 4d 54 5f 54 41 52 47 45 getenv "MT_TARGE
11160 54 22 29 20 22 2f 22 0a 20 20 20 20 20 20 20 20 T") "/".
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 20 20 20 20 20 20 28 67 65 74 65 6e 76 (getenv
111b0 20 22 4d 54 5f 52 55 4e 4e 41 4d 45 22 29 20 22 "MT_RUNNAME") "
111c0 2f 22 0a 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 20 20 20 20 20
111f0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11200 20 20 20 20 74 65 73 74 2d 6e 61 6d 65 20 22 2f test-name "/
11210 22 20 69 74 65 6d 2d 70 61 74 68 29 29 0a 20 20 " item-path)).
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 20 20 20 20 20 20 20 20 20 28 6c 6f 63 (loc
11250 61 6c 2d 74 63 66 67 20 28 63 6f 6e 63 20 6c 6f al-tcfg (conc lo
11260 63 61 6c 2d 74 63 64 69 72 20 22 2f 74 65 73 74 cal-tcdir "/test
11270 63 6f 6e 66 69 67 22 29 29 29 0a 20 20 20 20 20 config"))).
11280 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11290 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
112a0 20 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a (if (common:
112b0 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 6c 6f 63 file-exists? loc
112c0 61 6c 2d 74 63 66 67 29 0a 20 20 20 20 20 20 20 al-tcfg).
112d0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
112e0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
112f0 20 20 20 20 20 20 6c 6f 63 61 6c 2d 74 63 64 69 local-tcdi
11300 72 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 r.
11310 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11320 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 23 #
11330 66 29 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 f))..... (
11340 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 conc *toppath* "
11350 2f 74 65 73 74 73 2f 22 20 74 65 73 74 2d 6e 61 /tests/" test-na
11360 6d 65 29 29 29 0a 09 09 20 20 20 20 20 28 74 65 me)))... (te
11370 73 74 2d 63 6f 6e 66 69 67 66 20 28 63 6f 6e 63 st-configf (conc
11380 20 74 65 73 74 2d 70 61 74 68 20 22 2f 74 65 73 test-path "/tes
11390 74 63 6f 6e 66 69 67 22 29 29 0a 09 09 20 20 20 tconfig"))...
113a0 20 20 28 74 65 73 74 65 78 69 73 74 73 20 20 20 (testexists
113b0 28 6c 65 74 20 6c 6f 6f 70 61 20 28 28 74 72 69 (let loopa ((tri
113c0 65 73 2d 6c 65 66 74 20 33 30 29 29 0a 20 20 20 es-left 30)).
113d0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
113e0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
113f0 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 20 20 20 (cond.
11400 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11410 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 0a (.
11420 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
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 28 61 6e 64 20 28 63 6f 6d (and (com
11450 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f mon:file-exists?
11460 20 74 65 73 74 2d 63 6f 6e 66 69 67 66 29 28 66 test-configf)(f
11470 69 6c 65 2d 72 65 61 64 2d 61 63 63 65 73 73 3f ile-read-access?
11480 20 74 65 73 74 2d 63 6f 6e 66 69 67 66 29 29 0a test-configf)).
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 20 20 20 20 20 20 20
114b0 20 20 20 20 20 20 20 23 74 29 0a 20 20 20 20 20 #t).
114c0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
114d0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
114e0 20 28 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 (.
114f0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11500 20 20 20 20 20 20 20 20 20 20 28 63 6f 6d 6d 6f (commo
11510 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 74 n:file-exists? t
11520 65 73 74 2d 63 6f 6e 66 69 67 66 29 0a 20 20 20 est-configf).
11530 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11540 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11550 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
11560 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
11570 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 port* "WARNING:
11580 43 61 6e 6e 6f 74 20 72 65 61 64 20 74 65 73 74 Cannot read test
11590 63 6f 6e 66 69 67 20 66 69 6c 65 3a 20 22 74 65 config file: "te
115a0 73 74 2d 63 6f 6e 66 69 67 66 29 0a 20 20 20 20 st-configf).
115b0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
115c0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
115d0 20 20 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 #f).
115e0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
115f0 20 20 20 20 20 20 20 20 20 20 20 20 20 28 0a 20 (.
11600 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11610 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11620 20 20 20 20 20 20 28 61 6e 64 20 77 61 69 74 2d (and wait-
11630 61 2d 6d 69 6e 75 74 65 20 28 3e 20 74 72 69 65 a-minute (> trie
11640 73 2d 6c 65 66 74 20 30 29 29 0a 20 20 20 20 20 s-left 0)).
11650 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11660 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11670 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
11680 20 31 30 29 0a 20 20 20 20 20 20 20 20 20 20 20 10).
11690 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
116a0 20 20 20 20 20 20 20 20 20 20 20 20 28 64 65 62 (deb
116b0 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
116c0 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 ult-log-port* "W
116d0 41 52 4e 49 4e 47 3a 20 74 65 73 74 63 6f 6e 66 ARNING: testconf
116e0 69 67 20 66 69 6c 65 20 64 6f 65 73 20 6e 6f 74 ig file does not
116f0 20 65 78 69 73 74 3a 20 22 74 65 73 74 2d 63 6f exist: "test-co
11700 6e 66 69 67 66 22 20 77 69 6c 6c 20 72 65 74 72 nfigf" will retr
11710 79 20 69 6e 20 31 30 20 73 65 63 6f 6e 64 73 2e y in 10 seconds.
11720 20 20 54 72 69 65 73 20 6c 65 66 74 3a 20 22 74 Tries left: "t
11730 72 69 65 73 2d 6c 65 66 74 29 20 3b 3b 20 42 42 ries-left) ;; BB
11740 3a 20 74 68 69 73 20 66 69 72 65 73 0a 20 20 20 : this fires.
11750 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11760 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11770 20 20 20 20 28 6c 6f 6f 70 61 20 28 73 75 62 31 (loopa (sub1
11780 20 74 72 69 65 73 2d 6c 65 66 74 29 29 29 0a 20 tries-left))).
11790 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
117a0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
117b0 20 20 20 20 20 28 65 6c 73 65 0a 20 20 20 20 20 (else.
117c0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
117d0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
117e0 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 (debug:print 2
117f0 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
11800 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 74 65 rt* "WARNING: te
11810 73 74 63 6f 6e 66 69 67 20 66 69 6c 65 20 64 6f stconfig file do
11820 65 73 20 6e 6f 74 20 65 78 69 73 74 3a 20 22 74 es not exist: "t
11830 65 73 74 2d 63 6f 6e 66 69 67 66 29 20 3b 3b 20 est-configf) ;;
11840 42 42 3a 20 74 68 69 73 20 66 69 72 65 73 0a 20 BB: this fires.
11850 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11860 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11870 20 20 20 20 20 20 23 66 29 29 29 29 0a 09 09 20 #f))))...
11880 20 20 20 20 28 74 63 66 67 20 20 20 20 20 20 20 (tcfg
11890 20 20 28 69 66 20 74 65 73 74 65 78 69 73 74 73 (if testexists
118a0 0a 09 09 09 09 20 20 20 20 20 20 20 28 72 65 61 ..... (rea
118b0 64 2d 63 6f 6e 66 69 67 20 74 65 73 74 2d 63 6f d-config test-co
118c0 6e 66 69 67 66 20 23 66 20 73 79 73 74 65 6d 2d nfigf #f system-
118d0 61 6c 6c 6f 77 65 64 0a 09 09 09 09 09 09 20 20 allowed.......
118e0 20 20 65 6e 76 69 72 6f 6e 2d 70 61 74 74 3a 20 environ-patt:
118f0 28 69 66 20 73 79 73 74 65 6d 2d 61 6c 6c 6f 77 (if system-allow
11900 65 64 0a 09 09 09 09 09 09 09 09 20 20 20 20 20 ed.........
11910 20 22 70 72 65 2d 6c 61 75 6e 63 68 2d 65 6e 76 "pre-launch-env
11920 2d 76 61 72 73 22 0a 09 09 09 09 09 09 09 09 20 -vars".........
11930 20 20 20 20 20 23 66 29 29 0a 09 09 09 09 20 20 #f)).....
11940 20 20 20 20 20 23 66 29 29 29 0a 09 09 28 69 66 #f)))...(if
11950 20 28 61 6e 64 20 74 63 66 67 20 63 61 63 68 65 (and tcfg cache
11960 2d 66 69 6c 65 29 20 28 68 61 73 68 2d 74 61 62 -file) (hash-tab
11970 6c 65 2d 73 65 74 21 20 74 63 66 67 20 22 68 61 le-set! tcfg "ha
11980 76 65 20 66 75 6c 6c 64 61 74 61 22 20 23 74 29 ve fulldata" #t)
11990 29 20 3b 3b 20 6d 61 72 6b 20 74 68 69 73 20 61 ) ;; mark this a
119a0 73 20 66 75 6c 6c 79 20 72 65 61 64 20 64 61 74 s fully read dat
119b0 61 0a 09 09 28 69 66 20 74 63 66 67 20 28 68 61 a...(if tcfg (ha
119c0 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a 74 sh-table-set! *t
119d0 65 73 74 63 6f 6e 66 69 67 73 2a 20 74 65 73 74 estconfigs* test
119e0 2d 66 75 6c 6c 2d 6e 61 6d 65 20 74 63 66 67 29 -full-name tcfg)
119f0 29 0a 09 09 28 69 66 20 28 61 6e 64 20 74 65 73 )...(if (and tes
11a00 74 65 78 69 73 74 73 0a 09 09 09 20 63 61 63 68 texists.... cach
11a10 65 2d 66 69 6c 65 0a 09 09 09 20 28 66 69 6c 65 e-file.... (file
11a20 2d 77 72 69 74 65 2d 61 63 63 65 73 73 3f 20 63 -write-access? c
11a30 61 63 68 65 2d 70 61 74 68 29 0a 09 09 09 20 61 ache-path).... a
11a40 6c 6c 6f 77 2d 77 72 69 74 65 2d 63 61 63 68 65 llow-write-cache
11a50 29 0a 09 09 20 20 20 20 28 6c 65 74 20 28 28 74 )... (let ((t
11a60 70 61 74 68 20 28 63 6f 6e 63 20 63 61 63 68 65 path (conc cache
11a70 2d 70 61 74 68 20 22 2f 2e 74 65 73 74 63 6f 6e -path "/.testcon
11a80 66 69 67 22 29 29 29 0a 09 09 20 20 20 20 20 20 fig")))...
11a90 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
11aa0 6f 20 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 1 *default-log
11ab0 2d 70 6f 72 74 2a 20 22 43 61 63 68 69 6e 67 20 -port* "Caching
11ac0 74 65 73 74 63 6f 6e 66 69 67 20 66 6f 72 20 22 testconfig for "
11ad0 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 69 6e 20 test-name " in
11ae0 22 20 74 70 61 74 68 29 0a 20 20 20 20 20 20 20 " tpath).
11af0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
11b00 69 66 20 28 61 6e 64 20 74 63 66 67 20 28 6e 6f if (and tcfg (no
11b10 74 20 28 63 6f 6d 6d 6f 6e 3a 69 6e 2d 72 75 6e t (common:in-run
11b20 6e 69 6e 67 2d 74 65 73 74 3f 29 29 29 0a 20 20 ning-test?))).
11b30 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11b40 20 20 20 20 20 20 20 20 28 63 6f 6e 66 69 67 66 (configf
11b50 3a 77 72 69 74 65 2d 61 6c 69 73 74 20 74 63 66 :write-alist tcf
11b60 67 20 74 70 61 74 68 29 29 29 29 0a 09 09 74 63 g tpath))))...tc
11b70 66 67 29 29 29 29 29 29 0a 20 20 0a 3b 3b 20 73 fg)))))). .;; s
11b80 6f 72 74 20 74 65 73 74 73 20 62 79 20 70 72 69 ort tests by pri
11b90 6f 72 69 74 79 20 61 6e 64 20 77 61 69 74 6f 6e ority and waiton
11ba0 0a 3b 3b 20 4d 6f 76 65 20 74 65 73 74 20 73 70 .;; Move test sp
11bb0 65 63 69 66 69 63 20 73 74 75 66 66 20 74 6f 20 ecific stuff to
11bc0 61 20 74 65 73 74 20 75 6e 69 74 20 46 49 58 4d a test unit FIXM
11bd0 45 20 6f 6e 65 20 6f 66 20 74 68 65 73 65 20 64 E one of these d
11be0 61 79 73 0a 28 64 65 66 69 6e 65 20 28 74 65 73 ays.(define (tes
11bf0 74 73 3a 73 6f 72 74 2d 62 79 2d 70 72 69 6f 72 ts:sort-by-prior
11c00 69 74 79 2d 61 6e 64 2d 77 61 69 74 6f 6e 20 74 ity-and-waiton t
11c10 65 73 74 2d 72 65 63 6f 72 64 73 29 0a 20 20 28 est-records). (
11c20 69 66 20 28 65 71 3f 20 28 68 61 73 68 2d 74 61 if (eq? (hash-ta
11c30 62 6c 65 2d 73 69 7a 65 20 74 65 73 74 2d 72 65 ble-size test-re
11c40 63 6f 72 64 73 29 20 30 29 0a 20 20 20 20 20 20 cords) 0).
11c50 27 28 29 0a 20 20 20 20 20 20 28 6c 65 74 2a 20 '(). (let*
11c60 28 28 6d 75 6e 67 65 70 72 69 6f 72 69 74 79 20 ((mungepriority
11c70 28 6c 61 6d 62 64 61 20 28 70 72 69 6f 72 69 74 (lambda (priorit
11c80 79 29 0a 09 09 09 20 20 20 20 20 20 28 69 66 20 y).... (if
11c90 70 72 69 6f 72 69 74 79 0a 09 09 09 09 20 20 28 priority..... (
11ca0 6c 65 74 20 28 28 74 6d 70 20 28 61 6e 79 2d 3e let ((tmp (any->
11cb0 6e 75 6d 62 65 72 20 70 72 69 6f 72 69 74 79 29 number priority)
11cc0 29 29 0a 09 09 09 09 20 20 20 20 28 69 66 20 74 ))..... (if t
11cd0 6d 70 20 74 6d 70 20 28 62 65 67 69 6e 20 28 64 mp tmp (begin (d
11ce0 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 ebug:print-error
11cf0 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
11d00 70 6f 72 74 2a 20 22 62 61 64 20 70 72 69 6f 72 port* "bad prior
11d10 69 74 79 20 76 61 6c 75 65 20 22 20 70 72 69 6f ity value " prio
11d20 72 69 74 79 20 22 2c 20 75 73 69 6e 67 20 30 22 rity ", using 0"
11d30 29 20 30 29 29 29 0a 09 09 09 09 20 20 30 29 29 ) 0)))..... 0))
11d40 29 0a 09 20 20 20 20 20 28 61 6c 6c 2d 74 65 73 ).. (all-tes
11d50 74 73 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 ts (hash-ta
11d60 62 6c 65 2d 6b 65 79 73 20 74 65 73 74 2d 72 65 ble-keys test-re
11d70 63 6f 72 64 73 29 29 0a 09 20 20 20 20 20 28 61 cords)).. (a
11d80 6c 6c 2d 77 61 69 74 65 64 2d 6f 6e 20 20 28 6c ll-waited-on (l
11d90 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 et loop ((hed (c
11da0 61 72 20 61 6c 6c 2d 74 65 73 74 73 29 29 0a 09 ar all-tests))..
11db0 09 09 09 09 28 74 61 6c 20 28 63 64 72 20 61 6c ....(tal (cdr al
11dc0 6c 2d 74 65 73 74 73 29 29 0a 09 09 09 09 09 28 l-tests))......(
11dd0 72 65 73 20 27 28 29 29 29 0a 09 09 09 20 20 20 res '()))....
11de0 20 20 20 20 28 6c 65 74 2a 20 28 28 74 72 65 63 (let* ((trec
11df0 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
11e00 72 65 66 20 74 65 73 74 2d 72 65 63 6f 72 64 73 ref test-records
11e10 20 68 65 64 29 29 0a 09 09 09 09 20 20 20 20 20 hed)).....
11e20 20 28 77 61 69 74 6f 6e 73 20 28 6f 72 20 28 74 (waitons (or (t
11e30 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 ests:testqueue-g
11e40 65 74 2d 77 61 69 74 6f 6e 73 20 74 72 65 63 29 et-waitons trec)
11e50 20 27 28 29 29 29 29 0a 09 09 09 09 20 28 69 66 '())))..... (if
11e60 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 09 (null? tal)....
11e70 09 20 20 20 20 20 28 61 70 70 65 6e 64 20 72 65 . (append re
11e80 73 20 77 61 69 74 6f 6e 73 29 0a 09 09 09 09 20 s waitons).....
11e90 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 (loop (car t
11ea0 61 6c 29 28 63 64 72 20 74 61 6c 29 28 61 70 70 al)(cdr tal)(app
11eb0 65 6e 64 20 72 65 73 20 77 61 69 74 6f 6e 73 29 end res waitons)
11ec0 29 29 29 29 29 0a 09 20 20 20 20 20 28 73 6f 72 ))))).. (sor
11ed0 74 2d 66 6e 31 20 0a 09 20 20 20 20 20 20 28 6c t-fn1 .. (l
11ee0 61 6d 62 64 61 20 28 61 20 62 29 0a 09 09 28 6c ambda (a b)...(l
11ef0 65 74 2a 20 28 28 61 2d 72 65 63 6f 72 64 20 20 et* ((a-record
11f00 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
11f10 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 61 29 test-records a)
11f20 29 0a 09 09 20 20 20 20 20 20 20 28 62 2d 72 65 )... (b-re
11f30 63 6f 72 64 20 20 20 28 68 61 73 68 2d 74 61 62 cord (hash-tab
11f40 6c 65 2d 72 65 66 20 74 65 73 74 2d 72 65 63 6f le-ref test-reco
11f50 72 64 73 20 62 29 29 0a 09 09 20 20 20 20 20 20 rds b))...
11f60 20 28 61 2d 77 61 69 74 6f 6e 73 20 20 28 6f 72 (a-waitons (or
11f70 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 (tests:testqueu
11f80 65 2d 67 65 74 2d 77 61 69 74 6f 6e 73 20 61 2d e-get-waitons a-
11f90 72 65 63 6f 72 64 29 20 27 28 29 29 29 0a 09 09 record) '()))...
11fa0 20 20 20 20 20 20 20 28 62 2d 77 61 69 74 6f 6e (b-waiton
11fb0 73 20 20 28 6f 72 20 28 74 65 73 74 73 3a 74 65 s (or (tests:te
11fc0 73 74 71 75 65 75 65 2d 67 65 74 2d 77 61 69 74 stqueue-get-wait
11fd0 6f 6e 73 20 62 2d 72 65 63 6f 72 64 29 20 27 28 ons b-record) '(
11fe0 29 29 29 0a 09 09 20 20 20 20 20 20 20 28 61 2d )))... (a-
11ff0 63 6f 6e 66 69 67 20 20 20 28 74 65 73 74 73 3a config (tests:
12000 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 testqueue-get-te
12010 73 74 63 6f 6e 66 69 67 20 20 61 2d 72 65 63 6f stconfig a-reco
12020 72 64 29 29 0a 09 09 20 20 20 20 20 20 20 28 62 rd))... (b
12030 2d 63 6f 6e 66 69 67 20 20 20 28 74 65 73 74 73 -config (tests
12040 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 74 :testqueue-get-t
12050 65 73 74 63 6f 6e 66 69 67 20 20 62 2d 72 65 63 estconfig b-rec
12060 6f 72 64 29 29 0a 09 09 20 20 20 20 20 20 20 28 ord))... (
12070 61 2d 72 61 77 2d 70 72 69 20 20 28 63 6f 6e 66 a-raw-pri (conf
12080 69 67 66 3a 6c 6f 6f 6b 75 70 20 61 2d 63 6f 6e igf:lookup a-con
12090 66 69 67 20 22 72 65 71 75 69 72 65 6d 65 6e 74 fig "requirement
120a0 73 22 20 22 70 72 69 6f 72 69 74 79 22 29 29 0a s" "priority")).
120b0 09 09 20 20 20 20 20 20 20 28 62 2d 72 61 77 2d .. (b-raw-
120c0 70 72 69 20 20 28 63 6f 6e 66 69 67 66 3a 6c 6f pri (configf:lo
120d0 6f 6b 75 70 20 62 2d 63 6f 6e 66 69 67 20 22 72 okup b-config "r
120e0 65 71 75 69 72 65 6d 65 6e 74 73 22 20 22 70 72 equirements" "pr
120f0 69 6f 72 69 74 79 22 29 29 0a 09 09 20 20 20 20 iority"))...
12100 20 20 20 28 61 2d 70 72 69 6f 72 69 74 79 20 28 (a-priority (
12110 6d 75 6e 67 65 70 72 69 6f 72 69 74 79 20 61 2d mungepriority a-
12120 72 61 77 2d 70 72 69 29 29 0a 09 09 20 20 20 20 raw-pri))...
12130 20 20 20 28 62 2d 70 72 69 6f 72 69 74 79 20 28 (b-priority (
12140 6d 75 6e 67 65 70 72 69 6f 72 69 74 79 20 62 2d mungepriority b-
12150 72 61 77 2d 70 72 69 29 29 29 0a 09 09 20 20 28 raw-pri)))... (
12160 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d tests:testqueue-
12170 73 65 74 2d 70 72 69 6f 72 69 74 79 21 20 61 2d set-priority! a-
12180 72 65 63 6f 72 64 20 61 2d 70 72 69 6f 72 69 74 record a-priorit
12190 79 29 0a 09 09 20 20 28 74 65 73 74 73 3a 74 65 y)... (tests:te
121a0 73 74 71 75 65 75 65 2d 73 65 74 2d 70 72 69 6f stqueue-set-prio
121b0 72 69 74 79 21 20 62 2d 72 65 63 6f 72 64 20 62 rity! b-record b
121c0 2d 70 72 69 6f 72 69 74 79 29 0a 09 09 20 20 3b -priority)... ;
121d0 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 ; (debug:print 0
121e0 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
121f0 72 74 2a 20 22 61 3d 22 20 61 20 22 2c 20 62 3d rt* "a=" a ", b=
12200 22 20 62 20 22 2c 20 61 2d 77 61 69 74 6f 6e 73 " b ", a-waitons
12210 3d 22 20 61 2d 77 61 69 74 6f 6e 73 20 22 2c 20 =" a-waitons ",
12220 62 2d 77 61 69 74 6f 6e 73 3d 22 20 62 2d 77 61 b-waitons=" b-wa
12230 69 74 6f 6e 73 29 0a 09 09 20 20 28 63 6f 6e 64 itons)... (cond
12240 0a 09 09 20 20 20 3b 3b 20 69 73 20 0a 09 09 20 ... ;; is ...
12250 20 20 28 28 6d 65 6d 62 65 72 20 61 20 62 2d 77 ((member a b-w
12260 61 69 74 6f 6e 73 29 20 20 20 20 20 20 20 20 20 aitons)
12270 20 3b 3b 20 69 73 20 62 20 77 61 69 74 69 6e 67 ;; is b waiting
12280 20 6f 6e 20 61 3f 0a 09 09 20 20 20 20 3b 3b 20 on a?... ;;
12290 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
122a0 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
122b0 2a 20 22 63 61 73 65 31 22 29 0a 09 09 20 20 20 * "case1")...
122c0 20 23 74 29 0a 09 09 20 20 20 28 28 6d 65 6d 62 #t)... ((memb
122d0 65 72 20 62 20 61 2d 77 61 69 74 6f 6e 73 29 20 er b a-waitons)
122e0 20 20 20 20 20 20 20 20 20 3b 3b 20 69 73 20 61 ;; is a
122f0 20 77 61 69 74 69 6e 67 20 6f 6e 20 62 3f 0a 09 waiting on b?..
12300 09 20 20 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 . ;; (debug:p
12310 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
12320 6c 6f 67 2d 70 6f 72 74 2a 20 22 63 61 73 65 32 log-port* "case2
12330 22 29 0a 09 09 20 20 20 20 23 66 29 0a 09 09 20 ")... #f)...
12340 20 20 28 28 61 6e 64 20 28 6e 6f 74 20 28 6e 75 ((and (not (nu
12350 6c 6c 3f 20 61 2d 77 61 69 74 6f 6e 73 29 29 20 ll? a-waitons))
12360 20 3b 3b 20 62 6f 74 68 20 68 61 76 65 20 77 61 ;; both have wa
12370 69 74 6f 6e 73 20 2d 20 64 6f 20 6e 6f 74 20 64 itons - do not d
12380 69 73 74 75 72 62 0a 09 09 09 20 28 6e 6f 74 20 isturb.... (not
12390 28 6e 75 6c 6c 3f 20 62 2d 77 61 69 74 6f 6e 73 (null? b-waitons
123a0 29 29 29 0a 09 09 20 20 20 20 3b 3b 20 28 64 65 )))... ;; (de
123b0 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
123c0 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
123d0 63 61 73 65 32 2e 31 22 29 0a 09 09 20 20 20 20 case2.1")...
123e0 23 74 29 0a 09 09 20 20 20 28 28 61 6e 64 20 28 #t)... ((and (
123f0 6e 75 6c 6c 3f 20 61 2d 77 61 69 74 6f 6e 73 29 null? a-waitons)
12400 20 20 20 20 20 20 20 20 3b 3b 20 6e 6f 20 77 61 ;; no wa
12410 69 74 6f 6e 73 20 66 6f 72 20 61 20 62 75 74 20 itons for a but
12420 62 20 68 61 73 20 77 61 69 74 6f 6e 73 0a 09 09 b has waitons...
12430 09 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 62 2d . (not (null? b-
12440 77 61 69 74 6f 6e 73 29 29 29 0a 09 09 20 20 20 waitons)))...
12450 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ;; (debug:print
12460 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
12470 70 6f 72 74 2a 20 22 63 61 73 65 33 22 29 0a 09 port* "case3")..
12480 09 20 20 20 20 23 66 29 0a 09 09 20 20 20 28 28 . #f)... ((
12490 61 6e 64 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 and (not (null?
124a0 61 2d 77 61 69 74 6f 6e 73 29 29 20 20 3b 3b 20 a-waitons)) ;;
124b0 61 20 68 61 73 20 77 61 69 74 6f 6e 73 20 62 75 a has waitons bu
124c0 74 20 62 20 64 6f 65 73 20 6e 6f 74 0a 09 09 09 t b does not....
124d0 20 28 6e 75 6c 6c 3f 20 62 2d 77 61 69 74 6f 6e (null? b-waiton
124e0 73 29 29 20 0a 09 09 20 20 20 20 3b 3b 20 28 64 s)) ... ;; (d
124f0 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
12500 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
12510 22 63 61 73 65 34 22 29 0a 09 09 20 20 20 20 23 "case4")... #
12520 74 29 0a 09 09 20 20 20 28 28 6e 6f 74 20 28 65 t)... ((not (e
12530 71 3f 20 61 2d 70 72 69 6f 72 69 74 79 20 62 2d q? a-priority b-
12540 70 72 69 6f 72 69 74 79 29 29 20 3b 3b 20 75 73 priority)) ;; us
12550 65 0a 09 09 20 20 20 20 28 3e 20 61 2d 70 72 69 e... (> a-pri
12560 6f 72 69 74 79 20 62 2d 70 72 69 6f 72 69 74 79 ority b-priority
12570 29 29 0a 09 09 20 20 20 28 65 6c 73 65 0a 09 09 ))... (else...
12580 20 20 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 ;; (debug:pr
12590 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
125a0 6f 67 2d 70 6f 72 74 2a 20 22 63 61 73 65 35 22 og-port* "case5"
125b0 29 0a 09 09 20 20 20 20 28 73 74 72 69 6e 67 3e )... (string>
125c0 3f 20 61 20 62 29 29 29 29 29 29 0a 09 20 20 20 ? a b))))))..
125d0 20 20 0a 09 20 20 20 20 20 28 73 6f 72 74 2d 66 .. (sort-f
125e0 6e 32 0a 09 20 20 20 20 20 20 28 6c 61 6d 62 64 n2.. (lambd
125f0 61 20 28 61 20 62 29 0a 09 09 28 3e 20 28 6d 75 a (a b)...(> (mu
12600 6e 67 65 70 72 69 6f 72 69 74 79 20 28 74 65 73 ngepriority (tes
12610 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 ts:testqueue-get
12620 2d 70 72 69 6f 72 69 74 79 20 28 68 61 73 68 2d -priority (hash-
12630 74 61 62 6c 65 2d 72 65 66 20 74 65 73 74 2d 72 table-ref test-r
12640 65 63 6f 72 64 73 20 61 29 29 29 0a 09 09 20 20 ecords a)))...
12650 20 28 6d 75 6e 67 65 70 72 69 6f 72 69 74 79 20 (mungepriority
12660 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 (tests:testqueue
12670 2d 67 65 74 2d 70 72 69 6f 72 69 74 79 20 28 68 -get-priority (h
12680 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 74 65 ash-table-ref te
12690 73 74 2d 72 65 63 6f 72 64 73 20 62 29 29 29 29 st-records b))))
126a0 29 29 29 0a 09 3b 3b 20 28 6c 65 74 20 28 28 64 )))..;; (let ((d
126b0 6f 74 2d 72 65 73 20 28 74 65 73 74 73 3a 72 75 ot-res (tests:ru
126c0 6e 2d 64 6f 74 20 28 74 65 73 74 73 3a 74 65 73 n-dot (tests:tes
126d0 74 73 2d 3e 64 6f 74 20 74 65 73 74 2d 72 65 63 ts->dot test-rec
126e0 6f 72 64 73 29 20 22 70 6c 61 69 6e 22 29 29 29 ords) "plain")))
126f0 0a 09 3b 3b 20 20 20 28 64 65 62 75 67 3a 70 72 ..;; (debug:pr
12700 69 6e 74 20 22 64 6f 74 2d 72 65 73 3d 22 20 64 int "dot-res=" d
12710 6f 74 2d 72 65 73 29 29 0a 09 3b 3b 20 28 6c 65 ot-res))..;; (le
12720 74 20 28 28 64 61 74 61 20 28 6d 61 70 20 63 64 t ((data (map cd
12730 72 20 28 66 69 6c 74 65 72 0a 09 3b 3b 20 20 20 r (filter..;;
12740 20 20 09 09 20 20 28 6c 61 6d 62 64 61 20 28 78 .. (lambda (x
12750 29 28 65 71 75 61 6c 3f 20 22 6e 6f 64 65 22 20 )(equal? "node"
12760 28 63 61 72 20 78 29 29 29 0a 09 3b 3b 20 20 20 (car x)))..;;
12770 20 20 09 09 20 20 28 6d 61 70 20 73 74 72 69 6e .. (map strin
12780 67 2d 73 70 6c 69 74 20 28 74 65 73 74 73 3a 65 g-split (tests:e
12790 61 73 79 2d 64 6f 74 20 74 65 73 74 2d 72 65 63 asy-dot test-rec
127a0 6f 72 64 73 20 22 70 6c 61 69 6e 22 29 29 29 29 ords "plain"))))
127b0 29 29 0a 09 3b 3b 20 20 20 28 6d 61 70 20 63 61 ))..;; (map ca
127c0 72 20 28 73 6f 72 74 20 64 61 74 61 20 28 6c 61 r (sort data (la
127d0 6d 62 64 61 20 28 61 20 62 29 0a 09 3b 3b 20 20 mbda (a b)..;;
127e0 20 20 20 09 09 20 20 20 20 28 3e 20 28 73 74 72 .. (> (str
127f0 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 63 61 64 ing->number (cad
12800 64 72 20 61 29 29 28 73 74 72 69 6e 67 2d 3e 6e dr a))(string->n
12810 75 6d 62 65 72 20 28 63 61 64 64 72 20 62 29 29 umber (caddr b))
12820 29 29 29 29 29 0a 09 3b 3b 20 29 29 0a 09 28 73 )))))..;; ))..(s
12830 6f 72 74 20 61 6c 6c 2d 74 65 73 74 73 20 73 6f ort all-tests so
12840 72 74 2d 66 6e 31 29 29 29 29 20 3b 3b 20 61 76 rt-fn1)))) ;; av
12850 6f 69 64 20 64 65 61 6c 69 6e 67 20 77 69 74 68 oid dealing with
12860 20 64 65 6c 65 74 65 64 20 74 65 73 74 73 2c 20 deleted tests,
12870 6c 6f 6f 6b 20 61 74 20 74 68 65 20 68 61 73 68 look at the hash
12880 20 74 61 62 6c 65 0a 0a 28 64 65 66 69 6e 65 20 table..(define
12890 28 74 65 73 74 73 3a 65 61 73 79 2d 64 6f 74 20 (tests:easy-dot
128a0 74 65 73 74 2d 72 65 63 6f 72 64 73 20 6f 75 74 test-records out
128b0 74 79 70 65 29 0a 20 20 28 6c 65 74 2d 76 61 6c type). (let-val
128c0 75 65 73 20 28 28 28 66 64 20 74 65 6d 70 2d 70 ues (((fd temp-p
128d0 61 74 68 29 20 28 66 69 6c 65 2d 6d 6b 73 74 65 ath) (file-mkste
128e0 6d 70 20 28 63 6f 6e 63 20 22 2f 74 6d 70 2f 22 mp (conc "/tmp/"
128f0 20 28 63 75 72 72 65 6e 74 2d 75 73 65 72 2d 6e (current-user-n
12900 61 6d 65 29 20 22 2e 58 58 58 58 58 58 22 29 29 ame) ".XXXXXX"))
12910 29 29 0a 20 20 20 20 28 6c 65 74 20 28 28 61 6c )). (let ((al
12920 6c 2d 74 65 73 74 6e 61 6d 65 73 20 28 68 61 73 l-testnames (has
12930 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 74 65 73 h-table-keys tes
12940 74 2d 72 65 63 6f 72 64 73 29 29 0a 09 20 20 28 t-records)).. (
12950 74 65 6d 70 2d 70 6f 72 74 20 20 20 20 20 28 6f temp-port (o
12960 70 65 6e 2d 6f 75 74 70 75 74 2d 66 69 6c 65 2a pen-output-file*
12970 20 66 64 29 29 29 0a 20 20 20 20 20 20 3b 3b 20 fd))). ;;
12980 28 66 6f 72 6d 61 74 20 74 65 6d 70 2d 70 6f 72 (format temp-por
12990 74 20 22 54 68 69 73 20 66 69 6c 65 20 69 73 20 t "This file is
129a0 7e 41 2e 7e 25 22 20 74 65 6d 70 2d 70 61 74 68 ~A.~%" temp-path
129b0 29 0a 20 20 20 20 20 20 28 66 6f 72 6d 61 74 20 ). (format
129c0 74 65 6d 70 2d 70 6f 72 74 20 22 64 69 67 72 61 temp-port "digra
129d0 70 68 20 74 65 73 74 73 20 7b 5c 6e 22 29 0a 20 ph tests {\n").
129e0 20 20 20 20 20 28 66 6f 72 6d 61 74 20 74 65 6d (format tem
129f0 70 2d 70 6f 72 74 20 22 20 20 73 69 7a 65 3d 34 p-port " size=4
12a00 2c 38 5c 6e 22 29 0a 20 20 20 20 20 20 3b 3b 20 ,8\n"). ;;
12a10 28 66 6f 72 6d 61 74 20 74 65 6d 70 2d 70 6f 72 (format temp-por
12a20 74 20 22 20 20 20 73 70 6c 69 6e 65 73 3d 6e 6f t " splines=no
12a30 6e 65 5c 6e 22 29 0a 20 20 20 20 20 20 28 66 6f ne\n"). (fo
12a40 72 2d 65 61 63 68 0a 20 20 20 20 20 20 20 28 6c r-each. (l
12a50 61 6d 62 64 61 20 28 74 65 73 74 6e 61 6d 65 29 ambda (testname)
12a60 0a 09 20 28 6c 65 74 2a 20 28 28 74 65 73 74 72 .. (let* ((testr
12a70 65 63 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 ec (hash-table-r
12a80 65 66 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 ef test-records
12a90 74 65 73 74 6e 61 6d 65 29 29 0a 09 09 28 77 61 testname))...(wa
12aa0 69 74 6f 6e 73 20 28 6f 72 20 28 74 65 73 74 73 itons (or (tests
12ab0 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 77 :testqueue-get-w
12ac0 61 69 74 6f 6e 73 20 74 65 73 74 72 65 63 29 20 aitons testrec)
12ad0 27 28 29 29 29 29 0a 09 20 20 20 28 66 6f 72 2d '()))).. (for-
12ae0 65 61 63 68 0a 09 20 20 20 20 28 6c 61 6d 62 64 each.. (lambd
12af0 61 20 28 77 61 69 74 6f 6e 29 0a 09 20 20 20 20 a (waiton)..
12b00 20 20 28 66 6f 72 6d 61 74 20 74 65 6d 70 2d 70 (format temp-p
12b10 6f 72 74 20 28 63 6f 6e 63 20 22 20 20 20 22 20 ort (conc " "
12b20 77 61 69 74 6f 6e 20 22 20 2d 3e 20 22 20 74 65 waiton " -> " te
12b30 73 74 6e 61 6d 65 20 22 20 5b 73 70 6c 69 6e 65 stname " [spline
12b40 73 3d 6f 72 74 68 6f 5d 5c 6e 22 29 29 29 0a 09 s=ortho]\n")))..
12b50 20 20 20 20 77 61 69 74 6f 6e 73 29 29 29 0a 20 waitons))).
12b60 20 20 20 20 20 20 61 6c 6c 2d 74 65 73 74 6e 61 all-testna
12b70 6d 65 73 29 0a 20 20 20 20 20 20 28 66 6f 72 6d mes). (form
12b80 61 74 20 74 65 6d 70 2d 70 6f 72 74 20 22 7d 5c at temp-port "}\
12b90 6e 22 29 0a 20 20 20 20 20 20 28 63 6c 6f 73 65 n"). (close
12ba0 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 74 65 6d -output-port tem
12bb0 70 2d 70 6f 72 74 29 0a 20 20 20 20 20 20 28 77 p-port). (w
12bc0 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 ith-input-from-p
12bd0 69 70 65 0a 20 20 20 20 20 20 20 28 63 6f 6e 63 ipe. (conc
12be0 20 22 65 6e 76 20 2d 69 20 50 41 54 48 3d 24 50 "env -i PATH=$P
12bf0 41 54 48 20 64 6f 74 20 2d 54 22 20 6f 75 74 74 ATH dot -T" outt
12c00 79 70 65 20 22 20 3c 20 22 20 74 65 6d 70 2d 70 ype " < " temp-p
12c10 61 74 68 29 0a 20 20 20 20 20 20 20 28 6c 61 6d ath). (lam
12c20 62 64 61 20 28 29 0a 09 20 28 6c 65 74 20 28 28 bda ().. (let ((
12c30 72 65 73 20 28 72 65 61 64 2d 6c 69 6e 65 73 29 res (read-lines)
12c40 29 29 0a 09 20 20 20 3b 3b 20 28 64 65 6c 65 74 )).. ;; (delet
12c50 65 2d 66 69 6c 65 20 74 65 6d 70 2d 70 61 74 68 e-file temp-path
12c60 29 0a 09 20 20 20 72 65 73 29 29 29 29 29 29 0a ).. res)))))).
12c70 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a .(define (tests:
12c80 77 72 69 74 65 2d 64 6f 74 2d 66 69 6c 65 20 74 write-dot-file t
12c90 65 73 74 2d 72 65 63 6f 72 64 73 20 66 6e 61 6d est-records fnam
12ca0 65 20 73 69 7a 65 78 20 73 69 7a 65 79 29 0a 20 e sizex sizey).
12cb0 20 28 69 66 20 28 66 69 6c 65 2d 77 72 69 74 65 (if (file-write
12cc0 2d 61 63 63 65 73 73 3f 20 28 70 61 74 68 6e 61 -access? (pathna
12cd0 6d 65 2d 64 69 72 65 63 74 6f 72 79 20 66 6e 61 me-directory fna
12ce0 6d 65 29 29 0a 20 20 20 20 20 20 28 77 69 74 68 me)). (with
12cf0 2d 6f 75 74 70 75 74 2d 74 6f 2d 66 69 6c 65 20 -output-to-file
12d00 66 6e 61 6d 65 0a 09 28 6c 61 6d 62 64 61 20 28 fname..(lambda (
12d10 29 0a 09 20 20 28 6d 61 70 20 70 72 69 6e 74 20 ).. (map print
12d20 28 74 65 73 74 73 3a 74 65 73 74 73 2d 3e 64 6f (tests:tests->do
12d30 74 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 73 t test-records s
12d40 69 7a 65 78 20 73 69 7a 65 79 29 29 29 29 29 29 izex sizey))))))
12d50 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 ..(define (tests
12d60 3a 74 65 73 74 73 2d 3e 64 6f 74 20 74 65 73 74 :tests->dot test
12d70 2d 72 65 63 6f 72 64 73 20 73 69 7a 65 78 20 73 -records sizex s
12d80 69 7a 65 79 29 0a 20 20 28 6c 65 74 20 28 28 61 izey). (let ((a
12d90 6c 6c 2d 74 65 73 74 6e 61 6d 65 73 20 28 68 61 ll-testnames (ha
12da0 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 74 65 sh-table-keys te
12db0 73 74 2d 72 65 63 6f 72 64 73 29 29 29 0a 20 20 st-records))).
12dc0 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 61 6c 6c (if (null? all
12dd0 2d 74 65 73 74 6e 61 6d 65 73 29 0a 09 27 28 29 -testnames)..'()
12de0 0a 09 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 ..(let loop ((he
12df0 64 20 28 63 61 72 20 61 6c 6c 2d 74 65 73 74 6e d (car all-testn
12e00 61 6d 65 73 29 29 0a 09 09 20 20 20 28 74 61 6c ames))... (tal
12e10 20 28 63 64 72 20 61 6c 6c 2d 74 65 73 74 6e 61 (cdr all-testna
12e20 6d 65 73 29 29 0a 09 09 20 20 20 28 72 65 73 20 mes))... (res
12e30 28 6c 69 73 74 20 22 64 69 67 72 61 70 68 20 74 (list "digraph t
12e40 65 73 74 73 20 7b 22 0a 09 09 09 20 20 20 20 20 ests {"....
12e50 20 28 63 6f 6e 63 20 22 20 73 69 7a 65 3d 5c 22 (conc " size=\"
12e60 22 20 28 6f 72 20 73 69 7a 65 78 20 31 31 29 20 " (or sizex 11)
12e70 22 2c 22 20 28 6f 72 20 73 69 7a 65 79 20 31 31 "," (or sizey 11
12e80 29 20 22 5c 22 3b 22 29 0a 09 09 09 20 20 20 20 ) "\";")....
12e90 20 20 22 20 72 61 74 69 6f 3d 30 2e 39 35 3b 22 " ratio=0.95;"
12ea0 0a 09 09 09 20 20 20 20 20 20 29 29 29 0a 09 20 .... )))..
12eb0 20 28 6c 65 74 2a 20 28 28 74 65 73 74 72 65 63 (let* ((testrec
12ec0 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
12ed0 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 68 65 test-records he
12ee0 64 29 29 0a 09 09 20 28 77 61 69 74 6f 6e 73 20 d))... (waitons
12ef0 28 6f 72 20 28 74 65 73 74 73 3a 74 65 73 74 71 (or (tests:testq
12f00 75 65 75 65 2d 67 65 74 2d 77 61 69 74 6f 6e 73 ueue-get-waitons
12f10 20 74 65 73 74 72 65 63 29 20 27 28 29 29 29 0a testrec) '())).
12f20 09 09 20 28 6e 65 77 72 65 73 20 20 28 61 70 70 .. (newres (app
12f30 65 6e 64 20 72 65 73 0a 09 09 09 09 20 20 28 69 end res..... (i
12f40 66 20 28 6e 75 6c 6c 3f 20 77 61 69 74 6f 6e 73 f (null? waitons
12f50 29 0a 09 09 09 09 20 20 20 20 20 20 28 6c 69 73 )..... (lis
12f60 74 20 28 63 6f 6e 63 20 22 20 20 20 5c 22 22 20 t (conc " \""
12f70 68 65 64 20 22 5c 22 20 5b 73 68 61 70 65 3d 62 hed "\" [shape=b
12f80 6f 78 5d 3b 22 29 29 0a 09 09 09 09 20 20 20 20 ox];")).....
12f90 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 (map (lambda (
12fa0 77 61 69 74 6f 6e 29 0a 09 09 09 09 09 20 20 20 waiton)......
12fb0 20 20 28 63 6f 6e 63 20 22 20 20 20 5c 22 22 20 (conc " \""
12fc0 77 61 69 74 6f 6e 20 22 5c 22 20 2d 3e 20 5c 22 waiton "\" -> \"
12fd0 22 20 68 65 64 20 22 5c 22 20 5b 73 68 61 70 65 " hed "\" [shape
12fe0 3d 62 6f 78 5d 3b 22 29 29 0a 09 09 09 09 09 20 =box];"))......
12ff0 20 20 77 61 69 74 6f 6e 73 29 0a 09 09 09 09 20 waitons).....
13000 20 20 20 20 20 29 29 29 29 0a 09 20 20 20 20 28 )))).. (
13010 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 if (null? tal)..
13020 09 28 61 70 70 65 6e 64 20 6e 65 77 72 65 73 20 .(append newres
13030 28 6c 69 73 74 20 22 7d 22 29 29 0a 09 09 28 6c (list "}"))...(l
13040 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 oop (car tal)(cd
13050 72 20 74 61 6c 29 20 6e 65 77 72 65 73 29 0a 09 r tal) newres)..
13060 09 29 29 29 29 29 29 0a 0a 3b 3b 20 28 74 65 73 .))))))..;; (tes
13070 74 73 3a 72 75 6e 2d 64 6f 74 20 28 6c 69 73 74 ts:run-dot (list
13080 20 22 64 69 67 72 61 70 68 20 74 65 73 74 73 20 "digraph tests
13090 7b 22 20 22 61 20 2d 3e 20 62 22 20 22 7d 22 29 {" "a -> b" "}")
130a0 20 22 70 6c 61 69 6e 22 29 0a 0a 28 64 65 66 69 "plain")..(defi
130b0 6e 65 20 28 74 65 73 74 73 3a 72 75 6e 2d 64 6f ne (tests:run-do
130c0 74 20 69 6e 64 61 74 20 6f 75 74 74 79 70 65 29 t indat outtype)
130d0 20 3b 3b 20 6f 75 74 74 79 70 65 20 69 73 20 70 ;; outtype is p
130e0 6c 61 69 6e 2c 20 66 69 67 2c 20 64 6f 74 2c 20 lain, fig, dot,
130f0 65 74 63 2e 20 68 74 74 70 3a 2f 2f 77 77 77 2e etc. http://www.
13100 67 72 61 70 68 76 69 7a 2e 6f 72 67 2f 63 6f 6e graphviz.org/con
13110 74 65 6e 74 2f 6f 75 74 70 75 74 2d 66 6f 72 6d tent/output-form
13120 61 74 73 0a 20 20 28 6c 65 74 2d 76 61 6c 75 65 ats. (let-value
13130 73 20 28 28 28 69 6e 70 20 6f 75 70 20 70 69 64 s (((inp oup pid
13140 29 28 70 72 6f 63 65 73 73 20 22 65 6e 76 20 2d )(process "env -
13150 69 20 50 41 54 48 3d 24 50 41 54 48 20 64 6f 74 i PATH=$PATH dot
13160 22 20 28 6c 69 73 74 20 22 2d 54 22 20 6f 75 74 " (list "-T" out
13170 74 79 70 65 29 29 29 29 0a 20 20 20 20 28 77 69 type)))). (wi
13180 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 70 6f 72 th-output-to-por
13190 74 20 6f 75 70 0a 20 20 20 20 20 20 28 6c 61 6d t oup. (lam
131a0 62 64 61 20 28 29 0a 09 28 6d 61 70 20 70 72 69 bda ()..(map pri
131b0 6e 74 20 69 6e 64 61 74 29 29 29 0a 20 20 20 20 nt indat))).
131c0 28 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d 70 6f (close-output-po
131d0 72 74 20 6f 75 70 29 0a 20 20 20 20 28 6c 65 74 rt oup). (let
131e0 20 28 28 72 65 73 20 28 77 69 74 68 2d 69 6e 70 ((res (with-inp
131f0 75 74 2d 66 72 6f 6d 2d 70 6f 72 74 20 69 6e 70 ut-from-port inp
13200 0a 09 09 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 ... (lambda ()..
13210 09 20 20 20 28 72 65 61 64 2d 6c 69 6e 65 73 29 . (read-lines)
13220 29 29 29 29 0a 20 20 20 20 20 20 28 63 6c 6f 73 )))). (clos
13230 65 2d 69 6e 70 75 74 2d 70 6f 72 74 20 69 6e 70 e-input-port inp
13240 29 0a 20 20 20 20 20 20 72 65 73 29 29 29 0a 0a ). res)))..
13250 3b 3b 20 72 65 61 64 20 64 61 74 61 20 66 72 6f ;; read data fro
13260 6d 20 74 6d 70 20 66 69 6c 65 20 6f 72 20 63 72 m tmp file or cr
13270 65 61 74 65 20 69 66 20 6e 6f 74 20 65 78 69 73 eate if not exis
13280 74 73 0a 3b 3b 20 69 66 20 65 78 69 73 74 73 20 ts.;; if exists
13290 72 65 67 65 6e 20 69 6e 20 62 61 63 6b 67 72 6f regen in backgro
132a0 75 6e 64 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 und.;;.(define (
132b0 74 65 73 74 73 3a 6c 61 7a 79 2d 64 6f 74 20 74 tests:lazy-dot t
132c0 65 73 74 72 65 63 6f 72 64 73 20 20 6f 75 74 74 estrecords outt
132d0 79 70 65 20 73 69 7a 65 78 20 73 69 7a 65 79 29 ype sizex sizey)
132e0 0a 20 20 28 6c 65 74 20 28 28 64 66 69 6c 65 20 . (let ((dfile
132f0 28 63 6f 6e 63 20 22 2f 74 6d 70 2f 2e 22 20 28 (conc "/tmp/." (
13300 63 75 72 72 65 6e 74 2d 75 73 65 72 2d 6e 61 6d current-user-nam
13310 65 29 20 22 2d 22 20 28 73 65 72 76 65 72 3a 6d e) "-" (server:m
13320 6b 2d 73 69 67 6e 61 74 75 72 65 29 20 22 2e 64 k-signature) ".d
13330 6f 74 22 29 29 0a 09 28 66 6e 61 6d 65 20 28 63 ot"))..(fname (c
13340 6f 6e 63 20 22 2f 74 6d 70 2f 2e 22 20 28 63 75 onc "/tmp/." (cu
13350 72 72 65 6e 74 2d 75 73 65 72 2d 6e 61 6d 65 29 rrent-user-name)
13360 20 22 2d 22 20 28 73 65 72 76 65 72 3a 6d 6b 2d "-" (server:mk-
13370 73 69 67 6e 61 74 75 72 65 29 20 22 2e 64 6f 74 signature) ".dot
13380 64 61 74 22 29 29 29 0a 20 20 20 20 28 74 65 73 dat"))). (tes
13390 74 73 3a 77 72 69 74 65 2d 64 6f 74 2d 66 69 6c ts:write-dot-fil
133a0 65 20 74 65 73 74 72 65 63 6f 72 64 73 20 64 66 e testrecords df
133b0 69 6c 65 20 73 69 7a 65 78 20 73 69 7a 65 79 29 ile sizex sizey)
133c0 0a 20 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e . (if (common
133d0 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 66 6e :file-exists? fn
133e0 61 6d 65 29 0a 09 28 6c 65 74 20 28 28 72 65 73 ame)..(let ((res
133f0 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f (with-input-fro
13400 6d 2d 66 69 6c 65 20 66 6e 61 6d 65 0a 09 09 20 m-file fname...
13410 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 (lambda ()..
13420 09 20 20 20 20 20 20 20 28 72 65 61 64 2d 6c 69 . (read-li
13430 6e 65 73 29 29 29 29 29 0a 09 20 20 28 73 79 73 nes))))).. (sys
13440 74 65 6d 20 28 63 6f 6e 63 20 22 65 6e 76 20 2d tem (conc "env -
13450 69 20 50 41 54 48 3d 24 50 41 54 48 20 64 6f 74 i PATH=$PATH dot
13460 20 2d 54 20 22 20 6f 75 74 74 79 70 65 20 22 20 -T " outtype "
13470 3c 20 22 20 64 66 69 6c 65 20 22 20 3e 20 22 20 < " dfile " > "
13480 66 6e 61 6d 65 20 22 26 22 29 29 0a 09 20 20 72 fname "&")).. r
13490 65 73 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 es)..(begin.. (
134a0 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 65 6e system (conc "en
134b0 76 20 2d 69 20 50 41 54 48 3d 24 50 41 54 48 20 v -i PATH=$PATH
134c0 64 6f 74 20 2d 54 20 22 20 6f 75 74 74 79 70 65 dot -T " outtype
134d0 20 22 20 3c 20 22 20 64 66 69 6c 65 20 22 20 3e " < " dfile " >
134e0 20 22 20 66 6e 61 6d 65 29 29 0a 09 20 20 28 77 " fname)).. (w
134f0 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 66 ith-input-from-f
13500 69 6c 65 20 66 6e 61 6d 65 0a 09 20 20 20 20 28 ile fname.. (
13510 6c 61 6d 62 64 61 20 28 29 0a 09 20 20 20 20 20 lambda ()..
13520 20 28 72 65 61 64 2d 6c 69 6e 65 73 29 29 29 29 (read-lines))))
13530 29 29 29 0a 09 20 20 0a 0a 3b 3b 20 66 6f 72 20 ))).. ..;; for
13540 65 61 63 68 20 74 65 73 74 3a 0a 3b 3b 20 20 20 each test:.;;
13550 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a .(define (tests:
13560 66 69 6c 74 65 72 2d 6e 6f 6e 2d 72 75 6e 6e 61 filter-non-runna
13570 62 6c 65 20 72 75 6e 2d 69 64 20 74 65 73 74 6b ble run-id testk
13580 65 79 6e 61 6d 65 73 20 74 65 73 74 72 65 63 6f eynames testreco
13590 72 64 73 68 61 73 68 29 0a 20 20 28 6c 65 74 20 rdshash). (let
135a0 28 28 72 75 6e 6e 61 62 6c 65 73 20 27 28 29 29 ((runnables '())
135b0 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a ). (for-each.
135c0 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 74 65 (lambda (te
135d0 73 74 6b 65 79 6e 61 6d 65 29 0a 20 20 20 20 20 stkeyname).
135e0 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 2d 72 (let* ((test-r
135f0 65 63 6f 72 64 20 28 68 61 73 68 2d 74 61 62 6c ecord (hash-tabl
13600 65 2d 72 65 66 20 74 65 73 74 72 65 63 6f 72 64 e-ref testrecord
13610 73 68 61 73 68 20 74 65 73 74 6b 65 79 6e 61 6d shash testkeynam
13620 65 29 29 0a 09 20 20 20 20 20 20 28 74 65 73 74 e)).. (test
13630 2d 6e 61 6d 65 20 20 20 28 74 65 73 74 73 3a 74 -name (tests:t
13640 65 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 73 estqueue-get-tes
13650 74 6e 61 6d 65 20 20 74 65 73 74 2d 72 65 63 6f tname test-reco
13660 72 64 29 29 0a 09 20 20 20 20 20 20 28 69 74 65 rd)).. (ite
13670 6d 64 61 74 20 20 20 20 20 28 74 65 73 74 73 3a mdat (tests:
13680 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 69 74 testqueue-get-it
13690 65 6d 64 61 74 20 20 20 74 65 73 74 2d 72 65 63 emdat test-rec
136a0 6f 72 64 29 29 0a 09 20 20 20 20 20 20 28 69 74 ord)).. (it
136b0 65 6d 2d 70 61 74 68 20 20 20 28 74 65 73 74 73 em-path (tests
136c0 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 69 :testqueue-get-i
136d0 74 65 6d 5f 70 61 74 68 20 74 65 73 74 2d 72 65 tem_path test-re
136e0 63 6f 72 64 29 29 0a 09 20 20 20 20 20 20 28 77 cord)).. (w
136f0 61 69 74 6f 6e 73 20 20 20 20 20 28 74 65 73 74 aitons (test
13700 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d s:testqueue-get-
13710 77 61 69 74 6f 6e 73 20 20 20 74 65 73 74 2d 72 waitons test-r
13720 65 63 6f 72 64 29 29 0a 09 20 20 20 20 20 20 28 ecord)).. (
13730 6b 65 65 70 2d 74 65 73 74 20 20 20 23 74 29 0a keep-test #t).
13740 09 20 20 20 20 20 20 28 74 65 73 74 2d 69 64 20 . (test-id
13750 20 20 20 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 (rmt:get-tes
13760 74 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 t-id run-id test
13770 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 -name item-path)
13780 29 0a 09 20 20 20 20 20 20 28 74 64 61 74 20 20 ).. (tdat
13790 20 20 20 20 20 20 28 72 6d 74 3a 67 65 74 2d 74 (rmt:get-t
137a0 65 73 74 69 6e 66 6f 2d 73 74 61 74 65 2d 73 74 estinfo-state-st
137b0 61 74 75 73 20 72 75 6e 2d 69 64 20 74 65 73 74 atus run-id test
137c0 2d 69 64 29 29 29 20 3b 3b 20 28 63 64 62 3a 67 -id))) ;; (cdb:g
137d0 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d et-test-info-by-
137e0 69 64 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 74 id *runremote* t
137f0 65 73 74 2d 69 64 29 29 29 0a 09 20 28 69 66 20 est-id))).. (if
13800 74 64 61 74 0a 09 20 20 20 20 20 28 62 65 67 69 tdat.. (begi
13810 6e 0a 09 20 20 20 20 20 20 20 3b 3b 20 4c 6f 6f n.. ;; Loo
13820 6b 20 61 74 20 74 68 65 20 74 65 73 74 20 73 74 k at the test st
13830 61 74 65 20 61 6e 64 20 73 74 61 74 75 73 0a 09 ate and status..
13840 20 20 20 20 20 20 20 28 69 66 20 28 6f 72 20 28 (if (or (
13850 61 6e 64 20 28 6d 65 6d 62 65 72 20 28 64 62 3a and (member (db:
13860 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 73 20 test-get-status
13870 74 64 61 74 29 20 0a 09 09 09 09 20 20 20 20 27 tdat) ..... '
13880 28 22 50 41 53 53 22 20 22 57 41 52 4e 22 20 22 ("PASS" "WARN" "
13890 57 41 49 56 45 44 22 20 22 43 48 45 43 4b 22 20 WAIVED" "CHECK"
138a0 22 53 4b 49 50 22 29 29 0a 09 09 09 20 20 20 20 "SKIP"))....
138b0 28 65 71 75 61 6c 3f 20 28 64 62 3a 74 65 73 74 (equal? (db:test
138c0 2d 67 65 74 2d 73 74 61 74 65 20 74 64 61 74 29 -get-state tdat)
138d0 20 22 43 4f 4d 50 4c 45 54 45 44 22 29 29 0a 09 "COMPLETED"))..
138e0 09 20 20 20 20 20 20 20 28 6d 65 6d 62 65 72 20 . (member
138f0 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 (db:test-get-sta
13900 74 65 20 74 64 61 74 29 0a 09 09 09 09 20 20 20 te tdat).....
13910 20 27 28 22 49 4e 43 4f 4d 50 4c 45 54 45 22 20 '("INCOMPLETE"
13920 22 4b 49 4c 4c 45 44 22 29 29 29 0a 09 09 20 20 "KILLED")))...
13930 20 28 73 65 74 21 20 6b 65 65 70 2d 74 65 73 74 (set! keep-test
13940 20 23 66 29 29 0a 0a 09 20 20 20 20 20 20 20 3b #f))... ;
13950 3b 20 65 78 61 6d 69 6e 65 20 77 61 69 74 6f 6e ; examine waiton
13960 73 20 66 6f 72 20 61 6e 79 20 66 61 69 6c 73 2e s for any fails.
13970 20 49 66 20 69 74 20 69 73 20 46 41 49 4c 20 6f If it is FAIL o
13980 72 20 49 4e 43 4f 4d 50 4c 45 54 45 20 74 68 65 r INCOMPLETE the
13990 6e 20 65 6c 69 6d 69 6e 61 74 65 20 74 68 69 73 n eliminate this
139a0 20 74 65 73 74 0a 09 20 20 20 20 20 20 20 3b 3b test.. ;;
139b0 20 66 72 6f 6d 20 74 68 65 20 72 75 6e 6e 61 62 from the runnab
139c0 6c 65 20 6c 69 73 74 0a 09 20 20 20 20 20 20 20 le list..
139d0 28 69 66 20 6b 65 65 70 2d 74 65 73 74 0a 09 09 (if keep-test...
139e0 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 (for-each (la
139f0 6d 62 64 61 20 28 77 61 69 74 6f 6e 29 0a 09 09 mbda (waiton)...
13a00 09 20 20 20 20 20 20 20 3b 3b 20 66 6f 72 20 6e . ;; for n
13a10 6f 77 20 77 65 20 61 72 65 20 77 61 69 74 69 6e ow we are waitin
13a20 67 20 6f 6e 6c 79 20 6f 6e 20 74 68 65 20 70 61 g only on the pa
13a30 72 65 6e 74 20 74 65 73 74 0a 09 09 09 20 20 20 rent test....
13a40 20 20 20 20 28 6c 65 74 2a 20 28 28 70 61 72 65 (let* ((pare
13a50 6e 74 2d 74 65 73 74 2d 69 64 20 28 72 6d 74 3a nt-test-id (rmt:
13a60 67 65 74 2d 74 65 73 74 2d 69 64 20 72 75 6e 2d get-test-id run-
13a70 69 64 20 77 61 69 74 6f 6e 20 22 22 29 29 0a 09 id waiton ""))..
13a80 09 09 09 20 20 20 20 20 20 28 77 74 64 61 74 20 ... (wtdat
13a90 20 20 20 20 20 20 20 20 20 28 72 6d 74 3a 67 65 (rmt:ge
13aa0 74 2d 74 65 73 74 69 6e 66 6f 2d 73 74 61 74 65 t-testinfo-state
13ab0 2d 73 74 61 74 75 73 20 72 75 6e 2d 69 64 20 74 -status run-id t
13ac0 65 73 74 2d 69 64 29 29 29 20 3b 3b 20 28 63 64 est-id))) ;; (cd
13ad0 62 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d b:get-test-info-
13ae0 62 79 2d 69 64 20 2a 72 75 6e 72 65 6d 6f 74 65 by-id *runremote
13af0 2a 20 74 65 73 74 2d 69 64 29 29 29 0a 09 09 09 * test-id)))....
13b00 09 20 28 69 66 20 28 6f 72 20 28 61 6e 64 20 28 . (if (or (and (
13b10 65 71 75 61 6c 3f 20 28 64 62 3a 74 65 73 74 2d equal? (db:test-
13b20 67 65 74 2d 73 74 61 74 65 20 77 74 64 61 74 29 get-state wtdat)
13b30 20 22 43 4f 4d 50 4c 45 54 45 44 22 29 0a 09 09 "COMPLETED")...
13b40 09 09 09 20 20 20 20 20 20 28 6d 65 6d 62 65 72 ... (member
13b50 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 (db:test-get-st
13b60 61 74 75 73 20 77 74 64 61 74 29 20 27 28 22 46 atus wtdat) '("F
13b70 41 49 4c 22 20 22 41 42 4f 52 54 22 29 29 29 0a AIL" "ABORT"))).
13b80 09 09 09 09 09 20 28 6d 65 6d 62 65 72 20 28 64 ..... (member (d
13b90 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 b:test-get-statu
13ba0 73 20 77 74 64 61 74 29 20 20 27 28 22 4b 49 4c s wtdat) '("KIL
13bb0 4c 45 44 22 29 29 0a 09 09 09 09 09 20 28 6d 65 LED"))...... (me
13bc0 6d 62 65 72 20 28 64 62 3a 74 65 73 74 2d 67 65 mber (db:test-ge
13bd0 74 2d 73 74 61 74 65 20 77 74 64 61 74 29 20 20 t-state wtdat)
13be0 20 27 28 22 49 4e 43 4f 4d 50 45 54 45 22 29 29 '("INCOMPETE"))
13bf0 29 0a 09 09 09 09 20 3b 3b 20 28 69 66 20 28 6f )..... ;; (if (o
13c00 72 20 28 6d 65 6d 62 65 72 20 28 64 62 3a 74 65 r (member (db:te
13c10 73 74 2d 67 65 74 2d 73 74 61 74 75 73 20 77 74 st-get-status wt
13c20 64 61 74 29 0a 09 09 09 09 20 3b 3b 20 20 20 20 dat)..... ;;
13c30 20 20 20 20 09 20 27 28 22 46 41 49 4c 22 20 22 . '("FAIL" "
13c40 4b 49 4c 4c 45 44 22 29 29 0a 09 09 09 09 20 3b KILLED"))..... ;
13c50 3b 20 20 20 20 20 20 20 20 20 28 6d 65 6d 62 65 ; (membe
13c60 72 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 r (db:test-get-s
13c70 74 61 74 65 20 77 74 64 61 74 29 0a 09 09 09 09 tate wtdat).....
13c80 20 3b 3b 20 20 20 20 20 20 20 20 09 20 27 28 22 ;; . '("
13c90 49 4e 43 4f 4d 50 45 54 45 22 29 29 29 0a 09 09 INCOMPETE")))...
13ca0 09 09 20 20 20 20 20 28 73 65 74 21 20 6b 65 65 .. (set! kee
13cb0 70 2d 74 65 73 74 20 23 66 29 29 29 29 20 3b 3b p-test #f)))) ;;
13cc0 20 6e 6f 20 70 6f 69 6e 74 20 69 6e 20 72 75 6e no point in run
13cd0 6e 69 6e 67 20 74 68 69 73 20 6f 6e 65 20 61 67 ning this one ag
13ce0 61 69 6e 0a 09 09 09 20 20 20 20 20 77 61 69 74 ain.... wait
13cf0 6f 6e 73 29 29 29 29 0a 09 20 28 69 66 20 6b 65 ons)))).. (if ke
13d00 65 70 2d 74 65 73 74 20 28 73 65 74 21 20 72 75 ep-test (set! ru
13d10 6e 6e 61 62 6c 65 73 20 28 63 6f 6e 73 20 74 65 nnables (cons te
13d20 73 74 6b 65 79 6e 61 6d 65 20 72 75 6e 6e 61 62 stkeyname runnab
13d30 6c 65 73 29 29 29 29 29 0a 20 20 20 20 20 74 65 les))))). te
13d40 73 74 6b 65 79 6e 61 6d 65 73 29 0a 20 20 20 20 stkeynames).
13d50 72 75 6e 6e 61 62 6c 65 73 29 29 0a 0a 3b 3b 3d runnables))..;;=
13d60 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13d70 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13d80 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13d90 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13da0 3d 3d 3d 3d 3d 0a 3b 3b 20 72 65 66 61 63 74 6f =====.;; refacto
13db0 72 69 6e 67 20 74 68 69 73 20 62 6c 6f 63 6b 20 ring this block
13dc0 69 6e 74 6f 20 74 65 73 74 73 3a 67 65 74 2d 66 into tests:get-f
13dd0 75 6c 6c 2d 64 61 74 61 20 66 72 6f 6d 20 6c 69 ull-data from li
13de0 6e 65 20 32 36 33 20 6f 66 20 72 75 6e 73 2e 73 ne 263 of runs.s
13df0 63 6d 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d cm.;;===========
13e00 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13e10 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13e20 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13e30 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 68 ===========.;; h
13e40 65 64 20 69 73 20 74 68 65 20 74 65 73 74 20 6e ed is the test n
13e50 61 6d 65 0a 3b 3b 20 74 65 73 74 2d 72 65 63 6f ame.;; test-reco
13e60 72 64 73 20 69 73 20 61 20 68 61 73 68 20 6f 66 rds is a hash of
13e70 20 74 65 73 74 2d 6e 61 6d 65 20 3d 3e 20 74 65 test-name => te
13e80 73 74 20 72 65 63 6f 72 64 0a 28 64 65 66 69 6e st record.(defin
13e90 65 20 28 74 65 73 74 73 3a 67 65 74 2d 66 75 6c e (tests:get-ful
13ea0 6c 2d 64 61 74 61 20 74 65 73 74 2d 6e 61 6d 65 l-data test-name
13eb0 73 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 72 s test-records r
13ec0 65 71 75 69 72 65 64 2d 74 65 73 74 73 20 61 6c equired-tests al
13ed0 6c 2d 74 65 73 74 73 2d 72 65 67 69 73 74 72 79 l-tests-registry
13ee0 29 0a 20 20 28 6c 65 74 20 28 28 6d 69 73 73 69 ). (let ((missi
13ef0 6e 67 2d 77 61 69 74 6f 6e 73 20 28 6d 61 6b 65 ng-waitons (make
13f00 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 0a 20 -hash-table))).
13f10 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c (if (not (nul
13f20 6c 3f 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 0a l? test-names)).
13f30 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 (let loop
13f40 28 28 68 65 64 20 28 63 61 72 20 74 65 73 74 2d ((hed (car test-
13f50 6e 61 6d 65 73 29 29 0a 09 09 20 28 74 61 6c 20 names))... (tal
13f60 28 63 64 72 20 74 65 73 74 2d 6e 61 6d 65 73 29 (cdr test-names)
13f70 29 29 20 20 20 20 20 20 20 20 20 3b 3b 20 27 72 )) ;; 'r
13f80 65 74 75 72 6e 2d 70 72 6f 63 73 20 74 65 6c 6c eturn-procs tell
13f90 73 20 74 68 65 20 63 6f 6e 66 69 67 20 72 65 61 s the config rea
13fa0 64 65 72 20 74 6f 20 70 72 65 70 20 72 75 6e 6e der to prep runn
13fb0 69 6e 67 20 73 79 73 74 65 6d 20 62 75 74 20 72 ing system but r
13fc0 65 74 75 72 6e 20 61 20 70 72 6f 63 0a 09 28 64 eturn a proc..(d
13fd0 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
13fe0 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 4 *default-log-p
13ff0 6f 72 74 2a 20 22 68 65 64 3d 22 20 68 65 64 20 ort* "hed=" hed
14000 22 20 61 74 20 74 6f 70 20 6f 66 20 6c 6f 6f 70 " at top of loop
14010 22 29 0a 20 20 20 20 20 20 20 20 3b 3b 20 64 6f "). ;; do
14020 6e 27 74 20 6b 6e 6f 77 20 69 74 65 6d 2d 70 61 n't know item-pa
14030 74 68 20 61 74 20 74 68 69 73 20 74 69 6d 65 2c th at this time,
14040 20 6c 65 74 20 74 68 65 20 74 65 73 74 63 6f 6e let the testcon
14050 66 69 67 20 67 65 74 20 74 68 65 20 74 6f 70 20 fig get the top
14060 6c 65 76 65 6c 20 74 65 73 74 63 6f 6e 66 69 67 level testconfig
14070 0a 09 28 6c 65 74 2a 20 28 28 63 6f 6e 66 69 67 ..(let* ((config
14080 20 20 28 74 65 73 74 73 3a 67 65 74 2d 74 65 73 (tests:get-tes
14090 74 63 6f 6e 66 69 67 20 68 65 64 20 23 66 20 61 tconfig hed #f a
140a0 6c 6c 2d 74 65 73 74 73 2d 72 65 67 69 73 74 72 ll-tests-registr
140b0 79 20 27 72 65 74 75 72 6e 2d 70 72 6f 63 73 29 y 'return-procs)
140c0 29 0a 09 20 20 20 20 20 20 20 28 77 61 69 74 6f ).. (waito
140d0 6e 73 20 28 6c 65 74 20 28 28 69 6e 73 74 72 20 ns (let ((instr
140e0 28 69 66 20 63 6f 6e 66 69 67 20 0a 09 09 09 09 (if config .....
140f0 09 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 . (configf:looku
14100 70 20 63 6f 6e 66 69 67 20 22 72 65 71 75 69 72 p config "requir
14110 65 6d 65 6e 74 73 22 20 22 77 61 69 74 6f 6e 22 ements" "waiton"
14120 29 0a 09 09 09 09 09 20 28 62 65 67 69 6e 20 3b )...... (begin ;
14130 3b 20 4e 6f 20 63 6f 6e 66 69 67 20 6d 65 61 6e ; No config mean
14140 73 20 74 68 69 73 20 69 73 20 61 20 6e 6f 6e 2d s this is a non-
14150 65 78 69 73 74 65 6e 74 20 74 65 73 74 0a 20 20 existent test.
14160 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14170 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14180 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 (let ((
14190 77 61 69 74 65 72 73 20 27 28 29 29 29 0a 20 20 waiters '())).
141a0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
141b0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
141c0 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 66 69 ;; fi
141d0 6e 64 20 74 68 65 20 77 61 69 74 65 72 28 73 29 nd the waiter(s)
141e0 20 66 6f 72 20 74 68 69 73 20 77 61 69 74 6f 6e for this waiton
141f0 2e 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ..
14200 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14210 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
14220 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 20 20 for-each .
14230 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14240 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14250 20 20 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 (lambda
14260 28 77 61 69 74 65 72 29 0a 20 20 20 20 20 20 20 (waiter).
14270 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14280 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14290 20 20 20 20 20 20 20 20 20 20 3b 3b 20 28 70 72 ;; (pr
142a0 69 6e 74 20 22 74 65 73 74 2d 72 65 63 6f 72 64 int "test-record
142b0 20 3d 20 22 20 28 68 61 73 68 2d 74 61 62 6c 65 = " (hash-table
142c0 2d 72 65 66 20 74 65 73 74 2d 72 65 63 6f 72 64 -ref test-record
142d0 73 20 77 61 69 74 65 72 29 29 0a 20 20 20 20 20 s waiter)).
142e0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
142f0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14300 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 28 ;; (
14310 70 72 69 6e 74 20 22 77 61 69 74 6f 6e 73 20 3d print "waitons =
14320 20 22 20 28 76 65 63 74 6f 72 2d 72 65 66 20 28 " (vector-ref (
14330 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 74 hash-table-ref t
14340 65 73 74 2d 72 65 63 6f 72 64 73 20 77 61 69 74 est-records wait
14350 65 72 29 20 32 29 29 0a 20 20 20 20 20 20 20 20 er) 2)).
14360 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14370 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14380 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6d 65 (if (me
14390 6d 62 65 72 20 68 65 64 20 28 76 65 63 74 6f 72 mber hed (vector
143a0 2d 72 65 66 20 28 68 61 73 68 2d 74 61 62 6c 65 -ref (hash-table
143b0 2d 72 65 66 20 74 65 73 74 2d 72 65 63 6f 72 64 -ref test-record
143c0 73 20 77 61 69 74 65 72 29 20 32 29 29 0a 20 20 s waiter) 2)).
143d0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
143e0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
143f0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14400 20 20 28 73 65 74 21 20 77 61 69 74 65 72 73 20 (set! waiters
14410 28 63 6f 6e 73 20 77 61 69 74 65 72 20 77 61 69 (cons waiter wai
14420 74 65 72 73 29 29 0a 20 20 20 20 20 20 20 20 20 ters)).
14430 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14440 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14450 20 20 20 20 20 20 20 20 29 0a 20 20 20 20 20 20 ).
14460 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14470 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14480 20 20 20 20 20 20 20 20 20 29 0a 20 20 20 20 20 ).
14490 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
144a0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
144b0 20 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 (hash-ta
144c0 62 6c 65 2d 6b 65 79 73 20 74 65 73 74 2d 72 65 ble-keys test-re
144d0 63 6f 72 64 73 29 29 0a 20 20 20 20 20 20 20 20 cords)).
144e0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
144f0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14500 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
14510 2d 73 65 74 21 20 6d 69 73 73 69 6e 67 2d 77 61 -set! missing-wa
14520 69 74 6f 6e 73 20 68 65 64 20 77 61 69 74 65 72 itons hed waiter
14530 73 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 s).
14540 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14550 20 20 20 20 20 20 20 20 20 20 20 20 20 20 29 0a ).
14560 09 09 09 09 09 20 20 20 22 22 29 29 29 29 0a 09 ..... ""))))..
14570 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
14580 2d 69 6e 66 6f 20 38 20 2a 64 65 66 61 75 6c 74 -info 8 *default
14590 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 77 61 69 74 -log-port* "wait
145a0 6f 6e 73 20 73 74 72 69 6e 67 20 69 73 20 22 20 ons string is "
145b0 69 6e 73 74 72 29 0a 09 09 09 20 20 28 73 74 72 instr).... (str
145c0 69 6e 67 2d 73 70 6c 69 74 20 28 63 6f 6e 64 0a ing-split (cond.
145d0 09 09 09 09 09 20 28 28 70 72 6f 63 65 64 75 72 ..... ((procedur
145e0 65 3f 20 69 6e 73 74 72 29 0a 09 09 09 09 09 20 e? instr)......
145f0 20 28 6c 65 74 20 28 28 72 65 73 20 28 69 6e 73 (let ((res (ins
14600 74 72 29 29 29 0a 09 09 09 09 09 20 20 20 20 28 tr)))...... (
14610 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
14620 20 38 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 8 *default-log-
14630 70 6f 72 74 2a 20 22 77 61 69 74 6f 6e 20 70 72 port* "waiton pr
14640 6f 63 65 64 75 72 65 20 72 65 73 75 6c 74 73 20 ocedure results
14650 69 6e 20 73 74 72 69 6e 67 20 22 20 72 65 73 20 in string " res
14660 22 20 66 6f 72 20 74 65 73 74 20 22 20 68 65 64 " for test " hed
14670 29 0a 09 09 09 09 09 20 20 20 20 72 65 73 29 29 )...... res))
14680 0a 09 09 09 09 09 20 28 28 73 74 72 69 6e 67 3f ...... ((string?
14690 20 69 6e 73 74 72 29 20 20 20 20 20 69 6e 73 74 instr) inst
146a0 72 29 0a 09 09 09 09 09 20 28 65 6c 73 65 20 0a r)...... (else .
146b0 09 09 09 09 09 20 20 3b 3b 20 4e 4f 54 45 3a 20 ..... ;; NOTE:
146c0 54 68 69 73 20 69 73 20 61 63 74 75 61 6c 6c 79 This is actually
146d0 20 74 68 65 20 63 61 73 65 20 6f 66 20 2a 6e 6f the case of *no
146e0 2a 20 77 61 69 74 6f 6e 73 21 20 3b 3b 20 0a 09 * waitons! ;; ..
146f0 09 09 09 09 20 20 22 22 29 29 29 29 29 29 0a 09 .... ""))))))..
14700 20 20 28 69 66 20 28 6e 6f 74 20 63 6f 6e 66 69 (if (not confi
14710 67 29 20 3b 3b 20 74 68 69 73 20 69 73 20 61 20 g) ;; this is a
14720 6e 6f 6e 2d 65 78 69 73 74 61 6e 74 20 74 65 73 non-existant tes
14730 74 20 63 61 6c 6c 65 64 20 69 6e 20 61 20 77 61 t called in a wa
14740 69 74 6f 6e 2e 20 0a 09 20 20 20 20 20 20 28 69 iton. .. (i
14750 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 f (null? tal)...
14760 20 20 74 65 73 74 2d 72 65 63 6f 72 64 73 0a 09 test-records..
14770 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 . (loop (car ta
14780 6c 29 28 63 64 72 20 74 61 6c 29 29 29 0a 09 20 l)(cdr tal)))..
14790 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 28 64 (begin...(d
147a0 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
147b0 38 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 8 *default-log-p
147c0 6f 72 74 2a 20 22 77 61 69 74 6f 6e 73 3a 20 22 ort* "waitons: "
147d0 20 77 61 69 74 6f 6e 73 29 0a 09 09 3b 3b 20 63 waitons)...;; c
147e0 68 65 63 6b 20 66 6f 72 20 68 65 64 20 69 6e 20 heck for hed in
147f0 77 61 69 74 6f 6e 73 20 3d 3e 20 74 68 69 73 20 waitons => this
14800 77 6f 75 6c 64 20 62 65 20 63 69 72 63 75 6c 61 would be circula
14810 72 2c 20 72 65 6d 6f 76 65 20 69 74 20 61 6e 64 r, remove it and
14820 20 69 73 73 75 65 20 61 6e 0a 09 09 3b 3b 20 65 issue an...;; e
14830 72 72 6f 72 0a 09 09 28 69 66 20 28 6d 65 6d 62 rror...(if (memb
14840 65 72 20 68 65 64 20 77 61 69 74 6f 6e 73 29 0a er hed waitons).
14850 09 09 20 20 20 20 28 62 65 67 69 6e 0a 09 09 20 .. (begin...
14860 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
14870 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 t-error 0 *defau
14880 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 74 65 lt-log-port* "te
14890 73 74 20 22 20 68 65 64 20 22 20 68 61 73 20 6c st " hed " has l
148a0 69 73 74 65 64 20 69 74 73 65 6c 66 20 61 73 20 isted itself as
148b0 61 20 77 61 69 74 6f 6e 2c 20 70 6c 65 61 73 65 a waiton, please
148c0 20 63 6f 72 72 65 63 74 20 74 68 69 73 21 22 29 correct this!")
148d0 0a 09 09 20 20 20 20 20 20 28 73 65 74 21 20 77 ... (set! w
148e0 61 69 74 6f 6e 73 20 28 66 69 6c 74 65 72 20 28 aitons (filter (
148f0 6c 61 6d 62 64 61 20 28 78 29 28 6e 6f 74 20 28 lambda (x)(not (
14900 65 71 75 61 6c 3f 20 78 20 68 65 64 29 29 29 20 equal? x hed)))
14910 77 61 69 74 6f 6e 73 29 29 29 29 0a 09 09 0a 09 waitons)))).....
14920 09 3b 3b 20 28 69 74 65 6d 73 20 20 20 28 69 74 .;; (items (it
14930 65 6d 73 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 ems:get-items-fr
14940 6f 6d 2d 63 6f 6e 66 69 67 20 63 6f 6e 66 69 67 om-config config
14950 29 29 29 0a 09 09 28 69 66 20 28 6e 6f 74 20 28 )))...(if (not (
14960 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
14970 65 66 61 75 6c 74 20 74 65 73 74 2d 72 65 63 6f efault test-reco
14980 72 64 73 20 68 65 64 20 23 66 29 29 0a 09 09 20 rds hed #f))...
14990 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 (hash-table-s
149a0 65 74 21 20 74 65 73 74 2d 72 65 63 6f 72 64 73 et! test-records
149b0 0a 09 09 09 09 20 20 20 20 20 68 65 64 20 28 76 ..... hed (v
149c0 65 63 74 6f 72 20 68 65 64 20 20 20 20 20 3b 3b ector hed ;;
149d0 20 30 0a 09 09 09 09 09 09 20 63 6f 6e 66 69 67 0....... config
149e0 20 20 3b 3b 20 31 0a 09 09 09 09 09 09 20 77 61 ;; 1....... wa
149f0 69 74 6f 6e 73 20 3b 3b 20 32 0a 09 09 09 09 09 itons ;; 2......
14a00 09 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 . (configf:looku
14a10 70 20 63 6f 6e 66 69 67 20 22 72 65 71 75 69 72 p config "requir
14a20 65 6d 65 6e 74 73 22 20 22 70 72 69 6f 72 69 74 ements" "priorit
14a30 79 22 29 20 20 20 20 20 3b 3b 20 70 72 69 6f 72 y") ;; prior
14a40 69 74 79 20 33 0a 09 09 09 09 09 09 20 28 6c 65 ity 3....... (le
14a50 74 20 28 28 69 74 65 6d 73 20 20 20 20 20 20 28 t ((items (
14a60 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
14a70 65 66 61 75 6c 74 20 63 6f 6e 66 69 67 20 22 69 efault config "i
14a80 74 65 6d 73 22 20 23 66 29 29 20 3b 3b 20 69 74 tems" #f)) ;; it
14a90 65 6d 73 20 34 0a 09 09 09 09 09 09 20 20 20 20 ems 4.......
14aa0 20 20 20 28 69 74 65 6d 73 74 61 62 6c 65 20 28 (itemstable (
14ab0 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
14ac0 65 66 61 75 6c 74 20 63 6f 6e 66 69 67 20 22 69 efault config "i
14ad0 74 65 6d 73 74 61 62 6c 65 22 20 23 66 29 29 29 temstable" #f)))
14ae0 20 0a 09 09 09 09 09 09 20 20 20 3b 3b 20 69 66 ....... ;; if
14af0 20 65 69 74 68 65 72 20 69 74 65 6d 73 20 6f 72 either items or
14b00 20 69 74 65 6d 73 20 74 61 62 6c 65 20 69 73 20 items table is
14b10 61 20 70 72 6f 63 20 72 65 74 75 72 6e 20 69 74 a proc return it
14b20 20 73 6f 20 74 65 73 74 20 72 75 6e 6e 69 6e 67 so test running
14b30 0a 09 09 09 09 09 09 20 20 20 3b 3b 20 70 72 6f ....... ;; pro
14b40 63 65 73 73 20 63 61 6e 20 6b 6e 6f 77 20 74 6f cess can know to
14b50 20 63 61 6c 6c 20 69 74 65 6d 73 3a 67 65 74 2d call items:get-
14b60 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 items-from-confi
14b70 67 0a 09 09 09 09 09 09 20 20 20 3b 3b 20 69 66 g....... ;; if
14b80 20 65 69 74 68 65 72 20 69 73 20 61 20 6c 69 73 either is a lis
14b90 74 20 61 6e 64 20 6e 6f 6e 65 20 69 73 20 61 20 t and none is a
14ba0 70 72 6f 63 20 67 6f 20 61 68 65 61 64 20 61 6e proc go ahead an
14bb0 64 20 63 61 6c 6c 20 67 65 74 2d 69 74 65 6d 73 d call get-items
14bc0 0a 09 09 09 09 09 09 20 20 20 3b 3b 20 6f 74 68 ....... ;; oth
14bd0 65 72 77 69 73 65 20 72 65 74 75 72 6e 20 23 66 erwise return #f
14be0 20 2d 20 74 68 69 73 20 69 73 20 6e 6f 74 20 61 - this is not a
14bf0 6e 20 69 74 65 72 61 74 65 64 20 74 65 73 74 0a n iterated test.
14c00 09 09 09 09 09 09 20 20 20 28 63 6f 6e 64 0a 09 ...... (cond..
14c10 09 09 09 09 09 20 20 20 20 28 28 70 72 6f 63 65 ..... ((proce
14c20 64 75 72 65 3f 20 69 74 65 6d 73 29 20 20 20 20 dure? items)
14c30 20 20 0a 09 09 09 09 09 09 20 20 20 20 20 28 64 ....... (d
14c40 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
14c50 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 4 *default-log-p
14c60 6f 72 74 2a 20 22 69 74 65 6d 73 20 69 73 20 61 ort* "items is a
14c70 20 70 72 6f 63 65 64 75 72 65 2c 20 77 69 6c 6c procedure, will
14c80 20 63 61 6c 63 20 6c 61 74 65 72 22 29 0a 09 09 calc later")...
14c90 09 09 09 09 20 20 20 20 20 69 74 65 6d 73 29 20 .... items)
14ca0 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 63 61 ;; ca
14cb0 6c 63 20 6c 61 74 65 72 0a 09 09 09 09 09 09 20 lc later.......
14cc0 20 20 20 28 28 70 72 6f 63 65 64 75 72 65 3f 20 ((procedure?
14cd0 69 74 65 6d 73 74 61 62 6c 65 29 0a 09 09 09 09 itemstable).....
14ce0 09 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 .. (debug:pr
14cf0 69 6e 74 2d 69 6e 66 6f 20 34 20 2a 64 65 66 61 int-info 4 *defa
14d00 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 69 ult-log-port* "i
14d10 74 65 6d 73 74 61 62 6c 65 20 69 73 20 61 20 70 temstable is a p
14d20 72 6f 63 65 64 75 72 65 2c 20 77 69 6c 6c 20 63 rocedure, will c
14d30 61 6c 63 20 6c 61 74 65 72 22 29 0a 09 09 09 09 alc later").....
14d40 09 09 20 20 20 20 20 69 74 65 6d 73 74 61 62 6c .. itemstabl
14d50 65 29 20 20 20 20 20 20 20 3b 3b 20 63 61 6c 63 e) ;; calc
14d60 20 6c 61 74 65 72 0a 09 09 09 09 09 09 20 20 20 later.......
14d70 20 28 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 ((filter (lambd
14d80 61 20 28 78 29 0a 09 09 09 09 09 09 09 20 20 20 a (x)........
14d90 20 20 20 20 28 6c 65 74 20 28 28 76 61 6c 20 28 (let ((val (
14da0 63 61 72 20 78 29 29 29 0a 09 09 09 09 09 09 09 car x)))........
14db0 09 20 28 69 66 20 28 70 72 6f 63 65 64 75 72 65 . (if (procedure
14dc0 3f 20 76 61 6c 29 20 76 61 6c 20 23 66 29 29 29 ? val) val #f)))
14dd0 0a 09 09 09 09 09 09 09 20 20 20 20 20 28 61 70 ........ (ap
14de0 70 65 6e 64 20 28 69 66 20 28 6c 69 73 74 3f 20 pend (if (list?
14df0 69 74 65 6d 73 29 20 69 74 65 6d 73 20 27 28 29 items) items '()
14e00 29 0a 09 09 09 09 09 09 09 09 20 20 20 20 20 28 )......... (
14e10 69 66 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 74 if (list? itemst
14e20 61 62 6c 65 29 20 69 74 65 6d 73 74 61 62 6c 65 able) itemstable
14e30 20 27 28 29 29 29 29 0a 09 09 09 09 09 09 20 20 '()))).......
14e40 20 20 20 27 68 61 76 65 2d 70 72 6f 63 65 64 75 'have-procedu
14e50 72 65 29 0a 09 09 09 09 09 09 20 20 20 20 28 28 re)....... ((
14e60 6f 72 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 or (list? items)
14e70 28 6c 69 73 74 3f 20 69 74 65 6d 73 74 61 62 6c (list? itemstabl
14e80 65 29 29 20 3b 3b 20 63 61 6c 63 20 6e 6f 77 0a e)) ;; calc now.
14e90 09 09 09 09 09 09 20 20 20 20 20 28 64 65 62 75 ...... (debu
14ea0 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 2a g:print-info 4 *
14eb0 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
14ec0 2a 20 22 69 74 65 6d 73 20 61 6e 64 20 69 74 65 * "items and ite
14ed0 6d 73 74 61 62 6c 65 20 61 72 65 20 6c 69 73 74 mstable are list
14ee0 73 2c 20 63 61 6c 63 20 6e 6f 77 5c 6e 22 0a 09 s, calc now\n"..
14ef0 09 09 09 09 09 09 09 20 20 20 20 20 20 20 22 20 ....... "
14f00 20 20 20 69 74 65 6d 73 3a 20 22 20 69 74 65 6d items: " item
14f10 73 20 22 20 69 74 65 6d 73 74 61 62 6c 65 3a 20 s " itemstable:
14f20 22 20 69 74 65 6d 73 74 61 62 6c 65 29 0a 09 09 " itemstable)...
14f30 09 09 09 09 20 20 20 20 20 28 69 74 65 6d 73 3a .... (items:
14f40 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 get-items-from-c
14f50 6f 6e 66 69 67 20 63 6f 6e 66 69 67 29 29 0a 09 onfig config))..
14f60 09 09 09 09 09 20 20 20 20 28 65 6c 73 65 20 23 ..... (else #
14f70 66 29 29 29 20 20 20 20 20 20 20 20 20 20 20 20 f)))
14f80 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
14f90 3b 20 6e 6f 74 20 69 74 65 72 61 74 65 64 0a 09 ; not iterated..
14fa0 09 09 09 09 09 20 23 66 20 20 20 20 20 20 3b 3b ..... #f ;;
14fb0 20 69 74 65 6d 73 64 61 74 20 35 0a 09 09 09 09 itemsdat 5.....
14fc0 09 09 20 23 66 20 20 20 20 20 20 3b 3b 20 73 70 .. #f ;; sp
14fd0 61 72 65 20 2d 20 75 73 65 64 20 66 6f 72 20 69 are - used for i
14fe0 74 65 6d 2d 70 61 74 68 0a 09 09 09 09 09 09 20 tem-path.......
14ff0 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
15000 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 09 (for-each ..
15010 09 20 28 6c 61 6d 62 64 61 20 28 77 61 69 74 6f . (lambda (waito
15020 6e 29 0a 09 09 20 20 20 28 69 66 20 28 61 6e 64 n)... (if (and
15030 20 77 61 69 74 6f 6e 20 28 6e 6f 74 20 28 73 74 waiton (not (st
15040 72 69 6e 67 3d 20 22 23 66 22 20 77 61 69 74 6f ring= "#f" waito
15050 6e 29 29 20 28 6e 6f 74 20 28 6d 65 6d 62 65 72 n)) (not (member
15060 20 77 61 69 74 6f 6e 20 74 65 73 74 2d 6e 61 6d waiton test-nam
15070 65 73 29 29 29 0a 09 09 20 20 20 20 20 20 20 28 es)))... (
15080 62 65 67 69 6e 0a 09 09 09 20 28 73 65 74 21 20 begin.... (set!
15090 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 20 28 required-tests (
150a0 63 6f 6e 73 20 77 61 69 74 6f 6e 20 72 65 71 75 cons waiton requ
150b0 69 72 65 64 2d 74 65 73 74 73 29 29 0a 09 09 09 ired-tests))....
150c0 20 28 73 65 74 21 20 74 65 73 74 2d 6e 61 6d 65 (set! test-name
150d0 73 20 28 63 6f 6e 73 20 77 61 69 74 6f 6e 20 74 s (cons waiton t
150e0 65 73 74 2d 6e 61 6d 65 73 29 29 29 29 29 20 3b est-names))))) ;
150f0 3b 20 77 61 73 20 61 6e 20 61 70 70 65 6e 64 2c ; was an append,
15100 20 6e 6f 77 20 61 20 63 6f 6e 73 0a 09 09 20 77 now a cons... w
15110 61 69 74 6f 6e 73 29 0a 09 09 28 6c 65 74 20 28 aitons)...(let (
15120 28 72 65 6d 74 65 73 74 73 20 28 64 65 6c 65 74 (remtests (delet
15130 65 2d 64 75 70 6c 69 63 61 74 65 73 20 28 61 70 e-duplicates (ap
15140 70 65 6e 64 20 77 61 69 74 6f 6e 73 20 74 61 6c pend waitons tal
15150 29 29 29 29 0a 09 09 20 20 28 69 66 20 28 6e 6f ))))... (if (no
15160 74 20 28 6e 75 6c 6c 3f 20 72 65 6d 74 65 73 74 t (null? remtest
15170 73 29 29 0a 09 09 20 20 20 20 20 20 28 6c 6f 6f s))... (loo
15180 70 20 28 63 61 72 20 72 65 6d 74 65 73 74 73 29 p (car remtests)
15190 28 63 64 72 20 72 65 6d 74 65 73 74 73 29 29 0a (cdr remtests)).
151a0 09 09 20 20 20 20 20 20 74 65 73 74 2d 72 65 63 .. test-rec
151b0 6f 72 64 73 29 29 29 29 29 29 29 0a 20 20 20 20 ords))))))).
151c0 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 (for-each.
151d0 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 6d 69 (lambda (mi
151e0 73 73 69 6e 67 2d 77 61 69 74 6f 6e 29 0a 20 20 ssing-waiton).
151f0 20 20 20 20 20 20 20 20 20 20 28 64 65 62 75 67 (debug
15200 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a :print-error 0 *
15210 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
15220 2a 20 22 6e 6f 6e 2d 65 78 69 73 74 65 6e 74 20 * "non-existent
15230 74 65 73 74 20 5c 22 22 20 6d 69 73 73 69 6e 67 test \"" missing
15240 2d 77 61 69 74 6f 6e 20 22 5c 22 20 69 73 20 61 -waiton "\" is a
15250 20 77 61 69 74 6f 6e 20 66 6f 72 20 74 65 73 74 waiton for test
15260 73 20 22 20 28 68 61 73 68 2d 74 61 62 6c 65 2d s " (hash-table-
15270 72 65 66 20 6d 69 73 73 69 6e 67 2d 77 61 69 74 ref missing-wait
15280 6f 6e 73 20 6d 69 73 73 69 6e 67 2d 77 61 69 74 ons missing-wait
15290 6f 6e 29 29 0a 20 20 20 20 20 20 20 20 20 29 0a on)). ).
152a0 20 20 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 (hash-t
152b0 61 62 6c 65 2d 6b 65 79 73 20 6d 69 73 73 69 6e able-keys missin
152c0 67 2d 77 61 69 74 6f 6e 73 29 0a 20 20 20 20 20 g-waitons).
152d0 20 29 0a 29 29 0a 0a 3b 3b 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 3d 3d 3d ================
15310 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
15320 3b 3b 20 74 65 73 74 20 73 74 65 70 73 0a 3b 3b ;; test steps.;;
15330 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15340 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15350 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15360 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15370 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 74 65 73 74 73 ======..;; tests
15380 74 65 70 2d 73 65 74 2d 73 74 61 74 75 73 21 20 tep-set-status!
15390 75 73 65 64 20 74 6f 20 62 65 20 68 65 72 65 0a used to be here.
153a0 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 2d 67 .(define (test-g
153b0 65 74 2d 6b 69 6c 6c 2d 72 65 71 75 65 73 74 20 et-kill-request
153c0 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 20 run-id test-id)
153d0 3b 3b 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e ;; run-id test-n
153e0 61 6d 65 20 69 74 65 6d 64 61 74 29 0a 20 20 28 ame itemdat). (
153f0 6c 65 74 2a 20 28 28 74 65 73 74 64 61 74 20 20 let* ((testdat
15400 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 (rmt:get-test-i
15410 6e 66 6f 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 nfo-by-id run-id
15420 20 74 65 73 74 2d 69 64 29 29 29 0a 20 20 20 20 test-id))).
15430 28 61 6e 64 20 74 65 73 74 64 61 74 0a 09 20 28 (and testdat.. (
15440 65 71 75 61 6c 3f 20 28 74 65 73 74 3a 67 65 74 equal? (test:get
15450 2d 73 74 61 74 65 20 74 65 73 74 64 61 74 29 20 -state testdat)
15460 22 4b 49 4c 4c 52 45 51 22 29 29 29 29 0a 0a 28 "KILLREQ"))))..(
15470 64 65 66 69 6e 65 20 28 74 65 73 74 3a 74 64 62 define (test:tdb
15480 2d 67 65 74 2d 72 75 6e 64 61 74 2d 63 6f 75 6e -get-rundat-coun
15490 74 20 74 64 62 29 0a 20 20 28 69 66 20 74 64 62 t tdb). (if tdb
154a0 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 65 . (let ((re
154b0 73 20 30 29 29 0a 09 28 73 71 6c 69 74 65 33 3a s 0))..(sqlite3:
154c0 66 6f 72 2d 65 61 63 68 2d 72 6f 77 0a 09 20 28 for-each-row.. (
154d0 6c 61 6d 62 64 61 20 28 63 6f 75 6e 74 29 0a 09 lambda (count)..
154e0 20 20 20 28 73 65 74 21 20 72 65 73 20 63 6f 75 (set! res cou
154f0 6e 74 29 29 0a 09 20 74 64 62 0a 09 20 22 53 45 nt)).. tdb.. "SE
15500 4c 45 43 54 20 63 6f 75 6e 74 28 69 64 29 20 46 LECT count(id) F
15510 52 4f 4d 20 74 65 73 74 5f 72 75 6e 64 61 74 3b ROM test_rundat;
15520 22 29 0a 09 72 65 73 29 29 0a 20 20 30 29 0a 0a ")..res)). 0)..
15530 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 75 (define (tests:u
15540 70 64 61 74 65 2d 63 65 6e 74 72 61 6c 2d 6d 65 pdate-central-me
15550 74 61 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 20 74 ta-info run-id t
15560 65 73 74 2d 69 64 20 63 70 75 6c 6f 61 64 20 64 est-id cpuload d
15570 69 73 6b 66 72 65 65 20 6d 69 6e 75 74 65 73 20 iskfree minutes
15580 75 6e 61 6d 65 20 68 6f 73 74 6e 61 6d 65 29 0a uname hostname).
15590 20 20 28 72 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 (rmt:general-c
155a0 61 6c 6c 20 27 75 70 64 61 74 65 2d 74 65 73 74 all 'update-test
155b0 2d 72 75 6e 64 61 74 20 72 75 6e 2d 69 64 20 74 -rundat run-id t
155c0 65 73 74 2d 69 64 20 28 63 75 72 72 65 6e 74 2d est-id (current-
155d0 73 65 63 6f 6e 64 73 29 20 28 6f 72 20 63 70 75 seconds) (or cpu
155e0 6c 6f 61 64 20 2d 31 29 28 6f 72 20 64 69 73 6b load -1)(or disk
155f0 66 72 65 65 20 2d 31 29 20 2d 31 20 28 6f 72 20 free -1) -1 (or
15600 6d 69 6e 75 74 65 73 20 2d 31 29 29 0a 20 20 28 minutes -1)). (
15610 69 66 20 28 61 6e 64 20 63 70 75 6c 6f 61 64 20 if (and cpuload
15620 64 69 73 6b 66 72 65 65 29 0a 20 20 20 20 20 20 diskfree).
15630 28 72 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 61 6c (rmt:general-cal
15640 6c 20 27 75 70 64 61 74 65 2d 63 70 75 6c 6f 61 l 'update-cpuloa
15650 64 2d 64 69 73 6b 66 72 65 65 20 72 75 6e 2d 69 d-diskfree run-i
15660 64 20 63 70 75 6c 6f 61 64 20 64 69 73 6b 66 72 d cpuload diskfr
15670 65 65 20 74 65 73 74 2d 69 64 29 29 0a 20 20 28 ee test-id)). (
15680 69 66 20 6d 69 6e 75 74 65 73 20 0a 20 20 20 20 if minutes .
15690 20 20 28 72 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 (rmt:general-c
156a0 61 6c 6c 20 27 75 70 64 61 74 65 2d 72 75 6e 2d all 'update-run-
156b0 64 75 72 61 74 69 6f 6e 20 72 75 6e 2d 69 64 20 duration run-id
156c0 6d 69 6e 75 74 65 73 20 74 65 73 74 2d 69 64 29 minutes test-id)
156d0 29 0a 20 20 28 69 66 20 28 61 6e 64 20 75 6e 61 ). (if (and una
156e0 6d 65 20 68 6f 73 74 6e 61 6d 65 29 0a 20 20 20 me hostname).
156f0 20 20 20 28 72 6d 74 3a 67 65 6e 65 72 61 6c 2d (rmt:general-
15700 63 61 6c 6c 20 27 75 70 64 61 74 65 2d 75 6e 61 call 'update-una
15710 6d 65 2d 68 6f 73 74 20 72 75 6e 2d 69 64 20 75 me-host run-id u
15720 6e 61 6d 65 20 68 6f 73 74 6e 61 6d 65 20 74 65 name hostname te
15730 73 74 2d 69 64 29 29 29 0a 20 20 0a 3b 3b 20 54 st-id))). .;; T
15740 68 69 73 20 6f 6e 65 20 69 73 20 66 6f 72 20 72 his one is for r
15750 75 6e 6e 69 6e 67 20 77 69 74 68 20 6e 6f 20 64 unning with no d
15760 62 20 61 63 63 65 73 73 20 28 69 2e 65 2e 20 76 b access (i.e. v
15770 69 61 20 72 6d 74 3a 20 69 6e 74 65 72 6e 61 6c ia rmt: internal
15780 6c 79 29 0a 28 64 65 66 69 6e 65 20 28 74 65 73 ly).(define (tes
15790 74 73 3a 73 65 74 2d 66 75 6c 6c 2d 6d 65 74 61 ts:set-full-meta
157a0 2d 69 6e 66 6f 20 64 62 20 74 65 73 74 2d 69 64 -info db test-id
157b0 20 72 75 6e 2d 69 64 20 6d 69 6e 75 74 65 73 20 run-id minutes
157c0 77 6f 72 6b 2d 61 72 65 61 20 72 65 6d 74 72 69 work-area remtri
157d0 65 73 29 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 es).;; (define (
157e0 74 65 73 74 73 3a 73 65 74 2d 66 75 6c 6c 2d 6d tests:set-full-m
157f0 65 74 61 2d 69 6e 66 6f 20 74 65 73 74 2d 69 64 eta-info test-id
15800 20 72 75 6e 2d 69 64 20 6d 69 6e 75 74 65 73 20 run-id minutes
15810 77 6f 72 6b 2d 61 72 65 61 29 0a 3b 3b 20 20 28 work-area).;; (
15820 6c 65 74 20 28 28 72 65 6d 74 72 69 65 73 20 31 let ((remtries 1
15830 30 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 63 70 0)). (let* ((cp
15840 75 6c 6f 61 64 20 20 28 67 65 74 2d 63 70 75 2d uload (get-cpu-
15850 6c 6f 61 64 29 29 0a 09 20 28 64 69 73 6b 66 72 load)).. (diskfr
15860 65 65 20 28 67 65 74 2d 64 66 20 28 63 75 72 72 ee (get-df (curr
15870 65 6e 74 2d 64 69 72 65 63 74 6f 72 79 29 29 29 ent-directory)))
15880 0a 09 20 28 75 6e 61 6d 65 20 20 20 20 28 67 65 .. (uname (ge
15890 74 2d 75 6e 61 6d 65 20 22 2d 73 72 76 70 69 6f t-uname "-srvpio
158a0 22 29 29 0a 09 20 28 68 6f 73 74 6e 61 6d 65 20 ")).. (hostname
158b0 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 (get-host-name))
158c0 29 0a 20 20 20 20 28 74 65 73 74 73 3a 75 70 64 ). (tests:upd
158d0 61 74 65 2d 63 65 6e 74 72 61 6c 2d 6d 65 74 61 ate-central-meta
158e0 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 20 74 65 73 -info run-id tes
158f0 74 2d 69 64 20 63 70 75 6c 6f 61 64 20 64 69 73 t-id cpuload dis
15900 6b 66 72 65 65 20 6d 69 6e 75 74 65 73 20 75 6e kfree minutes un
15910 61 6d 65 20 68 6f 73 74 6e 61 6d 65 29 29 29 0a ame hostname))).
15920 20 20 20 20 0a 3b 3b 20 28 64 65 66 69 6e 65 20 .;; (define
15930 28 74 65 73 74 73 3a 73 65 74 2d 70 61 72 74 69 (tests:set-parti
15940 61 6c 2d 6d 65 74 61 2d 69 6e 66 6f 20 74 65 73 al-meta-info tes
15950 74 2d 69 64 20 72 75 6e 2d 69 64 20 6d 69 6e 75 t-id run-id minu
15960 74 65 73 20 77 6f 72 6b 2d 61 72 65 61 29 0a 23 tes work-area).#
15970 3b 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a ;(define (tests:
15980 73 65 74 2d 70 61 72 74 69 61 6c 2d 6d 65 74 61 set-partial-meta
15990 2d 69 6e 66 6f 20 74 65 73 74 2d 69 64 20 72 75 -info test-id ru
159a0 6e 2d 69 64 20 6d 69 6e 75 74 65 73 20 77 6f 72 n-id minutes wor
159b0 6b 2d 61 72 65 61 20 72 65 6d 74 72 69 65 73 29 k-area remtries)
159c0 0a 20 20 28 6c 65 74 2a 20 28 28 63 70 75 6c 6f . (let* ((cpulo
159d0 61 64 20 20 28 67 65 74 2d 63 70 75 2d 6c 6f 61 ad (get-cpu-loa
159e0 64 29 29 0a 09 20 28 64 69 73 6b 66 72 65 65 20 d)).. (diskfree
159f0 28 67 65 74 2d 64 66 20 28 63 75 72 72 65 6e 74 (get-df (current
15a00 2d 64 69 72 65 63 74 6f 72 79 29 29 29 0a 09 20 -directory)))..
15a10 28 72 65 6d 74 72 69 65 73 20 31 30 29 29 0a 20 (remtries 10)).
15a20 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 (handle-excep
15a30 74 69 6f 6e 73 0a 20 20 20 20 20 65 78 6e 0a 20 tions. exn.
15a40 20 20 20 20 28 69 66 20 28 3e 20 72 65 6d 74 72 (if (> remtr
15a50 69 65 73 20 30 29 0a 09 20 28 62 65 67 69 6e 0a ies 0).. (begin.
15a60 09 20 20 20 28 70 72 69 6e 74 2d 63 61 6c 6c 2d . (print-call-
15a70 63 68 61 69 6e 20 28 63 75 72 72 65 6e 74 2d 65 chain (current-e
15a80 72 72 6f 72 2d 70 6f 72 74 29 29 0a 09 20 20 20 rror-port))..
15a90 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
15aa0 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
15ab0 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a -port* "WARNING:
15ac0 20 66 61 69 6c 65 64 20 74 6f 20 73 65 74 20 6d failed to set m
15ad0 65 74 61 20 69 6e 66 6f 2e 20 57 69 6c 6c 20 74 eta info. Will t
15ae0 72 79 20 22 20 72 65 6d 74 72 69 65 73 20 22 20 ry " remtries "
15af0 6d 6f 72 65 20 74 69 6d 65 73 22 29 0a 09 20 20 more times")..
15b00 20 28 73 65 74 21 20 72 65 6d 74 72 69 65 73 20 (set! remtries
15b10 28 2d 20 72 65 6d 74 72 69 65 73 20 31 29 29 0a (- remtries 1)).
15b20 09 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 . (thread-slee
15b30 70 21 20 31 30 29 0a 09 20 20 20 28 74 65 73 74 p! 10).. (test
15b40 73 3a 73 65 74 2d 66 75 6c 6c 2d 6d 65 74 61 2d s:set-full-meta-
15b50 69 6e 66 6f 20 64 62 20 74 65 73 74 2d 69 64 20 info db test-id
15b60 72 75 6e 2d 69 64 20 6d 69 6e 75 74 65 73 20 77 run-id minutes w
15b70 6f 72 6b 2d 61 72 65 61 20 28 2d 20 72 65 6d 74 ork-area (- remt
15b80 72 69 65 73 20 31 29 29 29 0a 09 20 28 6c 65 74 ries 1))).. (let
15b90 20 28 28 65 72 72 2d 73 74 61 74 75 73 20 28 28 ((err-status ((
15ba0 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 condition-proper
15bb0 74 79 2d 61 63 63 65 73 73 6f 72 20 27 73 71 6c ty-accessor 'sql
15bc0 69 74 65 33 20 27 73 74 61 74 75 73 20 23 66 29 ite3 'status #f)
15bd0 20 65 78 6e 29 29 29 0a 09 20 20 20 28 64 65 62 exn))).. (deb
15be0 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 ug:print-error 0
15bf0 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
15c00 72 74 2a 20 22 74 72 69 65 64 20 66 6f 72 20 6f rt* "tried for o
15c10 76 65 72 20 61 20 6d 69 6e 75 74 65 20 74 6f 20 ver a minute to
15c20 75 70 64 61 74 65 20 6d 65 74 61 20 69 6e 66 6f update meta info
15c30 20 61 6e 64 20 66 61 69 6c 65 64 2e 20 47 69 76 and failed. Giv
15c40 69 6e 67 20 75 70 22 29 0a 09 20 20 20 28 64 65 ing up").. (de
15c50 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
15c60 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
15c70 45 58 43 45 50 54 49 4f 4e 3a 20 64 61 74 61 62 EXCEPTION: datab
15c80 61 73 65 20 70 72 6f 62 61 62 6c 79 20 6f 76 65 ase probably ove
15c90 72 6c 6f 61 64 65 64 20 6f 72 20 75 6e 72 65 61 rloaded or unrea
15ca0 64 61 62 6c 65 2e 22 29 0a 09 20 20 20 28 64 65 dable.").. (de
15cb0 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
15cc0 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
15cd0 20 6d 65 73 73 61 67 65 3a 20 22 20 28 28 63 6f message: " ((co
15ce0 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 ndition-property
15cf0 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 -accessor 'exn '
15d00 6d 65 73 73 61 67 65 29 20 65 78 6e 29 29 0a 09 message) exn))..
15d10 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
15d20 35 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 5 *default-log-p
15d30 6f 72 74 2a 20 22 65 78 6e 3d 22 20 28 63 6f 6e ort* "exn=" (con
15d40 64 69 74 69 6f 6e 2d 3e 6c 69 73 74 20 65 78 6e dition->list exn
15d50 29 29 0a 09 20 20 20 28 64 65 62 75 67 3a 70 72 )).. (debug:pr
15d60 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
15d70 6f 67 2d 70 6f 72 74 2a 20 22 20 73 74 61 74 75 og-port* " statu
15d80 73 3a 20 20 22 20 28 28 63 6f 6e 64 69 74 69 6f s: " ((conditio
15d90 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 n-property-acces
15da0 73 6f 72 20 27 73 71 6c 69 74 65 33 20 27 73 74 sor 'sqlite3 'st
15db0 61 74 75 73 29 20 65 78 6e 29 29 0a 09 20 20 20 atus) exn))..
15dc0 28 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 (print-call-chai
15dd0 6e 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 n (current-error
15de0 2d 70 6f 72 74 29 29 29 29 0a 20 20 20 20 20 28 -port)))). (
15df0 74 65 73 74 73 3a 75 70 64 61 74 65 2d 74 65 73 tests:update-tes
15e00 74 64 61 74 2d 6d 65 74 61 2d 69 6e 66 6f 20 64 tdat-meta-info d
15e10 62 20 74 65 73 74 2d 69 64 20 77 6f 72 6b 2d 61 b test-id work-a
15e20 72 65 61 20 63 70 75 6c 6f 61 64 20 64 69 73 6b rea cpuload disk
15e30 66 72 65 65 20 6d 69 6e 75 74 65 73 29 0a 20 20 free minutes).
15e40 29 29 29 0a 09 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d ))).. .;;=======
15e50 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15e60 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15e70 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15e80 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
15e90 3b 3b 20 41 20 52 20 43 20 48 20 49 20 56 20 49 ;; A R C H I V I
15ea0 20 4e 20 47 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d N G.;;=========
15eb0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15ec0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15ed0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15ee0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 =============..(
15ef0 64 65 66 69 6e 65 20 28 74 65 73 74 3a 61 72 63 define (test:arc
15f00 68 69 76 65 20 64 62 20 74 65 73 74 2d 69 64 29 hive db test-id)
15f10 0a 20 20 23 66 29 0a 0a 28 64 65 66 69 6e 65 20 . #f)..(define
15f20 28 74 65 73 74 3a 61 72 63 68 69 76 65 2d 74 65 (test:archive-te
15f30 73 74 73 20 64 62 20 6b 65 79 6e 61 6d 65 73 20 sts db keynames
15f40 74 61 72 67 65 74 29 0a 20 20 23 66 29 0a 0a target). #f)..