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 74 65 73 74 73 3a 67 65 74 2d . (tests:get-
0830: 76 61 6c 69 64 2d 74 65 73 74 73 20 28 6d 61 6b valid-tests (mak
0840: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 20 74 65 e-hash-table) te
0850: 73 74 2d 73 65 61 72 63 68 2d 70 61 74 68 29 29 st-search-path))
0860: 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 )..(define (test
0870: 73 3a 67 65 74 2d 74 65 73 74 73 2d 73 65 61 72 s:get-tests-sear
0880: 63 68 2d 70 61 74 68 20 63 66 67 64 61 74 29 0a ch-path cfgdat).
0890: 20 20 28 6c 65 74 20 28 28 70 61 74 68 73 20 28 (let ((paths (
08a0: 6c 65 74 20 28 28 73 65 63 74 69 6f 6e 20 28 69 let ((section (i
08b0: 66 20 63 66 67 64 61 74 0a 09 09 09 09 20 20 28 f cfgdat..... (
08c0: 63 6f 6e 66 69 67 66 3a 67 65 74 2d 73 65 63 74 configf:get-sect
08d0: 69 6f 6e 20 63 66 67 64 61 74 20 22 74 65 73 74 ion cfgdat "test
08e0: 73 2d 70 61 74 68 73 22 29 0a 09 09 09 09 20 20 s-paths").....
08f0: 23 66 29 29 29 0a 09 09 20 28 69 66 20 73 65 63 #f)))... (if sec
0900: 74 69 6f 6e 0a 09 09 20 20 20 20 20 28 6d 61 70 tion... (map
0910: 20 63 61 64 72 20 73 65 63 74 69 6f 6e 29 0a 09 cadr section)..
0920: 09 20 20 20 20 20 27 28 29 29 29 29 29 0a 20 20 . '())))).
0930: 20 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 (filter (lambd
0940: 61 20 28 64 29 0a 09 20 20 20 20 20 20 28 69 66 a (d).. (if
0950: 20 28 64 69 72 65 63 74 6f 72 79 2d 65 78 69 73 (directory-exis
0960: 74 73 3f 20 64 29 0a 09 09 20 20 64 0a 09 09 20 ts? d)... d...
0970: 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 28 69 (begin... (i
0980: 66 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f f (common:low-no
0990: 69 73 65 2d 70 72 69 6e 74 20 36 30 20 22 74 65 ise-print 60 "te
09a0: 73 74 73 3a 67 65 74 2d 74 65 73 74 73 2d 73 65 sts:get-tests-se
09b0: 61 72 63 68 2d 70 61 74 68 22 20 64 29 0a 09 09 arch-path" d)...
09c0: 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 .(debug:print 0
09d0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
09e0: 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 70 72 6f t* "WARNING: pro
09f0: 62 6c 65 6d 20 77 69 74 68 20 64 69 72 65 63 74 blem with direct
0a00: 6f 72 79 20 22 20 64 20 22 2c 20 64 72 6f 70 70 ory " d ", dropp
0a10: 69 6e 67 20 69 74 20 66 72 6f 6d 20 74 65 73 74 ing it from test
0a20: 73 20 70 61 74 68 22 29 29 0a 09 09 20 20 20 20 s path"))...
0a30: 23 66 29 29 29 0a 09 20 20 20 20 28 61 70 70 65 #f))).. (appe
0a40: 6e 64 20 70 61 74 68 73 20 28 6c 69 73 74 20 28 nd paths (list (
0a50: 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 conc *toppath* "
0a60: 2f 74 65 73 74 73 22 29 29 29 29 29 29 0a 0a 28 /tests"))))))..(
0a70: 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 67 65 define (tests:ge
0a80: 74 2d 76 61 6c 69 64 2d 74 65 73 74 73 20 74 65 t-valid-tests te
0a90: 73 74 2d 72 65 67 69 73 74 72 79 20 74 65 73 74 st-registry test
0aa0: 73 2d 70 61 74 68 73 29 0a 20 20 28 69 66 20 28 s-paths). (if (
0ab0: 6e 75 6c 6c 3f 20 74 65 73 74 73 2d 70 61 74 68 null? tests-path
0ac0: 73 29 20 0a 20 20 20 20 20 20 74 65 73 74 2d 72 s) . test-r
0ad0: 65 67 69 73 74 72 79 0a 20 20 20 20 20 20 28 6c egistry. (l
0ae0: 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 et loop ((hed (c
0af0: 61 72 20 74 65 73 74 73 2d 70 61 74 68 73 29 29 ar tests-paths))
0b00: 0a 09 09 20 28 74 61 6c 20 28 63 64 72 20 74 65 ... (tal (cdr te
0b10: 73 74 73 2d 70 61 74 68 73 29 29 29 0a 09 28 69 sts-paths)))..(i
0b20: 66 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 f (common:file-e
0b30: 78 69 73 74 73 3f 20 68 65 64 29 0a 09 20 20 20 xists? hed)..
0b40: 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 (for-each (lamb
0b50: 64 61 20 28 74 65 73 74 2d 70 61 74 68 29 0a 09 da (test-path)..
0b60: 09 09 28 6c 65 74 2a 20 28 28 74 6e 61 6d 65 20 ..(let* ((tname
0b70: 20 20 28 6c 61 73 74 20 28 73 74 72 69 6e 67 2d (last (string-
0b80: 73 70 6c 69 74 20 74 65 73 74 2d 70 61 74 68 20 split test-path
0b90: 22 2f 22 29 29 29 0a 09 09 09 20 20 20 20 20 20 "/")))....
0ba0: 20 28 74 63 6f 6e 66 69 67 20 28 63 6f 6e 63 20 (tconfig (conc
0bb0: 74 65 73 74 2d 70 61 74 68 20 22 2f 74 65 73 74 test-path "/test
0bc0: 63 6f 6e 66 69 67 22 29 29 29 0a 09 09 09 20 20 config")))....
0bd0: 28 69 66 20 28 61 6e 64 20 28 6e 6f 74 20 28 68 (if (and (not (h
0be0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
0bf0: 66 61 75 6c 74 20 74 65 73 74 2d 72 65 67 69 73 fault test-regis
0c00: 74 72 79 20 74 6e 61 6d 65 20 23 66 29 29 0a 09 try tname #f))..
0c10: 09 09 09 20 20 20 28 63 6f 6d 6d 6f 6e 3a 66 69 ... (common:fi
0c20: 6c 65 2d 65 78 69 73 74 73 3f 20 74 63 6f 6e 66 le-exists? tconf
0c30: 69 67 29 29 0a 09 09 09 20 20 20 20 20 20 28 68 ig)).... (h
0c40: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 ash-table-set! t
0c50: 65 73 74 2d 72 65 67 69 73 74 72 79 20 74 6e 61 est-registry tna
0c60: 6d 65 20 74 65 73 74 2d 70 61 74 68 29 29 29 29 me test-path))))
0c70: 0a 09 09 20 20 20 20 20 20 28 67 6c 6f 62 20 28 ... (glob (
0c80: 63 6f 6e 63 20 68 65 64 20 22 2f 2a 22 29 29 29 conc hed "/*")))
0c90: 29 0a 09 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 )..(if (null? ta
0ca0: 6c 29 0a 09 20 20 20 20 74 65 73 74 2d 72 65 67 l).. test-reg
0cb0: 69 73 74 72 79 0a 09 20 20 20 20 28 6c 6f 6f 70 istry.. (loop
0cc0: 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 (car tal)(cdr t
0cd0: 61 6c 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e al))))))..(defin
0ce0: 65 20 28 74 65 73 74 73 3a 66 69 6c 74 65 72 2d e (tests:filter-
0cf0: 74 65 73 74 2d 6e 61 6d 65 73 2d 6e 6f 74 2d 6d test-names-not-m
0d00: 61 74 63 68 65 64 20 74 65 73 74 2d 6e 61 6d 65 atched test-name
0d10: 73 20 74 65 73 74 2d 70 61 74 74 73 29 0a 20 20 s test-patts).
0d20: 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 74 (delete-duplicat
0d30: 65 73 0a 20 20 20 28 66 69 6c 74 65 72 20 28 6c es. (filter (l
0d40: 61 6d 62 64 61 20 28 74 65 73 74 6e 61 6d 65 29 ambda (testname)
0d50: 0a 09 20 20 20 20 20 28 6e 6f 74 20 28 74 65 73 .. (not (tes
0d60: 74 73 3a 6d 61 74 63 68 20 74 65 73 74 2d 70 61 ts:match test-pa
0d70: 74 74 73 20 74 65 73 74 6e 61 6d 65 20 23 66 29 tts testname #f)
0d80: 29 29 0a 09 20 20 20 74 65 73 74 2d 6e 61 6d 65 )).. test-name
0d90: 73 29 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 s)))...(define (
0da0: 74 65 73 74 73 3a 66 69 6c 74 65 72 2d 74 65 73 tests:filter-tes
0db0: 74 2d 6e 61 6d 65 73 20 74 65 73 74 2d 6e 61 6d t-names test-nam
0dc0: 65 73 20 74 65 73 74 2d 70 61 74 74 73 29 0a 20 es test-patts).
0dd0: 20 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 (delete-duplica
0de0: 74 65 73 0a 20 20 20 28 66 69 6c 74 65 72 20 28 tes. (filter (
0df0: 6c 61 6d 62 64 61 20 28 74 65 73 74 6e 61 6d 65 lambda (testname
0e00: 29 0a 09 20 20 20 20 20 28 74 65 73 74 73 3a 6d ).. (tests:m
0e10: 61 74 63 68 20 74 65 73 74 2d 70 61 74 74 73 20 atch test-patts
0e20: 74 65 73 74 6e 61 6d 65 20 23 66 29 29 0a 09 20 testname #f))..
0e30: 20 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 29 0a test-names))).
0e40: 0a 3b 3b 20 69 74 65 6d 6d 61 70 20 69 73 20 61 .;; itemmap is a
0e50: 20 6c 69 73 74 20 6f 66 20 74 65 73 74 6e 61 6d list of testnam
0e60: 65 20 70 61 74 74 65 72 6e 73 20 74 6f 20 6d 61 e patterns to ma
0e70: 70 73 0a 3b 3b 20 20 20 20 20 74 65 73 74 31 20 ps.;; test1
0e80: 2e 2a 2f 62 61 72 2f 28 5c 64 2b 29 20 66 6f 6f .*/bar/(\d+) foo
0e90: 2f 5c 31 0a 3b 3b 20 20 20 20 20 25 20 20 20 20 /\1.;; %
0ea0: 20 66 6f 6f 2f 28 5b 5e 2f 5d 2b 29 20 20 5c 31 foo/([^/]+) \1
0eb0: 2f 62 61 72 0a 3b 3b 0a 3b 3b 20 23 20 4e 4f 54 /bar.;;.;; # NOT
0ec0: 45 3a 20 74 68 65 20 6c 69 6e 65 20 77 69 74 68 E: the line with
0ed0: 20 74 68 65 20 73 69 6e 67 6c 65 20 25 20 63 6f the single % co
0ee0: 75 6c 64 20 62 65 20 74 68 65 20 72 65 73 75 6c uld be the resul
0ef0: 74 20 6f 66 0a 3b 3b 20 23 20 20 20 20 20 20 20 t of.;; #
0f00: 69 74 65 6d 6d 61 70 20 65 6e 74 72 79 20 69 6e itemmap entry in
0f10: 20 72 65 71 75 69 72 65 6d 65 6e 74 73 20 28 6c requirements (l
0f20: 65 67 61 63 79 29 2e 20 54 68 65 20 69 74 65 6d egacy). The item
0f30: 6d 61 70 0a 3b 3b 20 23 20 20 20 20 20 20 20 72 map.;; # r
0f40: 65 71 75 69 72 65 6d 65 6e 74 73 20 65 6e 74 72 equirements entr
0f50: 79 20 69 73 20 64 65 70 72 65 63 61 74 65 64 0a y is deprecated.
0f60: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 ;;.(define (test
0f70: 73 3a 67 65 74 2d 69 74 65 6d 6d 61 70 73 20 74 s:get-itemmaps t
0f80: 63 6f 6e 66 69 67 29 0a 20 20 28 6c 65 74 20 28 config). (let (
0f90: 28 62 61 73 65 2d 69 74 65 6d 6d 61 70 20 20 28 (base-itemmap (
0fa0: 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 74 configf:lookup t
0fb0: 63 6f 6e 66 69 67 20 22 72 65 71 75 69 72 65 6d config "requirem
0fc0: 65 6e 74 73 22 20 22 69 74 65 6d 6d 61 70 22 29 ents" "itemmap")
0fd0: 29 0a 09 28 69 74 65 6d 6d 61 70 2d 74 61 62 6c )..(itemmap-tabl
0fe0: 65 20 28 63 6f 6e 66 69 67 66 3a 67 65 74 2d 73 e (configf:get-s
0ff0: 65 63 74 69 6f 6e 20 74 63 6f 6e 66 69 67 20 22 ection tconfig "
1000: 69 74 65 6d 6d 61 70 22 29 29 29 0a 20 20 20 20 itemmap"))).
1010: 28 61 70 70 65 6e 64 20 28 69 66 20 62 61 73 65 (append (if base
1020: 2d 69 74 65 6d 6d 61 70 0a 09 09 28 6c 69 73 74 -itemmap...(list
1030: 20 28 6c 69 73 74 20 22 25 22 20 62 61 73 65 2d (list "%" base-
1040: 69 74 65 6d 6d 61 70 29 29 0a 09 09 27 28 29 29 itemmap))...'())
1050: 0a 09 20 20 20 20 28 69 66 20 69 74 65 6d 6d 61 .. (if itemma
1060: 70 2d 74 61 62 6c 65 0a 09 09 69 74 65 6d 6d 61 p-table...itemma
1070: 70 2d 74 61 62 6c 65 0a 09 09 27 28 29 29 29 29 p-table...'())))
1080: 29 0a 0a 3b 3b 20 67 69 76 65 6e 20 61 20 6c 69 )..;; given a li
1090: 73 74 20 6f 66 20 69 74 65 6d 6d 61 70 73 20 28 st of itemmaps (
10a0: 74 65 73 74 6e 61 6d 65 20 2e 20 6d 61 70 29 2c testname . map),
10b0: 20 72 65 74 75 72 6e 20 74 68 65 20 66 69 72 73 return the firs
10c0: 74 20 6d 61 74 63 68 0a 3b 3b 0a 28 64 65 66 69 t match.;;.(defi
10d0: 6e 65 20 28 74 65 73 74 73 3a 6c 6f 6f 6b 75 70 ne (tests:lookup
10e0: 2d 69 74 65 6d 6d 61 70 20 69 74 65 6d 6d 61 70 -itemmap itemmap
10f0: 73 20 74 65 73 74 6e 61 6d 65 29 0a 20 20 28 6c s testname). (l
1100: 65 74 20 28 28 62 65 73 74 2d 6d 61 74 63 68 65 et ((best-matche
1110: 73 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 s (filter (lambd
1120: 61 20 28 69 74 65 6d 6d 61 70 29 0a 09 09 09 09 a (itemmap).....
1130: 28 74 65 73 74 73 3a 6d 61 74 63 68 20 28 63 61 (tests:match (ca
1140: 72 20 69 74 65 6d 6d 61 70 29 20 74 65 73 74 6e r itemmap) testn
1150: 61 6d 65 20 23 66 29 29 0a 09 09 09 20 20 20 20 ame #f))....
1160: 20 20 69 74 65 6d 6d 61 70 73 29 29 29 0a 20 20 itemmaps))).
1170: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 62 65 73 (if (null? bes
1180: 74 2d 6d 61 74 63 68 65 73 29 0a 09 23 66 0a 09 t-matches)..#f..
1190: 28 6c 65 74 20 28 28 72 65 73 20 28 63 61 72 20 (let ((res (car
11a0: 62 65 73 74 2d 6d 61 74 63 68 65 73 29 29 29 0a best-matches))).
11b0: 09 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 . ;; (debug:pri
11c0: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
11d0: 67 2d 70 6f 72 74 2a 20 22 72 65 73 3d 22 20 72 g-port* "res=" r
11e0: 65 73 29 0a 09 20 20 28 63 6f 6e 64 0a 09 20 20 es).. (cond..
11f0: 20 28 28 73 74 72 69 6e 67 3f 20 72 65 73 29 20 ((string? res)
1200: 72 65 73 29 20 3b 3b 3b 20 46 49 58 20 54 48 45 res) ;;; FIX THE
1210: 20 52 4f 4f 54 20 43 41 55 53 45 20 48 45 52 45 ROOT CAUSE HERE
1220: 20 2e 2e 2e 2e 0a 09 20 20 20 28 28 6e 75 6c 6c ...... ((null
1230: 3f 20 72 65 73 29 20 20 20 23 66 29 0a 09 20 20 ? res) #f)..
1240: 20 28 28 73 74 72 69 6e 67 3f 20 28 63 64 72 20 ((string? (cdr
1250: 72 65 73 29 29 20 28 63 64 72 20 72 65 73 29 29 res)) (cdr res))
1260: 20 20 3b 3b 20 69 74 20 69 73 20 61 20 70 61 69 ;; it is a pai
1270: 72 0a 09 20 20 20 28 28 73 74 72 69 6e 67 3f 20 r.. ((string?
1280: 28 63 61 64 72 20 72 65 73 29 29 28 63 61 64 72 (cadr res))(cadr
1290: 20 72 65 73 29 29 20 3b 3b 20 69 74 20 69 73 20 res)) ;; it is
12a0: 61 20 6c 69 73 74 0a 09 20 20 20 28 65 6c 73 65 a list.. (else
12b0: 20 63 61 64 72 20 72 65 73 29 29 29 29 29 29 0a cadr res)))))).
12c0: 0a 3b 3b 20 72 65 74 75 72 6e 20 69 74 65 6d 73 .;; return items
12d0: 20 67 69 76 65 6e 20 63 6f 6e 66 69 67 0a 3b 3b given config.;;
12e0: 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a .(define (tests:
12f0: 67 65 74 2d 69 74 65 6d 73 20 74 63 6f 6e 66 69 get-items tconfi
1300: 67 29 0a 20 20 28 6c 65 74 20 28 28 69 74 65 6d g). (let ((item
1310: 73 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 s (hash-tab
1320: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 le-ref/default t
1330: 63 6f 6e 66 69 67 20 22 69 74 65 6d 73 22 20 23 config "items" #
1340: 66 29 29 20 3b 3b 20 69 74 65 6d 73 20 34 0a 09 f)) ;; items 4..
1350: 28 69 74 65 6d 73 74 61 62 6c 65 20 28 68 61 73 (itemstable (has
1360: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
1370: 75 6c 74 20 74 63 6f 6e 66 69 67 20 22 69 74 65 ult tconfig "ite
1380: 6d 73 74 61 62 6c 65 22 20 23 66 29 29 29 20 0a mstable" #f))) .
1390: 20 20 20 20 3b 3b 20 69 66 20 65 69 74 68 65 72 ;; if either
13a0: 20 69 74 65 6d 73 20 6f 72 20 69 74 65 6d 73 20 items or items
13b0: 74 61 62 6c 65 20 69 73 20 61 20 70 72 6f 63 20 table is a proc
13c0: 72 65 74 75 72 6e 20 69 74 20 73 6f 20 74 65 73 return it so tes
13d0: 74 20 72 75 6e 6e 69 6e 67 0a 20 20 20 20 3b 3b t running. ;;
13e0: 20 70 72 6f 63 65 73 73 20 63 61 6e 20 6b 6e 6f process can kno
13f0: 77 20 74 6f 20 63 61 6c 6c 20 69 74 65 6d 73 3a w to call items:
1400: 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 get-items-from-c
1410: 6f 6e 66 69 67 0a 20 20 20 20 3b 3b 20 69 66 20 onfig. ;; if
1420: 65 69 74 68 65 72 20 69 73 20 61 20 6c 69 73 74 either is a list
1430: 20 61 6e 64 20 6e 6f 6e 65 20 69 73 20 61 20 70 and none is a p
1440: 72 6f 63 20 67 6f 20 61 68 65 61 64 20 61 6e 64 roc go ahead and
1450: 20 63 61 6c 6c 20 67 65 74 2d 69 74 65 6d 73 0a call get-items.
1460: 20 20 20 20 3b 3b 20 6f 74 68 65 72 77 69 73 65 ;; otherwise
1470: 20 72 65 74 75 72 6e 20 23 66 20 2d 20 74 68 69 return #f - thi
1480: 73 20 69 73 20 6e 6f 74 20 61 6e 20 69 74 65 72 s is not an iter
1490: 61 74 65 64 20 74 65 73 74 0a 20 20 20 20 28 63 ated test. (c
14a0: 6f 6e 64 0a 20 20 20 20 20 28 28 70 72 6f 63 65 ond. ((proce
14b0: 64 75 72 65 3f 20 69 74 65 6d 73 29 20 20 20 20 dure? items)
14c0: 20 20 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a . (debug:
14d0: 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 2a 64 65 print-info 4 *de
14e0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
14f0: 22 69 74 65 6d 73 20 69 73 20 61 20 70 72 6f 63 "items is a proc
1500: 65 64 75 72 65 2c 20 77 69 6c 6c 20 63 61 6c 63 edure, will calc
1510: 20 6c 61 74 65 72 22 29 0a 20 20 20 20 20 20 69 later"). i
1520: 74 65 6d 73 29 20 20 20 20 20 20 20 20 20 20 20 tems)
1530: 20 3b 3b 20 63 61 6c 63 20 6c 61 74 65 72 0a 20 ;; calc later.
1540: 20 20 20 20 28 28 70 72 6f 63 65 64 75 72 65 3f ((procedure?
1550: 20 69 74 65 6d 73 74 61 62 6c 65 29 0a 20 20 20 itemstable).
1560: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
1570: 69 6e 66 6f 20 34 20 2a 64 65 66 61 75 6c 74 2d info 4 *default-
1580: 6c 6f 67 2d 70 6f 72 74 2a 20 22 69 74 65 6d 73 log-port* "items
1590: 74 61 62 6c 65 20 69 73 20 61 20 70 72 6f 63 65 table is a proce
15a0: 64 75 72 65 2c 20 77 69 6c 6c 20 63 61 6c 63 20 dure, will calc
15b0: 6c 61 74 65 72 22 29 0a 20 20 20 20 20 20 69 74 later"). it
15c0: 65 6d 73 74 61 62 6c 65 29 20 20 20 20 20 20 20 emstable)
15d0: 3b 3b 20 63 61 6c 63 20 6c 61 74 65 72 0a 20 20 ;; calc later.
15e0: 20 20 20 28 28 66 69 6c 74 65 72 20 28 6c 61 6d ((filter (lam
15f0: 62 64 61 20 28 78 29 0a 09 09 28 6c 65 74 20 28 bda (x)...(let (
1600: 28 76 61 6c 20 28 63 61 72 20 78 29 29 29 0a 09 (val (car x)))..
1610: 09 20 20 28 69 66 20 28 70 72 6f 63 65 64 75 72 . (if (procedur
1620: 65 3f 20 76 61 6c 29 20 76 61 6c 20 23 66 29 29 e? val) val #f))
1630: 29 0a 09 20 20 20 20 20 20 28 61 70 70 65 6e 64 ).. (append
1640: 20 28 69 66 20 28 6c 69 73 74 3f 20 69 74 65 6d (if (list? item
1650: 73 29 20 69 74 65 6d 73 20 27 28 29 29 0a 09 09 s) items '())...
1660: 20 20 20 20 20 20 28 69 66 20 28 6c 69 73 74 3f (if (list?
1670: 20 69 74 65 6d 73 74 61 62 6c 65 29 20 69 74 65 itemstable) ite
1680: 6d 73 74 61 62 6c 65 20 27 28 29 29 29 29 0a 20 mstable '()))).
1690: 20 20 20 20 20 27 68 61 76 65 2d 70 72 6f 63 65 'have-proce
16a0: 64 75 72 65 29 0a 20 20 20 20 20 28 28 6f 72 20 dure). ((or
16b0: 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 28 6c 69 (list? items)(li
16c0: 73 74 3f 20 69 74 65 6d 73 74 61 62 6c 65 29 29 st? itemstable))
16d0: 20 3b 3b 20 63 61 6c 63 20 6e 6f 77 0a 20 20 20 ;; calc now.
16e0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
16f0: 69 6e 66 6f 20 34 20 2a 64 65 66 61 75 6c 74 2d info 4 *default-
1700: 6c 6f 67 2d 70 6f 72 74 2a 20 22 69 74 65 6d 73 log-port* "items
1710: 20 61 6e 64 20 69 74 65 6d 73 74 61 62 6c 65 20 and itemstable
1720: 61 72 65 20 6c 69 73 74 73 2c 20 63 61 6c 63 20 are lists, calc
1730: 6e 6f 77 5c 6e 22 0a 09 09 09 22 20 20 20 20 69 now\n"...." i
1740: 74 65 6d 73 3a 20 22 20 69 74 65 6d 73 20 22 20 tems: " items "
1750: 69 74 65 6d 73 74 61 62 6c 65 3a 20 22 20 69 74 itemstable: " it
1760: 65 6d 73 74 61 62 6c 65 29 0a 20 20 20 20 20 20 emstable).
1770: 28 69 74 65 6d 73 3a 67 65 74 2d 69 74 65 6d 73 (items:get-items
1780: 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 20 74 63 6f -from-config tco
1790: 6e 66 69 67 29 29 0a 20 20 20 20 20 28 65 6c 73 nfig)). (els
17a0: 65 20 23 66 29 29 29 29 20 20 20 20 20 20 20 20 e #f))))
17b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
17c0: 20 20 20 3b 3b 20 6e 6f 74 20 69 74 65 72 61 74 ;; not iterat
17d0: 65 64 0a 0a 0a 3b 3b 20 72 65 74 75 72 6e 73 20 ed...;; returns
17e0: 77 61 69 74 6f 6e 73 20 77 61 69 74 6f 72 73 20 waitons waitors
17f0: 74 63 6f 6e 66 69 67 64 61 74 0a 3b 3b 0a 28 64 tconfigdat.;;.(d
1800: 65 66 69 6e 65 20 28 74 65 73 74 73 3a 67 65 74 efine (tests:get
1810: 2d 77 61 69 74 6f 6e 73 20 74 65 73 74 2d 6e 61 -waitons test-na
1820: 6d 65 20 61 6c 6c 2d 74 65 73 74 73 2d 72 65 67 me all-tests-reg
1830: 69 73 74 72 79 29 0a 20 20 20 28 6c 65 74 2a 20 istry). (let*
1840: 28 28 63 6f 6e 66 69 67 20 20 28 74 65 73 74 73 ((config (tests
1850: 3a 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 :get-testconfig
1860: 74 65 73 74 2d 6e 61 6d 65 20 23 66 20 61 6c 6c test-name #f all
1870: 2d 74 65 73 74 73 2d 72 65 67 69 73 74 72 79 20 -tests-registry
1880: 27 72 65 74 75 72 6e 2d 70 72 6f 63 73 29 29 29 'return-procs)))
1890: 20 3b 3b 20 61 73 73 75 6d 69 6e 67 20 6e 6f 20 ;; assuming no
18a0: 70 72 6f 62 6c 65 6d 73 20 77 69 74 68 20 69 6d problems with im
18b0: 6d 65 64 69 61 74 65 20 65 76 61 6c 75 61 74 69 mediate evaluati
18c0: 6f 6e 2c 20 74 68 69 73 20 63 6f 75 6c 64 20 62 on, this could b
18d0: 65 20 73 69 6d 70 6c 69 66 69 65 64 20 28 27 72 e simplified ('r
18e0: 65 74 75 72 6e 2d 70 72 6f 63 73 20 2d 3e 20 23 eturn-procs -> #
18f0: 74 29 0a 20 20 20 20 20 28 6c 65 74 20 28 28 69 t). (let ((i
1900: 6e 73 74 72 20 28 69 66 20 63 6f 6e 66 69 67 20 nstr (if config
1910: 0a 09 09 20 20 20 20 20 20 28 63 6f 6e 66 69 67 ... (config
1920: 66 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 20 f:lookup config
1930: 22 72 65 71 75 69 72 65 6d 65 6e 74 73 22 20 22 "requirements" "
1940: 77 61 69 74 6f 6e 22 29 0a 09 09 20 20 20 20 20 waiton")...
1950: 20 28 62 65 67 69 6e 20 3b 3b 20 4e 6f 20 63 6f (begin ;; No co
1960: 6e 66 69 67 20 6d 65 61 6e 73 20 74 68 69 73 20 nfig means this
1970: 69 73 20 61 20 6e 6f 6e 2d 65 78 69 73 74 61 6e is a non-existan
1980: 74 20 74 65 73 74 0a 09 09 09 28 64 65 62 75 67 t test....(debug
1990: 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a :print-error 0 *
19a0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
19b0: 2a 20 22 6e 6f 6e 2d 65 78 69 73 74 65 6e 74 20 * "non-existent
19c0: 72 65 71 75 69 72 65 64 20 74 65 73 74 20 5c 22 required test \"
19d0: 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 5c 22 22 " test-name "\""
19e0: 29 0a 09 09 09 28 65 78 69 74 20 31 29 29 29 29 )....(exit 1))))
19f0: 0a 09 20 20 20 28 69 6e 73 74 72 32 20 28 69 66 .. (instr2 (if
1a00: 20 63 6f 6e 66 69 67 0a 09 09 20 20 20 20 20 20 config...
1a10: 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 (configf:lookup
1a20: 20 63 6f 6e 66 69 67 20 22 72 65 71 75 69 72 65 config "require
1a30: 6d 65 6e 74 73 22 20 22 77 61 69 74 6f 72 22 29 ments" "waitor")
1a40: 0a 09 09 20 20 20 20 20 20 20 22 22 29 29 29 0a ... ""))).
1a50: 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 (debug:pr
1a60: 69 6e 74 2d 69 6e 66 6f 20 38 20 2a 64 65 66 61 int-info 8 *defa
1a70: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 77 ult-log-port* "w
1a80: 61 69 74 6f 6e 73 20 73 74 72 69 6e 67 20 69 73 aitons string is
1a90: 20 22 20 69 6e 73 74 72 20 22 2c 20 77 61 69 74 " instr ", wait
1aa0: 6f 72 73 20 73 74 72 69 6e 67 20 69 73 20 22 20 ors string is "
1ab0: 69 6e 73 74 72 32 29 0a 20 20 20 20 20 20 20 28 instr2). (
1ac0: 6c 65 74 20 28 28 6e 65 77 77 61 69 74 6f 6e 73 let ((newwaitons
1ad0: 0a 09 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d .. (string-
1ae0: 73 70 6c 69 74 20 28 63 6f 6e 64 0a 09 09 09 20 split (cond....
1af0: 20 20 20 20 28 28 70 72 6f 63 65 64 75 72 65 3f ((procedure?
1b00: 20 69 6e 73 74 72 29 20 3b 3b 20 68 65 72 65 20 instr) ;; here
1b10: 0a 09 09 09 20 20 20 20 20 20 28 6c 65 74 20 28 .... (let (
1b20: 28 72 65 73 20 28 69 6e 73 74 72 29 29 29 0a 09 (res (instr)))..
1b30: 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d ...(debug:print-
1b40: 69 6e 66 6f 20 38 20 2a 64 65 66 61 75 6c 74 2d info 8 *default-
1b50: 6c 6f 67 2d 70 6f 72 74 2a 20 22 77 61 69 74 6f log-port* "waito
1b60: 6e 20 70 72 6f 63 65 64 75 72 65 20 72 65 73 75 n procedure resu
1b70: 6c 74 73 20 69 6e 20 73 74 72 69 6e 67 20 22 20 lts in string "
1b80: 72 65 73 20 22 20 66 6f 72 20 74 65 73 74 20 22 res " for test "
1b90: 20 74 65 73 74 2d 6e 61 6d 65 29 0a 09 09 09 09 test-name).....
1ba0: 72 65 73 29 29 0a 09 09 09 20 20 20 20 20 28 28 res)).... ((
1bb0: 73 74 72 69 6e 67 3f 20 69 6e 73 74 72 29 20 20 string? instr)
1bc0: 20 20 20 69 6e 73 74 72 29 0a 09 09 09 20 20 20 instr)....
1bd0: 20 20 28 65 6c 73 65 20 0a 09 09 09 20 20 20 20 (else ....
1be0: 20 20 3b 3b 20 4e 4f 54 45 3a 20 54 68 69 73 20 ;; NOTE: This
1bf0: 69 73 20 61 63 74 75 61 6c 6c 79 20 74 68 65 20 is actually the
1c00: 63 61 73 65 20 6f 66 20 2a 6e 6f 2a 20 77 61 69 case of *no* wai
1c10: 74 6f 6e 73 21 20 3b 3b 20 28 64 65 62 75 67 3a tons! ;; (debug:
1c20: 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 print-error 0 *d
1c30: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
1c40: 20 22 73 6f 6d 65 74 68 69 6e 67 20 77 65 6e 74 "something went
1c50: 20 77 72 6f 6e 67 20 69 6e 20 70 72 6f 63 65 73 wrong in proces
1c60: 73 69 6e 67 20 77 61 69 74 6f 6e 73 20 66 6f 72 sing waitons for
1c70: 20 74 65 73 74 20 22 20 74 65 73 74 2d 6e 61 6d test " test-nam
1c80: 65 29 0a 09 09 09 20 20 20 20 20 20 22 22 29 29 e).... ""))
1c90: 29 29 0a 09 20 20 20 20 20 28 6e 65 77 77 61 69 )).. (newwai
1ca0: 74 6f 72 73 0a 09 20 20 20 20 20 20 28 73 74 72 tors.. (str
1cb0: 69 6e 67 2d 73 70 6c 69 74 20 28 63 6f 6e 64 0a ing-split (cond.
1cc0: 09 09 09 20 20 20 20 20 28 28 70 72 6f 63 65 64 ... ((proced
1cd0: 75 72 65 3f 20 69 6e 73 74 72 32 29 0a 09 09 09 ure? instr2)....
1ce0: 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 (let ((res
1cf0: 20 28 69 6e 73 74 72 32 29 29 29 0a 09 09 09 09 (instr2))).....
1d00: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
1d10: 6f 20 38 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 8 *default-log
1d20: 2d 70 6f 72 74 2a 20 22 77 61 69 74 6f 72 20 70 -port* "waitor p
1d30: 72 6f 63 65 64 75 72 65 20 72 65 73 75 6c 74 73 rocedure results
1d40: 20 69 6e 20 73 74 72 69 6e 67 20 22 20 72 65 73 in string " res
1d50: 20 22 20 66 6f 72 20 74 65 73 74 20 22 20 74 65 " for test " te
1d60: 73 74 2d 6e 61 6d 65 29 0a 09 09 09 09 72 65 73 st-name).....res
1d70: 29 29 0a 09 09 09 20 20 20 20 20 28 28 73 74 72 )).... ((str
1d80: 69 6e 67 3f 20 69 6e 73 74 72 32 29 20 20 20 20 ing? instr2)
1d90: 20 69 6e 73 74 72 32 29 0a 09 09 09 20 20 20 20 instr2)....
1da0: 20 28 65 6c 73 65 20 0a 09 09 09 20 20 20 20 20 (else ....
1db0: 20 3b 3b 20 4e 4f 54 45 3a 20 54 68 69 73 20 69 ;; NOTE: This i
1dc0: 73 20 61 63 74 75 61 6c 6c 79 20 74 68 65 20 63 s actually the c
1dd0: 61 73 65 20 6f 66 20 2a 6e 6f 2a 20 77 61 69 74 ase of *no* wait
1de0: 6f 6e 73 21 20 3b 3b 20 28 64 65 62 75 67 3a 70 ons! ;; (debug:p
1df0: 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 rint-error 0 *de
1e00: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
1e10: 22 73 6f 6d 65 74 68 69 6e 67 20 77 65 6e 74 20 "something went
1e20: 77 72 6f 6e 67 20 69 6e 20 70 72 6f 63 65 73 73 wrong in process
1e30: 69 6e 67 20 77 61 69 74 6f 6e 73 20 66 6f 72 20 ing waitons for
1e40: 74 65 73 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 test " test-name
1e50: 29 0a 09 09 09 20 20 20 20 20 20 22 22 29 29 29 ).... "")))
1e60: 29 29 0a 09 20 28 76 61 6c 75 65 73 0a 09 20 20 )).. (values..
1e70: 3b 3b 20 74 68 65 20 77 61 69 74 6f 6e 73 0a 09 ;; the waitons..
1e80: 20 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 (filter (lambd
1e90: 61 20 28 78 29 0a 09 09 20 20 20 20 28 69 66 20 a (x)... (if
1ea0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
1eb0: 64 65 66 61 75 6c 74 20 61 6c 6c 2d 74 65 73 74 default all-test
1ec0: 73 2d 72 65 67 69 73 74 72 79 20 78 20 23 66 29 s-registry x #f)
1ed0: 0a 09 09 09 23 74 0a 09 09 09 28 62 65 67 69 6e ....#t....(begin
1ee0: 0a 09 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 .... (debug:pri
1ef0: 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 nt-error 0 *defa
1f00: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 74 ult-log-port* "t
1f10: 65 73 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 est " test-name
1f20: 22 20 68 61 73 20 75 6e 72 65 63 6f 67 6e 69 73 " has unrecognis
1f30: 65 64 20 77 61 69 74 6f 6e 20 74 65 73 74 6e 61 ed waiton testna
1f40: 6d 65 20 22 20 78 29 0a 09 09 09 20 20 23 66 29 me " x).... #f)
1f50: 29 29 0a 09 09 20 20 6e 65 77 77 61 69 74 6f 6e ))... newwaiton
1f60: 73 29 0a 09 20 20 28 66 69 6c 74 65 72 20 28 6c s).. (filter (l
1f70: 61 6d 62 64 61 20 28 78 29 0a 09 09 20 20 20 20 ambda (x)...
1f80: 28 69 66 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (if (hash-table-
1f90: 72 65 66 2f 64 65 66 61 75 6c 74 20 61 6c 6c 2d ref/default all-
1fa0: 74 65 73 74 73 2d 72 65 67 69 73 74 72 79 20 78 tests-registry x
1fb0: 20 23 66 29 0a 09 09 09 23 74 0a 09 09 09 28 62 #f)....#t....(b
1fc0: 65 67 69 6e 0a 09 09 09 20 20 28 64 65 62 75 67 egin.... (debug
1fd0: 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a :print-error 0 *
1fe0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
1ff0: 2a 20 22 74 65 73 74 20 22 20 74 65 73 74 2d 6e * "test " test-n
2000: 61 6d 65 20 22 20 68 61 73 20 75 6e 72 65 63 6f ame " has unreco
2010: 67 6e 69 73 65 64 20 77 61 69 74 6f 6e 20 74 65 gnised waiton te
2020: 73 74 6e 61 6d 65 20 22 20 78 29 0a 09 09 09 20 stname " x)....
2030: 20 23 66 29 29 29 0a 09 09 20 20 6e 65 77 77 61 #f)))... newwa
2040: 69 74 6f 72 73 29 0a 09 20 20 63 6f 6e 66 69 67 itors).. config
2050: 29 29 29 29 29 0a 09 09 09 09 09 20 20 20 20 20 )))))......
2060: 0a 3b 3b 20 67 69 76 65 6e 20 77 61 69 74 69 6e .;; given waitin
2070: 67 2d 74 65 73 74 20 74 68 61 74 20 69 73 20 77 g-test that is w
2080: 61 69 74 69 6e 67 20 6f 6e 20 77 61 69 74 6f 6e aiting on waiton
2090: 2d 74 65 73 74 20 65 78 74 65 6e 64 20 74 65 73 -test extend tes
20a0: 74 2d 70 61 74 74 20 61 70 70 72 6f 70 72 69 61 t-patt appropria
20b0: 74 65 6c 79 0a 3b 3b 0a 3b 3b 20 20 67 65 6e 6c tely.;;.;; genl
20c0: 69 62 2f 74 65 73 74 63 6f 6e 66 69 67 20 20 20 ib/testconfig
20d0: 20 20 20 20 20 20 20 20 20 20 20 20 73 69 6d 2f sim/
20e0: 74 65 73 74 63 6f 6e 66 69 67 0a 3b 3b 20 20 67 testconfig.;; g
20f0: 65 6e 6c 69 62 2f 73 63 68 20 20 20 20 20 20 20 enlib/sch
2100: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 73 s
2110: 69 6d 2f 73 63 68 2f 63 65 6c 6c 31 0a 3b 3b 0a im/sch/cell1.;;.
2120: 3b 3b 20 20 5b 72 65 71 75 69 72 65 6d 65 6e 74 ;; [requirement
2130: 73 5d 20 20 20 20 20 20 20 20 20 20 20 20 20 20 s]
2140: 20 20 20 20 5b 72 65 71 75 69 72 65 6d 65 6e 74 [requirement
2150: 73 5d 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 s].;;
2160: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2170: 20 20 20 20 20 20 20 6d 6f 64 65 20 69 74 65 6d mode item
2180: 77 61 69 74 0a 3b 3b 20 20 20 20 20 20 20 20 20 wait.;;
2190: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
21a0: 20 20 20 20 20 20 20 20 20 23 20 74 72 69 6d 20 # trim
21b0: 6f 66 66 20 74 68 65 20 63 65 6c 6c 20 74 6f 20 off the cell to
21c0: 64 65 74 65 72 6d 69 6e 65 20 77 68 61 74 20 74 determine what t
21d0: 6f 20 72 75 6e 20 66 6f 72 20 67 65 6e 6c 69 62 o run for genlib
21e0: 0a 3b 3b 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 20
2200: 20 20 20 20 20 69 74 65 6d 6d 61 70 20 2f 2e 2a itemmap /.*
2210: 0a 3b 3b 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 .;;.;;
2220: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2230: 20 20 20 20 20 20 20 20 77 61 69 74 69 6e 67 2d waiting-
2240: 74 65 73 74 20 69 73 20 77 61 69 74 69 6e 67 20 test is waiting
2250: 6f 6e 20 77 61 69 74 6f 6e 2d 74 65 73 74 20 73 on waiton-test s
2260: 6f 20 77 65 20 6e 65 65 64 20 74 6f 20 63 72 65 o we need to cre
2270: 61 74 65 20 61 20 70 61 74 74 65 72 6e 20 66 6f ate a pattern fo
2280: 72 20 77 61 69 74 6f 6e 2d 74 65 73 74 20 67 69 r waiton-test gi
2290: 76 65 6e 20 77 61 69 74 69 6e 67 2d 74 65 73 74 ven waiting-test
22a0: 20 61 6e 64 20 69 74 65 6d 6d 61 70 0a 3b 3b 20 and itemmap.;;
22b0: 42 42 3e 20 28 74 65 73 74 73 3a 65 78 74 65 6e BB> (tests:exten
22c0: 64 2d 74 65 73 74 2d 70 61 74 74 73 20 22 6e 6f d-test-patts "no
22d0: 72 6d 61 6c 2d 73 65 63 6f 6e 64 2f 32 22 20 22 rmal-second/2" "
22e0: 6e 6f 72 6d 61 6c 2d 73 65 63 6f 6e 64 22 20 22 normal-second" "
22f0: 6e 6f 72 6d 61 6c 2d 66 69 72 73 74 22 20 27 28 normal-first" '(
2300: 29 29 0a 3b 3b 20 6f 62 73 65 72 76 65 64 20 2d )).;; observed -
2310: 3e 20 22 6e 6f 72 6d 61 6c 2d 66 69 72 73 74 2f > "normal-first/
2320: 32 2c 6e 6f 72 6d 61 6c 2d 66 69 72 73 74 2f 2c 2,normal-first/,
2330: 6e 6f 72 6d 61 6c 2d 73 65 63 6f 6e 64 2f 32 2c normal-second/2,
2340: 6e 6f 72 6d 61 6c 2d 73 65 63 6f 6e 64 2f 22 0a normal-second/".
2350: 3b 3b 20 65 78 70 65 63 74 65 64 20 2d 3e 20 22 ;; expected -> "
2360: 6e 6f 72 6d 61 6c 2d 66 69 72 73 74 2c 6e 6f 72 normal-first,nor
2370: 6d 61 6c 2d 73 65 63 6f 6e 64 2f 32 2c 6e 6f 72 mal-second/2,nor
2380: 6d 61 6c 2d 73 65 63 6f 6e 64 2f 22 0a 3b 3b 20 mal-second/".;;
2390: 74 65 73 74 70 61 74 74 20 3d 20 6e 6f 72 6d 61 testpatt = norma
23a0: 6c 2d 73 65 63 6f 6e 64 2f 32 0a 3b 3b 20 77 61 l-second/2.;; wa
23b0: 69 74 69 6e 67 2d 74 65 73 74 20 3d 20 6e 6f 72 iting-test = nor
23c0: 6d 61 6c 2d 73 65 63 6f 6e 64 0a 3b 3b 20 77 61 mal-second.;; wa
23d0: 69 74 6f 6e 2d 74 65 73 74 20 3d 20 6e 6f 72 6d iton-test = norm
23e0: 61 6c 2d 66 69 72 73 74 0a 3b 3b 20 69 74 65 6d al-first.;; item
23f0: 6d 61 70 73 20 3d 20 28 29 0a 0a 28 64 65 66 69 maps = ()..(defi
2400: 6e 65 20 28 74 65 73 74 73 3a 65 78 74 65 6e 64 ne (tests:extend
2410: 2d 74 65 73 74 2d 70 61 74 74 73 20 74 65 73 74 -test-patts test
2420: 2d 70 61 74 74 20 77 61 69 74 69 6e 67 2d 74 65 -patt waiting-te
2430: 73 74 20 77 61 69 74 6f 6e 2d 74 65 73 74 20 69 st waiton-test i
2440: 74 65 6d 6d 61 70 73 20 69 74 65 6d 69 7a 65 64 temmaps itemized
2450: 2d 77 61 69 74 6f 6e 29 0a 20 20 28 63 6f 6e 64 -waiton). (cond
2460: 0a 20 20 20 28 69 74 65 6d 69 7a 65 64 2d 77 61 . (itemized-wa
2470: 69 74 6f 6e 0a 20 20 20 20 28 6c 65 74 2a 20 28 iton. (let* (
2480: 28 69 74 65 6d 6d 61 70 20 20 20 20 20 20 20 20 (itemmap
2490: 20 20 28 74 65 73 74 73 3a 6c 6f 6f 6b 75 70 2d (tests:lookup-
24a0: 69 74 65 6d 6d 61 70 20 69 74 65 6d 6d 61 70 73 itemmap itemmaps
24b0: 20 77 61 69 74 6f 6e 2d 74 65 73 74 29 29 0a 20 waiton-test)).
24c0: 20 20 20 20 20 20 20 20 20 20 28 70 61 74 74 73 (patts
24d0: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 74 72 (str
24e0: 69 6e 67 2d 73 70 6c 69 74 20 74 65 73 74 2d 70 ing-split test-p
24f0: 61 74 74 20 22 2c 22 29 29 0a 20 20 20 20 20 20 att ",")).
2500: 20 20 20 20 20 28 77 61 69 74 69 6e 67 2d 74 65 (waiting-te
2510: 73 74 2d 6c 65 6e 20 28 2b 20 28 73 74 72 69 6e st-len (+ (strin
2520: 67 2d 6c 65 6e 67 74 68 20 77 61 69 74 69 6e 67 g-length waiting
2530: 2d 74 65 73 74 29 20 31 29 29 0a 20 20 20 20 20 -test) 1)).
2540: 20 20 20 20 20 20 28 70 61 74 74 73 2d 77 61 69 (patts-wai
2550: 74 6f 6e 20 20 20 20 20 28 6d 61 70 20 28 6c 61 ton (map (la
2560: 6d 62 64 61 20 28 78 29 20 20 3b 3b 20 66 6f 72 mbda (x) ;; for
2570: 20 65 61 63 68 20 69 6e 63 6f 6d 69 6e 67 20 70 each incoming p
2580: 61 74 74 20 74 68 61 74 20 6d 61 74 63 68 65 73 att that matches
2590: 20 74 68 65 20 77 61 69 74 69 6e 67 20 74 65 73 the waiting tes
25a0: 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 t.
25b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
25c0: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 6d 6f (let* ((mo
25d0: 64 70 61 74 74 20 28 69 66 20 69 74 65 6d 6d 61 dpatt (if itemma
25e0: 70 20 28 64 62 3a 63 6f 6e 76 65 72 74 2d 74 65 p (db:convert-te
25f0: 73 74 2d 69 74 65 6d 70 61 74 68 20 78 20 69 74 st-itempath x it
2600: 65 6d 6d 61 70 29 20 78 29 29 20 0a 20 20 20 20 emmap) x)) .
2610: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2620: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2630: 20 20 20 20 20 20 20 28 6e 65 77 70 61 74 74 20 (newpatt
2640: 28 63 6f 6e 63 20 77 61 69 74 6f 6e 2d 74 65 73 (conc waiton-tes
2650: 74 20 22 2f 22 20 28 73 75 62 73 74 72 69 6e 67 t "/" (substring
2660: 20 6d 6f 64 70 61 74 74 20 77 61 69 74 69 6e 67 modpatt waiting
2670: 2d 74 65 73 74 2d 6c 65 6e 20 28 73 74 72 69 6e -test-len (strin
2680: 67 2d 6c 65 6e 67 74 68 20 6d 6f 64 70 61 74 74 g-length modpatt
2690: 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 ))))).
26a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
26b0: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 28 ;; (
26c0: 63 6f 6e 63 20 77 61 69 74 69 6e 67 2d 74 65 73 conc waiting-tes
26d0: 74 20 22 2f 2c 22 20 77 61 69 74 69 6e 67 2d 74 t "/," waiting-t
26e0: 65 73 74 20 22 2f 22 20 28 73 75 62 73 74 72 69 est "/" (substri
26f0: 6e 67 20 6d 6f 64 70 61 74 74 20 77 61 69 74 6f ng modpatt waito
2700: 6e 2d 74 65 73 74 2d 6c 65 6e 20 28 73 74 72 69 n-test-len (stri
2710: 6e 67 2d 6c 65 6e 67 74 68 20 6d 6f 64 70 61 74 ng-length modpat
2720: 74 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 t))))).
2730: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2740: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ;;
2750: 28 70 72 69 6e 74 20 22 69 6e 20 6d 61 70 2c 20 (print "in map,
2760: 78 3d 22 20 78 20 22 2c 20 6e 65 77 70 61 74 74 x=" x ", newpatt
2770: 3d 22 20 6e 65 77 70 61 74 74 29 0a 20 20 20 20 =" newpatt).
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 6e 65 77 70 61 74 74 29 29 0a 20 20 20 20 newpatt)).
27b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
27c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 66 (f
27d0: 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 ilter (lambda (x
27e0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
27f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2800: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 65 (e
2810: 71 3f 20 28 73 75 62 73 74 72 69 6e 67 2d 69 6e q? (substring-in
2820: 64 65 78 20 28 63 6f 6e 63 20 77 61 69 74 69 6e dex (conc waitin
2830: 67 2d 74 65 73 74 20 22 2f 22 29 20 78 29 20 30 g-test "/") x) 0
2840: 29 29 20 3b 3b 20 69 73 20 74 68 69 73 20 70 61 )) ;; is this pa
2850: 74 74 20 70 65 72 74 69 6e 65 6e 74 20 74 6f 20 tt pertinent to
2860: 74 68 65 20 77 61 69 74 69 6e 67 20 74 65 73 74 the waiting test
2870: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
2880: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2890: 20 20 20 20 20 20 20 20 20 20 20 70 61 74 74 73 patts
28a0: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 ))). (
28b0: 65 78 74 65 6e 64 65 64 2d 74 65 73 74 2d 70 61 extended-test-pa
28c0: 74 74 20 20 20 28 61 70 70 65 6e 64 20 70 61 74 tt (append pat
28d0: 74 73 20 28 69 66 20 28 6e 75 6c 6c 3f 20 70 61 ts (if (null? pa
28e0: 74 74 73 2d 77 61 69 74 6f 6e 29 0a 20 20 20 20 tts-waiton).
28f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2900: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2910: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
2920: 6c 69 73 74 20 28 63 6f 6e 63 20 77 61 69 74 6f list (conc waito
2930: 6e 2d 74 65 73 74 20 22 2f 25 22 29 29 20 3b 3b n-test "/%")) ;;
2940: 20 72 65 61 6c 6c 79 20 73 68 6f 75 6c 64 6e 27 really shouldn'
2950: 74 20 61 64 64 20 74 68 65 20 77 61 69 74 6f 6e t add the waiton
2960: 20 66 6f 72 63 65 66 75 6c 6c 79 20 6c 69 6b 65 forcefully like
2970: 20 74 68 69 73 0a 20 20 20 20 20 20 20 20 20 20 this.
2980: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2990: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
29a0: 20 20 20 20 20 20 20 20 20 70 61 74 74 73 2d 77 patts-w
29b0: 61 69 74 6f 6e 29 29 29 0a 20 20 20 20 20 20 20 aiton))).
29c0: 20 20 20 20 28 65 78 74 65 6e 64 65 64 2d 74 65 (extended-te
29d0: 73 74 2d 70 61 74 74 2d 77 69 74 68 2d 74 6f 70 st-patt-with-top
29e0: 6c 65 76 65 6c 73 0a 20 20 20 20 20 20 20 20 20 levels.
29f0: 20 20 20 28 66 6f 6c 64 20 28 6c 61 6d 62 64 61 (fold (lambda
2a00: 20 28 74 65 73 74 70 61 74 74 2d 69 74 65 6d 20 (testpatt-item
2a10: 61 63 63 75 6d 20 29 0a 20 20 20 20 20 20 20 20 accum ).
2a20: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 (let
2a30: 20 28 28 6d 79 2d 6d 61 74 63 68 20 28 73 74 72 ((my-match (str
2a40: 69 6e 67 2d 6d 61 74 63 68 20 22 5e 28 5b 5e 25 ing-match "^([^%
2a50: 5c 5c 2f 5d 2b 29 5c 5c 2f 2e 2b 24 22 20 74 65 \\/]+)\\/.+$" te
2a60: 73 74 70 61 74 74 2d 69 74 65 6d 29 29 29 0a 20 stpatt-item))).
2a70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2a80: 20 20 20 20 20 28 63 6f 6e 73 20 74 65 73 74 70 (cons testp
2a90: 61 74 74 2d 69 74 65 6d 0a 20 20 20 20 20 20 20 att-item.
2aa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2ab0: 20 20 20 20 20 28 69 66 20 6d 79 2d 6d 61 74 63 (if my-matc
2ac0: 68 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 h.
2ad0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2ae0: 20 20 28 63 6f 6e 73 0a 20 20 20 20 20 20 20 20 (cons.
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 28 63 6f 6e 63 20 28 (conc (
2b10: 63 61 64 72 20 6d 79 2d 6d 61 74 63 68 29 20 22 cadr my-match) "
2b20: 2f 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 /").
2b30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2b40: 20 20 20 20 20 61 63 63 75 6d 29 0a 20 20 20 20 accum).
2b50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2b60: 20 20 20 20 20 20 20 20 20 20 20 20 61 63 63 75 accu
2b70: 6d 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 m)))).
2b80: 20 20 20 20 20 20 20 20 27 28 29 0a 20 20 20 20 '().
2b90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 65 78 ex
2ba0: 74 65 6e 64 65 64 2d 74 65 73 74 2d 70 61 74 74 tended-test-patt
2bb0: 29 29 29 0a 20 20 20 20 20 20 28 73 74 72 69 6e ))). (strin
2bc0: 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 64 g-intersperse (d
2bd0: 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 74 65 73 elete-duplicates
2be0: 20 65 78 74 65 6e 64 65 64 2d 74 65 73 74 2d 70 extended-test-p
2bf0: 61 74 74 2d 77 69 74 68 2d 74 6f 70 6c 65 76 65 att-with-topleve
2c00: 6c 73 29 20 22 2c 22 29 29 29 0a 20 20 20 28 65 ls) ","))). (e
2c10: 6c 73 65 20 3b 3b 20 6e 6f 74 20 77 61 69 74 69 lse ;; not waiti
2c20: 6e 67 20 6f 6e 20 69 74 65 6d 73 2c 20 77 61 69 ng on items, wai
2c30: 74 69 6e 67 20 6f 6e 20 65 6e 74 69 72 65 20 77 ting on entire w
2c40: 61 69 74 6f 6e 20 74 65 73 74 2e 0a 20 20 20 20 aiton test..
2c50: 28 6c 65 74 2a 20 28 28 70 61 74 74 73 20 28 73 (let* ((patts (s
2c60: 74 72 69 6e 67 2d 73 70 6c 69 74 20 74 65 73 74 tring-split test
2c70: 2d 70 61 74 74 20 22 2c 22 29 29 0a 20 20 20 20 -patt ",")).
2c80: 20 20 20 20 20 20 20 28 6e 65 77 2d 70 61 74 74 (new-patt
2c90: 73 20 28 69 66 20 28 6d 65 6d 62 65 72 20 77 61 s (if (member wa
2ca0: 69 74 6f 6e 2d 74 65 73 74 20 70 61 74 74 73 29 iton-test patts)
2cb0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
2cc0: 20 20 20 20 20 20 20 20 20 20 20 70 61 74 74 73 patts
2cd0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
2ce0: 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 73 (cons
2cf0: 20 77 61 69 74 6f 6e 2d 74 65 73 74 20 70 61 74 waiton-test pat
2d00: 74 73 29 29 29 29 0a 20 20 20 20 20 20 28 73 74 ts)))). (st
2d10: 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
2d20: 20 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 (delete-duplica
2d30: 74 65 73 20 6e 65 77 2d 70 61 74 74 73 29 20 22 tes new-patts) "
2d40: 2c 22 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 ,")))))..(define
2d50: 20 2a 67 6c 6f 62 2d 6c 69 6b 65 2d 6d 61 74 63 *glob-like-matc
2d60: 68 2d 63 61 63 68 65 2a 20 28 6d 61 6b 65 2d 68 h-cache* (make-h
2d70: 61 73 68 2d 74 61 62 6c 65 29 29 0a 28 64 65 66 ash-table)).(def
2d80: 69 6e 65 20 28 74 65 73 74 73 3a 63 61 63 68 65 ine (tests:cache
2d90: 2d 72 65 67 65 78 70 20 73 74 72 2d 69 6e 20 66 -regexp str-in f
2da0: 6c 61 67 29 0a 20 20 28 6c 65 74 2a 20 28 28 6b lag). (let* ((k
2db0: 65 79 20 28 63 6f 6e 63 20 73 74 72 2d 69 6e 20 ey (conc str-in
2dc0: 66 6c 61 67 29 29 29 0a 20 20 20 20 28 6f 72 20 flag))). (or
2dd0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
2de0: 64 65 66 61 75 6c 74 20 2a 67 6c 6f 62 2d 6c 69 default *glob-li
2df0: 6b 65 2d 6d 61 74 63 68 2d 63 61 63 68 65 2a 20 ke-match-cache*
2e00: 6b 65 79 20 23 66 29 0a 09 28 6c 65 74 2a 20 28 key #f)..(let* (
2e10: 28 6e 65 77 72 78 20 28 72 65 67 65 78 70 20 73 (newrx (regexp s
2e20: 74 72 2d 69 6e 20 66 6c 61 67 29 29 29 0a 09 20 tr-in flag)))..
2e30: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
2e40: 21 20 2a 67 6c 6f 62 2d 6c 69 6b 65 2d 6d 61 74 ! *glob-like-mat
2e50: 63 68 2d 63 61 63 68 65 2a 20 6b 65 79 20 6e 65 ch-cache* key ne
2e60: 77 72 78 29 0a 09 20 20 6e 65 77 72 78 29 29 29 wrx).. newrx)))
2e70: 29 0a 0a 3b 3b 20 74 65 73 74 73 3a 67 6c 6f 62 )..;; tests:glob
2e80: 2d 6c 69 6b 65 2d 6d 61 74 63 68 20 0a 28 64 65 -like-match .(de
2e90: 66 69 6e 65 20 28 74 65 73 74 73 3a 67 6c 6f 62 fine (tests:glob
2ea0: 2d 6c 69 6b 65 2d 6d 61 74 63 68 20 70 61 74 74 -like-match patt
2eb0: 20 73 74 72 29 20 0a 20 20 28 6c 65 74 2a 20 28 str) . (let* (
2ec0: 28 6c 69 6b 65 20 20 20 20 20 28 73 75 62 73 74 (like (subst
2ed0: 72 69 6e 67 2d 69 6e 64 65 78 20 22 25 22 20 70 ring-index "%" p
2ee0: 61 74 74 29 29 0a 09 20 28 6e 6f 74 70 61 74 74 att)).. (notpatt
2ef0: 20 20 28 65 71 75 61 6c 3f 20 28 73 75 62 73 74 (equal? (subst
2f00: 72 69 6e 67 2d 69 6e 64 65 78 20 22 7e 22 20 70 ring-index "~" p
2f10: 61 74 74 29 20 30 29 29 0a 09 20 28 6e 65 77 70 att) 0)).. (newp
2f20: 61 74 74 20 20 28 69 66 20 6e 6f 74 70 61 74 74 att (if notpatt
2f30: 20 28 73 75 62 73 74 72 69 6e 67 20 70 61 74 74 (substring patt
2f40: 20 31 29 20 70 61 74 74 29 29 0a 09 20 28 66 69 1) patt)).. (fi
2f50: 6e 70 61 74 74 20 20 28 69 66 20 6c 69 6b 65 0a npatt (if like.
2f60: 09 09 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 .. (string
2f70: 2d 73 75 62 73 74 69 74 75 74 65 20 28 72 65 67 -substitute (reg
2f80: 65 78 70 20 22 25 22 29 20 22 2e 2a 22 20 6e 65 exp "%") ".*" ne
2f90: 77 70 61 74 74 20 23 66 29 0a 09 09 20 20 20 20 wpatt #f)...
2fa0: 20 20 20 28 73 74 72 69 6e 67 2d 73 75 62 73 74 (string-subst
2fb0: 69 74 75 74 65 20 28 72 65 67 65 78 70 20 22 5c itute (regexp "\
2fc0: 5c 2a 22 29 20 22 2e 2a 22 20 6e 65 77 70 61 74 \*") ".*" newpat
2fd0: 74 20 23 66 29 29 29 0a 09 20 28 72 78 20 20 20 t #f))).. (rx
2fe0: 20 20 20 20 28 74 65 73 74 73 3a 63 61 63 68 65 (tests:cache
2ff0: 2d 72 65 67 65 78 70 20 66 69 6e 70 61 74 74 20 -regexp finpatt
3000: 28 69 66 20 6c 69 6b 65 20 23 74 20 23 66 29 29 (if like #t #f))
3010: 29 0a 09 20 28 72 65 73 20 20 20 20 20 20 28 73 ).. (res (s
3020: 74 72 69 6e 67 2d 6d 61 74 63 68 20 72 78 20 73 tring-match rx s
3030: 74 72 29 29 29 0a 20 20 20 20 28 69 66 20 6e 6f tr))). (if no
3040: 74 70 61 74 74 20 28 6e 6f 74 20 72 65 73 29 20 tpatt (not res)
3050: 72 65 73 29 29 29 0a 0a 3b 3b 20 69 66 20 69 74 res)))..;; if it
3060: 65 6d 70 61 74 68 20 69 73 20 23 66 20 74 68 65 empath is #f the
3070: 6e 20 6c 6f 6f 6b 20 6f 6e 6c 79 20 61 74 20 74 n look only at t
3080: 68 65 20 74 65 73 74 6e 61 6d 65 20 70 61 72 74 he testname part
3090: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 65 73 .;;.(define (tes
30a0: 74 73 3a 6d 61 74 63 68 20 70 61 74 74 65 72 6e ts:match pattern
30b0: 73 20 74 65 73 74 6e 61 6d 65 20 69 74 65 6d 70 s testname itemp
30c0: 61 74 68 20 23 21 6b 65 79 20 28 72 65 71 75 69 ath #!key (requi
30d0: 72 65 64 20 27 28 29 29 29 0a 20 20 28 69 66 20 red '())). (if
30e0: 28 73 74 72 69 6e 67 3f 20 70 61 74 74 65 72 6e (string? pattern
30f0: 73 29 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 s). (let ((
3100: 70 61 74 74 73 20 28 61 70 70 65 6e 64 20 28 73 patts (append (s
3110: 74 72 69 6e 67 2d 73 70 6c 69 74 20 70 61 74 74 tring-split patt
3120: 65 72 6e 73 20 22 2c 22 29 20 72 65 71 75 69 72 erns ",") requir
3130: 65 64 29 29 29 0a 09 28 69 66 20 28 6e 75 6c 6c ed)))..(if (null
3140: 3f 20 70 61 74 74 73 29 20 3b 3b 3b 20 6e 6f 20 ? patts) ;;; no
3150: 70 61 74 74 65 72 6e 28 73 29 20 6d 65 61 6e 73 pattern(s) means
3160: 20 6e 6f 20 6d 61 74 63 68 0a 09 20 20 20 20 23 no match.. #
3170: 66 0a 09 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 f.. (let loop
3180: 20 28 28 70 61 74 74 20 28 63 61 72 20 70 61 74 ((patt (car pat
3190: 74 73 29 29 0a 09 09 20 20 20 20 20 20 20 28 74 ts))... (t
31a0: 61 6c 20 20 28 63 64 72 20 70 61 74 74 73 29 29 al (cdr patts))
31b0: 29 0a 09 20 20 20 20 20 20 3b 3b 20 28 70 72 69 ).. ;; (pri
31c0: 6e 74 20 22 6c 6f 6f 70 3a 20 70 61 74 74 3a 20 nt "loop: patt:
31d0: 22 20 70 61 74 74 20 22 2c 20 74 61 6c 20 22 20 " patt ", tal "
31e0: 74 61 6c 29 0a 09 20 20 20 20 20 20 28 69 66 20 tal).. (if
31f0: 28 73 74 72 69 6e 67 3d 3f 20 70 61 74 74 20 22 (string=? patt "
3200: 22 29 0a 09 09 20 20 23 66 20 3b 3b 20 6e 6f 74 ")... #f ;; not
3210: 68 69 6e 67 20 65 76 65 72 20 6d 61 74 63 68 65 hing ever matche
3220: 73 20 65 6d 70 74 79 20 73 74 72 69 6e 67 20 2d s empty string -
3230: 20 70 6f 6c 69 63 79 0a 09 09 20 20 28 6c 65 74 policy... (let
3240: 2a 20 28 28 70 61 74 74 2d 70 61 72 74 73 20 28 * ((patt-parts (
3250: 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 28 72 65 string-match (re
3260: 67 65 78 70 20 22 5e 28 5b 5e 5c 5c 2f 5d 2a 29 gexp "^([^\\/]*)
3270: 28 5c 5c 2f 28 2e 2a 29 7c 29 24 22 29 20 70 61 (\\/(.*)|)$") pa
3280: 74 74 29 29 0a 09 09 09 20 28 74 65 73 74 2d 70 tt)).... (test-p
3290: 61 74 74 20 20 28 63 61 64 72 20 70 61 74 74 2d att (cadr patt-
32a0: 70 61 72 74 73 29 29 0a 09 09 09 20 28 69 74 65 parts)).... (ite
32b0: 6d 2d 70 61 74 74 20 20 28 63 61 64 64 64 72 20 m-patt (cadddr
32c0: 70 61 74 74 2d 70 61 72 74 73 29 29 29 0a 09 09 patt-parts)))...
32d0: 20 20 20 20 3b 3b 20 73 70 65 63 69 61 6c 20 63 ;; special c
32e0: 61 73 65 3a 20 74 65 73 74 20 76 73 2e 20 74 65 ase: test vs. te
32f0: 73 74 2f 0a 09 09 20 20 20 20 3b 3b 20 20 20 74 st/... ;; t
3300: 65 73 74 20 20 3d 3e 20 22 74 65 73 74 22 20 22 est => "test" "
3310: 25 22 0a 09 09 20 20 20 20 3b 3b 20 20 20 74 65 %"... ;; te
3320: 73 74 2f 20 3d 3e 20 22 74 65 73 74 22 20 22 22 st/ => "test" ""
3330: 0a 09 09 20 20 20 20 28 69 66 20 28 61 6e 64 20 ... (if (and
3340: 28 6e 6f 74 20 28 73 75 62 73 74 72 69 6e 67 2d (not (substring-
3350: 69 6e 64 65 78 20 22 2f 22 20 70 61 74 74 29 29 index "/" patt))
3360: 20 3b 3b 20 6e 6f 20 73 6c 61 73 68 20 69 6e 20 ;; no slash in
3370: 74 68 65 20 6f 72 69 67 69 6e 61 6c 0a 09 09 09 the original....
3380: 20 20 20 20 20 28 6f 72 20 28 6e 6f 74 20 69 74 (or (not it
3390: 65 6d 2d 70 61 74 74 29 0a 09 09 09 09 20 28 65 em-patt)..... (e
33a0: 71 75 61 6c 3f 20 69 74 65 6d 2d 70 61 74 74 20 qual? item-patt
33b0: 22 22 29 29 29 20 20 20 20 20 20 3b 3b 20 73 68 ""))) ;; sh
33c0: 6f 75 6c 64 20 61 6c 77 61 79 73 20 62 65 20 74 ould always be t
33d0: 72 75 65 20 74 68 61 74 20 69 74 65 6d 2d 70 61 rue that item-pa
33e0: 74 74 20 69 73 20 22 22 0a 09 09 09 28 73 65 74 tt is ""....(set
33f0: 21 20 69 74 65 6d 2d 70 61 74 74 20 22 25 22 29 ! item-patt "%")
3400: 29 0a 09 09 20 20 20 20 3b 3b 20 28 70 72 69 6e )... ;; (prin
3410: 74 20 22 74 65 73 74 73 3a 6d 61 74 63 68 20 3d t "tests:match =
3420: 3e 20 70 61 74 74 2d 70 61 72 74 73 3a 20 22 20 > patt-parts: "
3430: 70 61 74 74 2d 70 61 72 74 73 20 22 2c 20 74 65 patt-parts ", te
3440: 73 74 2d 70 61 74 74 3a 20 22 20 74 65 73 74 2d st-patt: " test-
3450: 70 61 74 74 20 22 2c 20 69 74 65 6d 2d 70 61 74 patt ", item-pat
3460: 74 3a 20 22 20 69 74 65 6d 2d 70 61 74 74 29 0a t: " item-patt).
3470: 09 09 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 .. (if (and (
3480: 74 65 73 74 73 3a 67 6c 6f 62 2d 6c 69 6b 65 2d tests:glob-like-
3490: 6d 61 74 63 68 20 74 65 73 74 2d 70 61 74 74 20 match test-patt
34a0: 74 65 73 74 6e 61 6d 65 29 0a 09 09 09 20 20 20 testname)....
34b0: 20 20 28 6f 72 20 28 6e 6f 74 20 69 74 65 6d 70 (or (not itemp
34c0: 61 74 68 29 0a 09 09 09 09 20 28 74 65 73 74 73 ath)..... (tests
34d0: 3a 67 6c 6f 62 2d 6c 69 6b 65 2d 6d 61 74 63 68 :glob-like-match
34e0: 20 28 69 66 20 69 74 65 6d 2d 70 61 74 74 20 69 (if item-patt i
34f0: 74 65 6d 2d 70 61 74 74 20 22 22 29 20 69 74 65 tem-patt "") ite
3500: 6d 70 61 74 68 29 29 29 0a 09 09 09 23 74 0a 09 mpath)))....#t..
3510: 09 09 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c ..(if (null? tal
3520: 29 0a 09 09 09 20 20 20 20 23 66 0a 09 09 09 20 ).... #f....
3530: 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 (loop (car ta
3540: 6c 29 28 63 64 72 20 74 61 6c 29 29 29 29 29 29 l)(cdr tal))))))
3550: 29 29 29 29 29 0a 0a 3b 3b 20 69 66 20 69 74 65 )))))..;; if ite
3560: 6d 70 61 74 68 20 69 73 20 23 66 20 74 68 65 6e mpath is #f then
3570: 20 6c 6f 6f 6b 20 6f 6e 6c 79 20 61 74 20 74 68 look only at th
3580: 65 20 74 65 73 74 6e 61 6d 65 20 70 61 72 74 0a e testname part.
3590: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 ;;.(define (test
35a0: 73 3a 6d 61 74 63 68 2d 3e 73 71 6c 71 72 79 20 s:match->sqlqry
35b0: 70 61 74 74 65 72 6e 73 29 0a 20 20 28 69 66 20 patterns). (if
35c0: 28 73 74 72 69 6e 67 3f 20 70 61 74 74 65 72 6e (string? pattern
35d0: 73 29 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 s). (let ((
35e0: 70 61 74 74 73 20 28 73 74 72 69 6e 67 2d 73 70 patts (string-sp
35f0: 6c 69 74 20 70 61 74 74 65 72 6e 73 20 22 2c 22 lit patterns ","
3600: 29 29 29 0a 09 28 69 66 20 28 6e 75 6c 6c 3f 20 )))..(if (null?
3610: 70 61 74 74 73 29 20 3b 3b 3b 20 6e 6f 20 70 61 patts) ;;; no pa
3620: 74 74 65 72 6e 28 73 29 20 6d 65 61 6e 73 20 6e ttern(s) means n
3630: 6f 20 6d 61 74 63 68 2c 20 77 65 20 77 69 6c 6c o match, we will
3640: 20 64 6f 20 6e 6f 20 71 75 65 72 79 0a 09 20 20 do no query..
3650: 20 20 23 66 0a 09 20 20 20 20 28 6c 65 74 20 6c #f.. (let l
3660: 6f 6f 70 20 28 28 70 61 74 74 20 28 63 61 72 20 oop ((patt (car
3670: 70 61 74 74 73 29 29 0a 09 09 20 20 20 20 20 20 patts))...
3680: 20 28 74 61 6c 20 20 28 63 64 72 20 70 61 74 74 (tal (cdr patt
3690: 73 29 29 0a 09 09 20 20 20 20 20 20 20 28 72 65 s))... (re
36a0: 73 20 20 27 28 29 29 29 0a 09 20 20 20 20 20 20 s '()))..
36b0: 3b 3b 20 28 70 72 69 6e 74 20 22 6c 6f 6f 70 3a ;; (print "loop:
36c0: 20 70 61 74 74 3a 20 22 20 70 61 74 74 20 22 2c patt: " patt ",
36d0: 20 74 61 6c 20 22 20 74 61 6c 29 0a 09 20 20 20 tal " tal)..
36e0: 20 20 20 28 6c 65 74 2a 20 28 28 70 61 74 74 2d (let* ((patt-
36f0: 70 61 72 74 73 20 28 73 74 72 69 6e 67 2d 6d 61 parts (string-ma
3700: 74 63 68 20 28 72 65 67 65 78 70 20 22 5e 28 5b tch (regexp "^([
3710: 5e 5c 5c 2f 5d 2a 29 28 5c 5c 2f 28 2e 2a 29 7c ^\\/]*)(\\/(.*)|
3720: 29 24 22 29 20 70 61 74 74 29 29 0a 09 09 20 20 )$") patt))...
3730: 20 20 20 28 74 65 73 74 2d 70 61 74 74 20 20 28 (test-patt (
3740: 63 61 64 72 20 70 61 74 74 2d 70 61 72 74 73 29 cadr patt-parts)
3750: 29 0a 09 09 20 20 20 20 20 28 69 74 65 6d 2d 70 )... (item-p
3760: 61 74 74 20 20 28 63 61 64 64 64 72 20 70 61 74 att (cadddr pat
3770: 74 2d 70 61 72 74 73 29 29 0a 09 09 20 20 20 20 t-parts))...
3780: 20 28 74 65 73 74 2d 71 72 79 20 20 20 28 64 62 (test-qry (db
3790: 3a 70 61 74 74 2d 3e 6c 69 6b 65 20 22 74 65 73 :patt->like "tes
37a0: 74 6e 61 6d 65 22 20 74 65 73 74 2d 70 61 74 74 tname" test-patt
37b0: 29 29 0a 09 09 20 20 20 20 20 28 69 74 65 6d 2d ))... (item-
37c0: 71 72 79 20 20 20 28 64 62 3a 70 61 74 74 2d 3e qry (db:patt->
37d0: 6c 69 6b 65 20 22 69 74 65 6d 5f 70 61 74 68 22 like "item_path"
37e0: 20 69 74 65 6d 2d 70 61 74 74 29 29 0a 09 09 20 item-patt))...
37f0: 20 20 20 20 28 71 72 79 20 20 20 20 20 20 20 20 (qry
3800: 28 63 6f 6e 63 20 22 28 22 20 74 65 73 74 2d 71 (conc "(" test-q
3810: 72 79 20 22 20 41 4e 44 20 22 20 69 74 65 6d 2d ry " AND " item-
3820: 71 72 79 20 22 29 22 29 29 29 0a 09 09 3b 3b 20 qry ")")))...;;
3830: 28 70 72 69 6e 74 20 22 74 65 73 74 73 3a 6d 61 (print "tests:ma
3840: 74 63 68 20 3d 3e 20 70 61 74 74 2d 70 61 72 74 tch => patt-part
3850: 73 3a 20 22 20 70 61 74 74 2d 70 61 72 74 73 20 s: " patt-parts
3860: 22 2c 20 74 65 73 74 2d 70 61 74 74 3a 20 22 20 ", test-patt: "
3870: 74 65 73 74 2d 70 61 74 74 20 22 2c 20 69 74 65 test-patt ", ite
3880: 6d 2d 70 61 74 74 3a 20 22 20 69 74 65 6d 2d 70 m-patt: " item-p
3890: 61 74 74 29 0a 09 09 28 69 66 20 28 6e 75 6c 6c att)...(if (null
38a0: 3f 20 74 61 6c 29 0a 09 09 20 20 20 20 28 73 74 ? tal)... (st
38b0: 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
38c0: 20 28 61 70 70 65 6e 64 20 28 72 65 76 65 72 73 (append (revers
38d0: 65 20 72 65 73 29 28 6c 69 73 74 20 71 72 79 29 e res)(list qry)
38e0: 29 20 22 20 4f 52 20 22 29 0a 09 09 20 20 20 20 ) " OR ")...
38f0: 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 (loop (car tal)(
3900: 63 64 72 20 74 61 6c 29 28 63 6f 6e 73 20 71 72 cdr tal)(cons qr
3910: 79 20 72 65 73 29 29 29 29 29 29 29 0a 20 20 20 y res))))))).
3920: 20 20 20 23 66 29 29 0a 0a 3b 3b 20 43 68 65 63 #f))..;; Chec
3930: 6b 20 66 6f 72 20 77 61 69 76 65 72 20 65 6c 69 k for waiver eli
3940: 67 69 62 69 6c 69 74 79 0a 3b 3b 0a 28 64 65 66 gibility.;;.(def
3950: 69 6e 65 20 28 74 65 73 74 73 3a 63 68 65 63 6b ine (tests:check
3960: 2d 77 61 69 76 65 72 2d 65 6c 69 67 69 62 69 6c -waiver-eligibil
3970: 69 74 79 20 74 65 73 74 64 61 74 20 70 72 65 76 ity testdat prev
3980: 2d 74 65 73 74 64 61 74 29 0a 20 20 28 6c 65 74 -testdat). (let
3990: 2a 20 28 28 74 65 73 74 2d 72 65 67 69 73 74 72 * ((test-registr
39a0: 79 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 y (make-hash-tab
39b0: 6c 65 29 29 0a 09 20 28 74 65 73 74 63 6f 6e 66 le)).. (testconf
39c0: 69 67 20 20 28 74 65 73 74 73 3a 67 65 74 2d 74 ig (tests:get-t
39d0: 65 73 74 63 6f 6e 66 69 67 20 28 64 62 3a 74 65 estconfig (db:te
39e0: 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 st-get-testname
39f0: 74 65 73 74 64 61 74 29 20 28 64 62 3a 74 65 73 testdat) (db:tes
3a00: 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 t-get-item-path
3a10: 74 65 73 74 64 61 74 29 20 74 65 73 74 2d 72 65 testdat) test-re
3a20: 67 69 73 74 72 79 20 23 66 29 29 0a 09 20 28 74 gistry #f)).. (t
3a30: 65 73 74 2d 72 75 6e 64 69 72 20 3b 3b 20 28 73 est-rundir ;; (s
3a40: 64 62 3a 71 72 79 20 27 70 61 73 73 73 74 72 20 db:qry 'passstr
3a50: 0a 09 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 .. (db:test-get
3a60: 2d 72 75 6e 64 69 72 20 74 65 73 74 64 61 74 29 -rundir testdat)
3a70: 29 20 3b 3b 20 29 0a 09 20 28 70 72 65 76 2d 72 ) ;; ).. (prev-r
3a80: 75 6e 64 69 72 20 3b 3b 20 28 73 64 62 3a 71 72 undir ;; (sdb:qr
3a90: 79 20 27 70 61 73 73 73 74 72 20 0a 09 20 20 28 y 'passstr .. (
3aa0: 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 db:test-get-rund
3ab0: 69 72 20 70 72 65 76 2d 74 65 73 74 64 61 74 29 ir prev-testdat)
3ac0: 29 20 3b 3b 20 29 0a 09 20 28 77 61 69 76 65 72 ) ;; ).. (waiver
3ad0: 73 20 20 20 20 20 28 69 66 20 74 65 73 74 63 6f s (if testco
3ae0: 6e 66 69 67 20 28 63 6f 6e 66 69 67 66 3a 73 65 nfig (configf:se
3af0: 63 74 69 6f 6e 2d 76 61 72 73 20 74 65 73 74 63 ction-vars testc
3b00: 6f 6e 66 69 67 20 22 77 61 69 76 65 72 73 22 29 onfig "waivers")
3b10: 20 27 28 29 29 29 0a 09 20 28 77 61 69 76 65 72 '())).. (waiver
3b20: 2d 72 78 20 20 20 28 72 65 67 65 78 70 20 22 5e -rx (regexp "^
3b30: 28 5c 5c 53 2b 29 5c 5c 73 2b 28 2e 2a 29 24 22 (\\S+)\\s+(.*)$"
3b40: 29 29 0a 09 20 28 64 69 66 66 2d 72 75 6c 65 20 )).. (diff-rule
3b50: 20 20 22 64 69 66 66 20 25 66 69 6c 65 31 25 20 "diff %file1%
3b60: 25 66 69 6c 65 32 25 22 29 0a 09 20 28 6c 6f 67 %file2%").. (log
3b70: 70 72 6f 2d 72 75 6c 65 20 22 64 69 66 66 20 25 pro-rule "diff %
3b80: 66 69 6c 65 31 25 20 25 66 69 6c 65 32 25 20 7c file1% %file2% |
3b90: 20 6c 6f 67 70 72 6f 20 25 77 61 69 76 65 72 6e logpro %waivern
3ba0: 61 6d 65 25 2e 6c 6f 67 70 72 6f 20 25 77 61 69 ame%.logpro %wai
3bb0: 76 65 72 6e 61 6d 65 25 2e 68 74 6d 6c 22 29 29 vername%.html"))
3bc0: 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 63 . (if (not (c
3bd0: 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 ommon:file-exist
3be0: 73 3f 20 74 65 73 74 2d 72 75 6e 64 69 72 29 29 s? test-rundir))
3bf0: 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 64 65 62 ..(begin.. (deb
3c00: 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 ug:print-error 0
3c10: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
3c20: 72 74 2a 20 22 74 65 73 74 20 72 75 6e 20 64 69 rt* "test run di
3c30: 72 65 63 74 6f 72 79 20 69 73 20 67 6f 6e 65 2c rectory is gone,
3c40: 20 63 61 6e 6e 6f 74 20 70 72 6f 70 61 67 61 74 cannot propagat
3c50: 65 20 77 61 69 76 65 72 22 29 0a 09 20 20 23 66 e waiver").. #f
3c60: 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 70 75 )..(begin.. (pu
3c70: 73 68 2d 64 69 72 65 63 74 6f 72 79 20 74 65 73 sh-directory tes
3c80: 74 2d 72 75 6e 64 69 72 29 0a 09 20 20 28 6c 65 t-rundir).. (le
3c90: 74 20 28 28 72 65 73 75 6c 74 20 28 69 66 20 28 t ((result (if (
3ca0: 6e 75 6c 6c 3f 20 77 61 69 76 65 72 73 29 0a 09 null? waivers)..
3cb0: 09 09 20 20 20 20 23 66 0a 09 09 09 20 20 20 20 .. #f....
3cc0: 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 (let loop ((hed
3cd0: 28 63 61 72 20 77 61 69 76 65 72 73 29 29 0a 09 (car waivers))..
3ce0: 09 09 09 20 20 20 20 20 20 20 28 74 61 6c 20 28 ... (tal (
3cf0: 63 64 72 20 77 61 69 76 65 72 73 29 29 29 0a 09 cdr waivers)))..
3d00: 09 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 .. (debug:p
3d10: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
3d20: 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a log-port* "INFO:
3d30: 20 41 70 70 6c 79 69 6e 67 20 77 61 69 76 65 72 Applying waiver
3d40: 20 72 75 6c 65 20 5c 22 22 20 68 65 64 20 22 5c rule \"" hed "\
3d50: 22 22 29 0a 09 09 09 20 20 20 20 20 20 28 6c 65 "").... (le
3d60: 74 2a 20 28 28 77 61 69 76 65 72 20 20 20 20 20 t* ((waiver
3d70: 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 (configf:lookup
3d80: 20 74 65 73 74 63 6f 6e 66 69 67 20 22 77 61 69 testconfig "wai
3d90: 76 65 72 73 22 20 68 65 64 29 29 0a 09 09 09 09 vers" hed)).....
3da0: 20 20 20 20 20 28 77 70 61 72 74 73 20 20 20 20 (wparts
3db0: 20 20 28 69 66 20 77 61 69 76 65 72 20 28 73 74 (if waiver (st
3dc0: 72 69 6e 67 2d 6d 61 74 63 68 20 77 61 69 76 65 ring-match waive
3dd0: 72 2d 72 78 20 77 61 69 76 65 72 29 20 23 66 29 r-rx waiver) #f)
3de0: 29 0a 09 09 09 09 20 20 20 20 20 28 77 61 69 76 )..... (waiv
3df0: 65 72 2d 72 75 6c 65 20 28 69 66 20 77 70 61 72 er-rule (if wpar
3e00: 74 73 20 28 63 61 64 72 20 77 70 61 72 74 73 29 ts (cadr wparts)
3e10: 20 20 23 66 29 29 0a 09 09 09 09 20 20 20 20 20 #f)).....
3e20: 28 77 61 69 76 65 72 2d 67 6c 6f 62 20 28 69 66 (waiver-glob (if
3e30: 20 77 70 61 72 74 73 20 28 63 61 64 64 72 20 77 wparts (caddr w
3e40: 70 61 72 74 73 29 20 23 66 29 29 0a 09 09 09 09 parts) #f)).....
3e50: 20 20 20 20 20 28 6c 6f 67 70 72 6f 2d 66 69 6c (logpro-fil
3e60: 65 20 28 69 66 20 77 61 69 76 65 72 0a 09 09 09 e (if waiver....
3e70: 09 09 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 ... (let ((
3e80: 66 6e 61 6d 65 20 28 63 6f 6e 63 20 68 65 64 20 fname (conc hed
3e90: 22 2e 6c 6f 67 70 72 6f 22 29 29 29 0a 09 09 09 ".logpro")))....
3ea0: 09 09 09 09 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a ....(if (common:
3eb0: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 66 6e 61 file-exists? fna
3ec0: 6d 65 29 0a 09 09 09 09 09 09 09 20 20 20 20 66 me)........ f
3ed0: 6e 61 6d 65 20 0a 09 09 09 09 09 09 09 20 20 20 name ........
3ee0: 20 28 62 65 67 69 6e 0a 09 09 09 09 09 09 09 20 (begin........
3ef0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
3f00: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
3f10: 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 4e 6f -port* "INFO: No
3f20: 20 6c 6f 67 70 72 6f 20 66 69 6c 65 20 22 20 66 logpro file " f
3f30: 6e 61 6d 65 20 22 20 66 61 6c 6c 69 6e 67 20 62 name " falling b
3f40: 61 63 6b 20 74 6f 20 64 69 66 66 22 29 0a 09 09 ack to diff")...
3f50: 09 09 09 09 09 20 20 20 20 20 20 23 66 29 29 29 ..... #f)))
3f60: 0a 09 09 09 09 09 09 20 20 20 20 20 20 23 66 29 ....... #f)
3f70: 29 0a 09 09 09 09 20 20 20 20 20 3b 3b 20 69 66 )..... ;; if
3f80: 20 72 75 6c 65 20 62 79 20 6e 61 6d 65 20 6f 66 rule by name of
3f90: 20 77 61 69 76 65 72 2d 72 75 6c 65 20 69 73 20 waiver-rule is
3fa0: 66 6f 75 6e 64 20 69 6e 20 74 65 73 74 63 6f 6e found in testcon
3fb0: 66 69 67 20 2d 20 75 73 65 20 69 74 0a 09 09 09 fig - use it....
3fc0: 09 20 20 20 20 20 3b 3b 20 65 6c 73 65 20 69 66 . ;; else if
3fd0: 20 77 61 69 76 65 72 6e 61 6d 65 2e 6c 6f 67 70 waivername.logp
3fe0: 72 6f 20 65 78 69 73 74 73 20 75 73 65 20 6c 6f ro exists use lo
3ff0: 67 70 72 6f 2d 72 75 6c 65 0a 09 09 09 09 20 20 gpro-rule.....
4000: 20 20 20 3b 3b 20 65 6c 73 65 20 64 65 66 61 75 ;; else defau
4010: 6c 74 20 74 6f 20 64 69 66 66 2d 72 75 6c 65 0a lt to diff-rule.
4020: 09 09 09 09 20 20 20 20 20 28 72 75 6c 65 2d 73 .... (rule-s
4030: 74 72 69 6e 67 20 28 6c 65 74 20 28 28 72 75 6c tring (let ((rul
4040: 65 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 e (configf:looku
4050: 70 20 74 65 73 74 63 6f 6e 66 69 67 20 22 77 61 p testconfig "wa
4060: 69 76 65 72 5f 72 75 6c 65 73 22 20 77 61 69 76 iver_rules" waiv
4070: 65 72 2d 72 75 6c 65 29 29 29 0a 09 09 09 09 09 er-rule)))......
4080: 09 20 20 20 20 28 69 66 20 72 75 6c 65 0a 09 09 . (if rule...
4090: 09 09 09 09 09 72 75 6c 65 0a 09 09 09 09 09 09 .....rule.......
40a0: 09 28 69 66 20 6c 6f 67 70 72 6f 2d 66 69 6c 65 .(if logpro-file
40b0: 0a 09 09 09 09 09 09 09 20 20 20 20 6c 6f 67 70 ........ logp
40c0: 72 6f 2d 72 75 6c 65 0a 09 09 09 09 09 09 09 20 ro-rule........
40d0: 20 20 20 28 62 65 67 69 6e 0a 09 09 09 09 09 09 (begin.......
40e0: 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
40f0: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
4100: 6f 67 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 og-port* "INFO:
4110: 4e 6f 20 6c 6f 67 70 72 6f 20 66 69 6c 65 20 22 No logpro file "
4120: 20 6c 6f 67 70 72 6f 2d 66 69 6c 65 20 22 20 66 logpro-file " f
4130: 6f 75 6e 64 2c 20 75 73 69 6e 67 20 64 69 66 66 ound, using diff
4140: 20 72 75 6c 65 22 29 0a 09 09 09 09 09 09 09 20 rule")........
4150: 20 20 20 20 20 64 69 66 66 2d 72 75 6c 65 29 29 diff-rule))
4160: 29 29 29 0a 09 09 09 09 20 20 20 20 20 3b 3b 20 )))..... ;;
4170: 28 73 74 72 69 6e 67 2d 73 75 62 73 74 69 74 75 (string-substitu
4180: 74 65 20 22 25 66 69 6c 65 31 25 22 20 22 66 6f te "%file1%" "fo
4190: 6f 66 6f 6f 2e 74 78 74 22 20 22 54 68 69 73 20 ofoo.txt" "This
41a0: 69 73 20 25 66 69 6c 65 31 25 20 61 6e 64 20 73 is %file1% and s
41b0: 6f 20 69 73 20 74 68 69 73 20 25 66 69 6c 65 31 o is this %file1
41c0: 25 2e 22 20 23 74 29 0a 09 09 09 09 20 20 20 20 %." #t).....
41d0: 20 28 70 72 6f 63 65 73 73 65 64 2d 63 6d 64 20 (processed-cmd
41e0: 28 73 74 72 69 6e 67 2d 73 75 62 73 74 69 74 75 (string-substitu
41f0: 74 65 20 0a 09 09 09 09 09 09 20 20 20 20 20 22 te ....... "
4200: 25 66 69 6c 65 31 25 22 20 28 63 6f 6e 63 20 74 %file1%" (conc t
4210: 65 73 74 2d 72 75 6e 64 69 72 20 22 2f 22 20 77 est-rundir "/" w
4220: 61 69 76 65 72 2d 67 6c 6f 62 29 0a 09 09 09 09 aiver-glob).....
4230: 09 09 20 20 20 20 20 28 73 74 72 69 6e 67 2d 73 .. (string-s
4240: 75 62 73 74 69 74 75 74 65 0a 09 09 09 09 09 09 ubstitute.......
4250: 20 20 20 20 20 20 22 25 66 69 6c 65 32 25 22 20 "%file2%"
4260: 28 63 6f 6e 63 20 70 72 65 76 2d 72 75 6e 64 69 (conc prev-rundi
4270: 72 20 22 2f 22 20 77 61 69 76 65 72 2d 67 6c 6f r "/" waiver-glo
4280: 62 29 0a 09 09 09 09 09 09 20 20 20 20 20 20 28 b)....... (
4290: 73 74 72 69 6e 67 2d 73 75 62 73 74 69 74 75 74 string-substitut
42a0: 65 0a 09 09 09 09 09 09 20 20 20 20 20 20 20 22 e....... "
42b0: 25 77 61 69 76 65 72 6e 61 6d 65 25 22 20 68 65 %waivername%" he
42c0: 64 20 72 75 6c 65 2d 73 74 72 69 6e 67 20 23 74 d rule-string #t
42d0: 29 20 23 74 29 20 23 74 29 29 0a 09 09 09 09 20 ) #t) #t)).....
42e0: 20 20 20 20 28 72 65 73 20 20 20 20 20 20 20 20 (res
42f0: 20 20 20 20 23 66 29 29 0a 09 09 09 09 28 64 65 #f)).....(de
4300: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
4310: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
4320: 49 4e 46 4f 3a 20 77 61 69 76 65 72 20 63 6f 6d INFO: waiver com
4330: 6d 61 6e 64 20 69 73 20 5c 22 22 20 70 72 6f 63 mand is \"" proc
4340: 65 73 73 65 64 2d 63 6d 64 20 22 5c 22 22 29 0a essed-cmd "\"").
4350: 09 09 09 09 28 69 66 20 28 65 71 3f 20 28 73 79 ....(if (eq? (sy
4360: 73 74 65 6d 20 70 72 6f 63 65 73 73 65 64 2d 63 stem processed-c
4370: 6d 64 29 20 30 29 0a 09 09 09 09 20 20 20 20 28 md) 0)..... (
4380: 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 if (null? tal)..
4390: 09 09 09 09 23 74 0a 09 09 09 09 09 28 6c 6f 6f ....#t......(loo
43a0: 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 p (car tal)(cdr
43b0: 74 61 6c 29 29 29 0a 09 09 09 09 20 20 20 20 23 tal)))..... #
43c0: 66 29 29 29 29 29 29 0a 09 20 20 20 20 28 70 6f f)))))).. (po
43d0: 70 2d 64 69 72 65 63 74 6f 72 79 29 0a 09 20 20 p-directory)..
43e0: 20 20 72 65 73 75 6c 74 29 29 29 29 29 0a 0a 3b result)))))..;
43f0: 3b 20 44 6f 20 6e 6f 74 20 72 70 63 20 74 68 69 ; Do not rpc thi
4400: 73 20 6f 6e 65 2c 20 64 6f 20 74 68 65 20 75 6e s one, do the un
4410: 64 65 72 6c 79 69 6e 67 20 63 61 6c 6c 73 21 21 derlying calls!!
4420: 21 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 !.(define (tests
4430: 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 75 73 :test-set-status
4440: 21 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 ! run-id test-id
4450: 20 73 74 61 74 65 20 73 74 61 74 75 73 20 63 6f state status co
4460: 6d 6d 65 6e 74 20 64 61 74 20 23 21 6b 65 79 20 mment dat #!key
4470: 28 77 6f 72 6b 2d 61 72 65 61 20 23 66 29 29 0a (work-area #f)).
4480: 20 20 28 6c 65 74 2a 20 28 28 72 65 61 6c 2d 73 (let* ((real-s
4490: 74 61 74 75 73 20 73 74 61 74 75 73 29 0a 09 20 tatus status)..
44a0: 28 6f 74 68 65 72 64 61 74 20 20 20 20 28 69 66 (otherdat (if
44b0: 20 64 61 74 20 64 61 74 20 28 6d 61 6b 65 2d 68 dat dat (make-h
44c0: 61 73 68 2d 74 61 62 6c 65 29 29 29 0a 09 20 28 ash-table))).. (
44d0: 74 65 73 74 64 61 74 20 20 20 20 20 28 72 6d 74 testdat (rmt
44e0: 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 :get-test-info-b
44f0: 79 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 y-id run-id test
4500: 2d 69 64 29 29 0a 09 20 28 74 65 73 74 2d 6e 61 -id)).. (test-na
4510: 6d 65 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 me (db:test-ge
4520: 74 2d 74 65 73 74 6e 61 6d 65 20 20 74 65 73 74 t-testname test
4530: 64 61 74 29 29 0a 09 20 28 69 74 65 6d 2d 70 61 dat)).. (item-pa
4540: 74 68 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 th (db:test-ge
4550: 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 65 73 74 t-item-path test
4560: 64 61 74 29 29 0a 09 20 3b 3b 20 62 65 66 6f 72 dat)).. ;; befor
4570: 65 20 70 72 6f 63 65 65 64 69 6e 67 20 77 65 20 e proceeding we
4580: 6d 75 73 74 20 66 69 6e 64 20 6f 75 74 20 69 66 must find out if
4590: 20 74 68 65 20 70 72 65 76 69 6f 75 73 20 74 65 the previous te
45a0: 73 74 20 28 77 68 65 72 65 20 61 6c 6c 20 6b 65 st (where all ke
45b0: 79 73 20 6d 61 74 63 68 65 64 20 65 78 63 65 70 ys matched excep
45c0: 74 20 72 75 6e 6e 61 6d 65 29 0a 09 20 3b 3b 20 t runname).. ;;
45d0: 77 61 73 20 57 41 49 56 45 44 20 69 66 20 74 68 was WAIVED if th
45e0: 69 73 20 74 65 73 74 20 69 73 20 46 41 49 4c 0a is test is FAIL.
45f0: 0a 09 20 3b 3b 20 4e 4f 54 45 53 3a 0a 09 20 3b .. ;; NOTES:.. ;
4600: 3b 20 20 31 2e 20 49 73 20 74 68 65 20 63 61 6c ; 1. Is the cal
4610: 6c 20 74 6f 20 74 65 73 74 3a 67 65 74 2d 70 72 l to test:get-pr
4620: 65 76 69 6f 75 73 2d 72 75 6e 2d 72 65 63 6f 72 evious-run-recor
4630: 64 20 72 65 6d 6f 74 69 66 69 65 64 3f 0a 09 20 d remotified?..
4640: 3b 3b 20 20 32 2e 20 41 64 64 20 74 65 73 74 20 ;; 2. Add test
4650: 66 6f 72 20 74 65 73 74 63 6f 6e 66 69 67 20 77 for testconfig w
4660: 61 69 76 65 72 20 70 72 6f 70 61 67 61 74 69 6f aiver propagatio
4670: 6e 20 63 6f 6e 74 72 6f 6c 20 68 65 72 65 0a 09 n control here..
4680: 20 3b 3b 0a 09 20 28 70 72 65 76 2d 74 65 73 74 ;;.. (prev-test
4690: 20 20 20 28 69 66 20 28 65 71 75 61 6c 3f 20 73 (if (equal? s
46a0: 74 61 74 75 73 20 22 46 41 49 4c 22 29 0a 09 09 tatus "FAIL")...
46b0: 09 20 20 28 72 6d 74 3a 67 65 74 2d 70 72 65 76 . (rmt:get-prev
46c0: 69 6f 75 73 2d 74 65 73 74 2d 72 75 6e 2d 72 65 ious-test-run-re
46d0: 63 6f 72 64 20 72 75 6e 2d 69 64 20 74 65 73 74 cord run-id test
46e0: 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 -name item-path)
46f0: 0a 09 09 09 20 20 23 66 29 29 0a 09 20 28 77 61 .... #f)).. (wa
4700: 69 76 65 64 20 20 20 28 69 66 20 70 72 65 76 2d ived (if prev-
4710: 74 65 73 74 0a 09 09 20 20 20 20 20 20 20 28 69 test... (i
4720: 66 20 70 72 65 76 2d 74 65 73 74 20 3b 3b 20 74 f prev-test ;; t
4730: 72 75 65 20 69 66 20 77 65 20 66 6f 75 6e 64 20 rue if we found
4740: 61 20 70 72 65 76 69 6f 75 73 20 74 65 73 74 20 a previous test
4750: 69 6e 20 74 68 69 73 20 72 75 6e 20 73 65 72 69 in this run seri
4760: 65 73 0a 09 09 09 20 20 20 28 6c 65 74 20 28 28 es.... (let ((
4770: 70 72 65 76 2d 73 74 61 74 75 73 20 20 28 64 62 prev-status (db
4780: 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 73 :test-get-status
4790: 20 20 70 72 65 76 2d 74 65 73 74 29 29 0a 09 09 prev-test))...
47a0: 09 09 20 28 70 72 65 76 2d 73 74 61 74 65 20 20 .. (prev-state
47b0: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 (db:test-get-st
47c0: 61 74 65 20 20 20 70 72 65 76 2d 74 65 73 74 29 ate prev-test)
47d0: 29 0a 09 09 09 09 20 28 70 72 65 76 2d 63 6f 6d )..... (prev-com
47e0: 6d 65 6e 74 20 28 64 62 3a 74 65 73 74 2d 67 65 ment (db:test-ge
47f0: 74 2d 63 6f 6d 6d 65 6e 74 20 70 72 65 76 2d 74 t-comment prev-t
4800: 65 73 74 29 29 29 0a 09 09 09 20 20 20 20 20 28 est))).... (
4810: 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 2a 64 debug:print 4 *d
4820: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
4830: 20 22 70 72 65 76 2d 73 74 61 74 75 73 20 22 20 "prev-status "
4840: 70 72 65 76 2d 73 74 61 74 75 73 20 22 2c 20 70 prev-status ", p
4850: 72 65 76 2d 73 74 61 74 65 20 22 20 70 72 65 76 rev-state " prev
4860: 2d 73 74 61 74 65 20 22 2c 20 70 72 65 76 2d 63 -state ", prev-c
4870: 6f 6d 6d 65 6e 74 20 22 20 70 72 65 76 2d 63 6f omment " prev-co
4880: 6d 6d 65 6e 74 29 0a 09 09 09 20 20 20 20 20 28 mment).... (
4890: 69 66 20 28 61 6e 64 20 28 65 71 75 61 6c 3f 20 if (and (equal?
48a0: 70 72 65 76 2d 73 74 61 74 65 20 20 22 43 4f 4d prev-state "COM
48b0: 50 4c 45 54 45 44 22 29 0a 09 09 09 09 20 20 20 PLETED").....
48c0: 20 20 20 28 65 71 75 61 6c 3f 20 70 72 65 76 2d (equal? prev-
48d0: 73 74 61 74 75 73 20 22 57 41 49 56 45 44 22 29 status "WAIVED")
48e0: 29 0a 09 09 09 09 20 28 69 66 20 63 6f 6d 6d 65 )..... (if comme
48f0: 6e 74 0a 09 09 09 09 20 20 20 20 20 63 6f 6d 6d nt..... comm
4900: 65 6e 74 0a 09 09 09 09 20 20 20 20 20 70 72 65 ent..... pre
4910: 76 2d 63 6f 6d 6d 65 6e 74 29 20 3b 3b 20 77 61 v-comment) ;; wa
4920: 69 76 65 64 20 69 73 20 65 69 74 68 65 72 20 74 ived is either t
4930: 68 65 20 63 6f 6d 6d 65 6e 74 20 6f 72 20 23 66 he comment or #f
4940: 0a 09 09 09 09 20 23 66 29 29 0a 09 09 09 20 20 ..... #f))....
4950: 20 23 66 29 0a 09 09 20 20 20 20 20 20 20 23 66 #f)... #f
4960: 29 29 29 0a 20 20 20 20 28 69 66 20 28 61 6e 64 ))). (if (and
4970: 20 77 61 69 76 65 64 20 0a 09 20 20 20 20 20 28 waived .. (
4980: 74 65 73 74 73 3a 63 68 65 63 6b 2d 77 61 69 76 tests:check-waiv
4990: 65 72 2d 65 6c 69 67 69 62 69 6c 69 74 79 20 74 er-eligibility t
49a0: 65 73 74 64 61 74 20 70 72 65 76 2d 74 65 73 74 estdat prev-test
49b0: 29 29 0a 09 28 73 65 74 21 20 72 65 61 6c 2d 73 ))..(set! real-s
49c0: 74 61 74 75 73 20 22 57 41 49 56 45 44 22 29 29 tatus "WAIVED"))
49d0: 0a 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
49e0: 6e 74 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 4 *default-lo
49f0: 67 2d 70 6f 72 74 2a 20 22 72 65 61 6c 2d 73 74 g-port* "real-st
4a00: 61 74 75 73 20 22 20 72 65 61 6c 2d 73 74 61 74 atus " real-stat
4a10: 75 73 20 22 2c 20 77 61 69 76 65 64 20 22 20 77 us ", waived " w
4a20: 61 69 76 65 64 20 22 2c 20 73 74 61 74 75 73 20 aived ", status
4a30: 22 20 73 74 61 74 75 73 29 0a 0a 20 20 20 20 3b " status).. ;
4a40: 3b 20 75 70 64 61 74 65 20 74 68 65 20 70 72 69 ; update the pri
4a50: 6d 61 72 79 20 72 65 63 6f 72 64 20 49 46 20 73 mary record IF s
4a60: 74 61 74 65 20 41 4e 44 20 73 74 61 74 75 73 20 tate AND status
4a70: 61 72 65 20 64 65 66 69 6e 65 64 0a 20 20 20 20 are defined.
4a80: 28 69 66 20 28 61 6e 64 20 73 74 61 74 65 20 73 (if (and state s
4a90: 74 61 74 75 73 29 0a 09 28 62 65 67 69 6e 0a 09 tatus)..(begin..
4aa0: 20 20 28 72 6d 74 3a 73 65 74 2d 73 74 61 74 65 (rmt:set-state
4ab0: 2d 73 74 61 74 75 73 2d 61 6e 64 2d 72 6f 6c 6c -status-and-roll
4ac0: 2d 75 70 2d 69 74 65 6d 73 20 72 75 6e 2d 69 64 -up-items run-id
4ad0: 20 74 65 73 74 2d 69 64 20 69 74 65 6d 2d 70 61 test-id item-pa
4ae0: 74 68 20 73 74 61 74 65 20 72 65 61 6c 2d 73 74 th state real-st
4af0: 61 74 75 73 20 28 69 66 20 77 61 69 76 65 64 20 atus (if waived
4b00: 77 61 69 76 65 64 20 63 6f 6d 6d 65 6e 74 29 29 waived comment))
4b10: 0a 09 20 20 3b 3b 20 28 6d 74 3a 70 72 6f 63 65 .. ;; (mt:proce
4b20: 73 73 2d 74 72 69 67 67 65 72 73 20 72 75 6e 2d ss-triggers run-
4b30: 69 64 20 74 65 73 74 2d 69 64 20 73 74 61 74 65 id test-id state
4b40: 20 72 65 61 6c 2d 73 74 61 74 75 73 29 20 3b 3b real-status) ;;
4b50: 20 74 72 69 67 67 65 72 73 20 61 72 65 20 63 61 triggers are ca
4b60: 6c 6c 65 64 20 69 6e 20 74 65 73 74 2d 73 65 74 lled in test-set
4b70: 2d 73 74 61 74 65 2d 73 74 61 74 75 73 0a 09 20 -state-status..
4b80: 20 29 29 0a 20 20 20 20 0a 20 20 20 20 3b 3b 20 )). . ;;
4b90: 69 66 20 73 74 61 74 75 73 20 69 73 20 22 41 55 if status is "AU
4ba0: 54 4f 22 20 74 68 65 6e 20 63 61 6c 6c 20 72 6f TO" then call ro
4bb0: 6c 6c 75 70 20 28 6e 6f 74 65 2c 20 74 68 69 73 llup (note, this
4bc0: 20 6f 6e 65 20 6d 6f 64 69 66 69 65 73 20 64 61 one modifies da
4bd0: 74 61 20 69 6e 20 74 65 73 74 0a 20 20 20 20 3b ta in test. ;
4be0: 3b 20 72 75 6e 20 61 72 65 61 2c 20 69 74 20 64 ; run area, it d
4bf0: 6f 65 73 20 72 65 6d 6f 74 65 20 63 61 6c 6c 73 oes remote calls
4c00: 20 75 6e 64 65 72 20 74 68 65 20 68 6f 6f 64 2e under the hood.
4c10: 0a 20 20 20 20 3b 3b 20 28 69 66 20 28 61 6e 64 . ;; (if (and
4c20: 20 74 65 73 74 2d 69 64 20 73 74 61 74 65 20 73 test-id state s
4c30: 74 61 74 75 73 20 28 65 71 75 61 6c 3f 20 73 74 tatus (equal? st
4c40: 61 74 75 73 20 22 41 55 54 4f 22 29 29 20 0a 20 atus "AUTO")) .
4c50: 20 20 20 3b 3b 20 09 28 72 6d 74 3a 74 65 73 74 ;; .(rmt:test
4c60: 2d 64 61 74 61 2d 72 6f 6c 6c 75 70 20 72 75 6e -data-rollup run
4c70: 2d 69 64 20 74 65 73 74 2d 69 64 20 73 74 61 74 -id test-id stat
4c80: 75 73 29 29 0a 0a 20 20 20 20 3b 3b 20 61 64 64 us)).. ;; add
4c90: 20 6d 65 74 61 64 61 74 61 20 28 6e 65 65 64 20 metadata (need
4ca0: 74 6f 20 64 6f 20 74 68 69 73 20 77 61 79 20 74 to do this way t
4cb0: 6f 20 61 76 6f 69 64 20 53 51 4c 20 69 6e 6a 65 o avoid SQL inje
4cc0: 63 74 69 6f 6e 20 69 73 73 75 65 73 29 0a 0a 20 ction issues)..
4cd0: 20 20 20 3b 3b 20 3a 66 69 72 73 74 5f 65 72 72 ;; :first_err
4ce0: 0a 20 20 20 20 3b 3b 20 28 6c 65 74 20 28 28 76 . ;; (let ((v
4cf0: 61 6c 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 al (hash-table-r
4d00: 65 66 2f 64 65 66 61 75 6c 74 20 6f 74 68 65 72 ef/default other
4d10: 64 61 74 20 22 3a 66 69 72 73 74 5f 65 72 72 22 dat ":first_err"
4d20: 20 23 66 29 29 29 0a 20 20 20 20 3b 3b 20 20 20 #f))). ;;
4d30: 28 69 66 20 76 61 6c 0a 20 20 20 20 3b 3b 20 20 (if val. ;;
4d40: 20 20 20 20 20 28 73 71 6c 69 74 65 33 3a 65 78 (sqlite3:ex
4d50: 65 63 75 74 65 20 64 62 20 22 55 50 44 41 54 45 ecute db "UPDATE
4d60: 20 74 65 73 74 73 20 53 45 54 20 66 69 72 73 74 tests SET first
4d70: 5f 65 72 72 3d 3f 20 57 48 45 52 45 20 72 75 6e _err=? WHERE run
4d80: 5f 69 64 3d 3f 20 41 4e 44 20 74 65 73 74 6e 61 _id=? AND testna
4d90: 6d 65 3d 3f 20 41 4e 44 20 69 74 65 6d 5f 70 61 me=? AND item_pa
4da0: 74 68 3d 3f 3b 22 20 76 61 6c 20 72 75 6e 2d 69 th=?;" val run-i
4db0: 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d d test-name item
4dc0: 2d 70 61 74 68 29 29 29 0a 20 20 20 20 3b 3b 20 -path))). ;;
4dd0: 0a 20 20 20 20 3b 3b 20 3b 3b 20 3a 66 69 72 73 . ;; ;; :firs
4de0: 74 5f 77 61 72 6e 0a 20 20 20 20 3b 3b 20 28 6c t_warn. ;; (l
4df0: 65 74 20 28 28 76 61 6c 20 28 68 61 73 68 2d 74 et ((val (hash-t
4e00: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
4e10: 20 6f 74 68 65 72 64 61 74 20 22 3a 66 69 72 73 otherdat ":firs
4e20: 74 5f 77 61 72 6e 22 20 23 66 29 29 29 0a 20 20 t_warn" #f))).
4e30: 20 20 3b 3b 20 20 20 28 69 66 20 76 61 6c 0a 20 ;; (if val.
4e40: 20 20 20 3b 3b 20 20 20 20 20 20 20 28 73 71 6c ;; (sql
4e50: 69 74 65 33 3a 65 78 65 63 75 74 65 20 64 62 20 ite3:execute db
4e60: 22 55 50 44 41 54 45 20 74 65 73 74 73 20 53 45 "UPDATE tests SE
4e70: 54 20 66 69 72 73 74 5f 77 61 72 6e 3d 3f 20 57 T first_warn=? W
4e80: 48 45 52 45 20 72 75 6e 5f 69 64 3d 3f 20 41 4e HERE run_id=? AN
4e90: 44 20 74 65 73 74 6e 61 6d 65 3d 3f 20 41 4e 44 D testname=? AND
4ea0: 20 69 74 65 6d 5f 70 61 74 68 3d 3f 3b 22 20 76 item_path=?;" v
4eb0: 61 6c 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e al run-id test-n
4ec0: 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 29 ame item-path)))
4ed0: 0a 0a 20 20 20 20 28 6c 65 74 20 28 28 63 61 74 .. (let ((cat
4ee0: 65 67 6f 72 79 20 28 68 61 73 68 2d 74 61 62 6c egory (hash-tabl
4ef0: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 6f 74 e-ref/default ot
4f00: 68 65 72 64 61 74 20 22 3a 63 61 74 65 67 6f 72 herdat ":categor
4f10: 79 22 20 22 22 29 29 0a 09 20 20 28 76 61 72 69 y" "")).. (vari
4f20: 61 62 6c 65 20 28 68 61 73 68 2d 74 61 62 6c 65 able (hash-table
4f30: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 6f 74 68 -ref/default oth
4f40: 65 72 64 61 74 20 22 3a 76 61 72 69 61 62 6c 65 erdat ":variable
4f50: 22 20 22 22 29 29 0a 09 20 20 28 76 61 6c 75 65 " "")).. (value
4f60: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
4f70: 72 65 66 2f 64 65 66 61 75 6c 74 20 6f 74 68 65 ref/default othe
4f80: 72 64 61 74 20 22 3a 76 61 6c 75 65 22 20 20 20 rdat ":value"
4f90: 20 23 66 29 29 0a 09 20 20 28 65 78 70 65 63 74 #f)).. (expect
4fa0: 65 64 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 ed (hash-table-r
4fb0: 65 66 2f 64 65 66 61 75 6c 74 20 6f 74 68 65 72 ef/default other
4fc0: 64 61 74 20 22 3a 65 78 70 65 63 74 65 64 22 20 dat ":expected"
4fd0: 22 6e 2f 61 22 29 29 0a 09 20 20 28 74 6f 6c 20 "n/a")).. (tol
4fe0: 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
4ff0: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 6f 74 68 -ref/default oth
5000: 65 72 64 61 74 20 22 3a 74 6f 6c 22 20 20 20 20 erdat ":tol"
5010: 20 20 22 6e 2f 61 22 29 29 0a 09 20 20 28 75 6e "n/a")).. (un
5020: 69 74 73 20 20 20 20 28 68 61 73 68 2d 74 61 62 its (hash-tab
5030: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 6f le-ref/default o
5040: 74 68 65 72 64 61 74 20 22 3a 75 6e 69 74 73 22 therdat ":units"
5050: 20 20 20 20 22 22 29 29 0a 09 20 20 28 74 79 70 "")).. (typ
5060: 65 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c e (hash-tabl
5070: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 6f 74 e-ref/default ot
5080: 68 65 72 64 61 74 20 22 3a 74 79 70 65 22 20 20 herdat ":type"
5090: 20 20 20 22 22 29 29 0a 09 20 20 28 64 63 6f 6d "")).. (dcom
50a0: 6d 65 6e 74 20 28 68 61 73 68 2d 74 61 62 6c 65 ment (hash-table
50b0: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 6f 74 68 -ref/default oth
50c0: 65 72 64 61 74 20 22 3a 63 6f 6d 6d 65 6e 74 22 erdat ":comment"
50d0: 20 20 22 22 29 29 29 0a 20 20 20 20 20 20 28 64 ""))). (d
50e0: 65 62 75 67 3a 70 72 69 6e 74 20 34 20 2a 64 65 ebug:print 4 *de
50f0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
5100: 0a 09 09 20 20 20 22 63 61 74 65 67 6f 72 79 3a ... "category:
5110: 20 22 20 63 61 74 65 67 6f 72 79 20 22 2c 20 76 " category ", v
5120: 61 72 69 61 62 6c 65 3a 20 22 20 76 61 72 69 61 ariable: " varia
5130: 62 6c 65 20 22 2c 20 76 61 6c 75 65 3a 20 22 20 ble ", value: "
5140: 76 61 6c 75 65 0a 09 09 20 20 20 22 2c 20 65 78 value... ", ex
5150: 70 65 63 74 65 64 3a 20 22 20 65 78 70 65 63 74 pected: " expect
5160: 65 64 20 22 2c 20 74 6f 6c 3a 20 22 20 74 6f 6c ed ", tol: " tol
5170: 20 22 2c 20 75 6e 69 74 73 3a 20 22 20 75 6e 69 ", units: " uni
5180: 74 73 29 0a 20 20 20 20 20 20 28 69 66 20 28 61 ts). (if (a
5190: 6e 64 20 76 61 6c 75 65 29 20 3b 3b 20 72 65 71 nd value) ;; req
51a0: 75 69 72 65 20 6f 6e 6c 79 20 76 61 6c 75 65 3b uire only value;
51b0: 20 42 42 20 77 61 73 2d 20 61 6c 6c 20 74 68 72 BB was- all thr
51c0: 65 65 20 72 65 71 75 69 72 65 64 0a 09 20 20 28 ee required.. (
51d0: 6c 65 74 20 28 28 64 61 74 20 28 63 6f 6e 63 20 let ((dat (conc
51e0: 63 61 74 65 67 6f 72 79 20 22 2c 22 0a 09 09 09 category ","....
51f0: 20 20 20 76 61 72 69 61 62 6c 65 20 22 2c 22 0a variable ",".
5200: 09 09 09 20 20 20 76 61 6c 75 65 20 20 20 20 22 ... value "
5210: 2c 22 0a 09 09 09 20 20 20 65 78 70 65 63 74 65 ,".... expecte
5220: 64 20 22 2c 22 0a 09 09 09 20 20 20 74 6f 6c 20 d ",".... tol
5230: 20 20 20 20 20 22 2c 22 0a 09 09 09 20 20 20 75 ",".... u
5240: 6e 69 74 73 20 20 20 20 22 2c 22 0a 09 09 09 20 nits ","....
5250: 20 20 64 63 6f 6d 6d 65 6e 74 20 22 2c 2c 22 20 dcomment ",,"
5260: 3b 3b 20 65 78 74 72 61 20 63 6f 6d 6d 61 20 66 ;; extra comma f
5270: 6f 72 20 73 74 61 74 75 73 0a 09 09 09 20 20 20 or status....
5280: 74 79 70 65 20 20 20 20 20 29 29 29 0a 09 20 20 type )))..
5290: 20 20 3b 3b 20 54 68 69 73 20 77 61 73 20 72 75 ;; This was ru
52a0: 6e 20 72 65 6d 6f 74 65 2c 20 64 6f 6e 27 74 20 n remote, don't
52b0: 74 68 69 6e 6b 20 74 68 61 74 20 6d 61 6b 65 73 think that makes
52c0: 20 73 65 6e 73 65 2e 20 50 65 72 68 61 70 73 20 sense. Perhaps
52d0: 6e 6f 74 2c 20 62 75 74 20 74 68 61 74 20 69 73 not, but that is
52e0: 20 74 68 65 20 65 61 73 69 65 73 74 20 70 61 74 the easiest pat
52f0: 68 20 66 6f 72 20 74 68 65 20 6d 6f 6d 65 6e 74 h for the moment
5300: 2e 0a 09 20 20 20 20 28 72 6d 74 3a 63 73 76 2d ... (rmt:csv-
5310: 3e 74 65 73 74 2d 64 61 74 61 20 72 75 6e 2d 69 >test-data run-i
5320: 64 20 74 65 73 74 2d 69 64 0a 09 09 09 09 64 61 d test-id.....da
5330: 74 29 0a 09 20 20 20 20 3b 3b 20 54 68 69 73 20 t).. ;; This
5340: 77 61 73 20 61 64 64 65 64 20 69 6e 20 63 68 65 was added in che
5350: 63 6b 2d 69 6e 20 61 35 61 64 66 61 33 66 39 61 ck-in a5adfa3f9a
5360: 2e 20 4d 65 73 73 61 67 65 20 77 61 73 3a 20 22 . Message was: "
5370: 2e 2e 2e 61 64 64 65 64 20 64 65 6c 61 79 20 69 ...added delay i
5380: 6e 20 73 65 74 2d 76 61 6c 75 65 73 20 74 6f 20 n set-values to
5390: 61 6c 6c 6f 77 20 66 6f 72 20 64 65 6c 61 79 65 allow for delaye
53a0: 64 20 77 72 69 74 65 20 6f 6e 20 73 65 72 76 65 d write on serve
53b0: 72 20 73 74 61 72 74 22 0a 09 20 20 20 20 3b 3b r start".. ;;
53c0: 20 49 27 6d 20 69 6e 73 65 72 74 69 6e 67 20 61 I'm inserting a
53d0: 6e 20 61 72 62 69 74 72 61 72 79 20 72 6d 74 3a n arbitrary rmt:
53e0: 20 63 61 6c 6c 20 74 6f 20 66 6f 72 63 65 2f 65 call to force/e
53f0: 6e 73 75 72 65 20 74 68 61 74 20 74 68 65 20 73 nsure that the s
5400: 65 72 76 65 72 20 69 73 20 61 76 61 69 6c 61 62 erver is availab
5410: 6c 65 20 74 6f 20 28 68 6f 70 65 66 75 6c 6c 79 le to (hopefully
5420: 29 20 70 72 65 76 65 6e 74 20 61 20 63 6f 6d 6d ) prevent a comm
5430: 75 6e 69 63 61 74 69 6f 6e 20 69 73 73 75 65 2e unication issue.
5440: 0a 09 20 20 20 20 28 72 6d 74 3a 67 65 74 2d 76 .. (rmt:get-v
5450: 61 72 20 22 4d 45 47 41 54 45 53 54 5f 56 45 52 ar "MEGATEST_VER
5460: 53 49 4f 4e 22 29 20 3b 3b 20 74 68 69 73 20 64 SION") ;; this d
5470: 6f 65 73 20 4e 4f 54 48 49 4e 47 20 62 75 74 20 oes NOTHING but
5480: 65 6e 73 75 72 65 20 74 68 65 20 73 65 72 76 65 ensure the serve
5490: 72 20 69 73 20 72 65 61 63 68 61 62 6c 65 2e 20 r is reachable.
54a0: 54 68 69 73 20 69 73 20 61 6c 6d 6f 73 74 20 63 This is almost c
54b0: 65 72 74 61 69 6e 6c 79 20 4e 4f 54 20 6e 65 65 ertainly NOT nee
54c0: 64 65 64 20 3a 29 0a 20 20 20 20 20 20 20 20 20 ded :).
54d0: 20 20 20 3b 3b 20 42 42 20 2d 20 63 6f 6d 6d 65 ;; BB - comme
54e0: 6e 74 69 6f 6e 67 20 6f 75 74 20 61 72 62 69 74 ntiong out arbit
54f0: 72 61 72 79 20 31 30 20 73 65 63 6f 6e 64 20 77 rary 10 second w
5500: 61 69 74 20 28 74 68 72 65 61 64 2d 73 6c 65 65 ait (thread-slee
5510: 70 21 20 31 30 29 20 3b 3b 20 61 64 64 20 31 30 p! 10) ;; add 10
5520: 20 73 65 63 6f 6e 64 20 64 65 6c 61 79 20 62 65 second delay be
5530: 66 6f 72 65 20 71 75 69 74 20 69 6e 63 61 73 65 fore quit incase
5540: 20 72 6d 74 20 6e 65 65 64 73 20 74 69 6d 65 20 rmt needs time
5550: 74 6f 20 73 74 61 72 74 20 61 20 73 65 72 76 65 to start a serve
5560: 72 2e 0a 20 20 20 20 20 20 20 20 20 20 20 20 29 r.. )
5570: 29 29 0a 20 20 20 20 20 20 0a 20 20 20 20 3b 3b )). . ;;
5580: 20 6e 65 65 64 20 74 6f 20 75 70 64 61 74 65 20 need to update
5590: 74 68 65 20 74 6f 70 20 74 65 73 74 20 72 65 63 the top test rec
55a0: 6f 72 64 20 69 66 20 50 41 53 53 20 6f 72 20 46 ord if PASS or F
55b0: 41 49 4c 20 61 6e 64 20 74 68 69 73 20 69 73 20 AIL and this is
55c0: 61 20 73 75 62 74 65 73 74 0a 20 20 20 20 3b 3b a subtest. ;;
55d0: 3b 3b 3b 3b 20 28 69 66 20 28 6e 6f 74 20 28 65 ;;;; (if (not (e
55e0: 71 75 61 6c 3f 20 69 74 65 6d 2d 70 61 74 68 20 qual? item-path
55f0: 22 22 29 29 0a 20 20 20 20 3b 3b 3b 3b 3b 3b 20 "")). ;;;;;;
5600: 20 20 20 20 28 72 6d 74 3a 73 65 74 2d 73 74 61 (rmt:set-sta
5610: 74 65 2d 73 74 61 74 75 73 2d 61 6e 64 2d 72 6f te-status-and-ro
5620: 6c 6c 2d 75 70 2d 69 74 65 6d 73 20 72 75 6e 2d ll-up-items run-
5630: 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 id test-name ite
5640: 6d 2d 70 61 74 68 20 73 74 61 74 65 20 73 74 61 m-path state sta
5650: 74 75 73 20 23 66 29 20 3b 3b 3b 3b 3b 29 0a 0a tus #f) ;;;;;)..
5660: 20 20 20 20 28 69 66 20 28 6f 72 20 28 61 6e 64 (if (or (and
5670: 20 28 73 74 72 69 6e 67 3f 20 63 6f 6d 6d 65 6e (string? commen
5680: 74 29 0a 09 09 20 28 73 74 72 69 6e 67 2d 6d 61 t)... (string-ma
5690: 74 63 68 20 28 72 65 67 65 78 70 20 22 5c 5c 53 tch (regexp "\\S
56a0: 2b 22 29 20 63 6f 6d 6d 65 6e 74 29 29 0a 09 20 +") comment))..
56b0: 20 20 20 77 61 69 76 65 64 29 0a 09 28 6c 65 74 waived)..(let
56c0: 20 28 28 63 6d 74 20 20 28 69 66 20 77 61 69 76 ((cmt (if waiv
56d0: 65 64 20 77 61 69 76 65 64 20 63 6f 6d 6d 65 6e ed waived commen
56e0: 74 29 29 29 0a 09 20 20 28 72 6d 74 3a 67 65 6e t))).. (rmt:gen
56f0: 65 72 61 6c 2d 63 61 6c 6c 20 27 73 65 74 2d 74 eral-call 'set-t
5700: 65 73 74 2d 63 6f 6d 6d 65 6e 74 20 72 75 6e 2d est-comment run-
5710: 69 64 20 63 6d 74 20 74 65 73 74 2d 69 64 29 29 id cmt test-id))
5720: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 )))..(define (te
5730: 73 74 73 3a 74 65 73 74 2d 73 65 74 2d 74 6f 70 sts:test-set-top
5740: 6c 6f 67 21 20 72 75 6e 2d 69 64 20 74 65 73 74 log! run-id test
5750: 2d 6e 61 6d 65 20 6c 6f 67 66 29 20 0a 20 20 28 -name logf) . (
5760: 72 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 61 6c 6c rmt:general-call
5770: 20 27 74 65 73 74 73 3a 74 65 73 74 2d 73 65 74 'tests:test-set
5780: 2d 74 6f 70 6c 6f 67 20 72 75 6e 2d 69 64 20 6c -toplog run-id l
5790: 6f 67 66 20 72 75 6e 2d 69 64 20 74 65 73 74 2d ogf run-id test-
57a0: 6e 61 6d 65 29 29 0a 0a 28 64 65 66 69 6e 65 20 name))..(define
57b0: 28 74 65 73 74 73 3a 73 75 6d 6d 61 72 69 7a 65 (tests:summarize
57c0: 2d 69 74 65 6d 73 20 72 75 6e 2d 69 64 20 74 65 -items run-id te
57d0: 73 74 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 st-id test-name
57e0: 66 6f 72 63 65 29 0a 20 20 3b 3b 20 69 66 20 6e force). ;; if n
57f0: 6f 74 20 66 6f 72 63 65 20 74 68 65 6e 20 6f 6e ot force then on
5800: 6c 79 20 75 70 64 61 74 65 20 74 68 65 20 72 65 ly update the re
5810: 63 6f 72 64 20 69 66 20 6f 6e 65 20 6f 66 20 74 cord if one of t
5820: 68 65 73 65 20 69 73 20 74 72 75 65 3a 0a 20 20 hese is true:.
5830: 3b 3b 20 20 20 31 2e 20 6c 6f 67 66 20 69 73 20 ;; 1. logf is
5840: 22 6c 6f 67 2f 66 69 6e 61 6c 2e 6c 6f 67 0a 20 "log/final.log.
5850: 20 3b 3b 20 20 20 32 2e 20 6c 6f 67 66 20 69 73 ;; 2. logf is
5860: 20 73 61 6d 65 20 61 73 20 6f 75 74 70 75 74 66 same as outputf
5870: 69 6c 65 6e 61 6d 65 0a 20 20 28 6c 65 74 2a 20 ilename. (let*
5880: 28 28 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 ((outputfilename
5890: 20 28 63 6f 6e 63 20 22 6d 65 67 61 74 65 73 74 (conc "megatest
58a0: 2d 72 6f 6c 6c 75 70 2d 22 20 74 65 73 74 2d 6e -rollup-" test-n
58b0: 61 6d 65 20 22 2e 68 74 6d 6c 22 29 29 0a 09 20 ame ".html"))..
58c0: 28 6f 72 69 67 2d 64 69 72 20 20 20 20 20 20 20 (orig-dir
58d0: 28 63 75 72 72 65 6e 74 2d 64 69 72 65 63 74 6f (current-directo
58e0: 72 79 29 29 0a 09 20 28 6c 6f 67 66 2d 69 6e 66 ry)).. (logf-inf
58f0: 6f 20 20 20 20 20 20 28 72 6d 74 3a 74 65 73 74 o (rmt:test
5900: 2d 67 65 74 2d 6c 6f 67 66 69 6c 65 2d 69 6e 66 -get-logfile-inf
5910: 6f 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 o run-id test-na
5920: 6d 65 29 29 0a 09 20 28 6c 6f 67 66 20 20 20 20 me)).. (logf
5930: 20 20 20 20 20 20 20 28 69 66 20 6c 6f 67 66 2d (if logf-
5940: 69 6e 66 6f 20 28 63 61 64 72 20 6c 6f 67 66 2d info (cadr logf-
5950: 69 6e 66 6f 29 20 23 66 29 29 0a 09 20 28 70 61 info) #f)).. (pa
5960: 74 68 20 20 20 20 20 20 20 20 20 20 20 28 69 66 th (if
5970: 20 6c 6f 67 66 2d 69 6e 66 6f 20 28 63 61 72 20 logf-info (car
5980: 20 6c 6f 67 66 2d 69 6e 66 6f 29 20 23 66 29 29 logf-info) #f))
5990: 29 0a 20 20 20 20 3b 3b 20 54 68 69 73 20 71 75 ). ;; This qu
59a0: 65 72 79 20 66 69 6e 64 73 20 74 68 65 20 70 61 ery finds the pa
59b0: 74 68 20 61 6e 64 20 63 68 61 6e 67 65 73 20 74 th and changes t
59c0: 68 65 20 64 69 72 65 63 74 6f 72 79 20 74 6f 20 he directory to
59d0: 69 74 20 66 6f 72 20 74 68 65 20 74 65 73 74 0a it for the test.
59e0: 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 73 74 (if (and (st
59f0: 72 69 6e 67 3f 20 70 61 74 68 29 0a 09 20 20 20 ring? path)..
5a00: 20 20 28 64 69 72 65 63 74 6f 72 79 3f 20 70 61 (directory? pa
5a10: 74 68 29 29 20 3b 3b 20 63 61 6e 20 67 65 74 20 th)) ;; can get
5a20: 23 66 20 68 65 72 65 20 75 6e 64 65 72 20 73 6f #f here under so
5a30: 6d 65 20 77 69 65 72 64 20 63 6f 6e 64 69 74 69 me wierd conditi
5a40: 6f 6e 73 2e 20 77 68 79 2c 20 75 6e 6b 6e 6f 77 ons. why, unknow
5a50: 6e 20 2e 2e 2e 0a 09 28 62 65 67 69 6e 0a 09 20 n .....(begin..
5a60: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 (debug:print 4
5a70: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
5a80: 74 2a 20 22 46 6f 75 6e 64 20 70 61 74 68 3a 20 t* "Found path:
5a90: 22 20 70 61 74 68 29 0a 09 20 20 28 63 68 61 6e " path).. (chan
5aa0: 67 65 2d 64 69 72 65 63 74 6f 72 79 20 70 61 74 ge-directory pat
5ab0: 68 29 29 0a 09 3b 3b 20 28 73 65 74 21 20 6f 75 h))..;; (set! ou
5ac0: 74 70 75 74 66 69 6c 65 6e 61 6d 65 20 28 63 6f tputfilename (co
5ad0: 6e 63 20 70 61 74 68 20 22 2f 22 20 6f 75 74 70 nc path "/" outp
5ae0: 75 74 66 69 6c 65 6e 61 6d 65 29 29 29 0a 09 28 utfilename)))..(
5af0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f debug:print-erro
5b00: 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 r 0 *default-log
5b10: 2d 70 6f 72 74 2a 20 22 73 75 6d 6d 61 72 69 7a -port* "summariz
5b20: 65 2d 69 74 65 6d 73 20 66 6f 72 20 72 75 6e 2d e-items for run-
5b30: 69 64 3d 22 20 72 75 6e 2d 69 64 20 22 2c 20 74 id=" run-id ", t
5b40: 65 73 74 2d 6e 61 6d 65 3d 22 20 74 65 73 74 2d est-name=" test-
5b50: 6e 61 6d 65 20 22 2c 20 6e 6f 20 73 75 63 68 20 name ", no such
5b60: 70 61 74 68 3a 20 22 20 70 61 74 68 29 29 0a 20 path: " path)).
5b70: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
5b80: 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 4 *default-log-p
5b90: 6f 72 74 2a 20 22 73 75 6d 6d 61 72 69 7a 65 2d ort* "summarize-
5ba0: 69 74 65 6d 73 20 77 69 74 68 20 6c 6f 67 66 20 items with logf
5bb0: 22 20 6c 6f 67 66 20 22 2c 20 6f 75 74 70 75 74 " logf ", output
5bc0: 66 69 6c 65 6e 61 6d 65 20 22 20 6f 75 74 70 75 filename " outpu
5bd0: 74 66 69 6c 65 6e 61 6d 65 20 22 20 61 6e 64 20 tfilename " and
5be0: 66 6f 72 63 65 20 22 20 66 6f 72 63 65 29 0a 20 force " force).
5bf0: 20 20 20 28 69 66 20 28 6f 72 20 28 65 71 75 61 (if (or (equa
5c00: 6c 3f 20 6c 6f 67 66 20 22 6c 6f 67 73 2f 66 69 l? logf "logs/fi
5c10: 6e 61 6c 2e 6c 6f 67 22 29 0a 09 20 20 20 20 28 nal.log").. (
5c20: 65 71 75 61 6c 3f 20 6c 6f 67 66 20 6f 75 74 70 equal? logf outp
5c30: 75 74 66 69 6c 65 6e 61 6d 65 29 0a 09 20 20 20 utfilename)..
5c40: 20 66 6f 72 63 65 29 0a 09 28 6c 65 74 20 28 28 force)..(let ((
5c50: 6d 79 2d 73 74 61 72 74 2d 74 69 6d 65 20 28 63 my-start-time (c
5c60: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 urrent-seconds))
5c70: 0a 09 20 20 20 20 20 20 28 6c 6f 63 6b 66 20 20 .. (lockf
5c80: 20 20 20 20 20 20 20 28 63 6f 6e 63 20 6f 75 74 (conc out
5c90: 70 75 74 66 69 6c 65 6e 61 6d 65 20 22 2e 6c 6f putfilename ".lo
5ca0: 63 6b 22 29 29 29 0a 09 20 20 28 6c 65 74 20 6c ck"))).. (let l
5cb0: 6f 6f 70 20 28 28 68 61 76 65 2d 6c 6f 63 6b 20 oop ((have-lock
5cc0: 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 2d (common:simple-
5cd0: 66 69 6c 65 2d 6c 6f 63 6b 20 6c 6f 63 6b 66 29 file-lock lockf)
5ce0: 29 29 0a 09 20 20 20 20 28 69 66 20 68 61 76 65 )).. (if have
5cf0: 2d 6c 6f 63 6b 0a 09 09 28 6c 65 74 20 28 28 73 -lock...(let ((s
5d00: 63 72 69 70 74 20 28 63 6f 6e 66 69 67 66 3a 6c cript (configf:l
5d10: 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 ookup *configdat
5d20: 2a 20 22 74 65 73 74 72 6f 6c 6c 75 70 22 20 74 * "testrollup" t
5d30: 65 73 74 2d 6e 61 6d 65 29 29 29 0a 09 09 20 20 est-name)))...
5d40: 28 70 72 69 6e 74 20 22 4f 62 74 61 69 6e 65 64 (print "Obtained
5d50: 20 6c 6f 63 6b 20 66 6f 72 20 22 20 6f 75 74 70 lock for " outp
5d60: 75 74 66 69 6c 65 6e 61 6d 65 29 0a 09 09 20 20 utfilename)...
5d70: 28 72 6d 74 3a 73 65 74 2d 73 74 61 74 65 2d 73 (rmt:set-state-s
5d80: 74 61 74 75 73 2d 61 6e 64 2d 72 6f 6c 6c 2d 75 tatus-and-roll-u
5d90: 70 2d 69 74 65 6d 73 20 72 75 6e 2d 69 64 20 74 p-items run-id t
5da0: 65 73 74 2d 6e 61 6d 65 20 22 22 20 23 66 20 23 est-name "" #f #
5db0: 66 20 23 66 29 0a 09 09 20 20 28 69 66 20 73 63 f #f)... (if sc
5dc0: 72 69 70 74 0a 09 09 20 20 20 20 20 20 28 73 79 ript... (sy
5dd0: 73 74 65 6d 20 28 63 6f 6e 63 20 73 63 72 69 70 stem (conc scrip
5de0: 74 20 22 20 3e 20 22 20 6f 75 74 70 75 74 66 69 t " > " outputfi
5df0: 6c 65 6e 61 6d 65 20 22 20 26 20 22 29 29 0a 09 lename " & "))..
5e00: 09 20 20 20 20 20 20 28 74 65 73 74 73 3a 67 65 . (tests:ge
5e10: 6e 65 72 61 74 65 2d 68 74 6d 6c 2d 73 75 6d 6d nerate-html-summ
5e20: 61 72 79 2d 66 6f 72 2d 69 74 65 72 61 74 65 64 ary-for-iterated
5e30: 2d 74 65 73 74 20 72 75 6e 2d 69 64 20 74 65 73 -test run-id tes
5e40: 74 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 6f t-id test-name o
5e50: 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 29 29 0a utputfilename)).
5e60: 09 09 20 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 .. (common:simp
5e70: 6c 65 2d 66 69 6c 65 2d 72 65 6c 65 61 73 65 2d le-file-release-
5e80: 6c 6f 63 6b 20 6c 6f 63 6b 66 29 0a 09 09 20 20 lock lockf)...
5e90: 28 63 68 61 6e 67 65 2d 64 69 72 65 63 74 6f 72 (change-director
5ea0: 79 20 6f 72 69 67 2d 64 69 72 29 0a 09 09 20 20 y orig-dir)...
5eb0: 3b 3b 20 4e 42 2f 2f 20 74 65 73 74 73 3a 74 65 ;; NB// tests:te
5ec0: 73 74 2d 73 65 74 2d 74 6f 70 6c 6f 67 21 20 69 st-set-toplog! i
5ed0: 73 20 72 65 6d 6f 74 65 20 69 6e 74 65 72 6e 61 s remote interna
5ee0: 6c 2e 2e 2e 0a 09 09 20 20 28 74 65 73 74 73 3a l...... (tests:
5ef0: 74 65 73 74 2d 73 65 74 2d 74 6f 70 6c 6f 67 21 test-set-toplog!
5f00: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
5f10: 65 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 e outputfilename
5f20: 29 29 0a 09 09 3b 3b 20 64 69 64 6e 27 74 20 67 ))...;; didn't g
5f30: 65 74 20 74 68 65 20 6c 6f 63 6b 2c 20 63 68 65 et the lock, che
5f40: 63 6b 20 74 6f 20 73 65 65 20 69 66 20 63 75 72 ck to see if cur
5f50: 72 65 6e 74 20 75 70 64 61 74 65 20 73 74 61 72 rent update star
5f60: 74 65 64 20 6c 61 74 65 72 20 74 68 61 6e 20 74 ted later than t
5f70: 68 69 73 20 0a 09 09 3b 3b 20 75 70 64 61 74 65 his ...;; update
5f80: 2c 20 69 66 20 73 6f 20 77 65 20 63 61 6e 20 65 , if so we can e
5f90: 78 69 74 20 77 69 74 68 6f 75 74 20 64 6f 69 6e xit without doin
5fa0: 67 20 61 6e 79 20 77 6f 72 6b 0a 09 09 28 69 66 g any work...(if
5fb0: 20 28 3e 20 6d 79 2d 73 74 61 72 74 2d 74 69 6d (> my-start-tim
5fc0: 65 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 e (handle-except
5fd0: 69 6f 6e 73 0a 09 09 09 09 09 20 65 78 6e 0a 09 ions...... exn..
5fe0: 09 09 09 20 20 20 20 20 20 20 28 62 65 67 69 6e ... (begin
5ff0: 0a 09 09 09 09 09 20 28 70 72 69 6e 74 20 22 66 ...... (print "f
6000: 61 69 6c 65 64 20 74 6f 20 67 65 74 20 6d 6f 64 ailed to get mod
6010: 20 74 69 6d 65 20 6f 6e 20 22 20 6c 6f 63 6b 66 time on " lockf
6020: 20 22 2c 20 65 78 6e 3d 22 20 65 78 6e 29 0a 09 ", exn=" exn)..
6030: 09 09 09 09 20 30 29 0a 09 09 09 09 20 20 20 20 .... 0).....
6040: 20 20 20 28 66 69 6c 65 2d 6d 6f 64 69 66 69 63 (file-modific
6050: 61 74 69 6f 6e 2d 74 69 6d 65 20 6c 6f 63 6b 66 ation-time lockf
6060: 29 29 29 0a 09 09 20 20 20 20 3b 3b 20 77 65 20 )))... ;; we
6070: 73 74 61 72 74 65 64 20 73 69 6e 63 65 20 63 75 started since cu
6080: 72 72 65 6e 74 20 72 65 2d 67 65 6e 20 69 6e 20 rrent re-gen in
6090: 66 6c 69 67 68 74 2c 20 64 65 6c 61 79 20 61 20 flight, delay a
60a0: 6c 69 74 74 6c 65 20 61 6e 64 20 74 72 79 20 61 little and try a
60b0: 67 61 69 6e 0a 09 09 20 20 20 20 28 62 65 67 69 gain... (begi
60c0: 6e 0a 09 09 20 20 20 20 20 20 28 64 65 62 75 67 n... (debug
60d0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 2a 64 :print-info 1 *d
60e0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
60f0: 20 22 57 61 69 74 69 6e 67 20 74 6f 20 75 70 64 "Waiting to upd
6100: 61 74 65 20 22 20 6f 75 74 70 75 74 66 69 6c 65 ate " outputfile
6110: 6e 61 6d 65 20 22 2c 20 61 6e 6f 74 68 65 72 20 name ", another
6120: 74 65 73 74 20 63 75 72 72 65 6e 74 6c 79 20 75 test currently u
6130: 70 64 61 74 69 6e 67 20 69 74 22 29 0a 09 09 20 pdating it")...
6140: 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 (thread-sle
6150: 65 70 21 20 28 2b 20 35 20 28 72 61 6e 64 6f 6d ep! (+ 5 (random
6160: 20 35 29 29 29 20 3b 3b 20 64 65 6c 61 79 20 62 5))) ;; delay b
6170: 65 74 77 65 65 6e 20 35 20 61 6e 64 20 31 30 20 etween 5 and 10
6180: 73 65 63 6f 6e 64 73 0a 09 09 20 20 20 20 20 20 seconds...
6190: 28 6c 6f 6f 70 20 28 63 6f 6d 6d 6f 6e 3a 73 69 (loop (common:si
61a0: 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 20 6c mple-file-lock l
61b0: 6f 63 6b 66 29 29 29 29 29 29 29 29 29 29 0a 0a ockf))))))))))..
61c0: 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 67 (define (tests:g
61d0: 65 6e 65 72 61 74 65 2d 68 74 6d 6c 2d 73 75 6d enerate-html-sum
61e0: 6d 61 72 79 2d 66 6f 72 2d 69 74 65 72 61 74 65 mary-for-iterate
61f0: 64 2d 74 65 73 74 20 72 75 6e 2d 69 64 20 74 65 d-test run-id te
6200: 73 74 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 st-id test-name
6210: 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 29 0a outputfilename).
6220: 20 20 28 6c 65 74 20 28 28 63 6f 75 6e 74 73 20 (let ((counts
6230: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 (ma
6240: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
6250: 09 28 73 74 61 74 65 63 6f 75 6e 74 73 20 20 20 .(statecounts
6260: 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 (make-hash
6270: 2d 74 61 62 6c 65 29 29 0a 09 28 6f 75 74 74 78 -table))..(outtx
6280: 74 20 20 20 20 20 20 20 20 20 20 20 20 20 20 22 t "
6290: 22 29 0a 09 28 74 6f 74 20 20 20 20 20 20 20 20 ")..(tot
62a0: 20 20 20 20 20 20 20 20 20 30 29 0a 09 28 74 65 0)..(te
62b0: 73 74 64 61 74 20 20 20 20 20 20 20 20 20 20 20 stdat
62c0: 20 20 28 72 6d 74 3a 74 65 73 74 2d 67 65 74 2d (rmt:test-get-
62d0: 72 65 63 6f 72 64 73 2d 66 6f 72 2d 69 6e 64 65 records-for-inde
62e0: 78 2d 66 69 6c 65 20 72 75 6e 2d 69 64 20 74 65 x-file run-id te
62f0: 73 74 2d 6e 61 6d 65 29 29 29 0a 20 20 20 20 28 st-name))). (
6300: 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 66 with-output-to-f
6310: 69 6c 65 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 ile outputfilena
6320: 6d 65 0a 20 20 20 20 20 20 28 6c 61 6d 62 64 61 me. (lambda
6330: 20 28 29 0a 09 28 73 65 74 21 20 6f 75 74 74 78 ()..(set! outtx
6340: 74 20 28 63 6f 6e 63 20 6f 75 74 74 78 74 20 22 t (conc outtxt "
6350: 3c 68 74 6d 6c 3e 3c 74 69 74 6c 65 3e 53 75 6d <html><title>Sum
6360: 6d 61 72 79 3a 20 22 20 74 65 73 74 2d 6e 61 6d mary: " test-nam
6370: 65 20 0a 09 09 09 20 20 20 22 3c 2f 74 69 74 6c e .... "</titl
6380: 65 3e 3c 62 6f 64 79 3e 3c 68 32 3e 53 75 6d 6d e><body><h2>Summ
6390: 61 72 79 20 66 6f 72 20 22 20 74 65 73 74 2d 6e ary for " test-n
63a0: 61 6d 65 20 22 3c 2f 68 32 3e 22 29 29 0a 09 28 ame "</h2>"))..(
63b0: 66 6f 72 2d 65 61 63 68 0a 09 20 28 6c 61 6d 62 for-each.. (lamb
63c0: 64 61 20 28 74 65 73 74 72 65 63 6f 72 64 29 0a da (testrecord).
63d0: 09 20 20 20 28 6c 65 74 20 28 28 69 64 20 20 20 . (let ((id
63e0: 20 20 20 20 20 20 20 20 20 20 28 76 65 63 74 6f (vecto
63f0: 72 2d 72 65 66 20 74 65 73 74 72 65 63 6f 72 64 r-ref testrecord
6400: 20 30 29 29 0a 09 09 20 28 69 74 65 6d 70 61 74 0))... (itempat
6410: 68 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d h (vector-
6420: 72 65 66 20 74 65 73 74 72 65 63 6f 72 64 20 31 ref testrecord 1
6430: 29 29 0a 09 09 20 28 73 74 61 74 65 20 20 20 20 ))... (state
6440: 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 (vector-re
6450: 66 20 74 65 73 74 72 65 63 6f 72 64 20 32 29 29 f testrecord 2))
6460: 0a 09 09 20 28 73 74 61 74 75 73 20 20 20 20 20 ... (status
6470: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
6480: 74 65 73 74 72 65 63 6f 72 64 20 33 29 29 0a 09 testrecord 3))..
6490: 09 20 28 72 75 6e 5f 64 75 72 61 74 69 6f 6e 20 . (run_duration
64a0: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 65 (vector-ref te
64b0: 73 74 72 65 63 6f 72 64 20 34 29 29 0a 09 09 20 strecord 4))...
64c0: 28 6c 6f 67 66 20 20 20 20 20 20 20 20 20 20 20 (logf
64d0: 28 76 65 63 74 6f 72 2d 72 65 66 20 74 65 73 74 (vector-ref test
64e0: 72 65 63 6f 72 64 20 35 29 29 0a 09 09 20 28 63 record 5))... (c
64f0: 6f 6d 6d 65 6e 74 20 20 20 20 20 20 20 20 28 76 omment (v
6500: 65 63 74 6f 72 2d 72 65 66 20 74 65 73 74 72 65 ector-ref testre
6510: 63 6f 72 64 20 36 29 29 29 0a 09 20 20 20 20 20 cord 6)))..
6520: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
6530: 20 63 6f 75 6e 74 73 20 73 74 61 74 75 73 20 28 counts status (
6540: 2b 20 31 20 28 68 61 73 68 2d 74 61 62 6c 65 2d + 1 (hash-table-
6550: 72 65 66 2f 64 65 66 61 75 6c 74 20 63 6f 75 6e ref/default coun
6560: 74 73 20 73 74 61 74 75 73 20 30 29 29 29 0a 09 ts status 0)))..
6570: 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
6580: 2d 73 65 74 21 20 73 74 61 74 65 63 6f 75 6e 74 -set! statecount
6590: 73 20 73 74 61 74 65 20 28 2b 20 31 20 28 68 61 s state (+ 1 (ha
65a0: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
65b0: 61 75 6c 74 20 73 74 61 74 65 63 6f 75 6e 74 73 ault statecounts
65c0: 20 73 74 61 74 65 20 30 29 29 29 0a 09 20 20 20 state 0)))..
65d0: 20 20 28 73 65 74 21 20 6f 75 74 74 78 74 20 28 (set! outtxt (
65e0: 63 6f 6e 63 20 6f 75 74 74 78 74 20 22 3c 74 72 conc outtxt "<tr
65f0: 3e 22 0a 09 09 09 09 3b 3b 20 22 3c 74 64 3e 3c >".....;; "<td><
6600: 61 20 68 72 65 66 3d 5c 22 22 20 69 74 65 6d 70 a href=\"" itemp
6610: 61 74 68 20 22 2f 22 20 6c 6f 67 66 20 22 5c 22 ath "/" logf "\"
6620: 3e 20 22 20 69 74 65 6d 70 61 74 68 20 22 3c 2f > " itempath "</
6630: 61 3e 3c 2f 74 64 3e 22 20 0a 09 09 09 09 22 3c a></td>" ....."<
6640: 74 64 3e 3c 61 20 68 72 65 66 3d 5c 22 22 20 69 td><a href=\"" i
6650: 74 65 6d 70 61 74 68 20 22 2f 74 65 73 74 2d 73 tempath "/test-s
6660: 75 6d 6d 61 72 79 2e 68 74 6d 6c 5c 22 3e 20 22 ummary.html\"> "
6670: 20 69 74 65 6d 70 61 74 68 20 22 3c 2f 61 3e 3c itempath "</a><
6680: 2f 74 64 3e 22 20 0a 09 09 09 09 22 3c 74 64 3e /td>" ....."<td>
6690: 22 20 73 74 61 74 65 20 20 20 20 22 3c 2f 74 64 " state "</td
66a0: 3e 22 20 0a 09 09 09 09 22 3c 74 64 3e 3c 66 6f >" ....."<td><fo
66b0: 6e 74 20 63 6f 6c 6f 72 3d 22 20 28 63 6f 6d 6d nt color=" (comm
66c0: 6f 6e 3a 67 65 74 2d 63 6f 6c 6f 72 2d 66 72 6f on:get-color-fro
66d0: 6d 2d 73 74 61 74 75 73 20 73 74 61 74 75 73 29 m-status status)
66e0: 0a 09 09 09 09 22 3e 22 20 20 20 73 74 61 74 75 .....">" statu
66f0: 73 20 20 20 22 3c 2f 66 6f 6e 74 3e 3c 2f 74 64 s "</font></td
6700: 3e 22 0a 09 09 09 09 22 3c 74 64 3e 22 20 28 69 >"....."<td>" (i
6710: 66 20 28 65 71 75 61 6c 3f 20 63 6f 6d 6d 65 6e f (equal? commen
6720: 74 20 22 22 29 0a 09 09 09 09 09 20 20 20 22 26 t "")...... "&
6730: 6e 62 73 70 3b 22 0a 09 09 09 09 09 20 20 20 63 nbsp;"...... c
6740: 6f 6d 6d 65 6e 74 29 20 22 3c 2f 74 64 3e 22 0a omment) "</td>".
6750: 09 09 09 09 09 20 20 20 22 3c 2f 74 72 3e 22 29 ..... "</tr>")
6760: 29 29 29 0a 09 20 28 69 66 20 28 6c 69 73 74 3f ))).. (if (list?
6770: 20 74 65 73 74 64 61 74 29 0a 09 20 20 20 20 20 testdat)..
6780: 74 65 73 74 64 61 74 0a 09 20 20 20 20 20 28 62 testdat.. (b
6790: 65 67 69 6e 0a 09 20 20 20 20 20 20 20 28 70 72 egin.. (pr
67a0: 69 6e 74 20 22 45 52 52 4f 52 3a 20 66 61 69 6c int "ERROR: fail
67b0: 65 64 20 74 6f 20 67 65 74 20 72 65 63 6f 72 64 ed to get record
67c0: 73 20 77 69 74 68 20 72 6d 74 3a 74 65 73 74 2d s with rmt:test-
67d0: 67 65 74 2d 72 65 63 6f 72 64 73 2d 66 6f 72 2d get-records-for-
67e0: 69 6e 64 65 78 2d 66 69 6c 65 20 72 75 6e 2d 69 index-file run-i
67f0: 64 3d 22 20 72 75 6e 2d 69 64 20 22 74 65 73 74 d=" run-id "test
6800: 2d 6e 61 6d 65 3d 22 20 74 65 73 74 2d 6e 61 6d -name=" test-nam
6810: 65 29 0a 09 20 20 20 20 20 20 20 27 28 29 29 29 e).. '()))
6820: 29 0a 09 0a 09 28 70 72 69 6e 74 20 22 3c 74 61 )....(print "<ta
6830: 62 6c 65 3e 3c 74 72 3e 3c 74 64 20 76 61 6c 69 ble><tr><td vali
6840: 67 6e 3d 5c 22 74 6f 70 5c 22 3e 22 29 0a 09 3b gn=\"top\">")..;
6850: 3b 20 50 72 69 6e 74 20 6f 75 74 20 73 74 61 74 ; Print out stat
6860: 73 20 66 6f 72 20 73 74 61 74 75 73 0a 09 28 73 s for status..(s
6870: 65 74 21 20 74 6f 74 20 30 29 0a 09 28 70 72 69 et! tot 0)..(pri
6880: 6e 74 20 22 3c 74 61 62 6c 65 20 63 65 6c 6c 73 nt "<table cells
6890: 70 61 63 69 6e 67 3d 5c 22 30 5c 22 20 62 6f 72 pacing=\"0\" bor
68a0: 64 65 72 3d 5c 22 31 5c 22 3e 3c 74 72 3e 3c 74 der=\"1\"><tr><t
68b0: 64 20 63 6f 6c 73 70 61 6e 3d 5c 22 32 5c 22 3e d colspan=\"2\">
68c0: 3c 68 32 3e 53 74 61 74 65 20 73 74 61 74 73 3c <h2>State stats<
68d0: 2f 68 32 3e 3c 2f 74 64 3e 3c 2f 74 72 3e 22 29 /h2></td></tr>")
68e0: 0a 09 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d ..(for-each (lam
68f0: 62 64 61 20 28 73 74 61 74 65 29 0a 09 09 20 20 bda (state)...
6900: 20 20 28 73 65 74 21 20 74 6f 74 20 28 2b 20 74 (set! tot (+ t
6910: 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 ot (hash-table-r
6920: 65 66 20 73 74 61 74 65 63 6f 75 6e 74 73 20 73 ef statecounts s
6930: 74 61 74 65 29 29 29 0a 09 09 20 20 20 20 28 70 tate)))... (p
6940: 72 69 6e 74 20 22 3c 74 72 3e 3c 74 64 3e 22 20 rint "<tr><td>"
6950: 73 74 61 74 65 20 22 3c 2f 74 64 3e 3c 74 64 3e state "</td><td>
6960: 22 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 " (hash-table-re
6970: 66 20 73 74 61 74 65 63 6f 75 6e 74 73 20 73 74 f statecounts st
6980: 61 74 65 29 20 22 3c 2f 74 64 3e 3c 2f 74 72 3e ate) "</td></tr>
6990: 22 29 29 0a 09 09 20 20 28 68 61 73 68 2d 74 61 "))... (hash-ta
69a0: 62 6c 65 2d 6b 65 79 73 20 73 74 61 74 65 63 6f ble-keys stateco
69b0: 75 6e 74 73 29 29 0a 09 28 70 72 69 6e 74 20 22 unts))..(print "
69c0: 3c 74 72 3e 3c 74 64 3e 54 6f 74 61 6c 3c 2f 74 <tr><td>Total</t
69d0: 64 3e 3c 74 64 3e 22 20 74 6f 74 20 22 3c 2f 74 d><td>" tot "</t
69e0: 64 3e 3c 2f 74 72 3e 3c 2f 74 61 62 6c 65 3e 22 d></tr></table>"
69f0: 29 0a 09 28 70 72 69 6e 74 20 22 3c 2f 74 64 3e )..(print "</td>
6a00: 3c 74 64 20 76 61 6c 69 67 6e 3d 5c 22 74 6f 70 <td valign=\"top
6a10: 5c 22 3e 22 29 0a 09 3b 3b 20 50 72 69 6e 74 20 \">")..;; Print
6a20: 6f 75 74 20 73 74 61 74 73 20 66 6f 72 20 73 74 out stats for st
6a30: 61 74 65 0a 09 28 73 65 74 21 20 74 6f 74 20 30 ate..(set! tot 0
6a40: 29 0a 09 28 70 72 69 6e 74 20 22 3c 74 61 62 6c )..(print "<tabl
6a50: 65 20 63 65 6c 6c 73 70 61 63 69 6e 67 3d 5c 22 e cellspacing=\"
6a60: 30 5c 22 20 62 6f 72 64 65 72 3d 5c 22 31 5c 22 0\" border=\"1\"
6a70: 3e 3c 74 72 3e 3c 74 64 20 63 6f 6c 73 70 61 6e ><tr><td colspan
6a80: 3d 5c 22 32 5c 22 3e 3c 68 32 3e 53 74 61 74 75 =\"2\"><h2>Statu
6a90: 73 20 73 74 61 74 73 3c 2f 68 32 3e 3c 2f 74 64 s stats</h2></td
6aa0: 3e 3c 2f 74 72 3e 22 29 0a 09 28 66 6f 72 2d 65 ></tr>")..(for-e
6ab0: 61 63 68 20 28 6c 61 6d 62 64 61 20 28 73 74 61 ach (lambda (sta
6ac0: 74 75 73 29 0a 09 09 20 20 20 20 28 73 65 74 21 tus)... (set!
6ad0: 20 74 6f 74 20 28 2b 20 74 6f 74 20 28 68 61 73 tot (+ tot (has
6ae0: 68 2d 74 61 62 6c 65 2d 72 65 66 20 63 6f 75 6e h-table-ref coun
6af0: 74 73 20 73 74 61 74 75 73 29 29 29 0a 09 09 20 ts status)))...
6b00: 20 20 20 28 70 72 69 6e 74 20 22 3c 74 72 3e 3c (print "<tr><
6b10: 74 64 3e 3c 66 6f 6e 74 20 63 6f 6c 6f 72 3d 5c td><font color=\
6b20: 22 22 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 "" (common:get-c
6b30: 6f 6c 6f 72 2d 66 72 6f 6d 2d 73 74 61 74 75 73 olor-from-status
6b40: 20 73 74 61 74 75 73 29 20 22 5c 22 3e 22 20 73 status) "\">" s
6b50: 74 61 74 75 73 0a 09 09 09 20 20 20 22 3c 2f 66 tatus.... "</f
6b60: 6f 6e 74 3e 3c 2f 74 64 3e 3c 74 64 3e 22 20 28 ont></td><td>" (
6b70: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 63 hash-table-ref c
6b80: 6f 75 6e 74 73 20 73 74 61 74 75 73 29 20 22 3c ounts status) "<
6b90: 2f 74 64 3e 3c 2f 74 72 3e 22 29 29 0a 09 09 20 /td></tr>"))...
6ba0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 (hash-table-key
6bb0: 73 20 63 6f 75 6e 74 73 29 29 0a 09 28 70 72 69 s counts))..(pri
6bc0: 6e 74 20 22 3c 74 72 3e 3c 74 64 3e 54 6f 74 61 nt "<tr><td>Tota
6bd0: 6c 3c 2f 74 64 3e 3c 74 64 3e 22 20 74 6f 74 20 l</td><td>" tot
6be0: 22 3c 2f 74 64 3e 3c 2f 74 72 3e 3c 2f 74 61 62 "</td></tr></tab
6bf0: 6c 65 3e 22 29 0a 09 28 70 72 69 6e 74 20 22 3c le>")..(print "<
6c00: 2f 74 64 3e 3c 2f 74 64 3e 3c 2f 74 72 3e 3c 2f /td></td></tr></
6c10: 74 61 62 6c 65 3e 22 29 0a 09 0a 09 28 70 72 69 table>")....(pri
6c20: 6e 74 20 22 3c 74 61 62 6c 65 20 63 65 6c 6c 73 nt "<table cells
6c30: 70 61 63 69 6e 67 3d 5c 22 30 5c 22 20 62 6f 72 pacing=\"0\" bor
6c40: 64 65 72 3d 5c 22 31 5c 22 3e 22 20 0a 09 20 20 der=\"1\">" ..
6c50: 20 20 20 20 20 22 3c 74 72 3e 3c 74 64 3e 49 74 "<tr><td>It
6c60: 65 6d 3c 2f 74 64 3e 3c 74 64 3e 53 74 61 74 65 em</td><td>State
6c70: 3c 2f 74 64 3e 3c 74 64 3e 53 74 61 74 75 73 3c </td><td>Status<
6c80: 2f 74 64 3e 3c 74 64 3e 43 6f 6d 6d 65 6e 74 3c /td><td>Comment<
6c90: 2f 74 64 3e 22 0a 09 20 20 20 20 20 20 20 6f 75 /td>".. ou
6ca0: 74 74 78 74 20 22 3c 2f 74 61 62 6c 65 3e 3c 2f ttxt "</table></
6cb0: 62 6f 64 79 3e 3c 2f 68 74 6d 6c 3e 22 29 0a 09 body></html>")..
6cc0: 3b 3b 20 28 72 65 6c 65 61 73 65 2d 64 6f 74 2d ;; (release-dot-
6cd0: 6c 6f 63 6b 20 6f 75 74 70 75 74 66 69 6c 65 6e lock outputfilen
6ce0: 61 6d 65 29 0a 09 3b 3b 28 72 6d 74 3a 75 70 64 ame)..;;(rmt:upd
6cf0: 61 74 65 2d 72 75 6e 2d 73 74 61 74 73 20 0a 09 ate-run-stats ..
6d00: 3b 3b 20 72 75 6e 2d 69 64 0a 09 3b 3b 20 28 68 ;; run-id..;; (h
6d10: 61 73 68 2d 74 61 62 6c 65 2d 6d 61 70 0a 09 3b ash-table-map..;
6d20: 3b 20 20 73 74 61 74 65 2d 73 74 61 74 75 73 2d ; state-status-
6d30: 63 6f 75 6e 74 73 0a 09 3b 3b 20 20 28 6c 61 6d counts..;; (lam
6d40: 62 64 61 20 28 6b 65 79 20 76 61 6c 29 0a 09 3b bda (key val)..;
6d50: 3b 09 28 61 70 70 65 6e 64 20 6b 65 79 20 28 6c ;.(append key (l
6d60: 69 73 74 20 76 61 6c 29 29 29 29 29 0a 09 29 29 ist val)))))..))
6d70: 29 29 0a 0a 28 64 65 66 69 6e 65 20 74 65 73 74 ))..(define test
6d80: 73 3a 63 73 73 2d 6a 73 63 72 69 70 74 2d 62 6c s:css-jscript-bl
6d90: 6f 63 6b 0a 23 3c 3c 45 4f 46 0a 3c 73 74 79 6c ock.#<<EOF.<styl
6da0: 65 20 74 79 70 65 3d 22 74 65 78 74 2f 63 73 73 e type="text/css
6db0: 22 3e 0a 75 6c 2e 4c 69 6e 6b 65 64 4c 69 73 74 ">.ul.LinkedList
6dc0: 20 7b 20 64 69 73 70 6c 61 79 3a 20 62 6c 6f 63 { display: bloc
6dd0: 6b 3b 20 7d 0a 2f 2a 20 75 6c 2e 4c 69 6e 6b 65 k; }./* ul.Linke
6de0: 64 4c 69 73 74 20 75 6c 20 7b 20 64 69 73 70 6c dList ul { displ
6df0: 61 79 3a 20 6e 6f 6e 65 3b 20 7d 20 2a 2f 0a 2e ay: none; } */..
6e00: 48 61 6e 64 43 75 72 73 6f 72 53 74 79 6c 65 20 HandCursorStyle
6e10: 7b 20 63 75 72 73 6f 72 3a 20 70 6f 69 6e 74 65 { cursor: pointe
6e20: 72 3b 20 63 75 72 73 6f 72 3a 20 68 61 6e 64 3b r; cursor: hand;
6e30: 20 7d 20 20 2f 2a 20 46 6f 72 20 49 45 20 2a 2f } /* For IE */
6e40: 0a 74 68 20 7b 62 61 63 6b 67 72 6f 75 6e 64 2d .th {background-
6e50: 63 6f 6c 6f 72 3a 20 23 38 63 38 63 38 63 3b 7d color: #8c8c8c;}
6e60: 0a 74 64 2e 74 65 73 74 20 7b 62 61 63 6b 67 72 .td.test {backgr
6e70: 6f 75 6e 64 2d 63 6f 6c 6f 72 3a 20 23 64 39 64 ound-color: #d9d
6e80: 62 64 64 3b 7d 0a 74 64 2e 50 41 53 53 20 7b 62 bdd;}.td.PASS {b
6e90: 61 63 6b 67 72 6f 75 6e 64 2d 63 6f 6c 6f 72 3a ackground-color:
6ea0: 20 23 33 34 37 35 33 33 3b 7d 0a 74 64 2e 46 41 #347533;}.td.FA
6eb0: 49 4c 20 7b 62 61 63 6b 67 72 6f 75 6e 64 2d 63 IL {background-c
6ec0: 6f 6c 6f 72 3a 20 23 63 63 32 38 31 32 3b 7d 0a olor: #cc2812;}.
6ed0: 74 64 2e 53 4b 49 50 7b 62 61 63 6b 67 72 6f 75 td.SKIP{backgrou
6ee0: 6e 64 2d 63 6f 6c 6f 72 3a 20 23 46 46 44 37 33 nd-color: #FFD73
6ef0: 33 3b 7d 0a 74 64 2e 57 41 52 4e 20 7b 62 61 63 3;}.td.WARN {bac
6f00: 6b 67 72 6f 75 6e 64 2d 63 6f 6c 6f 72 3a 20 23 kground-color: #
6f10: 45 41 38 37 32 34 3b 7d 0a 74 64 2e 57 41 49 56 EA8724;}.td.WAIV
6f20: 45 44 20 7b 62 61 63 6b 67 72 6f 75 6e 64 2d 63 ED {background-c
6f30: 6f 6c 6f 72 3a 20 23 38 33 38 41 31 32 3b 7d 0a olor: #838A12;}.
6f40: 74 64 2e 41 42 4f 52 54 7b 62 61 63 6b 67 72 6f td.ABORT{backgro
6f50: 75 6e 64 2d 63 6f 6c 6f 72 3a 20 23 45 41 32 34 und-color: #EA24
6f60: 42 37 3b 7d 0a 2e 50 41 53 53 20 2e 6c 69 6e 6b B7;}..PASS .link
6f70: 2c 20 2e 53 4b 49 50 20 2e 6c 69 6e 6b 2c 20 2e , .SKIP .link, .
6f80: 57 41 52 4e 20 2e 6c 69 6e 6b 2c 2e 57 41 49 56 WARN .link,.WAIV
6f90: 45 44 20 2e 6c 69 6e 6b 2c 2e 41 42 4f 52 54 20 ED .link,.ABORT
6fa0: 2e 6c 69 6e 6b 2c 20 2e 46 41 49 4c 20 2e 6c 69 .link, .FAIL .li
6fb0: 6e 6b 7b 63 6f 6c 6f 72 3a 20 23 46 46 46 46 46 nk{color: #FFFFF
6fc0: 46 3b 7d 0a 0a 0a 3c 2f 73 74 79 6c 65 3e 0a 0a F;}...</style>..
6fd0: 0a 20 20 3c 73 63 72 69 70 74 20 74 79 70 65 3d . <script type=
6fe0: 22 74 65 78 74 2f 4a 61 76 61 53 63 72 69 70 74 "text/JavaScript
6ff0: 22 3e 0a 0a 20 20 20 20 66 75 6e 63 74 69 6f 6e ">.. function
7000: 20 66 69 6c 74 65 72 73 6f 6d 65 28 29 20 7b 0a filtersome() {.
7010: 20 20 24 28 22 74 72 22 29 2e 73 68 6f 77 28 29 $("tr").show()
7020: 3b 0a 20 20 24 28 22 2e 74 65 73 74 22 29 2e 66 ;. $(".test").f
7030: 69 6c 74 65 72 28 0a 20 20 20 20 66 75 6e 63 74 ilter(. funct
7040: 69 6f 6e 28 29 20 7b 0a 20 20 20 20 20 20 76 61 ion() {. va
7050: 72 20 6e 61 6d 65 73 20 3d 20 24 28 27 23 74 65 r names = $('#te
7060: 73 74 6e 61 6d 65 27 29 2e 76 61 6c 28 29 2e 73 stname').val().s
7070: 70 6c 69 74 28 27 2c 27 29 3b 0a 20 20 20 20 20 plit(',');.
7080: 20 76 61 72 20 67 6f 6f 64 3d 31 3b 0a 20 20 20 var good=1;.
7090: 20 20 20 66 6f 72 20 28 76 61 72 20 69 3d 30 2c for (var i=0,
70a0: 20 6c 65 6e 3d 6e 61 6d 65 73 2e 6c 65 6e 67 74 len=names.lengt
70b0: 68 3b 20 69 3c 6c 65 6e 3b 20 69 2b 2b 29 20 7b h; i<len; i++) {
70c0: 0a 20 20 20 20 20 20 20 20 76 61 72 20 75 6e 61 . var una
70d0: 6d 65 3d 6e 61 6d 65 73 5b 69 5d 3b 0a 20 20 20 me=names[i];.
70e0: 20 20 20 20 20 63 6f 6e 73 6f 6c 65 2e 6c 6f 67 console.log
70f0: 28 22 54 72 79 69 6e 67 20 74 6f 20 63 68 65 63 ("Trying to chec
7100: 6b 20 66 6f 72 20 22 20 2b 20 75 6e 61 6d 65 29 k for " + uname)
7110: 3b 20 0a 20 20 20 20 20 20 20 20 69 66 28 24 28 ; . if($(
7120: 74 68 69 73 29 2e 74 65 78 74 28 29 2e 69 6e 64 this).text().ind
7130: 65 78 4f 66 28 75 6e 61 6d 65 29 20 21 3d 20 2d exOf(uname) != -
7140: 31 29 20 7b 0a 20 20 20 20 20 20 20 20 20 20 67 1) {. g
7150: 6f 6f 64 3d 20 30 3b 0a 20 20 20 20 20 20 20 20 ood= 0;.
7160: 20 20 63 6f 6e 73 6f 6c 65 2e 6c 6f 67 28 22 46 console.log("F
7170: 6f 75 6e 64 20 22 2b 75 6e 61 6d 65 29 3b 0a 20 ound "+uname);.
7180: 20 20 20 20 20 20 20 7d 0a 20 20 20 20 20 20 7d }. }
7190: 0a 20 20 20 20 20 20 72 65 74 75 72 6e 20 67 6f . return go
71a0: 6f 64 3b 20 0a 20 20 20 20 7d 0a 20 20 29 2e 70 od; . }. ).p
71b0: 61 72 65 6e 74 28 29 2e 68 69 64 65 28 29 3b 0a arent().hide();.
71c0: 2f 2f 20 20 24 28 22 2e 73 75 6d 22 29 2e 73 68 // $(".sum").sh
71d0: 6f 77 28 29 3b 0a 7d 0a 20 20 0a 20 20 20 20 2f ow();.}. . /
71e0: 2f 20 41 64 64 20 74 68 69 73 20 74 6f 20 74 68 / Add this to th
71f0: 65 20 6f 6e 6c 6f 61 64 20 65 76 65 6e 74 20 6f e onload event o
7200: 66 20 74 68 65 20 42 4f 44 59 20 65 6c 65 6d 65 f the BODY eleme
7210: 6e 74 0a 20 20 20 20 66 75 6e 63 74 69 6f 6e 20 nt. function
7220: 61 64 64 45 76 65 6e 74 73 28 29 20 7b 0a 20 20 addEvents() {.
7230: 20 20 20 20 61 63 74 69 76 61 74 65 54 72 65 65 activateTree
7240: 28 64 6f 63 75 6d 65 6e 74 2e 67 65 74 45 6c 65 (document.getEle
7250: 6d 65 6e 74 42 79 49 64 28 22 4c 69 6e 6b 65 64 mentById("Linked
7260: 4c 69 73 74 31 22 29 29 3b 0a 20 20 20 20 7d 0a List1"));. }.
7270: 0a 20 20 20 20 2f 2f 20 54 68 69 73 20 66 75 6e . // This fun
7280: 63 74 69 6f 6e 20 74 72 61 76 65 72 73 65 73 20 ction traverses
7290: 74 68 65 20 6c 69 73 74 20 61 6e 64 20 61 64 64 the list and add
72a0: 20 6c 69 6e 6b 73 20 0a 20 20 20 20 2f 2f 20 74 links . // t
72b0: 6f 20 6e 65 73 74 65 64 20 6c 69 73 74 20 69 74 o nested list it
72c0: 65 6d 73 0a 20 20 20 20 66 75 6e 63 74 69 6f 6e ems. function
72d0: 20 61 63 74 69 76 61 74 65 54 72 65 65 28 6f 4c activateTree(oL
72e0: 69 73 74 29 20 7b 0a 20 20 20 20 20 20 2f 2f 20 ist) {. //
72f0: 43 6f 6c 6c 61 70 73 65 20 74 68 65 20 74 72 65 Collapse the tre
7300: 65 0a 20 20 20 20 20 20 66 6f 72 20 28 76 61 72 e. for (var
7310: 20 69 3d 30 3b 20 69 20 3c 20 6f 4c 69 73 74 2e i=0; i < oList.
7320: 67 65 74 45 6c 65 6d 65 6e 74 73 42 79 54 61 67 getElementsByTag
7330: 4e 61 6d 65 28 22 75 6c 22 29 2e 6c 65 6e 67 74 Name("ul").lengt
7340: 68 3b 20 69 2b 2b 29 20 7b 0a 20 20 20 20 20 20 h; i++) {.
7350: 20 20 6f 4c 69 73 74 2e 67 65 74 45 6c 65 6d 65 oList.getEleme
7360: 6e 74 73 42 79 54 61 67 4e 61 6d 65 28 22 75 6c ntsByTagName("ul
7370: 22 29 5b 69 5d 2e 73 74 79 6c 65 2e 64 69 73 70 ")[i].style.disp
7380: 6c 61 79 3d 22 6e 6f 6e 65 22 3b 20 20 20 20 20 lay="none";
7390: 20 20 20 20 20 20 20 0a 20 20 20 20 20 20 7d 20 . }
73a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
73b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
73c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
73d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
73e0: 20 0a 20 20 20 20 20 20 2f 2f 20 41 64 64 20 74 . // Add t
73f0: 68 65 20 63 6c 69 63 6b 2d 65 76 65 6e 74 20 68 he click-event h
7400: 61 6e 64 6c 65 72 20 74 6f 20 74 68 65 20 6c 69 andler to the li
7410: 73 74 20 69 74 65 6d 73 0a 20 20 20 20 20 20 69 st items. i
7420: 66 20 28 6f 4c 69 73 74 2e 61 64 64 45 76 65 6e f (oList.addEven
7430: 74 4c 69 73 74 65 6e 65 72 29 20 7b 0a 20 20 20 tListener) {.
7440: 20 20 20 20 20 6f 4c 69 73 74 2e 61 64 64 45 76 oList.addEv
7450: 65 6e 74 4c 69 73 74 65 6e 65 72 28 22 63 6c 69 entListener("cli
7460: 63 6b 22 2c 20 74 6f 67 67 6c 65 42 72 61 6e 63 ck", toggleBranc
7470: 68 2c 20 66 61 6c 73 65 29 3b 0a 20 20 20 20 20 h, false);.
7480: 20 7d 20 65 6c 73 65 20 69 66 20 28 6f 4c 69 73 } else if (oLis
7490: 74 2e 61 74 74 61 63 68 45 76 65 6e 74 29 20 7b t.attachEvent) {
74a0: 20 2f 2f 20 46 6f 72 20 49 45 0a 20 20 20 20 20 // For IE.
74b0: 20 20 20 6f 4c 69 73 74 2e 61 74 74 61 63 68 45 oList.attachE
74c0: 76 65 6e 74 28 22 6f 6e 63 6c 69 63 6b 22 2c 20 vent("onclick",
74d0: 74 6f 67 67 6c 65 42 72 61 6e 63 68 29 3b 0a 20 toggleBranch);.
74e0: 20 20 20 20 20 7d 0a 20 20 20 20 20 20 2f 2f 20 }. //
74f0: 4d 61 6b 65 20 74 68 65 20 6e 65 73 74 65 64 20 Make the nested
7500: 69 74 65 6d 73 20 6c 6f 6f 6b 20 6c 69 6b 65 20 items look like
7510: 6c 69 6e 6b 73 0a 20 20 20 20 20 20 61 64 64 4c links. addL
7520: 69 6e 6b 73 54 6f 42 72 61 6e 63 68 65 73 28 6f inksToBranches(o
7530: 4c 69 73 74 29 3b 0a 20 20 20 20 7d 0a 0a 20 20 List);. }..
7540: 20 20 2f 2f 20 54 68 69 73 20 69 73 20 74 68 65 // This is the
7550: 20 63 6c 69 63 6b 2d 65 76 65 6e 74 20 68 61 6e click-event han
7560: 64 6c 65 72 0a 20 20 20 20 66 75 6e 63 74 69 6f dler. functio
7570: 6e 20 74 6f 67 67 6c 65 42 72 61 6e 63 68 28 65 n toggleBranch(e
7580: 76 65 6e 74 29 20 7b 0a 20 20 20 20 20 20 76 61 vent) {. va
7590: 72 20 6f 42 72 61 6e 63 68 2c 20 63 53 75 62 42 r oBranch, cSubB
75a0: 72 61 6e 63 68 65 73 3b 0a 20 20 20 20 20 20 69 ranches;. i
75b0: 66 20 28 65 76 65 6e 74 2e 74 61 72 67 65 74 29 f (event.target)
75c0: 20 7b 0a 20 20 20 20 20 20 20 20 6f 42 72 61 6e {. oBran
75d0: 63 68 20 3d 20 65 76 65 6e 74 2e 74 61 72 67 65 ch = event.targe
75e0: 74 3b 0a 20 20 20 20 20 20 7d 20 65 6c 73 65 20 t;. } else
75f0: 69 66 20 28 65 76 65 6e 74 2e 73 72 63 45 6c 65 if (event.srcEle
7600: 6d 65 6e 74 29 20 7b 20 2f 2f 20 46 6f 72 20 49 ment) { // For I
7610: 45 0a 20 20 20 20 20 20 20 20 6f 42 72 61 6e 63 E. oBranc
7620: 68 20 3d 20 65 76 65 6e 74 2e 73 72 63 45 6c 65 h = event.srcEle
7630: 6d 65 6e 74 3b 0a 20 20 20 20 20 20 7d 0a 20 20 ment;. }.
7640: 20 20 20 20 63 53 75 62 42 72 61 6e 63 68 65 73 cSubBranches
7650: 20 3d 20 6f 42 72 61 6e 63 68 2e 67 65 74 45 6c = oBranch.getEl
7660: 65 6d 65 6e 74 73 42 79 54 61 67 4e 61 6d 65 28 ementsByTagName(
7670: 22 75 6c 22 29 3b 0a 20 20 20 20 20 20 69 66 20 "ul");. if
7680: 28 63 53 75 62 42 72 61 6e 63 68 65 73 2e 6c 65 (cSubBranches.le
7690: 6e 67 74 68 20 3e 20 30 29 20 7b 0a 20 20 20 20 ngth > 0) {.
76a0: 20 20 20 20 69 66 20 28 63 53 75 62 42 72 61 6e if (cSubBran
76b0: 63 68 65 73 5b 30 5d 2e 73 74 79 6c 65 2e 64 69 ches[0].style.di
76c0: 73 70 6c 61 79 20 3d 3d 20 22 62 6c 6f 63 6b 22 splay == "block"
76d0: 29 20 7b 0a 20 20 20 20 20 20 20 20 20 20 63 53 ) {. cS
76e0: 75 62 42 72 61 6e 63 68 65 73 5b 30 5d 2e 73 74 ubBranches[0].st
76f0: 79 6c 65 2e 64 69 73 70 6c 61 79 20 3d 20 22 6e yle.display = "n
7700: 6f 6e 65 22 3b 0a 20 20 20 20 20 20 20 20 7d 20 one";. }
7710: 65 6c 73 65 20 7b 0a 20 20 20 20 20 20 20 20 20 else {.
7720: 20 63 53 75 62 42 72 61 6e 63 68 65 73 5b 30 5d cSubBranches[0]
7730: 2e 73 74 79 6c 65 2e 64 69 73 70 6c 61 79 20 3d .style.display =
7740: 20 22 62 6c 6f 63 6b 22 3b 0a 20 20 20 20 20 20 "block";.
7750: 20 20 7d 0a 20 20 20 20 20 20 7d 0a 20 20 20 20 }. }.
7760: 7d 0a 0a 20 20 20 20 2f 2f 20 54 68 69 73 20 66 }.. // This f
7770: 75 6e 63 74 69 6f 6e 20 6d 61 6b 65 73 20 6e 65 unction makes ne
7780: 73 74 65 64 20 6c 69 73 74 20 69 74 65 6d 73 20 sted list items
7790: 6c 6f 6f 6b 20 6c 69 6b 65 20 6c 69 6e 6b 73 0a look like links.
77a0: 20 20 20 20 66 75 6e 63 74 69 6f 6e 20 61 64 64 function add
77b0: 4c 69 6e 6b 73 54 6f 42 72 61 6e 63 68 65 73 28 LinksToBranches(
77c0: 6f 4c 69 73 74 29 20 7b 0a 20 20 20 20 20 20 76 oList) {. v
77d0: 61 72 20 63 42 72 61 6e 63 68 65 73 20 3d 20 6f ar cBranches = o
77e0: 4c 69 73 74 2e 67 65 74 45 6c 65 6d 65 6e 74 73 List.getElements
77f0: 42 79 54 61 67 4e 61 6d 65 28 22 6c 69 22 29 3b ByTagName("li");
7800: 0a 20 20 20 20 20 20 76 61 72 20 69 2c 20 6e 2c . var i, n,
7810: 20 63 53 75 62 42 72 61 6e 63 68 65 73 3b 0a 20 cSubBranches;.
7820: 20 20 20 20 20 69 66 20 28 63 42 72 61 6e 63 68 if (cBranch
7830: 65 73 2e 6c 65 6e 67 74 68 20 3e 20 30 29 20 7b es.length > 0) {
7840: 0a 20 20 20 20 20 20 20 20 66 6f 72 20 28 69 3d . for (i=
7850: 30 2c 20 6e 20 3d 20 63 42 72 61 6e 63 68 65 73 0, n = cBranches
7860: 2e 6c 65 6e 67 74 68 3b 20 69 20 3c 20 6e 3b 20 .length; i < n;
7870: 69 2b 2b 29 20 7b 0a 20 20 20 20 20 20 20 20 20 i++) {.
7880: 20 63 53 75 62 42 72 61 6e 63 68 65 73 20 3d 20 cSubBranches =
7890: 63 42 72 61 6e 63 68 65 73 5b 69 5d 2e 67 65 74 cBranches[i].get
78a0: 45 6c 65 6d 65 6e 74 73 42 79 54 61 67 4e 61 6d ElementsByTagNam
78b0: 65 28 22 75 6c 22 29 3b 0a 20 20 20 20 20 20 20 e("ul");.
78c0: 20 20 20 69 66 20 28 63 53 75 62 42 72 61 6e 63 if (cSubBranc
78d0: 68 65 73 2e 6c 65 6e 67 74 68 20 3e 20 30 29 20 hes.length > 0)
78e0: 7b 0a 20 20 20 20 20 20 20 20 20 20 20 20 61 64 {. ad
78f0: 64 4c 69 6e 6b 73 54 6f 42 72 61 6e 63 68 65 73 dLinksToBranches
7900: 28 63 53 75 62 42 72 61 6e 63 68 65 73 5b 30 5d (cSubBranches[0]
7910: 29 3b 0a 20 20 20 20 20 20 20 20 20 20 20 20 63 );. c
7920: 42 72 61 6e 63 68 65 73 5b 69 5d 2e 63 6c 61 73 Branches[i].clas
7930: 73 4e 61 6d 65 20 3d 20 22 48 61 6e 64 43 75 72 sName = "HandCur
7940: 73 6f 72 53 74 79 6c 65 22 3b 0a 20 20 20 20 20 sorStyle";.
7950: 20 20 20 20 20 20 20 63 42 72 61 6e 63 68 65 73 cBranches
7960: 5b 69 5d 2e 73 74 79 6c 65 2e 63 6f 6c 6f 72 20 [i].style.color
7970: 3d 20 22 62 6c 75 65 22 3b 0a 20 20 20 20 20 20 = "blue";.
7980: 20 20 20 20 20 20 63 53 75 62 42 72 61 6e 63 68 cSubBranch
7990: 65 73 5b 30 5d 2e 73 74 79 6c 65 2e 63 6f 6c 6f es[0].style.colo
79a0: 72 20 3d 20 22 62 6c 61 63 6b 22 3b 0a 20 20 20 r = "black";.
79b0: 20 20 20 20 20 20 20 20 20 63 53 75 62 42 72 61 cSubBra
79c0: 6e 63 68 65 73 5b 30 5d 2e 73 74 79 6c 65 2e 63 nches[0].style.c
79d0: 75 72 73 6f 72 20 3d 20 22 61 75 74 6f 22 3b 0a ursor = "auto";.
79e0: 20 20 20 20 20 20 20 20 20 20 7d 0a 20 20 20 20 }.
79f0: 20 20 20 20 7d 0a 20 20 20 20 20 20 7d 0a 20 20 }. }.
7a00: 20 20 7d 0a 20 20 3c 2f 73 63 72 69 70 74 3e 0a }. </script>.
7a10: 45 4f 46 0a 29 0a 0a 28 64 65 66 69 6e 65 20 74 EOF.)..(define t
7a20: 65 73 74 73 3a 63 73 73 2d 6a 73 63 72 69 70 74 ests:css-jscript
7a30: 2d 62 6c 6f 63 6b 2d 64 79 6e 61 6d 69 63 20 0a -block-dynamic .
7a40: 23 3c 3c 45 4f 46 0a 20 20 20 20 20 20 20 20 20 #<<EOF.
7a50: 20 20 3c 73 63 72 69 70 74 20 73 72 63 3d 20 2e <script src= .
7a60: 2f 6a 71 75 65 72 79 33 2e 31 2e 30 2e 6a 73 3e /jquery3.1.0.js>
7a70: 3c 2f 73 63 72 69 70 74 3e 20 0a 45 4f 46 0a 29 </script> .EOF.)
7a80: 0a 0a 28 64 65 66 69 6e 65 20 20 28 74 65 73 74 ..(define (test
7a90: 3a 6a 73 2d 62 6c 6f 63 6b 20 6a 61 76 61 73 63 :js-block javasc
7aa0: 72 69 70 74 2d 6c 69 62 29 0a 20 20 20 28 63 6f ript-lib). (co
7ab0: 6e 63 20 20 22 3c 73 63 72 69 70 74 20 73 72 63 nc "<script src
7ac0: 3d 22 20 6a 61 76 61 73 63 72 69 70 74 2d 6c 69 =" javascript-li
7ad0: 62 20 22 3e 3c 2f 73 63 72 69 70 74 3e 22 20 29 b "></script>" )
7ae0: 29 0a 0a 0a 28 64 65 66 69 6e 65 20 74 65 73 74 )...(define test
7af0: 73 3a 63 73 73 2d 6a 73 63 72 69 70 74 2d 62 6c s:css-jscript-bl
7b00: 6f 63 6b 2d 73 74 61 74 69 63 20 28 74 65 73 74 ock-static (test
7b10: 3a 6a 73 2d 62 6c 6f 63 6b 20 2a 6a 61 76 61 2d :js-block *java-
7b20: 73 63 72 69 70 74 2d 6c 69 62 2a 29 29 0a 0a 28 script-lib*))..(
7b30: 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 63 73 define (tests:cs
7b40: 73 2d 6a 73 63 72 69 70 74 2d 62 6c 6f 63 6b 2d s-jscript-block-
7b50: 63 6f 6e 64 20 64 79 6e 61 6d 69 63 29 20 0a 20 cond dynamic) .
7b60: 20 20 20 20 20 28 69 66 20 28 65 71 75 61 6c 3f (if (equal?
7b70: 20 64 79 6e 61 6d 69 63 20 20 23 74 29 0a 20 20 dynamic #t).
7b80: 20 20 20 20 20 74 65 73 74 73 3a 63 73 73 2d 6a tests:css-j
7b90: 73 63 72 69 70 74 2d 62 6c 6f 63 6b 2d 64 79 6e script-block-dyn
7ba0: 61 6d 69 63 0a 20 20 20 20 20 20 20 74 65 73 74 amic. test
7bb0: 73 3a 63 73 73 2d 6a 73 63 72 69 70 74 2d 62 6c s:css-jscript-bl
7bc0: 6f 63 6b 2d 73 74 61 74 69 63 29 29 0a 0a 20 20 ock-static))..
7bd0: 20 20 20 20 20 0a 28 64 65 66 69 6e 65 20 28 74 .(define (t
7be0: 65 73 74 73 3a 72 75 6e 2d 72 65 63 6f 72 64 2d ests:run-record-
7bf0: 3e 74 65 73 74 2d 70 61 74 68 20 72 75 6e 20 6e >test-path run n
7c00: 75 6d 6b 65 79 73 29 0a 20 20 20 28 61 70 70 65 umkeys). (appe
7c10: 6e 64 20 28 74 61 6b 65 20 28 76 65 63 74 6f 72 nd (take (vector
7c20: 2d 3e 6c 69 73 74 20 72 75 6e 29 20 6e 75 6d 6b ->list run) numk
7c30: 65 79 73 29 0a 09 20 20 20 28 6c 69 73 74 20 28 eys).. (list (
7c40: 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 20 28 vector-ref run (
7c50: 2b 20 31 20 6e 75 6d 6b 65 79 73 29 29 29 29 29 + 1 numkeys)))))
7c60: 0a 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 ...(define (test
7c70: 73 3a 67 65 74 2d 72 65 73 74 2d 64 61 74 61 20 s:get-rest-data
7c80: 72 75 6e 73 20 68 65 61 64 65 72 20 6e 75 6d 6b runs header numk
7c90: 65 79 73 29 0a 20 20 20 28 6c 65 74 20 28 28 72 eys). (let ((r
7ca0: 65 73 68 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 esh (make-hash-t
7cb0: 61 62 6c 65 29 29 29 0a 20 20 20 28 66 6f 72 2d able))). (for-
7cc0: 65 61 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 each. (lambd
7cd0: 61 20 28 72 75 6e 29 0a 20 20 20 20 20 20 20 20 a (run).
7ce0: 28 6c 65 74 2a 20 28 28 72 75 6e 2d 69 64 20 28 (let* ((run-id (
7cf0: 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d db:get-value-by-
7d00: 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 header run heade
7d10: 72 20 22 69 64 22 29 29 0a 20 20 20 20 20 20 20 r "id")).
7d20: 20 20 20 20 20 20 20 20 28 72 75 6e 2d 64 69 72 (run-dir
7d30: 20 20 20 20 20 20 28 74 65 73 74 73 3a 72 75 6e (tests:run
7d40: 2d 72 65 63 6f 72 64 2d 3e 74 65 73 74 2d 70 61 -record->test-pa
7d50: 74 68 20 72 75 6e 20 6e 75 6d 6b 65 79 73 29 29 th run numkeys))
7d60: 0a 09 20 20 20 20 20 20 20 28 74 65 73 74 2d 64 .. (test-d
7d70: 61 74 61 20 20 20 20 28 72 6d 74 3a 67 65 74 2d ata (rmt:get-
7d80: 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 0a 09 09 tests-for-run...
7d90: 09 09 20 20 20 72 75 6e 2d 69 64 0a 20 20 20 20 .. run-id.
7da0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7db0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 22 "
7dc0: 25 22 20 20 20 20 20 20 20 3b 3b 20 74 65 73 74 %" ;; test
7dd0: 6e 61 6d 65 70 61 74 74 0a 09 09 09 09 20 20 20 namepatt.....
7de0: 27 28 29 20 20 20 20 20 20 20 20 3b 3b 20 73 74 '() ;; st
7df0: 61 74 65 73 0a 09 09 09 09 20 20 20 27 28 29 20 ates..... '()
7e00: 20 20 20 20 20 20 20 3b 3b 20 73 74 61 74 75 73 ;; status
7e10: 65 73 0a 09 09 09 09 20 20 20 23 66 20 20 20 20 es..... #f
7e20: 20 20 20 20 20 3b 3b 20 6f 66 66 73 65 74 0a 09 ;; offset..
7e30: 09 09 09 20 20 20 23 66 20 20 20 20 20 20 20 20 ... #f
7e40: 20 3b 3b 20 6e 75 6d 2d 74 6f 2d 67 65 74 0a 09 ;; num-to-get..
7e50: 09 09 09 20 20 20 23 66 20 20 20 20 20 20 20 20 ... #f
7e60: 20 3b 3b 20 68 69 64 65 2f 6e 6f 74 2d 68 69 64 ;; hide/not-hid
7e70: 65 0a 09 09 09 09 20 20 20 23 66 20 20 20 20 20 e..... #f
7e80: 20 20 20 20 3b 3b 20 73 6f 72 74 2d 62 79 0a 09 ;; sort-by..
7e90: 09 09 09 20 20 20 23 66 20 20 20 20 20 20 20 20 ... #f
7ea0: 20 3b 3b 20 73 6f 72 74 2d 6f 72 64 65 72 0a 09 ;; sort-order..
7eb0: 09 09 09 20 20 20 23 66 20 20 20 20 20 20 20 20 ... #f
7ec0: 20 3b 3b 20 27 73 68 6f 72 74 6c 69 73 74 20 20 ;; 'shortlist
7ed0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7ee0: 20 20 20 20 20 20 20 20 20 3b 3b 20 71 72 79 74 ;; qryt
7ef0: 79 70 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 ype.
7f00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7f10: 20 20 20 20 20 20 20 30 20 20 20 20 20 20 20 20 0
7f20: 20 3b 3b 20 6c 61 73 74 20 75 70 64 61 74 65 0a ;; last update.
7f30: 09 09 09 09 20 20 20 23 66 29 29 29 0a 20 20 20 .... #f))).
7f40: 20 20 20 20 20 20 20 20 20 0a 20 20 20 20 20 20 .
7f50: 20 20 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 (map (lamb
7f60: 64 61 20 28 74 65 73 74 29 0a 20 20 20 20 20 20 da (test).
7f70: 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 2a (let*
7f80: 20 28 28 74 65 73 74 2d 6e 61 6d 65 20 28 76 65 ((test-name (ve
7f90: 63 74 6f 72 2d 72 65 66 20 74 65 73 74 20 32 29 ctor-ref test 2)
7fa0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
7fb0: 20 20 20 20 20 20 20 20 20 20 28 74 65 73 74 2d (test-
7fc0: 68 74 6d 6c 2d 70 61 74 68 20 28 63 6f 6e 63 20 html-path (conc
7fd0: 28 76 65 63 74 6f 72 2d 72 65 66 20 74 65 73 74 (vector-ref test
7fe0: 20 31 30 29 20 22 2f 22 20 28 76 65 63 74 6f 72 10) "/" (vector
7ff0: 2d 72 65 66 20 74 65 73 74 20 31 33 29 29 29 0a -ref test 13))).
8000: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8010: 20 20 20 20 20 20 20 20 28 74 65 73 74 2d 69 74 (test-it
8020: 65 6d 20 28 63 6f 6e 63 20 74 65 73 74 2d 6e 61 em (conc test-na
8030: 6d 65 20 22 3a 22 20 28 76 65 63 74 6f 72 2d 72 me ":" (vector-r
8040: 65 66 20 74 65 73 74 20 31 31 29 29 29 0a 20 20 ef test 11))).
8050: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8060: 20 20 20 20 20 20 28 74 65 73 74 2d 73 74 61 74 (test-stat
8070: 75 73 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 us (vector-ref t
8080: 65 73 74 20 34 29 29 29 0a 20 20 20 20 20 20 20 est 4))).
8090: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
80a0: 20 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 .
80b0: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 68 61 73 (if (not (has
80c0: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
80d0: 75 6c 74 20 72 65 73 68 20 74 65 73 74 2d 6e 61 ult resh test-na
80e0: 6d 65 20 20 23 66 29 29 0a 20 20 20 20 20 20 20 me #f)).
80f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
8100: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
8110: 72 65 73 68 20 74 65 73 74 2d 6e 61 6d 65 20 20 resh test-name
8120: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
8130: 65 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 e))).
8140: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 68 (if (not (h
8150: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
8160: 66 61 75 6c 74 20 28 68 61 73 68 2d 74 61 62 6c fault (hash-tabl
8170: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 72 65 e-ref/default re
8180: 73 68 20 74 65 73 74 2d 6e 61 6d 65 20 20 23 66 sh test-name #f
8190: 29 20 20 74 65 73 74 2d 69 74 65 6d 20 20 23 66 ) test-item #f
81a0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
81b0: 20 20 20 20 20 20 20 20 20 20 28 68 61 73 68 2d (hash-
81c0: 74 61 62 6c 65 2d 73 65 74 21 20 28 68 61 73 68 table-set! (hash
81d0: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
81e0: 6c 74 20 72 65 73 68 20 74 65 73 74 2d 6e 61 6d lt resh test-nam
81f0: 65 20 20 23 66 29 20 74 65 73 74 2d 69 74 65 6d e #f) test-item
8200: 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 (make-hash-ta
8210: 62 6c 65 29 29 29 20 0a 20 20 20 20 20 20 20 20 ble))) .
8220: 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 (hash-tab
8230: 6c 65 2d 73 65 74 21 20 20 28 68 61 73 68 2d 74 le-set! (hash-t
8240: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
8250: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
8260: 2f 64 65 66 61 75 6c 74 20 72 65 73 68 20 74 65 /default resh te
8270: 73 74 2d 6e 61 6d 65 20 20 23 66 29 20 74 65 73 st-name #f) tes
8280: 74 2d 69 74 65 6d 20 23 66 29 20 72 75 6e 2d 69 t-item #f) run-i
8290: 64 20 28 6c 69 73 74 20 74 65 73 74 2d 73 74 61 d (list test-sta
82a0: 74 75 73 20 74 65 73 74 2d 68 74 6d 6c 2d 70 61 tus test-html-pa
82b0: 74 68 29 29 29 29 20 0a 20 20 20 20 20 20 20 20 th)))) .
82c0: 74 65 73 74 2d 64 61 74 61 29 29 29 0a 20 20 20 test-data))).
82d0: 20 20 20 72 75 6e 73 29 0a 20 20 20 72 65 73 68 runs). resh
82e0: 29 29 0a 0a 0a 3b 3b 20 74 65 73 74 73 3a 67 65 ))...;; tests:ge
82f0: 6e 72 61 74 65 20 64 61 73 68 62 6f 61 72 64 20 nrate dashboard
8300: 62 6f 64 79 20 0a 3b 3b 0a 0a 28 64 65 66 69 6e body .;;..(defin
8310: 65 20 28 74 65 73 74 73 3a 64 61 73 68 62 6f 61 e (tests:dashboa
8320: 72 64 2d 62 6f 64 79 20 70 61 67 65 20 70 67 2d rd-body page pg-
8330: 73 69 7a 65 20 6b 65 79 73 20 6e 75 6d 6b 65 79 size keys numkey
8340: 73 20 20 74 6f 74 61 6c 2d 72 75 6e 73 20 6c 69 s total-runs li
8350: 6e 6b 74 72 65 65 20 61 72 65 61 2d 6e 61 6d 65 nktree area-name
8360: 20 67 65 74 2d 70 72 65 76 2d 6c 69 6e 6b 73 20 get-prev-links
8370: 67 65 74 2d 6e 65 78 74 2d 6c 69 6e 6b 73 20 66 get-next-links f
8380: 6c 61 67 20 72 75 6e 2d 70 61 74 74 20 74 61 72 lag run-patt tar
8390: 67 65 74 2d 70 61 74 74 29 0a 20 20 28 6c 65 74 get-patt). (let
83a0: 2a 20 28 28 73 74 61 72 74 20 28 2a 20 70 61 67 * ((start (* pag
83b0: 65 20 70 67 2d 73 69 7a 65 29 29 20 0a 09 09 09 e pg-size)) ....
83c0: 09 09 3b 28 72 75 6e 73 64 61 74 20 20 20 28 72 ..;(runsdat (r
83d0: 6d 74 3a 67 65 74 2d 72 75 6e 73 20 22 25 22 20 mt:get-runs "%"
83e0: 70 67 2d 73 69 7a 65 20 73 74 61 72 74 20 28 6d pg-size start (m
83f0: 61 70 20 28 6c 61 6d 62 64 61 20 28 78 29 28 6c ap (lambda (x)(l
8400: 69 73 74 20 78 20 22 25 22 29 29 20 6b 65 79 73 ist x "%")) keys
8410: 29 29 29 0a 20 20 20 20 20 20 20 20 20 28 72 75 ))). (ru
8420: 6e 73 64 61 74 20 20 20 28 72 6d 74 3a 67 65 74 nsdat (rmt:get
8430: 2d 72 75 6e 73 2d 62 79 2d 70 61 74 74 20 20 6b -runs-by-patt k
8440: 65 79 73 20 72 75 6e 2d 70 61 74 74 20 74 61 72 eys run-patt tar
8450: 67 65 74 2d 70 61 74 74 20 73 74 61 72 74 20 70 get-patt start p
8460: 67 2d 73 69 7a 65 20 23 66 20 30 20 73 6f 72 74 g-size #f 0 sort
8470: 2d 6f 72 64 65 72 3a 20 22 64 65 73 63 22 29 29 -order: "desc"))
8480: 0a 09 09 09 09 09 3b 20 64 62 3a 67 65 74 2d 72 ......; db:get-r
8490: 75 6e 73 2d 62 79 2d 70 61 74 74 20 20 20 6b 65 uns-by-patt ke
84a0: 79 73 20 72 75 6e 6e 61 6d 65 70 61 74 74 20 74 ys runnamepatt t
84b0: 61 72 67 70 61 74 74 20 6f 66 66 73 65 74 20 6c argpatt offset l
84c0: 69 6d 69 74 20 66 69 65 6c 64 73 20 6c 61 73 74 imit fields last
84d0: 2d 75 70 64 61 74 65 20 20 20 0a 09 20 28 68 65 -update .. (he
84e0: 61 64 65 72 20 20 20 20 28 76 65 63 74 6f 72 2d ader (vector-
84f0: 72 65 66 20 72 75 6e 73 64 61 74 20 30 29 29 0a ref runsdat 0)).
8500: 09 20 28 72 75 6e 73 20 20 20 20 20 20 28 76 65 . (runs (ve
8510: 63 74 6f 72 2d 72 65 66 20 72 75 6e 73 64 61 74 ctor-ref runsdat
8520: 20 31 29 29 0a 20 20 20 20 20 20 20 20 20 28 63 1)). (c
8530: 74 72 20 30 29 0a 20 20 20 20 20 20 20 20 20 28 tr 0). (
8540: 74 65 73 74 2d 72 75 6e 73 2d 68 61 73 68 20 28 test-runs-hash (
8550: 74 65 73 74 73 3a 67 65 74 2d 72 65 73 74 2d 64 tests:get-rest-d
8560: 61 74 61 20 72 75 6e 73 20 68 65 61 64 65 72 20 ata runs header
8570: 6e 75 6d 6b 65 79 73 29 29 0a 20 20 20 20 20 20 numkeys)).
8580: 20 20 20 28 74 65 73 74 2d 6c 69 73 74 20 28 68 (test-list (h
8590: 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 74 ash-table-keys t
85a0: 65 73 74 2d 72 75 6e 73 2d 68 61 73 68 29 29 29 est-runs-hash)))
85b0: 20 0a 20 20 20 20 0a 20 20 20 20 28 73 3a 68 74 . . (s:ht
85c0: 6d 6c 20 74 65 73 74 73 3a 63 73 73 2d 6a 73 63 ml tests:css-jsc
85d0: 72 69 70 74 2d 62 6c 6f 63 6b 20 28 74 65 73 74 ript-block (test
85e0: 73 3a 63 73 73 2d 6a 73 63 72 69 70 74 2d 62 6c s:css-jscript-bl
85f0: 6f 63 6b 2d 63 6f 6e 64 20 66 6c 61 67 29 0a 09 ock-cond flag)..
8600: 20 20 20 20 28 73 3a 74 69 74 6c 65 20 22 53 75 (s:title "Su
8610: 6d 6d 61 72 79 20 66 6f 72 20 22 20 61 72 65 61 mmary for " area
8620: 2d 6e 61 6d 65 29 0a 09 20 20 20 20 28 73 3a 62 -name).. (s:b
8630: 6f 64 79 20 27 6f 6e 6c 6f 61 64 20 22 61 64 64 ody 'onload "add
8640: 45 76 65 6e 74 73 28 29 3b 22 0a 09 09 20 20 20 Events();"...
8650: 20 28 67 65 74 2d 70 72 65 76 2d 6c 69 6e 6b 73 (get-prev-links
8660: 20 70 61 67 65 20 6c 69 6e 6b 74 72 65 65 29 0a page linktree).
8670: 09 09 20 20 20 20 28 67 65 74 2d 6e 65 78 74 2d .. (get-next-
8680: 6c 69 6e 6b 73 20 70 61 67 65 20 6c 69 6e 6b 74 links page linkt
8690: 72 65 65 20 74 6f 74 61 6c 2d 72 75 6e 73 29 0a ree total-runs).
86a0: 09 09 20 20 20 20 0a 09 09 20 20 20 20 28 73 3a .. ... (s:
86b0: 68 31 20 22 53 75 6d 6d 61 72 79 20 66 6f 72 20 h1 "Summary for
86c0: 22 20 61 72 65 61 2d 6e 61 6d 65 29 0a 09 09 20 " area-name)...
86d0: 20 20 20 28 73 3a 68 33 20 22 46 69 6c 74 65 72 (s:h3 "Filter
86e0: 22 20 29 0a 09 09 20 20 20 20 28 73 3a 69 6e 70 " )... (s:inp
86f0: 75 74 20 27 74 79 70 65 20 22 74 65 78 74 22 20 ut 'type "text"
8700: 20 27 6e 61 6d 65 20 22 74 65 73 74 6e 61 6d 65 'name "testname
8710: 22 20 27 69 64 20 22 74 65 73 74 6e 61 6d 65 22 " 'id "testname"
8720: 20 27 6c 65 6e 67 74 68 20 22 33 30 22 20 27 6f 'length "30" 'o
8730: 6e 6b 65 79 75 70 20 22 66 69 6c 74 65 72 73 6f nkeyup "filterso
8740: 6d 65 28 29 22 29 0a 09 09 20 20 20 20 3b 3b 20 me()")... ;;
8750: 74 6f 70 20 6c 69 73 74 0a 09 09 20 20 20 20 0a top list... .
8760: 09 09 20 20 20 20 28 73 3a 74 61 62 6c 65 20 27 .. (s:table '
8770: 69 64 20 22 4c 69 6e 6b 65 64 4c 69 73 74 31 22 id "LinkedList1"
8780: 20 27 62 6f 72 64 65 72 20 22 31 22 20 27 63 65 'border "1" 'ce
8790: 6c 6c 73 70 61 63 69 6e 67 20 30 0a 09 09 09 20 llspacing 0....
87a0: 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 (map (lambda
87b0: 20 28 6b 65 79 29 0a 09 09 09 09 20 20 20 20 28 (key)..... (
87c0: 6c 65 74 2a 20 28 28 72 65 73 20 28 73 3a 74 72 let* ((res (s:tr
87d0: 20 27 63 6c 61 73 73 20 22 73 6f 6d 65 74 68 69 'class "somethi
87e0: 6e 67 22 20 0a 09 09 09 09 09 09 20 20 20 20 20 ng" .......
87f0: 20 28 73 3a 74 68 20 6b 65 79 20 29 0a 09 09 09 (s:th key )....
8800: 09 09 09 20 20 20 20 20 20 28 6d 61 70 20 28 6c ... (map (l
8810: 61 6d 62 64 61 20 28 72 75 6e 29 0a 09 09 09 09 ambda (run).....
8820: 09 09 09 20 20 20 20 20 28 73 3a 74 68 20 20 28 ... (s:th (
8830: 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 20 63 vector-ref run c
8840: 74 72 29 29 29 0a 09 09 09 09 09 09 09 20 20 20 tr)))........
8850: 72 75 6e 73 29 29 29 29 0a 09 09 09 09 20 20 20 runs)))).....
8860: 20 20 20 28 73 65 74 21 20 63 74 72 20 28 2b 20 (set! ctr (+
8870: 63 74 72 20 31 29 29 0a 09 09 09 09 20 20 20 20 ctr 1)).....
8880: 20 20 72 65 73 29 29 0a 09 09 09 09 20 20 6b 65 res))..... ke
8890: 79 73 29 0a 09 09 09 20 20 20 20 20 28 73 3a 74 ys).... (s:t
88a0: 72 0a 09 09 09 20 20 20 20 20 20 28 73 3a 74 68 r.... (s:th
88b0: 20 22 52 75 6e 20 4e 61 6d 65 22 29 0a 09 09 09 "Run Name")....
88c0: 20 20 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 (map (lamb
88d0: 64 61 20 28 72 75 6e 29 0a 09 09 09 09 20 20 20 da (run).....
88e0: 20 20 28 73 3a 74 68 20 28 64 62 3a 67 65 74 2d (s:th (db:get-
88f0: 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 value-by-header
8900: 72 75 6e 20 68 65 61 64 65 72 20 22 72 75 6e 6e run header "runn
8910: 61 6d 65 22 29 29 29 0a 09 09 09 09 20 20 20 72 ame")))..... r
8920: 75 6e 73 29 29 0a 09 09 09 20 20 20 20 20 0a 09 uns)).... ..
8930: 09 09 20 20 20 20 20 28 6d 61 70 20 28 6c 61 6d .. (map (lam
8940: 62 64 61 20 28 74 65 73 74 2d 6e 61 6d 65 29 0a bda (test-name).
8950: 09 09 09 09 20 20 20 20 28 6c 65 74 2a 20 28 28 .... (let* ((
8960: 69 74 65 6d 2d 68 61 73 68 20 28 68 61 73 68 2d item-hash (hash-
8970: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
8980: 74 20 74 65 73 74 2d 72 75 6e 73 2d 68 61 73 68 t test-runs-hash
8990: 20 74 65 73 74 2d 6e 61 6d 65 20 20 23 66 29 29 test-name #f))
89a0: 0a 09 09 09 09 09 20 20 20 28 69 74 65 6d 2d 6b ...... (item-k
89b0: 65 79 73 20 28 73 6f 72 74 20 28 68 61 73 68 2d eys (sort (hash-
89c0: 74 61 62 6c 65 2d 6b 65 79 73 20 69 74 65 6d 2d table-keys item-
89d0: 68 61 73 68 29 20 73 74 72 69 6e 67 3c 3d 3f 29 hash) string<=?)
89e0: 29 29 20 0a 09 09 09 09 20 20 20 20 20 20 28 6d )) ..... (m
89f0: 61 70 20 28 6c 61 6d 62 64 61 20 28 69 74 65 6d ap (lambda (item
8a00: 2d 6e 61 6d 65 29 20 20 0a 20 20 09 09 20 20 20 -name) . ..
8a10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8a20: 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 (let*
8a30: 28 28 72 65 73 20 28 73 3a 74 72 20 20 27 63 6c ((res (s:tr 'cl
8a40: 61 73 73 20 69 74 65 6d 2d 6e 61 6d 65 0a 09 09 ass item-name...
8a50: 09 09 09 09 09 09 28 73 3a 74 64 20 20 69 74 65 ......(s:td ite
8a60: 6d 2d 6e 61 6d 65 20 27 63 6c 61 73 73 20 22 74 m-name 'class "t
8a70: 65 73 74 22 20 29 0a 09 09 09 09 09 09 09 09 28 est" ).........(
8a80: 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 72 75 6e map (lambda (run
8a90: 29 0a 09 09 09 09 09 09 09 09 20 20 20 20 20 20 ).........
8aa0: 20 28 6c 65 74 2a 20 28 28 72 75 6e 2d 74 65 73 (let* ((run-tes
8ab0: 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 t (hash-table-re
8ac0: 66 2f 64 65 66 61 75 6c 74 20 69 74 65 6d 2d 68 f/default item-h
8ad0: 61 73 68 20 69 74 65 6d 2d 6e 61 6d 65 20 20 23 ash item-name #
8ae0: 66 29 29 0a 09 09 09 09 09 09 09 09 09 20 20 20 f))..........
8af0: 20 20 20 28 72 75 6e 2d 69 64 20 28 64 62 3a 67 (run-id (db:g
8b00: 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 et-value-by-head
8b10: 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 69 er run header "i
8b20: 64 22 29 29 0a 09 09 09 09 09 09 09 09 09 20 20 d"))..........
8b30: 20 20 20 20 28 72 65 73 75 6c 74 20 28 68 61 73 (result (has
8b40: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
8b50: 75 6c 74 20 72 75 6e 2d 74 65 73 74 20 72 75 6e ult run-test run
8b60: 2d 69 64 20 22 6e 2f 61 22 29 29 0a 09 09 09 09 -id "n/a")).....
8b70: 09 3b 28 72 65 6c 61 74 69 76 65 2d 70 61 74 68 .;(relative-path
8b80: 20 28 67 65 74 2d 72 65 6c 61 74 69 76 65 2d 70 (get-relative-p
8b90: 61 74 68 29 29 20 0a 09 09 09 09 09 09 09 09 09 ath)) ..........
8ba0: 20 20 20 20 20 20 28 73 74 61 74 75 73 20 28 69 (status (i
8bb0: 66 20 28 73 74 72 69 6e 67 3f 20 72 65 73 75 6c f (string? resul
8bc0: 74 29 0a 09 09 09 09 09 09 09 09 09 09 09 20 20 t)............
8bd0: 72 65 73 75 6c 74 0a 09 09 09 09 09 09 09 09 09 result..........
8be0: 09 09 20 20 28 63 61 72 20 72 65 73 75 6c 74 29 .. (car result)
8bf0: 29 29 0a 09 09 09 09 09 09 09 09 09 20 20 20 20 ))..........
8c00: 20 20 28 6c 69 6e 6b 20 28 69 66 20 28 73 74 72 (link (if (str
8c10: 69 6e 67 3f 20 72 65 73 75 6c 74 29 0a 09 09 09 ing? result)....
8c20: 09 09 09 09 09 09 09 09 72 65 73 75 6c 74 0a 09 ........result..
8c30: 09 09 09 09 09 09 09 09 09 09 28 69 66 20 28 65 ..........(if (e
8c40: 71 75 61 6c 3f 20 66 6c 61 67 20 23 74 29 20 0a qual? flag #t) .
8c50: 09 09 09 09 09 09 09 09 09 09 09 20 20 20 20 28 ........... (
8c60: 73 3a 61 20 28 63 61 72 20 72 65 73 75 6c 74 29 s:a (car result)
8c70: 20 27 68 72 65 66 20 28 63 6f 6e 63 20 22 2e 2f 'href (conc "./
8c80: 74 65 73 74 5f 6c 6f 67 3f 72 75 6e 69 64 3d 22 test_log?runid="
8c90: 20 72 75 6e 2d 69 64 20 22 26 74 65 73 74 6e 61 run-id "&testna
8ca0: 6d 65 3d 22 20 20 69 74 65 6d 2d 6e 61 6d 65 20 me=" item-name
8cb0: 29 29 0a 09 09 09 09 09 09 09 09 09 09 09 20 20 ))............
8cc0: 20 20 28 73 3a 61 20 28 63 61 72 20 72 65 73 75 (s:a (car resu
8cd0: 6c 74 29 20 27 68 72 65 66 20 28 73 74 72 69 6e lt) 'href (strin
8ce0: 67 2d 73 75 62 73 74 69 74 75 74 65 20 20 28 63 g-substitute (c
8cf0: 6f 6e 63 20 6c 69 6e 6b 74 72 65 65 20 22 2f 22 onc linktree "/"
8d00: 29 20 20 22 22 20 28 63 61 64 72 20 72 65 73 75 ) "" (cadr resu
8d10: 6c 74 29 20 20 22 2d 22 29 29 29 29 29 29 0a 09 lt) "-"))))))..
8d20: 09 09 09 09 09 09 09 09 20 28 73 3a 74 64 20 20 ........ (s:td
8d30: 6c 69 6e 6b 20 27 63 6c 61 73 73 20 73 74 61 74 link 'class stat
8d40: 75 73 29 29 29 0a 09 09 09 09 09 09 09 09 20 20 us))).........
8d50: 20 20 20 72 75 6e 73 29 29 29 29 0a 09 09 09 09 runs)))).....
8d60: 09 20 20 20 20 20 20 20 72 65 73 29 29 0a 09 09 . res))...
8d70: 09 09 09 20 20 20 69 74 65 6d 2d 6b 65 79 73 29 ... item-keys)
8d80: 29 29 0a 09 09 09 09 20 20 74 65 73 74 2d 6c 69 ))..... test-li
8d90: 73 74 29 29 29 29 29 29 20 0a 0a 3b 3b 20 28 74 st)))))) ..;; (t
8da0: 65 73 74 73 3a 63 72 65 61 74 65 2d 68 74 6d 6c ests:create-html
8db0: 2d 74 72 65 65 20 22 74 65 73 74 2d 69 6e 64 65 -tree "test-inde
8dc0: 78 2e 68 74 6d 6c 22 29 0a 3b 3b 0a 28 64 65 66 x.html").;;.(def
8dd0: 69 6e 65 20 28 74 65 73 74 73 3a 63 72 65 61 74 ine (tests:creat
8de0: 65 2d 68 74 6d 6c 2d 74 72 65 65 20 6f 75 74 66 e-html-tree outf
8df0: 29 0a 20 20 28 6c 65 74 2a 20 28 28 6c 6f 63 6b ). (let* ((lock
8e00: 66 69 6c 65 20 20 28 63 6f 6e 63 20 6f 75 74 66 file (conc outf
8e10: 20 22 2e 6c 6f 63 6b 22 29 29 0a 09 20 28 72 75 ".lock")).. (ru
8e20: 6e 73 2d 74 6f 2d 70 72 6f 63 65 73 73 20 27 28 ns-to-process '(
8e30: 29 29 0a 20 20 20 20 20 20 20 20 20 28 6c 69 6e )). (lin
8e40: 6b 74 72 65 65 20 20 28 63 6f 6d 6d 6f 6e 3a 67 ktree (common:g
8e50: 65 74 2d 6c 69 6e 6b 74 72 65 65 29 29 0a 20 20 et-linktree)).
8e60: 20 20 20 20 20 20 20 28 61 72 65 61 2d 6e 61 6d (area-nam
8e70: 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 74 65 e (common:get-te
8e80: 73 74 73 75 69 74 65 2d 6e 61 6d 65 29 29 0a 09 stsuite-name))..
8e90: 20 28 6b 65 79 73 20 20 20 20 20 20 28 72 6d 74 (keys (rmt
8ea0: 3a 67 65 74 2d 6b 65 79 73 29 29 0a 09 20 28 6e :get-keys)).. (n
8eb0: 75 6d 6b 65 79 73 20 20 20 28 6c 65 6e 67 74 68 umkeys (length
8ec0: 20 6b 65 79 73 29 29 0a 20 20 20 20 20 20 20 20 keys)).
8ed0: 20 28 72 75 6e 2d 70 61 74 74 20 28 6f 72 20 28 (run-patt (or (
8ee0: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 args:get-arg "-r
8ef0: 75 6e 2d 70 61 74 74 22 29 0a 09 09 20 20 20 20 un-patt")...
8f00: 20 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 (args:get-arg
8f10: 20 22 2d 72 75 6e 6e 61 6d 65 22 29 0a 09 09 20 "-runname")...
8f20: 20 20 20 20 20 20 22 25 22 29 29 0a 20 20 20 20 "%")).
8f30: 20 20 20 20 20 28 74 61 72 67 65 74 20 28 6f 72 (target (or
8f40: 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 (args:get-arg
8f50: 22 2d 74 61 72 67 65 74 2d 70 61 74 74 22 29 20 "-target-patt")
8f60: 0a 09 09 20 20 20 20 20 20 28 61 72 67 73 3a 67 ... (args:g
8f70: 65 74 2d 61 72 67 20 22 2d 74 61 72 67 65 74 22 et-arg "-target"
8f80: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
8f90: 20 20 20 20 20 20 20 20 22 25 22 29 29 0a 20 20 "%")).
8fa0: 20 20 20 20 20 20 20 28 74 61 72 67 6c 69 73 74 (targlist
8fb0: 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 74 (string-split t
8fc0: 61 72 67 65 74 20 22 2f 22 29 29 0a 20 20 20 20 arget "/")).
8fd0: 20 20 20 20 20 28 6e 75 6d 74 61 72 67 20 20 28 (numtarg (
8fe0: 6c 65 6e 67 74 68 20 74 61 72 67 6c 69 73 74 29 length targlist)
8ff0: 29 20 20 0a 20 20 20 20 20 20 20 20 20 28 74 61 ) . (ta
9000: 72 67 74 77 65 61 6b 65 64 20 28 69 66 20 28 3e rgtweaked (if (>
9010: 20 6e 75 6d 6b 65 79 73 20 6e 75 6d 74 61 72 67 numkeys numtarg
9020: 29 0a 09 09 09 20 20 28 61 70 70 65 6e 64 20 74 ).... (append t
9030: 61 72 67 6c 69 73 74 20 28 6d 61 6b 65 2d 6c 69 arglist (make-li
9040: 73 74 20 28 2d 20 6e 75 6d 6b 65 79 73 20 6e 75 st (- numkeys nu
9050: 6d 74 61 72 67 29 20 22 25 22 29 29 0a 09 09 09 mtarg) "%"))....
9060: 20 20 74 61 72 67 6c 69 73 74 29 29 0a 20 20 20 targlist)).
9070: 20 20 20 20 20 20 28 74 61 72 67 65 74 2d 70 61 (target-pa
9080: 74 74 20 28 73 74 72 69 6e 67 2d 6a 6f 69 6e 20 tt (string-join
9090: 74 61 72 67 74 77 65 61 6b 65 64 20 22 2f 22 29 targtweaked "/")
90a0: 29 0a 09 09 09 09 09 3b 28 74 6f 74 61 6c 2d 72 )......;(total-r
90b0: 75 6e 73 20 20 28 72 6d 74 3a 67 65 74 2d 6e 75 uns (rmt:get-nu
90c0: 6d 2d 72 75 6e 73 20 22 25 22 29 29 20 3b 3b 74 m-runs "%")) ;;t
90d0: 68 69 73 20 6e 65 65 64 73 20 74 6f 20 62 65 20 his needs to be
90e0: 63 68 61 6e 67 65 64 20 74 6f 20 66 69 6c 74 65 changed to filte
90f0: 72 20 62 79 20 74 61 72 67 65 74 0a 09 20 28 74 r by target.. (t
9100: 6f 74 61 6c 2d 72 75 6e 73 20 28 72 6d 74 3a 67 otal-runs (rmt:g
9110: 65 74 2d 72 75 6e 73 2d 63 6e 74 2d 62 79 2d 70 et-runs-cnt-by-p
9120: 61 74 74 20 72 75 6e 2d 70 61 74 74 20 74 61 72 att run-patt tar
9130: 67 65 74 2d 70 61 74 74 20 6b 65 79 73 20 29 29 get-patt keys ))
9140: 20 0a 20 20 20 20 20 20 20 20 20 28 70 67 2d 73 . (pg-s
9150: 69 7a 65 20 31 30 29 29 0a 20 20 20 20 28 69 66 ize 10)). (if
9160: 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 2d (common:simple-
9170: 66 69 6c 65 2d 6c 6f 63 6b 20 6c 6f 63 6b 66 69 file-lock lockfi
9180: 6c 65 29 0a 20 20 20 20 20 20 20 20 28 62 65 67 le). (beg
9190: 69 6e 0a 09 09 09 09 09 3b 28 70 72 69 6e 74 20 in......;(print
91a0: 74 6f 74 61 6c 2d 72 75 6e 73 29 20 20 20 20 0a total-runs) .
91b0: 09 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 70 . (let loop ((p
91c0: 61 67 65 20 30 29 29 0a 09 20 20 20 20 28 6c 65 age 0)).. (le
91d0: 74 2a 20 28 28 6f 75 70 20 20 20 20 20 20 20 20 t* ((oup
91e0: 20 20 20 20 28 6f 70 65 6e 2d 6f 75 74 70 75 74 (open-output
91f0: 2d 66 69 6c 65 20 28 6f 72 20 6f 75 74 66 20 28 -file (or outf (
9200: 63 6f 6e 63 20 6c 69 6e 6b 74 72 65 65 20 22 2f conc linktree "/
9210: 70 61 67 65 22 20 70 61 67 65 20 22 2e 68 74 6d page" page ".htm
9220: 6c 22 29 29 29 29 0a 09 09 20 20 20 28 67 65 74 l"))))... (get
9230: 2d 70 72 65 76 2d 6c 69 6e 6b 73 20 28 6c 61 6d -prev-links (lam
9240: 62 64 61 20 28 70 61 67 65 20 6c 69 6e 6b 74 72 bda (page linktr
9250: 65 65 20 29 20 20 20 0a 09 09 09 09 20 20 20 20 ee ) .....
9260: 20 28 6c 65 74 2a 20 28 28 6c 69 6e 6b 20 20 28 (let* ((link (
9270: 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 70 61 67 if (not (eq? pag
9280: 65 20 30 29 29 0a 09 09 09 09 09 09 20 20 20 20 e 0)).......
9290: 20 20 20 28 73 3a 61 20 22 26 6c 74 3b 26 6c 74 (s:a "<<
92a0: 3b 70 72 65 76 22 20 27 68 72 65 66 20 28 63 6f ;prev" 'href (co
92b0: 6e 63 20 20 22 70 61 67 65 22 20 28 2d 20 70 61 nc "page" (- pa
92c0: 67 65 20 31 29 20 22 2e 68 74 6d 6c 22 29 29 0a ge 1) ".html")).
92d0: 09 09 09 09 09 09 20 20 20 20 20 20 20 28 73 3a ...... (s:
92e0: 61 20 22 22 20 27 68 72 65 66 20 28 63 6f 6e 63 a "" 'href (conc
92f0: 20 20 20 22 70 61 67 65 22 20 20 70 61 67 65 20 "page" page
9300: 22 2e 68 74 6d 6c 22 29 29 29 29 29 0a 09 09 09 ".html")))))....
9310: 09 20 20 20 20 20 20 20 6c 69 6e 6b 29 29 29 0a . link))).
9320: 09 09 20 20 20 28 67 65 74 2d 6e 65 78 74 2d 6c .. (get-next-l
9330: 69 6e 6b 73 20 28 6c 61 6d 62 64 61 20 28 70 61 inks (lambda (pa
9340: 67 65 20 6c 69 6e 6b 74 72 65 65 20 74 6f 74 61 ge linktree tota
9350: 6c 2d 72 75 6e 73 29 20 20 20 0a 09 09 09 09 20 l-runs) .....
9360: 20 20 20 20 28 6c 65 74 2a 20 28 28 6c 69 6e 6b (let* ((link
9370: 20 20 28 69 66 20 28 3e 20 74 6f 74 61 6c 2d 72 (if (> total-r
9380: 75 6e 73 20 28 2b 20 31 30 20 28 2a 20 70 61 67 uns (+ 10 (* pag
9390: 65 20 70 67 2d 73 69 7a 65 29 29 29 0a 09 09 09 e pg-size)))....
93a0: 09 09 09 20 20 20 20 20 20 20 28 73 3a 61 20 22 ... (s:a "
93b0: 6e 65 78 74 26 67 74 3b 26 67 74 3b 22 20 27 68 next>>" 'h
93c0: 72 65 66 20 28 63 6f 6e 63 20 20 22 70 61 67 65 ref (conc "page
93d0: 22 20 20 28 2b 20 70 61 67 65 20 31 29 20 22 2e " (+ page 1) ".
93e0: 68 74 6d 6c 22 29 29 0a 09 09 09 09 09 09 20 20 html")).......
93f0: 20 20 20 20 20 28 73 3a 61 20 22 22 20 27 68 72 (s:a "" 'hr
9400: 65 66 20 28 63 6f 6e 63 20 20 20 22 70 61 67 65 ef (conc "page
9410: 22 20 70 61 67 65 20 20 22 2e 68 74 6d 6c 22 29 " page ".html")
9420: 29 29 29 29 0a 09 09 09 09 20 20 20 20 20 20 20 )))).....
9430: 6c 69 6e 6b 29 29 29 20 29 0a 09 20 20 20 20 20 link))) )..
9440: 20 28 70 72 69 6e 74 20 22 74 6f 74 61 6c 20 72 (print "total r
9450: 75 6e 73 3a 20 22 20 74 6f 74 61 6c 2d 72 75 6e uns: " total-run
9460: 73 29 20 0a 09 20 20 20 20 20 20 28 73 3a 6f 75 s) .. (s:ou
9470: 74 70 75 74 2d 6e 65 77 0a 09 20 20 20 20 20 20 tput-new..
9480: 20 6f 75 70 0a 09 20 20 20 20 20 20 20 28 74 65 oup.. (te
9490: 73 74 73 3a 64 61 73 68 62 6f 61 72 64 2d 62 6f sts:dashboard-bo
94a0: 64 79 20 70 61 67 65 20 70 67 2d 73 69 7a 65 20 dy page pg-size
94b0: 6b 65 79 73 20 6e 75 6d 6b 65 79 73 20 74 6f 74 keys numkeys tot
94c0: 61 6c 2d 72 75 6e 73 20 6c 69 6e 6b 74 72 65 65 al-runs linktree
94d0: 20 61 72 65 61 2d 6e 61 6d 65 20 67 65 74 2d 70 area-name get-p
94e0: 72 65 76 2d 6c 69 6e 6b 73 20 67 65 74 2d 6e 65 rev-links get-ne
94f0: 78 74 2d 6c 69 6e 6b 73 20 23 66 20 72 75 6e 2d xt-links #f run-
9500: 70 61 74 74 20 74 61 72 67 65 74 2d 70 61 74 74 patt target-patt
9510: 29 29 20 3b 3b 20 75 70 64 61 74 65 20 74 68 69 )) ;; update thi
9520: 73 20 66 75 6e 63 74 69 6f 6e 0a 09 20 20 20 20 s function..
9530: 20 20 28 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d (close-output-
9540: 70 6f 72 74 20 6f 75 70 29 0a 09 09 09 09 09 3b port oup)......;
9550: 20 28 73 65 74 21 20 70 61 67 65 20 28 2b 20 31 (set! page (+ 1
9560: 20 70 61 67 65 29 29 0a 09 20 20 20 20 20 20 28 page)).. (
9570: 69 66 20 28 3e 20 74 6f 74 61 6c 2d 72 75 6e 73 if (> total-runs
9580: 20 28 2a 20 28 2b 20 31 20 70 61 67 65 29 20 70 (* (+ 1 page) p
9590: 67 2d 73 69 7a 65 29 29 0a 09 09 20 20 28 6c 6f g-size))... (lo
95a0: 6f 70 20 28 2b 20 31 20 20 70 61 67 65 29 29 29 op (+ 1 page)))
95b0: 29 29 0a 09 20 20 28 63 6f 6d 6d 6f 6e 3a 73 69 )).. (common:si
95c0: 6d 70 6c 65 2d 66 69 6c 65 2d 72 65 6c 65 61 73 mple-file-releas
95d0: 65 2d 6c 6f 63 6b 20 6c 6f 63 6b 66 69 6c 65 29 e-lock lockfile)
95e0: 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 64 65 )..(begin.. (de
95f0: 62 75 67 2d 70 72 69 6e 74 20 30 20 2a 64 65 66 bug-print 0 *def
9600: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
9610: 46 61 69 6c 65 64 20 74 6f 20 67 65 74 20 6c 6f Failed to get lo
9620: 63 6b 20 6f 6e 20 66 69 6c 65 20 6f 75 74 66 2c ck on file outf,
9630: 20 6c 6f 63 6b 66 69 6c 65 3a 20 22 20 6c 6f 63 lockfile: " loc
9640: 6b 66 69 6c 65 29 20 23 66 29 29 29 29 0a 0a 0a kfile) #f))))...
9650: 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 72 (define (tests:r
9660: 65 61 64 6c 69 6e 65 73 20 66 69 6c 65 6e 61 6d eadlines filenam
9670: 65 29 0a 20 20 28 63 61 6c 6c 2d 77 69 74 68 2d e). (call-with-
9680: 69 6e 70 75 74 2d 66 69 6c 65 20 66 69 6c 65 6e input-file filen
9690: 61 6d 65 0a 20 20 20 20 28 6c 61 6d 62 64 61 20 ame. (lambda
96a0: 28 70 29 0a 20 20 20 20 20 20 28 6c 65 74 20 6c (p). (let l
96b0: 6f 6f 70 20 28 28 6c 69 6e 65 20 28 72 65 61 64 oop ((line (read
96c0: 2d 6c 69 6e 65 20 70 29 29 0a 20 20 20 20 20 20 -line p)).
96d0: 20 20 20 20 20 20 20 20 20 20 20 28 72 65 73 75 (resu
96e0: 6c 74 20 27 28 29 29 29 0a 20 20 20 20 20 20 20 lt '())).
96f0: 20 28 69 66 20 28 65 6f 66 2d 6f 62 6a 65 63 74 (if (eof-object
9700: 3f 20 6c 69 6e 65 29 0a 20 20 20 20 20 20 20 20 ? line).
9710: 20 20 20 20 28 72 65 76 65 72 73 65 20 72 65 73 (reverse res
9720: 75 6c 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 ult).
9730: 20 28 6c 6f 6f 70 20 28 72 65 61 64 2d 6c 69 6e (loop (read-lin
9740: 65 20 70 29 20 28 63 6f 6e 73 20 6c 69 6e 65 20 e p) (cons line
9750: 72 65 73 75 6c 74 29 29 29 29 29 29 29 0a 0a 28 result)))))))..(
9760: 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 67 65 define (tests:ge
9770: 74 2d 74 65 73 74 2d 6c 6f 67 20 72 75 6e 2d 69 t-test-log run-i
9780: 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d d test-name item
9790: 2d 6e 61 6d 65 29 0a 20 20 28 6c 65 74 2a 20 28 -name). (let* (
97a0: 28 74 65 73 74 2d 64 61 74 61 20 20 20 20 28 72 (test-data (r
97b0: 6d 74 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 mt:get-tests-for
97c0: 2d 72 75 6e 0a 09 09 09 09 20 20 20 28 73 74 72 -run..... (str
97d0: 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 72 75 6e 2d ing->number run-
97e0: 69 64 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 id).
97f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9800: 20 20 20 20 20 20 20 20 74 65 73 74 2d 6e 61 6d test-nam
9810: 65 20 20 20 20 20 20 3b 3b 20 74 65 73 74 6e 61 e ;; testna
9820: 6d 65 70 61 74 74 0a 09 09 09 09 20 20 20 27 28 mepatt..... '(
9830: 29 20 20 20 20 20 20 20 20 3b 3b 20 73 74 61 74 ) ;; stat
9840: 65 73 0a 09 09 09 09 20 20 20 27 28 29 20 20 20 es..... '()
9850: 20 20 20 20 20 3b 3b 20 73 74 61 74 75 73 65 73 ;; statuses
9860: 0a 09 09 09 09 20 20 20 23 66 20 20 20 20 20 20 ..... #f
9870: 20 20 20 3b 3b 20 6f 66 66 73 65 74 0a 09 09 09 ;; offset....
9880: 09 20 20 20 23 66 20 20 20 20 20 20 20 20 20 3b . #f ;
9890: 3b 20 6e 75 6d 2d 74 6f 2d 67 65 74 0a 09 09 09 ; num-to-get....
98a0: 09 20 20 20 23 66 20 20 20 20 20 20 20 20 20 3b . #f ;
98b0: 3b 20 68 69 64 65 2f 6e 6f 74 2d 68 69 64 65 0a ; hide/not-hide.
98c0: 09 09 09 09 20 20 20 23 66 20 20 20 20 20 20 20 .... #f
98d0: 20 20 3b 3b 20 73 6f 72 74 2d 62 79 0a 09 09 09 ;; sort-by....
98e0: 09 20 20 20 23 66 20 20 20 20 20 20 20 20 20 3b . #f ;
98f0: 3b 20 73 6f 72 74 2d 6f 72 64 65 72 0a 09 09 09 ; sort-order....
9900: 09 20 20 20 23 66 20 20 20 20 20 20 20 20 20 3b . #f ;
9910: 3b 20 27 73 68 6f 72 74 6c 69 73 74 20 20 20 20 ; 'shortlist
9920: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9930: 20 20 20 20 20 20 20 3b 3b 20 71 72 79 74 79 70 ;; qrytyp
9940: 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 e.
9950: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9960: 20 20 20 20 20 30 20 20 20 20 20 20 20 20 20 3b 0 ;
9970: 3b 20 6c 61 73 74 20 75 70 64 61 74 65 0a 09 09 ; last update...
9980: 09 09 20 20 20 23 66 29 29 0a 20 20 20 20 20 20 .. #f)).
9990: 20 20 20 28 70 61 74 68 20 22 22 29 0a 20 20 20 (path "").
99a0: 20 20 20 20 20 20 28 66 6f 75 6e 64 20 30 29 29 (found 0))
99b0: 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
99c0: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
99d0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 66 6f 75 t-log-port* "fou
99e0: 6e 64 3a 20 22 20 66 6f 75 6e 64 20 29 0a 0a 20 nd: " found )..
99f0: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 (let loop ((he
9a00: 64 20 28 63 61 72 20 74 65 73 74 2d 64 61 74 61 d (car test-data
9a10: 29 29 0a 09 09 20 28 74 61 6c 20 28 63 64 72 20 ))... (tal (cdr
9a20: 74 65 73 74 2d 64 61 74 61 29 29 29 0a 20 20 20 test-data))).
9a30: 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 (debug:pr
9a40: 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 int-info 0 *defa
9a50: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 69 ult-log-port* "i
9a60: 74 65 6d 3a 20 22 20 28 76 65 63 74 6f 72 2d 72 tem: " (vector-r
9a70: 65 66 20 68 65 64 20 31 31 29 20 28 76 65 63 74 ef hed 11) (vect
9a80: 6f 72 2d 72 65 66 20 68 65 64 20 31 30 29 20 22 or-ref hed 10) "
9a90: 2f 22 20 28 76 65 63 74 6f 72 2d 72 65 66 20 68 /" (vector-ref h
9aa0: 65 64 20 31 33 29 29 0a 0a 09 28 69 66 20 28 65 ed 13))...(if (e
9ab0: 71 75 61 6c 3f 20 28 76 65 63 74 6f 72 2d 72 65 qual? (vector-re
9ac0: 66 20 68 65 64 20 31 31 29 20 69 74 65 6d 2d 6e f hed 11) item-n
9ad0: 61 6d 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 ame).
9ae0: 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 (begin.
9af0: 20 20 20 20 20 20 28 73 65 74 21 20 66 6f 75 6e (set! foun
9b00: 64 20 31 29 20 0a 09 20 20 20 20 20 20 28 73 65 d 1) .. (se
9b10: 74 21 20 70 61 74 68 20 28 63 6f 6e 63 20 28 76 t! path (conc (v
9b20: 65 63 74 6f 72 2d 72 65 66 20 68 65 64 20 31 30 ector-ref hed 10
9b30: 29 20 22 2f 22 20 28 76 65 63 74 6f 72 2d 72 65 ) "/" (vector-re
9b40: 66 20 68 65 64 20 31 33 29 29 29 29 29 0a 09 20 f hed 13)))))..
9b50: 20 20 20 28 69 66 20 28 61 6e 64 20 28 6e 6f 74 (if (and (not
9b60: 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 20 28 65 (null? tal)) (e
9b70: 71 75 61 6c 3f 20 66 6f 75 6e 64 20 30 29 29 0a qual? found 0)).
9b80: 09 09 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c ..(loop (car tal
9b90: 29 28 63 64 72 20 74 61 6c 29 29 29 29 0a 20 20 )(cdr tal)))).
9ba0: 20 28 69 66 20 28 65 71 75 61 6c 3f 20 70 61 74 (if (equal? pat
9bb0: 68 20 22 22 29 0a 20 20 20 20 20 22 3c 48 32 3e h ""). "<H2>
9bc0: 44 61 74 61 20 6e 6f 74 20 66 6f 75 6e 64 3c 2f Data not found</
9bd0: 48 32 3e 22 0a 20 20 20 20 20 28 73 74 72 69 6e H2>". (strin
9be0: 67 2d 6a 6f 69 6e 20 28 74 65 73 74 73 3a 72 65 g-join (tests:re
9bf0: 61 64 6c 69 6e 65 73 20 70 61 74 68 29 20 22 5c adlines path) "\
9c00: 6e 22 29 29 29 29 0a 0a 0a 28 64 65 66 69 6e 65 n"))))...(define
9c10: 20 28 74 65 73 74 73 3a 64 79 6e 61 6d 69 63 2d (tests:dynamic-
9c20: 64 62 6f 61 72 64 20 70 61 67 65 29 0a 3b 28 64 dboard page).;(d
9c30: 65 66 69 6e 65 20 28 74 65 73 74 73 3a 63 72 65 efine (tests:cre
9c40: 61 74 65 2d 68 74 6d 6c 2d 74 72 65 65 20 6f 29 ate-html-tree o)
9c50: 0a 20 28 6c 65 74 2a 20 28 0a 3b 28 70 61 67 65 . (let* (.;(page
9c60: 20 22 31 22 29 0a 20 20 20 20 20 20 20 20 20 20 "1").
9c70: 28 6c 69 6e 6b 74 72 65 65 20 20 28 63 6f 6d 6d (linktree (comm
9c80: 6f 6e 3a 67 65 74 2d 6c 69 6e 6b 74 72 65 65 29 on:get-linktree)
9c90: 29 0a 20 20 20 20 20 20 20 20 20 28 61 72 65 61 ). (area
9ca0: 2d 6e 61 6d 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 -name (common:ge
9cb0: 74 2d 74 65 73 74 73 75 69 74 65 2d 6e 61 6d 65 t-testsuite-name
9cc0: 29 29 0a 09 20 20 20 20 20 20 20 28 6b 65 79 73 )).. (keys
9cd0: 20 20 20 20 20 20 28 72 6d 74 3a 67 65 74 2d 6b (rmt:get-k
9ce0: 65 79 73 29 29 0a 09 20 20 20 20 20 20 20 28 6e eys)).. (n
9cf0: 75 6d 6b 65 79 73 20 20 20 28 6c 65 6e 67 74 68 umkeys (length
9d00: 20 6b 65 79 73 29 29 0a 20 20 20 20 20 20 20 20 keys)).
9d10: 20 28 74 61 72 67 74 77 65 61 6b 65 64 20 28 6d (targtweaked (m
9d20: 61 6b 65 2d 6c 69 73 74 20 6e 75 6d 6b 65 79 73 ake-list numkeys
9d30: 20 22 25 22 29 29 0a 20 20 20 20 20 20 20 20 20 "%")).
9d40: 28 74 61 72 67 65 74 2d 70 61 74 74 20 28 73 74 (target-patt (st
9d50: 72 69 6e 67 2d 6a 6f 69 6e 20 74 61 72 67 74 77 ring-join targtw
9d60: 65 61 6b 65 64 20 22 2f 22 29 29 0a 20 20 20 20 eaked "/")).
9d70: 20 20 20 20 20 28 74 6f 74 61 6c 2d 72 75 6e 73 (total-runs
9d80: 20 20 28 72 6d 74 3a 67 65 74 2d 6e 75 6d 2d 72 (rmt:get-num-r
9d90: 75 6e 73 20 22 25 22 29 29 0a 20 20 20 20 20 20 uns "%")).
9da0: 20 20 20 28 70 67 2d 73 69 7a 65 20 31 30 29 0a (pg-size 10).
9db0: 20 20 20 20 20 20 20 20 20 28 70 67 20 28 69 66 (pg (if
9dc0: 20 28 65 71 75 61 6c 3f 20 70 61 67 65 20 23 66 (equal? page #f
9dd0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
9de0: 20 20 20 30 0a 20 20 20 20 20 20 20 20 20 20 20 0.
9df0: 20 20 20 20 20 20 28 2d 20 28 73 74 72 69 6e 67 (- (string
9e00: 2d 3e 6e 75 6d 62 65 72 20 70 61 67 65 29 20 31 ->number page) 1
9e10: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 67 ))). (g
9e20: 65 74 2d 70 72 65 76 2d 6c 69 6e 6b 73 20 20 28 et-prev-links (
9e30: 6c 61 6d 62 64 61 20 28 70 67 20 6c 69 6e 6b 74 lambda (pg linkt
9e40: 72 65 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 ree).
9e50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9e60: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
9e70: 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
9e80: 2d 70 6f 72 74 2a 20 22 76 61 6c 3a 20 22 20 28 -port* "val: " (
9e90: 2d 20 31 20 70 67 29 29 0a 20 20 20 20 20 20 20 - 1 pg)).
9ea0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9eb0: 20 20 20 28 6c 65 74 2a 20 28 28 6c 69 6e 6b 20 (let* ((link
9ec0: 20 28 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 70 (if (not (eq? p
9ed0: 67 20 30 29 29 0a 20 20 20 20 20 20 20 20 20 20 g 0)).
9ee0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9ef0: 20 20 20 20 20 28 73 3a 61 20 20 22 26 6c 74 3b (s:a "<
9f00: 26 6c 74 3b 70 72 65 76 20 22 20 27 68 72 65 66 <prev " 'href
9f10: 20 28 63 6f 6e 63 20 20 22 64 61 73 68 62 6f 61 (conc "dashboa
9f20: 72 64 3f 70 61 67 65 3d 22 20 20 70 67 20 20 29 rd?page=" pg )
9f30: 29 0a 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 20 20 20 20 20
9f50: 20 28 73 3a 61 20 22 22 20 27 68 72 65 66 20 28 (s:a "" 'href (
9f60: 63 6f 6e 63 20 20 22 64 61 73 68 62 6f 61 72 64 conc "dashboard
9f70: 3f 70 61 67 65 3d 22 20 70 67 29 29 29 29 29 0a ?page=" pg))))).
9f80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9f90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 6c l
9fa0: 69 6e 6b 29 29 29 0a 20 20 20 20 20 20 20 20 20 ink))).
9fb0: 20 28 67 65 74 2d 6e 65 78 74 2d 6c 69 6e 6b 73 (get-next-links
9fc0: 20 20 20 28 6c 61 6d 62 64 61 20 28 70 67 20 6c (lambda (pg l
9fd0: 69 6e 6b 74 72 65 65 20 74 6f 74 61 6c 2d 72 75 inktree total-ru
9fe0: 6e 73 29 20 20 0a 20 20 20 20 20 20 20 20 20 20 ns) .
9ff0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a000: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
a010: 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 0 *default-l
a020: 6f 67 2d 70 6f 72 74 2a 20 22 76 61 6c 3a 20 22 og-port* "val: "
a030: 20 70 67 29 0a 20 20 20 20 20 20 20 20 20 20 20 pg).
a040: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a050: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
a060: 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 0 *default-l
a070: 6f 67 2d 70 6f 72 74 2a 20 22 76 61 6c 3a 20 22 og-port* "val: "
a080: 20 74 6f 74 61 6c 2d 72 75 6e 73 20 22 20 73 69 total-runs " si
a090: 7a 65 22 20 70 67 2d 73 69 7a 65 29 0a 20 0a 20 ze" pg-size). .
a0a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a0b0: 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 2a (let*
a0c0: 20 28 28 6c 69 6e 6b 20 20 28 69 66 20 28 3e 20 ((link (if (>
a0d0: 74 6f 74 61 6c 2d 72 75 6e 73 20 28 2b 20 31 30 total-runs (+ 10
a0e0: 20 28 2a 20 70 67 20 70 67 2d 73 69 7a 65 29 29 (* pg pg-size))
a0f0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
a100: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a110: 28 73 3a 61 20 20 22 6e 65 78 74 26 67 74 3b 26 (s:a "next>&
a120: 67 74 3b 20 22 20 20 27 68 72 65 66 20 28 63 6f gt; " 'href (co
a130: 6e 63 20 20 22 64 61 73 68 62 6f 61 72 64 3f 70 nc "dashboard?p
a140: 61 67 65 3d 22 20 20 28 2b 20 70 67 20 32 29 20 age=" (+ pg 2)
a150: 20 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 )).
a160: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a170: 20 28 73 3a 61 20 22 22 20 27 68 72 65 66 20 28 (s:a "" 'href (
a180: 63 6f 6e 63 20 20 22 64 61 73 68 62 6f 61 72 64 conc "dashboard
a190: 3f 70 61 67 65 3d 22 20 70 67 20 20 29 29 29 29 ?page=" pg ))))
a1a0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
a1b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 6c l
a1c0: 69 6e 6b 29 29 29 0a 20 20 20 20 20 20 20 20 20 ink))).
a1d0: 28 68 74 6d 6c 2d 62 6f 64 79 20 28 74 65 73 74 (html-body (test
a1e0: 73 3a 64 61 73 68 62 6f 61 72 64 2d 62 6f 64 79 s:dashboard-body
a1f0: 20 70 67 20 70 67 2d 73 69 7a 65 20 6b 65 79 73 pg pg-size keys
a200: 20 6e 75 6d 6b 65 79 73 20 74 6f 74 61 6c 2d 72 numkeys total-r
a210: 75 6e 73 20 6c 69 6e 6b 74 72 65 65 20 61 72 65 uns linktree are
a220: 61 2d 6e 61 6d 65 20 67 65 74 2d 70 72 65 76 2d a-name get-prev-
a230: 6c 69 6e 6b 73 20 67 65 74 2d 6e 65 78 74 2d 6c links get-next-l
a240: 69 6e 6b 73 20 23 74 20 22 25 22 20 74 61 72 67 inks #t "%" targ
a250: 65 74 2d 70 61 74 74 29 29 29 20 3b 3b 20 75 70 et-patt))) ;; up
a260: 64 61 74 65 20 74 69 73 20 66 75 6e 63 74 69 6f date tis functio
a270: 6e 0a 20 20 20 20 20 20 20 20 68 74 6d 6c 2d 62 n. html-b
a280: 6f 64 79 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 ody))..(define (
a290: 74 65 73 74 73 3a 63 72 65 61 74 65 2d 68 74 6d tests:create-htm
a2a0: 6c 2d 73 75 6d 6d 61 72 79 20 6f 75 74 66 29 0a l-summary outf).
a2b0: 20 28 6c 65 74 2a 20 28 28 6c 6f 63 6b 66 69 6c (let* ((lockfil
a2c0: 65 20 20 28 63 6f 6e 63 20 6f 75 74 66 20 22 2e e (conc outf ".
a2d0: 6c 6f 63 6b 22 29 29 0a 20 20 20 20 20 20 20 20 lock")).
a2e0: 28 6c 69 6e 6b 74 72 65 65 20 20 28 63 6f 6d 6d (linktree (comm
a2f0: 6f 6e 3a 67 65 74 2d 6c 69 6e 6b 74 72 65 65 29 on:get-linktree)
a300: 29 0a 09 09 09 09 28 6b 65 79 73 20 20 20 20 20 ).....(keys
a310: 20 28 72 6d 74 3a 67 65 74 2d 6b 65 79 73 29 29 (rmt:get-keys))
a320: 0a 20 20 20 20 20 20 20 20 28 61 72 65 61 2d 6e . (area-n
a330: 61 6d 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d ame (common:get-
a340: 74 65 73 74 73 75 69 74 65 2d 6e 61 6d 65 29 29 testsuite-name))
a350: 0a 20 20 20 20 20 20 20 20 28 72 75 6e 2d 70 61 . (run-pa
a360: 74 74 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 tt (or (args:get
a370: 2d 61 72 67 20 22 2d 72 75 6e 2d 70 61 74 74 22 -arg "-run-patt"
a380: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
a390: 20 20 20 20 20 20 20 20 20 20 28 61 72 67 73 3a (args:
a3a0: 67 65 74 2d 61 72 67 20 22 2d 72 75 6e 6e 61 6d get-arg "-runnam
a3b0: 65 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 e").
a3c0: 20 20 20 20 20 20 20 20 20 20 20 20 22 25 22 29 "%")
a3d0: 29 0a 20 20 20 20 20 20 20 20 28 74 61 72 67 65 ). (targe
a3e0: 74 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d t (or (args:get-
a3f0: 61 72 67 20 22 2d 74 61 72 67 65 74 2d 70 61 74 arg "-target-pat
a400: 74 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 t").
a410: 20 20 20 20 20 20 20 20 20 20 20 20 28 61 72 67 (arg
a420: 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 72 67 s:get-arg "-targ
a430: 65 74 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 et").
a440: 20 20 20 20 20 20 20 20 20 20 20 20 20 22 25 22 "%"
a450: 29 29 0a 20 20 20 20 20 20 20 20 20 28 74 61 72 )). (tar
a460: 67 6c 69 73 74 20 28 73 74 72 69 6e 67 2d 73 70 glist (string-sp
a470: 6c 69 74 20 74 61 72 67 65 74 20 22 2f 22 29 29 lit target "/"))
a480: 0a 20 20 20 20 20 20 20 20 20 28 6e 75 6d 6b 65 . (numke
a490: 79 73 20 20 28 6c 65 6e 67 74 68 20 6b 65 79 73 ys (length keys
a4a0: 29 29 0a 09 20 20 20 20 20 20 20 28 6e 75 6d 74 )).. (numt
a4b0: 61 72 67 20 20 28 6c 65 6e 67 74 68 20 74 61 72 arg (length tar
a4c0: 67 6c 69 73 74 29 29 20 20 0a 20 20 20 20 20 20 glist)) .
a4d0: 20 20 20 28 74 61 72 67 74 77 65 61 6b 65 64 20 (targtweaked
a4e0: 28 69 66 20 28 3e 20 6e 75 6d 6b 65 79 73 20 6e (if (> numkeys n
a4f0: 75 6d 74 61 72 67 29 0a 09 09 09 20 20 20 09 09 umtarg).... ..
a500: 09 09 09 09 09 09 28 61 70 70 65 6e 64 20 74 61 ......(append ta
a510: 72 67 6c 69 73 74 20 28 6d 61 6b 65 2d 6c 69 73 rglist (make-lis
a520: 74 20 28 2d 20 6e 75 6d 6b 65 79 73 20 6e 75 6d t (- numkeys num
a530: 74 61 72 67 29 20 22 25 22 29 29 0a 09 09 09 20 targ) "%"))....
a540: 20 09 09 09 09 09 09 09 09 74 61 72 67 6c 69 73 ........targlis
a550: 74 29 29 0a 20 20 20 20 20 20 20 20 28 74 61 72 t)). (tar
a560: 67 65 74 2d 70 61 74 74 20 28 73 74 72 69 6e 67 get-patt (string
a570: 2d 6a 6f 69 6e 20 74 61 72 67 74 77 65 61 6b 65 -join targtweake
a580: 64 20 22 2f 22 29 29 29 0a 20 20 20 20 28 69 66 d "/"))). (if
a590: 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 2d (common:simple-
a5a0: 66 69 6c 65 2d 6c 6f 63 6b 20 6c 6f 63 6b 66 69 file-lock lockfi
a5b0: 6c 65 29 0a 20 20 20 20 20 20 20 20 28 62 65 67 le). (beg
a5c0: 69 6e 0a 20 20 20 20 20 20 20 20 20 20 28 6c 65 in. (le
a5d0: 74 2a 20 28 3b 28 72 75 6e 73 64 61 74 31 20 20 t* (;(runsdat1
a5e0: 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e 73 20 72 (rmt:get-runs r
a5f0: 75 6e 2d 70 61 74 74 20 23 66 20 23 66 20 28 6d un-patt #f #f (m
a600: 61 70 20 28 6c 61 6d 62 64 61 20 28 78 29 28 6c ap (lambda (x)(l
a610: 69 73 74 20 78 20 22 25 22 29 29 20 6b 65 79 73 ist x "%")) keys
a620: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
a630: 20 20 20 20 20 28 72 75 6e 73 64 61 74 20 20 20 (runsdat
a640: 28 72 6d 74 3a 67 65 74 2d 72 75 6e 73 2d 62 79 (rmt:get-runs-by
a650: 2d 70 61 74 74 20 20 6b 65 79 73 20 72 75 6e 2d -patt keys run-
a660: 70 61 74 74 20 74 61 72 67 65 74 2d 70 61 74 74 patt target-patt
a670: 20 23 66 20 23 66 20 23 66 20 30 29 29 0a 09 09 #f #f #f 0))...
a680: 09 09 09 20 20 20 20 20 20 20 28 72 75 6e 73 20 ... (runs
a690: 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 (vector-ref
a6a0: 20 72 75 6e 73 64 61 74 20 31 29 29 0a 20 20 20 runsdat 1)).
a6b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 68 (h
a6c0: 65 61 64 65 72 20 20 20 20 20 20 28 76 65 63 74 eader (vect
a6d0: 6f 72 2d 72 65 66 20 72 75 6e 73 64 61 74 20 30 or-ref runsdat 0
a6e0: 29 29 0a 20 20 20 20 20 20 20 20 09 20 20 20 20 )). .
a6f0: 20 20 20 28 6f 75 70 20 20 20 20 20 20 20 28 6f (oup (o
a700: 70 65 6e 2d 6f 75 74 70 75 74 2d 66 69 6c 65 20 pen-output-file
a710: 28 6f 72 20 6f 75 74 66 20 28 63 6f 6e 63 20 6c (or outf (conc l
a720: 69 6e 6b 74 72 65 65 20 22 2f 74 61 72 67 65 74 inktree "/target
a730: 73 2e 68 74 6d 6c 22 29 29 29 29 0a 20 20 20 20 s.html")))).
a740: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 74 61 (ta
a750: 72 67 65 74 2d 68 61 73 68 20 28 74 65 73 74 3a rget-hash (test:
a760: 63 72 65 61 74 65 2d 74 61 72 67 65 74 2d 68 61 create-target-ha
a770: 73 68 20 72 75 6e 73 20 68 65 61 64 65 72 20 28 sh runs header (
a780: 6c 65 6e 67 74 68 20 6b 65 79 73 29 29 29 29 0a length keys)))).
a790: 20 20 20 20 20 20 20 20 20 20 20 28 74 65 73 74 (test
a7a0: 3a 63 72 65 61 74 65 2d 74 61 72 67 65 74 2d 68 :create-target-h
a7b0: 74 6d 6c 20 74 61 72 67 65 74 2d 68 61 73 68 20 tml target-hash
a7c0: 6f 75 70 20 61 72 65 61 2d 6e 61 6d 65 20 6c 69 oup area-name li
a7d0: 6e 6b 74 72 65 65 29 0a 20 20 20 20 20 20 20 20 nktree).
a7e0: 20 20 28 74 65 73 74 3a 63 72 65 61 74 65 2d 72 (test:create-r
a7f0: 75 6e 2d 68 74 6d 6c 20 20 72 75 6e 73 20 61 72 un-html runs ar
a800: 65 61 2d 6e 61 6d 65 20 6c 69 6e 6b 74 72 65 65 ea-name linktree
a810: 20 28 6c 65 6e 67 74 68 20 6b 65 79 73 29 20 68 (length keys) h
a820: 65 61 64 65 72 29 29 0a 09 20 20 28 63 6f 6d 6d eader)).. (comm
a830: 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 72 on:simple-file-r
a840: 65 6c 65 61 73 65 2d 6c 6f 63 6b 20 6c 6f 63 6b elease-lock lock
a850: 66 69 6c 65 29 29 0a 09 23 66 29 29 29 0a 0a 28 file))..#f)))..(
a860: 64 65 66 69 6e 65 20 28 74 65 73 74 3a 67 65 74 define (test:get
a870: 2d 74 65 73 74 2d 68 61 73 68 20 74 65 73 74 2d -test-hash test-
a880: 64 61 74 61 29 0a 09 28 6c 65 74 20 28 28 72 65 data)..(let ((re
a890: 73 68 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 sh (make-hash-ta
a8a0: 62 6c 65 29 29 29 0a 20 20 20 20 09 28 6d 61 70 ble))). .(map
a8b0: 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 29 0a (lambda (test).
a8c0: 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 (let* ((
a8d0: 74 65 73 74 2d 6e 61 6d 65 20 28 76 65 63 74 6f test-name (vecto
a8e0: 72 2d 72 65 66 20 74 65 73 74 20 32 29 29 0a 20 r-ref test 2)).
a8f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 74 (t
a900: 65 73 74 2d 68 74 6d 6c 2d 70 61 74 68 20 28 69 est-html-path (i
a910: 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 f (file-exists?
a920: 28 63 6f 6e 63 20 28 76 65 63 74 6f 72 2d 72 65 (conc (vector-re
a930: 66 20 74 65 73 74 20 31 30 29 20 22 2f 74 65 73 f test 10) "/tes
a940: 74 2d 73 75 6d 6d 61 72 79 2e 68 74 6d 6c 22 29 t-summary.html")
a950: 29 0a 09 09 09 09 09 09 09 09 09 09 09 09 09 09 )...............
a960: 09 09 20 28 63 6f 6e 63 20 28 76 65 63 74 6f 72 .. (conc (vector
a970: 2d 72 65 66 20 74 65 73 74 20 31 30 29 20 22 2f -ref test 10) "/
a980: 74 65 73 74 2d 73 75 6d 6d 61 72 79 2e 68 74 6d test-summary.htm
a990: 6c 22 20 29 0a 09 09 09 09 09 09 09 20 09 09 09 l" )........ ...
a9a0: 09 09 09 09 09 09 20 28 63 6f 6e 63 20 28 76 65 ...... (conc (ve
a9b0: 63 74 6f 72 2d 72 65 66 20 74 65 73 74 20 31 30 ctor-ref test 10
a9c0: 29 20 22 2f 22 20 28 76 65 63 74 6f 72 2d 72 65 ) "/" (vector-re
a9d0: 66 20 74 65 73 74 20 31 33 29 29 29 29 0a 20 20 f test 13)))).
a9e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 74 65 (te
a9f0: 73 74 2d 69 74 65 6d 20 20 28 76 65 63 74 6f 72 st-item (vector
aa00: 2d 72 65 66 20 74 65 73 74 20 31 31 29 29 0a 20 -ref test 11)).
aa10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 74 (t
aa20: 65 73 74 2d 73 74 61 74 75 73 20 28 76 65 63 74 est-status (vect
aa30: 6f 72 2d 72 65 66 20 74 65 73 74 20 34 29 29 29 or-ref test 4)))
aa40: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
aa50: 28 69 66 20 28 6e 6f 74 20 28 68 61 73 68 2d 74 (if (not (hash-t
aa60: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
aa70: 20 72 65 73 68 20 74 65 73 74 2d 69 74 65 6d 20 resh test-item
aa80: 20 23 66 29 29 0a 20 20 20 20 20 20 20 20 20 20 #f)).
aa90: 20 20 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 (hash-t
aaa0: 61 62 6c 65 2d 73 65 74 21 20 72 65 73 68 20 74 able-set! resh t
aab0: 65 73 74 2d 69 74 65 6d 20 20 20 28 6d 61 6b 65 est-item (make
aac0: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 0a 20 -hash-table))).
aad0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 68 (h
aae0: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 28 ash-table-set! (
aaf0: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
ab00: 65 66 61 75 6c 74 20 72 65 73 68 20 74 65 73 74 efault resh test
ab10: 2d 69 74 65 6d 20 20 23 66 29 20 74 65 73 74 2d -item #f) test-
ab20: 6e 61 6d 65 20 28 6c 69 73 74 20 74 65 73 74 2d name (list test-
ab30: 73 74 61 74 75 73 20 74 65 73 74 2d 68 74 6d 6c status test-html
ab40: 2d 70 61 74 68 29 29 29 29 20 0a 20 20 20 20 20 -path)))) .
ab50: 20 20 20 74 65 73 74 2d 64 61 74 61 29 0a 72 65 test-data).re
ab60: 73 68 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 sh))..(define (t
ab70: 65 73 74 3a 67 65 74 2d 64 61 74 61 2d 3e 62 2d est:get-data->b-
ab80: 6b 65 79 73 20 6f 72 64 65 72 65 64 2d 64 61 74 keys ordered-dat
ab90: 61 20 61 2d 6b 65 79 73 29 0a 20 20 28 64 65 6c a a-keys). (del
aba0: 65 74 65 2d 64 75 70 6c 69 63 61 74 65 73 0a 20 ete-duplicates.
abb0: 20 20 28 73 6f 72 74 20 28 61 70 70 6c 79 0a 09 (sort (apply..
abc0: 20 20 61 70 70 65 6e 64 0a 09 20 20 28 6d 61 70 append.. (map
abd0: 20 28 6c 61 6d 62 64 61 20 28 73 75 62 2d 6b 65 (lambda (sub-ke
abe0: 79 29 0a 09 09 20 28 6c 65 74 20 28 28 73 75 62 y)... (let ((sub
abf0: 64 61 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d dat (hash-table-
ac00: 72 65 66 20 6f 72 64 65 72 65 64 2d 64 61 74 61 ref ordered-data
ac10: 20 73 75 62 2d 6b 65 79 29 29 29 0a 09 09 20 20 sub-key)))...
ac20: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 (hash-table-key
ac30: 73 20 73 75 62 64 61 74 29 29 29 0a 09 20 20 20 s subdat)))..
ac40: 20 20 20 20 61 2d 6b 65 79 73 29 29 0a 09 20 73 a-keys)).. s
ac50: 74 72 69 6e 67 3e 3d 3f 29 29 29 0a 0a 0a 28 64 tring>=?)))...(d
ac60: 65 66 69 6e 65 20 28 74 65 73 74 3a 63 72 65 61 efine (test:crea
ac70: 74 65 2d 72 75 6e 2d 68 74 6d 6c 20 72 75 6e 73 te-run-html runs
ac80: 20 61 72 65 61 2d 6e 61 6d 65 20 6c 69 6e 6b 74 area-name linkt
ac90: 72 65 65 20 6e 75 6d 6b 65 79 73 20 68 65 61 64 ree numkeys head
aca0: 65 72 29 0a 20 20 28 6d 61 70 20 28 6c 61 6d 62 er). (map (lamb
acb0: 64 61 20 28 72 75 6e 29 0a 09 09 20 28 6c 65 74 da (run)... (let
acc0: 2a 20 28 28 74 61 72 67 65 74 20 28 73 74 72 69 * ((target (stri
acd0: 6e 67 2d 6a 6f 69 6e 20 28 74 61 6b 65 20 28 76 ng-join (take (v
ace0: 65 63 74 6f 72 2d 3e 6c 69 73 74 20 72 75 6e 29 ector->list run)
acf0: 20 6e 75 6d 6b 65 79 73 29 20 22 2f 22 29 29 0a numkeys) "/")).
ad00: 09 09 09 09 09 09 28 72 75 6e 2d 6e 61 6d 65 20 ......(run-name
ad10: 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 (db:get-value-by
ad20: 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 -header run head
ad30: 65 72 20 22 72 75 6e 6e 61 6d 65 22 29 29 0a 20 er "runname")).
ad40: 20 20 20 20 20 20 20 20 20 20 20 28 72 75 6e 2d (run-
ad50: 74 69 6d 65 20 28 73 65 63 6f 6e 64 73 2d 3e 77 time (seconds->w
ad60: 6f 72 6b 2d 77 65 65 6b 2f 64 61 79 2d 74 69 6d ork-week/day-tim
ad70: 65 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d e (db:get-value-
ad80: 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 by-header run he
ad90: 61 64 65 72 20 22 65 76 65 6e 74 5f 74 69 6d 65 ader "event_time
ada0: 22 29 29 29 0a 09 09 09 09 09 09 28 6f 75 70 20 "))).......(oup
adb0: 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 (if (file-exists
adc0: 3f 20 28 63 6f 6e 63 20 6c 69 6e 6b 74 72 65 65 ? (conc linktree
add0: 20 22 2f 22 20 74 61 72 67 65 74 20 22 2f 22 20 "/" target "/"
ade0: 72 75 6e 2d 6e 61 6d 65 29 29 0a 20 20 20 20 20 run-name)).
adf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ae00: 20 20 20 28 6f 70 65 6e 2d 6f 75 74 70 75 74 2d (open-output-
ae10: 66 69 6c 65 20 28 63 6f 6e 63 20 6c 69 6e 6b 74 file (conc linkt
ae20: 72 65 65 20 22 2f 22 20 74 61 72 67 65 74 20 22 ree "/" target "
ae30: 2f 22 20 72 75 6e 2d 6e 61 6d 65 20 22 2f 72 75 /" run-name "/ru
ae40: 6e 2e 68 74 6d 6c 22 29 29 0a 20 20 20 20 20 20 n.html")).
ae50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ae60: 20 20 20 23 66 29 29 0a 20 20 20 20 20 20 20 20 #f)).
ae70: 20 20 20 20 28 72 75 6e 2d 69 64 20 28 64 62 3a (run-id (db:
ae80: 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 get-value-by-hea
ae90: 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 der run header "
aea0: 69 64 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 id")).
aeb0: 20 20 28 74 65 73 74 2d 64 61 74 61 20 20 20 20 (test-data
aec0: 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 73 2d 66 (rmt:get-tests-f
aed0: 6f 72 2d 72 75 6e 0a 09 09 09 09 20 20 09 09 09 or-run..... ...
aee0: 09 09 09 09 09 20 72 75 6e 2d 69 64 0a 20 20 20 ..... run-id.
aef0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
af00: 20 20 20 20 20 20 20 20 22 25 22 20 20 20 20 20 "%"
af10: 20 20 3b 3b 20 74 65 73 74 6e 61 6d 65 70 61 74 ;; testnamepat
af20: 74 0a 09 09 09 09 20 20 09 09 09 09 09 09 09 09 t..... ........
af30: 20 27 28 29 20 20 20 20 20 20 20 20 3b 3b 20 73 '() ;; s
af40: 74 61 74 65 73 0a 09 09 09 09 20 20 20 09 09 09 tates..... ...
af50: 09 09 09 09 09 20 27 28 29 20 20 20 20 20 20 20 ..... '()
af60: 20 3b 3b 20 73 74 61 74 75 73 65 73 0a 09 09 09 ;; statuses....
af70: 09 20 20 09 09 09 09 09 09 09 09 20 09 23 66 20 . ........ .#f
af80: 20 20 20 20 20 20 20 20 3b 3b 20 6f 66 66 73 65 ;; offse
af90: 74 0a 09 09 09 09 20 20 09 09 09 09 09 09 20 09 t..... ...... .
afa0: 09 09 23 66 20 20 20 20 20 20 20 20 20 3b 3b 20 ..#f ;;
afb0: 6e 75 6d 2d 74 6f 2d 67 65 74 0a 09 09 09 09 20 num-to-get.....
afc0: 20 20 09 09 09 09 09 09 09 09 09 23 66 20 20 20 .........#f
afd0: 20 20 20 20 20 20 3b 3b 20 68 69 64 65 2f 6e 6f ;; hide/no
afe0: 74 2d 68 69 64 65 0a 09 09 09 09 20 20 09 09 09 t-hide..... ...
aff0: 09 09 09 09 09 20 20 23 66 20 20 20 20 20 20 20 ..... #f
b000: 20 20 3b 3b 20 73 6f 72 74 2d 62 79 0a 09 09 09 ;; sort-by....
b010: 09 20 20 20 09 09 09 09 09 09 09 09 09 23 66 20 . .........#f
b020: 20 20 20 20 20 20 20 20 3b 3b 20 73 6f 72 74 2d ;; sort-
b030: 6f 72 64 65 72 0a 09 09 09 09 20 20 20 09 09 09 order..... ...
b040: 09 09 09 09 09 09 23 66 20 20 20 20 20 20 20 20 ......#f
b050: 20 3b 3b 20 27 73 68 6f 72 74 6c 69 73 74 20 20 ;; 'shortlist
b060: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b070: 20 20 20 20 20 20 20 20 20 3b 3b 20 71 72 79 74 ;; qryt
b080: 79 70 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 ype.
b090: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b0a0: 30 20 20 20 20 20 20 20 20 20 3b 3b 20 6c 61 73 0 ;; las
b0b0: 74 20 75 70 64 61 74 65 0a 09 09 09 09 20 20 09 t update..... .
b0c0: 09 09 09 09 09 09 09 09 23 66 29 29 0a 20 20 20 ........#f)).
b0d0: 20 20 20 20 20 20 20 20 20 28 69 74 65 6d 2d 74 (item-t
b0e0: 65 73 74 2d 68 61 73 68 20 28 74 65 73 74 3a 67 est-hash (test:g
b0f0: 65 74 2d 74 65 73 74 2d 68 61 73 68 20 74 65 73 et-test-hash tes
b100: 74 2d 64 61 74 61 29 29 0a 20 20 20 20 20 20 20 t-data)).
b110: 20 20 20 20 20 28 69 74 65 6d 73 20 20 28 68 61 (items (ha
b120: 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 69 74 sh-table-keys it
b130: 65 6d 2d 74 65 73 74 2d 68 61 73 68 29 29 0a 20 em-test-hash)).
b140: 09 09 09 09 09 09 28 74 65 73 74 2d 6e 61 6d 65 ......(test-name
b150: 73 20 28 74 65 73 74 3a 67 65 74 2d 64 61 74 61 s (test:get-data
b160: 2d 3e 62 2d 6b 65 79 73 20 69 74 65 6d 2d 74 65 ->b-keys item-te
b170: 73 74 2d 68 61 73 68 20 69 74 65 6d 73 29 29 29 st-hash items)))
b180: 0a 20 20 20 20 28 69 66 20 6f 75 70 0a 20 20 20 . (if oup.
b190: 20 20 20 28 62 65 67 69 6e 20 0a 20 20 20 20 20 (begin .
b1a0: 28 73 3a 6f 75 74 70 75 74 2d 6e 65 77 0a 09 20 (s:output-new..
b1b0: 20 20 6f 75 70 0a 09 20 20 20 28 73 3a 68 74 6d oup.. (s:htm
b1c0: 6c 20 74 65 73 74 73 3a 63 73 73 2d 6a 73 63 72 l tests:css-jscr
b1d0: 69 70 74 2d 62 6c 6f 63 6b 20 28 74 65 73 74 73 ipt-block (tests
b1e0: 3a 63 73 73 2d 6a 73 63 72 69 70 74 2d 62 6c 6f :css-jscript-blo
b1f0: 63 6b 2d 63 6f 6e 64 20 23 66 29 0a 09 09 20 20 ck-cond #f)...
b200: 20 28 73 3a 74 69 74 6c 65 20 22 52 75 6e 73 20 (s:title "Runs
b210: 56 69 65 77 20 22 20 72 75 6e 2d 6e 61 6d 65 29 View " run-name)
b220: 0a 09 09 20 20 20 28 73 3a 62 6f 64 79 0a 09 09 ... (s:body...
b230: 20 20 20 20 20 28 73 3a 68 31 20 22 52 75 6e 73 (s:h1 "Runs
b240: 20 56 69 65 77 20 22 20 29 0a 20 20 20 20 20 20 View " ).
b250: 20 20 20 28 73 3a 68 33 20 22 54 61 72 67 65 74 (s:h3 "Target
b260: 22 20 74 61 72 67 65 74 29 0a 09 09 09 09 20 28 " target)..... (
b270: 73 3a 70 20 0a 09 09 09 09 09 28 73 3a 62 20 22 s:p ......(s:b "
b280: 52 75 6e 20 6e 61 6d 65 22 20 29 20 72 75 6e 2d Run name" ) run-
b290: 6e 61 6d 65 29 0a 20 20 20 20 20 20 20 20 20 28 name). (
b2a0: 73 3a 70 20 0a 09 09 09 09 09 28 73 3a 62 20 22 s:p ......(s:b "
b2b0: 52 75 6e 20 44 61 74 65 22 20 29 20 72 75 6e 2d Run Date" ) run-
b2c0: 74 69 6d 65 29 0a 20 20 20 20 20 20 20 20 20 28 time). (
b2d0: 73 3a 74 61 62 6c 65 20 27 62 6f 72 64 65 72 20 s:table 'border
b2e0: 31 20 27 63 65 6c 6c 73 70 61 63 69 6e 67 20 30 1 'cellspacing 0
b2f0: 0a 20 20 20 20 20 20 20 20 20 20 20 28 73 3a 74 . (s:t
b300: 72 0a 20 20 20 20 20 20 20 20 20 20 20 28 73 3a r. (s:
b310: 74 68 20 22 49 74 65 6d 73 22 29 0a 20 20 20 20 th "Items").
b320: 20 20 20 20 20 20 20 28 6d 61 70 20 28 6c 61 6d (map (lam
b330: 62 64 61 20 28 74 65 73 74 29 0a 20 20 20 20 20 bda (test).
b340: 20 20 20 20 20 20 20 28 73 3a 74 68 20 74 65 73 (s:th tes
b350: 74 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 74 t)). t
b360: 65 73 74 2d 6e 61 6d 65 73 29 29 20 20 0a 20 20 est-names)) .
b370: 20 20 20 20 20 20 20 20 20 28 6d 61 70 20 28 6c (map (l
b380: 61 6d 62 64 61 20 28 69 74 65 6d 29 20 0a 09 09 ambda (item) ...
b390: 09 09 09 20 20 28 6c 65 74 2a 20 28 28 74 65 73 ... (let* ((tes
b3a0: 74 2d 68 61 73 68 20 28 68 61 73 68 2d 74 61 62 t-hash (hash-tab
b3b0: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 69 le-ref/default i
b3c0: 74 65 6d 2d 74 65 73 74 2d 68 61 73 68 20 69 74 tem-test-hash it
b3d0: 65 6d 20 20 23 66 29 29 29 0a 09 09 09 09 09 09 em #f))).......
b3e0: 09 09 20 28 69 66 20 74 65 73 74 2d 68 61 73 68 .. (if test-hash
b3f0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
b400: 20 20 20 28 62 65 67 69 6e 0a 09 09 09 09 09 09 (begin.......
b410: 09 09 09 28 73 3a 74 72 0a 09 09 09 09 09 20 20 ...(s:tr......
b420: 09 09 09 28 73 3a 74 64 20 27 63 6c 61 73 73 20 ...(s:td 'class
b430: 22 74 65 73 74 22 20 69 74 65 6d 29 0a 20 20 20 "test" item).
b440: 20 20 20 20 20 20 20 20 20 09 09 09 28 6d 61 70 ...(map
b450: 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 29 0a (lambda (test).
b460: 09 09 09 09 09 09 20 20 09 09 28 6c 65 74 2a 20 ...... ..(let*
b470: 28 28 74 65 73 74 2d 64 65 74 61 69 6c 73 20 28 ((test-details (
b480: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
b490: 65 66 61 75 6c 74 20 74 65 73 74 2d 68 61 73 68 efault test-hash
b4a0: 20 74 65 73 74 20 20 23 66 29 29 0a 09 09 09 09 test #f)).....
b4b0: 09 09 09 09 09 09 09 09 28 73 74 61 74 75 73 20 ........(status
b4c0: 28 69 66 20 74 65 73 74 2d 64 65 74 61 69 6c 73 (if test-details
b4d0: 0a 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 ................
b4e0: 09 28 63 61 72 20 74 65 73 74 2d 64 65 74 61 69 .(car test-detai
b4f0: 6c 73 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 ls))).
b500: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l
b510: 69 6e 6b 20 28 69 66 20 74 65 73 74 2d 64 65 74 ink (if test-det
b520: 61 69 6c 73 20 0a 09 09 09 09 09 09 09 09 09 09 ails ...........
b530: 09 09 09 09 28 73 74 72 69 6e 67 2d 73 75 62 73 ....(string-subs
b540: 74 69 74 75 74 65 20 20 28 63 6f 6e 63 20 6c 69 titute (conc li
b550: 6e 6b 74 72 65 65 20 22 2f 22 20 74 61 72 67 65 nktree "/" targe
b560: 74 20 22 2f 22 20 72 75 6e 2d 6e 61 6d 65 20 22 t "/" run-name "
b570: 2f 22 29 20 20 22 22 20 28 63 61 64 72 20 74 65 /") "" (cadr te
b580: 73 74 2d 64 65 74 61 69 6c 73 29 20 22 2d 22 29 st-details) "-")
b590: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
b5a0: 20 20 20 20 20 20 20 28 69 66 20 74 65 73 74 2d (if test-
b5b0: 64 65 74 61 69 6c 73 0a 09 09 09 09 09 09 09 09 details.........
b5c0: 09 09 09 28 73 3a 74 64 20 27 63 6c 61 73 73 20 ...(s:td 'class
b5d0: 73 74 61 74 75 73 0a 09 09 09 09 09 09 09 09 09 status..........
b5e0: 09 09 09 28 73 3a 61 20 27 63 6c 61 73 73 20 22 ...(s:a 'class "
b5f0: 6c 69 6e 6b 22 20 27 68 72 65 66 20 6c 69 6e 6b link" 'href link
b600: 20 73 74 61 74 75 73 20 29 29 0a 20 20 20 20 20 status )).
b610: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b620: 20 28 73 3a 74 64 20 22 22 29 29 29 29 20 09 09 (s:td "")))) ..
b630: 09 0a 09 09 09 09 09 09 09 09 09 74 65 73 74 2d ...........test-
b640: 6e 61 6d 65 73 29 29 29 29 29 29 0a 09 09 09 09 names)))))).....
b650: 20 20 28 73 6f 72 74 20 69 74 65 6d 73 20 73 74 (sort items st
b660: 72 69 6e 67 3c 3d 3f 29 29 29 29 29 29 0a 09 09 ring<=?))))))...
b670: 28 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d 70 6f (close-output-po
b680: 72 74 20 6f 75 70 29 29 0a 20 20 20 20 28 64 65 rt oup)). (de
b690: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
b6a0: 20 22 53 6b 69 70 3a 20 44 69 72 63 74 6f 72 79 "Skip: Dirctory
b6b0: 20 73 74 72 75 63 74 75 72 65 20 22 20 6c 69 6e structure " lin
b6c0: 6b 74 72 65 65 20 22 2f 22 20 74 61 72 67 65 74 ktree "/" target
b6d0: 20 22 2f 22 20 72 75 6e 2d 6e 61 6d 65 20 22 20 "/" run-name "
b6e0: 64 6f 65 73 20 6e 6f 74 20 65 78 69 73 74 2e 20 does not exist.
b6f0: 4d 65 67 61 74 65 73 74 20 77 69 6c 6c 20 6e 6f Megatest will no
b700: 74 20 63 72 65 61 74 65 20 72 75 6e 2e 68 74 6d t create run.htm
b710: 6c 22 29 29 29 29 0a 72 75 6e 73 29 29 0a 0a 28 l")))).runs))..(
b720: 64 65 66 69 6e 65 20 28 74 65 73 74 3a 63 72 65 define (test:cre
b730: 61 74 65 2d 74 61 72 67 65 74 2d 68 61 73 68 20 ate-target-hash
b740: 72 75 6e 73 20 68 65 61 64 65 72 20 6e 75 6d 6b runs header numk
b750: 65 79 73 29 0a 20 20 28 6c 65 74 20 28 28 72 65 eys). (let ((re
b760: 73 68 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 sh (make-hash-ta
b770: 62 6c 65 29 29 29 0a 20 20 20 28 66 6f 72 2d 65 ble))). (for-e
b780: 61 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 ach. (lambda
b790: 20 28 72 75 6e 29 0a 20 20 20 20 20 20 20 20 28 (run). (
b7a0: 6c 65 74 2a 20 28 28 72 75 6e 2d 6e 61 6d 65 20 let* ((run-name
b7b0: 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 (db:get-value-by
b7c0: 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 -header run head
b7d0: 65 72 20 22 72 75 6e 6e 61 6d 65 22 29 29 0a 20 er "runname")).
b7e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 74 (t
b7f0: 61 72 67 65 74 20 20 20 28 73 74 72 69 6e 67 2d arget (string-
b800: 6a 6f 69 6e 20 28 74 61 6b 65 20 28 76 65 63 74 join (take (vect
b810: 6f 72 2d 3e 6c 69 73 74 20 72 75 6e 29 20 6e 75 or->list run) nu
b820: 6d 6b 65 79 73 29 20 22 2f 22 29 29 0a 20 20 20 mkeys) "/")).
b830: 20 20 20 20 20 20 20 20 20 20 20 20 28 72 75 6e (run
b840: 2d 6c 69 73 74 20 28 68 61 73 68 2d 74 61 62 6c -list (hash-tabl
b850: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 72 65 e-ref/default re
b860: 73 68 20 74 61 72 67 65 74 20 20 23 66 29 29 29 sh target #f)))
b870: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
b880: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
b890: 28 69 66 20 28 6e 6f 74 20 72 75 6e 2d 6c 69 73 (if (not run-lis
b8a0: 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 t).
b8b0: 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c (hash-tabl
b8c0: 65 2d 73 65 74 21 20 72 65 73 68 20 74 61 72 67 e-set! resh targ
b8d0: 65 74 20 20 20 28 6c 69 73 74 20 72 75 6e 2d 6e et (list run-n
b8e0: 61 6d 65 29 29 0a 20 20 20 20 20 20 20 20 20 20 ame)).
b8f0: 20 20 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 (hash-t
b900: 61 62 6c 65 2d 73 65 74 21 20 72 65 73 68 20 74 able-set! resh t
b910: 61 72 67 65 74 20 20 20 28 63 6f 6e 73 20 72 75 arget (cons ru
b920: 6e 2d 6e 61 6d 65 20 72 75 6e 2d 6c 69 73 74 29 n-name run-list)
b930: 29 29 29 29 0a 20 20 20 20 20 20 72 75 6e 73 29 )))). runs)
b940: 0a 20 20 20 72 65 73 68 29 29 0a 0a 28 64 65 66 . resh))..(def
b950: 69 6e 65 20 28 74 65 73 74 3a 67 65 74 2d 6d 61 ine (test:get-ma
b960: 78 2d 72 75 6e 2d 63 6e 74 20 74 61 72 67 65 74 x-run-cnt target
b970: 2d 68 61 73 68 20 74 61 72 67 65 74 73 29 0a 20 -hash targets).
b980: 20 20 28 6c 65 74 2a 20 28 28 63 6e 74 20 30 20 (let* ((cnt 0
b990: 29 29 0a 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 )). (map (lamb
b9a0: 64 61 20 28 74 61 72 67 65 74 29 0a 20 20 20 20 da (target).
b9b0: 20 20 20 20 28 6c 65 74 2a 20 28 28 72 75 6e 73 (let* ((runs
b9c0: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 (hash-table-re
b9d0: 66 2f 64 65 66 61 75 6c 74 20 74 61 72 67 65 74 f/default target
b9e0: 2d 68 61 73 68 20 74 61 72 67 65 74 20 20 23 66 -hash target #f
b9f0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
ba00: 20 20 28 72 75 6e 2d 6c 65 6e 67 74 68 20 28 69 (run-length (i
ba10: 66 20 72 75 6e 73 0a 09 09 09 09 09 09 09 09 09 f runs..........
ba20: 09 09 09 09 09 09 09 28 6c 65 6e 67 74 68 20 72 .......(length r
ba30: 75 6e 73 29 0a 20 20 20 20 20 20 20 20 20 20 20 uns).
ba40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ba50: 20 20 20 20 20 20 30 29 29 29 0a 20 20 0a 20 20 0))). .
ba60: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
ba70: 28 3c 20 63 6e 74 20 72 75 6e 2d 6c 65 6e 67 74 (< cnt run-lengt
ba80: 68 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 h).
ba90: 20 20 28 73 65 74 21 20 63 6e 74 20 20 72 75 6e (set! cnt run
baa0: 2d 6c 65 6e 67 74 68 29 29 29 29 20 0a 09 09 74 -length)))) ...t
bab0: 61 72 67 65 74 73 29 20 0a 63 6e 74 29 29 0a 20 argets) .cnt)).
bac0: 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 3a 70 .(define (test:p
bad0: 61 64 2d 72 75 6e 73 20 74 61 72 67 65 74 2d 68 ad-runs target-h
bae0: 61 73 68 20 74 61 72 67 65 74 73 20 6d 61 78 2d ash targets max-
baf0: 72 6f 77 2d 6c 65 6e 67 74 68 29 0a 20 28 6d 61 row-length). (ma
bb00: 70 20 28 6c 61 6d 62 64 61 20 28 74 61 72 67 65 p (lambda (targe
bb10: 74 29 0a 20 20 20 20 20 20 20 20 28 6c 65 74 20 t). (let
bb20: 6c 6f 6f 70 20 28 28 72 75 6e 2d 6c 69 73 74 20 loop ((run-list
bb30: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
bb40: 2f 64 65 66 61 75 6c 74 20 74 61 72 67 65 74 2d /default target-
bb50: 68 61 73 68 20 74 61 72 67 65 74 20 20 23 66 29 hash target #f)
bb60: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
bb70: 20 20 28 69 66 20 28 3c 20 28 6c 65 6e 67 74 68 (if (< (length
bb80: 20 72 75 6e 2d 6c 69 73 74 29 20 6d 61 78 2d 72 run-list) max-r
bb90: 6f 77 2d 6c 65 6e 67 74 68 29 0a 20 20 20 20 20 ow-length).
bba0: 20 20 20 20 20 20 20 20 20 20 20 20 28 62 65 67 (beg
bbb0: 69 6e 20 20 0a 20 20 20 20 20 20 20 20 20 20 20 in .
bbc0: 20 20 20 20 09 09 20 28 68 61 73 68 2d 74 61 62 .. (hash-tab
bbd0: 6c 65 2d 73 65 74 21 20 74 61 72 67 65 74 2d 68 le-set! target-h
bbe0: 61 73 68 20 74 61 72 67 65 74 20 20 20 28 63 6f ash target (co
bbf0: 6e 73 20 22 22 20 72 75 6e 2d 6c 69 73 74 29 29 ns "" run-list))
bc00: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
bc10: 09 09 20 28 6c 6f 6f 70 20 28 68 61 73 68 2d 74 .. (loop (hash-t
bc20: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
bc30: 20 74 61 72 67 65 74 2d 68 61 73 68 20 74 61 72 target-hash tar
bc40: 67 65 74 20 20 23 66 29 20 29 29 29 29 29 20 0a get #f) ))))) .
bc50: 09 09 74 61 72 67 65 74 73 29 0a 20 20 20 74 61 ..targets). ta
bc60: 72 67 65 74 2d 68 61 73 68 29 0a 0a 28 64 65 66 rget-hash)..(def
bc70: 69 6e 65 20 28 74 65 73 74 3a 63 72 65 61 74 65 ine (test:create
bc80: 2d 74 61 72 67 65 74 2d 68 74 6d 6c 20 74 61 72 -target-html tar
bc90: 67 65 74 2d 68 61 73 68 20 6f 75 70 20 61 72 65 get-hash oup are
bca0: 61 2d 6e 61 6d 65 20 6c 69 6e 6b 74 72 65 65 29 a-name linktree)
bcb0: 0a 20 20 28 6c 65 74 2a 20 28 28 74 61 72 67 65 . (let* ((targe
bcc0: 74 73 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b ts (hash-table-k
bcd0: 65 79 73 20 74 61 72 67 65 74 2d 68 61 73 68 29 eys target-hash)
bce0: 29 0a 20 20 20 20 20 20 20 20 20 28 6d 61 78 2d ). (max-
bcf0: 72 6f 77 2d 6c 65 6e 67 74 68 20 28 74 65 73 74 row-length (test
bd00: 3a 67 65 74 2d 6d 61 78 2d 72 75 6e 2d 63 6e 74 :get-max-run-cnt
bd10: 20 74 61 72 67 65 74 2d 68 61 73 68 20 74 61 72 target-hash tar
bd20: 67 65 74 73 29 29 0a 20 20 20 20 20 20 20 20 20 gets)).
bd30: 28 70 61 64 2d 72 75 6e 73 2d 68 61 73 68 20 28 (pad-runs-hash (
bd40: 74 65 73 74 3a 70 61 64 2d 72 75 6e 73 20 74 61 test:pad-runs ta
bd50: 72 67 65 74 2d 68 61 73 68 20 74 61 72 67 65 74 rget-hash target
bd60: 73 20 6d 61 78 2d 72 6f 77 2d 6c 65 6e 67 74 68 s max-row-length
bd70: 29 29 29 0a 20 20 20 28 73 3a 6f 75 74 70 75 74 ))). (s:output
bd80: 2d 6e 65 77 0a 09 20 20 20 6f 75 70 0a 09 20 20 -new.. oup..
bd90: 20 28 73 3a 68 74 6d 6c 20 74 65 73 74 73 3a 63 (s:html tests:c
bda0: 73 73 2d 6a 73 63 72 69 70 74 2d 62 6c 6f 63 6b ss-jscript-block
bdb0: 20 28 74 65 73 74 73 3a 63 73 73 2d 6a 73 63 72 (tests:css-jscr
bdc0: 69 70 74 2d 62 6c 6f 63 6b 2d 63 6f 6e 64 20 23 ipt-block-cond #
bdd0: 66 29 0a 0a 09 09 20 20 20 28 73 3a 74 69 74 6c f).... (s:titl
bde0: 65 20 22 54 61 72 67 65 74 20 56 69 65 77 20 22 e "Target View "
bdf0: 20 61 72 65 61 2d 6e 61 6d 65 29 0a 09 09 20 20 area-name)...
be00: 20 28 73 3a 62 6f 64 79 0a 09 09 20 20 20 28 73 (s:body... (s
be10: 3a 68 31 20 22 54 61 72 67 65 74 20 56 69 65 77 :h1 "Target View
be20: 20 22 20 61 72 65 61 2d 6e 61 6d 65 29 0a 09 09 " area-name)...
be30: 09 09 09 28 73 3a 74 61 62 6c 65 20 27 69 64 20 ...(s:table 'id
be40: 22 4c 69 6e 6b 65 64 4c 69 73 74 31 22 20 27 62 "LinkedList1" 'b
be50: 6f 72 64 65 72 20 22 31 22 20 27 63 65 6c 6c 73 order "1" 'cells
be60: 70 61 63 69 6e 67 20 30 0a 20 20 20 20 20 20 20 pacing 0.
be70: 20 20 20 20 20 20 28 73 3a 74 72 20 27 63 6c 61 (s:tr 'cla
be80: 73 73 20 22 73 6f 6d 65 74 68 69 6e 67 22 20 0a ss "something" .
be90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
bea0: 73 3a 74 68 20 22 54 61 72 67 65 74 22 29 0a 09 s:th "Target")..
beb0: 09 09 09 09 09 09 09 28 73 3a 74 68 20 27 63 6f .......(s:th 'co
bec0: 6c 73 70 61 6e 20 6d 61 78 2d 72 6f 77 2d 6c 65 lspan max-row-le
bed0: 6e 67 74 68 20 22 52 75 6e 73 22 29 29 20 20 20 ngth "Runs"))
bee0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bef0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bf00: 20 20 20 20 20 20 20 20 20 20 20 0a 20 20 20 20 .
bf10: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 (let
bf20: 2a 20 28 28 74 62 6c 20 28 6d 61 70 20 28 6c 61 * ((tbl (map (la
bf30: 6d 62 64 61 20 28 74 61 72 67 65 74 29 0a 20 20 mbda (target).
bf40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bf50: 20 20 20 20 28 73 3a 74 72 0a 20 20 20 20 20 20 (s:tr.
bf60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bf70: 28 73 3a 74 64 20 27 63 6c 61 73 73 20 22 74 65 (s:td 'class "te
bf80: 73 74 22 20 74 61 72 67 65 74 29 0a 09 09 09 09 st" target).....
bf90: 09 09 09 09 09 09 20 20 28 6c 65 74 2a 20 28 28 ...... (let* ((
bfa0: 72 75 6e 73 20 20 28 68 61 73 68 2d 74 61 62 6c runs (hash-tabl
bfb0: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 61 e-ref/default ta
bfc0: 72 67 65 74 2d 68 61 73 68 20 74 61 72 67 65 74 rget-hash target
bfd0: 20 20 23 66 29 29 0a 09 09 09 09 09 09 09 09 09 #f))..........
bfe0: 09 09 09 09 09 20 28 72 65 73 74 2d 72 6f 77 20 ..... (rest-row
bff0: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 72 75 (map (lambda (ru
c000: 6e 29 0a 09 09 09 09 09 09 09 09 09 09 09 09 09 n)..............
c010: 09 09 09 09 09 09 09 28 69 66 20 28 65 71 75 61 .......(if (equa
c020: 6c 3f 20 72 75 6e 20 22 22 29 0a 09 09 09 09 09 l? run "")......
c030: 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 ................
c040: 09 28 73 3a 74 64 20 72 75 6e 29 0a 20 20 20 20 .(s:td run).
c050: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c060: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c070: 20 20 20 20 20 20 20 20 28 69 66 20 28 66 69 6c (if (fil
c080: 65 2d 65 78 69 73 74 73 3f 28 63 6f 6e 63 20 6c e-exists?(conc l
c090: 69 6e 6b 74 72 65 65 20 22 2f 22 20 74 61 72 67 inktree "/" targ
c0a0: 65 74 20 22 2f 22 20 72 75 6e 20 29 29 0a 09 09 et "/" run ))...
c0b0: 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 ................
c0c0: 09 09 09 09 28 62 65 67 69 6e 20 0a 09 09 09 09 ....(begin .....
c0d0: 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 ................
c0e0: 09 09 09 28 73 3a 74 64 20 0a 09 09 09 09 09 09 ...(s:td .......
c0f0: 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 ................
c100: 09 28 73 3a 61 20 27 68 72 65 66 20 28 63 6f 6e .(s:a 'href (con
c110: 63 20 20 74 61 72 67 65 74 20 22 2f 22 20 72 75 c target "/" ru
c120: 6e 20 22 2f 72 75 6e 2e 68 74 6d 6c 22 29 20 72 n "/run.html") r
c130: 75 6e 29 29 29 29 29 29 0a 09 09 09 09 09 09 09 un))))))........
c140: 09 09 09 09 09 09 09 09 09 09 09 09 09 28 72 65 .............(re
c150: 76 65 72 73 65 20 72 75 6e 73 29 29 29 29 0a 20 verse runs)))).
c160: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c170: 20 20 20 20 20 20 20 20 20 20 20 20 20 72 65 73 res
c180: 74 2d 72 6f 77 29 29 29 0a 20 20 20 20 20 20 20 t-row))).
c190: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c1a0: 20 20 20 20 20 20 20 20 20 20 20 20 74 61 72 67 targ
c1b0: 65 74 73 29 29 29 0a 20 20 20 20 20 20 20 20 20 ets))).
c1c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c1d0: 20 20 74 62 6c 29 29 29 29 29 0a 20 20 20 20 20 tbl))))).
c1e0: 20 20 20 20 20 28 63 6c 6f 73 65 2d 6f 75 74 70 (close-outp
c1f0: 75 74 2d 70 6f 72 74 20 6f 75 70 29 29 29 0a 0a ut-port oup)))..
c200: 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a .(define (tests:
c210: 63 72 65 61 74 65 2d 68 74 6d 6c 2d 74 72 65 65 create-html-tree
c220: 2d 6f 6c 64 20 6f 75 74 66 29 0a 20 20 20 28 6c -old outf). (l
c230: 65 74 2a 20 28 28 6c 6f 63 6b 66 69 6c 65 20 20 et* ((lockfile
c240: 28 63 6f 6e 63 20 6f 75 74 66 20 22 2e 6c 6f 63 (conc outf ".loc
c250: 6b 22 29 29 0a 09 20 28 72 75 6e 73 2d 74 6f 2d k")).. (runs-to-
c260: 70 72 6f 63 65 73 73 20 27 28 29 29 29 0a 20 20 process '())).
c270: 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 73 69 (if (common:si
c280: 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 20 6c mple-file-lock l
c290: 6f 63 6b 66 69 6c 65 29 0a 09 28 6c 65 74 2a 20 ockfile)..(let*
c2a0: 28 28 6c 69 6e 6b 74 72 65 65 20 20 28 63 6f 6d ((linktree (com
c2b0: 6d 6f 6e 3a 67 65 74 2d 6c 69 6e 6b 74 72 65 65 mon:get-linktree
c2c0: 29 29 0a 09 20 20 20 20 20 20 20 28 6f 75 70 20 )).. (oup
c2d0: 20 20 20 20 20 20 28 6f 70 65 6e 2d 6f 75 74 70 (open-outp
c2e0: 75 74 2d 66 69 6c 65 20 28 6f 72 20 6f 75 74 66 ut-file (or outf
c2f0: 20 28 63 6f 6e 63 20 6c 69 6e 6b 74 72 65 65 20 (conc linktree
c300: 22 2f 72 75 6e 73 2d 69 6e 64 65 78 2e 68 74 6d "/runs-index.htm
c310: 6c 22 29 29 29 29 0a 09 20 20 20 20 20 20 20 28 l")))).. (
c320: 61 72 65 61 2d 6e 61 6d 65 20 28 63 6f 6d 6d 6f area-name (commo
c330: 6e 3a 67 65 74 2d 74 65 73 74 73 75 69 74 65 2d n:get-testsuite-
c340: 6e 61 6d 65 29 29 0a 09 20 20 20 20 20 20 20 28 name)).. (
c350: 6b 65 79 73 20 20 20 20 20 20 28 72 6d 74 3a 67 keys (rmt:g
c360: 65 74 2d 6b 65 79 73 29 29 0a 09 20 20 20 20 20 et-keys))..
c370: 20 20 28 6e 75 6d 6b 65 79 73 20 20 20 28 6c 65 (numkeys (le
c380: 6e 67 74 68 20 6b 65 79 73 29 29 0a 09 20 20 20 ngth keys))..
c390: 20 20 20 20 28 72 75 6e 73 64 61 74 20 20 20 28 (runsdat (
c3a0: 72 6d 74 3a 67 65 74 2d 72 75 6e 73 20 22 25 22 rmt:get-runs "%"
c3b0: 20 23 66 20 23 66 20 28 6d 61 70 20 28 6c 61 6d #f #f (map (lam
c3c0: 62 64 61 20 28 78 29 28 6c 69 73 74 20 78 20 22 bda (x)(list x "
c3d0: 25 22 29 29 20 6b 65 79 73 29 29 29 0a 09 20 20 %")) keys)))..
c3e0: 20 20 20 20 20 28 68 65 61 64 65 72 20 20 20 20 (header
c3f0: 28 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 73 (vector-ref runs
c400: 64 61 74 20 30 29 29 0a 09 20 20 20 20 20 20 20 dat 0))..
c410: 28 72 75 6e 73 20 20 20 20 20 20 28 76 65 63 74 (runs (vect
c420: 6f 72 2d 72 65 66 20 72 75 6e 73 64 61 74 20 31 or-ref runsdat 1
c430: 29 29 0a 09 20 20 20 20 20 20 20 28 72 75 6e 74 )).. (runt
c440: 72 65 65 64 61 74 20 28 6d 61 70 20 28 6c 61 6d reedat (map (lam
c450: 62 64 61 20 28 78 29 0a 09 09 09 09 20 20 28 74 bda (x)..... (t
c460: 65 73 74 73 3a 72 75 6e 2d 72 65 63 6f 72 64 2d ests:run-record-
c470: 3e 74 65 73 74 2d 70 61 74 68 20 78 20 6e 75 6d >test-path x num
c480: 6b 65 79 73 29 29 0a 09 09 09 09 72 75 6e 73 29 keys)).....runs)
c490: 29 0a 09 20 20 20 20 20 20 20 28 72 75 6e 73 2d ).. (runs-
c4a0: 68 74 72 65 65 20 28 63 6f 6d 6d 6f 6e 3a 6c 69 htree (common:li
c4b0: 73 74 2d 3e 68 74 72 65 65 20 72 75 6e 74 72 65 st->htree runtre
c4c0: 65 64 61 74 29 29 29 0a 09 20 20 28 73 65 74 21 edat))).. (set!
c4d0: 20 72 75 6e 73 2d 74 6f 2d 70 72 6f 63 65 73 73 runs-to-process
c4e0: 20 72 75 6e 73 29 0a 09 20 20 28 73 3a 6f 75 74 runs).. (s:out
c4f0: 70 75 74 2d 6e 65 77 0a 09 20 20 20 6f 75 70 0a put-new.. oup.
c500: 09 20 20 20 28 73 3a 68 74 6d 6c 20 74 65 73 74 . (s:html test
c510: 73 3a 63 73 73 2d 6a 73 63 72 69 70 74 2d 62 6c s:css-jscript-bl
c520: 6f 63 6b 0a 09 09 20 20 20 28 73 3a 74 69 74 6c ock... (s:titl
c530: 65 20 22 53 75 6d 6d 61 72 79 20 66 6f 72 20 22 e "Summary for "
c540: 20 61 72 65 61 2d 6e 61 6d 65 29 0a 09 09 20 20 area-name)...
c550: 20 28 73 3a 62 6f 64 79 20 27 6f 6e 6c 6f 61 64 (s:body 'onload
c560: 20 22 61 64 64 45 76 65 6e 74 73 28 29 3b 22 0a "addEvents();".
c570: 09 09 09 20 20 20 28 73 3a 68 31 20 22 53 75 6d ... (s:h1 "Sum
c580: 6d 61 72 79 20 66 6f 72 20 22 20 61 72 65 61 2d mary for " area-
c590: 6e 61 6d 65 29 0a 09 09 09 20 20 20 3b 3b 20 74 name).... ;; t
c5a0: 6f 70 20 6c 69 73 74 0a 09 09 09 20 20 20 28 73 op list.... (s
c5b0: 3a 75 6c 20 27 69 64 20 22 4c 69 6e 6b 65 64 4c :ul 'id "LinkedL
c5c0: 69 73 74 31 22 20 27 63 6c 61 73 73 20 22 4c 69 ist1" 'class "Li
c5d0: 6e 6b 65 64 4c 69 73 74 22 0a 09 09 09 09 20 28 nkedList"..... (
c5e0: 73 3a 6c 69 0a 09 09 09 09 20 20 22 52 75 6e 73 s:li..... "Runs
c5f0: 22 0a 09 09 09 09 20 20 28 63 6f 6d 6d 6f 6e 3a "..... (common:
c600: 68 74 72 65 65 2d 3e 68 74 6d 6c 20 72 75 6e 73 htree->html runs
c610: 2d 68 74 72 65 65 0a 09 09 09 09 09 09 20 20 20 -htree.......
c620: 20 20 20 27 28 29 0a 09 09 09 09 09 09 20 20 20 '().......
c630: 20 20 20 28 6c 61 6d 62 64 61 20 28 78 20 70 29 (lambda (x p)
c640: 0a 09 09 09 09 09 09 09 28 6c 65 74 2a 20 28 28 ........(let* ((
c650: 74 61 72 67 2d 70 61 74 68 20 28 73 74 72 69 6e targ-path (strin
c660: 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 70 20 g-intersperse p
c670: 22 2f 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 "/")).
c680: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c690: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c6a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c6b0: 20 20 20 20 20 28 66 75 6c 6c 2d 70 61 74 68 20 (full-path
c6c0: 28 63 6f 6e 63 20 6c 69 6e 6b 74 72 65 65 20 22 (conc linktree "
c6d0: 2f 22 20 74 61 72 67 2d 70 61 74 68 29 29 0a 20 /" targ-path)).
c6e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c6f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c700: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c710: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 (r
c720: 75 6e 2d 6e 61 6d 65 20 20 28 63 61 72 20 28 72 un-name (car (r
c730: 65 76 65 72 73 65 20 70 29 29 29 29 0a 20 20 20 everse p)))).
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 20 20 20 28 69 66 20 28 61 6e 64 20 (if (and
c780: 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 (common:file-exi
c790: 73 74 73 3f 20 66 75 6c 6c 2d 70 61 74 68 29 0a sts? full-path).
c7a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c7b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c7c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c7d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c7e0: 20 20 20 28 64 69 72 65 63 74 6f 72 79 3f 20 20 (directory?
c7f0: 20 66 75 6c 6c 2d 70 61 74 68 29 0a 20 20 20 20 full-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 20 20 20 20 20 20 28 (
c840: 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 73 file-write-acces
c850: 73 3f 20 66 75 6c 6c 2d 70 61 74 68 29 29 0a 20 s? full-path)).
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 20 20 20 20 20 20 20 20 28 73 3a (s:
c8a0: 61 20 72 75 6e 2d 6e 61 6d 65 20 27 68 72 65 66 a run-name 'href
c8b0: 20 28 63 6f 6e 63 20 74 61 72 67 2d 70 61 74 68 (conc targ-path
c8c0: 20 22 2f 72 75 6e 2d 73 75 6d 6d 61 72 79 2e 68 "/run-summary.h
c8d0: 74 6d 6c 22 29 29 0a 20 20 20 20 20 20 20 20 20 tml")).
c8e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c8f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c900: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c910: 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 (begin.
c920: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c930: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c940: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c950: 20 20 20 20 20 20 20 20 20 20 20 20 28 64 65 62 (deb
c960: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
c970: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 ult-log-port* "I
c980: 4e 46 4f 3a 20 43 61 6e 27 74 20 63 72 65 61 74 NFO: Can't creat
c990: 65 20 22 20 74 61 72 67 2d 70 61 74 68 20 22 2f e " targ-path "/
c9a0: 72 75 6e 2d 73 75 6d 6d 61 72 79 2e 68 74 6d 6c run-summary.html
c9b0: 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ").
c9c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c9d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c9e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c9f0: 20 20 20 28 63 6f 6e 63 20 72 75 6e 2d 6e 61 6d (conc run-nam
ca00: 65 20 22 20 28 4e 6f 74 20 61 62 6c 65 20 74 6f e " (Not able to
ca10: 20 63 72 65 61 74 65 20 73 75 6d 6d 61 72 79 20 create summary
ca20: 61 74 20 22 20 74 61 72 67 2d 70 61 74 68 20 22 at " targ-path "
ca30: 29 22 29 29 29 29 29 29 29 29 29 29 29 0a 20 20 )"))))))))))).
ca40: 20 20 20 20 20 20 20 20 28 63 6c 6f 73 65 2d 6f (close-o
ca50: 75 74 70 75 74 2d 70 6f 72 74 20 6f 75 70 29 0a utput-port oup).
ca60: 09 20 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c . (common:simpl
ca70: 65 2d 66 69 6c 65 2d 72 65 6c 65 61 73 65 2d 6c e-file-release-l
ca80: 6f 63 6b 20 6c 6f 63 6b 66 69 6c 65 29 0a 20 20 ock lockfile).
ca90: 20 20 20 20 20 20 20 20 20 20 20 20 20 0a 09 20 ..
caa0: 20 28 66 6f 72 2d 65 61 63 68 0a 09 20 20 20 28 (for-each.. (
cab0: 6c 61 6d 62 64 61 20 28 72 75 6e 29 0a 09 20 20 lambda (run)..
cac0: 20 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 2d (let* ((test-
cad0: 73 75 62 70 61 74 68 20 28 74 65 73 74 73 3a 72 subpath (tests:r
cae0: 75 6e 2d 72 65 63 6f 72 64 2d 3e 74 65 73 74 2d un-record->test-
caf0: 70 61 74 68 20 72 75 6e 20 6e 75 6d 6b 65 79 73 path run numkeys
cb00: 29 29 0a 09 09 20 20 20 20 28 72 75 6e 2d 69 64 ))... (run-id
cb10: 20 20 20 20 20 20 20 28 64 62 3a 67 65 74 2d 76 (db:get-v
cb20: 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 alue-by-header r
cb30: 75 6e 20 68 65 61 64 65 72 20 22 69 64 22 29 29 un header "id"))
cb40: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
cb50: 20 20 20 20 20 28 72 75 6e 2d 64 69 72 20 20 20 (run-dir
cb60: 20 20 20 28 74 65 73 74 73 3a 72 75 6e 2d 72 65 (tests:run-re
cb70: 63 6f 72 64 2d 3e 74 65 73 74 2d 70 61 74 68 20 cord->test-path
cb80: 72 75 6e 20 6e 75 6d 6b 65 79 73 29 29 0a 09 09 run numkeys))...
cb90: 20 20 20 20 28 74 65 73 74 2d 64 61 74 73 20 20 (test-dats
cba0: 20 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 73 (rmt:get-tests
cbb0: 2d 66 6f 72 2d 72 75 6e 0a 09 09 09 09 20 20 20 -for-run.....
cbc0: 72 75 6e 2d 69 64 0a 20 20 20 20 20 20 20 20 20 run-id.
cbd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cbe0: 20 20 20 20 20 20 20 20 20 20 22 25 2f 22 20 20 "%/"
cbf0: 20 20 20 20 20 3b 3b 20 74 65 73 74 6e 61 6d 65 ;; testname
cc00: 70 61 74 74 0a 09 09 09 09 20 20 20 27 28 29 20 patt..... '()
cc10: 20 20 20 20 20 20 20 3b 3b 20 73 74 61 74 65 73 ;; states
cc20: 0a 09 09 09 09 20 20 20 27 28 29 20 20 20 20 20 ..... '()
cc30: 20 20 20 3b 3b 20 73 74 61 74 75 73 65 73 0a 09 ;; statuses..
cc40: 09 09 09 20 20 20 23 66 20 20 20 20 20 20 20 20 ... #f
cc50: 20 3b 3b 20 6f 66 66 73 65 74 0a 09 09 09 09 20 ;; offset.....
cc60: 20 20 23 66 20 20 20 20 20 20 20 20 20 3b 3b 20 #f ;;
cc70: 6e 75 6d 2d 74 6f 2d 67 65 74 0a 09 09 09 09 20 num-to-get.....
cc80: 20 20 23 66 20 20 20 20 20 20 20 20 20 3b 3b 20 #f ;;
cc90: 68 69 64 65 2f 6e 6f 74 2d 68 69 64 65 0a 09 09 hide/not-hide...
cca0: 09 09 20 20 20 23 66 20 20 20 20 20 20 20 20 20 .. #f
ccb0: 3b 3b 20 73 6f 72 74 2d 62 79 0a 09 09 09 09 20 ;; sort-by.....
ccc0: 20 20 23 66 20 20 20 20 20 20 20 20 20 3b 3b 20 #f ;;
ccd0: 73 6f 72 74 2d 6f 72 64 65 72 0a 09 09 09 09 20 sort-order.....
cce0: 20 20 23 66 20 20 20 20 20 20 20 20 20 3b 3b 20 #f ;;
ccf0: 27 73 68 6f 72 74 6c 69 73 74 20 20 20 20 20 20 'shortlist
cd00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cd10: 20 20 20 20 20 3b 3b 20 71 72 79 74 79 70 65 0a ;; qrytype.
cd20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cd30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cd40: 20 20 20 30 20 20 20 20 20 20 20 20 20 3b 3b 20 0 ;;
cd50: 6c 61 73 74 20 75 70 64 61 74 65 0a 09 09 09 09 last update.....
cd60: 20 20 20 23 66 29 29 0a 20 20 20 20 20 20 20 20 #f)).
cd70: 20 20 20 20 20 20 20 20 20 20 20 20 28 74 65 73 (tes
cd80: 74 73 2d 74 72 65 65 2d 64 61 74 20 28 6d 61 70 ts-tree-dat (map
cd90: 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 2d 64 (lambda (test-d
cda0: 61 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 at).
cdb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cdc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ;;
cdd0: 28 74 65 73 74 73 3a 72 75 6e 2d 72 65 63 6f 72 (tests:run-recor
cde0: 64 2d 3e 74 65 73 74 2d 70 61 74 68 20 78 20 6e d->test-path x n
cdf0: 75 6d 6b 65 79 73 29 29 0a 20 20 20 20 20 20 20 umkeys)).
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 28 6c 65 74 2a 20 28 28 74 65 73 74 2d 6e (let* ((test-n
ce30: 61 6d 65 20 20 28 64 62 3a 74 65 73 74 2d 67 65 ame (db:test-ge
ce40: 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 2d t-testname test-
ce50: 64 61 74 29 29 0a 20 20 20 20 20 20 20 20 20 20 dat)).
ce60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ce70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ce80: 20 20 20 20 20 20 28 69 74 65 6d 2d 70 61 74 68 (item-path
ce90: 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 (db:test-get-i
cea0: 74 65 6d 2d 70 61 74 68 20 74 65 73 74 2d 64 61 tem-path test-da
ceb0: 74 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 t)).
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 20 20 20 20
cee0: 20 20 20 20 28 66 75 6c 6c 2d 6e 61 6d 65 20 20 (full-name
cef0: 28 64 62 3a 74 65 73 74 2d 6d 61 6b 65 2d 66 75 (db:test-make-fu
cf00: 6c 6c 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d ll-name test-nam
cf10: 65 20 69 74 65 6d 2d 70 61 74 68 29 29 0a 20 20 e item-path)).
cf20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cf30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cf40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 70 (p
cf50: 61 74 68 2d 70 61 72 74 73 20 28 73 74 72 69 6e ath-parts (strin
cf60: 67 2d 73 70 6c 69 74 20 66 75 6c 6c 2d 6e 61 6d g-split full-nam
cf70: 65 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 e))).
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: 70 61 74 68 2d 70 61 72 74 73 29 29 0a 20 20 20 path-parts)).
cfb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cfc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cfd0: 20 20 20 20 74 65 73 74 2d 64 61 74 73 29 29 0a test-dats)).
cfe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cff0: 20 20 20 20 28 74 65 73 74 73 2d 68 74 72 65 65 (tests-htree
d000: 20 28 63 6f 6d 6d 6f 6e 3a 6c 69 73 74 2d 3e 68 (common:list->h
d010: 74 72 65 65 20 74 65 73 74 73 2d 74 72 65 65 2d tree tests-tree-
d020: 64 61 74 29 29 0a 20 20 20 20 20 20 20 20 20 20 dat)).
d030: 20 20 20 20 20 20 20 20 20 20 28 68 74 6d 6c 2d (html-
d040: 64 69 72 20 20 20 20 28 63 6f 6e 63 20 6c 69 6e dir (conc lin
d050: 6b 74 72 65 65 20 22 2f 22 20 28 73 74 72 69 6e ktree "/" (strin
d060: 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 72 75 g-intersperse ru
d070: 6e 2d 64 69 72 20 22 2f 22 29 29 29 0a 20 20 20 n-dir "/"))).
d080: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d090: 20 28 68 74 6d 6c 2d 70 61 74 68 20 20 20 28 63 (html-path (c
d0a0: 6f 6e 63 20 68 74 6d 6c 2d 64 69 72 20 22 2f 72 onc html-dir "/r
d0b0: 75 6e 2d 73 75 6d 6d 61 72 79 2e 68 74 6d 6c 22 un-summary.html"
d0c0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
d0d0: 20 20 20 20 20 20 20 28 6f 75 70 20 20 20 20 20 (oup
d0e0: 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 63 6f (if (and (co
d0f0: 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 mmon:file-exists
d100: 3f 20 68 74 6d 6c 2d 64 69 72 29 0a 20 20 20 20 ? html-dir).
d110: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d120: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d130: 20 20 20 20 20 20 28 64 69 72 65 63 74 6f 72 79 (directory
d140: 3f 20 20 20 68 74 6d 6c 2d 64 69 72 29 0a 20 20 ? html-dir).
d150: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d160: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d170: 20 20 20 20 20 20 20 20 28 66 69 6c 65 2d 77 72 (file-wr
d180: 69 74 65 2d 61 63 63 65 73 73 3f 20 68 74 6d 6c ite-access? html
d190: 2d 64 69 72 29 29 0a 20 20 20 20 20 20 20 20 20 -dir)).
d1a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d1b0: 20 20 20 20 20 20 20 20 20 20 20 20 28 6f 70 65 (ope
d1c0: 6e 2d 6f 75 74 70 75 74 2d 66 69 6c 65 20 20 68 n-output-file h
d1d0: 74 6d 6c 2d 70 61 74 68 29 0a 20 20 20 20 20 20 tml-path).
d1e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d1f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 23 #
d200: 66 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 f))).
d210: 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 72 ;; (print "r
d220: 75 6e 2d 64 69 72 3a 20 22 20 72 75 6e 2d 64 69 un-dir: " run-di
d230: 72 20 22 2c 20 74 65 73 74 73 2d 74 72 65 65 2d r ", tests-tree-
d240: 64 61 74 3a 20 22 20 74 65 73 74 73 2d 74 72 65 dat: " tests-tre
d250: 65 2d 64 61 74 29 0a 20 20 20 20 20 20 20 20 20 e-dat).
d260: 20 20 20 20 20 20 28 69 66 20 6f 75 70 0a 20 20 (if oup.
d270: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d280: 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 (begin.
d290: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 3a (s:
d2a0: 6f 75 74 70 75 74 2d 6e 65 77 0a 20 20 20 20 20 output-new.
d2b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d2c0: 20 6f 75 70 0a 20 20 20 20 20 20 20 20 20 20 20 oup.
d2d0: 20 20 20 20 20 20 20 20 20 20 20 28 73 3a 68 74 (s:ht
d2e0: 6d 6c 20 74 65 73 74 73 3a 63 73 73 2d 6a 73 63 ml tests:css-jsc
d2f0: 72 69 70 74 2d 62 6c 6f 63 6b 0a 20 20 20 20 20 ript-block.
d300: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d310: 20 20 20 20 20 20 20 20 20 28 73 3a 74 69 74 6c (s:titl
d320: 65 20 22 53 75 6d 6d 61 72 79 20 66 6f 72 20 22 e "Summary for "
d330: 20 61 72 65 61 2d 6e 61 6d 65 29 0a 20 20 20 20 area-name).
d340: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d350: 20 20 20 20 20 20 20 20 20 20 28 73 3a 62 6f 64 (s:bod
d360: 79 20 27 6f 6e 6c 6f 61 64 20 22 61 64 64 45 76 y 'onload "addEv
d370: 65 6e 74 73 28 29 3b 22 0a 20 20 20 20 20 20 20 ents();".
d380: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d390: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
d3a0: 73 3a 68 31 20 22 53 75 6d 6d 61 72 79 20 66 6f s:h1 "Summary fo
d3b0: 72 20 22 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 r " (string-inte
d3c0: 72 73 70 65 72 73 65 20 72 75 6e 2d 64 69 72 20 rsperse run-dir
d3d0: 22 2f 22 29 29 0a 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 20 20 20 20 20 20 20 3b 3b 20 74 ;; t
d400: 6f 70 20 6c 69 73 74 0a 20 20 20 20 20 20 20 20 op list.
d410: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d420: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s
d430: 3a 75 6c 20 27 69 64 20 22 4c 69 6e 6b 65 64 4c :ul 'id "LinkedL
d440: 69 73 74 31 22 20 27 63 6c 61 73 73 20 22 4c 69 ist1" 'class "Li
d450: 6e 6b 65 64 4c 69 73 74 22 0a 20 20 20 20 20 20 nkedList".
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 20 20 28 73 3a 6c 69 0a 20 20 20 20 (s:li.
d490: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d4a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d4b0: 20 20 20 20 20 20 20 20 20 22 54 65 73 74 73 22 "Tests"
d4c0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
d4d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d4e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c
d4f0: 6f 6d 6d 6f 6e 3a 68 74 72 65 65 2d 3e 68 74 6d ommon:htree->htm
d500: 6c 20 74 65 73 74 73 2d 68 74 72 65 65 0a 20 20 l tests-htree.
d510: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d520: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d530: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d540: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 27 '
d550: 28 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ().
d560: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d570: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d580: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d590: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 78 20 70 (lambda (x p
d5a0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
d5b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d5c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d5d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d5e0: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 61 72 (let* ((tar
d5f0: 67 2d 70 61 74 68 20 28 73 74 72 69 6e 67 2d 69 g-path (string-i
d600: 6e 74 65 72 73 70 65 72 73 65 20 70 20 22 2f 22 ntersperse p "/"
d610: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
d620: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d630: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d640: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d650: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 74 65 (te
d660: 73 74 2d 6e 61 6d 65 20 28 63 61 72 20 70 29 29 st-name (car p))
d670: 0a 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 20 20 20 20 20 20 20 20 28 69 74 65 6d (item
d6c0: 2d 70 61 74 68 20 3b 3b 20 28 69 66 20 28 3e 20 -path ;; (if (>
d6d0: 28 6c 65 6e 67 74 68 20 70 29 20 32 29 20 3b 3b (length p) 2) ;;
d6e0: 20 74 65 73 74 2d 6e 61 6d 65 20 2b 20 72 75 6e test-name + run
d6f0: 2d 6e 61 6d 65 0a 20 20 20 20 20 20 20 20 20 20 -name.
d700: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d710: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d720: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d730: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d740: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
d750: 65 72 73 65 20 70 20 22 2f 22 29 29 0a 20 20 20 erse p "/")).
d760: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d770: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d780: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d790: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d7a0: 20 20 20 20 20 20 20 28 66 75 6c 6c 2d 74 61 72 (full-tar
d7b0: 67 20 28 63 6f 6e 63 20 68 74 6d 6c 2d 64 69 72 g (conc html-dir
d7c0: 20 22 2f 22 20 74 61 72 67 2d 70 61 74 68 29 29 "/" targ-path))
d7d0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
d7e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d7f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d800: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d810: 20 20 20 20 20 20 20 20 20 20 20 28 73 74 64 2d (std-
d820: 66 69 6c 65 20 20 28 63 6f 6e 63 20 66 75 6c 6c file (conc full
d830: 2d 74 61 72 67 20 22 2f 74 65 73 74 2d 73 75 6d -targ "/test-sum
d840: 6d 61 72 79 2e 68 74 6d 6c 22 29 29 0a 20 20 20 mary.html")).
d850: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d860: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d870: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d880: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d890: 20 20 20 20 20 20 20 28 61 6c 74 2d 66 69 6c 65 (alt-file
d8a0: 20 20 28 63 6f 6e 63 20 66 75 6c 6c 2d 74 61 72 (conc full-tar
d8b0: 67 20 22 2f 6d 65 67 61 74 65 73 74 2d 72 6f 6c g "/megatest-rol
d8c0: 6c 75 70 2d 22 20 74 65 73 74 2d 6e 61 6d 65 20 lup-" test-name
d8d0: 22 2e 68 74 6d 6c 22 29 29 0a 20 20 20 20 20 20 ".html")).
d8e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d8f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d900: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d910: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d920: 20 20 20 20 28 68 74 6d 6c 2d 66 69 6c 65 20 28 (html-file (
d930: 69 66 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d if (common:file-
d940: 65 78 69 73 74 73 3f 20 61 6c 74 2d 66 69 6c 65 exists? alt-file
d950: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
d960: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d970: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d980: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d990: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d9a0: 20 20 20 20 20 20 20 20 20 20 20 61 6c 74 2d 66 alt-f
d9b0: 69 6c 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 ile.
d9c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d9d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d9e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d9f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
da00: 20 20 20 20 20 20 20 20 20 20 20 20 20 73 74 64 std
da10: 2d 66 69 6c 65 29 29 0a 20 20 20 20 20 20 20 20 -file)).
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 28 72 75 6e 2d 6e 61 6d 65 20 20 28 63 61 (run-name (ca
da70: 72 20 28 72 65 76 65 72 73 65 20 70 29 29 29 29 r (reverse p))))
da80: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
da90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
daa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dab0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dac0: 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 (if (and (
dad0: 6e 6f 74 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 not (common:file
dae0: 2d 65 78 69 73 74 73 3f 20 66 75 6c 6c 2d 74 61 -exists? full-ta
daf0: 72 67 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 rg)).
db00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
db10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
db20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
db30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
db40: 20 20 20 28 64 69 72 65 63 74 6f 72 79 3f 20 66 (directory? f
db50: 75 6c 6c 2d 74 61 72 67 29 0a 20 20 20 20 20 20 ull-targ).
db60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
db70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
db80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
db90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dba0: 20 20 20 20 20 20 20 20 28 66 69 6c 65 2d 77 72 (file-wr
dbb0: 69 74 65 2d 61 63 63 65 73 73 3f 20 66 75 6c 6c ite-access? full
dbc0: 2d 74 61 72 67 29 29 0a 20 20 20 20 20 20 20 20 -targ)).
dbd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dbe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dbf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dc00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dc10: 20 28 74 65 73 74 73 3a 73 75 6d 6d 61 72 69 7a (tests:summariz
dc20: 65 2d 74 65 73 74 20 0a 20 20 20 20 20 20 20 20 e-test .
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 20 20 20 20 20 20 20 20 20
dc70: 20 20 72 75 6e 2d 69 64 20 0a 20 20 20 20 20 20 run-id .
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 28 72 6d 74 3a 67 65 74 2d 74 65 73 (rmt:get-tes
dcd0: 74 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 t-id run-id test
dce0: 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 -name item-path)
dcf0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
dd00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dd10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dd20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dd30: 20 20 20 20 20 20 20 20 28 69 66 20 28 63 6f 6d (if (com
dd40: 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f mon:file-exists?
dd50: 20 66 75 6c 6c 2d 74 61 72 67 29 0a 20 20 20 20 full-targ).
dd60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dd70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dd80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dd90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dda0: 20 20 20 20 20 28 73 3a 61 20 72 75 6e 2d 6e 61 (s:a run-na
ddb0: 6d 65 20 27 68 72 65 66 20 68 74 6d 6c 2d 66 69 me 'href html-fi
ddc0: 6c 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 le).
ddd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dde0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ddf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
de00: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 62 65 (be
de10: 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 gin.
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 28 (
de60: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
de70: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
de80: 20 22 45 52 52 4f 52 3a 20 63 61 6e 27 74 20 61 "ERROR: can't a
de90: 63 63 65 73 73 20 22 20 66 75 6c 6c 2d 74 61 72 ccess " full-tar
dea0: 67 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 g).
deb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dec0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ded0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dee0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c
def0: 6f 6e 63 20 22 4e 6f 20 73 75 6d 6d 61 72 79 20 onc "No summary
df00: 66 6f 72 20 22 20 72 75 6e 2d 6e 61 6d 65 29 29 for " run-name))
df10: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
df20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
df30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
df40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
df50: 20 20 20 20 20 29 29 29 29 29 29 0a 20 20 20 20 )))))).
df60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
df70: 20 28 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d 70 (close-output-p
df80: 6f 72 74 20 6f 75 70 29 29 29 29 29 0a 20 20 20 ort oup))))).
df90: 20 20 20 20 20 20 20 20 72 75 6e 73 29 0a 20 20 runs).
dfa0: 20 20 20 20 20 20 20 20 23 74 29 0a 09 23 66 29 #t)..#f)
dfb0: 29 29 0a 0a 0a 0a 0a 0a 0a 0a 3b 3b 20 43 48 45 ))........;; CHE
dfc0: 43 4b 20 2d 20 57 41 53 20 54 48 49 53 20 41 44 CK - WAS THIS AD
dfd0: 44 45 44 20 4f 52 20 52 45 4d 4f 56 45 44 3f 20 DED OR REMOVED?
dfe0: 4d 41 4e 55 41 4c 20 4d 45 52 47 45 20 57 49 54 MANUAL MERGE WIT
dff0: 48 20 41 50 49 20 53 54 55 46 46 21 21 21 0a 3b H API STUFF!!!.;
e000: 3b 0a 3b 3b 20 67 65 74 20 61 20 70 72 65 74 74 ;.;; get a prett
e010: 79 20 74 61 62 6c 65 20 74 6f 20 73 75 6d 6d 61 y table to summa
e020: 72 69 7a 65 20 73 74 65 70 73 0a 3b 3b 0a 3b 3b rize steps.;;.;;
e030: 20 28 64 65 66 69 6e 65 20 28 64 63 6f 6d 6d 6f (define (dcommo
e040: 6e 3a 70 72 6f 63 65 73 73 2d 73 74 65 70 73 2d n:process-steps-
e050: 74 61 62 6c 65 20 73 74 65 70 73 29 3b 3b 20 64 table steps);; d
e060: 62 20 74 65 73 74 2d 69 64 20 23 21 6b 65 79 20 b test-id #!key
e070: 28 77 6f 72 6b 2d 61 72 65 61 20 23 66 29 29 0a (work-area #f)).
e080: 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 70 (define (tests:p
e090: 72 6f 63 65 73 73 2d 73 74 65 70 73 2d 74 61 62 rocess-steps-tab
e0a0: 6c 65 20 73 74 65 70 73 29 3b 3b 20 64 62 20 74 le steps);; db t
e0b0: 65 73 74 2d 69 64 20 23 21 6b 65 79 20 28 77 6f est-id #!key (wo
e0c0: 72 6b 2d 61 72 65 61 20 23 66 29 29 0a 3b 3b 20 rk-area #f)).;;
e0d0: 20 28 6c 65 74 20 28 28 73 74 65 70 73 20 20 20 (let ((steps
e0e0: 28 64 62 3a 67 65 74 2d 73 74 65 70 73 2d 66 6f (db:get-steps-fo
e0f0: 72 2d 74 65 73 74 20 64 62 20 74 65 73 74 2d 69 r-test db test-i
e100: 64 20 77 6f 72 6b 2d 61 72 65 61 3a 20 77 6f 72 d work-area: wor
e110: 6b 2d 61 72 65 61 29 29 29 0a 20 20 20 20 3b 3b k-area))). ;;
e120: 20 6f 72 67 61 6e 69 73 65 20 74 68 65 20 73 74 organise the st
e130: 65 70 73 20 66 6f 72 20 62 65 74 74 65 72 20 72 eps for better r
e140: 65 61 64 61 62 69 6c 69 74 79 0a 20 20 20 20 28 eadability. (
e150: 6c 65 74 20 28 28 72 65 73 20 28 6d 61 6b 65 2d let ((res (make-
e160: 68 61 73 68 2d 74 61 62 6c 65 29 29 29 0a 20 20 hash-table))).
e170: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 (for-each .
e180: 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 73 (lambda (s
e190: 74 65 70 29 0a 09 20 28 64 65 62 75 67 3a 70 72 tep).. (debug:pr
e1a0: 69 6e 74 20 36 20 2a 64 65 66 61 75 6c 74 2d 6c int 6 *default-l
e1b0: 6f 67 2d 70 6f 72 74 2a 20 22 73 74 65 70 3d 22 og-port* "step="
e1c0: 20 73 74 65 70 29 0a 09 20 28 6c 65 74 20 28 28 step).. (let ((
e1d0: 72 65 63 6f 72 64 20 28 68 61 73 68 2d 74 61 62 record (hash-tab
e1e0: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 0a le-ref/default .
e1f0: 09 09 09 72 65 73 20 0a 09 09 09 28 74 64 62 3a ...res ....(tdb:
e200: 73 74 65 70 2d 67 65 74 2d 73 74 65 70 6e 61 6d step-get-stepnam
e210: 65 20 73 74 65 70 29 0a 09 09 09 3b 3b 20 20 20 e step)....;;
e220: 20 20 20 20 20 20 20 20 30 20 20 20 20 20 20 20 0
e230: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 31 1
e240: 20 20 20 20 32 20 20 20 20 33 20 20 20 20 20 20 2 3
e250: 20 34 20 20 20 20 20 20 20 20 20 35 20 20 20 20 4 5
e260: 20 20 20 36 20 20 20 20 20 20 20 37 0a 09 09 09 6 7....
e270: 3b 3b 20 20 20 20 20 20 20 20 73 74 65 70 6e 61 ;; stepna
e280: 6d 65 20 20 20 20 20 20 20 20 20 20 20 20 20 20 me
e290: 20 20 73 74 61 72 74 20 65 6e 64 20 73 74 61 74 start end stat
e2a0: 75 73 20 44 75 72 61 74 69 6f 6e 20 20 4c 6f 67 us Duration Log
e2b0: 66 69 6c 65 20 43 6f 6d 6d 65 6e 74 20 20 66 69 file Comment fi
e2c0: 72 73 74 2d 69 64 0a 09 09 09 28 76 65 63 74 6f rst-id....(vecto
e2d0: 72 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d r (tdb:step-get-
e2e0: 73 74 65 70 6e 61 6d 65 20 73 74 65 70 29 20 22 stepname step) "
e2f0: 22 20 20 20 22 22 20 22 22 20 20 20 20 20 22 22 " "" "" ""
e300: 20 20 20 20 20 20 20 20 22 22 20 20 20 20 20 22 "" "
e310: 22 20 20 20 20 20 20 20 23 66 29 29 29 29 0a 09 " #f))))..
e320: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
e330: 36 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6 *default-log-p
e340: 6f 72 74 2a 20 22 72 65 63 6f 72 64 28 62 65 66 ort* "record(bef
e350: 6f 72 65 29 20 3d 20 22 20 72 65 63 6f 72 64 20 ore) = " record
e360: 0a 09 09 09 22 5c 6e 69 64 3a 20 20 20 20 20 20 ...."\nid:
e370: 20 22 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 " (tdb:step-get
e380: 2d 69 64 20 73 74 65 70 29 0a 09 09 09 22 5c 6e -id step)...."\n
e390: 73 74 65 70 6e 61 6d 65 3a 20 22 20 28 74 64 62 stepname: " (tdb
e3a0: 3a 73 74 65 70 2d 67 65 74 2d 73 74 65 70 6e 61 :step-get-stepna
e3b0: 6d 65 20 73 74 65 70 29 0a 09 09 09 22 5c 6e 73 me step)...."\ns
e3c0: 74 61 74 65 3a 20 20 20 20 22 20 28 74 64 62 3a tate: " (tdb:
e3d0: 73 74 65 70 2d 67 65 74 2d 73 74 61 74 65 20 73 step-get-state s
e3e0: 74 65 70 29 0a 09 09 09 22 5c 6e 73 74 61 74 75 tep)...."\nstatu
e3f0: 73 3a 20 20 20 22 20 28 74 64 62 3a 73 74 65 70 s: " (tdb:step
e400: 2d 67 65 74 2d 73 74 61 74 75 73 20 73 74 65 70 -get-status step
e410: 29 0a 09 09 09 22 5c 6e 74 69 6d 65 3a 20 20 20 )...."\ntime:
e420: 20 20 22 20 28 74 64 62 3a 73 74 65 70 2d 67 65 " (tdb:step-ge
e430: 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 73 74 65 t-event_time ste
e440: 70 29 29 0a 09 20 20 20 28 69 66 20 28 6e 6f 74 p)).. (if (not
e450: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 65 63 (vector-ref rec
e460: 6f 72 64 20 37 29 29 28 76 65 63 74 6f 72 2d 73 ord 7))(vector-s
e470: 65 74 21 20 72 65 63 6f 72 64 20 37 20 28 74 64 et! record 7 (td
e480: 62 3a 73 74 65 70 2d 67 65 74 2d 69 64 20 73 74 b:step-get-id st
e490: 65 70 29 29 29 20 3b 3b 20 64 6f 20 6e 6f 74 20 ep))) ;; do not
e4a0: 63 6c 6f 62 62 65 72 20 74 68 65 20 69 64 20 69 clobber the id i
e4b0: 66 20 70 72 65 76 69 6f 75 73 6c 79 20 73 65 74 f previously set
e4c0: 0a 09 20 20 20 28 63 61 73 65 20 28 73 74 72 69 .. (case (stri
e4d0: 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 74 64 62 3a ng->symbol (tdb:
e4e0: 73 74 65 70 2d 67 65 74 2d 73 74 61 74 65 20 73 step-get-state s
e4f0: 74 65 70 29 29 0a 09 20 20 20 20 20 28 28 73 74 tep)).. ((st
e500: 61 72 74 29 28 76 65 63 74 6f 72 2d 73 65 74 21 art)(vector-set!
e510: 20 72 65 63 6f 72 64 20 31 20 28 74 64 62 3a 73 record 1 (tdb:s
e520: 74 65 70 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 tep-get-event_ti
e530: 6d 65 20 73 74 65 70 29 29 0a 09 20 20 20 20 20 me step))..
e540: 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 72 65 (vector-set! re
e550: 63 6f 72 64 20 33 20 28 69 66 20 28 65 71 75 61 cord 3 (if (equa
e560: 6c 3f 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 l? (vector-ref r
e570: 65 63 6f 72 64 20 33 29 20 22 22 29 0a 09 09 09 ecord 3) "")....
e580: 09 09 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d ..(tdb:step-get-
e590: 73 74 61 74 75 73 20 73 74 65 70 29 29 29 0a 09 status step)))..
e5a0: 20 20 20 20 20 20 28 69 66 20 28 3e 20 28 73 74 (if (> (st
e5b0: 72 69 6e 67 2d 6c 65 6e 67 74 68 20 28 74 64 62 ring-length (tdb
e5c0: 3a 73 74 65 70 2d 67 65 74 2d 6c 6f 67 66 69 6c :step-get-logfil
e5d0: 65 20 73 74 65 70 29 29 0a 09 09 20 20 20 20 20 e step))...
e5e0: 30 29 0a 09 09 20 20 28 76 65 63 74 6f 72 2d 73 0)... (vector-s
e5f0: 65 74 21 20 72 65 63 6f 72 64 20 35 20 28 74 64 et! record 5 (td
e600: 62 3a 73 74 65 70 2d 67 65 74 2d 6c 6f 67 66 69 b:step-get-logfi
e610: 6c 65 20 73 74 65 70 29 29 29 29 0a 09 20 20 20 le step))))..
e620: 20 20 28 28 65 6e 64 29 20 20 0a 09 20 20 20 20 ((end) ..
e630: 20 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 72 (vector-set! r
e640: 65 63 6f 72 64 20 32 20 28 61 6e 79 2d 3e 6e 75 ecord 2 (any->nu
e650: 6d 62 65 72 20 28 74 64 62 3a 73 74 65 70 2d 67 mber (tdb:step-g
e660: 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 73 74 et-event_time st
e670: 65 70 29 29 29 0a 09 20 20 20 20 20 20 28 76 65 ep))).. (ve
e680: 63 74 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 64 ctor-set! record
e690: 20 33 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 3 (tdb:step-get
e6a0: 2d 73 74 61 74 75 73 20 73 74 65 70 29 29 0a 09 -status step))..
e6b0: 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 73 65 (vector-se
e6c0: 74 21 20 72 65 63 6f 72 64 20 34 20 28 6c 65 74 t! record 4 (let
e6d0: 20 28 28 73 74 61 72 74 74 20 28 61 6e 79 2d 3e ((startt (any->
e6e0: 6e 75 6d 62 65 72 20 28 76 65 63 74 6f 72 2d 72 number (vector-r
e6f0: 65 66 20 72 65 63 6f 72 64 20 31 29 29 29 0a 09 ef record 1)))..
e700: 09 09 09 09 20 20 28 65 6e 64 74 20 20 20 28 61 .... (endt (a
e710: 6e 79 2d 3e 6e 75 6d 62 65 72 20 28 76 65 63 74 ny->number (vect
e720: 6f 72 2d 72 65 66 20 72 65 63 6f 72 64 20 32 29 or-ref record 2)
e730: 29 29 29 0a 09 09 09 09 20 20 20 20 20 20 28 64 )))..... (d
e740: 65 62 75 67 3a 70 72 69 6e 74 20 34 20 2a 64 65 ebug:print 4 *de
e750: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
e760: 22 72 65 63 6f 72 64 5b 31 5d 3d 22 20 28 76 65 "record[1]=" (ve
e770: 63 74 6f 72 2d 72 65 66 20 72 65 63 6f 72 64 20 ctor-ref record
e780: 31 29 20 0a 09 09 09 09 09 09 20 20 20 22 2c 20 1) ....... ",
e790: 73 74 61 72 74 74 3d 22 20 73 74 61 72 74 74 20 startt=" startt
e7a0: 22 2c 20 65 6e 64 74 3d 22 20 65 6e 64 74 0a 09 ", endt=" endt..
e7b0: 09 09 09 09 09 20 20 20 22 2c 20 67 65 74 2d 73 ..... ", get-s
e7c0: 74 61 74 75 73 3a 20 22 20 28 74 64 62 3a 73 74 tatus: " (tdb:st
e7d0: 65 70 2d 67 65 74 2d 73 74 61 74 75 73 20 73 74 ep-get-status st
e7e0: 65 70 29 29 0a 09 09 09 09 20 20 20 20 20 20 28 ep))..... (
e7f0: 69 66 20 28 61 6e 64 20 28 6e 75 6d 62 65 72 3f if (and (number?
e800: 20 73 74 61 72 74 74 29 28 6e 75 6d 62 65 72 3f startt)(number?
e810: 20 65 6e 64 74 29 29 0a 09 09 09 09 09 20 20 28 endt))...... (
e820: 73 65 63 6f 6e 64 73 2d 3e 68 72 2d 6d 69 6e 2d seconds->hr-min-
e830: 73 65 63 20 28 2d 20 65 6e 64 74 20 73 74 61 72 sec (- endt star
e840: 74 74 29 29 20 22 2d 31 22 29 29 29 0a 09 20 20 tt)) "-1")))..
e850: 20 20 20 20 28 69 66 20 28 3e 20 28 73 74 72 69 (if (> (stri
e860: 6e 67 2d 6c 65 6e 67 74 68 20 28 74 64 62 3a 73 ng-length (tdb:s
e870: 74 65 70 2d 67 65 74 2d 6c 6f 67 66 69 6c 65 20 tep-get-logfile
e880: 73 74 65 70 29 29 0a 09 09 20 20 20 20 20 30 29 step))... 0)
e890: 0a 09 09 20 20 28 76 65 63 74 6f 72 2d 73 65 74 ... (vector-set
e8a0: 21 20 72 65 63 6f 72 64 20 35 20 28 74 64 62 3a ! record 5 (tdb:
e8b0: 73 74 65 70 2d 67 65 74 2d 6c 6f 67 66 69 6c 65 step-get-logfile
e8c0: 20 73 74 65 70 29 29 29 0a 09 20 20 20 20 20 20 step)))..
e8d0: 28 69 66 20 28 3e 20 28 73 74 72 69 6e 67 2d 6c (if (> (string-l
e8e0: 65 6e 67 74 68 20 28 74 64 62 3a 73 74 65 70 2d ength (tdb:step-
e8f0: 67 65 74 2d 63 6f 6d 6d 65 6e 74 20 73 74 65 70 get-comment step
e900: 29 29 0a 09 09 20 20 20 20 20 30 29 0a 09 09 20 ))... 0)...
e910: 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 72 65 (vector-set! re
e920: 63 6f 72 64 20 36 20 28 74 64 62 3a 73 74 65 70 cord 6 (tdb:step
e930: 2d 67 65 74 2d 63 6f 6d 6d 65 6e 74 20 73 74 65 -get-comment ste
e940: 70 29 29 29 29 0a 09 20 20 20 20 20 28 65 6c 73 p)))).. (els
e950: 65 0a 09 20 20 20 20 20 20 28 76 65 63 74 6f 72 e.. (vector
e960: 2d 73 65 74 21 20 72 65 63 6f 72 64 20 32 20 28 -set! record 2 (
e970: 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 61 tdb:step-get-sta
e980: 74 65 20 73 74 65 70 29 29 0a 09 20 20 20 20 20 te step))..
e990: 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 72 65 (vector-set! re
e9a0: 63 6f 72 64 20 33 20 28 74 64 62 3a 73 74 65 70 cord 3 (tdb:step
e9b0: 2d 67 65 74 2d 73 74 61 74 75 73 20 73 74 65 70 -get-status step
e9c0: 29 29 0a 09 20 20 20 20 20 20 28 76 65 63 74 6f )).. (vecto
e9d0: 72 2d 73 65 74 21 20 72 65 63 6f 72 64 20 34 20 r-set! record 4
e9e0: 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 65 76 (tdb:step-get-ev
e9f0: 65 6e 74 5f 74 69 6d 65 20 73 74 65 70 29 29 0a ent_time step)).
ea00: 09 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 73 . (vector-s
ea10: 65 74 21 20 72 65 63 6f 72 64 20 36 20 28 74 64 et! record 6 (td
ea20: 62 3a 73 74 65 70 2d 67 65 74 2d 63 6f 6d 6d 65 b:step-get-comme
ea30: 6e 74 20 73 74 65 70 29 29 29 29 0a 09 20 20 20 nt step))))..
ea40: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
ea50: 20 72 65 73 20 28 74 64 62 3a 73 74 65 70 2d 67 res (tdb:step-g
ea60: 65 74 2d 73 74 65 70 6e 61 6d 65 20 73 74 65 70 et-stepname step
ea70: 29 20 72 65 63 6f 72 64 29 0a 09 20 20 20 28 64 ) record).. (d
ea80: 65 62 75 67 3a 70 72 69 6e 74 20 36 20 2a 64 65 ebug:print 6 *de
ea90: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
eaa0: 22 72 65 63 6f 72 64 28 61 66 74 65 72 29 20 20 "record(after)
eab0: 3d 20 22 20 72 65 63 6f 72 64 20 0a 09 09 09 22 = " record ...."
eac0: 5c 6e 69 64 3a 20 20 20 20 20 20 20 22 20 28 74 \nid: " (t
ead0: 64 62 3a 73 74 65 70 2d 67 65 74 2d 69 64 20 73 db:step-get-id s
eae0: 74 65 70 29 0a 09 09 09 22 5c 6e 73 74 65 70 6e tep)...."\nstepn
eaf0: 61 6d 65 3a 20 22 20 28 74 64 62 3a 73 74 65 70 ame: " (tdb:step
eb00: 2d 67 65 74 2d 73 74 65 70 6e 61 6d 65 20 73 74 -get-stepname st
eb10: 65 70 29 0a 09 09 09 22 5c 6e 73 74 61 74 65 3a ep)...."\nstate:
eb20: 20 20 20 20 22 20 28 74 64 62 3a 73 74 65 70 2d " (tdb:step-
eb30: 67 65 74 2d 73 74 61 74 65 20 73 74 65 70 29 0a get-state step).
eb40: 09 09 09 22 5c 6e 73 74 61 74 75 73 3a 20 20 20 ..."\nstatus:
eb50: 22 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d " (tdb:step-get-
eb60: 73 74 61 74 75 73 20 73 74 65 70 29 0a 09 09 09 status step)....
eb70: 22 5c 6e 74 69 6d 65 3a 20 20 20 20 20 22 20 28 "\ntime: " (
eb80: 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 65 76 65 tdb:step-get-eve
eb90: 6e 74 5f 74 69 6d 65 20 73 74 65 70 29 29 29 29 nt_time step))))
eba0: 0a 20 20 20 20 20 20 20 3b 3b 20 28 65 6c 73 65 . ;; (else
ebb0: 20 20 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 (vector-set!
ebc0: 72 65 63 6f 72 64 20 31 20 28 74 64 62 3a 73 74 record 1 (tdb:st
ebd0: 65 70 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 6d ep-get-event_tim
ebe0: 65 20 73 74 65 70 29 29 29 0a 20 20 20 20 20 20 e step))).
ebf0: 20 28 73 6f 72 74 20 73 74 65 70 73 20 28 6c 61 (sort steps (la
ec00: 6d 62 64 61 20 28 61 20 62 29 0a 09 09 20 20 20 mbda (a b)...
ec10: 20 20 28 63 6f 6e 64 0a 09 09 20 20 20 20 20 20 (cond...
ec20: 28 28 3c 20 20 20 28 74 64 62 3a 73 74 65 70 2d ((< (tdb:step-
ec30: 67 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 61 get-event_time a
ec40: 29 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 65 )(tdb:step-get-e
ec50: 76 65 6e 74 5f 74 69 6d 65 20 62 29 29 20 23 74 vent_time b)) #t
ec60: 29 0a 09 09 20 20 20 20 20 20 28 28 65 71 3f 20 )... ((eq?
ec70: 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 65 76 (tdb:step-get-ev
ec80: 65 6e 74 5f 74 69 6d 65 20 61 29 28 74 64 62 3a ent_time a)(tdb:
ec90: 73 74 65 70 2d 67 65 74 2d 65 76 65 6e 74 5f 74 step-get-event_t
eca0: 69 6d 65 20 62 29 29 20 0a 09 09 20 20 20 20 20 ime b)) ...
ecb0: 20 20 28 3c 20 20 20 28 74 64 62 3a 73 74 65 70 (< (tdb:step
ecc0: 2d 67 65 74 2d 69 64 20 61 29 20 20 20 20 20 20 -get-id a)
ecd0: 20 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d (tdb:step-get-
ece0: 69 64 20 62 29 29 29 0a 09 09 20 20 20 20 20 20 id b)))...
ecf0: 28 65 6c 73 65 20 23 66 29 29 29 29 29 0a 20 20 (else #f))))).
ed00: 20 20 20 20 72 65 73 29 29 0a 0a 3b 3b 20 0a 3b res))..;; .;
ed10: 3b 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 ;.(define (tests
ed20: 3a 67 65 74 2d 63 6f 6d 70 72 65 73 73 65 64 2d :get-compressed-
ed30: 73 74 65 70 73 20 72 75 6e 2d 69 64 20 74 65 73 steps run-id tes
ed40: 74 2d 69 64 29 0a 20 20 28 6c 65 74 2a 20 28 28 t-id). (let* ((
ed50: 73 74 65 70 73 2d 64 61 74 61 20 20 28 72 6d 74 steps-data (rmt
ed60: 3a 67 65 74 2d 73 74 65 70 73 2d 66 6f 72 2d 74 :get-steps-for-t
ed70: 65 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d est run-id test-
ed80: 69 64 29 29 20 3b 3b 20 20 20 20 20 20 30 20 20 id)) ;; 0
ed90: 20 20 20 20 20 31 20 20 20 20 32 20 20 20 20 33 1 2 3
eda0: 20 20 20 20 20 20 20 34 20 20 20 20 20 20 20 35 4 5
edb0: 20 20 20 20 20 20 20 36 20 20 20 20 20 20 37 20 6 7
edc0: 20 20 20 20 20 20 0a 09 20 28 63 6f 6d 70 72 73 .. (comprs
edd0: 74 65 70 73 20 20 28 74 65 73 74 73 3a 70 72 6f teps (tests:pro
ede0: 63 65 73 73 2d 73 74 65 70 73 2d 74 61 62 6c 65 cess-steps-table
edf0: 20 73 74 65 70 73 2d 64 61 74 61 29 29 29 20 3b steps-data))) ;
ee00: 3b 20 23 3c 73 74 65 70 6e 61 6d 65 20 73 74 61 ; #<stepname sta
ee10: 72 74 20 65 6e 64 20 73 74 61 74 75 73 20 44 75 rt end status Du
ee20: 72 61 74 69 6f 6e 20 4c 6f 67 66 69 6c 65 20 43 ration Logfile C
ee30: 6f 6d 6d 65 6e 74 20 69 64 3e 0a 20 20 20 20 28 omment id>. (
ee40: 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 78 29 0a map (lambda (x).
ee50: 09 20 20 20 3b 3b 20 74 61 6b 65 20 61 64 76 61 . ;; take adva
ee60: 6e 74 61 67 65 20 6f 66 20 74 68 65 20 5c 6e 20 ntage of the \n
ee70: 6f 6e 20 74 69 6d 65 2d 3e 73 74 72 69 6e 67 0a on time->string.
ee80: 09 20 20 20 28 76 65 63 74 6f 72 20 20 20 20 3b . (vector ;
ee90: 3b 20 77 65 20 61 72 65 20 63 6f 6e 73 74 72 75 ; we are constru
eea0: 63 74 69 6e 67 20 62 61 73 69 63 61 6c 6c 79 20 cting basically
eeb0: 74 68 65 20 6f 72 69 67 69 6e 61 6c 20 76 65 63 the original vec
eec0: 74 6f 72 20 62 75 74 20 63 6f 6c 6c 61 70 73 69 tor but collapsi
eed0: 6e 67 20 73 74 61 72 74 20 65 6e 64 20 72 65 63 ng start end rec
eee0: 6f 72 64 73 0a 09 20 20 20 20 28 76 65 63 74 6f ords.. (vecto
eef0: 72 2d 72 65 66 20 78 20 30 29 20 20 20 20 20 20 r-ref x 0)
ef00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ef10: 20 20 20 20 20 20 20 20 3b 3b 20 69 64 20 20 20 ;; id
ef20: 20 20 20 20 20 30 0a 09 20 20 20 20 28 6c 65 74 0.. (let
ef30: 20 28 28 73 20 28 76 65 63 74 6f 72 2d 72 65 66 ((s (vector-ref
ef40: 20 78 20 31 29 29 29 0a 09 20 20 20 20 20 20 28 x 1))).. (
ef50: 69 66 20 28 6e 75 6d 62 65 72 3f 20 73 29 28 73 if (number? s)(s
ef60: 65 63 6f 6e 64 73 2d 3e 74 69 6d 65 2d 73 74 72 econds->time-str
ef70: 69 6e 67 20 73 29 20 73 29 29 20 3b 3b 20 73 74 ing s) s)) ;; st
ef80: 61 72 74 74 69 6d 65 20 31 0a 09 20 20 20 20 28 arttime 1.. (
ef90: 6c 65 74 20 28 28 73 20 28 76 65 63 74 6f 72 2d let ((s (vector-
efa0: 72 65 66 20 78 20 32 29 29 29 0a 09 20 20 20 20 ref x 2)))..
efb0: 20 20 28 69 66 20 28 6e 75 6d 62 65 72 3f 20 73 (if (number? s
efc0: 29 28 73 65 63 6f 6e 64 73 2d 3e 74 69 6d 65 2d )(seconds->time-
efd0: 73 74 72 69 6e 67 20 73 29 20 73 29 29 20 3b 3b string s) s)) ;;
efe0: 20 65 6e 64 74 69 6d 65 20 20 20 32 0a 09 20 20 endtime 2..
eff0: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 78 20 (vector-ref x
f000: 33 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3)
f010: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
f020: 3b 3b 20 73 74 61 74 75 73 20 20 20 20 33 20 20 ;; status 3
f030: 20 20 0a 09 20 20 20 20 28 76 65 63 74 6f 72 2d .. (vector-
f040: 72 65 66 20 78 20 34 29 20 20 20 20 20 20 20 20 ref x 4)
f050: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
f060: 20 20 20 20 20 20 3b 3b 20 64 75 72 61 74 69 6f ;; duratio
f070: 6e 20 20 34 0a 09 20 20 20 20 28 76 65 63 74 6f n 4.. (vecto
f080: 72 2d 72 65 66 20 78 20 35 29 20 20 20 20 20 20 r-ref x 5)
f090: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
f0a0: 20 20 20 20 20 20 20 20 3b 3b 20 6c 6f 67 66 69 ;; logfi
f0b0: 6c 65 20 20 20 35 0a 09 20 20 20 20 28 76 65 63 le 5.. (vec
f0c0: 74 6f 72 2d 72 65 66 20 78 20 36 29 20 20 20 20 tor-ref x 6)
f0d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
f0e0: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 63 6f 6d ;; com
f0f0: 6d 65 6e 74 20 20 20 36 0a 09 20 20 20 20 28 76 ment 6.. (v
f100: 65 63 74 6f 72 2d 72 65 66 20 78 20 37 29 29 29 ector-ref x 7)))
f110: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
f120: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 69 ;; i
f130: 64 20 20 20 20 20 20 20 20 37 0a 09 20 28 73 6f d 7.. (so
f140: 72 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 76 rt (hash-table-v
f150: 61 6c 75 65 73 20 63 6f 6d 70 72 73 74 65 70 73 alues comprsteps
f160: 29 0a 09 20 20 20 20 20 20 20 28 6c 61 6d 62 64 ).. (lambd
f170: 61 20 28 61 20 62 29 0a 09 09 20 28 6c 65 74 20 a (a b)... (let
f180: 28 28 74 69 6d 65 2d 61 20 28 76 65 63 74 6f 72 ((time-a (vector
f190: 2d 72 65 66 20 61 20 31 29 29 0a 09 09 20 20 20 -ref a 1))...
f1a0: 20 20 20 20 28 74 69 6d 65 2d 62 20 28 76 65 63 (time-b (vec
f1b0: 74 6f 72 2d 72 65 66 20 62 20 31 29 29 0a 09 09 tor-ref b 1))...
f1c0: 20 20 20 20 20 20 20 28 69 64 2d 61 20 20 20 28 (id-a (
f1d0: 76 65 63 74 6f 72 2d 72 65 66 20 61 20 37 29 29 vector-ref a 7))
f1e0: 0a 09 09 20 20 20 20 20 20 20 28 69 64 2d 62 20 ... (id-b
f1f0: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 62 20 (vector-ref b
f200: 37 29 29 29 0a 09 09 20 20 20 28 69 66 20 28 61 7)))... (if (a
f210: 6e 64 20 28 6e 75 6d 62 65 72 3f 20 74 69 6d 65 nd (number? time
f220: 2d 61 29 28 6e 75 6d 62 65 72 3f 20 74 69 6d 65 -a)(number? time
f230: 2d 62 29 29 0a 09 09 20 20 20 20 20 20 20 28 69 -b))... (i
f240: 66 20 28 3c 20 74 69 6d 65 2d 61 20 74 69 6d 65 f (< time-a time
f250: 2d 62 29 0a 09 09 09 20 20 20 23 74 0a 09 09 09 -b).... #t....
f260: 20 20 20 28 69 66 20 28 65 71 3f 20 74 69 6d 65 (if (eq? time
f270: 2d 61 20 74 69 6d 65 2d 62 29 0a 09 09 09 20 20 -a time-b)....
f280: 20 20 20 20 20 28 3c 20 69 64 2d 61 20 69 64 2d (< id-a id-
f290: 62 29 0a 09 09 09 20 20 20 20 20 20 20 3b 3b 20 b).... ;;
f2a0: 28 73 74 72 69 6e 67 3c 3f 20 28 63 6f 6e 63 20 (string<? (conc
f2b0: 28 76 65 63 74 6f 72 2d 72 65 66 20 61 20 32 29 (vector-ref a 2)
f2c0: 29 0a 09 09 09 20 20 20 20 20 20 20 3b 3b 09 20 ).... ;;.
f2d0: 20 20 20 28 63 6f 6e 63 20 28 76 65 63 74 6f 72 (conc (vector
f2e0: 2d 72 65 66 20 62 20 32 29 29 29 0a 09 09 09 20 -ref b 2)))....
f2f0: 20 20 20 20 20 20 23 66 29 29 0a 09 09 20 20 20 #f))...
f300: 20 20 20 20 28 73 74 72 69 6e 67 3c 3f 20 28 63 (string<? (c
f310: 6f 6e 63 20 74 69 6d 65 2d 61 29 28 63 6f 6e 63 onc time-a)(conc
f320: 20 74 69 6d 65 2d 62 29 29 29 29 29 29 29 29 29 time-b)))))))))
f330: 0a 0a 0a 3b 3b 20 53 61 76 65 20 74 65 73 74 20 ...;; Save test
f340: 73 74 61 74 65 20 61 6e 64 20 73 74 61 74 75 73 state and status
f350: 20 69 6e 20 74 6f 20 61 20 66 69 6c 65 20 2e 66 in to a file .f
f360: 69 6e 61 6c 2d 73 74 61 74 75 73 20 69 6e 20 74 inal-status in t
f370: 68 65 20 74 65 73 74 20 64 69 72 65 63 74 6f 72 he test director
f380: 79 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 65 y.;;.(define (te
f390: 73 74 73 3a 73 61 76 65 2d 66 69 6e 61 6c 2d 73 sts:save-final-s
f3a0: 74 61 74 75 73 20 72 75 6e 2d 69 64 20 74 65 73 tatus run-id tes
f3b0: 74 2d 69 64 29 0a 20 20 28 6c 65 74 2a 20 28 28 t-id). (let* ((
f3c0: 74 65 73 74 2d 64 61 74 20 20 28 72 6d 74 3a 67 test-dat (rmt:g
f3d0: 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d et-test-info-by-
f3e0: 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 id run-id test-i
f3f0: 64 29 29 0a 09 20 28 6f 75 74 2d 64 69 72 20 20 d)).. (out-dir
f400: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 (db:test-get-ru
f410: 6e 64 69 72 20 74 65 73 74 2d 64 61 74 29 29 0a ndir test-dat)).
f420: 09 20 28 73 74 61 74 75 73 2d 66 69 6c 65 20 20 . (status-file
f430: 28 63 6f 6e 63 20 6f 75 74 2d 64 69 72 20 22 2f (conc out-dir "/
f440: 2e 66 69 6e 61 6c 2d 73 74 61 74 75 73 22 29 29 .final-status"))
f450: 0a 20 20 20 29 0a 20 20 20 20 3b 3b 20 66 69 72 . ). ;; fir
f460: 73 74 20 76 65 72 69 66 79 20 77 65 20 61 72 65 st verify we are
f470: 20 61 62 6c 65 20 74 6f 20 77 72 69 74 65 20 74 able to write t
f480: 68 65 20 6f 75 74 70 75 74 20 66 69 6c 65 0a 20 he output file.
f490: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 66 69 6c (if (not (fil
f4a0: 65 2d 77 72 69 74 65 2d 61 63 63 65 73 73 3f 20 e-write-access?
f4b0: 6f 75 74 2d 64 69 72 29 29 0a 09 20 20 20 20 28 out-dir)).. (
f4c0: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
f4d0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
f4e0: 20 22 45 52 52 4f 52 3a 20 63 61 6e 6e 6f 74 20 "ERROR: cannot
f4f0: 77 72 69 74 65 20 2e 66 69 6e 61 6c 2d 73 74 61 write .final-sta
f500: 74 75 73 20 74 6f 20 22 20 6f 75 74 2d 64 69 72 tus to " out-dir
f510: 29 0a 09 20 20 20 20 28 6c 65 74 2a 20 0a 20 20 ).. (let* .
f520: 20 20 20 20 20 20 20 28 28 6f 75 74 70 20 20 20 ((outp
f530: 20 20 20 28 6f 70 65 6e 2d 6f 75 74 70 75 74 2d (open-output-
f540: 66 69 6c 65 20 73 74 61 74 75 73 2d 66 69 6c 65 file status-file
f550: 29 29 0a 09 20 20 20 20 20 20 20 28 73 74 61 74 )).. (stat
f560: 75 73 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 us (db:test-g
f570: 65 74 2d 73 74 61 74 75 73 20 20 20 74 65 73 74 et-status test
f580: 2d 64 61 74 29 29 0a 20 20 20 20 20 20 20 20 20 -dat)).
f590: 28 73 74 61 74 65 20 20 20 20 20 28 64 62 3a 74 (state (db:t
f5a0: 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 20 20 est-get-state
f5b0: 20 74 65 73 74 2d 64 61 74 29 29 29 0a 20 20 20 test-dat))).
f5c0: 20 20 20 20 20 28 66 70 72 69 6e 74 66 20 6f 75 (fprintf ou
f5d0: 74 70 20 22 7e 53 5c 6e 22 20 73 74 61 74 65 29 tp "~S\n" state)
f5e0: 20 0a 20 20 20 20 20 20 20 20 28 66 70 72 69 6e . (fprin
f5f0: 74 66 20 6f 75 74 70 20 22 7e 53 5c 6e 22 20 73 tf outp "~S\n" s
f600: 74 61 74 75 73 29 20 0a 20 20 20 20 20 20 20 20 tatus) .
f610: 28 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d 70 6f (close-output-po
f620: 72 74 20 6f 75 74 70 29 29 29 29 29 0a 0a 0a 3b rt outp)))))...;
f630: 3b 20 73 75 6d 6d 61 72 69 7a 65 20 74 65 73 74 ; summarize test
f640: 20 69 6e 20 74 6f 20 61 20 66 69 6c 65 20 74 65 in to a file te
f650: 73 74 2d 73 75 6d 6d 61 72 79 2e 68 74 6d 6c 20 st-summary.html
f660: 69 6e 20 74 68 65 20 74 65 73 74 20 64 69 72 65 in the test dire
f670: 63 74 6f 72 79 0a 3b 3b 0a 28 64 65 66 69 6e 65 ctory.;;.(define
f680: 20 28 74 65 73 74 73 3a 73 75 6d 6d 61 72 69 7a (tests:summariz
f690: 65 2d 74 65 73 74 20 72 75 6e 2d 69 64 20 74 65 e-test run-id te
f6a0: 73 74 2d 69 64 29 0a 20 20 28 6c 65 74 2a 20 28 st-id). (let* (
f6b0: 28 74 65 73 74 2d 64 61 74 20 20 28 72 6d 74 3a (test-dat (rmt:
f6c0: 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 get-test-info-by
f6d0: 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d -id run-id test-
f6e0: 69 64 29 29 0a 09 20 28 6f 75 74 2d 64 69 72 20 id)).. (out-dir
f6f0: 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 (db:test-get-r
f700: 75 6e 64 69 72 20 74 65 73 74 2d 64 61 74 29 29 undir test-dat))
f710: 0a 09 20 28 6f 75 74 2d 66 69 6c 65 20 20 28 63 .. (out-file (c
f720: 6f 6e 63 20 6f 75 74 2d 64 69 72 20 22 2f 74 65 onc out-dir "/te
f730: 73 74 2d 73 75 6d 6d 61 72 79 2e 68 74 6d 6c 22 st-summary.html"
f740: 29 29 29 0a 20 20 20 20 3b 3b 20 66 69 72 73 74 ))). ;; first
f750: 20 76 65 72 69 66 79 20 77 65 20 61 72 65 20 61 verify we are a
f760: 62 6c 65 20 74 6f 20 77 72 69 74 65 20 74 68 65 ble to write the
f770: 20 6f 75 74 70 75 74 20 66 69 6c 65 0a 20 20 20 output file.
f780: 20 28 69 66 20 28 6e 6f 74 20 28 66 69 6c 65 2d (if (not (file-
f790: 77 72 69 74 65 2d 61 63 63 65 73 73 3f 20 6f 75 write-access? ou
f7a0: 74 2d 64 69 72 29 29 0a 09 28 64 65 62 75 67 3a t-dir))..(debug:
f7b0: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
f7c0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 52 52 4f -log-port* "ERRO
f7d0: 52 3a 20 63 61 6e 6e 6f 74 20 77 72 69 74 65 20 R: cannot write
f7e0: 74 65 73 74 2d 73 75 6d 6d 61 72 79 2e 68 74 6d test-summary.htm
f7f0: 6c 20 74 6f 20 22 20 6f 75 74 2d 64 69 72 29 0a l to " out-dir).
f800: 09 28 6c 65 74 2a 20 28 3b 3b 20 28 73 74 65 70 .(let* (;; (step
f810: 73 2d 64 61 74 20 28 72 6d 74 3a 67 65 74 2d 73 s-dat (rmt:get-s
f820: 74 65 70 73 2d 66 6f 72 2d 74 65 73 74 20 72 75 teps-for-test ru
f830: 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 29 0a 09 n-id test-id))..
f840: 20 20 20 20 20 20 20 28 74 65 73 74 2d 6e 61 6d (test-nam
f850: 65 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 e (db:test-get-t
f860: 65 73 74 6e 61 6d 65 20 74 65 73 74 2d 64 61 74 estname test-dat
f870: 29 29 0a 09 20 20 20 20 20 20 20 28 69 74 65 6d )).. (item
f880: 2d 70 61 74 68 20 28 64 62 3a 74 65 73 74 2d 67 -path (db:test-g
f890: 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 65 73 et-item-path tes
f8a0: 74 2d 64 61 74 29 29 0a 09 20 20 20 20 20 20 20 t-dat))..
f8b0: 28 66 75 6c 6c 2d 6e 61 6d 65 20 28 64 62 3a 74 (full-name (db:t
f8c0: 65 73 74 2d 6d 61 6b 65 2d 66 75 6c 6c 2d 6e 61 est-make-full-na
f8d0: 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 me test-name ite
f8e0: 6d 2d 70 61 74 68 29 29 0a 09 20 20 20 20 20 20 m-path))..
f8f0: 20 28 6f 75 70 20 20 20 20 20 20 20 28 6f 70 65 (oup (ope
f900: 6e 2d 6f 75 74 70 75 74 2d 66 69 6c 65 20 6f 75 n-output-file ou
f910: 74 2d 66 69 6c 65 29 29 0a 09 20 20 20 20 20 20 t-file))..
f920: 20 28 73 74 61 74 75 73 20 20 20 20 28 64 62 3a (status (db:
f930: 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 73 20 test-get-status
f940: 20 20 74 65 73 74 2d 64 61 74 29 29 0a 09 20 20 test-dat))..
f950: 20 20 20 20 20 28 63 6f 6c 6f 72 20 20 20 20 20 (color
f960: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 6f 6c 6f (common:get-colo
f970: 72 2d 66 72 6f 6d 2d 73 74 61 74 75 73 20 73 74 r-from-status st
f980: 61 74 75 73 29 29 0a 09 20 20 20 20 20 20 20 28 atus)).. (
f990: 6c 6f 67 66 20 20 20 20 20 20 28 64 62 3a 74 65 logf (db:te
f9a0: 73 74 2d 67 65 74 2d 66 69 6e 61 6c 5f 6c 6f 67 st-get-final_log
f9b0: 66 20 74 65 73 74 2d 64 61 74 29 29 0a 09 20 20 f test-dat))..
f9c0: 20 20 20 20 20 28 73 74 65 70 73 2d 64 61 74 20 (steps-dat
f9d0: 28 74 65 73 74 73 3a 67 65 74 2d 63 6f 6d 70 72 (tests:get-compr
f9e0: 65 73 73 65 64 2d 73 74 65 70 73 20 72 75 6e 2d essed-steps run-
f9f0: 69 64 20 74 65 73 74 2d 69 64 29 29 29 0a 09 20 id test-id)))..
fa00: 20 3b 3b 20 28 64 63 6f 6d 6d 6f 6e 3a 67 65 74 ;; (dcommon:get
fa10: 2d 63 6f 6d 70 72 65 73 73 65 64 2d 73 74 65 70 -compressed-step
fa20: 73 20 23 66 20 31 20 33 30 30 34 35 29 0a 09 20 s #f 1 30045)..
fa30: 20 3b 3b 20 28 23 28 22 77 61 73 74 69 6e 67 5f ;; (#("wasting_
fa40: 74 69 6d 65 22 20 22 32 33 3a 33 36 3a 31 33 22 time" "23:36:13"
fa50: 20 22 32 33 3a 33 36 3a 32 31 22 20 22 30 22 20 "23:36:21" "0"
fa60: 22 38 2e 30 73 22 20 22 77 61 73 74 69 6e 67 5f "8.0s" "wasting_
fa70: 74 69 6d 65 2e 6c 6f 67 22 29 29 0a 09 0a 09 20 time.log"))....
fa80: 20 28 73 3a 6f 75 74 70 75 74 2d 6e 65 77 0a 09 (s:output-new..
fa90: 20 20 20 6f 75 70 0a 09 20 20 20 28 73 3a 68 74 oup.. (s:ht
faa0: 6d 6c 0a 09 20 20 20 20 28 73 3a 74 69 74 6c 65 ml.. (s:title
fab0: 20 22 53 75 6d 6d 61 72 79 20 66 6f 72 20 22 20 "Summary for "
fac0: 66 75 6c 6c 2d 6e 61 6d 65 29 0a 09 20 20 20 20 full-name)..
fad0: 28 73 3a 62 6f 64 79 20 0a 09 20 20 20 20 20 28 (s:body .. (
fae0: 73 3a 68 32 20 22 53 75 6d 6d 61 72 79 20 66 6f s:h2 "Summary fo
faf0: 72 20 22 20 66 75 6c 6c 2d 6e 61 6d 65 29 0a 09 r " full-name)..
fb00: 20 20 20 20 20 28 73 3a 74 61 62 6c 65 20 27 63 (s:table 'c
fb10: 65 6c 6c 73 70 61 63 69 6e 67 20 22 30 22 20 27 ellspacing "0" '
fb20: 62 6f 72 64 65 72 20 22 31 22 0a 09 09 20 20 20 border "1"...
fb30: 20 20 20 28 73 3a 74 72 20 28 73 3a 74 64 20 22 (s:tr (s:td "
fb40: 72 75 6e 20 69 64 22 29 20 20 20 28 73 3a 74 64 run id") (s:td
fb50: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 (db:test-get-ru
fb60: 6e 5f 69 64 20 20 20 74 65 73 74 2d 64 61 74 29 n_id test-dat)
fb70: 29 0a 09 09 09 20 20 20 20 28 73 3a 74 64 20 22 ).... (s:td "
fb80: 74 65 73 74 20 69 64 22 29 20 20 28 73 3a 74 64 test id") (s:td
fb90: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 (db:test-get-id
fba0: 20 20 20 20 20 20 20 74 65 73 74 2d 64 61 74 29 test-dat)
fbb0: 29 29 0a 09 09 20 20 20 20 20 20 28 73 3a 74 72 ))... (s:tr
fbc0: 20 28 73 3a 74 64 20 22 74 65 73 74 6e 61 6d 65 (s:td "testname
fbd0: 22 29 20 28 73 3a 74 64 20 74 65 73 74 2d 6e 61 ") (s:td test-na
fbe0: 6d 65 29 0a 09 09 09 20 20 20 20 28 73 3a 74 64 me).... (s:td
fbf0: 20 22 69 74 65 6d 70 61 74 68 22 29 20 28 73 3a "itempath") (s:
fc00: 74 64 20 69 74 65 6d 2d 70 61 74 68 29 29 0a 09 td item-path))..
fc10: 09 20 20 20 20 20 20 28 73 3a 74 72 20 28 73 3a . (s:tr (s:
fc20: 74 64 20 22 73 74 61 74 65 22 29 20 20 20 20 28 td "state") (
fc30: 73 3a 74 64 20 28 64 62 3a 74 65 73 74 2d 67 65 s:td (db:test-ge
fc40: 74 2d 73 74 61 74 65 20 20 20 20 74 65 73 74 2d t-state test-
fc50: 64 61 74 29 29 0a 09 09 09 20 20 20 20 28 73 3a dat)).... (s:
fc60: 74 64 20 22 73 74 61 74 75 73 22 29 20 20 20 28 td "status") (
fc70: 73 3a 74 64 20 28 73 3a 61 20 27 68 72 65 66 20 s:td (s:a 'href
fc80: 6c 6f 67 66 20 28 73 3a 66 6f 6e 74 20 27 63 6f logf (s:font 'co
fc90: 6c 6f 72 20 63 6f 6c 6f 72 20 73 74 61 74 75 73 lor color status
fca0: 29 29 29 29 0a 09 09 20 20 20 20 20 20 28 73 3a ))))... (s:
fcb0: 74 72 20 28 73 3a 74 64 20 22 54 65 73 74 44 61 tr (s:td "TestDa
fcc0: 74 65 22 29 20 28 73 3a 74 64 20 28 73 65 63 6f te") (s:td (seco
fcd0: 6e 64 73 2d 3e 77 6f 72 6b 2d 77 65 65 6b 2f 64 nds->work-week/d
fce0: 61 79 2d 74 69 6d 65 20 0a 09 09 09 09 09 09 20 ay-time .......
fcf0: 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 (db:test-get
fd00: 2d 65 76 65 6e 74 5f 74 69 6d 65 20 74 65 73 74 -event_time test
fd10: 2d 64 61 74 29 29 29 0a 09 09 09 20 20 20 20 28 -dat))).... (
fd20: 73 3a 74 64 20 22 44 75 72 61 74 69 6f 6e 22 29 s:td "Duration")
fd30: 20 28 73 3a 74 64 20 28 73 65 63 6f 6e 64 73 2d (s:td (seconds-
fd40: 3e 68 72 2d 6d 69 6e 2d 73 65 63 20 28 64 62 3a >hr-min-sec (db:
fd50: 74 65 73 74 2d 67 65 74 2d 72 75 6e 5f 64 75 72 test-get-run_dur
fd60: 61 74 69 6f 6e 20 74 65 73 74 2d 64 61 74 29 29 ation test-dat))
fd70: 29 29 29 0a 09 20 20 20 20 20 28 73 3a 68 33 20 ))).. (s:h3
fd80: 22 4c 6f 67 20 66 69 6c 65 73 22 29 0a 09 20 20 "Log files")..
fd90: 20 20 20 28 73 3a 74 61 62 6c 65 20 0a 09 20 20 (s:table ..
fda0: 20 20 20 20 27 63 65 6c 6c 73 70 61 63 69 6e 67 'cellspacing
fdb0: 20 22 30 22 20 27 62 6f 72 64 65 72 20 22 31 22 "0" 'border "1"
fdc0: 0a 09 20 20 20 20 20 20 28 73 3a 74 72 20 28 73 .. (s:tr (s
fdd0: 3a 74 64 20 22 46 69 6e 61 6c 20 6c 6f 67 22 29 :td "Final log")
fde0: 28 73 3a 74 64 20 28 73 3a 61 20 27 68 72 65 66 (s:td (s:a 'href
fdf0: 20 6c 6f 67 66 20 6c 6f 67 66 29 29 29 29 0a 09 logf logf))))..
fe00: 20 20 20 20 20 28 73 3a 74 61 62 6c 65 0a 09 20 (s:table..
fe10: 20 20 20 20 20 27 63 65 6c 6c 73 70 61 63 69 6e 'cellspacin
fe20: 67 20 22 30 22 20 27 62 6f 72 64 65 72 20 22 31 g "0" 'border "1
fe30: 22 0a 09 20 20 20 20 20 20 28 73 3a 74 72 20 28 ".. (s:tr (
fe40: 73 3a 74 64 20 22 53 74 65 70 20 4e 61 6d 65 22 s:td "Step Name"
fe50: 29 28 73 3a 74 64 20 22 53 74 61 72 74 22 29 28 )(s:td "Start")(
fe60: 73 3a 74 64 20 22 45 6e 64 22 29 28 73 3a 74 64 s:td "End")(s:td
fe70: 20 22 53 74 61 74 75 73 22 29 28 73 3a 74 64 20 "Status")(s:td
fe80: 22 44 75 72 61 74 69 6f 6e 22 29 28 73 3a 74 64 "Duration")(s:td
fe90: 20 22 4c 6f 67 20 46 69 6c 65 22 29 29 0a 09 20 "Log File"))..
fea0: 20 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 (map (lambd
feb0: 61 20 28 73 74 65 70 2d 64 61 74 29 0a 09 09 20 a (step-dat)...
fec0: 20 20 20 20 28 73 3a 74 72 20 28 73 3a 74 64 20 (s:tr (s:td
fed0: 28 74 64 62 3a 73 74 65 70 73 2d 74 61 62 6c 65 (tdb:steps-table
fee0: 2d 67 65 74 2d 73 74 65 70 6e 61 6d 65 20 73 74 -get-stepname st
fef0: 65 70 2d 64 61 74 29 29 0a 09 09 09 20 20 20 28 ep-dat)).... (
ff00: 73 3a 74 64 20 28 74 64 62 3a 73 74 65 70 73 2d s:td (tdb:steps-
ff10: 74 61 62 6c 65 2d 67 65 74 2d 73 74 61 72 74 20 table-get-start
ff20: 20 20 20 73 74 65 70 2d 64 61 74 29 29 0a 09 09 step-dat))...
ff30: 09 20 20 20 28 73 3a 74 64 20 28 74 64 62 3a 73 . (s:td (tdb:s
ff40: 74 65 70 73 2d 74 61 62 6c 65 2d 67 65 74 2d 65 teps-table-get-e
ff50: 6e 64 20 20 20 20 20 20 73 74 65 70 2d 64 61 74 nd step-dat
ff60: 29 29 0a 09 09 09 20 20 20 28 73 3a 74 64 20 28 )).... (s:td (
ff70: 74 64 62 3a 73 74 65 70 73 2d 74 61 62 6c 65 2d tdb:steps-table-
ff80: 67 65 74 2d 73 74 61 74 75 73 20 20 20 73 74 65 get-status ste
ff90: 70 2d 64 61 74 29 29 0a 09 09 09 20 20 20 28 73 p-dat)).... (s
ffa0: 3a 74 64 20 28 74 64 62 3a 73 74 65 70 73 2d 74 :td (tdb:steps-t
ffb0: 61 62 6c 65 2d 67 65 74 2d 72 75 6e 74 69 6d 65 able-get-runtime
ffc0: 20 20 73 74 65 70 2d 64 61 74 29 29 0a 09 09 09 step-dat))....
ffd0: 20 20 20 28 73 3a 74 64 20 28 6c 65 74 20 28 28 (s:td (let ((
ffe0: 73 74 65 70 2d 6c 6f 67 20 28 74 64 62 3a 73 74 step-log (tdb:st
fff0: 65 70 73 2d 74 61 62 6c 65 2d 67 65 74 2d 6c 6f eps-table-get-lo
10000 67 2d 66 69 6c 65 20 73 74 65 70 2d 64 61 74 29 g-file step-dat)
10010 29 29 0a 09 09 09 09 20 20 20 28 73 3a 61 20 27 ))..... (s:a '
10020 68 72 65 66 20 73 74 65 70 2d 6c 6f 67 20 73 74 href step-log st
10030 65 70 2d 6c 6f 67 29 29 29 29 29 0a 09 09 20 20 ep-log)))))...
10040 20 73 74 65 70 73 2d 64 61 74 29 29 0a 09 20 20 steps-dat))..
10050 20 20 20 29 29 29 0a 09 20 20 28 63 6c 6f 73 65 ))).. (close
10060 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 6f 75 70 -output-port oup
10070 29 29 29 29 29 0a 09 20 20 0a 09 20 20 0a 3b 3b ))))).. .. .;;
10080 20 4d 55 53 54 20 42 45 20 43 41 4c 4c 45 44 20 MUST BE CALLED
10090 6c 6f 63 61 6c 21 0a 3b 3b 0a 28 64 65 66 69 6e local!.;;.(defin
100a0 65 20 28 74 65 73 74 73 3a 74 65 73 74 2d 67 65 e (tests:test-ge
100b0 74 2d 70 61 74 68 73 2d 6d 61 74 63 68 69 6e 67 t-paths-matching
100c0 20 6b 65 79 6e 61 6d 65 73 20 74 61 72 67 65 74 keynames target
100d0 20 66 6e 61 6d 65 70 61 74 74 20 23 21 6b 65 79 fnamepatt #!key
100e0 20 28 72 65 73 20 27 28 29 29 29 0a 20 20 3b 3b (res '())). ;;
100f0 20 42 55 47 3a 20 4d 6f 76 65 20 74 68 65 20 76 BUG: Move the v
10100 61 6c 75 65 73 20 64 65 72 69 76 65 64 20 66 72 alues derived fr
10110 6f 6d 20 61 72 67 73 20 74 6f 20 70 61 72 61 6d om args to param
10120 65 74 65 72 73 20 61 6e 64 20 70 75 73 68 20 74 eters and push t
10130 6f 20 6d 65 67 61 74 65 73 74 2e 73 63 6d 0a 20 o megatest.scm.
10140 20 28 6c 65 74 2a 20 28 28 74 65 73 74 70 61 74 (let* ((testpat
10150 74 20 20 20 28 6f 72 20 28 61 72 67 73 3a 67 65 t (or (args:ge
10160 74 2d 61 72 67 20 22 2d 74 65 73 74 70 61 74 74 t-arg "-testpatt
10170 22 29 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 ")(args:get-arg
10180 22 2d 74 65 73 74 70 61 74 74 22 29 20 22 25 22 "-testpatt") "%"
10190 29 29 0a 09 20 28 73 74 61 74 65 70 61 74 74 20 )).. (statepatt
101a0 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 (or (args:get-a
101b0 72 67 20 22 2d 73 74 61 74 65 22 29 20 20 20 28 rg "-state") (
101c0 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 3a 73 args:get-arg ":s
101d0 74 61 74 65 22 29 20 20 20 20 22 25 22 29 29 0a tate") "%")).
101e0 09 20 28 73 74 61 74 75 73 70 61 74 74 20 28 6f . (statuspatt (o
101f0 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 r (args:get-arg
10200 22 2d 73 74 61 74 75 73 22 29 20 20 28 61 72 67 "-status") (arg
10210 73 3a 67 65 74 2d 61 72 67 20 22 3a 73 74 61 74 s:get-arg ":stat
10220 75 73 22 29 20 20 20 22 25 22 29 29 0a 09 20 28 us") "%")).. (
10230 72 75 6e 6e 61 6d 65 20 20 20 20 28 6f 72 20 28 runname (or (
10240 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 args:get-arg "-r
10250 75 6e 6e 61 6d 65 22 29 20 28 61 72 67 73 3a 67 unname") (args:g
10260 65 74 2d 61 72 67 20 22 3a 72 75 6e 6e 61 6d 65 et-arg ":runname
10270 22 29 20 20 22 25 22 29 29 0a 09 20 28 70 61 74 ") "%")).. (pat
10280 68 73 2d 66 72 6f 6d 2d 64 62 20 28 72 6d 74 3a hs-from-db (rmt:
10290 74 65 73 74 2d 67 65 74 2d 70 61 74 68 73 2d 6d test-get-paths-m
102a0 61 74 63 68 69 6e 67 2d 6b 65 79 6e 61 6d 65 73 atching-keynames
102b0 2d 74 61 72 67 65 74 2d 6e 65 77 20 6b 65 79 6e -target-new keyn
102c0 61 6d 65 73 20 74 61 72 67 65 74 20 72 65 73 0a ames target res.
102d0 09 09 09 09 09 74 65 73 74 70 61 74 74 0a 09 09 .....testpatt...
102e0 09 09 09 73 74 61 74 65 70 61 74 74 0a 09 09 09 ...statepatt....
102f0 09 09 73 74 61 74 75 73 70 61 74 74 0a 09 09 09 ..statuspatt....
10300 09 09 72 75 6e 6e 61 6d 65 29 29 29 0a 20 20 20 ..runname))).
10310 20 28 69 66 20 66 6e 61 6d 65 70 61 74 74 0a 09 (if fnamepatt..
10320 28 61 70 70 6c 79 20 61 70 70 65 6e 64 20 0a 09 (apply append ..
10330 20 20 20 20 20 20 20 28 6d 61 70 20 28 6c 61 6d (map (lam
10340 62 64 61 20 28 70 29 0a 09 09 20 20 20 20 20 20 bda (p)...
10350 28 69 66 20 28 64 69 72 65 63 74 6f 72 79 2d 65 (if (directory-e
10360 78 69 73 74 73 3f 20 70 29 0a 09 09 09 20 20 28 xists? p).... (
10370 6c 65 74 20 28 28 67 6c 6f 62 2d 71 75 65 72 79 let ((glob-query
10380 20 28 63 6f 6e 63 20 70 20 22 2f 22 20 66 6e 61 (conc p "/" fna
10390 6d 65 70 61 74 74 29 29 29 0a 09 09 09 20 20 20 mepatt)))....
103a0 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 (handle-excepti
103b0 6f 6e 73 0a 09 09 09 09 65 78 6e 0a 09 09 09 20 ons.....exn....
103c0 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 09 (begin.....
103d0 28 70 72 69 6e 74 20 22 62 75 69 6c 74 2d 69 6e (print "built-in
103e0 20 67 6c 6f 62 20 6f 6e 20 22 20 67 6c 6f 62 2d glob on " glob-
103f0 71 75 65 72 79 20 22 2c 20 66 61 69 6c 65 64 2c query ", failed,
10400 20 74 72 79 20 75 73 69 6e 67 20 74 68 65 20 73 try using the s
10410 68 65 6c 6c 2e 20 65 78 6e 3d 22 20 65 78 6e 29 hell. exn=" exn)
10420 0a 09 09 09 09 28 77 69 74 68 2d 69 6e 70 75 74 .....(with-input
10430 2d 66 72 6f 6d 2d 70 69 70 65 0a 09 09 09 09 20 -from-pipe.....
10440 28 63 6f 6e 63 20 22 65 63 68 6f 20 22 20 67 6c (conc "echo " gl
10450 6f 62 2d 71 75 65 72 79 29 0a 09 09 09 09 20 72 ob-query)..... r
10460 65 61 64 2d 6c 69 6e 65 73 29 29 20 20 3b 3b 20 ead-lines)) ;;
10470 77 65 20 61 72 65 6e 27 74 20 67 6f 69 6e 67 20 we aren't going
10480 74 6f 20 74 72 79 20 74 6f 6f 20 68 61 72 64 2e to try too hard.
10490 20 49 66 20 67 6c 6f 62 20 62 72 65 61 6b 73 20 If glob breaks
104a0 69 74 20 69 73 20 6c 69 6b 65 6c 79 20 62 65 63 it is likely bec
104b0 61 75 73 65 20 73 6f 6d 65 6f 6e 65 20 74 72 69 ause someone tri
104c0 65 64 20 74 6f 20 64 6f 20 2a 2f 2a 2f 2a 2e 6c ed to do */*/*.l
104d0 6f 67 20 6f 72 20 73 69 6d 69 6c 61 72 0a 09 09 og or similar...
104e0 09 20 20 20 20 20 20 28 67 6c 6f 62 20 67 6c 6f . (glob glo
104f0 62 2d 71 75 65 72 79 29 29 29 0a 09 09 09 20 20 b-query)))....
10500 27 28 29 29 29 0a 09 09 20 20 20 20 70 61 74 68 '()))... path
10510 73 2d 66 72 6f 6d 2d 64 62 29 29 0a 09 70 61 74 s-from-db))..pat
10520 68 73 2d 66 72 6f 6d 2d 64 62 29 29 29 0a 0a 09 hs-from-db)))...
10530 09 09 20 20 20 20 20 20 0a 3b 3b 3d 3d 3d 3d 3d .. .;;=====
10540 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10550 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10560 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10570 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10580 3d 0a 3b 3b 20 47 61 74 68 65 72 20 64 61 74 61 =.;; Gather data
10590 20 66 72 6f 6d 20 74 65 73 74 2f 74 61 73 6b 20 from test/task
105a0 73 70 65 63 69 66 69 63 61 74 69 6f 6e 73 0a 3b specifications.;
105b0 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
105c0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
105d0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
105e0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
105f0 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 28 64 65 66 =======..;; (def
10600 69 6e 65 20 28 74 65 73 74 73 3a 67 65 74 2d 76 ine (tests:get-v
10610 61 6c 69 64 2d 74 65 73 74 73 20 74 65 73 74 73 alid-tests tests
10620 64 69 72 20 74 65 73 74 2d 70 61 74 74 73 29 20 dir test-patts)
10630 3b 3b 20 20 23 21 6b 65 79 20 28 74 65 73 74 2d ;; #!key (test-
10640 6e 61 6d 65 73 20 27 28 29 29 29 0a 3b 3b 20 20 names '())).;;
10650 20 28 6c 65 74 20 28 28 74 65 73 74 73 20 28 67 (let ((tests (g
10660 6c 6f 62 20 28 63 6f 6e 63 20 74 65 73 74 73 64 lob (conc testsd
10670 69 72 20 22 2f 74 65 73 74 73 2f 2a 22 29 29 29 ir "/tests/*")))
10680 29 20 3b 3b 20 22 20 28 73 74 72 69 6e 67 2d 74 ) ;; " (string-t
10690 72 61 6e 73 6c 61 74 65 20 70 61 74 74 20 22 25 ranslate patt "%
106a0 22 20 22 2a 22 29 29 29 29 29 0a 3b 3b 20 20 20 " "*"))))).;;
106b0 20 20 28 73 65 74 21 20 74 65 73 74 73 20 28 66 (set! tests (f
106c0 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 74 ilter (lambda (t
106d0 65 73 74 29 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 est)(common:file
106e0 2d 65 78 69 73 74 73 3f 20 28 63 6f 6e 63 20 74 -exists? (conc t
106f0 65 73 74 20 22 2f 74 65 73 74 63 6f 6e 66 69 67 est "/testconfig
10700 22 29 29 29 20 74 65 73 74 73 29 29 0a 3b 3b 20 "))) tests)).;;
10710 20 20 20 20 28 64 65 6c 65 74 65 2d 64 75 70 6c (delete-dupl
10720 69 63 61 74 65 73 0a 3b 3b 20 20 20 20 20 20 28 icates.;; (
10730 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 filter (lambda (
10740 74 65 73 74 6e 61 6d 65 29 0a 3b 3b 20 09 20 20 testname).;; .
10750 20 20 20 20 20 28 74 65 73 74 73 3a 6d 61 74 63 (tests:matc
10760 68 20 74 65 73 74 2d 70 61 74 74 73 20 74 65 73 h test-patts tes
10770 74 6e 61 6d 65 20 23 66 29 29 0a 3b 3b 20 09 20 tname #f)).;; .
10780 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 (map (lambda
10790 20 28 74 65 73 74 70 29 0a 3b 3b 20 09 09 20 20 (testp).;; ..
107a0 20 20 28 6c 61 73 74 20 28 73 74 72 69 6e 67 2d (last (string-
107b0 73 70 6c 69 74 20 74 65 73 74 70 20 22 2f 22 29 split testp "/")
107c0 29 29 0a 3b 3b 20 09 09 20 20 74 65 73 74 73 29 )).;; .. tests)
107d0 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 ))))..(define (t
107e0 65 73 74 73 3a 67 65 74 2d 74 65 73 74 2d 70 61 ests:get-test-pa
107f0 74 68 2d 66 72 6f 6d 2d 65 6e 76 69 72 6f 6e 6d th-from-environm
10800 65 6e 74 29 0a 20 20 28 69 66 20 28 61 6e 64 20 ent). (if (and
10810 28 67 65 74 65 6e 76 20 22 4d 54 5f 4c 49 4e 4b (getenv "MT_LINK
10820 54 52 45 45 22 29 0a 09 20 20 20 28 67 65 74 65 TREE").. (gete
10830 6e 76 20 22 4d 54 5f 54 41 52 47 45 54 22 29 0a nv "MT_TARGET").
10840 09 20 20 20 28 67 65 74 65 6e 76 20 22 4d 54 5f . (getenv "MT_
10850 52 55 4e 4e 41 4d 45 22 29 0a 09 20 20 20 28 67 RUNNAME").. (g
10860 65 74 65 6e 76 20 22 4d 54 5f 54 45 53 54 5f 4e etenv "MT_TEST_N
10870 41 4d 45 22 29 0a 09 20 20 20 28 67 65 74 65 6e AME").. (geten
10880 76 20 22 4d 54 5f 49 54 45 4d 50 41 54 48 22 29 v "MT_ITEMPATH")
10890 29 0a 20 20 20 20 20 20 28 63 6f 6e 63 20 28 67 ). (conc (g
108a0 65 74 65 6e 76 20 22 4d 54 5f 4c 49 4e 4b 54 52 etenv "MT_LINKTR
108b0 45 45 22 29 20 20 22 2f 22 0a 09 20 20 20 20 28 EE") "/".. (
108c0 67 65 74 65 6e 76 20 22 4d 54 5f 54 41 52 47 45 getenv "MT_TARGE
108d0 54 22 29 20 20 20 20 22 2f 22 0a 09 20 20 20 20 T") "/"..
108e0 28 67 65 74 65 6e 76 20 22 4d 54 5f 52 55 4e 4e (getenv "MT_RUNN
108f0 41 4d 45 22 29 20 20 20 22 2f 22 0a 09 20 20 20 AME") "/"..
10900 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 54 45 53 (getenv "MT_TES
10910 54 5f 4e 41 4d 45 22 29 0a 09 20 20 20 20 28 69 T_NAME").. (i
10920 66 20 28 61 6e 64 20 28 67 65 74 65 6e 76 20 22 f (and (getenv "
10930 4d 54 5f 49 54 45 4d 50 41 54 48 22 29 0a 20 20 MT_ITEMPATH").
10940 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
10950 20 20 20 28 6e 6f 74 20 28 73 74 72 69 6e 67 3d (not (string=
10960 3f 20 22 22 20 28 67 65 74 65 6e 76 20 22 4d 54 ? "" (getenv "MT
10970 5f 49 54 45 4d 50 41 54 48 22 29 29 29 29 0a 09 _ITEMPATH"))))..
10980 09 28 63 6f 6e 63 20 22 2f 22 20 28 67 65 74 65 .(conc "/" (gete
10990 6e 76 20 22 4d 54 5f 49 54 45 4d 50 41 54 48 22 nv "MT_ITEMPATH"
109a0 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
109b0 20 20 20 22 22 29 29 0a 20 20 20 20 20 20 23 66 "")). #f
109c0 29 29 0a 0a 3b 3b 20 69 66 20 2e 74 65 73 74 63 ))..;; if .testc
109d0 6f 6e 66 69 67 20 65 78 69 73 74 73 20 69 6e 20 onfig exists in
109e0 74 65 73 74 20 64 69 72 65 63 74 6f 72 79 20 72 test directory r
109f0 65 61 64 20 61 6e 64 20 72 65 74 75 72 6e 20 69 ead and return i
10a00 74 0a 3b 3b 20 65 6c 73 65 20 69 66 20 68 61 76 t.;; else if hav
10a10 65 20 63 61 63 68 65 64 20 63 6f 70 79 20 69 6e e cached copy in
10a20 20 2a 74 65 73 74 63 6f 6e 66 69 67 73 2a 20 72 *testconfigs* r
10a30 65 74 75 72 6e 20 69 74 20 49 46 46 20 74 68 65 eturn it IFF the
10a40 72 65 20 69 73 20 61 20 73 65 63 74 69 6f 6e 20 re is a section
10a50 22 68 61 76 65 20 66 75 6c 6c 64 61 74 61 22 0a "have fulldata".
10a60 3b 3b 20 65 6c 73 65 20 72 65 61 64 20 74 68 65 ;; else read the
10a70 20 74 65 73 74 63 6f 6e 66 69 67 20 66 69 6c 65 testconfig file
10a80 0a 3b 3b 20 20 20 69 66 20 68 61 76 65 20 70 61 .;; if have pa
10a90 74 68 20 74 6f 20 74 65 73 74 20 64 69 72 65 63 th to test direc
10aa0 74 6f 72 79 20 73 61 76 65 20 74 68 65 20 63 6f tory save the co
10ab0 6e 66 69 67 20 61 73 20 2e 74 65 73 74 63 6f 6e nfig as .testcon
10ac0 66 69 67 20 61 6e 64 20 72 65 74 75 72 6e 20 69 fig and return i
10ad0 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 65 t.;;.(define (te
10ae0 73 74 73 3a 67 65 74 2d 74 65 73 74 63 6f 6e 66 sts:get-testconf
10af0 69 67 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 ig test-name ite
10b00 6d 2d 70 61 74 68 20 74 65 73 74 2d 72 65 67 69 m-path test-regi
10b10 73 74 72 79 20 73 79 73 74 65 6d 2d 61 6c 6c 6f stry system-allo
10b20 77 65 64 20 23 21 6b 65 79 20 28 66 6f 72 63 65 wed #!key (force
10b30 2d 63 72 65 61 74 65 20 23 66 29 28 61 6c 6c 6f -create #f)(allo
10b40 77 2d 77 72 69 74 65 2d 63 61 63 68 65 20 23 74 w-write-cache #t
10b50 29 28 77 61 69 74 2d 61 2d 6d 69 6e 75 74 65 20 )(wait-a-minute
10b60 23 66 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 75 #f)). (let* ((u
10b70 73 65 2d 63 61 63 68 65 20 20 20 20 28 63 6f 6d se-cache (com
10b80 6d 6f 6e 3a 75 73 65 2d 63 61 63 68 65 3f 29 29 mon:use-cache?))
10b90 0a 09 20 28 63 61 63 68 65 2d 70 61 74 68 20 20 .. (cache-path
10ba0 20 28 74 65 73 74 73 3a 67 65 74 2d 74 65 73 74 (tests:get-test
10bb0 2d 70 61 74 68 2d 66 72 6f 6d 2d 65 6e 76 69 72 -path-from-envir
10bc0 6f 6e 6d 65 6e 74 29 29 0a 09 20 28 63 61 63 68 onment)).. (cach
10bd0 65 2d 66 69 6c 65 20 20 20 28 61 6e 64 20 63 61 e-file (and ca
10be0 63 68 65 2d 70 61 74 68 20 28 63 6f 6e 63 20 63 che-path (conc c
10bf0 61 63 68 65 2d 70 61 74 68 20 22 2f 2e 74 65 73 ache-path "/.tes
10c00 74 63 6f 6e 66 69 67 22 29 29 29 0a 09 20 28 63 tconfig"))).. (c
10c10 61 63 68 65 2d 65 78 69 73 74 73 20 28 61 6e 64 ache-exists (and
10c20 20 63 61 63 68 65 2d 66 69 6c 65 0a 09 09 09 20 cache-file....
10c30 20 20 20 28 6e 6f 74 20 66 6f 72 63 65 2d 63 72 (not force-cr
10c40 65 61 74 65 29 20 20 3b 3b 20 69 66 20 66 6f 72 eate) ;; if for
10c50 63 65 2d 63 72 65 61 74 65 20 74 68 65 6e 20 70 ce-create then p
10c60 72 65 74 65 6e 64 20 74 68 65 72 65 20 69 73 20 retend there is
10c70 6e 6f 20 63 61 63 68 65 20 74 6f 20 72 65 61 64 no cache to read
10c80 0a 09 09 09 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a .... (common:
10c90 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 63 61 63 file-exists? cac
10ca0 68 65 2d 66 69 6c 65 29 29 29 0a 09 20 28 63 61 he-file))).. (ca
10cb0 63 68 65 64 2d 64 61 74 20 20 20 28 69 66 20 28 ched-dat (if (
10cc0 61 6e 64 20 28 6e 6f 74 20 66 6f 72 63 65 2d 63 and (not force-c
10cd0 72 65 61 74 65 29 0a 09 09 09 09 63 61 63 68 65 reate).....cache
10ce0 2d 65 78 69 73 74 73 0a 09 09 09 09 75 73 65 2d -exists.....use-
10cf0 63 61 63 68 65 29 0a 09 09 09 20 20 20 28 68 61 cache).... (ha
10d00 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a ndle-exceptions.
10d10 09 09 09 20 20 20 20 20 20 20 65 78 6e 0a 09 09 ... exn...
10d20 09 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 . (begin....
10d30 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 (debug:pr
10d40 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
10d50 6f 67 2d 70 6f 72 74 2a 20 22 66 61 69 6c 65 64 og-port* "failed
10d60 20 74 6f 20 72 65 61 64 20 22 20 63 61 63 68 65 to read " cache
10d70 2d 66 69 6c 65 20 22 2c 20 65 78 6e 3d 22 20 65 -file ", exn=" e
10d80 78 6e 29 0a 09 09 09 20 20 20 20 20 20 20 23 66 xn).... #f
10d90 29 20 3b 3b 20 61 6e 79 20 69 73 73 75 65 73 2c ) ;; any issues,
10da0 20 6a 75 73 74 20 67 69 76 65 20 75 70 20 77 69 just give up wi
10db0 74 68 20 74 68 65 20 63 61 63 68 65 64 20 76 65 th the cached ve
10dc0 72 73 69 6f 6e 20 61 6e 64 20 72 65 2d 72 65 61 rsion and re-rea
10dd0 64 0a 09 09 09 20 20 20 20 20 28 63 6f 6e 66 69 d.... (confi
10de0 67 66 3a 72 65 61 64 2d 61 6c 69 73 74 20 63 61 gf:read-alist ca
10df0 63 68 65 2d 66 69 6c 65 29 29 0a 09 09 09 20 20 che-file))....
10e00 20 23 66 29 29 0a 20 20 20 20 20 20 20 20 20 28 #f)). (
10e10 74 65 73 74 2d 66 75 6c 6c 2d 6e 61 6d 65 20 28 test-full-name (
10e20 69 66 20 28 61 6e 64 20 69 74 65 6d 2d 70 61 74 if (and item-pat
10e30 68 20 28 6e 6f 74 20 28 73 74 72 69 6e 67 2d 6e h (not (string-n
10e40 75 6c 6c 3f 20 69 74 65 6d 2d 70 61 74 68 29 29 ull? item-path))
10e50 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
10e60 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
10e70 63 6f 6e 63 20 74 65 73 74 2d 6e 61 6d 65 20 22 conc test-name "
10e80 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 0a 20 20 /" item-path).
10e90 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
10ea0 20 20 20 20 20 20 20 20 20 20 20 74 65 73 74 2d test-
10eb0 6e 61 6d 65 29 29 29 0a 20 20 20 20 28 69 66 20 name))). (if
10ec0 63 61 63 68 65 64 2d 64 61 74 0a 09 63 61 63 68 cached-dat..cach
10ed0 65 64 2d 64 61 74 0a 09 28 6c 65 74 20 28 28 64 ed-dat..(let ((d
10ee0 61 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 at (hash-table-r
10ef0 65 66 2f 64 65 66 61 75 6c 74 20 2a 74 65 73 74 ef/default *test
10f00 63 6f 6e 66 69 67 73 2a 20 74 65 73 74 2d 66 75 configs* test-fu
10f10 6c 6c 2d 6e 61 6d 65 20 23 66 29 29 29 0a 09 20 ll-name #f)))..
10f20 20 28 69 66 20 28 61 6e 64 20 20 64 61 74 20 3b (if (and dat ;
10f30 3b 20 68 61 76 65 20 61 20 6c 6f 63 61 6c 6c 79 ; have a locally
10f40 20 63 61 63 68 65 64 20 76 65 72 73 69 6f 6e 0a cached version.
10f50 09 09 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c .. (hash-tabl
10f60 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 64 61 e-ref/default da
10f70 74 20 22 68 61 76 65 20 66 75 6c 6c 64 61 74 61 t "have fulldata
10f80 22 20 23 66 29 29 20 3b 3b 20 6d 61 72 6b 65 64 " #f)) ;; marked
10f90 20 61 73 20 67 6f 6f 64 20 64 61 74 61 3f 0a 09 as good data?..
10fa0 20 20 20 20 20 20 64 61 74 0a 09 20 20 20 20 20 dat..
10fb0 20 3b 3b 20 6e 6f 20 63 61 63 68 65 64 20 64 61 ;; no cached da
10fc0 74 61 20 61 76 61 69 6c 61 62 6c 65 0a 09 20 20 ta available..
10fd0 20 20 20 20 28 6c 65 74 2a 20 28 28 74 72 65 67 (let* ((treg
10fe0 20 20 20 20 20 20 20 20 20 28 6f 72 20 74 65 73 (or tes
10ff0 74 2d 72 65 67 69 73 74 72 79 0a 09 09 09 09 20 t-registry.....
11000 20 20 20 20 20 20 28 74 65 73 74 73 3a 67 65 74 (tests:get
11010 2d 61 6c 6c 29 29 29 0a 09 09 20 20 20 20 20 28 -all)))... (
11020 74 65 73 74 2d 70 61 74 68 20 20 20 20 28 6f 72 test-path (or
11030 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
11040 2f 64 65 66 61 75 6c 74 20 74 72 65 67 20 74 65 /default treg te
11050 73 74 2d 6e 61 6d 65 20 23 66 29 0a 20 20 20 20 st-name #f).
11060 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11070 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11080 20 20 20 28 6c 65 74 2a 20 28 28 6c 6f 63 61 6c (let* ((local
11090 2d 74 63 64 69 72 20 28 63 6f 6e 63 20 28 67 65 -tcdir (conc (ge
110a0 74 65 6e 76 20 22 4d 54 5f 4c 49 4e 4b 54 52 45 tenv "MT_LINKTRE
110b0 45 22 29 20 22 2f 22 0a 20 20 20 20 20 20 20 20 E") "/".
110c0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
110d0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
110e0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
110f0 20 20 20 20 20 20 20 20 20 28 67 65 74 65 6e 76 (getenv
11100 20 22 4d 54 5f 54 41 52 47 45 54 22 29 20 22 2f "MT_TARGET") "/
11110 22 0a 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 20
11150 20 20 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 52 (getenv "MT_R
11160 55 4e 4e 41 4d 45 22 29 20 22 2f 22 0a 20 20 20 UNNAME") "/".
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 20 20 20 20 20 74 65 te
111b0 73 74 2d 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d st-name "/" item
111c0 2d 70 61 74 68 29 29 0a 20 20 20 20 20 20 20 20 -path)).
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 28 6c 6f 63 61 6c 2d 74 63 66 (local-tcf
11200 67 20 28 63 6f 6e 63 20 6c 6f 63 61 6c 2d 74 63 g (conc local-tc
11210 64 69 72 20 22 2f 74 65 73 74 63 6f 6e 66 69 67 dir "/testconfig
11220 22 29 29 29 0a 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 20 20 28 69 (i
11250 66 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 f (common:file-e
11260 78 69 73 74 73 3f 20 6c 6f 63 61 6c 2d 74 63 66 xists? local-tcf
11270 67 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 g).
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 6c 6f 63 61 6c 2d 74 63 64 69 72 0a 20 20 20 20 local-tcdir.
112b0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
112c0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
112d0 20 20 20 20 20 20 20 20 20 23 66 29 29 0a 09 09 #f))...
112e0 09 09 20 20 20 20 20 20 20 28 63 6f 6e 63 20 2a .. (conc *
112f0 74 6f 70 70 61 74 68 2a 20 22 2f 74 65 73 74 73 toppath* "/tests
11300 2f 22 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a /" test-name))).
11310 09 09 20 20 20 20 20 28 74 65 73 74 2d 63 6f 6e .. (test-con
11320 66 69 67 66 20 28 63 6f 6e 63 20 74 65 73 74 2d figf (conc test-
11330 70 61 74 68 20 22 2f 74 65 73 74 63 6f 6e 66 69 path "/testconfi
11340 67 22 29 29 0a 09 09 20 20 20 20 20 28 74 65 73 g"))... (tes
11350 74 65 78 69 73 74 73 20 20 20 28 6c 65 74 20 6c texists (let l
11360 6f 6f 70 61 20 28 28 74 72 69 65 73 2d 6c 65 66 oopa ((tries-lef
11370 74 20 33 30 29 29 0a 20 20 20 20 20 20 20 20 20 t 30)).
11380 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11390 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e (con
113a0 64 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 d.
113b0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
113c0 20 20 20 20 20 20 20 20 28 0a 20 20 20 20 20 20 (.
113d0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
113e0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
113f0 20 28 61 6e 64 20 28 63 6f 6d 6d 6f 6e 3a 66 69 (and (common:fi
11400 6c 65 2d 65 78 69 73 74 73 3f 20 74 65 73 74 2d le-exists? test-
11410 63 6f 6e 66 69 67 66 29 28 66 69 6c 65 2d 72 65 configf)(file-re
11420 61 64 2d 61 63 63 65 73 73 3f 20 74 65 73 74 2d ad-access? test-
11430 63 6f 6e 66 69 67 66 29 29 0a 20 20 20 20 20 20 configf)).
11440 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11450 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11460 20 23 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 #t).
11470 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11480 20 20 20 20 20 20 20 20 20 20 20 28 0a 20 20 20 (.
11490 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
114a0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
114b0 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 (common:file
114c0 2d 65 78 69 73 74 73 3f 20 74 65 73 74 2d 63 6f -exists? test-co
114d0 6e 66 69 67 66 29 0a 20 20 20 20 20 20 20 20 20 nfigf).
114e0 20 20 20 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 28 64 (d
11500 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
11510 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
11520 22 57 41 52 4e 49 4e 47 3a 20 43 61 6e 6e 6f 74 "WARNING: Cannot
11530 20 72 65 61 64 20 74 65 73 74 63 6f 6e 66 69 67 read testconfig
11540 20 66 69 6c 65 3a 20 22 74 65 73 74 2d 63 6f 6e file: "test-con
11550 66 69 67 66 29 0a 20 20 20 20 20 20 20 20 20 20 figf).
11560 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11570 20 20 20 20 20 20 20 20 20 20 20 20 20 23 66 29 #f)
11580 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
11590 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
115a0 20 20 20 20 20 20 20 28 0a 20 20 20 20 20 20 20 (.
115b0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
115c0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
115d0 28 61 6e 64 20 77 61 69 74 2d 61 2d 6d 69 6e 75 (and wait-a-minu
115e0 74 65 20 28 3e 20 74 72 69 65 73 2d 6c 65 66 74 te (> tries-left
115f0 20 30 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 0)).
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 28 74 68 72 (thr
11620 65 61 64 2d 73 6c 65 65 70 21 20 31 30 29 0a 20 ead-sleep! 10).
11630 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11640 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11650 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
11660 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
11670 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 g-port* "WARNING
11680 3a 20 74 65 73 74 63 6f 6e 66 69 67 20 66 69 6c : testconfig fil
11690 65 20 64 6f 65 73 20 6e 6f 74 20 65 78 69 73 74 e does not exist
116a0 3a 20 22 74 65 73 74 2d 63 6f 6e 66 69 67 66 22 : "test-configf"
116b0 20 77 69 6c 6c 20 72 65 74 72 79 20 69 6e 20 31 will retry in 1
116c0 30 20 73 65 63 6f 6e 64 73 2e 20 20 54 72 69 65 0 seconds. Trie
116d0 73 20 6c 65 66 74 3a 20 22 74 72 69 65 73 2d 6c s left: "tries-l
116e0 65 66 74 29 20 3b 3b 20 42 42 3a 20 74 68 69 73 eft) ;; BB: this
116f0 20 66 69 72 65 73 0a 20 20 20 20 20 20 20 20 20 fires.
11700 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11710 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l
11720 6f 6f 70 61 20 28 73 75 62 31 20 74 72 69 65 73 oopa (sub1 tries
11730 2d 6c 65 66 74 29 29 29 0a 20 20 20 20 20 20 20 -left))).
11740 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11750 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
11760 65 6c 73 65 0a 20 20 20 20 20 20 20 20 20 20 20 else.
11770 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11780 20 20 20 20 20 20 20 20 20 20 20 20 28 64 65 62 (deb
11790 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
117a0 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 ult-log-port* "W
117b0 41 52 4e 49 4e 47 3a 20 74 65 73 74 63 6f 6e 66 ARNING: testconf
117c0 69 67 20 66 69 6c 65 20 64 6f 65 73 20 6e 6f 74 ig file does not
117d0 20 65 78 69 73 74 3a 20 22 74 65 73 74 2d 63 6f exist: "test-co
117e0 6e 66 69 67 66 29 20 3b 3b 20 42 42 3a 20 74 68 nfigf) ;; BB: th
117f0 69 73 20 66 69 72 65 73 0a 20 20 20 20 20 20 20 is fires.
11800 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11810 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11820 23 66 29 29 29 29 0a 09 09 20 20 20 20 20 28 74 #f))))... (t
11830 63 66 67 20 20 20 20 20 20 20 20 20 28 69 66 20 cfg (if
11840 74 65 73 74 65 78 69 73 74 73 0a 09 09 09 09 20 testexists.....
11850 20 20 20 20 20 20 28 72 65 61 64 2d 63 6f 6e 66 (read-conf
11860 69 67 20 74 65 73 74 2d 63 6f 6e 66 69 67 66 20 ig test-configf
11870 23 66 20 73 79 73 74 65 6d 2d 61 6c 6c 6f 77 65 #f system-allowe
11880 64 0a 09 09 09 09 09 09 20 20 20 20 65 6e 76 69 d....... envi
11890 72 6f 6e 2d 70 61 74 74 3a 20 28 69 66 20 73 79 ron-patt: (if sy
118a0 73 74 65 6d 2d 61 6c 6c 6f 77 65 64 0a 09 09 09 stem-allowed....
118b0 09 09 09 09 09 20 20 20 20 20 20 22 70 72 65 2d ..... "pre-
118c0 6c 61 75 6e 63 68 2d 65 6e 76 2d 76 61 72 73 22 launch-env-vars"
118d0 0a 09 09 09 09 09 09 09 09 20 20 20 20 20 20 23 ......... #
118e0 66 29 29 0a 09 09 09 09 20 20 20 20 20 20 20 23 f))..... #
118f0 66 29 29 29 0a 09 09 28 69 66 20 28 61 6e 64 20 f)))...(if (and
11900 74 63 66 67 20 63 61 63 68 65 2d 66 69 6c 65 29 tcfg cache-file)
11910 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
11920 21 20 74 63 66 67 20 22 68 61 76 65 20 66 75 6c ! tcfg "have ful
11930 6c 64 61 74 61 22 20 23 74 29 29 20 3b 3b 20 6d ldata" #t)) ;; m
11940 61 72 6b 20 74 68 69 73 20 61 73 20 66 75 6c 6c ark this as full
11950 79 20 72 65 61 64 20 64 61 74 61 0a 09 09 28 69 y read data...(i
11960 66 20 74 63 66 67 20 28 68 61 73 68 2d 74 61 62 f tcfg (hash-tab
11970 6c 65 2d 73 65 74 21 20 2a 74 65 73 74 63 6f 6e le-set! *testcon
11980 66 69 67 73 2a 20 74 65 73 74 2d 66 75 6c 6c 2d figs* test-full-
11990 6e 61 6d 65 20 74 63 66 67 29 29 0a 09 09 28 69 name tcfg))...(i
119a0 66 20 28 61 6e 64 20 74 65 73 74 65 78 69 73 74 f (and testexist
119b0 73 0a 09 09 09 20 63 61 63 68 65 2d 66 69 6c 65 s.... cache-file
119c0 0a 09 09 09 20 28 66 69 6c 65 2d 77 72 69 74 65 .... (file-write
119d0 2d 61 63 63 65 73 73 3f 20 63 61 63 68 65 2d 70 -access? cache-p
119e0 61 74 68 29 0a 09 09 09 20 61 6c 6c 6f 77 2d 77 ath).... allow-w
119f0 72 69 74 65 2d 63 61 63 68 65 29 0a 09 09 20 20 rite-cache)...
11a00 20 20 28 6c 65 74 20 28 28 74 70 61 74 68 20 28 (let ((tpath (
11a10 63 6f 6e 63 20 63 61 63 68 65 2d 70 61 74 68 20 conc cache-path
11a20 22 2f 2e 74 65 73 74 63 6f 6e 66 69 67 22 29 29 "/.testconfig"))
11a30 29 0a 09 09 20 20 20 20 20 20 28 64 65 62 75 67 )... (debug
11a40 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 2a 64 :print-info 1 *d
11a50 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
11a60 20 22 43 61 63 68 69 6e 67 20 74 65 73 74 63 6f "Caching testco
11a70 6e 66 69 67 20 66 6f 72 20 22 20 74 65 73 74 2d nfig for " test-
11a80 6e 61 6d 65 20 22 20 69 6e 20 22 20 74 70 61 74 name " in " tpat
11a90 68 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 h).
11aa0 20 20 20 20 20 20 20 20 20 28 69 66 20 28 61 6e (if (an
11ab0 64 20 74 63 66 67 20 28 6e 6f 74 20 28 63 6f 6d d tcfg (not (com
11ac0 6d 6f 6e 3a 69 6e 2d 72 75 6e 6e 69 6e 67 2d 74 mon:in-running-t
11ad0 65 73 74 3f 29 29 29 0a 20 20 20 20 20 20 20 20 est?))).
11ae0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11af0 20 20 28 63 6f 6e 66 69 67 66 3a 77 72 69 74 65 (configf:write
11b00 2d 61 6c 69 73 74 20 74 63 66 67 20 74 70 61 74 -alist tcfg tpat
11b10 68 29 29 29 29 0a 09 09 74 63 66 67 29 29 29 29 h))))...tcfg))))
11b20 29 29 0a 20 20 0a 3b 3b 20 73 6f 72 74 20 74 65 )). .;; sort te
11b30 73 74 73 20 62 79 20 70 72 69 6f 72 69 74 79 20 sts by priority
11b40 61 6e 64 20 77 61 69 74 6f 6e 0a 3b 3b 20 4d 6f and waiton.;; Mo
11b50 76 65 20 74 65 73 74 20 73 70 65 63 69 66 69 63 ve test specific
11b60 20 73 74 75 66 66 20 74 6f 20 61 20 74 65 73 74 stuff to a test
11b70 20 75 6e 69 74 20 46 49 58 4d 45 20 6f 6e 65 20 unit FIXME one
11b80 6f 66 20 74 68 65 73 65 20 64 61 79 73 0a 28 64 of these days.(d
11b90 65 66 69 6e 65 20 28 74 65 73 74 73 3a 73 6f 72 efine (tests:sor
11ba0 74 2d 62 79 2d 70 72 69 6f 72 69 74 79 2d 61 6e t-by-priority-an
11bb0 64 2d 77 61 69 74 6f 6e 20 74 65 73 74 2d 72 65 d-waiton test-re
11bc0 63 6f 72 64 73 29 0a 20 20 28 69 66 20 28 65 71 cords). (if (eq
11bd0 3f 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 69 ? (hash-table-si
11be0 7a 65 20 74 65 73 74 2d 72 65 63 6f 72 64 73 29 ze test-records)
11bf0 20 30 29 0a 20 20 20 20 20 20 27 28 29 0a 20 20 0). '().
11c00 20 20 20 20 28 6c 65 74 2a 20 28 28 6d 75 6e 67 (let* ((mung
11c10 65 70 72 69 6f 72 69 74 79 20 28 6c 61 6d 62 64 epriority (lambd
11c20 61 20 28 70 72 69 6f 72 69 74 79 29 0a 09 09 09 a (priority)....
11c30 20 20 20 20 20 20 28 69 66 20 70 72 69 6f 72 69 (if priori
11c40 74 79 0a 09 09 09 09 20 20 28 6c 65 74 20 28 28 ty..... (let ((
11c50 74 6d 70 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 tmp (any->number
11c60 20 70 72 69 6f 72 69 74 79 29 29 29 0a 09 09 09 priority)))....
11c70 09 20 20 20 20 28 69 66 20 74 6d 70 20 74 6d 70 . (if tmp tmp
11c80 20 28 62 65 67 69 6e 20 28 64 65 62 75 67 3a 70 (begin (debug:p
11c90 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 rint-error 0 *de
11ca0 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
11cb0 22 62 61 64 20 70 72 69 6f 72 69 74 79 20 76 61 "bad priority va
11cc0 6c 75 65 20 22 20 70 72 69 6f 72 69 74 79 20 22 lue " priority "
11cd0 2c 20 75 73 69 6e 67 20 30 22 29 20 30 29 29 29 , using 0") 0)))
11ce0 0a 09 09 09 09 20 20 30 29 29 29 0a 09 20 20 20 ..... 0)))..
11cf0 20 20 28 61 6c 6c 2d 74 65 73 74 73 20 20 20 20 (all-tests
11d00 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 (hash-table-ke
11d10 79 73 20 74 65 73 74 2d 72 65 63 6f 72 64 73 29 ys test-records)
11d20 29 0a 09 20 20 20 20 20 28 61 6c 6c 2d 77 61 69 ).. (all-wai
11d30 74 65 64 2d 6f 6e 20 20 28 6c 65 74 20 6c 6f 6f ted-on (let loo
11d40 70 20 28 28 68 65 64 20 28 63 61 72 20 61 6c 6c p ((hed (car all
11d50 2d 74 65 73 74 73 29 29 0a 09 09 09 09 09 28 74 -tests))......(t
11d60 61 6c 20 28 63 64 72 20 61 6c 6c 2d 74 65 73 74 al (cdr all-test
11d70 73 29 29 0a 09 09 09 09 09 28 72 65 73 20 27 28 s))......(res '(
11d80 29 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 6c ))).... (l
11d90 65 74 2a 20 28 28 74 72 65 63 20 20 20 20 28 68 et* ((trec (h
11da0 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 74 65 ash-table-ref te
11db0 73 74 2d 72 65 63 6f 72 64 73 20 68 65 64 29 29 st-records hed))
11dc0 0a 09 09 09 09 20 20 20 20 20 20 28 77 61 69 74 ..... (wait
11dd0 6f 6e 73 20 28 6f 72 20 28 74 65 73 74 73 3a 74 ons (or (tests:t
11de0 65 73 74 71 75 65 75 65 2d 67 65 74 2d 77 61 69 estqueue-get-wai
11df0 74 6f 6e 73 20 74 72 65 63 29 20 27 28 29 29 29 tons trec) '()))
11e00 29 0a 09 09 09 09 20 28 69 66 20 28 6e 75 6c 6c )..... (if (null
11e10 3f 20 74 61 6c 29 0a 09 09 09 09 20 20 20 20 20 ? tal).....
11e20 28 61 70 70 65 6e 64 20 72 65 73 20 77 61 69 74 (append res wait
11e30 6f 6e 73 29 0a 09 09 09 09 20 20 20 20 20 28 6c ons)..... (l
11e40 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 oop (car tal)(cd
11e50 72 20 74 61 6c 29 28 61 70 70 65 6e 64 20 72 65 r tal)(append re
11e60 73 20 77 61 69 74 6f 6e 73 29 29 29 29 29 29 0a s waitons)))))).
11e70 09 20 20 20 20 20 28 73 6f 72 74 2d 66 6e 31 20 . (sort-fn1
11e80 0a 09 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 .. (lambda
11e90 28 61 20 62 29 0a 09 09 28 6c 65 74 2a 20 28 28 (a b)...(let* ((
11ea0 61 2d 72 65 63 6f 72 64 20 20 20 28 68 61 73 68 a-record (hash
11eb0 2d 74 61 62 6c 65 2d 72 65 66 20 74 65 73 74 2d -table-ref test-
11ec0 72 65 63 6f 72 64 73 20 61 29 29 0a 09 09 20 20 records a))...
11ed0 20 20 20 20 20 28 62 2d 72 65 63 6f 72 64 20 20 (b-record
11ee0 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
11ef0 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 62 29 test-records b)
11f00 29 0a 09 09 20 20 20 20 20 20 20 28 61 2d 77 61 )... (a-wa
11f10 69 74 6f 6e 73 20 20 28 6f 72 20 28 74 65 73 74 itons (or (test
11f20 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d s:testqueue-get-
11f30 77 61 69 74 6f 6e 73 20 61 2d 72 65 63 6f 72 64 waitons a-record
11f40 29 20 27 28 29 29 29 0a 09 09 20 20 20 20 20 20 ) '()))...
11f50 20 28 62 2d 77 61 69 74 6f 6e 73 20 20 28 6f 72 (b-waitons (or
11f60 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 (tests:testqueu
11f70 65 2d 67 65 74 2d 77 61 69 74 6f 6e 73 20 62 2d e-get-waitons b-
11f80 72 65 63 6f 72 64 29 20 27 28 29 29 29 0a 09 09 record) '()))...
11f90 20 20 20 20 20 20 20 28 61 2d 63 6f 6e 66 69 67 (a-config
11fa0 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 (tests:testqu
11fb0 65 75 65 2d 67 65 74 2d 74 65 73 74 63 6f 6e 66 eue-get-testconf
11fc0 69 67 20 20 61 2d 72 65 63 6f 72 64 29 29 0a 09 ig a-record))..
11fd0 09 20 20 20 20 20 20 20 28 62 2d 63 6f 6e 66 69 . (b-confi
11fe0 67 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 g (tests:testq
11ff0 75 65 75 65 2d 67 65 74 2d 74 65 73 74 63 6f 6e ueue-get-testcon
12000 66 69 67 20 20 62 2d 72 65 63 6f 72 64 29 29 0a fig b-record)).
12010 09 09 20 20 20 20 20 20 20 28 61 2d 72 61 77 2d .. (a-raw-
12020 70 72 69 20 20 28 63 6f 6e 66 69 67 66 3a 6c 6f pri (configf:lo
12030 6f 6b 75 70 20 61 2d 63 6f 6e 66 69 67 20 22 72 okup a-config "r
12040 65 71 75 69 72 65 6d 65 6e 74 73 22 20 22 70 72 equirements" "pr
12050 69 6f 72 69 74 79 22 29 29 0a 09 09 20 20 20 20 iority"))...
12060 20 20 20 28 62 2d 72 61 77 2d 70 72 69 20 20 28 (b-raw-pri (
12070 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 62 configf:lookup b
12080 2d 63 6f 6e 66 69 67 20 22 72 65 71 75 69 72 65 -config "require
12090 6d 65 6e 74 73 22 20 22 70 72 69 6f 72 69 74 79 ments" "priority
120a0 22 29 29 0a 09 09 20 20 20 20 20 20 20 28 61 2d "))... (a-
120b0 70 72 69 6f 72 69 74 79 20 28 6d 75 6e 67 65 70 priority (mungep
120c0 72 69 6f 72 69 74 79 20 61 2d 72 61 77 2d 70 72 riority a-raw-pr
120d0 69 29 29 0a 09 09 20 20 20 20 20 20 20 28 62 2d i))... (b-
120e0 70 72 69 6f 72 69 74 79 20 28 6d 75 6e 67 65 70 priority (mungep
120f0 72 69 6f 72 69 74 79 20 62 2d 72 61 77 2d 70 72 riority b-raw-pr
12100 69 29 29 29 0a 09 09 20 20 28 74 65 73 74 73 3a i)))... (tests:
12110 74 65 73 74 71 75 65 75 65 2d 73 65 74 2d 70 72 testqueue-set-pr
12120 69 6f 72 69 74 79 21 20 61 2d 72 65 63 6f 72 64 iority! a-record
12130 20 61 2d 70 72 69 6f 72 69 74 79 29 0a 09 09 20 a-priority)...
12140 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 (tests:testqueu
12150 65 2d 73 65 74 2d 70 72 69 6f 72 69 74 79 21 20 e-set-priority!
12160 62 2d 72 65 63 6f 72 64 20 62 2d 70 72 69 6f 72 b-record b-prior
12170 69 74 79 29 0a 09 09 20 20 3b 3b 20 28 64 65 62 ity)... ;; (deb
12180 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
12190 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 61 ult-log-port* "a
121a0 3d 22 20 61 20 22 2c 20 62 3d 22 20 62 20 22 2c =" a ", b=" b ",
121b0 20 61 2d 77 61 69 74 6f 6e 73 3d 22 20 61 2d 77 a-waitons=" a-w
121c0 61 69 74 6f 6e 73 20 22 2c 20 62 2d 77 61 69 74 aitons ", b-wait
121d0 6f 6e 73 3d 22 20 62 2d 77 61 69 74 6f 6e 73 29 ons=" b-waitons)
121e0 0a 09 09 20 20 28 63 6f 6e 64 0a 09 09 20 20 20 ... (cond...
121f0 3b 3b 20 69 73 20 0a 09 09 20 20 20 28 28 6d 65 ;; is ... ((me
12200 6d 62 65 72 20 61 20 62 2d 77 61 69 74 6f 6e 73 mber a b-waitons
12210 29 20 20 20 20 20 20 20 20 20 20 3b 3b 20 69 73 ) ;; is
12220 20 62 20 77 61 69 74 69 6e 67 20 6f 6e 20 61 3f b waiting on a?
12230 0a 09 09 20 20 20 20 3b 3b 20 28 64 65 62 75 67 ... ;; (debug
12240 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
12250 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 63 61 73 t-log-port* "cas
12260 65 31 22 29 0a 09 09 20 20 20 20 23 74 29 0a 09 e1")... #t)..
12270 09 20 20 20 28 28 6d 65 6d 62 65 72 20 62 20 61 . ((member b a
12280 2d 77 61 69 74 6f 6e 73 29 20 20 20 20 20 20 20 -waitons)
12290 20 20 20 3b 3b 20 69 73 20 61 20 77 61 69 74 69 ;; is a waiti
122a0 6e 67 20 6f 6e 20 62 3f 0a 09 09 20 20 20 20 3b ng on b?... ;
122b0 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 ; (debug:print 0
122c0 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
122d0 72 74 2a 20 22 63 61 73 65 32 22 29 0a 09 09 20 rt* "case2")...
122e0 20 20 20 23 66 29 0a 09 09 20 20 20 28 28 61 6e #f)... ((an
122f0 64 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 61 2d d (not (null? a-
12300 77 61 69 74 6f 6e 73 29 29 20 20 3b 3b 20 62 6f waitons)) ;; bo
12310 74 68 20 68 61 76 65 20 77 61 69 74 6f 6e 73 20 th have waitons
12320 2d 20 64 6f 20 6e 6f 74 20 64 69 73 74 75 72 62 - do not disturb
12330 0a 09 09 09 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f .... (not (null?
12340 20 62 2d 77 61 69 74 6f 6e 73 29 29 29 0a 09 09 b-waitons)))...
12350 20 20 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 ;; (debug:pr
12360 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
12370 6f 67 2d 70 6f 72 74 2a 20 22 63 61 73 65 32 2e og-port* "case2.
12380 31 22 29 0a 09 09 20 20 20 20 23 74 29 0a 09 09 1")... #t)...
12390 20 20 20 28 28 61 6e 64 20 28 6e 75 6c 6c 3f 20 ((and (null?
123a0 61 2d 77 61 69 74 6f 6e 73 29 20 20 20 20 20 20 a-waitons)
123b0 20 20 3b 3b 20 6e 6f 20 77 61 69 74 6f 6e 73 20 ;; no waitons
123c0 66 6f 72 20 61 20 62 75 74 20 62 20 68 61 73 20 for a but b has
123d0 77 61 69 74 6f 6e 73 0a 09 09 09 20 28 6e 6f 74 waitons.... (not
123e0 20 28 6e 75 6c 6c 3f 20 62 2d 77 61 69 74 6f 6e (null? b-waiton
123f0 73 29 29 29 0a 09 09 20 20 20 20 3b 3b 20 28 64 s)))... ;; (d
12400 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
12410 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
12420 22 63 61 73 65 33 22 29 0a 09 09 20 20 20 20 23 "case3")... #
12430 66 29 0a 09 09 20 20 20 28 28 61 6e 64 20 28 6e f)... ((and (n
12440 6f 74 20 28 6e 75 6c 6c 3f 20 61 2d 77 61 69 74 ot (null? a-wait
12450 6f 6e 73 29 29 20 20 3b 3b 20 61 20 68 61 73 20 ons)) ;; a has
12460 77 61 69 74 6f 6e 73 20 62 75 74 20 62 20 64 6f waitons but b do
12470 65 73 20 6e 6f 74 0a 09 09 09 20 28 6e 75 6c 6c es not.... (null
12480 3f 20 62 2d 77 61 69 74 6f 6e 73 29 29 20 0a 09 ? b-waitons)) ..
12490 09 20 20 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 . ;; (debug:p
124a0 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
124b0 6c 6f 67 2d 70 6f 72 74 2a 20 22 63 61 73 65 34 log-port* "case4
124c0 22 29 0a 09 09 20 20 20 20 23 74 29 0a 09 09 20 ")... #t)...
124d0 20 20 28 28 6e 6f 74 20 28 65 71 3f 20 61 2d 70 ((not (eq? a-p
124e0 72 69 6f 72 69 74 79 20 62 2d 70 72 69 6f 72 69 riority b-priori
124f0 74 79 29 29 20 3b 3b 20 75 73 65 0a 09 09 20 20 ty)) ;; use...
12500 20 20 28 3e 20 61 2d 70 72 69 6f 72 69 74 79 20 (> a-priority
12510 62 2d 70 72 69 6f 72 69 74 79 29 29 0a 09 09 20 b-priority))...
12520 20 20 28 65 6c 73 65 0a 09 09 20 20 20 20 3b 3b (else... ;;
12530 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
12540 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
12550 74 2a 20 22 63 61 73 65 35 22 29 0a 09 09 20 20 t* "case5")...
12560 20 20 28 73 74 72 69 6e 67 3e 3f 20 61 20 62 29 (string>? a b)
12570 29 29 29 29 29 0a 09 20 20 20 20 20 0a 09 20 20 ))))).. ..
12580 20 20 20 28 73 6f 72 74 2d 66 6e 32 0a 09 20 20 (sort-fn2..
12590 20 20 20 20 28 6c 61 6d 62 64 61 20 28 61 20 62 (lambda (a b
125a0 29 0a 09 09 28 3e 20 28 6d 75 6e 67 65 70 72 69 )...(> (mungepri
125b0 6f 72 69 74 79 20 28 74 65 73 74 73 3a 74 65 73 ority (tests:tes
125c0 74 71 75 65 75 65 2d 67 65 74 2d 70 72 69 6f 72 tqueue-get-prior
125d0 69 74 79 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ity (hash-table-
125e0 72 65 66 20 74 65 73 74 2d 72 65 63 6f 72 64 73 ref test-records
125f0 20 61 29 29 29 0a 09 09 20 20 20 28 6d 75 6e 67 a)))... (mung
12600 65 70 72 69 6f 72 69 74 79 20 28 74 65 73 74 73 epriority (tests
12610 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 70 :testqueue-get-p
12620 72 69 6f 72 69 74 79 20 28 68 61 73 68 2d 74 61 riority (hash-ta
12630 62 6c 65 2d 72 65 66 20 74 65 73 74 2d 72 65 63 ble-ref test-rec
12640 6f 72 64 73 20 62 29 29 29 29 29 29 29 0a 09 3b ords b)))))))..;
12650 3b 20 28 6c 65 74 20 28 28 64 6f 74 2d 72 65 73 ; (let ((dot-res
12660 20 28 74 65 73 74 73 3a 72 75 6e 2d 64 6f 74 20 (tests:run-dot
12670 28 74 65 73 74 73 3a 74 65 73 74 73 2d 3e 64 6f (tests:tests->do
12680 74 20 74 65 73 74 2d 72 65 63 6f 72 64 73 29 20 t test-records)
12690 22 70 6c 61 69 6e 22 29 29 29 0a 09 3b 3b 20 20 "plain")))..;;
126a0 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 22 64 (debug:print "d
126b0 6f 74 2d 72 65 73 3d 22 20 64 6f 74 2d 72 65 73 ot-res=" dot-res
126c0 29 29 0a 09 3b 3b 20 28 6c 65 74 20 28 28 64 61 ))..;; (let ((da
126d0 74 61 20 28 6d 61 70 20 63 64 72 20 28 66 69 6c ta (map cdr (fil
126e0 74 65 72 0a 09 3b 3b 20 20 20 20 20 09 09 20 20 ter..;; ..
126f0 28 6c 61 6d 62 64 61 20 28 78 29 28 65 71 75 61 (lambda (x)(equa
12700 6c 3f 20 22 6e 6f 64 65 22 20 28 63 61 72 20 78 l? "node" (car x
12710 29 29 29 0a 09 3b 3b 20 20 20 20 20 09 09 20 20 )))..;; ..
12720 28 6d 61 70 20 73 74 72 69 6e 67 2d 73 70 6c 69 (map string-spli
12730 74 20 28 74 65 73 74 73 3a 65 61 73 79 2d 64 6f t (tests:easy-do
12740 74 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 22 t test-records "
12750 70 6c 61 69 6e 22 29 29 29 29 29 29 0a 09 3b 3b plain"))))))..;;
12760 20 20 20 28 6d 61 70 20 63 61 72 20 28 73 6f 72 (map car (sor
12770 74 20 64 61 74 61 20 28 6c 61 6d 62 64 61 20 28 t data (lambda (
12780 61 20 62 29 0a 09 3b 3b 20 20 20 20 20 09 09 20 a b)..;; ..
12790 20 20 20 28 3e 20 28 73 74 72 69 6e 67 2d 3e 6e (> (string->n
127a0 75 6d 62 65 72 20 28 63 61 64 64 72 20 61 29 29 umber (caddr a))
127b0 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 (string->number
127c0 28 63 61 64 64 72 20 62 29 29 29 29 29 29 29 0a (caddr b))))))).
127d0 09 3b 3b 20 29 29 0a 09 28 73 6f 72 74 20 61 6c .;; ))..(sort al
127e0 6c 2d 74 65 73 74 73 20 73 6f 72 74 2d 66 6e 31 l-tests sort-fn1
127f0 29 29 29 29 20 3b 3b 20 61 76 6f 69 64 20 64 65 )))) ;; avoid de
12800 61 6c 69 6e 67 20 77 69 74 68 20 64 65 6c 65 74 aling with delet
12810 65 64 20 74 65 73 74 73 2c 20 6c 6f 6f 6b 20 61 ed tests, look a
12820 74 20 74 68 65 20 68 61 73 68 20 74 61 62 6c 65 t the hash table
12830 0a 0a 3b 3b 20 6c 6f 6f 6b 20 75 70 20 61 6c 6c ..;; look up all
12840 20 77 61 69 74 6f 6e 73 20 74 68 61 74 20 61 72 waitons that ar
12850 65 20 72 65 6c 61 74 65 64 20 74 6f 20 74 65 73 e related to tes
12860 74 20 22 74 65 73 74 6e 61 6d 65 22 0a 3b 3b 0a t "testname".;;.
12870 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 67 (define (tests:g
12880 65 74 2d 6d 74 2d 77 61 69 74 6f 6e 73 20 74 65 et-mt-waitons te
12890 73 74 6e 61 6d 65 20 66 6c 61 74 74 65 6e 29 0a stname flatten).
128a0 20 20 28 6c 65 74 2a 20 28 28 6d 74 2d 77 61 69 (let* ((mt-wai
128b0 74 6f 6e 73 20 20 20 20 28 63 6f 6e 66 69 67 66 tons (configf
128c0 3a 67 65 74 2d 73 65 63 74 69 6f 6e 20 2a 63 6f :get-section *co
128d0 6e 66 69 67 64 61 74 2a 20 22 77 61 69 74 6f 6e nfigdat* "waiton
128e0 73 22 29 29 0a 09 20 28 6d 79 2d 77 61 69 74 6f s")).. (my-waito
128f0 6e 73 20 20 20 20 28 66 69 6c 74 65 72 0a 09 09 ns (filter...
12900 09 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 09 . (lambda (x)...
12910 09 20 20 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 . (string-matc
12920 68 20 28 63 6f 6e 63 20 22 5e 28 22 20 74 65 73 h (conc "^(" tes
12930 74 6e 61 6d 65 20 22 7c 22 20 74 65 73 74 6e 61 tname "|" testna
12940 6d 65 22 2f 2e 2a 29 24 22 29 20 28 63 61 72 20 me"/.*)$") (car
12950 78 29 29 29 0a 09 09 09 20 6d 74 2d 77 61 69 74 x))).... mt-wait
12960 6f 6e 73 29 29 29 0a 20 20 20 20 28 69 66 20 66 ons))). (if f
12970 6c 61 74 74 65 6e 0a 09 28 6d 61 70 20 28 6c 61 latten..(map (la
12980 6d 62 64 61 20 28 77 29 0a 09 20 20 20 20 20 20 mbda (w)..
12990 20 28 63 61 72 20 28 73 74 72 69 6e 67 2d 73 70 (car (string-sp
129a0 6c 69 74 20 77 20 22 2f 22 29 29 29 0a 09 20 20 lit w "/")))..
129b0 20 20 20 28 61 70 70 6c 79 20 61 70 70 65 6e 64 (apply append
129c0 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 78 (map (lambda (x
129d0 29 0a 09 09 09 09 20 20 28 73 74 72 69 6e 67 2d )..... (string-
129e0 73 70 6c 69 74 20 28 63 61 64 72 20 78 29 29 29 split (cadr x)))
129f0 0a 09 09 09 09 6d 79 2d 77 61 69 74 6f 6e 73 29 .....my-waitons)
12a00 29 29 0a 09 6d 79 2d 77 61 69 74 6f 6e 73 29 29 ))..my-waitons))
12a10 29 0a 0a 3b 3b 20 4e 4f 54 20 55 53 45 44 0a 28 )..;; NOT USED.(
12a20 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 65 61 define (tests:ea
12a30 73 79 2d 64 6f 74 20 74 65 73 74 2d 72 65 63 6f sy-dot test-reco
12a40 72 64 73 20 6f 75 74 74 79 70 65 29 0a 20 20 28 rds outtype). (
12a50 6c 65 74 2d 76 61 6c 75 65 73 20 28 28 28 66 64 let-values (((fd
12a60 20 74 65 6d 70 2d 70 61 74 68 29 20 28 66 69 6c temp-path) (fil
12a70 65 2d 6d 6b 73 74 65 6d 70 20 28 63 6f 6e 63 20 e-mkstemp (conc
12a80 22 2f 74 6d 70 2f 22 20 28 63 75 72 72 65 6e 74 "/tmp/" (current
12a90 2d 75 73 65 72 2d 6e 61 6d 65 29 20 22 2e 58 58 -user-name) ".XX
12aa0 58 58 58 58 22 29 29 29 29 0a 20 20 20 20 28 6c XXXX")))). (l
12ab0 65 74 20 28 28 61 6c 6c 2d 74 65 73 74 6e 61 6d et ((all-testnam
12ac0 65 73 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b es (hash-table-k
12ad0 65 79 73 20 74 65 73 74 2d 72 65 63 6f 72 64 73 eys test-records
12ae0 29 29 0a 09 20 20 28 74 65 6d 70 2d 70 6f 72 74 )).. (temp-port
12af0 20 20 20 20 20 28 6f 70 65 6e 2d 6f 75 74 70 75 (open-outpu
12b00 74 2d 66 69 6c 65 2a 20 66 64 29 29 29 0a 20 20 t-file* fd))).
12b10 20 20 20 20 3b 3b 20 28 66 6f 72 6d 61 74 20 74 ;; (format t
12b20 65 6d 70 2d 70 6f 72 74 20 22 54 68 69 73 20 66 emp-port "This f
12b30 69 6c 65 20 69 73 20 7e 41 2e 7e 25 22 20 74 65 ile is ~A.~%" te
12b40 6d 70 2d 70 61 74 68 29 0a 20 20 20 20 20 20 28 mp-path). (
12b50 66 6f 72 6d 61 74 20 74 65 6d 70 2d 70 6f 72 74 format temp-port
12b60 20 22 64 69 67 72 61 70 68 20 74 65 73 74 73 20 "digraph tests
12b70 7b 5c 6e 22 29 0a 20 20 20 20 20 20 28 66 6f 72 {\n"). (for
12b80 6d 61 74 20 74 65 6d 70 2d 70 6f 72 74 20 22 20 mat temp-port "
12b90 20 73 69 7a 65 3d 34 2c 38 5c 6e 22 29 0a 20 20 size=4,8\n").
12ba0 20 20 20 20 3b 3b 20 28 66 6f 72 6d 61 74 20 74 ;; (format t
12bb0 65 6d 70 2d 70 6f 72 74 20 22 20 20 20 73 70 6c emp-port " spl
12bc0 69 6e 65 73 3d 6e 6f 6e 65 5c 6e 22 29 0a 20 20 ines=none\n").
12bd0 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 (for-each.
12be0 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 74 65 (lambda (te
12bf0 73 74 6e 61 6d 65 29 0a 09 20 28 6c 65 74 2a 20 stname).. (let*
12c00 28 28 74 65 73 74 72 65 63 20 28 68 61 73 68 2d ((testrec (hash-
12c10 74 61 62 6c 65 2d 72 65 66 20 74 65 73 74 2d 72 table-ref test-r
12c20 65 63 6f 72 64 73 20 74 65 73 74 6e 61 6d 65 29 ecords testname)
12c30 29 0a 09 09 28 77 61 69 74 6f 6e 73 20 28 6f 72 )...(waitons (or
12c40 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 (tests:testqueu
12c50 65 2d 67 65 74 2d 77 61 69 74 6f 6e 73 20 74 65 e-get-waitons te
12c60 73 74 72 65 63 29 20 27 28 29 29 29 0a 09 09 28 strec) '()))...(
12c70 6d 79 2d 6d 74 2d 77 61 69 74 6f 6e 73 20 28 74 my-mt-waitons (t
12c80 65 73 74 73 3a 67 65 74 2d 6d 74 2d 77 61 69 74 ests:get-mt-wait
12c90 6f 6e 73 20 74 65 73 74 6e 61 6d 65 20 23 74 29 ons testname #t)
12ca0 29 29 0a 09 20 20 20 3b 3b 20 28 70 72 69 6e 74 )).. ;; (print
12cb0 20 22 6d 79 2d 6d 74 2d 77 61 69 74 6f 6e 73 3d "my-mt-waitons=
12cc0 22 20 6d 79 2d 6d 74 2d 77 61 69 74 6f 6e 73 29 " my-mt-waitons)
12cd0 0a 09 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 09 .. (for-each..
12ce0 20 20 20 20 28 6c 61 6d 62 64 61 20 28 77 61 69 (lambda (wai
12cf0 74 6f 6e 29 0a 09 20 20 20 20 20 20 28 66 6f 72 ton).. (for
12d00 6d 61 74 20 74 65 6d 70 2d 70 6f 72 74 20 28 63 mat temp-port (c
12d10 6f 6e 63 20 22 20 20 20 22 20 77 61 69 74 6f 6e onc " " waiton
12d20 20 22 20 2d 3e 20 22 20 74 65 73 74 6e 61 6d 65 " -> " testname
12d30 20 22 20 5b 73 70 6c 69 6e 65 73 3d 6f 72 74 68 " [splines=orth
12d40 6f 5d 5c 6e 22 29 29 29 0a 09 20 20 20 20 28 61 o]\n"))).. (a
12d50 70 70 65 6e 64 20 77 61 69 74 6f 6e 73 20 6d 79 ppend waitons my
12d60 2d 6d 74 2d 77 61 69 74 6f 6e 73 29 29 29 29 0a -mt-waitons)))).
12d70 20 20 20 20 20 20 20 61 6c 6c 2d 74 65 73 74 6e all-testn
12d80 61 6d 65 73 29 0a 20 20 20 20 20 20 28 66 6f 72 ames). (for
12d90 6d 61 74 20 74 65 6d 70 2d 70 6f 72 74 20 22 7d mat temp-port "}
12da0 5c 6e 22 29 0a 20 20 20 20 20 20 28 63 6c 6f 73 \n"). (clos
12db0 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 74 65 e-output-port te
12dc0 6d 70 2d 70 6f 72 74 29 0a 20 20 20 20 20 20 28 mp-port). (
12dd0 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d with-input-from-
12de0 70 69 70 65 0a 20 20 20 20 20 20 20 28 63 6f 6e pipe. (con
12df0 63 20 22 65 6e 76 20 2d 69 20 50 41 54 48 3d 24 c "env -i PATH=$
12e00 50 41 54 48 20 64 6f 74 20 2d 54 22 20 6f 75 74 PATH dot -T" out
12e10 74 79 70 65 20 22 20 3c 20 22 20 74 65 6d 70 2d type " < " temp-
12e20 70 61 74 68 29 0a 20 20 20 20 20 20 20 28 6c 61 path). (la
12e30 6d 62 64 61 20 28 29 0a 09 20 28 6c 65 74 20 28 mbda ().. (let (
12e40 28 72 65 73 20 28 72 65 61 64 2d 6c 69 6e 65 73 (res (read-lines
12e50 29 29 29 0a 09 20 20 20 3b 3b 20 28 64 65 6c 65 ))).. ;; (dele
12e60 74 65 2d 66 69 6c 65 20 74 65 6d 70 2d 70 61 74 te-file temp-pat
12e70 68 29 0a 09 20 20 20 72 65 73 29 29 29 29 29 29 h).. res))))))
12e80 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 ..(define (tests
12e90 3a 77 72 69 74 65 2d 64 6f 74 2d 66 69 6c 65 20 :write-dot-file
12ea0 74 65 73 74 2d 72 65 63 6f 72 64 73 20 66 6e 61 test-records fna
12eb0 6d 65 20 73 69 7a 65 78 20 73 69 7a 65 79 29 0a me sizex sizey).
12ec0 20 20 28 69 66 20 28 66 69 6c 65 2d 77 72 69 74 (if (file-writ
12ed0 65 2d 61 63 63 65 73 73 3f 20 28 70 61 74 68 6e e-access? (pathn
12ee0 61 6d 65 2d 64 69 72 65 63 74 6f 72 79 20 66 6e ame-directory fn
12ef0 61 6d 65 29 29 0a 20 20 20 20 20 20 28 77 69 74 ame)). (wit
12f00 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 66 69 6c 65 h-output-to-file
12f10 20 66 6e 61 6d 65 0a 09 28 6c 61 6d 62 64 61 20 fname..(lambda
12f20 28 29 0a 09 20 20 28 6d 61 70 20 70 72 69 6e 74 ().. (map print
12f30 20 28 74 65 73 74 73 3a 74 65 73 74 73 2d 3e 64 (tests:tests->d
12f40 6f 74 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 ot test-records
12f50 73 69 7a 65 78 20 73 69 7a 65 79 29 29 29 29 29 sizex sizey)))))
12f60 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 )..(define (test
12f70 73 3a 74 65 73 74 73 2d 3e 64 6f 74 20 74 65 73 s:tests->dot tes
12f80 74 2d 72 65 63 6f 72 64 73 20 73 69 7a 65 78 20 t-records sizex
12f90 73 69 7a 65 79 29 0a 20 20 28 6c 65 74 20 28 28 sizey). (let ((
12fa0 61 6c 6c 2d 74 65 73 74 6e 61 6d 65 73 20 28 68 all-testnames (h
12fb0 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 74 ash-table-keys t
12fc0 65 73 74 2d 72 65 63 6f 72 64 73 29 29 29 0a 20 est-records))).
12fd0 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 61 6c (if (null? al
12fe0 6c 2d 74 65 73 74 6e 61 6d 65 73 29 0a 09 27 28 l-testnames)..'(
12ff0 29 0a 09 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 )..(let loop ((h
13000 65 64 20 28 63 61 72 20 61 6c 6c 2d 74 65 73 74 ed (car all-test
13010 6e 61 6d 65 73 29 29 0a 09 09 20 20 20 28 74 61 names))... (ta
13020 6c 20 28 63 64 72 20 61 6c 6c 2d 74 65 73 74 6e l (cdr all-testn
13030 61 6d 65 73 29 29 0a 09 09 20 20 20 28 72 65 73 ames))... (res
13040 20 28 6c 69 73 74 20 22 64 69 67 72 61 70 68 20 (list "digraph
13050 74 65 73 74 73 20 7b 22 0a 09 09 09 20 20 20 20 tests {"....
13060 20 20 28 63 6f 6e 63 20 22 20 73 69 7a 65 3d 5c (conc " size=\
13070 22 22 20 28 6f 72 20 73 69 7a 65 78 20 31 31 29 "" (or sizex 11)
13080 20 22 2c 22 20 28 6f 72 20 73 69 7a 65 79 20 31 "," (or sizey 1
13090 31 29 20 22 5c 22 3b 22 29 0a 09 09 09 20 20 20 1) "\";")....
130a0 20 20 20 22 20 72 61 74 69 6f 3d 30 2e 39 35 3b " ratio=0.95;
130b0 22 0a 09 09 09 20 20 20 20 20 20 29 29 29 0a 09 ".... )))..
130c0 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 72 65 (let* ((testre
130d0 63 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 c (hash-table-re
130e0 66 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 68 f test-records h
130f0 65 64 29 29 0a 09 09 20 28 77 61 69 74 6f 6e 73 ed))... (waitons
13100 20 28 6f 72 20 28 74 65 73 74 73 3a 74 65 73 74 (or (tests:test
13110 71 75 65 75 65 2d 67 65 74 2d 77 61 69 74 6f 6e queue-get-waiton
13120 73 20 74 65 73 74 72 65 63 29 20 27 28 29 29 29 s testrec) '()))
13130 0a 09 09 20 28 6d 79 2d 6d 74 2d 77 61 69 74 6f ... (my-mt-waito
13140 6e 73 20 28 74 65 73 74 73 3a 67 65 74 2d 6d 74 ns (tests:get-mt
13150 2d 77 61 69 74 6f 6e 73 20 68 65 64 20 23 74 29 -waitons hed #t)
13160 29 0a 09 09 20 28 61 6c 6c 2d 77 61 69 74 6f 6e )... (all-waiton
13170 73 20 20 20 28 64 65 6c 65 74 65 2d 64 75 70 6c s (delete-dupl
13180 69 63 61 74 65 73 20 28 61 70 70 65 6e 64 20 77 icates (append w
13190 61 69 74 6f 6e 73 20 6d 79 2d 6d 74 2d 77 61 69 aitons my-mt-wai
131a0 74 6f 6e 73 29 29 29 0a 09 09 20 28 6e 65 77 72 tons)))... (newr
131b0 65 73 20 20 28 61 70 70 65 6e 64 20 72 65 73 0a es (append res.
131c0 09 09 09 09 20 20 28 69 66 20 28 6e 75 6c 6c 3f .... (if (null?
131d0 20 61 6c 6c 2d 77 61 69 74 6f 6e 73 29 0a 09 09 all-waitons)...
131e0 09 09 20 20 20 20 20 20 28 6c 69 73 74 20 28 63 .. (list (c
131f0 6f 6e 63 20 22 20 20 20 5c 22 22 20 68 65 64 20 onc " \"" hed
13200 22 5c 22 20 5b 73 68 61 70 65 3d 62 6f 78 5d 3b "\" [shape=box];
13210 22 29 29 0a 09 09 09 09 20 20 20 20 20 20 28 6d "))..... (m
13220 61 70 20 28 6c 61 6d 62 64 61 20 28 77 61 69 74 ap (lambda (wait
13230 6f 6e 29 0a 09 09 09 09 09 20 20 20 20 20 28 63 on)...... (c
13240 6f 6e 63 20 22 20 20 20 5c 22 22 20 77 61 69 74 onc " \"" wait
13250 6f 6e 20 22 5c 22 20 2d 3e 20 5c 22 22 20 68 65 on "\" -> \"" he
13260 64 20 22 5c 22 20 5b 73 68 61 70 65 3d 62 6f 78 d "\" [shape=box
13270 5d 3b 22 29 29 0a 09 09 09 09 09 20 20 20 61 6c ];"))...... al
13280 6c 2d 77 61 69 74 6f 6e 73 29 29 29 29 29 0a 09 l-waitons)))))..
13290 20 20 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 ;; (debug:pr
132a0 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
132b0 6f 67 2d 70 6f 72 74 2a 20 22 46 6f 72 20 74 65 og-port* "For te
132c0 73 74 20 22 68 65 64 22 20 67 6f 74 20 22 61 6c st "hed" got "al
132d0 6c 2d 77 61 69 74 6f 6e 73 29 0a 09 20 20 20 20 l-waitons)..
132e0 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a (if (null? tal).
132f0 09 09 28 61 70 70 65 6e 64 20 6e 65 77 72 65 73 ..(append newres
13300 20 28 6c 69 73 74 20 22 7d 22 29 29 0a 09 09 28 (list "}"))...(
13310 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 loop (car tal)(c
13320 64 72 20 74 61 6c 29 20 6e 65 77 72 65 73 29 0a dr tal) newres).
13330 09 09 29 29 29 29 29 29 0a 0a 3b 3b 20 28 74 65 ..))))))..;; (te
13340 73 74 73 3a 72 75 6e 2d 64 6f 74 20 28 6c 69 73 sts:run-dot (lis
13350 74 20 22 64 69 67 72 61 70 68 20 74 65 73 74 73 t "digraph tests
13360 20 7b 22 20 22 61 20 2d 3e 20 62 22 20 22 7d 22 {" "a -> b" "}"
13370 29 20 22 70 6c 61 69 6e 22 29 0a 0a 28 64 65 66 ) "plain")..(def
13380 69 6e 65 20 28 74 65 73 74 73 3a 72 75 6e 2d 64 ine (tests:run-d
13390 6f 74 20 69 6e 64 61 74 20 6f 75 74 74 79 70 65 ot indat outtype
133a0 29 20 3b 3b 20 6f 75 74 74 79 70 65 20 69 73 20 ) ;; outtype is
133b0 70 6c 61 69 6e 2c 20 66 69 67 2c 20 64 6f 74 2c plain, fig, dot,
133c0 20 65 74 63 2e 20 68 74 74 70 3a 2f 2f 77 77 77 etc. http://www
133d0 2e 67 72 61 70 68 76 69 7a 2e 6f 72 67 2f 63 6f .graphviz.org/co
133e0 6e 74 65 6e 74 2f 6f 75 74 70 75 74 2d 66 6f 72 ntent/output-for
133f0 6d 61 74 73 0a 20 20 28 6c 65 74 2d 76 61 6c 75 mats. (let-valu
13400 65 73 20 28 28 28 69 6e 70 20 6f 75 70 20 70 69 es (((inp oup pi
13410 64 29 28 70 72 6f 63 65 73 73 20 22 65 6e 76 20 d)(process "env
13420 2d 69 20 50 41 54 48 3d 24 50 41 54 48 20 64 6f -i PATH=$PATH do
13430 74 22 20 28 6c 69 73 74 20 22 2d 54 22 20 6f 75 t" (list "-T" ou
13440 74 74 79 70 65 29 29 29 29 0a 20 20 20 20 28 77 ttype)))). (w
13450 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 70 6f ith-output-to-po
13460 72 74 20 6f 75 70 0a 20 20 20 20 20 20 28 6c 61 rt oup. (la
13470 6d 62 64 61 20 28 29 0a 09 28 6d 61 70 20 70 72 mbda ()..(map pr
13480 69 6e 74 20 69 6e 64 61 74 29 29 29 0a 20 20 20 int indat))).
13490 20 28 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d 70 (close-output-p
134a0 6f 72 74 20 6f 75 70 29 0a 20 20 20 20 28 6c 65 ort oup). (le
134b0 74 20 28 28 72 65 73 20 28 77 69 74 68 2d 69 6e t ((res (with-in
134c0 70 75 74 2d 66 72 6f 6d 2d 70 6f 72 74 20 69 6e put-from-port in
134d0 70 0a 09 09 20 28 6c 61 6d 62 64 61 20 28 29 0a p... (lambda ().
134e0 09 09 20 20 20 28 72 65 61 64 2d 6c 69 6e 65 73 .. (read-lines
134f0 29 29 29 29 29 0a 20 20 20 20 20 20 28 63 6c 6f ))))). (clo
13500 73 65 2d 69 6e 70 75 74 2d 70 6f 72 74 20 69 6e se-input-port in
13510 70 29 0a 20 20 20 20 20 20 72 65 73 29 29 29 0a p). res))).
13520 0a 3b 3b 20 72 65 61 64 20 64 61 74 61 20 66 72 .;; read data fr
13530 6f 6d 20 74 6d 70 20 66 69 6c 65 20 6f 72 20 63 om tmp file or c
13540 72 65 61 74 65 20 69 66 20 6e 6f 74 20 65 78 69 reate if not exi
13550 73 74 73 0a 3b 3b 20 69 66 20 65 78 69 73 74 73 sts.;; if exists
13560 20 72 65 67 65 6e 20 69 6e 20 62 61 63 6b 67 72 regen in backgr
13570 6f 75 6e 64 0a 3b 3b 20 6d 6f 64 65 3a 20 72 61 ound.;; mode: ra
13580 77 20 28 72 65 74 75 72 6e 20 64 61 74 61 20 61 w (return data a
13590 73 20 72 65 61 64 29 20 6f 72 20 6d 75 6e 67 65 s read) or munge
135a0 64 20 28 63 6f 6e 76 65 72 74 20 74 6f 20 6c 69 d (convert to li
135b0 73 74 20 6f 66 20 6c 69 73 74 73 20 61 6e 64 20 st of lists and
135c0 72 65 6d 6f 76 65 20 22 20 66 72 6f 6d 20 73 74 remove " from st
135d0 72 69 6e 67 73 29 0a 3b 3b 0a 28 64 65 66 69 6e rings).;;.(defin
135e0 65 20 28 74 65 73 74 73 3a 6c 61 7a 79 2d 64 6f e (tests:lazy-do
135f0 74 20 74 65 73 74 72 65 63 6f 72 64 73 20 20 6f t testrecords o
13600 75 74 74 79 70 65 20 73 69 7a 65 78 20 73 69 7a uttype sizex siz
13610 65 79 20 6d 6f 64 65 29 0a 20 20 28 6c 65 74 20 ey mode). (let
13620 28 28 64 66 69 6c 65 20 28 63 6f 6e 63 20 22 2f ((dfile (conc "/
13630 74 6d 70 2f 2e 22 20 28 63 75 72 72 65 6e 74 2d tmp/." (current-
13640 75 73 65 72 2d 6e 61 6d 65 29 20 22 2d 22 20 28 user-name) "-" (
13650 73 65 72 76 65 72 3a 6d 6b 2d 73 69 67 6e 61 74 server:mk-signat
13660 75 72 65 29 20 22 2e 64 6f 74 22 29 29 0a 09 28 ure) ".dot"))..(
13670 66 6e 61 6d 65 20 28 63 6f 6e 63 20 22 2f 74 6d fname (conc "/tm
13680 70 2f 2e 22 20 28 63 75 72 72 65 6e 74 2d 75 73 p/." (current-us
13690 65 72 2d 6e 61 6d 65 29 20 22 2d 22 20 28 73 65 er-name) "-" (se
136a0 72 76 65 72 3a 6d 6b 2d 73 69 67 6e 61 74 75 72 rver:mk-signatur
136b0 65 29 20 22 2e 64 6f 74 64 61 74 22 29 29 29 0a e) ".dotdat"))).
136c0 20 20 20 20 28 74 65 73 74 73 3a 77 72 69 74 65 (tests:write
136d0 2d 64 6f 74 2d 66 69 6c 65 20 74 65 73 74 72 65 -dot-file testre
136e0 63 6f 72 64 73 20 64 66 69 6c 65 20 73 69 7a 65 cords dfile size
136f0 78 20 73 69 7a 65 79 29 0a 20 20 20 20 28 6c 65 x sizey). (le
13700 74 20 28 28 64 61 74 61 20 28 69 66 20 28 63 6f t ((data (if (co
13710 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 mmon:file-exists
13720 3f 20 66 6e 61 6d 65 29 0a 09 09 20 20 20 20 28 ? fname)... (
13730 6c 65 74 20 28 28 72 65 73 20 28 77 69 74 68 2d let ((res (with-
13740 69 6e 70 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 20 input-from-file
13750 66 6e 61 6d 65 0a 09 09 09 09 20 28 6c 61 6d 62 fname..... (lamb
13760 64 61 20 28 29 0a 09 09 09 09 20 20 20 28 72 65 da ()..... (re
13770 61 64 2d 6c 69 6e 65 73 29 29 29 29 29 0a 09 09 ad-lines)))))...
13780 20 20 20 20 20 20 28 73 79 73 74 65 6d 20 28 63 (system (c
13790 6f 6e 63 20 22 65 6e 76 20 2d 69 20 50 41 54 48 onc "env -i PATH
137a0 3d 24 50 41 54 48 20 64 6f 74 20 2d 54 20 22 20 =$PATH dot -T "
137b0 6f 75 74 74 79 70 65 20 22 20 3c 20 22 20 64 66 outtype " < " df
137c0 69 6c 65 20 22 20 3e 20 22 20 66 6e 61 6d 65 20 ile " > " fname
137d0 22 26 22 29 29 0a 09 09 20 20 20 20 20 20 72 65 "&"))... re
137e0 73 29 0a 09 09 20 20 20 20 28 62 65 67 69 6e 0a s)... (begin.
137f0 09 09 20 20 20 20 20 20 28 73 79 73 74 65 6d 20 .. (system
13800 28 63 6f 6e 63 20 22 65 6e 76 20 2d 69 20 50 41 (conc "env -i PA
13810 54 48 3d 24 50 41 54 48 20 64 6f 74 20 2d 54 20 TH=$PATH dot -T
13820 22 20 6f 75 74 74 79 70 65 20 22 20 3c 20 22 20 " outtype " < "
13830 64 66 69 6c 65 20 22 20 3e 20 22 20 66 6e 61 6d dfile " > " fnam
13840 65 29 29 0a 09 09 20 20 20 20 20 20 28 77 69 74 e))... (wit
13850 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 66 69 6c h-input-from-fil
13860 65 20 66 6e 61 6d 65 0a 09 09 09 28 6c 61 6d 62 e fname....(lamb
13870 64 61 20 28 29 0a 09 09 09 20 20 28 72 65 61 64 da ().... (read
13880 2d 6c 69 6e 65 73 29 29 29 29 29 29 29 0a 20 20 -lines))))))).
13890 20 20 20 20 28 69 66 20 28 65 71 3f 20 6d 6f 64 (if (eq? mod
138a0 65 20 27 72 61 77 29 0a 09 20 20 64 61 74 61 0a e 'raw).. data.
138b0 09 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 . (map (lambda
138c0 28 69 6e 6c 29 0a 09 09 20 28 6d 61 70 20 28 6c (inl)... (map (l
138d0 61 6d 62 64 61 20 28 73 29 0a 09 09 09 28 73 74 ambda (s)....(st
138e0 72 69 6e 67 2d 73 75 62 73 74 69 74 75 74 65 20 ring-substitute
138f0 22 5c 22 22 20 22 22 20 73 20 23 74 29 29 0a 09 "\"" "" s #t))..
13900 09 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 73 . (string-s
13910 70 6c 69 74 20 69 6e 6c 29 29 29 0a 09 20 20 20 plit inl)))..
13920 20 20 20 20 64 61 74 61 29 29 29 29 29 0a 0a 3b data)))))..;
13930 3b 20 66 6f 72 20 65 61 63 68 20 74 65 73 74 3a ; for each test:
13940 0a 3b 3b 20 20 20 0a 28 64 65 66 69 6e 65 20 28 .;; .(define (
13950 74 65 73 74 73 3a 66 69 6c 74 65 72 2d 6e 6f 6e tests:filter-non
13960 2d 72 75 6e 6e 61 62 6c 65 20 72 75 6e 2d 69 64 -runnable run-id
13970 20 74 65 73 74 6b 65 79 6e 61 6d 65 73 20 74 65 testkeynames te
13980 73 74 72 65 63 6f 72 64 73 68 61 73 68 29 0a 20 strecordshash).
13990 20 28 6c 65 74 20 28 28 72 75 6e 6e 61 62 6c 65 (let ((runnable
139a0 73 20 27 28 29 29 29 0a 20 20 20 20 28 66 6f 72 s '())). (for
139b0 2d 65 61 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 -each. (lamb
139c0 64 61 20 28 74 65 73 74 6b 65 79 6e 61 6d 65 29 da (testkeyname)
139d0 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 . (let* ((
139e0 74 65 73 74 2d 72 65 63 6f 72 64 20 28 68 61 73 test-record (has
139f0 68 2d 74 61 62 6c 65 2d 72 65 66 20 74 65 73 74 h-table-ref test
13a00 72 65 63 6f 72 64 73 68 61 73 68 20 74 65 73 74 recordshash test
13a10 6b 65 79 6e 61 6d 65 29 29 0a 09 20 20 20 20 20 keyname))..
13a20 20 28 74 65 73 74 2d 6e 61 6d 65 20 20 20 28 74 (test-name (t
13a30 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 ests:testqueue-g
13a40 65 74 2d 74 65 73 74 6e 61 6d 65 20 20 74 65 73 et-testname tes
13a50 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 20 20 20 t-record))..
13a60 20 20 28 69 74 65 6d 64 61 74 20 20 20 20 20 28 (itemdat (
13a70 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d tests:testqueue-
13a80 67 65 74 2d 69 74 65 6d 64 61 74 20 20 20 74 65 get-itemdat te
13a90 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 20 20 st-record))..
13aa0 20 20 20 28 69 74 65 6d 2d 70 61 74 68 20 20 20 (item-path
13ab0 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 (tests:testqueue
13ac0 2d 67 65 74 2d 69 74 65 6d 5f 70 61 74 68 20 74 -get-item_path t
13ad0 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 20 est-record))..
13ae0 20 20 20 20 28 77 61 69 74 6f 6e 73 20 20 20 20 (waitons
13af0 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 (tests:testqueu
13b00 65 2d 67 65 74 2d 77 61 69 74 6f 6e 73 20 20 20 e-get-waitons
13b10 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 test-record))..
13b20 20 20 20 20 20 28 6b 65 65 70 2d 74 65 73 74 20 (keep-test
13b30 20 20 23 74 29 0a 09 20 20 20 20 20 20 28 74 65 #t).. (te
13b40 73 74 2d 69 64 20 20 20 20 20 28 72 6d 74 3a 67 st-id (rmt:g
13b50 65 74 2d 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 et-test-id run-i
13b60 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d d test-name item
13b70 2d 70 61 74 68 29 29 0a 09 20 20 20 20 20 20 28 -path)).. (
13b80 74 64 61 74 20 20 20 20 20 20 20 20 28 72 6d 74 tdat (rmt
13b90 3a 67 65 74 2d 74 65 73 74 69 6e 66 6f 2d 73 74 :get-testinfo-st
13ba0 61 74 65 2d 73 74 61 74 75 73 20 72 75 6e 2d 69 ate-status run-i
13bb0 64 20 74 65 73 74 2d 69 64 29 29 29 20 3b 3b 20 d test-id))) ;;
13bc0 28 63 64 62 3a 67 65 74 2d 74 65 73 74 2d 69 6e (cdb:get-test-in
13bd0 66 6f 2d 62 79 2d 69 64 20 2a 72 75 6e 72 65 6d fo-by-id *runrem
13be0 6f 74 65 2a 20 74 65 73 74 2d 69 64 29 29 29 0a ote* test-id))).
13bf0 09 20 28 69 66 20 74 64 61 74 0a 09 20 20 20 20 . (if tdat..
13c00 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 20 (begin..
13c10 3b 3b 20 4c 6f 6f 6b 20 61 74 20 74 68 65 20 74 ;; Look at the t
13c20 65 73 74 20 73 74 61 74 65 20 61 6e 64 20 73 74 est state and st
13c30 61 74 75 73 0a 09 20 20 20 20 20 20 20 28 69 66 atus.. (if
13c40 20 28 6f 72 20 28 61 6e 64 20 28 6d 65 6d 62 65 (or (and (membe
13c50 72 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 r (db:test-get-s
13c60 74 61 74 75 73 20 74 64 61 74 29 20 0a 09 09 09 tatus tdat) ....
13c70 09 20 20 20 20 27 28 22 50 41 53 53 22 20 22 57 . '("PASS" "W
13c80 41 52 4e 22 20 22 57 41 49 56 45 44 22 20 22 43 ARN" "WAIVED" "C
13c90 48 45 43 4b 22 20 22 53 4b 49 50 22 29 29 0a 09 HECK" "SKIP"))..
13ca0 09 09 20 20 20 20 28 65 71 75 61 6c 3f 20 28 64 .. (equal? (d
13cb0 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 b:test-get-state
13cc0 20 74 64 61 74 29 20 22 43 4f 4d 50 4c 45 54 45 tdat) "COMPLETE
13cd0 44 22 29 29 0a 09 09 20 20 20 20 20 20 20 28 6d D"))... (m
13ce0 65 6d 62 65 72 20 28 64 62 3a 74 65 73 74 2d 67 ember (db:test-g
13cf0 65 74 2d 73 74 61 74 65 20 74 64 61 74 29 0a 09 et-state tdat)..
13d00 09 09 09 20 20 20 20 27 28 22 49 4e 43 4f 4d 50 ... '("INCOMP
13d10 4c 45 54 45 22 20 22 4b 49 4c 4c 45 44 22 29 29 LETE" "KILLED"))
13d20 29 0a 09 09 20 20 20 28 73 65 74 21 20 6b 65 65 )... (set! kee
13d30 70 2d 74 65 73 74 20 23 66 29 29 0a 0a 09 20 20 p-test #f))...
13d40 20 20 20 20 20 3b 3b 20 65 78 61 6d 69 6e 65 20 ;; examine
13d50 77 61 69 74 6f 6e 73 20 66 6f 72 20 61 6e 79 20 waitons for any
13d60 66 61 69 6c 73 2e 20 49 66 20 69 74 20 69 73 20 fails. If it is
13d70 46 41 49 4c 20 6f 72 20 49 4e 43 4f 4d 50 4c 45 FAIL or INCOMPLE
13d80 54 45 20 74 68 65 6e 20 65 6c 69 6d 69 6e 61 74 TE then eliminat
13d90 65 20 74 68 69 73 20 74 65 73 74 0a 09 20 20 20 e this test..
13da0 20 20 20 20 3b 3b 20 66 72 6f 6d 20 74 68 65 20 ;; from the
13db0 72 75 6e 6e 61 62 6c 65 20 6c 69 73 74 0a 09 20 runnable list..
13dc0 20 20 20 20 20 20 28 69 66 20 6b 65 65 70 2d 74 (if keep-t
13dd0 65 73 74 0a 09 09 20 20 20 28 66 6f 72 2d 65 61 est... (for-ea
13de0 63 68 20 28 6c 61 6d 62 64 61 20 28 77 61 69 74 ch (lambda (wait
13df0 6f 6e 29 0a 09 09 09 20 20 20 20 20 20 20 3b 3b on).... ;;
13e00 20 66 6f 72 20 6e 6f 77 20 77 65 20 61 72 65 20 for now we are
13e10 77 61 69 74 69 6e 67 20 6f 6e 6c 79 20 6f 6e 20 waiting only on
13e20 74 68 65 20 70 61 72 65 6e 74 20 74 65 73 74 0a the parent test.
13e30 09 09 09 20 20 20 20 20 20 20 28 6c 65 74 2a 20 ... (let*
13e40 28 28 70 61 72 65 6e 74 2d 74 65 73 74 2d 69 64 ((parent-test-id
13e50 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 (rmt:get-test-i
13e60 64 20 72 75 6e 2d 69 64 20 77 61 69 74 6f 6e 20 d run-id waiton
13e70 22 22 29 29 0a 09 09 09 09 20 20 20 20 20 20 28 ""))..... (
13e80 77 74 64 61 74 20 20 20 20 20 20 20 20 20 20 28 wtdat (
13e90 72 6d 74 3a 67 65 74 2d 74 65 73 74 69 6e 66 6f rmt:get-testinfo
13ea0 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 72 75 -state-status ru
13eb0 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 29 29 20 n-id test-id)))
13ec0 3b 3b 20 28 63 64 62 3a 67 65 74 2d 74 65 73 74 ;; (cdb:get-test
13ed0 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 2a 72 75 6e -info-by-id *run
13ee0 72 65 6d 6f 74 65 2a 20 74 65 73 74 2d 69 64 29 remote* test-id)
13ef0 29 29 0a 09 09 09 09 20 28 69 66 20 28 6f 72 20 ))..... (if (or
13f00 28 61 6e 64 20 28 65 71 75 61 6c 3f 20 28 64 62 (and (equal? (db
13f10 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 :test-get-state
13f20 77 74 64 61 74 29 20 22 43 4f 4d 50 4c 45 54 45 wtdat) "COMPLETE
13f30 44 22 29 0a 09 09 09 09 09 20 20 20 20 20 20 28 D")...... (
13f40 6d 65 6d 62 65 72 20 28 64 62 3a 74 65 73 74 2d member (db:test-
13f50 67 65 74 2d 73 74 61 74 75 73 20 77 74 64 61 74 get-status wtdat
13f60 29 20 27 28 22 46 41 49 4c 22 20 22 41 42 4f 52 ) '("FAIL" "ABOR
13f70 54 22 29 29 29 0a 09 09 09 09 09 20 28 6d 65 6d T")))...... (mem
13f80 62 65 72 20 28 64 62 3a 74 65 73 74 2d 67 65 74 ber (db:test-get
13f90 2d 73 74 61 74 75 73 20 77 74 64 61 74 29 20 20 -status wtdat)
13fa0 27 28 22 4b 49 4c 4c 45 44 22 29 29 0a 09 09 09 '("KILLED"))....
13fb0 09 09 20 28 6d 65 6d 62 65 72 20 28 64 62 3a 74 .. (member (db:t
13fc0 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 77 74 est-get-state wt
13fd0 64 61 74 29 20 20 20 27 28 22 49 4e 43 4f 4d 50 dat) '("INCOMP
13fe0 45 54 45 22 29 29 29 0a 09 09 09 09 20 3b 3b 20 ETE")))..... ;;
13ff0 28 69 66 20 28 6f 72 20 28 6d 65 6d 62 65 72 20 (if (or (member
14000 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 (db:test-get-sta
14010 74 75 73 20 77 74 64 61 74 29 0a 09 09 09 09 20 tus wtdat).....
14020 3b 3b 20 20 20 20 20 20 20 20 09 20 27 28 22 46 ;; . '("F
14030 41 49 4c 22 20 22 4b 49 4c 4c 45 44 22 29 29 0a AIL" "KILLED")).
14040 09 09 09 09 20 3b 3b 20 20 20 20 20 20 20 20 20 .... ;;
14050 28 6d 65 6d 62 65 72 20 28 64 62 3a 74 65 73 74 (member (db:test
14060 2d 67 65 74 2d 73 74 61 74 65 20 77 74 64 61 74 -get-state wtdat
14070 29 0a 09 09 09 09 20 3b 3b 20 20 20 20 20 20 20 )..... ;;
14080 20 09 20 27 28 22 49 4e 43 4f 4d 50 45 54 45 22 . '("INCOMPETE"
14090 29 29 29 0a 09 09 09 09 20 20 20 20 20 28 73 65 )))..... (se
140a0 74 21 20 6b 65 65 70 2d 74 65 73 74 20 23 66 29 t! keep-test #f)
140b0 29 29 29 20 3b 3b 20 6e 6f 20 70 6f 69 6e 74 20 ))) ;; no point
140c0 69 6e 20 72 75 6e 6e 69 6e 67 20 74 68 69 73 20 in running this
140d0 6f 6e 65 20 61 67 61 69 6e 0a 09 09 09 20 20 20 one again....
140e0 20 20 77 61 69 74 6f 6e 73 29 29 29 29 0a 09 20 waitons))))..
140f0 28 69 66 20 6b 65 65 70 2d 74 65 73 74 20 28 73 (if keep-test (s
14100 65 74 21 20 72 75 6e 6e 61 62 6c 65 73 20 28 63 et! runnables (c
14110 6f 6e 73 20 74 65 73 74 6b 65 79 6e 61 6d 65 20 ons testkeyname
14120 72 75 6e 6e 61 62 6c 65 73 29 29 29 29 29 0a 20 runnables))))).
14130 20 20 20 20 74 65 73 74 6b 65 79 6e 61 6d 65 73 testkeynames
14140 29 0a 20 20 20 20 72 75 6e 6e 61 62 6c 65 73 29 ). runnables)
14150 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )..;;===========
14160 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14170 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14180 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14190 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 72 ===========.;; r
141a0 65 66 61 63 74 6f 72 69 6e 67 20 74 68 69 73 20 efactoring this
141b0 62 6c 6f 63 6b 20 69 6e 74 6f 20 74 65 73 74 73 block into tests
141c0 3a 67 65 74 2d 66 75 6c 6c 2d 64 61 74 61 20 66 :get-full-data f
141d0 72 6f 6d 20 6c 69 6e 65 20 32 36 33 20 6f 66 20 rom line 263 of
141e0 72 75 6e 73 2e 73 63 6d 0a 3b 3b 3d 3d 3d 3d 3d runs.scm.;;=====
141f0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14200 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14210 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14220 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14230 3d 0a 3b 3b 20 68 65 64 20 69 73 20 74 68 65 20 =.;; hed is the
14240 74 65 73 74 20 6e 61 6d 65 0a 3b 3b 20 74 65 73 test name.;; tes
14250 74 2d 72 65 63 6f 72 64 73 20 69 73 20 61 20 68 t-records is a h
14260 61 73 68 20 6f 66 20 74 65 73 74 2d 6e 61 6d 65 ash of test-name
14270 20 3d 3e 20 74 65 73 74 20 72 65 63 6f 72 64 0a => test record.
14280 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 67 (define (tests:g
14290 65 74 2d 66 75 6c 6c 2d 64 61 74 61 20 74 65 73 et-full-data tes
142a0 74 2d 6e 61 6d 65 73 20 74 65 73 74 2d 72 65 63 t-names test-rec
142b0 6f 72 64 73 20 72 65 71 75 69 72 65 64 2d 74 65 ords required-te
142c0 73 74 73 20 61 6c 6c 2d 74 65 73 74 73 2d 72 65 sts all-tests-re
142d0 67 69 73 74 72 79 29 0a 20 20 28 69 66 20 28 6e gistry). (if (n
142e0 6f 74 20 28 6e 75 6c 6c 3f 20 74 65 73 74 2d 6e ot (null? test-n
142f0 61 6d 65 73 29 29 0a 20 20 20 20 20 20 28 6c 65 ames)). (le
14300 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 61 t loop ((hed (ca
14310 72 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 0a 09 r test-names))..
14320 09 20 28 74 61 6c 20 28 63 64 72 20 74 65 73 74 . (tal (cdr test
14330 2d 6e 61 6d 65 73 29 29 29 20 20 20 20 20 20 20 -names)))
14340 20 20 3b 3b 20 27 72 65 74 75 72 6e 2d 70 72 6f ;; 'return-pro
14350 63 73 20 74 65 6c 6c 73 20 74 68 65 20 63 6f 6e cs tells the con
14360 66 69 67 20 72 65 61 64 65 72 20 74 6f 20 70 72 fig reader to pr
14370 65 70 20 72 75 6e 6e 69 6e 67 20 73 79 73 74 65 ep running syste
14380 6d 20 62 75 74 20 72 65 74 75 72 6e 20 61 20 70 m but return a p
14390 72 6f 63 0a 09 28 64 65 62 75 67 3a 70 72 69 6e roc..(debug:prin
143a0 74 2d 69 6e 66 6f 20 34 20 2a 64 65 66 61 75 6c t-info 4 *defaul
143b0 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 68 65 64 t-log-port* "hed
143c0 3d 22 20 68 65 64 20 22 20 61 74 20 74 6f 70 20 =" hed " at top
143d0 6f 66 20 6c 6f 6f 70 22 29 0a 20 20 20 20 20 20 of loop").
143e0 20 20 3b 3b 20 64 6f 6e 27 74 20 6b 6e 6f 77 20 ;; don't know
143f0 69 74 65 6d 2d 70 61 74 68 20 61 74 20 74 68 69 item-path at thi
14400 73 20 74 69 6d 65 2c 20 6c 65 74 20 74 68 65 20 s time, let the
14410 74 65 73 74 63 6f 6e 66 69 67 20 67 65 74 20 74 testconfig get t
14420 68 65 20 74 6f 70 20 6c 65 76 65 6c 20 74 65 73 he top level tes
14430 74 63 6f 6e 66 69 67 0a 09 28 6c 65 74 2a 20 28 tconfig..(let* (
14440 28 63 6f 6e 66 69 67 20 20 28 74 65 73 74 73 3a (config (tests:
14450 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 68 get-testconfig h
14460 65 64 20 23 66 20 61 6c 6c 2d 74 65 73 74 73 2d ed #f all-tests-
14470 72 65 67 69 73 74 72 79 20 27 72 65 74 75 72 6e registry 'return
14480 2d 70 72 6f 63 73 29 29 0a 09 20 20 20 20 20 20 -procs))..
14490 20 28 77 61 69 74 6f 6e 73 20 28 6c 65 74 20 28 (waitons (let (
144a0 28 69 6e 73 74 72 20 28 69 66 20 63 6f 6e 66 69 (instr (if confi
144b0 67 20 0a 09 09 09 09 09 20 28 63 6f 6e 66 69 67 g ...... (config
144c0 66 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 20 f:lookup config
144d0 22 72 65 71 75 69 72 65 6d 65 6e 74 73 22 20 22 "requirements" "
144e0 77 61 69 74 6f 6e 22 29 0a 09 09 09 09 09 20 28 waiton")...... (
144f0 62 65 67 69 6e 20 3b 3b 20 4e 6f 20 63 6f 6e 66 begin ;; No conf
14500 69 67 20 6d 65 61 6e 73 20 74 68 69 73 20 69 73 ig means this is
14510 20 61 20 6e 6f 6e 2d 65 78 69 73 74 61 6e 74 20 a non-existant
14520 74 65 73 74 0a 09 09 09 09 09 20 20 20 28 64 65 test...... (de
14530 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 bug:print-error
14540 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
14550 6f 72 74 2a 20 22 6e 6f 6e 2d 65 78 69 73 74 65 ort* "non-existe
14560 6e 74 20 72 65 71 75 69 72 65 64 20 74 65 73 74 nt required test
14570 20 5c 22 22 20 68 65 64 20 22 5c 22 2c 20 67 72 \"" hed "\", gr
14580 65 70 20 74 68 72 6f 75 67 68 20 79 6f 75 72 20 ep through your
14590 74 65 73 74 63 6f 6e 66 69 67 73 20 74 6f 20 66 testconfigs to f
145a0 69 6e 64 20 61 6e 64 20 72 65 6d 6f 76 65 20 6f ind and remove o
145b0 72 20 63 72 65 61 74 65 20 74 68 65 20 74 65 73 r create the tes
145c0 74 2e 20 44 69 73 63 61 72 64 69 6e 67 20 61 6e t. Discarding an
145d0 64 20 63 6f 6e 74 69 6e 75 69 6e 67 2e 22 29 0a d continuing.").
145e0 09 09 09 09 09 20 20 20 20 20 22 22 29 29 29 29 ..... ""))))
145f0 0a 09 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 .... (debug:pri
14600 6e 74 2d 69 6e 66 6f 20 38 20 2a 64 65 66 61 75 nt-info 8 *defau
14610 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 77 61 lt-log-port* "wa
14620 69 74 6f 6e 73 20 73 74 72 69 6e 67 20 69 73 20 itons string is
14630 22 20 69 6e 73 74 72 29 0a 09 09 09 20 20 28 73 " instr).... (s
14640 74 72 69 6e 67 2d 73 70 6c 69 74 20 28 63 6f 6e tring-split (con
14650 64 0a 09 09 09 09 09 20 28 28 70 72 6f 63 65 64 d...... ((proced
14660 75 72 65 3f 20 69 6e 73 74 72 29 0a 09 09 09 09 ure? instr).....
14670 09 20 20 28 6c 65 74 20 28 28 72 65 73 20 28 69 . (let ((res (i
14680 6e 73 74 72 29 29 29 0a 09 09 09 09 09 20 20 20 nstr)))......
14690 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
146a0 66 6f 20 38 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 8 *default-lo
146b0 67 2d 70 6f 72 74 2a 20 22 77 61 69 74 6f 6e 20 g-port* "waiton
146c0 70 72 6f 63 65 64 75 72 65 20 72 65 73 75 6c 74 procedure result
146d0 73 20 69 6e 20 73 74 72 69 6e 67 20 22 20 72 65 s in string " re
146e0 73 20 22 20 66 6f 72 20 74 65 73 74 20 22 20 68 s " for test " h
146f0 65 64 29 0a 09 09 09 09 09 20 20 20 20 72 65 73 ed)...... res
14700 29 29 0a 09 09 09 09 09 20 28 28 73 74 72 69 6e ))...... ((strin
14710 67 3f 20 69 6e 73 74 72 29 20 20 20 20 20 69 6e g? instr) in
14720 73 74 72 29 0a 09 09 09 09 09 20 28 65 6c 73 65 str)...... (else
14730 20 0a 09 09 09 09 09 20 20 3b 3b 20 4e 4f 54 45 ...... ;; NOTE
14740 3a 20 54 68 69 73 20 69 73 20 61 63 74 75 61 6c : This is actual
14750 6c 79 20 74 68 65 20 63 61 73 65 20 6f 66 20 2a ly the case of *
14760 6e 6f 2a 20 77 61 69 74 6f 6e 73 21 20 3b 3b 20 no* waitons! ;;
14770 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 (debug:print-err
14780 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f or 0 *default-lo
14790 67 2d 70 6f 72 74 2a 20 22 73 6f 6d 65 74 68 69 g-port* "somethi
147a0 6e 67 20 77 65 6e 74 20 77 72 6f 6e 67 20 69 6e ng went wrong in
147b0 20 70 72 6f 63 65 73 73 69 6e 67 20 77 61 69 74 processing wait
147c0 6f 6e 73 20 66 6f 72 20 74 65 73 74 20 22 20 68 ons for test " h
147d0 65 64 29 0a 09 09 09 09 09 20 20 22 22 29 29 29 ed)...... "")))
147e0 29 29 29 0a 09 20 20 28 69 66 20 28 6e 6f 74 20 ))).. (if (not
147f0 63 6f 6e 66 69 67 29 20 3b 3b 20 74 68 69 73 20 config) ;; this
14800 69 73 20 61 20 6e 6f 6e 2d 65 78 69 73 74 61 6e is a non-existan
14810 74 20 74 65 73 74 20 63 61 6c 6c 65 64 20 69 6e t test called in
14820 20 61 20 77 61 69 74 6f 6e 2e 20 0a 09 20 20 20 a waiton. ..
14830 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 (if (null? ta
14840 6c 29 0a 09 09 20 20 74 65 73 74 2d 72 65 63 6f l)... test-reco
14850 72 64 73 0a 09 09 20 20 28 6c 6f 6f 70 20 28 63 rds... (loop (c
14860 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 ar tal)(cdr tal)
14870 29 29 0a 09 20 20 20 20 20 20 28 62 65 67 69 6e )).. (begin
14880 0a 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d ...(debug:print-
14890 69 6e 66 6f 20 38 20 2a 64 65 66 61 75 6c 74 2d info 8 *default-
148a0 6c 6f 67 2d 70 6f 72 74 2a 20 22 77 61 69 74 6f log-port* "waito
148b0 6e 73 3a 20 22 20 77 61 69 74 6f 6e 73 29 0a 09 ns: " waitons)..
148c0 09 3b 3b 20 63 68 65 63 6b 20 66 6f 72 20 68 65 .;; check for he
148d0 64 20 69 6e 20 77 61 69 74 6f 6e 73 20 3d 3e 20 d in waitons =>
148e0 74 68 69 73 20 77 6f 75 6c 64 20 62 65 20 63 69 this would be ci
148f0 72 63 75 6c 61 72 2c 20 72 65 6d 6f 76 65 20 69 rcular, remove i
14900 74 20 61 6e 64 20 69 73 73 75 65 20 61 6e 0a 09 t and issue an..
14910 09 3b 3b 20 65 72 72 6f 72 0a 09 09 28 69 66 20 .;; error...(if
14920 28 6d 65 6d 62 65 72 20 68 65 64 20 77 61 69 74 (member hed wait
14930 6f 6e 73 29 0a 09 09 20 20 20 20 28 62 65 67 69 ons)... (begi
14940 6e 0a 09 09 20 20 20 20 20 20 28 64 65 62 75 67 n... (debug
14950 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a :print-error 0 *
14960 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
14970 2a 20 22 74 65 73 74 20 22 20 68 65 64 20 22 20 * "test " hed "
14980 68 61 73 20 6c 69 73 74 65 64 20 69 74 73 65 6c has listed itsel
14990 66 20 61 73 20 61 20 77 61 69 74 6f 6e 2c 20 70 f as a waiton, p
149a0 6c 65 61 73 65 20 63 6f 72 72 65 63 74 20 74 68 lease correct th
149b0 69 73 21 22 29 0a 09 09 20 20 20 20 20 20 28 73 is!")... (s
149c0 65 74 21 20 77 61 69 74 6f 6e 73 20 28 66 69 6c et! waitons (fil
149d0 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 28 ter (lambda (x)(
149e0 6e 6f 74 20 28 65 71 75 61 6c 3f 20 78 20 68 65 not (equal? x he
149f0 64 29 29 29 20 77 61 69 74 6f 6e 73 29 29 29 29 d))) waitons))))
14a00 0a 09 09 0a 09 09 3b 3b 20 28 69 74 65 6d 73 20 ......;; (items
14a10 20 20 28 69 74 65 6d 73 3a 67 65 74 2d 69 74 65 (items:get-ite
14a20 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 20 63 ms-from-config c
14a30 6f 6e 66 69 67 29 29 29 0a 09 09 28 69 66 20 28 onfig)))...(if (
14a40 6e 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d not (hash-table-
14a50 72 65 66 2f 64 65 66 61 75 6c 74 20 74 65 73 74 ref/default test
14a60 2d 72 65 63 6f 72 64 73 20 68 65 64 20 23 66 29 -records hed #f)
14a70 29 0a 09 09 20 20 20 20 28 68 61 73 68 2d 74 61 )... (hash-ta
14a80 62 6c 65 2d 73 65 74 21 20 74 65 73 74 2d 72 65 ble-set! test-re
14a90 63 6f 72 64 73 0a 09 09 09 09 20 20 20 20 20 68 cords..... h
14aa0 65 64 20 28 76 65 63 74 6f 72 20 68 65 64 20 20 ed (vector hed
14ab0 20 20 20 3b 3b 20 30 0a 09 09 09 09 09 09 20 63 ;; 0....... c
14ac0 6f 6e 66 69 67 20 20 3b 3b 20 31 0a 09 09 09 09 onfig ;; 1.....
14ad0 09 09 20 77 61 69 74 6f 6e 73 20 3b 3b 20 32 0a .. waitons ;; 2.
14ae0 09 09 09 09 09 09 20 28 63 6f 6e 66 69 67 66 3a ...... (configf:
14af0 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 20 22 72 lookup config "r
14b00 65 71 75 69 72 65 6d 65 6e 74 73 22 20 22 70 72 equirements" "pr
14b10 69 6f 72 69 74 79 22 29 20 20 20 20 20 3b 3b 20 iority") ;;
14b20 70 72 69 6f 72 69 74 79 20 33 0a 09 09 09 09 09 priority 3......
14b30 09 20 28 6c 65 74 20 28 28 69 74 65 6d 73 20 20 . (let ((items
14b40 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
14b50 72 65 66 2f 64 65 66 61 75 6c 74 20 63 6f 6e 66 ref/default conf
14b60 69 67 20 22 69 74 65 6d 73 22 20 23 66 29 29 20 ig "items" #f))
14b70 3b 3b 20 69 74 65 6d 73 20 34 0a 09 09 09 09 09 ;; items 4......
14b80 09 20 20 20 20 20 20 20 28 69 74 65 6d 73 74 61 . (itemsta
14b90 62 6c 65 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ble (hash-table-
14ba0 72 65 66 2f 64 65 66 61 75 6c 74 20 63 6f 6e 66 ref/default conf
14bb0 69 67 20 22 69 74 65 6d 73 74 61 62 6c 65 22 20 ig "itemstable"
14bc0 23 66 29 29 29 20 0a 09 09 09 09 09 09 20 20 20 #f))) .......
14bd0 3b 3b 20 69 66 20 65 69 74 68 65 72 20 69 74 65 ;; if either ite
14be0 6d 73 20 6f 72 20 69 74 65 6d 73 20 74 61 62 6c ms or items tabl
14bf0 65 20 69 73 20 61 20 70 72 6f 63 20 72 65 74 75 e is a proc retu
14c00 72 6e 20 69 74 20 73 6f 20 74 65 73 74 20 72 75 rn it so test ru
14c10 6e 6e 69 6e 67 0a 09 09 09 09 09 09 20 20 20 3b nning....... ;
14c20 3b 20 70 72 6f 63 65 73 73 20 63 61 6e 20 6b 6e ; process can kn
14c30 6f 77 20 74 6f 20 63 61 6c 6c 20 69 74 65 6d 73 ow to call items
14c40 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d :get-items-from-
14c50 63 6f 6e 66 69 67 0a 09 09 09 09 09 09 20 20 20 config.......
14c60 3b 3b 20 69 66 20 65 69 74 68 65 72 20 69 73 20 ;; if either is
14c70 61 20 6c 69 73 74 20 61 6e 64 20 6e 6f 6e 65 20 a list and none
14c80 69 73 20 61 20 70 72 6f 63 20 67 6f 20 61 68 65 is a proc go ahe
14c90 61 64 20 61 6e 64 20 63 61 6c 6c 20 67 65 74 2d ad and call get-
14ca0 69 74 65 6d 73 0a 09 09 09 09 09 09 20 20 20 3b items....... ;
14cb0 3b 20 6f 74 68 65 72 77 69 73 65 20 72 65 74 75 ; otherwise retu
14cc0 72 6e 20 23 66 20 2d 20 74 68 69 73 20 69 73 20 rn #f - this is
14cd0 6e 6f 74 20 61 6e 20 69 74 65 72 61 74 65 64 20 not an iterated
14ce0 74 65 73 74 0a 09 09 09 09 09 09 20 20 20 28 63 test....... (c
14cf0 6f 6e 64 0a 09 09 09 09 09 09 20 20 20 20 28 28 ond....... ((
14d00 70 72 6f 63 65 64 75 72 65 3f 20 69 74 65 6d 73 procedure? items
14d10 29 20 20 20 20 20 20 0a 09 09 09 09 09 09 20 20 ) .......
14d20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
14d30 69 6e 66 6f 20 34 20 2a 64 65 66 61 75 6c 74 2d info 4 *default-
14d40 6c 6f 67 2d 70 6f 72 74 2a 20 22 69 74 65 6d 73 log-port* "items
14d50 20 69 73 20 61 20 70 72 6f 63 65 64 75 72 65 2c is a procedure,
14d60 20 77 69 6c 6c 20 63 61 6c 63 20 6c 61 74 65 72 will calc later
14d70 22 29 0a 09 09 09 09 09 09 20 20 20 20 20 69 74 ")....... it
14d80 65 6d 73 29 20 20 20 20 20 20 20 20 20 20 20 20 ems)
14d90 3b 3b 20 63 61 6c 63 20 6c 61 74 65 72 0a 09 09 ;; calc later...
14da0 09 09 09 09 20 20 20 20 28 28 70 72 6f 63 65 64 .... ((proced
14db0 75 72 65 3f 20 69 74 65 6d 73 74 61 62 6c 65 29 ure? itemstable)
14dc0 0a 09 09 09 09 09 09 20 20 20 20 20 28 64 65 62 ....... (deb
14dd0 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 ug:print-info 4
14de0 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
14df0 74 2a 20 22 69 74 65 6d 73 74 61 62 6c 65 20 69 t* "itemstable i
14e00 73 20 61 20 70 72 6f 63 65 64 75 72 65 2c 20 77 s a procedure, w
14e10 69 6c 6c 20 63 61 6c 63 20 6c 61 74 65 72 22 29 ill calc later")
14e20 0a 09 09 09 09 09 09 20 20 20 20 20 69 74 65 6d ....... item
14e30 73 74 61 62 6c 65 29 20 20 20 20 20 20 20 3b 3b stable) ;;
14e40 20 63 61 6c 63 20 6c 61 74 65 72 0a 09 09 09 09 calc later.....
14e50 09 09 20 20 20 20 28 28 66 69 6c 74 65 72 20 28 .. ((filter (
14e60 6c 61 6d 62 64 61 20 28 78 29 0a 09 09 09 09 09 lambda (x)......
14e70 09 09 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 .. (let ((
14e80 76 61 6c 20 28 63 61 72 20 78 29 29 29 0a 09 09 val (car x)))...
14e90 09 09 09 09 09 09 20 28 69 66 20 28 70 72 6f 63 ...... (if (proc
14ea0 65 64 75 72 65 3f 20 76 61 6c 29 20 76 61 6c 20 edure? val) val
14eb0 23 66 29 29 29 0a 09 09 09 09 09 09 09 20 20 20 #f)))........
14ec0 20 20 28 61 70 70 65 6e 64 20 28 69 66 20 28 6c (append (if (l
14ed0 69 73 74 3f 20 69 74 65 6d 73 29 20 69 74 65 6d ist? items) item
14ee0 73 20 27 28 29 29 0a 09 09 09 09 09 09 09 09 20 s '()).........
14ef0 20 20 20 20 28 69 66 20 28 6c 69 73 74 3f 20 69 (if (list? i
14f00 74 65 6d 73 74 61 62 6c 65 29 20 69 74 65 6d 73 temstable) items
14f10 74 61 62 6c 65 20 27 28 29 29 29 29 0a 09 09 09 table '())))....
14f20 09 09 09 20 20 20 20 20 27 68 61 76 65 2d 70 72 ... 'have-pr
14f30 6f 63 65 64 75 72 65 29 0a 09 09 09 09 09 09 20 ocedure).......
14f40 20 20 20 28 28 6f 72 20 28 6c 69 73 74 3f 20 69 ((or (list? i
14f50 74 65 6d 73 29 28 6c 69 73 74 3f 20 69 74 65 6d tems)(list? item
14f60 73 74 61 62 6c 65 29 29 20 3b 3b 20 63 61 6c 63 stable)) ;; calc
14f70 20 6e 6f 77 0a 09 09 09 09 09 09 20 20 20 20 20 now.......
14f80 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
14f90 6f 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 4 *default-log
14fa0 2d 70 6f 72 74 2a 20 22 69 74 65 6d 73 20 61 6e -port* "items an
14fb0 64 20 69 74 65 6d 73 74 61 62 6c 65 20 61 72 65 d itemstable are
14fc0 20 6c 69 73 74 73 2c 20 63 61 6c 63 20 6e 6f 77 lists, calc now
14fd0 5c 6e 22 0a 09 09 09 09 09 09 09 09 20 20 20 20 \n".........
14fe0 20 20 20 22 20 20 20 20 69 74 65 6d 73 3a 20 22 " items: "
14ff0 20 69 74 65 6d 73 20 22 20 69 74 65 6d 73 74 61 items " itemsta
15000 62 6c 65 3a 20 22 20 69 74 65 6d 73 74 61 62 6c ble: " itemstabl
15010 65 29 0a 09 09 09 09 09 09 20 20 20 20 20 28 69 e)....... (i
15020 74 65 6d 73 3a 67 65 74 2d 69 74 65 6d 73 2d 66 tems:get-items-f
15030 72 6f 6d 2d 63 6f 6e 66 69 67 20 63 6f 6e 66 69 rom-config confi
15040 67 29 29 0a 09 09 09 09 09 09 20 20 20 20 28 65 g))....... (e
15050 6c 73 65 20 23 66 29 29 29 20 20 20 20 20 20 20 lse #f)))
15060 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
15070 20 20 20 20 3b 3b 20 6e 6f 74 20 69 74 65 72 61 ;; not itera
15080 74 65 64 0a 09 09 09 09 09 09 20 23 66 20 20 20 ted....... #f
15090 20 20 20 3b 3b 20 69 74 65 6d 73 64 61 74 20 35 ;; itemsdat 5
150a0 0a 09 09 09 09 09 09 20 23 66 20 20 20 20 20 20 ....... #f
150b0 3b 3b 20 73 70 61 72 65 20 2d 20 75 73 65 64 20 ;; spare - used
150c0 66 6f 72 20 69 74 65 6d 2d 70 61 74 68 0a 09 09 for item-path...
150d0 09 09 09 09 20 29 29 29 0a 09 09 28 66 6f 72 2d .... )))...(for-
150e0 65 61 63 68 20 0a 09 09 20 28 6c 61 6d 62 64 61 each ... (lambda
150f0 20 28 77 61 69 74 6f 6e 29 0a 09 09 20 20 20 28 (waiton)... (
15100 69 66 20 28 61 6e 64 20 77 61 69 74 6f 6e 20 28 if (and waiton (
15110 6e 6f 74 20 28 6d 65 6d 62 65 72 20 77 61 69 74 not (member wait
15120 6f 6e 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 29 on test-names)))
15130 0a 09 09 20 20 20 20 20 20 20 28 62 65 67 69 6e ... (begin
15140 0a 09 09 09 20 28 73 65 74 21 20 72 65 71 75 69 .... (set! requi
15150 72 65 64 2d 74 65 73 74 73 20 28 63 6f 6e 73 20 red-tests (cons
15160 77 61 69 74 6f 6e 20 72 65 71 75 69 72 65 64 2d waiton required-
15170 74 65 73 74 73 29 29 0a 09 09 09 20 28 73 65 74 tests)).... (set
15180 21 20 74 65 73 74 2d 6e 61 6d 65 73 20 28 63 6f ! test-names (co
15190 6e 73 20 77 61 69 74 6f 6e 20 74 65 73 74 2d 6e ns waiton test-n
151a0 61 6d 65 73 29 29 29 29 29 20 3b 3b 20 77 61 73 ames))))) ;; was
151b0 20 61 6e 20 61 70 70 65 6e 64 2c 20 6e 6f 77 20 an append, now
151c0 61 20 63 6f 6e 73 0a 09 09 20 77 61 69 74 6f 6e a cons... waiton
151d0 73 29 0a 09 09 28 6c 65 74 20 28 28 72 65 6d 74 s)...(let ((remt
151e0 65 73 74 73 20 28 64 65 6c 65 74 65 2d 64 75 70 ests (delete-dup
151f0 6c 69 63 61 74 65 73 20 28 61 70 70 65 6e 64 20 licates (append
15200 77 61 69 74 6f 6e 73 20 74 61 6c 29 29 29 29 0a waitons tal)))).
15210 09 09 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 .. (if (not (nu
15220 6c 6c 3f 20 72 65 6d 74 65 73 74 73 29 29 0a 09 ll? remtests))..
15230 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 . (loop (ca
15240 72 20 72 65 6d 74 65 73 74 73 29 28 63 64 72 20 r remtests)(cdr
15250 72 65 6d 74 65 73 74 73 29 29 0a 09 09 20 20 20 remtests))...
15260 20 20 20 74 65 73 74 2d 72 65 63 6f 72 64 73 29 test-records)
15270 29 29 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d )))))))..;;=====
15280 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15290 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
152a0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
152b0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
152c0 3d 0a 3b 3b 20 74 65 73 74 20 73 74 65 70 73 0a =.;; test steps.
152d0 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
152e0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
152f0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15300 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15310 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 74 65 73 ========..;; tes
15320 74 73 74 65 70 2d 73 65 74 2d 73 74 61 74 75 73 tstep-set-status
15330 21 20 75 73 65 64 20 74 6f 20 62 65 20 68 65 72 ! used to be her
15340 65 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 e..(define (test
15350 2d 67 65 74 2d 6b 69 6c 6c 2d 72 65 71 75 65 73 -get-kill-reques
15360 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 t run-id test-id
15370 29 20 3b 3b 20 72 75 6e 2d 69 64 20 74 65 73 74 ) ;; run-id test
15380 2d 6e 61 6d 65 20 69 74 65 6d 64 61 74 29 0a 20 -name itemdat).
15390 20 28 6c 65 74 2a 20 28 28 74 65 73 74 64 61 74 (let* ((testdat
153a0 20 20 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 (rmt:get-test
153b0 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 72 75 6e 2d -info-by-id run-
153c0 69 64 20 74 65 73 74 2d 69 64 29 29 29 0a 20 20 id test-id))).
153d0 20 20 28 61 6e 64 20 74 65 73 74 64 61 74 0a 09 (and testdat..
153e0 20 28 65 71 75 61 6c 3f 20 28 74 65 73 74 3a 67 (equal? (test:g
153f0 65 74 2d 73 74 61 74 65 20 74 65 73 74 64 61 74 et-state testdat
15400 29 20 22 4b 49 4c 4c 52 45 51 22 29 29 29 29 0a ) "KILLREQ")))).
15410 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 3a 74 .(define (test:t
15420 64 62 2d 67 65 74 2d 72 75 6e 64 61 74 2d 63 6f db-get-rundat-co
15430 75 6e 74 20 74 64 62 29 0a 20 20 28 69 66 20 74 unt tdb). (if t
15440 64 62 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 db. (let ((
15450 72 65 73 20 30 29 29 0a 09 28 73 71 6c 69 74 65 res 0))..(sqlite
15460 33 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 0a 09 3:for-each-row..
15470 20 28 6c 61 6d 62 64 61 20 28 63 6f 75 6e 74 29 (lambda (count)
15480 0a 09 20 20 20 28 73 65 74 21 20 72 65 73 20 63 .. (set! res c
15490 6f 75 6e 74 29 29 0a 09 20 74 64 62 0a 09 20 22 ount)).. tdb.. "
154a0 53 45 4c 45 43 54 20 63 6f 75 6e 74 28 69 64 29 SELECT count(id)
154b0 20 46 52 4f 4d 20 74 65 73 74 5f 72 75 6e 64 61 FROM test_runda
154c0 74 3b 22 29 0a 09 72 65 73 29 29 0a 20 20 30 29 t;")..res)). 0)
154d0 0a 0a 3b 3b 20 0a 28 64 65 66 69 6e 65 20 28 74 ..;; .(define (t
154e0 65 73 74 73 3a 75 70 64 61 74 65 2d 63 65 6e 74 ests:update-cent
154f0 72 61 6c 2d 6d 65 74 61 2d 69 6e 66 6f 20 72 75 ral-meta-info ru
15500 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 63 70 75 n-id test-id cpu
15510 6c 6f 61 64 20 64 69 73 6b 66 72 65 65 20 6d 69 load diskfree mi
15520 6e 75 74 65 73 20 75 6e 61 6d 65 20 68 6f 73 74 nutes uname host
15530 6e 61 6d 65 20 23 21 6b 65 79 20 28 75 70 64 61 name #!key (upda
15540 74 65 2d 64 62 20 23 66 29 28 74 6d 70 66 72 65 te-db #f)(tmpfre
15550 65 20 23 66 29 29 0a 20 20 28 69 66 20 28 67 65 e #f)). (if (ge
15560 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 t-environment-va
15570 72 69 61 62 6c 65 20 22 4d 54 5f 54 45 53 54 5f riable "MT_TEST_
15580 52 55 4e 5f 44 49 52 22 29 0a 20 20 20 20 20 20 RUN_DIR").
15590 28 6c 65 74 2a 20 28 28 64 65 73 74 2d 64 69 72 (let* ((dest-dir
155a0 20 28 63 6f 6e 63 20 28 67 65 74 2d 65 6e 76 69 (conc (get-envi
155b0 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 ronment-variable
155c0 20 22 4d 54 5f 54 45 53 54 5f 52 55 4e 5f 44 49 "MT_TEST_RUN_DI
155d0 52 22 29 20 22 2f 2e 6d 74 5f 64 61 74 61 22 29 R") "/.mt_data")
155e0 29 0a 09 20 20 20 20 20 28 6f 72 2d 64 61 73 68 ).. (or-dash
155f0 20 20 28 6c 61 6d 62 64 61 20 28 69 6e 73 74 72 (lambda (instr
15600 29 0a 09 09 09 20 28 63 6f 6e 64 0a 09 09 09 20 ).... (cond....
15610 20 28 28 6e 6f 74 20 69 6e 73 74 72 29 20 22 22 ((not instr) ""
15620 29 20 3b 3b 20 23 66 20 2d 3e 20 62 6c 61 6e 6b ) ;; #f -> blank
15630 2c 20 69 6e 64 69 63 61 74 65 73 20 76 61 6c 75 , indicates valu
15640 65 20 75 6e 63 68 61 6e 67 65 64 20 73 69 6e 63 e unchanged sinc
15650 65 20 6c 61 73 74 20 6d 65 61 73 75 72 65 6d 65 e last measureme
15660 6e 74 20 74 61 6b 65 6e 0a 09 09 09 20 20 28 28 nt taken.... ((
15670 73 74 72 69 6e 67 3f 20 69 6e 73 74 72 29 28 69 string? instr)(i
15680 66 20 28 73 74 72 69 6e 67 2d 73 65 61 72 63 68 f (string-search
15690 20 22 20 22 20 69 6e 73 74 72 29 20 28 63 6f 6e " " instr) (con
156a0 63 20 22 5c 22 22 20 69 6e 73 74 72 20 22 5c 22 c "\"" instr "\"
156b0 22 29 20 69 6e 73 74 72 29 29 0a 09 09 09 20 20 ") instr))....
156c0 28 65 6c 73 65 20 69 6e 73 74 72 29 29 29 29 0a (else instr)))).
156d0 09 20 20 20 20 20 28 66 69 6c 65 2d 6e 65 77 20 . (file-new
156e0 28 6e 6f 74 20 28 64 69 72 65 63 74 6f 72 79 2d (not (directory-
156f0 65 78 69 73 74 73 3f 20 64 65 73 74 2d 64 69 72 exists? dest-dir
15700 29 29 29 29 0a 09 28 69 66 20 66 69 6c 65 2d 6e ))))..(if file-n
15710 65 77 20 28 63 72 65 61 74 65 2d 64 69 72 65 63 ew (create-direc
15720 74 6f 72 79 20 64 65 73 74 2d 64 69 72 20 23 74 tory dest-dir #t
15730 29 29 0a 09 28 6c 65 74 2a 20 28 28 6f 75 74 70 ))..(let* ((outp
15740 20 28 6f 70 65 6e 2d 6f 75 74 70 75 74 2d 66 69 (open-output-fi
15750 6c 65 20 28 63 6f 6e 63 20 64 65 73 74 2d 64 69 le (conc dest-di
15760 72 20 22 2f 74 65 73 74 2d 72 75 6e 2e 64 61 74 r "/test-run.dat
15770 22 29 20 23 3a 61 70 70 65 6e 64 29 29 29 0a 09 ") #:append)))..
15780 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 (with-output-t
15790 6f 2d 70 6f 72 74 20 6f 75 74 70 0a 09 20 20 20 o-port outp..
157a0 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 20 20 20 (lambda ()..
157b0 20 20 20 28 69 66 20 66 69 6c 65 2d 6e 65 77 0a (if file-new.
157c0 09 09 20 20 28 70 72 69 6e 74 20 22 65 70 6f 63 .. (print "epoc
157d0 68 5f 74 69 6d 65 2c 72 75 6e 5f 69 64 2c 74 65 h_time,run_id,te
157e0 73 74 5f 69 64 2c 63 70 75 6c 6f 61 64 2c 64 69 st_id,cpuload,di
157f0 73 6b 66 72 65 65 2c 74 6d 70 66 72 65 65 2c 72 skfree,tmpfree,r
15800 75 6e 5f 6d 69 6e 75 74 65 73 2c 68 6f 73 74 6e un_minutes,hostn
15810 61 6d 65 2c 75 6e 61 6d 65 22 29 29 0a 09 20 20 ame,uname"))..
15820 20 20 20 20 28 70 72 69 6e 74 20 28 63 75 72 72 (print (curr
15830 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 22 2c 22 ent-seconds) ","
15840 20 28 6f 72 2d 64 61 73 68 20 72 75 6e 2d 69 64 (or-dash run-id
15850 29 20 20 20 22 2c 22 20 28 6f 72 2d 64 61 73 68 ) "," (or-dash
15860 20 74 65 73 74 2d 69 64 29 20 20 22 2c 22 0a 09 test-id) ","..
15870 09 20 20 20 20 20 28 6f 72 2d 64 61 73 68 20 63 . (or-dash c
15880 70 75 6c 6f 61 64 29 20 22 2c 22 20 28 6f 72 2d puload) "," (or-
15890 64 61 73 68 20 64 69 73 6b 66 72 65 65 29 20 22 dash diskfree) "
158a0 2c 22 20 28 6f 72 2d 64 61 73 68 20 74 6d 70 66 ," (or-dash tmpf
158b0 72 65 65 29 20 20 22 2c 22 0a 09 09 20 20 20 20 ree) ","...
158c0 20 28 6f 72 2d 64 61 73 68 20 6d 69 6e 75 74 65 (or-dash minute
158d0 73 29 20 22 2c 22 20 28 6f 72 2d 64 61 73 68 20 s) "," (or-dash
158e0 68 6f 73 74 6e 61 6d 65 29 20 22 2c 22 0a 09 09 hostname) ","...
158f0 20 20 20 20 20 28 6f 72 2d 64 61 73 68 20 75 6e (or-dash un
15900 61 6d 65 29 29 29 29 20 3b 3b 20 70 75 74 20 75 ame)))) ;; put u
15910 6e 61 6d 65 20 6c 61 73 74 20 61 73 20 69 74 20 name last as it
15920 68 61 73 20 73 70 61 63 65 73 20 69 6e 20 69 74 has spaces in it
15930 0a 09 20 20 28 63 6c 6f 73 65 2d 6f 75 74 70 75 .. (close-outpu
15940 74 2d 70 6f 72 74 20 6f 75 74 70 29 29 29 0a 20 t-port outp))).
15950 20 20 20 20 20 28 62 65 67 69 6e 0a 09 28 72 6d (begin..(rm
15960 74 3a 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 t:general-call '
15970 75 70 64 61 74 65 2d 74 65 73 74 2d 72 75 6e 64 update-test-rund
15980 61 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 at run-id test-i
15990 64 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e d (current-secon
159a0 64 73 29 20 28 6f 72 20 63 70 75 6c 6f 61 64 20 ds) (or cpuload
159b0 2d 31 29 28 6f 72 20 64 69 73 6b 66 72 65 65 20 -1)(or diskfree
159c0 2d 31 29 20 2d 31 20 28 6f 72 20 6d 69 6e 75 74 -1) -1 (or minut
159d0 65 73 20 2d 31 29 29 29 29 0a 20 20 28 69 66 20 es -1)))). (if
159e0 75 70 64 61 74 65 2d 64 62 0a 20 20 20 20 20 20 update-db.
159f0 28 62 65 67 69 6e 0a 09 28 69 66 20 28 61 6e 64 (begin..(if (and
15a00 20 63 70 75 6c 6f 61 64 20 64 69 73 6b 66 72 65 cpuload diskfre
15a10 65 29 0a 09 20 20 20 20 28 72 6d 74 3a 67 65 6e e).. (rmt:gen
15a20 65 72 61 6c 2d 63 61 6c 6c 20 27 75 70 64 61 74 eral-call 'updat
15a30 65 2d 63 70 75 6c 6f 61 64 2d 64 69 73 6b 66 72 e-cpuload-diskfr
15a40 65 65 20 72 75 6e 2d 69 64 20 63 70 75 6c 6f 61 ee run-id cpuloa
15a50 64 20 64 69 73 6b 66 72 65 65 20 74 65 73 74 2d d diskfree test-
15a60 69 64 29 29 0a 09 28 69 66 20 6d 69 6e 75 74 65 id))..(if minute
15a70 73 20 0a 09 20 20 20 20 28 72 6d 74 3a 67 65 6e s .. (rmt:gen
15a80 65 72 61 6c 2d 63 61 6c 6c 20 27 75 70 64 61 74 eral-call 'updat
15a90 65 2d 72 75 6e 2d 64 75 72 61 74 69 6f 6e 20 72 e-run-duration r
15aa0 75 6e 2d 69 64 20 6d 69 6e 75 74 65 73 20 74 65 un-id minutes te
15ab0 73 74 2d 69 64 29 29 0a 09 28 69 66 20 28 61 6e st-id))..(if (an
15ac0 64 20 75 6e 61 6d 65 20 68 6f 73 74 6e 61 6d 65 d uname hostname
15ad0 29 0a 09 20 20 20 20 28 72 6d 74 3a 67 65 6e 65 ).. (rmt:gene
15ae0 72 61 6c 2d 63 61 6c 6c 20 27 75 70 64 61 74 65 ral-call 'update
15af0 2d 75 6e 61 6d 65 2d 68 6f 73 74 20 72 75 6e 2d -uname-host run-
15b00 69 64 20 75 6e 61 6d 65 20 68 6f 73 74 6e 61 6d id uname hostnam
15b10 65 20 74 65 73 74 2d 69 64 29 29 29 29 29 0a 20 e test-id))))).
15b20 20 0a 3b 3b 20 54 68 69 73 20 6f 6e 65 20 69 73 .;; This one is
15b30 20 66 6f 72 20 72 75 6e 6e 69 6e 67 20 77 69 74 for running wit
15b40 68 20 6e 6f 20 64 62 20 61 63 63 65 73 73 20 28 h no db access (
15b50 69 2e 65 2e 20 76 69 61 20 72 6d 74 3a 20 69 6e i.e. via rmt: in
15b60 74 65 72 6e 61 6c 6c 79 29 0a 28 64 65 66 69 6e ternally).(defin
15b70 65 20 28 74 65 73 74 73 3a 73 65 74 2d 66 75 6c e (tests:set-ful
15b80 6c 2d 6d 65 74 61 2d 69 6e 66 6f 20 64 62 20 74 l-meta-info db t
15b90 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 6d 69 est-id run-id mi
15ba0 6e 75 74 65 73 20 77 6f 72 6b 2d 61 72 65 61 20 nutes work-area
15bb0 72 65 6d 74 72 69 65 73 20 23 21 6b 65 79 20 28 remtries #!key (
15bc0 75 70 64 61 74 65 2d 64 62 20 23 66 29 29 0a 3b update-db #f)).;
15bd0 3b 20 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 ; (define (tests
15be0 3a 73 65 74 2d 66 75 6c 6c 2d 6d 65 74 61 2d 69 :set-full-meta-i
15bf0 6e 66 6f 20 74 65 73 74 2d 69 64 20 72 75 6e 2d nfo test-id run-
15c00 69 64 20 6d 69 6e 75 74 65 73 20 77 6f 72 6b 2d id minutes work-
15c10 61 72 65 61 29 0a 3b 3b 20 20 28 6c 65 74 20 28 area).;; (let (
15c20 28 72 65 6d 74 72 69 65 73 20 31 30 29 29 0a 20 (remtries 10)).
15c30 20 28 6c 65 74 2a 20 28 28 63 70 75 6c 6f 61 64 (let* ((cpuload
15c40 20 20 28 67 65 74 2d 63 70 75 2d 6c 6f 61 64 29 (get-cpu-load)
15c50 29 0a 09 20 28 64 69 73 6b 66 72 65 65 20 28 67 ).. (diskfree (g
15c60 65 74 2d 64 66 20 28 63 75 72 72 65 6e 74 2d 64 et-df (current-d
15c70 69 72 65 63 74 6f 72 79 29 29 29 0a 09 20 28 74 irectory))).. (t
15c80 6d 70 66 72 65 65 20 20 28 67 65 74 2d 64 66 20 mpfree (get-df
15c90 22 2f 74 6d 70 22 29 29 0a 09 20 28 75 6e 61 6d "/tmp")).. (unam
15ca0 65 20 20 20 20 28 67 65 74 2d 75 6e 61 6d 65 20 e (get-uname
15cb0 22 2d 73 72 76 70 69 6f 22 29 29 0a 09 20 28 68 "-srvpio")).. (h
15cc0 6f 73 74 6e 61 6d 65 20 28 67 65 74 2d 68 6f 73 ostname (get-hos
15cd0 74 2d 6e 61 6d 65 29 29 29 0a 20 20 20 20 28 74 t-name))). (t
15ce0 65 73 74 73 3a 75 70 64 61 74 65 2d 63 65 6e 74 ests:update-cent
15cf0 72 61 6c 2d 6d 65 74 61 2d 69 6e 66 6f 20 72 75 ral-meta-info ru
15d00 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 63 70 75 n-id test-id cpu
15d10 6c 6f 61 64 20 64 69 73 6b 66 72 65 65 20 6d 69 load diskfree mi
15d20 6e 75 74 65 73 20 75 6e 61 6d 65 20 68 6f 73 74 nutes uname host
15d30 6e 61 6d 65 20 75 70 64 61 74 65 2d 64 62 3a 20 name update-db:
15d40 75 70 64 61 74 65 2d 64 62 20 74 6d 70 66 72 65 update-db tmpfre
15d50 65 3a 20 74 6d 70 66 72 65 65 29 29 29 0a 20 20 e: tmpfree))).
15d60 20 20 0a 09 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d .. .;;========
15d70 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15d80 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15d90 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15da0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
15db0 3b 20 41 20 52 20 43 20 48 20 49 20 56 20 49 20 ; A R C H I V I
15dc0 4e 20 47 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d N G.;;==========
15dd0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15de0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15df0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15e00 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 ============..(d
15e10 65 66 69 6e 65 20 28 74 65 73 74 3a 61 72 63 68 efine (test:arch
15e20 69 76 65 20 64 62 20 74 65 73 74 2d 69 64 29 0a ive db test-id).
15e30 20 20 23 66 29 0a 0a 28 64 65 66 69 6e 65 20 28 #f)..(define (
15e40 74 65 73 74 3a 61 72 63 68 69 76 65 2d 74 65 73 test:archive-tes
15e50 74 73 20 64 62 20 6b 65 79 6e 61 6d 65 73 20 74 ts db keynames t
15e60 61 72 67 65 74 29 0a 20 20 23 66 29 0a 0a arget). #f)..