0000: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
0010: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0020: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0030: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0040: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 43 6f 70 79 ========.;; Copy
0050: 72 69 67 68 74 20 32 30 30 36 2d 32 30 31 33 2c right 2006-2013,
0060: 20 4d 61 74 74 68 65 77 20 57 65 6c 6c 61 6e 64 Matthew Welland
0070: 2e 0a 3b 3b 20 0a 3b 3b 20 54 68 69 73 20 66 69 ..;; .;; This fi
0080: 6c 65 20 69 73 20 70 61 72 74 20 6f 66 20 4d 65 le is part of Me
0090: 67 61 74 65 73 74 2e 0a 3b 3b 20 0a 3b 3b 20 20 gatest..;; .;;
00a0: 20 20 20 4d 65 67 61 74 65 73 74 20 69 73 20 66 Megatest is f
00b0: 72 65 65 20 73 6f 66 74 77 61 72 65 3a 20 79 6f ree software: yo
00c0: 75 20 63 61 6e 20 72 65 64 69 73 74 72 69 62 75 u can redistribu
00d0: 74 65 20 69 74 20 61 6e 64 2f 6f 72 20 6d 6f 64 te it and/or mod
00e0: 69 66 79 0a 3b 3b 20 20 20 20 20 69 74 20 75 6e ify.;; it un
00f0: 64 65 72 20 74 68 65 20 74 65 72 6d 73 20 6f 66 der the terms of
0100: 20 74 68 65 20 47 4e 55 20 47 65 6e 65 72 61 6c the GNU General
0110: 20 50 75 62 6c 69 63 20 4c 69 63 65 6e 73 65 20 Public License
0120: 61 73 20 70 75 62 6c 69 73 68 65 64 20 62 79 0a as published by.
0130: 3b 3b 20 20 20 20 20 74 68 65 20 46 72 65 65 20 ;; the Free
0140: 53 6f 66 74 77 61 72 65 20 46 6f 75 6e 64 61 74 Software Foundat
0150: 69 6f 6e 2c 20 65 69 74 68 65 72 20 76 65 72 73 ion, either vers
0160: 69 6f 6e 20 33 20 6f 66 20 74 68 65 20 4c 69 63 ion 3 of the Lic
0170: 65 6e 73 65 2c 20 6f 72 0a 3b 3b 20 20 20 20 20 ense, or.;;
0180: 28 61 74 20 79 6f 75 72 20 6f 70 74 69 6f 6e 29 (at your option)
0190: 20 61 6e 79 20 6c 61 74 65 72 20 76 65 72 73 69 any later versi
01a0: 6f 6e 2e 0a 3b 3b 20 0a 3b 3b 20 20 20 20 20 4d on..;; .;; M
01b0: 65 67 61 74 65 73 74 20 69 73 20 64 69 73 74 72 egatest is distr
01c0: 69 62 75 74 65 64 20 69 6e 20 74 68 65 20 68 6f ibuted in the ho
01d0: 70 65 20 74 68 61 74 20 69 74 20 77 69 6c 6c 20 pe that it will
01e0: 62 65 20 75 73 65 66 75 6c 2c 0a 3b 3b 20 20 20 be useful,.;;
01f0: 20 20 62 75 74 20 57 49 54 48 4f 55 54 20 41 4e but WITHOUT AN
0200: 59 20 57 41 52 52 41 4e 54 59 3b 20 77 69 74 68 Y WARRANTY; with
0210: 6f 75 74 20 65 76 65 6e 20 74 68 65 20 69 6d 70 out even the imp
0220: 6c 69 65 64 20 77 61 72 72 61 6e 74 79 20 6f 66 lied warranty of
0230: 0a 3b 3b 20 20 20 20 20 4d 45 52 43 48 41 4e 54 .;; MERCHANT
0240: 41 42 49 4c 49 54 59 20 6f 72 20 46 49 54 4e 45 ABILITY or FITNE
0250: 53 53 20 46 4f 52 20 41 20 50 41 52 54 49 43 55 SS FOR A PARTICU
0260: 4c 41 52 20 50 55 52 50 4f 53 45 2e 20 20 53 65 LAR PURPOSE. Se
0270: 65 20 74 68 65 0a 3b 3b 20 20 20 20 20 47 4e 55 e the.;; GNU
0280: 20 47 65 6e 65 72 61 6c 20 50 75 62 6c 69 63 20 General Public
0290: 4c 69 63 65 6e 73 65 20 66 6f 72 20 6d 6f 72 65 License for more
02a0: 20 64 65 74 61 69 6c 73 2e 0a 3b 3b 20 0a 3b 3b details..;; .;;
02b0: 20 20 20 20 20 59 6f 75 20 73 68 6f 75 6c 64 20 You should
02c0: 68 61 76 65 20 72 65 63 65 69 76 65 64 20 61 20 have received a
02d0: 63 6f 70 79 20 6f 66 20 74 68 65 20 47 4e 55 20 copy of the GNU
02e0: 47 65 6e 65 72 61 6c 20 50 75 62 6c 69 63 20 4c General Public L
02f0: 69 63 65 6e 73 65 0a 3b 3b 20 20 20 20 20 61 6c icense.;; al
0300: 6f 6e 67 20 77 69 74 68 20 4d 65 67 61 74 65 73 ong with Megates
0310: 74 2e 20 20 49 66 20 6e 6f 74 2c 20 73 65 65 20 t. If not, see
0320: 3c 68 74 74 70 3a 2f 2f 77 77 77 2e 67 6e 75 2e <http://www.gnu.
0330: 6f 72 67 2f 6c 69 63 65 6e 73 65 73 2f 3e 2e 0a org/licenses/>..
0340: 3b 3b 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;.;;===========
0350: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0360: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0370: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0380: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 3d ===========..;;=
0390: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
03a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
03b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
03c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
03d0: 3d 3d 3d 3d 3d 0a 3b 3b 20 54 65 73 74 73 0a 3b =====.;; Tests.;
03e0: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
03f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0400: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0410: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0420: 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 63 6c 61 72 =======..(declar
0430: 65 20 28 75 6e 69 74 20 74 65 73 74 73 29 29 0a e (unit tests)).
0440: 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 6c (declare (uses l
0450: 6f 63 6b 2d 71 75 65 75 65 29 29 0a 28 64 65 63 ock-queue)).(dec
0460: 6c 61 72 65 20 28 75 73 65 73 20 64 62 29 29 0a lare (uses db)).
0470: 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 74 (declare (uses t
0480: 64 62 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 db)).(declare (u
0490: 73 65 73 20 63 6f 6d 6d 6f 6e 29 29 0a 3b 3b 20 ses common)).;;
04a0: 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 64 (declare (uses d
04b0: 63 6f 6d 6d 6f 6e 29 29 20 3b 3b 20 6e 65 65 64 common)) ;; need
04c0: 65 64 20 66 6f 72 20 74 68 65 20 73 74 65 70 73 ed for the steps
04d0: 20 70 72 6f 63 65 73 73 69 6e 67 0a 28 64 65 63 processing.(dec
04e0: 6c 61 72 65 20 28 75 73 65 73 20 69 74 65 6d 73 lare (uses items
04f0: 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 )).(declare (use
0500: 73 20 72 75 6e 63 6f 6e 66 69 67 29 29 0a 3b 3b s runconfig)).;;
0510: 20 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 (declare (uses
0520: 73 64 62 29 29 0a 28 64 65 63 6c 61 72 65 20 28 sdb)).(declare (
0530: 75 73 65 73 20 73 65 72 76 65 72 29 29 0a 3b 3b uses server)).;;
0540: 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 73 (declare (uses s
0550: 74 6d 6c 32 29 29 0a 0a 28 75 73 65 20 73 71 6c tml2))..(use sql
0560: 69 74 65 33 20 73 72 66 69 2d 31 20 70 6f 73 69 ite3 srfi-1 posi
0570: 78 20 72 65 67 65 78 20 72 65 67 65 78 2d 63 61 x regex regex-ca
0580: 73 65 20 73 72 66 69 2d 36 39 20 64 6f 74 2d 6c se srfi-69 dot-l
0590: 6f 63 6b 69 6e 67 20 74 63 70 20 64 69 72 65 63 ocking tcp direc
05a0: 74 6f 72 79 2d 75 74 69 6c 73 29 0a 28 69 6d 70 tory-utils).(imp
05b0: 6f 72 74 20 28 70 72 65 66 69 78 20 73 71 6c 69 ort (prefix sqli
05c0: 74 65 33 20 73 71 6c 69 74 65 33 3a 29 29 0a 28 te3 sqlite3:)).(
05d0: 72 65 71 75 69 72 65 2d 6c 69 62 72 61 72 79 20 require-library
05e0: 73 74 6d 6c 29 0a 0a 28 69 6e 63 6c 75 64 65 20 stml)..(include
05f0: 22 63 6f 6d 6d 6f 6e 5f 72 65 63 6f 72 64 73 2e "common_records.
0600: 73 63 6d 22 29 0a 28 69 6e 63 6c 75 64 65 20 22 scm").(include "
0610: 6b 65 79 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 key_records.scm"
0620: 29 0a 28 69 6e 63 6c 75 64 65 20 22 64 62 5f 72 ).(include "db_r
0630: 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a 28 69 6e ecords.scm").(in
0640: 63 6c 75 64 65 20 22 72 75 6e 5f 72 65 63 6f 72 clude "run_recor
0650: 64 73 2e 73 63 6d 22 29 0a 28 69 6e 63 6c 75 64 ds.scm").(includ
0660: 65 20 22 74 65 73 74 5f 72 65 63 6f 72 64 73 2e e "test_records.
0670: 73 63 6d 22 29 0a 28 69 6e 63 6c 75 64 65 20 22 scm").(include "
0680: 6a 73 2d 70 61 74 68 2e 73 63 6d 22 29 0a 0a 28 js-path.scm")..(
0690: 64 65 66 69 6e 65 20 28 69 6e 69 74 2d 6a 61 76 define (init-jav
06a0: 61 2d 73 63 72 69 70 74 2d 6c 69 62 29 0a 20 20 a-script-lib).
06b0: 28 73 65 74 21 20 2a 6a 61 76 61 2d 73 63 72 69 (set! *java-scri
06c0: 70 74 2d 6c 69 62 2a 20 28 63 6f 6e 63 20 20 28 pt-lib* (conc (
06d0: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 69 6e 73 74 61 common:get-insta
06e0: 6c 6c 2d 61 72 65 61 29 20 22 2f 73 68 61 72 65 ll-area) "/share
06f0: 2f 6a 73 2f 6a 71 75 65 72 79 2d 33 2e 31 2e 30 /js/jquery-3.1.0
0700: 2e 73 6c 69 6d 2e 6d 69 6e 2e 6a 73 22 29 29 0a .slim.min.js")).
0710: 20 20 29 0a 0a 3b 3b 20 43 61 6c 6c 20 74 68 69 )..;; Call thi
0720: 73 20 6f 6e 65 20 74 6f 20 64 6f 20 61 6c 6c 20 s one to do all
0730: 74 68 65 20 77 6f 72 6b 20 61 6e 64 20 67 65 74 the work and get
0740: 20 61 20 73 74 61 6e 64 61 72 64 69 7a 65 64 20 a standardized
0750: 6c 69 73 74 20 6f 66 20 74 65 73 74 73 0a 3b 3b list of tests.;;
0760: 20 20 20 67 65 74 73 20 70 61 74 68 73 20 66 72 gets paths fr
0770: 6f 6d 20 63 6f 6e 66 69 67 73 20 61 6e 64 20 66 om configs and f
0780: 69 6e 64 73 20 76 61 6c 69 64 20 74 65 73 74 73 inds valid tests
0790: 20 0a 3b 3b 20 20 20 72 65 74 75 72 6e 73 20 68 .;; returns h
07a0: 61 73 68 20 6f 66 20 74 65 73 74 6e 61 6d 65 20 ash of testname
07b0: 2d 2d 3e 20 66 75 6c 6c 70 61 74 68 0a 3b 3b 0a --> fullpath.;;.
07c0: 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 67 (define (tests:g
07d0: 65 74 2d 61 6c 6c 29 0a 20 20 28 6c 65 74 2a 20 et-all). (let*
07e0: 28 28 74 65 73 74 2d 73 65 61 72 63 68 2d 70 61 ((test-search-pa
07f0: 74 68 20 20 20 28 74 65 73 74 73 3a 67 65 74 2d th (tests:get-
0800: 74 65 73 74 73 2d 73 65 61 72 63 68 2d 70 61 74 tests-search-pat
0810: 68 20 2a 63 6f 6e 66 69 67 64 61 74 2a 29 29 29 h *configdat*)))
0820: 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
0830: 74 20 38 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 8 *default-log
0840: 2d 70 6f 72 74 2a 20 22 74 65 73 74 2d 73 65 61 -port* "test-sea
0850: 72 63 68 2d 70 61 74 68 3a 20 22 20 74 65 73 74 rch-path: " test
0860: 2d 73 65 61 72 63 68 2d 70 61 74 68 29 0a 20 20 -search-path).
0870: 20 20 28 74 65 73 74 73 3a 67 65 74 2d 76 61 6c (tests:get-val
0880: 69 64 2d 74 65 73 74 73 20 28 6d 61 6b 65 2d 68 id-tests (make-h
0890: 61 73 68 2d 74 61 62 6c 65 29 20 74 65 73 74 2d ash-table) test-
08a0: 73 65 61 72 63 68 2d 70 61 74 68 29 29 29 0a 0a search-path)))..
08b0: 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 67 (define (tests:g
08c0: 65 74 2d 74 65 73 74 73 2d 73 65 61 72 63 68 2d et-tests-search-
08d0: 70 61 74 68 20 63 66 67 64 61 74 29 0a 20 20 28 path cfgdat). (
08e0: 6c 65 74 20 28 28 70 61 74 68 73 20 28 6c 65 74 let ((paths (let
08f0: 20 28 28 73 65 63 74 69 6f 6e 20 28 69 66 20 63 ((section (if c
0900: 66 67 64 61 74 0a 09 09 09 09 20 20 28 63 6f 6e fgdat..... (con
0910: 66 69 67 66 3a 67 65 74 2d 73 65 63 74 69 6f 6e figf:get-section
0920: 20 63 66 67 64 61 74 20 22 74 65 73 74 73 2d 70 cfgdat "tests-p
0930: 61 74 68 73 22 29 0a 09 09 09 09 20 20 23 66 29 aths")..... #f)
0940: 29 29 0a 09 09 20 28 69 66 20 73 65 63 74 69 6f ))... (if sectio
0950: 6e 0a 09 09 20 20 20 20 20 28 6d 61 70 20 63 61 n... (map ca
0960: 64 72 20 73 65 63 74 69 6f 6e 29 0a 09 09 20 20 dr section)...
0970: 20 20 20 27 28 29 29 29 29 29 0a 20 20 20 20 28 '())))). (
0980: 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 filter (lambda (
0990: 64 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 64 d).. (if (d
09a0: 69 72 65 63 74 6f 72 79 2d 65 78 69 73 74 73 3f irectory-exists?
09b0: 20 64 29 0a 09 09 20 20 64 0a 09 09 20 20 28 62 d)... d... (b
09c0: 65 67 69 6e 0a 09 09 20 20 20 20 3b 3b 20 28 69 egin... ;; (i
09d0: 66 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f f (common:low-no
09e0: 69 73 65 2d 70 72 69 6e 74 20 36 30 20 22 74 65 ise-print 60 "te
09f0: 73 74 73 3a 67 65 74 2d 74 65 73 74 73 2d 73 65 sts:get-tests-se
0a00: 61 72 63 68 2d 70 61 74 68 22 20 64 29 0a 09 09 arch-path" d)...
0a10: 20 20 20 20 3b 3b 09 28 64 65 62 75 67 3a 70 72 ;;.(debug:pr
0a20: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
0a30: 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e og-port* "WARNIN
0a40: 47 3a 20 70 72 6f 62 6c 65 6d 20 77 69 74 68 20 G: problem with
0a50: 64 69 72 65 63 74 6f 72 79 20 22 20 64 20 22 2c directory " d ",
0a60: 20 64 72 6f 70 70 69 6e 67 20 69 74 20 66 72 6f dropping it fro
0a70: 6d 20 74 65 73 74 73 20 70 61 74 68 22 29 29 0a m tests path")).
0a80: 09 09 20 20 20 20 23 66 29 29 29 0a 09 20 20 20 .. #f)))..
0a90: 20 28 61 70 70 65 6e 64 20 70 61 74 68 73 20 28 (append paths (
0aa0: 6c 69 73 74 20 28 63 6f 6e 63 20 2a 74 6f 70 70 list (conc *topp
0ab0: 61 74 68 2a 20 22 2f 74 65 73 74 73 22 29 29 29 ath* "/tests")))
0ac0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 )))..(define (te
0ad0: 73 74 73 3a 67 65 74 2d 76 61 6c 69 64 2d 74 65 sts:get-valid-te
0ae0: 73 74 73 20 74 65 73 74 2d 72 65 67 69 73 74 72 sts test-registr
0af0: 79 20 74 65 73 74 73 2d 70 61 74 68 73 29 0a 20 y tests-paths).
0b00: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 65 73 74 (if (null? test
0b10: 73 2d 70 61 74 68 73 29 20 0a 20 20 20 20 20 20 s-paths) .
0b20: 74 65 73 74 2d 72 65 67 69 73 74 72 79 0a 20 20 test-registry.
0b30: 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 (let loop ((
0b40: 68 65 64 20 28 63 61 72 20 74 65 73 74 73 2d 70 hed (car tests-p
0b50: 61 74 68 73 29 29 0a 09 09 20 28 74 61 6c 20 28 aths))... (tal (
0b60: 63 64 72 20 74 65 73 74 73 2d 70 61 74 68 73 29 cdr tests-paths)
0b70: 29 29 0a 09 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a ))..(if (common:
0b80: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 68 65 64 file-exists? hed
0b90: 29 0a 09 20 20 20 20 28 66 6f 72 2d 65 61 63 68 ).. (for-each
0ba0: 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 2d 70 (lambda (test-p
0bb0: 61 74 68 29 0a 09 09 09 28 6c 65 74 2a 20 28 28 ath)....(let* ((
0bc0: 74 6e 61 6d 65 20 20 20 28 6c 61 73 74 20 28 73 tname (last (s
0bd0: 74 72 69 6e 67 2d 73 70 6c 69 74 20 74 65 73 74 tring-split test
0be0: 2d 70 61 74 68 20 22 2f 22 29 29 29 0a 09 09 09 -path "/")))....
0bf0: 20 20 20 20 20 20 20 28 74 63 6f 6e 66 69 67 20 (tconfig
0c00: 28 63 6f 6e 63 20 74 65 73 74 2d 70 61 74 68 20 (conc test-path
0c10: 22 2f 74 65 73 74 63 6f 6e 66 69 67 22 29 29 29 "/testconfig")))
0c20: 0a 09 09 09 20 20 28 69 66 20 28 61 6e 64 20 28 .... (if (and (
0c30: 6e 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d not (hash-table-
0c40: 72 65 66 2f 64 65 66 61 75 6c 74 20 74 65 73 74 ref/default test
0c50: 2d 72 65 67 69 73 74 72 79 20 74 6e 61 6d 65 20 -registry tname
0c60: 23 66 29 29 0a 09 09 09 09 20 20 20 28 63 6f 6d #f))..... (com
0c70: 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f mon:file-exists?
0c80: 20 74 63 6f 6e 66 69 67 29 29 0a 09 09 09 20 20 tconfig))....
0c90: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
0ca0: 73 65 74 21 20 74 65 73 74 2d 72 65 67 69 73 74 set! test-regist
0cb0: 72 79 20 74 6e 61 6d 65 20 74 65 73 74 2d 70 61 ry tname test-pa
0cc0: 74 68 29 29 29 29 0a 09 09 20 20 20 20 20 20 28 th))))... (
0cd0: 67 6c 6f 62 20 28 63 6f 6e 63 20 68 65 64 20 22 glob (conc hed "
0ce0: 2f 2a 22 29 29 29 29 0a 09 28 69 66 20 28 6e 75 /*"))))..(if (nu
0cf0: 6c 6c 3f 20 74 61 6c 29 0a 09 20 20 20 20 74 65 ll? tal).. te
0d00: 73 74 2d 72 65 67 69 73 74 72 79 0a 09 20 20 20 st-registry..
0d10: 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 (loop (car tal)
0d20: 28 63 64 72 20 74 61 6c 29 29 29 29 29 29 0a 0a (cdr tal))))))..
0d30: 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 66 (define (tests:f
0d40: 69 6c 74 65 72 2d 74 65 73 74 2d 6e 61 6d 65 73 ilter-test-names
0d50: 2d 6e 6f 74 2d 6d 61 74 63 68 65 64 20 74 65 73 -not-matched tes
0d60: 74 2d 6e 61 6d 65 73 20 74 65 73 74 2d 70 61 74 t-names test-pat
0d70: 74 73 29 0a 20 20 28 64 65 6c 65 74 65 2d 64 75 ts). (delete-du
0d80: 70 6c 69 63 61 74 65 73 0a 20 20 20 28 66 69 6c plicates. (fil
0d90: 74 65 72 20 28 6c 61 6d 62 64 61 20 28 74 65 73 ter (lambda (tes
0da0: 74 6e 61 6d 65 29 0a 09 20 20 20 20 20 28 6e 6f tname).. (no
0db0: 74 20 28 74 65 73 74 73 3a 6d 61 74 63 68 20 74 t (tests:match t
0dc0: 65 73 74 2d 70 61 74 74 73 20 74 65 73 74 6e 61 est-patts testna
0dd0: 6d 65 20 23 66 29 29 29 0a 09 20 20 20 74 65 73 me #f))).. tes
0de0: 74 2d 6e 61 6d 65 73 29 29 29 0a 0a 0a 28 64 65 t-names)))...(de
0df0: 66 69 6e 65 20 28 74 65 73 74 73 3a 66 69 6c 74 fine (tests:filt
0e00: 65 72 2d 74 65 73 74 2d 6e 61 6d 65 73 20 74 65 er-test-names te
0e10: 73 74 2d 6e 61 6d 65 73 20 74 65 73 74 2d 70 61 st-names test-pa
0e20: 74 74 73 29 0a 20 20 28 64 65 6c 65 74 65 2d 64 tts). (delete-d
0e30: 75 70 6c 69 63 61 74 65 73 0a 20 20 20 28 66 69 uplicates. (fi
0e40: 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 74 65 lter (lambda (te
0e50: 73 74 6e 61 6d 65 29 0a 09 20 20 20 20 20 28 74 stname).. (t
0e60: 65 73 74 73 3a 6d 61 74 63 68 20 74 65 73 74 2d ests:match test-
0e70: 70 61 74 74 73 20 74 65 73 74 6e 61 6d 65 20 23 patts testname #
0e80: 66 29 29 0a 09 20 20 20 74 65 73 74 2d 6e 61 6d f)).. test-nam
0e90: 65 73 29 29 29 0a 0a 3b 3b 20 69 74 65 6d 6d 61 es)))..;; itemma
0ea0: 70 20 69 73 20 61 20 6c 69 73 74 20 6f 66 20 74 p is a list of t
0eb0: 65 73 74 6e 61 6d 65 20 70 61 74 74 65 72 6e 73 estname patterns
0ec0: 20 74 6f 20 6d 61 70 73 0a 3b 3b 20 20 20 20 20 to maps.;;
0ed0: 74 65 73 74 31 20 2e 2a 2f 62 61 72 2f 28 5c 64 test1 .*/bar/(\d
0ee0: 2b 29 20 66 6f 6f 2f 5c 31 0a 3b 3b 20 20 20 20 +) foo/\1.;;
0ef0: 20 25 20 20 20 20 20 66 6f 6f 2f 28 5b 5e 2f 5d % foo/([^/]
0f00: 2b 29 20 20 5c 31 2f 62 61 72 0a 3b 3b 0a 3b 3b +) \1/bar.;;.;;
0f10: 20 23 20 4e 4f 54 45 3a 20 74 68 65 20 6c 69 6e # NOTE: the lin
0f20: 65 20 77 69 74 68 20 74 68 65 20 73 69 6e 67 6c e with the singl
0f30: 65 20 25 20 63 6f 75 6c 64 20 62 65 20 74 68 65 e % could be the
0f40: 20 72 65 73 75 6c 74 20 6f 66 0a 3b 3b 20 23 20 result of.;; #
0f50: 20 20 20 20 20 20 69 74 65 6d 6d 61 70 20 65 6e itemmap en
0f60: 74 72 79 20 69 6e 20 72 65 71 75 69 72 65 6d 65 try in requireme
0f70: 6e 74 73 20 28 6c 65 67 61 63 79 29 2e 20 54 68 nts (legacy). Th
0f80: 65 20 69 74 65 6d 6d 61 70 0a 3b 3b 20 23 20 20 e itemmap.;; #
0f90: 20 20 20 20 20 72 65 71 75 69 72 65 6d 65 6e 74 requirement
0fa0: 73 20 65 6e 74 72 79 20 69 73 20 64 65 70 72 65 s entry is depre
0fb0: 63 61 74 65 64 0a 3b 3b 0a 28 64 65 66 69 6e 65 cated.;;.(define
0fc0: 20 28 74 65 73 74 73 3a 67 65 74 2d 69 74 65 6d (tests:get-item
0fd0: 6d 61 70 73 20 74 63 6f 6e 66 69 67 29 0a 20 20 maps tconfig).
0fe0: 28 6c 65 74 20 28 28 62 61 73 65 2d 69 74 65 6d (let ((base-item
0ff0: 6d 61 70 20 20 28 63 6f 6e 66 69 67 66 3a 6c 6f map (configf:lo
1000: 6f 6b 75 70 20 74 63 6f 6e 66 69 67 20 22 72 65 okup tconfig "re
1010: 71 75 69 72 65 6d 65 6e 74 73 22 20 22 69 74 65 quirements" "ite
1020: 6d 6d 61 70 22 29 29 0a 09 28 69 74 65 6d 6d 61 mmap"))..(itemma
1030: 70 2d 74 61 62 6c 65 20 28 63 6f 6e 66 69 67 66 p-table (configf
1040: 3a 67 65 74 2d 73 65 63 74 69 6f 6e 20 74 63 6f :get-section tco
1050: 6e 66 69 67 20 22 69 74 65 6d 6d 61 70 22 29 29 nfig "itemmap"))
1060: 29 0a 20 20 20 20 28 61 70 70 65 6e 64 20 28 69 ). (append (i
1070: 66 20 62 61 73 65 2d 69 74 65 6d 6d 61 70 0a 09 f base-itemmap..
1080: 09 28 6c 69 73 74 20 28 6c 69 73 74 20 22 25 22 .(list (list "%"
1090: 20 62 61 73 65 2d 69 74 65 6d 6d 61 70 29 29 0a base-itemmap)).
10a0: 09 09 27 28 29 29 0a 09 20 20 20 20 28 69 66 20 ..'()).. (if
10b0: 69 74 65 6d 6d 61 70 2d 74 61 62 6c 65 0a 09 09 itemmap-table...
10c0: 69 74 65 6d 6d 61 70 2d 74 61 62 6c 65 0a 09 09 itemmap-table...
10d0: 27 28 29 29 29 29 29 0a 0a 3b 3b 20 67 69 76 65 '()))))..;; give
10e0: 6e 20 61 20 6c 69 73 74 20 6f 66 20 69 74 65 6d n a list of item
10f0: 6d 61 70 73 20 28 74 65 73 74 6e 61 6d 65 20 2e maps (testname .
1100: 20 6d 61 70 29 2c 20 72 65 74 75 72 6e 20 74 68 map), return th
1110: 65 20 66 69 72 73 74 20 6d 61 74 63 68 0a 3b 3b e first match.;;
1120: 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a .(define (tests:
1130: 6c 6f 6f 6b 75 70 2d 69 74 65 6d 6d 61 70 20 69 lookup-itemmap i
1140: 74 65 6d 6d 61 70 73 20 74 65 73 74 6e 61 6d 65 temmaps testname
1150: 29 0a 20 20 28 6c 65 74 20 28 28 62 65 73 74 2d ). (let ((best-
1160: 6d 61 74 63 68 65 73 20 28 66 69 6c 74 65 72 20 matches (filter
1170: 28 6c 61 6d 62 64 61 20 28 69 74 65 6d 6d 61 70 (lambda (itemmap
1180: 29 0a 09 09 09 09 28 74 65 73 74 73 3a 6d 61 74 ).....(tests:mat
1190: 63 68 20 28 63 61 72 20 69 74 65 6d 6d 61 70 29 ch (car itemmap)
11a0: 20 74 65 73 74 6e 61 6d 65 20 23 66 29 29 0a 09 testname #f))..
11b0: 09 09 20 20 20 20 20 20 69 74 65 6d 6d 61 70 73 .. itemmaps
11c0: 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 75 6c ))). (if (nul
11d0: 6c 3f 20 62 65 73 74 2d 6d 61 74 63 68 65 73 29 l? best-matches)
11e0: 0a 09 23 66 0a 09 28 6c 65 74 20 28 28 72 65 73 ..#f..(let ((res
11f0: 20 28 63 61 72 20 62 65 73 74 2d 6d 61 74 63 68 (car best-match
1200: 65 73 29 29 29 0a 09 20 20 3b 3b 20 28 64 65 62 es))).. ;; (deb
1210: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
1220: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 ult-log-port* "r
1230: 65 73 3d 22 20 72 65 73 29 0a 09 20 20 28 63 6f es=" res).. (co
1240: 6e 64 0a 09 20 20 20 28 28 73 74 72 69 6e 67 3f nd.. ((string?
1250: 20 72 65 73 29 20 72 65 73 29 20 3b 3b 3b 20 46 res) res) ;;; F
1260: 49 58 20 54 48 45 20 52 4f 4f 54 20 43 41 55 53 IX THE ROOT CAUS
1270: 45 20 48 45 52 45 20 2e 2e 2e 2e 0a 09 20 20 20 E HERE ......
1280: 28 28 6e 75 6c 6c 3f 20 72 65 73 29 20 20 20 23 ((null? res) #
1290: 66 29 0a 09 20 20 20 28 28 73 74 72 69 6e 67 3f f).. ((string?
12a0: 20 28 63 64 72 20 72 65 73 29 29 20 28 63 64 72 (cdr res)) (cdr
12b0: 20 72 65 73 29 29 20 20 3b 3b 20 69 74 20 69 73 res)) ;; it is
12c0: 20 61 20 70 61 69 72 0a 09 20 20 20 28 28 73 74 a pair.. ((st
12d0: 72 69 6e 67 3f 20 28 63 61 64 72 20 72 65 73 29 ring? (cadr res)
12e0: 29 28 63 61 64 72 20 72 65 73 29 29 20 3b 3b 20 )(cadr res)) ;;
12f0: 69 74 20 69 73 20 61 20 6c 69 73 74 0a 09 20 20 it is a list..
1300: 20 28 65 6c 73 65 20 63 61 64 72 20 72 65 73 29 (else cadr res)
1310: 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 )))))..(define (
1320: 74 65 73 74 73 3a 67 65 74 2d 67 6c 6f 62 61 6c tests:get-global
1330: 2d 77 61 69 74 6f 6e 73 20 72 63 6f 6e 66 69 67 -waitons rconfig
1340: 29 0a 20 20 28 6c 65 74 2a 20 28 28 67 6c 6f 62 ). (let* ((glob
1350: 61 6c 2d 77 61 69 74 6f 6e 73 20 28 72 75 6e 63 al-waitons (runc
1360: 6f 6e 66 69 67 73 2d 67 65 74 20 72 63 6f 6e 66 onfigs-get rconf
1370: 69 67 20 22 21 47 4c 4f 42 41 4c 5f 57 41 49 54 ig "!GLOBAL_WAIT
1380: 4f 4e 53 22 29 29 29 0a 20 20 20 20 28 69 66 20 ONS"))). (if
1390: 28 73 74 72 69 6e 67 3f 20 67 6c 6f 62 61 6c 2d (string? global-
13a0: 77 61 69 74 6f 6e 73 29 0a 09 28 73 74 72 69 6e waitons)..(strin
13b0: 67 2d 73 70 6c 69 74 20 67 6c 6f 62 61 6c 2d 77 g-split global-w
13c0: 61 69 74 6f 6e 73 29 0a 09 27 28 29 29 29 29 0a aitons)..'()))).
13d0: 0a 3b 3b 20 72 65 74 75 72 6e 20 69 74 65 6d 73 .;; return items
13e0: 20 67 69 76 65 6e 20 63 6f 6e 66 69 67 0a 3b 3b given config.;;
13f0: 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a .(define (tests:
1400: 67 65 74 2d 69 74 65 6d 73 20 74 63 6f 6e 66 69 get-items tconfi
1410: 67 29 0a 20 20 28 6c 65 74 20 28 28 69 74 65 6d g). (let ((item
1420: 73 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 s (hash-tab
1430: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 le-ref/default t
1440: 63 6f 6e 66 69 67 20 22 69 74 65 6d 73 22 20 23 config "items" #
1450: 66 29 29 20 3b 3b 20 69 74 65 6d 73 20 34 0a 09 f)) ;; items 4..
1460: 28 69 74 65 6d 73 74 61 62 6c 65 20 28 68 61 73 (itemstable (has
1470: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
1480: 75 6c 74 20 74 63 6f 6e 66 69 67 20 22 69 74 65 ult tconfig "ite
1490: 6d 73 74 61 62 6c 65 22 20 23 66 29 29 29 20 0a mstable" #f))) .
14a0: 20 20 20 20 3b 3b 20 69 66 20 65 69 74 68 65 72 ;; if either
14b0: 20 69 74 65 6d 73 20 6f 72 20 69 74 65 6d 73 20 items or items
14c0: 74 61 62 6c 65 20 69 73 20 61 20 70 72 6f 63 20 table is a proc
14d0: 72 65 74 75 72 6e 20 69 74 20 73 6f 20 74 65 73 return it so tes
14e0: 74 20 72 75 6e 6e 69 6e 67 0a 20 20 20 20 3b 3b t running. ;;
14f0: 20 70 72 6f 63 65 73 73 20 63 61 6e 20 6b 6e 6f process can kno
1500: 77 20 74 6f 20 63 61 6c 6c 20 69 74 65 6d 73 3a w to call items:
1510: 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 get-items-from-c
1520: 6f 6e 66 69 67 0a 20 20 20 20 3b 3b 20 69 66 20 onfig. ;; if
1530: 65 69 74 68 65 72 20 69 73 20 61 20 6c 69 73 74 either is a list
1540: 20 61 6e 64 20 6e 6f 6e 65 20 69 73 20 61 20 70 and none is a p
1550: 72 6f 63 20 67 6f 20 61 68 65 61 64 20 61 6e 64 roc go ahead and
1560: 20 63 61 6c 6c 20 67 65 74 2d 69 74 65 6d 73 0a call get-items.
1570: 20 20 20 20 3b 3b 20 6f 74 68 65 72 77 69 73 65 ;; otherwise
1580: 20 72 65 74 75 72 6e 20 23 66 20 2d 20 74 68 69 return #f - thi
1590: 73 20 69 73 20 6e 6f 74 20 61 6e 20 69 74 65 72 s is not an iter
15a0: 61 74 65 64 20 74 65 73 74 0a 20 20 20 20 28 63 ated test. (c
15b0: 6f 6e 64 0a 20 20 20 20 20 28 28 70 72 6f 63 65 ond. ((proce
15c0: 64 75 72 65 3f 20 69 74 65 6d 73 29 20 20 20 20 dure? items)
15d0: 20 20 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a . (debug:
15e0: 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 2a 64 65 print-info 4 *de
15f0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
1600: 22 69 74 65 6d 73 20 69 73 20 61 20 70 72 6f 63 "items is a proc
1610: 65 64 75 72 65 2c 20 77 69 6c 6c 20 63 61 6c 63 edure, will calc
1620: 20 6c 61 74 65 72 22 29 0a 20 20 20 20 20 20 69 later"). i
1630: 74 65 6d 73 29 20 20 20 20 20 20 20 20 20 20 20 tems)
1640: 20 3b 3b 20 63 61 6c 63 20 6c 61 74 65 72 0a 20 ;; calc later.
1650: 20 20 20 20 28 28 70 72 6f 63 65 64 75 72 65 3f ((procedure?
1660: 20 69 74 65 6d 73 74 61 62 6c 65 29 0a 20 20 20 itemstable).
1670: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
1680: 69 6e 66 6f 20 34 20 2a 64 65 66 61 75 6c 74 2d info 4 *default-
1690: 6c 6f 67 2d 70 6f 72 74 2a 20 22 69 74 65 6d 73 log-port* "items
16a0: 74 61 62 6c 65 20 69 73 20 61 20 70 72 6f 63 65 table is a proce
16b0: 64 75 72 65 2c 20 77 69 6c 6c 20 63 61 6c 63 20 dure, will calc
16c0: 6c 61 74 65 72 22 29 0a 20 20 20 20 20 20 69 74 later"). it
16d0: 65 6d 73 74 61 62 6c 65 29 20 20 20 20 20 20 20 emstable)
16e0: 3b 3b 20 63 61 6c 63 20 6c 61 74 65 72 0a 20 20 ;; calc later.
16f0: 20 20 20 28 28 66 69 6c 74 65 72 20 28 6c 61 6d ((filter (lam
1700: 62 64 61 20 28 78 29 0a 09 09 28 6c 65 74 20 28 bda (x)...(let (
1710: 28 76 61 6c 20 28 63 61 72 20 78 29 29 29 0a 09 (val (car x)))..
1720: 09 20 20 28 69 66 20 28 70 72 6f 63 65 64 75 72 . (if (procedur
1730: 65 3f 20 76 61 6c 29 20 76 61 6c 20 23 66 29 29 e? val) val #f))
1740: 29 0a 09 20 20 20 20 20 20 28 61 70 70 65 6e 64 ).. (append
1750: 20 28 69 66 20 28 6c 69 73 74 3f 20 69 74 65 6d (if (list? item
1760: 73 29 20 69 74 65 6d 73 20 27 28 29 29 0a 09 09 s) items '())...
1770: 20 20 20 20 20 20 28 69 66 20 28 6c 69 73 74 3f (if (list?
1780: 20 69 74 65 6d 73 74 61 62 6c 65 29 20 69 74 65 itemstable) ite
1790: 6d 73 74 61 62 6c 65 20 27 28 29 29 29 29 0a 20 mstable '()))).
17a0: 20 20 20 20 20 27 68 61 76 65 2d 70 72 6f 63 65 'have-proce
17b0: 64 75 72 65 29 0a 20 20 20 20 20 28 28 6f 72 20 dure). ((or
17c0: 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 28 6c 69 (list? items)(li
17d0: 73 74 3f 20 69 74 65 6d 73 74 61 62 6c 65 29 29 st? itemstable))
17e0: 20 3b 3b 20 63 61 6c 63 20 6e 6f 77 0a 20 20 20 ;; calc now.
17f0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
1800: 69 6e 66 6f 20 34 20 2a 64 65 66 61 75 6c 74 2d info 4 *default-
1810: 6c 6f 67 2d 70 6f 72 74 2a 20 22 69 74 65 6d 73 log-port* "items
1820: 20 61 6e 64 20 69 74 65 6d 73 74 61 62 6c 65 20 and itemstable
1830: 61 72 65 20 6c 69 73 74 73 2c 20 63 61 6c 63 20 are lists, calc
1840: 6e 6f 77 5c 6e 22 0a 09 09 09 22 20 20 20 20 69 now\n"...." i
1850: 74 65 6d 73 3a 20 22 20 69 74 65 6d 73 20 22 20 tems: " items "
1860: 69 74 65 6d 73 74 61 62 6c 65 3a 20 22 20 69 74 itemstable: " it
1870: 65 6d 73 74 61 62 6c 65 29 0a 20 20 20 20 20 20 emstable).
1880: 28 69 74 65 6d 73 3a 67 65 74 2d 69 74 65 6d 73 (items:get-items
1890: 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 20 74 63 6f -from-config tco
18a0: 6e 66 69 67 29 29 0a 20 20 20 20 20 28 65 6c 73 nfig)). (els
18b0: 65 20 23 66 29 29 29 29 20 20 20 20 20 20 20 20 e #f))))
18c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
18d0: 20 20 20 3b 3b 20 6e 6f 74 20 69 74 65 72 61 74 ;; not iterat
18e0: 65 64 0a 0a 0a 3b 3b 20 72 65 74 75 72 6e 73 20 ed...;; returns
18f0: 77 61 69 74 6f 6e 73 20 77 61 69 74 6f 72 73 20 waitons waitors
1900: 74 63 6f 6e 66 69 67 64 61 74 0a 3b 3b 0a 28 64 tconfigdat.;;.(d
1910: 65 66 69 6e 65 20 28 74 65 73 74 73 3a 67 65 74 efine (tests:get
1920: 2d 77 61 69 74 6f 6e 73 20 74 65 73 74 2d 6e 61 -waitons test-na
1930: 6d 65 20 61 6c 6c 2d 74 65 73 74 73 2d 72 65 67 me all-tests-reg
1940: 69 73 74 72 79 20 67 6c 6f 62 61 6c 2d 77 61 69 istry global-wai
1950: 74 6f 6e 73 29 0a 20 20 20 28 6c 65 74 2a 20 28 tons). (let* (
1960: 28 63 6f 6e 66 69 67 20 20 28 74 65 73 74 73 3a (config (tests:
1970: 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 74 get-testconfig t
1980: 65 73 74 2d 6e 61 6d 65 20 23 66 20 61 6c 6c 2d est-name #f all-
1990: 74 65 73 74 73 2d 72 65 67 69 73 74 72 79 20 27 tests-registry '
19a0: 72 65 74 75 72 6e 2d 70 72 6f 63 73 29 29 29 20 return-procs)))
19b0: 3b 3b 20 61 73 73 75 6d 69 6e 67 20 6e 6f 20 70 ;; assuming no p
19c0: 72 6f 62 6c 65 6d 73 20 77 69 74 68 20 69 6d 6d roblems with imm
19d0: 65 64 69 61 74 65 20 65 76 61 6c 75 61 74 69 6f ediate evaluatio
19e0: 6e 2c 20 74 68 69 73 20 63 6f 75 6c 64 20 62 65 n, this could be
19f0: 20 73 69 6d 70 6c 69 66 69 65 64 20 28 27 72 65 simplified ('re
1a00: 74 75 72 6e 2d 70 72 6f 63 73 20 2d 3e 20 23 74 turn-procs -> #t
1a10: 29 0a 20 20 20 20 20 28 6c 65 74 20 28 28 69 6e ). (let ((in
1a20: 73 74 72 20 28 69 66 20 63 6f 6e 66 69 67 20 0a str (if config .
1a30: 09 09 20 20 20 20 20 20 28 63 6f 6e 66 69 67 66 .. (configf
1a40: 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 20 22 :lookup config "
1a50: 72 65 71 75 69 72 65 6d 65 6e 74 73 22 20 22 77 requirements" "w
1a60: 61 69 74 6f 6e 22 29 0a 09 09 20 20 20 20 20 20 aiton")...
1a70: 28 62 65 67 69 6e 20 3b 3b 20 4e 6f 20 63 6f 6e (begin ;; No con
1a80: 66 69 67 20 6d 65 61 6e 73 20 74 68 69 73 20 69 fig means this i
1a90: 73 20 61 20 6e 6f 6e 2d 65 78 69 73 74 61 6e 74 s a non-existant
1aa0: 20 74 65 73 74 0a 09 09 09 28 64 65 62 75 67 3a test....(debug:
1ab0: 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 print-error 0 *d
1ac0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
1ad0: 20 22 6e 6f 6e 2d 65 78 69 73 74 65 6e 74 20 72 "non-existent r
1ae0: 65 71 75 69 72 65 64 20 74 65 73 74 20 5c 22 22 equired test \""
1af0: 20 74 65 73 74 2d 6e 61 6d 65 20 22 5c 22 22 29 test-name "\"")
1b00: 0a 09 09 09 28 65 78 69 74 20 31 29 29 29 29 0a ....(exit 1)))).
1b10: 09 20 20 20 28 69 6e 73 74 72 32 20 28 69 66 20 . (instr2 (if
1b20: 63 6f 6e 66 69 67 0a 09 09 20 20 20 20 20 20 20 config...
1b30: 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 (configf:lookup
1b40: 63 6f 6e 66 69 67 20 22 72 65 71 75 69 72 65 6d config "requirem
1b50: 65 6e 74 73 22 20 22 77 61 69 74 6f 72 22 29 0a ents" "waitor").
1b60: 09 09 20 20 20 20 20 20 20 22 22 29 29 29 0a 20 .. ""))).
1b70: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
1b80: 6e 74 2d 69 6e 66 6f 20 38 20 2a 64 65 66 61 75 nt-info 8 *defau
1b90: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 77 61 lt-log-port* "wa
1ba0: 69 74 6f 6e 73 20 73 74 72 69 6e 67 20 69 73 20 itons string is
1bb0: 22 20 69 6e 73 74 72 20 22 2c 20 77 61 69 74 6f " instr ", waito
1bc0: 72 73 20 73 74 72 69 6e 67 20 69 73 20 22 20 69 rs string is " i
1bd0: 6e 73 74 72 32 29 0a 20 20 20 20 20 20 20 28 6c nstr2). (l
1be0: 65 74 2a 20 28 28 6e 65 77 77 61 69 74 6f 6e 73 et* ((newwaitons
1bf0: 2d 74 6d 70 0a 09 20 20 20 20 20 20 28 73 74 72 -tmp.. (str
1c00: 69 6e 67 2d 73 70 6c 69 74 20 28 63 6f 6e 64 0a ing-split (cond.
1c10: 09 09 09 20 20 20 20 20 28 28 70 72 6f 63 65 64 ... ((proced
1c20: 75 72 65 3f 20 69 6e 73 74 72 29 20 3b 3b 20 68 ure? instr) ;; h
1c30: 65 72 65 20 0a 09 09 09 20 20 20 20 20 20 28 6c ere .... (l
1c40: 65 74 20 28 28 72 65 73 20 28 69 6e 73 74 72 29 et ((res (instr)
1c50: 29 29 0a 09 09 09 09 28 64 65 62 75 67 3a 70 72 )).....(debug:pr
1c60: 69 6e 74 2d 69 6e 66 6f 20 38 20 2a 64 65 66 61 int-info 8 *defa
1c70: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 77 ult-log-port* "w
1c80: 61 69 74 6f 6e 20 70 72 6f 63 65 64 75 72 65 20 aiton procedure
1c90: 72 65 73 75 6c 74 73 20 69 6e 20 73 74 72 69 6e results in strin
1ca0: 67 20 22 20 72 65 73 20 22 20 66 6f 72 20 74 65 g " res " for te
1cb0: 73 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 29 0a st " test-name).
1cc0: 09 09 09 09 72 65 73 29 29 0a 09 09 09 20 20 20 ....res))....
1cd0: 20 20 28 28 73 74 72 69 6e 67 3f 20 69 6e 73 74 ((string? inst
1ce0: 72 29 20 20 20 20 20 69 6e 73 74 72 29 0a 09 09 r) instr)...
1cf0: 09 20 20 20 20 20 28 65 6c 73 65 20 0a 09 09 09 . (else ....
1d00: 20 20 20 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 54 ;; NOTE: T
1d10: 68 69 73 20 69 73 20 61 63 74 75 61 6c 6c 79 20 his is actually
1d20: 74 68 65 20 63 61 73 65 20 6f 66 20 2a 6e 6f 2a the case of *no*
1d30: 20 77 61 69 74 6f 6e 73 21 20 3b 3b 20 28 64 65 waitons! ;; (de
1d40: 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 bug:print-error
1d50: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
1d60: 6f 72 74 2a 20 22 73 6f 6d 65 74 68 69 6e 67 20 ort* "something
1d70: 77 65 6e 74 20 77 72 6f 6e 67 20 69 6e 20 70 72 went wrong in pr
1d80: 6f 63 65 73 73 69 6e 67 20 77 61 69 74 6f 6e 73 ocessing waitons
1d90: 20 66 6f 72 20 74 65 73 74 20 22 20 74 65 73 74 for test " test
1da0: 2d 6e 61 6d 65 29 0a 09 09 09 20 20 20 20 20 20 -name)....
1db0: 22 22 29 29 29 29 0a 09 20 20 20 20 20 28 6e 65 "")))).. (ne
1dc0: 77 77 61 69 74 6f 72 73 0a 09 20 20 20 20 20 20 wwaitors..
1dd0: 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 28 63 (string-split (c
1de0: 6f 6e 64 0a 09 09 09 20 20 20 20 20 28 28 70 72 ond.... ((pr
1df0: 6f 63 65 64 75 72 65 3f 20 69 6e 73 74 72 32 29 ocedure? instr2)
1e00: 0a 09 09 09 20 20 20 20 20 20 28 6c 65 74 20 28 .... (let (
1e10: 28 72 65 73 20 28 69 6e 73 74 72 32 29 29 29 0a (res (instr2))).
1e20: 09 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 ....(debug:print
1e30: 2d 69 6e 66 6f 20 38 20 2a 64 65 66 61 75 6c 74 -info 8 *default
1e40: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 77 61 69 74 -log-port* "wait
1e50: 6f 72 20 70 72 6f 63 65 64 75 72 65 20 72 65 73 or procedure res
1e60: 75 6c 74 73 20 69 6e 20 73 74 72 69 6e 67 20 22 ults in string "
1e70: 20 72 65 73 20 22 20 66 6f 72 20 74 65 73 74 20 res " for test
1e80: 22 20 74 65 73 74 2d 6e 61 6d 65 29 0a 09 09 09 " test-name)....
1e90: 09 72 65 73 29 29 0a 09 09 09 20 20 20 20 20 28 .res)).... (
1ea0: 28 73 74 72 69 6e 67 3f 20 69 6e 73 74 72 32 29 (string? instr2)
1eb0: 20 20 20 20 20 69 6e 73 74 72 32 29 0a 09 09 09 instr2)....
1ec0: 20 20 20 20 20 28 65 6c 73 65 20 0a 09 09 09 20 (else ....
1ed0: 20 20 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 54 68 ;; NOTE: Th
1ee0: 69 73 20 69 73 20 61 63 74 75 61 6c 6c 79 20 74 is is actually t
1ef0: 68 65 20 63 61 73 65 20 6f 66 20 2a 6e 6f 2a 20 he case of *no*
1f00: 77 61 69 74 6f 6e 73 21 20 3b 3b 20 28 64 65 62 waitons! ;; (deb
1f10: 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 ug:print-error 0
1f20: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
1f30: 72 74 2a 20 22 73 6f 6d 65 74 68 69 6e 67 20 77 rt* "something w
1f40: 65 6e 74 20 77 72 6f 6e 67 20 69 6e 20 70 72 6f ent wrong in pro
1f50: 63 65 73 73 69 6e 67 20 77 61 69 74 6f 6e 73 20 cessing waitons
1f60: 66 6f 72 20 74 65 73 74 20 22 20 74 65 73 74 2d for test " test-
1f70: 6e 61 6d 65 29 0a 09 09 09 20 20 20 20 20 20 22 name).... "
1f80: 22 29 29 29 29 0a 09 20 20 20 20 20 28 6e 65 77 ")))).. (new
1f90: 77 61 69 74 6f 6e 73 20 28 69 66 20 28 61 6e 64 waitons (if (and
1fa0: 20 28 6c 69 73 74 3f 20 67 6c 6f 62 61 6c 2d 77 (list? global-w
1fb0: 61 69 74 6f 6e 73 29 0a 09 09 09 09 20 20 28 6e aitons)..... (n
1fc0: 6f 74 20 28 6e 75 6c 6c 3f 20 67 6c 6f 62 61 6c ot (null? global
1fd0: 2d 77 61 69 74 6f 6e 73 29 29 29 0a 09 09 09 20 -waitons)))....
1fe0: 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 20 20 (begin....
1ff0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
2000: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
2010: 2d 70 6f 72 74 2a 20 22 41 64 64 69 6e 67 20 67 -port* "Adding g
2020: 6c 6f 62 61 6c 20 77 61 69 74 6f 6e 73 20 22 20 lobal waitons "
2030: 67 6c 6f 62 61 6c 2d 77 61 69 74 6f 6e 73 29 0a global-waitons).
2040: 09 09 09 20 20 20 20 20 20 20 28 61 70 70 65 6e ... (appen
2050: 64 20 6e 65 77 77 61 69 74 6f 6e 73 2d 74 6d 70 d newwaitons-tmp
2060: 20 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 (filter (lambd
2070: 61 20 28 78 29 20 3b 3b 20 72 65 6d 6f 76 65 20 a (x) ;; remove
2080: 73 65 6c 66 20 66 72 6f 6d 20 67 6c 6f 62 61 6c self from global
2090: 20 77 61 69 74 6f 6e 73 0a 09 09 09 09 09 09 09 waitons........
20a0: 09 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 78 . (not (equal? x
20b0: 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a 09 09 test-name)))...
20c0: 09 09 09 09 09 20 20 20 20 20 20 20 67 6c 6f 62 ..... glob
20d0: 61 6c 2d 77 61 69 74 6f 6e 73 29 29 29 0a 09 09 al-waitons)))...
20e0: 09 20 20 20 20 20 6e 65 77 77 61 69 74 6f 6e 73 . newwaitons
20f0: 2d 74 6d 70 29 29 29 0a 09 20 28 76 61 6c 75 65 -tmp))).. (value
2100: 73 0a 09 20 20 3b 3b 20 74 68 65 20 77 61 69 74 s.. ;; the wait
2110: 6f 6e 73 0a 09 20 20 28 66 69 6c 74 65 72 20 28 ons.. (filter (
2120: 6c 61 6d 62 64 61 20 28 78 29 0a 09 09 20 20 20 lambda (x)...
2130: 20 28 69 66 20 28 68 61 73 68 2d 74 61 62 6c 65 (if (hash-table
2140: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 61 6c 6c -ref/default all
2150: 2d 74 65 73 74 73 2d 72 65 67 69 73 74 72 79 20 -tests-registry
2160: 78 20 23 66 29 0a 09 09 09 23 74 0a 09 09 09 28 x #f)....#t....(
2170: 62 65 67 69 6e 0a 09 09 09 20 20 28 64 65 62 75 begin.... (debu
2180: 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 g:print-error 0
2190: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
21a0: 74 2a 20 22 74 65 73 74 20 22 20 74 65 73 74 2d t* "test " test-
21b0: 6e 61 6d 65 20 22 20 68 61 73 20 75 6e 72 65 63 name " has unrec
21c0: 6f 67 6e 69 73 65 64 20 77 61 69 74 6f 6e 20 74 ognised waiton t
21d0: 65 73 74 6e 61 6d 65 20 22 20 78 29 0a 09 09 09 estname " x)....
21e0: 20 20 23 66 29 29 29 0a 09 09 20 20 6e 65 77 77 #f)))... neww
21f0: 61 69 74 6f 6e 73 29 0a 09 20 20 28 66 69 6c 74 aitons).. (filt
2200: 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 er (lambda (x)..
2210: 09 20 20 20 20 28 69 66 20 28 68 61 73 68 2d 74 . (if (hash-t
2220: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
2230: 20 61 6c 6c 2d 74 65 73 74 73 2d 72 65 67 69 73 all-tests-regis
2240: 74 72 79 20 78 20 23 66 29 0a 09 09 09 23 74 0a try x #f)....#t.
2250: 09 09 09 28 62 65 67 69 6e 0a 09 09 09 20 20 28 ...(begin.... (
2260: 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f debug:print-erro
2270: 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 r 0 *default-log
2280: 2d 70 6f 72 74 2a 20 22 74 65 73 74 20 22 20 74 -port* "test " t
2290: 65 73 74 2d 6e 61 6d 65 20 22 20 68 61 73 20 75 est-name " has u
22a0: 6e 72 65 63 6f 67 6e 69 73 65 64 20 77 61 69 74 nrecognised wait
22b0: 6f 6e 20 74 65 73 74 6e 61 6d 65 20 22 20 78 29 on testname " x)
22c0: 0a 09 09 09 20 20 23 66 29 29 29 0a 09 09 20 20 .... #f)))...
22d0: 6e 65 77 77 61 69 74 6f 72 73 29 0a 09 20 20 63 newwaitors).. c
22e0: 6f 6e 66 69 67 29 29 29 29 29 0a 09 09 09 09 09 onfig)))))......
22f0: 20 20 20 20 20 0a 3b 3b 20 67 69 76 65 6e 20 77 .;; given w
2300: 61 69 74 69 6e 67 2d 74 65 73 74 20 74 68 61 74 aiting-test that
2310: 20 69 73 20 77 61 69 74 69 6e 67 20 6f 6e 20 77 is waiting on w
2320: 61 69 74 6f 6e 2d 74 65 73 74 20 65 78 74 65 6e aiton-test exten
2330: 64 20 74 65 73 74 2d 70 61 74 74 20 61 70 70 72 d test-patt appr
2340: 6f 70 72 69 61 74 65 6c 79 0a 3b 3b 0a 3b 3b 20 opriately.;;.;;
2350: 20 67 65 6e 6c 69 62 2f 74 65 73 74 63 6f 6e 66 genlib/testconf
2360: 69 67 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ig
2370: 20 73 69 6d 2f 74 65 73 74 63 6f 6e 66 69 67 0a sim/testconfig.
2380: 3b 3b 20 20 67 65 6e 6c 69 62 2f 73 63 68 20 20 ;; genlib/sch
2390: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
23a0: 20 20 20 20 73 69 6d 2f 73 63 68 2f 63 65 6c 6c sim/sch/cell
23b0: 31 0a 3b 3b 0a 3b 3b 20 20 5b 72 65 71 75 69 72 1.;;.;; [requir
23c0: 65 6d 65 6e 74 73 5d 20 20 20 20 20 20 20 20 20 ements]
23d0: 20 20 20 20 20 20 20 20 20 5b 72 65 71 75 69 72 [requir
23e0: 65 6d 65 6e 74 73 5d 0a 3b 3b 20 20 20 20 20 20 ements].;;
23f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2400: 20 20 20 20 20 20 20 20 20 20 20 20 6d 6f 64 65 mode
2410: 20 69 74 65 6d 77 61 69 74 0a 3b 3b 20 20 20 20 itemwait.;;
2420: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2430: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 23 20 #
2440: 74 72 69 6d 20 6f 66 66 20 74 68 65 20 63 65 6c trim off the cel
2450: 6c 20 74 6f 20 64 65 74 65 72 6d 69 6e 65 20 77 l to determine w
2460: 68 61 74 20 74 6f 20 72 75 6e 20 66 6f 72 20 67 hat to run for g
2470: 65 6e 6c 69 62 0a 3b 3b 20 20 20 20 20 20 20 20 enlib.;;
2480: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2490: 20 20 20 20 20 20 20 20 20 20 69 74 65 6d 6d 61 itemma
24a0: 70 20 2f 2e 2a 0a 3b 3b 0a 3b 3b 20 20 20 20 20 p /.*.;;.;;
24b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
24c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 77 61 69 wai
24d0: 74 69 6e 67 2d 74 65 73 74 20 69 73 20 77 61 69 ting-test is wai
24e0: 74 69 6e 67 20 6f 6e 20 77 61 69 74 6f 6e 2d 74 ting on waiton-t
24f0: 65 73 74 20 73 6f 20 77 65 20 6e 65 65 64 20 74 est so we need t
2500: 6f 20 63 72 65 61 74 65 20 61 20 70 61 74 74 65 o create a patte
2510: 72 6e 20 66 6f 72 20 77 61 69 74 6f 6e 2d 74 65 rn for waiton-te
2520: 73 74 20 67 69 76 65 6e 20 77 61 69 74 69 6e 67 st given waiting
2530: 2d 74 65 73 74 20 61 6e 64 20 69 74 65 6d 6d 61 -test and itemma
2540: 70 0a 3b 3b 20 42 42 3e 20 28 74 65 73 74 73 3a p.;; BB> (tests:
2550: 65 78 74 65 6e 64 2d 74 65 73 74 2d 70 61 74 74 extend-test-patt
2560: 73 20 22 6e 6f 72 6d 61 6c 2d 73 65 63 6f 6e 64 s "normal-second
2570: 2f 32 22 20 22 6e 6f 72 6d 61 6c 2d 73 65 63 6f /2" "normal-seco
2580: 6e 64 22 20 22 6e 6f 72 6d 61 6c 2d 66 69 72 73 nd" "normal-firs
2590: 74 22 20 27 28 29 29 0a 3b 3b 20 6f 62 73 65 72 t" '()).;; obser
25a0: 76 65 64 20 2d 3e 20 22 6e 6f 72 6d 61 6c 2d 66 ved -> "normal-f
25b0: 69 72 73 74 2f 32 2c 6e 6f 72 6d 61 6c 2d 66 69 irst/2,normal-fi
25c0: 72 73 74 2f 2c 6e 6f 72 6d 61 6c 2d 73 65 63 6f rst/,normal-seco
25d0: 6e 64 2f 32 2c 6e 6f 72 6d 61 6c 2d 73 65 63 6f nd/2,normal-seco
25e0: 6e 64 2f 22 0a 3b 3b 20 65 78 70 65 63 74 65 64 nd/".;; expected
25f0: 20 2d 3e 20 22 6e 6f 72 6d 61 6c 2d 66 69 72 73 -> "normal-firs
2600: 74 2c 6e 6f 72 6d 61 6c 2d 73 65 63 6f 6e 64 2f t,normal-second/
2610: 32 2c 6e 6f 72 6d 61 6c 2d 73 65 63 6f 6e 64 2f 2,normal-second/
2620: 22 0a 3b 3b 20 74 65 73 74 70 61 74 74 20 3d 20 ".;; testpatt =
2630: 6e 6f 72 6d 61 6c 2d 73 65 63 6f 6e 64 2f 32 0a normal-second/2.
2640: 3b 3b 20 77 61 69 74 69 6e 67 2d 74 65 73 74 20 ;; waiting-test
2650: 3d 20 6e 6f 72 6d 61 6c 2d 73 65 63 6f 6e 64 0a = normal-second.
2660: 3b 3b 20 77 61 69 74 6f 6e 2d 74 65 73 74 20 3d ;; waiton-test =
2670: 20 6e 6f 72 6d 61 6c 2d 66 69 72 73 74 0a 3b 3b normal-first.;;
2680: 20 69 74 65 6d 6d 61 70 73 20 3d 20 28 29 0a 0a itemmaps = ()..
2690: 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 65 (define (tests:e
26a0: 78 74 65 6e 64 2d 74 65 73 74 2d 70 61 74 74 73 xtend-test-patts
26b0: 20 74 65 73 74 2d 70 61 74 74 20 77 61 69 74 69 test-patt waiti
26c0: 6e 67 2d 74 65 73 74 20 77 61 69 74 6f 6e 2d 74 ng-test waiton-t
26d0: 65 73 74 20 69 74 65 6d 6d 61 70 73 20 69 74 65 est itemmaps ite
26e0: 6d 69 7a 65 64 2d 77 61 69 74 6f 6e 29 0a 20 20 mized-waiton).
26f0: 28 63 6f 6e 64 0a 20 20 20 28 69 74 65 6d 69 7a (cond. (itemiz
2700: 65 64 2d 77 61 69 74 6f 6e 0a 20 20 20 20 28 6c ed-waiton. (l
2710: 65 74 2a 20 28 28 69 74 65 6d 6d 61 70 20 20 20 et* ((itemmap
2720: 20 20 20 20 20 20 20 28 74 65 73 74 73 3a 6c 6f (tests:lo
2730: 6f 6b 75 70 2d 69 74 65 6d 6d 61 70 20 69 74 65 okup-itemmap ite
2740: 6d 6d 61 70 73 20 77 61 69 74 6f 6e 2d 74 65 73 mmaps waiton-tes
2750: 74 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 t)). (
2760: 70 61 74 74 73 20 20 20 20 20 20 20 20 20 20 20 patts
2770: 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 74 (string-split t
2780: 65 73 74 2d 70 61 74 74 20 22 2c 22 29 29 0a 20 est-patt ",")).
2790: 20 20 20 20 20 20 20 20 20 20 28 77 61 69 74 69 (waiti
27a0: 6e 67 2d 74 65 73 74 2d 6c 65 6e 20 28 2b 20 28 ng-test-len (+ (
27b0: 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 77 61 string-length wa
27c0: 69 74 69 6e 67 2d 74 65 73 74 29 20 31 29 29 0a iting-test) 1)).
27d0: 20 20 20 20 20 20 20 20 20 20 20 28 70 61 74 74 (patt
27e0: 73 2d 77 61 69 74 6f 6e 20 20 20 20 20 28 6d 61 s-waiton (ma
27f0: 70 20 28 6c 61 6d 62 64 61 20 28 78 29 20 20 3b p (lambda (x) ;
2800: 3b 20 66 6f 72 20 65 61 63 68 20 69 6e 63 6f 6d ; for each incom
2810: 69 6e 67 20 70 61 74 74 20 74 68 61 74 20 6d 61 ing patt that ma
2820: 74 63 68 65 73 20 74 68 65 20 77 61 69 74 69 6e tches the waitin
2830: 67 20 74 65 73 74 0a 20 20 20 20 20 20 20 20 20 g test.
2840: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2850: 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 2a (let*
2860: 20 28 28 6d 6f 64 70 61 74 74 20 28 69 66 20 69 ((modpatt (if i
2870: 74 65 6d 6d 61 70 20 28 64 62 3a 63 6f 6e 76 65 temmap (db:conve
2880: 72 74 2d 74 65 73 74 2d 69 74 65 6d 70 61 74 68 rt-test-itempath
2890: 20 78 20 69 74 65 6d 6d 61 70 29 20 78 29 29 20 x itemmap) x))
28a0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
28b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
28c0: 20 20 20 20 20 20 20 20 20 20 20 20 28 6e 65 77 (new
28d0: 70 61 74 74 20 28 63 6f 6e 63 20 77 61 69 74 6f patt (conc waito
28e0: 6e 2d 74 65 73 74 20 22 2f 22 20 28 73 75 62 73 n-test "/" (subs
28f0: 74 72 69 6e 67 20 6d 6f 64 70 61 74 74 20 77 61 tring modpatt wa
2900: 69 74 69 6e 67 2d 74 65 73 74 2d 6c 65 6e 20 28 iting-test-len (
2910: 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 6d 6f string-length mo
2920: 64 70 61 74 74 29 29 29 29 29 0a 20 20 20 20 20 dpatt))))).
2930: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2940: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2950: 20 3b 3b 20 28 63 6f 6e 63 20 77 61 69 74 69 6e ;; (conc waitin
2960: 67 2d 74 65 73 74 20 22 2f 2c 22 20 77 61 69 74 g-test "/," wait
2970: 69 6e 67 2d 74 65 73 74 20 22 2f 22 20 28 73 75 ing-test "/" (su
2980: 62 73 74 72 69 6e 67 20 6d 6f 64 70 61 74 74 20 bstring modpatt
2990: 77 61 69 74 6f 6e 2d 74 65 73 74 2d 6c 65 6e 20 waiton-test-len
29a0: 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 6d (string-length m
29b0: 6f 64 70 61 74 74 29 29 29 29 29 0a 20 20 20 20 odpatt))))).
29c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
29d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
29e0: 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 69 6e 20 ;; (print "in
29f0: 6d 61 70 2c 20 78 3d 22 20 78 20 22 2c 20 6e 65 map, x=" x ", ne
2a00: 77 70 61 74 74 3d 22 20 6e 65 77 70 61 74 74 29 wpatt=" newpatt)
2a10: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
2a20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2a30: 20 20 20 20 20 20 20 6e 65 77 70 61 74 74 29 29 newpatt))
2a40: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
2a50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2a60: 20 20 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 (filter (lamb
2a70: 64 61 20 28 78 29 0a 20 20 20 20 20 20 20 20 20 da (x).
2a80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2a90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2aa0: 20 20 20 28 65 71 3f 20 28 73 75 62 73 74 72 69 (eq? (substri
2ab0: 6e 67 2d 69 6e 64 65 78 20 28 63 6f 6e 63 20 77 ng-index (conc w
2ac0: 61 69 74 69 6e 67 2d 74 65 73 74 20 22 2f 22 29 aiting-test "/")
2ad0: 20 78 29 20 30 29 29 20 3b 3b 20 69 73 20 74 68 x) 0)) ;; is th
2ae0: 69 73 20 70 61 74 74 20 70 65 72 74 69 6e 65 6e is patt pertinen
2af0: 74 20 74 6f 20 74 68 65 20 77 61 69 74 69 6e 67 t to the waiting
2b00: 20 74 65 73 74 0a 20 20 20 20 20 20 20 20 20 20 test.
2b10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2b20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2b30: 70 61 74 74 73 29 29 29 0a 20 20 20 20 20 20 20 patts))).
2b40: 20 20 20 20 28 65 78 74 65 6e 64 65 64 2d 74 65 (extended-te
2b50: 73 74 2d 70 61 74 74 20 20 20 28 61 70 70 65 6e st-patt (appen
2b60: 64 20 70 61 74 74 73 20 28 69 66 20 28 6e 75 6c d patts (if (nul
2b70: 6c 3f 20 70 61 74 74 73 2d 77 61 69 74 6f 6e 29 l? patts-waiton)
2b80: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
2b90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2ba0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2bb0: 20 20 20 20 28 6c 69 73 74 20 28 63 6f 6e 63 20 (list (conc
2bc0: 77 61 69 74 6f 6e 2d 74 65 73 74 20 22 2f 25 22 waiton-test "/%"
2bd0: 29 29 20 3b 3b 20 72 65 61 6c 6c 79 20 73 68 6f )) ;; really sho
2be0: 75 6c 64 6e 27 74 20 61 64 64 20 74 68 65 20 77 uldn't add the w
2bf0: 61 69 74 6f 6e 20 66 6f 72 63 65 66 75 6c 6c 79 aiton forcefully
2c00: 20 6c 69 6b 65 20 74 68 69 73 0a 20 20 20 20 20 like this.
2c10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2c20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2c30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 70 61 pa
2c40: 74 74 73 2d 77 61 69 74 6f 6e 29 29 29 0a 20 20 tts-waiton))).
2c50: 20 20 20 20 20 20 20 20 20 28 65 78 74 65 6e 64 (extend
2c60: 65 64 2d 74 65 73 74 2d 70 61 74 74 2d 77 69 74 ed-test-patt-wit
2c70: 68 2d 74 6f 70 6c 65 76 65 6c 73 0a 20 20 20 20 h-toplevels.
2c80: 20 20 20 20 20 20 20 20 28 66 6f 6c 64 20 28 6c (fold (l
2c90: 61 6d 62 64 61 20 28 74 65 73 74 70 61 74 74 2d ambda (testpatt-
2ca0: 69 74 65 6d 20 61 63 63 75 6d 20 29 0a 20 20 20 item accum ).
2cb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2cc0: 20 28 6c 65 74 20 28 28 6d 79 2d 6d 61 74 63 68 (let ((my-match
2cd0: 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 22 (string-match "
2ce0: 5e 28 5b 5e 25 5c 5c 2f 5d 2b 29 5c 5c 2f 2e 2b ^([^%\\/]+)\\/.+
2cf0: 24 22 20 74 65 73 74 70 61 74 74 2d 69 74 65 6d $" testpatt-item
2d00: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
2d10: 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 73 20 (cons
2d20: 74 65 73 74 70 61 74 74 2d 69 74 65 6d 0a 20 20 testpatt-item.
2d30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2d40: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 6d 79 (if my
2d50: 2d 6d 61 74 63 68 0a 20 20 20 20 20 20 20 20 20 -match.
2d60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2d70: 20 20 20 20 20 20 20 28 63 6f 6e 73 0a 20 20 20 (cons.
2d80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2d90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c
2da0: 6f 6e 63 20 28 63 61 64 72 20 6d 79 2d 6d 61 74 onc (cadr my-mat
2db0: 63 68 29 20 22 2f 22 29 0a 20 20 20 20 20 20 20 ch) "/").
2dc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2dd0: 20 20 20 20 20 20 20 20 20 20 61 63 63 75 6d 29 accum)
2de0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
2df0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2e00: 20 61 63 63 75 6d 29 29 29 29 0a 20 20 20 20 20 accum)))).
2e10: 20 20 20 20 20 20 20 20 20 20 20 20 20 27 28 29 '()
2e20: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
2e30: 20 20 20 65 78 74 65 6e 64 65 64 2d 74 65 73 74 extended-test
2e40: 2d 70 61 74 74 29 29 29 0a 20 20 20 20 20 20 28 -patt))). (
2e50: 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
2e60: 73 65 20 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 se (delete-dupli
2e70: 63 61 74 65 73 20 65 78 74 65 6e 64 65 64 2d 74 cates extended-t
2e80: 65 73 74 2d 70 61 74 74 2d 77 69 74 68 2d 74 6f est-patt-with-to
2e90: 70 6c 65 76 65 6c 73 29 20 22 2c 22 29 29 29 0a plevels) ","))).
2ea0: 20 20 20 28 65 6c 73 65 20 3b 3b 20 6e 6f 74 20 (else ;; not
2eb0: 77 61 69 74 69 6e 67 20 6f 6e 20 69 74 65 6d 73 waiting on items
2ec0: 2c 20 77 61 69 74 69 6e 67 20 6f 6e 20 65 6e 74 , waiting on ent
2ed0: 69 72 65 20 77 61 69 74 6f 6e 20 74 65 73 74 2e ire waiton test.
2ee0: 0a 20 20 20 20 28 6c 65 74 2a 20 28 28 70 61 74 . (let* ((pat
2ef0: 74 73 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 ts (string-split
2f00: 20 74 65 73 74 2d 70 61 74 74 20 22 2c 22 29 29 test-patt ","))
2f10: 0a 20 20 20 20 20 20 20 20 20 20 20 28 6e 65 77 . (new
2f20: 2d 70 61 74 74 73 20 28 69 66 20 28 6d 65 6d 62 -patts (if (memb
2f30: 65 72 20 77 61 69 74 6f 6e 2d 74 65 73 74 20 70 er waiton-test p
2f40: 61 74 74 73 29 0a 20 20 20 20 20 20 20 20 20 20 atts).
2f50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2f60: 70 61 74 74 73 0a 20 20 20 20 20 20 20 20 20 20 patts.
2f70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2f80: 28 63 6f 6e 73 20 77 61 69 74 6f 6e 2d 74 65 73 (cons waiton-tes
2f90: 74 20 70 61 74 74 73 29 29 29 29 0a 20 20 20 20 t patts)))).
2fa0: 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 (string-inters
2fb0: 70 65 72 73 65 20 28 64 65 6c 65 74 65 2d 64 75 perse (delete-du
2fc0: 70 6c 69 63 61 74 65 73 20 6e 65 77 2d 70 61 74 plicates new-pat
2fd0: 74 73 29 20 22 2c 22 29 29 29 29 29 0a 0a 28 64 ts) ",")))))..(d
2fe0: 65 66 69 6e 65 20 2a 67 6c 6f 62 2d 6c 69 6b 65 efine *glob-like
2ff0: 2d 6d 61 74 63 68 2d 63 61 63 68 65 2a 20 28 6d -match-cache* (m
3000: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
3010: 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a .(define (tests:
3020: 63 61 63 68 65 2d 72 65 67 65 78 70 20 73 74 72 cache-regexp str
3030: 2d 69 6e 20 66 6c 61 67 29 0a 20 20 28 6c 65 74 -in flag). (let
3040: 2a 20 28 28 6b 65 79 20 28 63 6f 6e 63 20 73 74 * ((key (conc st
3050: 72 2d 69 6e 20 66 6c 61 67 29 29 29 0a 20 20 20 r-in flag))).
3060: 20 28 6f 72 20 28 68 61 73 68 2d 74 61 62 6c 65 (or (hash-table
3070: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 67 6c -ref/default *gl
3080: 6f 62 2d 6c 69 6b 65 2d 6d 61 74 63 68 2d 63 61 ob-like-match-ca
3090: 63 68 65 2a 20 6b 65 79 20 23 66 29 0a 09 28 6c che* key #f)..(l
30a0: 65 74 2a 20 28 28 6e 65 77 72 78 20 28 72 65 67 et* ((newrx (reg
30b0: 65 78 70 20 73 74 72 2d 69 6e 20 66 6c 61 67 29 exp str-in flag)
30c0: 29 29 0a 09 20 20 28 68 61 73 68 2d 74 61 62 6c )).. (hash-tabl
30d0: 65 2d 73 65 74 21 20 2a 67 6c 6f 62 2d 6c 69 6b e-set! *glob-lik
30e0: 65 2d 6d 61 74 63 68 2d 63 61 63 68 65 2a 20 6b e-match-cache* k
30f0: 65 79 20 6e 65 77 72 78 29 0a 09 20 20 6e 65 77 ey newrx).. new
3100: 72 78 29 29 29 29 0a 0a 3b 3b 20 74 65 73 74 73 rx))))..;; tests
3110: 3a 67 6c 6f 62 2d 6c 69 6b 65 2d 6d 61 74 63 68 :glob-like-match
3120: 20 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 .(define (tests
3130: 3a 67 6c 6f 62 2d 6c 69 6b 65 2d 6d 61 74 63 68 :glob-like-match
3140: 20 70 61 74 74 20 73 74 72 29 20 0a 20 20 28 6c patt str) . (l
3150: 65 74 2a 20 28 28 6c 69 6b 65 20 20 20 20 20 28 et* ((like (
3160: 73 75 62 73 74 72 69 6e 67 2d 69 6e 64 65 78 20 substring-index
3170: 22 25 22 20 70 61 74 74 29 29 0a 09 20 28 6e 6f "%" patt)).. (no
3180: 74 70 61 74 74 20 20 28 65 71 75 61 6c 3f 20 28 tpatt (equal? (
3190: 73 75 62 73 74 72 69 6e 67 2d 69 6e 64 65 78 20 substring-index
31a0: 22 7e 22 20 70 61 74 74 29 20 30 29 29 0a 09 20 "~" patt) 0))..
31b0: 28 6e 65 77 70 61 74 74 20 20 28 69 66 20 6e 6f (newpatt (if no
31c0: 74 70 61 74 74 20 28 73 75 62 73 74 72 69 6e 67 tpatt (substring
31d0: 20 70 61 74 74 20 31 29 20 70 61 74 74 29 29 0a patt 1) patt)).
31e0: 09 20 28 66 69 6e 70 61 74 74 20 20 28 69 66 20 . (finpatt (if
31f0: 6c 69 6b 65 0a 09 09 20 20 20 20 20 20 20 28 73 like... (s
3200: 74 72 69 6e 67 2d 73 75 62 73 74 69 74 75 74 65 tring-substitute
3210: 20 28 72 65 67 65 78 70 20 22 25 22 29 20 22 2e (regexp "%") ".
3220: 2a 22 20 6e 65 77 70 61 74 74 20 23 66 29 0a 09 *" newpatt #f)..
3230: 09 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d . (string-
3240: 73 75 62 73 74 69 74 75 74 65 20 28 72 65 67 65 substitute (rege
3250: 78 70 20 22 5c 5c 2a 22 29 20 22 2e 2a 22 20 6e xp "\\*") ".*" n
3260: 65 77 70 61 74 74 20 23 66 29 29 29 0a 09 20 28 ewpatt #f))).. (
3270: 72 78 20 20 20 20 20 20 20 28 74 65 73 74 73 3a rx (tests:
3280: 63 61 63 68 65 2d 72 65 67 65 78 70 20 66 69 6e cache-regexp fin
3290: 70 61 74 74 20 28 69 66 20 6c 69 6b 65 20 23 74 patt (if like #t
32a0: 20 23 66 29 29 29 0a 09 20 28 72 65 73 20 20 20 #f))).. (res
32b0: 20 20 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 (string-match
32c0: 20 72 78 20 73 74 72 29 29 29 0a 20 20 20 20 28 rx str))). (
32d0: 69 66 20 6e 6f 74 70 61 74 74 20 28 6e 6f 74 20 if notpatt (not
32e0: 72 65 73 29 20 72 65 73 29 29 29 0a 0a 3b 3b 20 res) res)))..;;
32f0: 69 66 20 69 74 65 6d 70 61 74 68 20 69 73 20 23 if itempath is #
3300: 66 20 74 68 65 6e 20 6c 6f 6f 6b 20 6f 6e 6c 79 f then look only
3310: 20 61 74 20 74 68 65 20 74 65 73 74 6e 61 6d 65 at the testname
3320: 20 70 61 72 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 part.;;.(define
3330: 20 28 74 65 73 74 73 3a 6d 61 74 63 68 20 70 61 (tests:match pa
3340: 74 74 65 72 6e 73 20 74 65 73 74 6e 61 6d 65 20 tterns testname
3350: 69 74 65 6d 70 61 74 68 20 23 21 6b 65 79 20 28 itempath #!key (
3360: 72 65 71 75 69 72 65 64 20 27 28 29 29 29 0a 20 required '())).
3370: 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 70 61 (if (string? pa
3380: 74 74 65 72 6e 73 29 0a 20 20 20 20 20 20 28 6c tterns). (l
3390: 65 74 20 28 28 70 61 74 74 73 20 28 61 70 70 65 et ((patts (appe
33a0: 6e 64 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 nd (string-split
33b0: 20 70 61 74 74 65 72 6e 73 20 22 2c 22 29 20 72 patterns ",") r
33c0: 65 71 75 69 72 65 64 29 29 29 0a 09 28 69 66 20 equired)))..(if
33d0: 28 6e 75 6c 6c 3f 20 70 61 74 74 73 29 20 3b 3b (null? patts) ;;
33e0: 3b 20 6e 6f 20 70 61 74 74 65 72 6e 28 73 29 20 ; no pattern(s)
33f0: 6d 65 61 6e 73 20 6e 6f 20 6d 61 74 63 68 0a 09 means no match..
3400: 20 20 20 20 23 66 0a 09 20 20 20 20 28 6c 65 74 #f.. (let
3410: 20 6c 6f 6f 70 20 28 28 70 61 74 74 20 28 63 61 loop ((patt (ca
3420: 72 20 70 61 74 74 73 29 29 0a 09 09 20 20 20 20 r patts))...
3430: 20 20 20 28 74 61 6c 20 20 28 63 64 72 20 70 61 (tal (cdr pa
3440: 74 74 73 29 29 29 0a 09 20 20 20 20 20 20 3b 3b tts))).. ;;
3450: 20 28 70 72 69 6e 74 20 22 6c 6f 6f 70 3a 20 70 (print "loop: p
3460: 61 74 74 3a 20 22 20 70 61 74 74 20 22 2c 20 74 att: " patt ", t
3470: 61 6c 20 22 20 74 61 6c 29 0a 09 20 20 20 20 20 al " tal)..
3480: 20 28 69 66 20 28 73 74 72 69 6e 67 3d 3f 20 70 (if (string=? p
3490: 61 74 74 20 22 22 29 0a 09 09 20 20 23 66 20 3b att "")... #f ;
34a0: 3b 20 6e 6f 74 68 69 6e 67 20 65 76 65 72 20 6d ; nothing ever m
34b0: 61 74 63 68 65 73 20 65 6d 70 74 79 20 73 74 72 atches empty str
34c0: 69 6e 67 20 2d 20 70 6f 6c 69 63 79 0a 09 09 20 ing - policy...
34d0: 20 28 6c 65 74 2a 20 28 28 70 61 74 74 2d 70 61 (let* ((patt-pa
34e0: 72 74 73 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 rts (string-matc
34f0: 68 20 28 72 65 67 65 78 70 20 22 5e 28 5b 5e 5c h (regexp "^([^\
3500: 5c 2f 5d 2a 29 28 5c 5c 2f 28 2e 2a 29 7c 29 24 \/]*)(\\/(.*)|)$
3510: 22 29 20 70 61 74 74 29 29 0a 09 09 09 20 28 74 ") patt)).... (t
3520: 65 73 74 2d 70 61 74 74 20 20 28 63 61 64 72 20 est-patt (cadr
3530: 70 61 74 74 2d 70 61 72 74 73 29 29 0a 09 09 09 patt-parts))....
3540: 20 28 69 74 65 6d 2d 70 61 74 74 20 20 28 63 61 (item-patt (ca
3550: 64 64 64 72 20 70 61 74 74 2d 70 61 72 74 73 29 dddr patt-parts)
3560: 29 29 0a 09 09 20 20 20 20 3b 3b 20 73 70 65 63 ))... ;; spec
3570: 69 61 6c 20 63 61 73 65 3a 20 74 65 73 74 20 76 ial case: test v
3580: 73 2e 20 74 65 73 74 2f 0a 09 09 20 20 20 20 3b s. test/... ;
3590: 3b 20 20 20 74 65 73 74 20 20 3d 3e 20 22 74 65 ; test => "te
35a0: 73 74 22 20 22 25 22 0a 09 09 20 20 20 20 3b 3b st" "%"... ;;
35b0: 20 20 20 74 65 73 74 2f 20 3d 3e 20 22 74 65 73 test/ => "tes
35c0: 74 22 20 22 22 0a 09 09 20 20 20 20 28 69 66 20 t" ""... (if
35d0: 28 61 6e 64 20 28 6e 6f 74 20 28 73 75 62 73 74 (and (not (subst
35e0: 72 69 6e 67 2d 69 6e 64 65 78 20 22 2f 22 20 70 ring-index "/" p
35f0: 61 74 74 29 29 20 3b 3b 20 6e 6f 20 73 6c 61 73 att)) ;; no slas
3600: 68 20 69 6e 20 74 68 65 20 6f 72 69 67 69 6e 61 h in the origina
3610: 6c 0a 09 09 09 20 20 20 20 20 28 6f 72 20 28 6e l.... (or (n
3620: 6f 74 20 69 74 65 6d 2d 70 61 74 74 29 0a 09 09 ot item-patt)...
3630: 09 09 20 28 65 71 75 61 6c 3f 20 69 74 65 6d 2d .. (equal? item-
3640: 70 61 74 74 20 22 22 29 29 29 20 20 20 20 20 20 patt "")))
3650: 3b 3b 20 73 68 6f 75 6c 64 20 61 6c 77 61 79 73 ;; should always
3660: 20 62 65 20 74 72 75 65 20 74 68 61 74 20 69 74 be true that it
3670: 65 6d 2d 70 61 74 74 20 69 73 20 22 22 0a 09 09 em-patt is ""...
3680: 09 28 73 65 74 21 20 69 74 65 6d 2d 70 61 74 74 .(set! item-patt
3690: 20 22 25 22 29 29 0a 09 09 20 20 20 20 3b 3b 20 "%"))... ;;
36a0: 28 70 72 69 6e 74 20 22 74 65 73 74 73 3a 6d 61 (print "tests:ma
36b0: 74 63 68 20 3d 3e 20 70 61 74 74 2d 70 61 72 74 tch => patt-part
36c0: 73 3a 20 22 20 70 61 74 74 2d 70 61 72 74 73 20 s: " patt-parts
36d0: 22 2c 20 74 65 73 74 2d 70 61 74 74 3a 20 22 20 ", test-patt: "
36e0: 74 65 73 74 2d 70 61 74 74 20 22 2c 20 69 74 65 test-patt ", ite
36f0: 6d 2d 70 61 74 74 3a 20 22 20 69 74 65 6d 2d 70 m-patt: " item-p
3700: 61 74 74 29 0a 09 09 20 20 20 20 28 69 66 20 28 att)... (if (
3710: 61 6e 64 20 28 74 65 73 74 73 3a 67 6c 6f 62 2d and (tests:glob-
3720: 6c 69 6b 65 2d 6d 61 74 63 68 20 74 65 73 74 2d like-match test-
3730: 70 61 74 74 20 74 65 73 74 6e 61 6d 65 29 0a 09 patt testname)..
3740: 09 09 20 20 20 20 20 28 6f 72 20 28 6e 6f 74 20 .. (or (not
3750: 69 74 65 6d 70 61 74 68 29 0a 09 09 09 09 20 28 itempath)..... (
3760: 74 65 73 74 73 3a 67 6c 6f 62 2d 6c 69 6b 65 2d tests:glob-like-
3770: 6d 61 74 63 68 20 28 69 66 20 69 74 65 6d 2d 70 match (if item-p
3780: 61 74 74 20 69 74 65 6d 2d 70 61 74 74 20 22 22 att item-patt ""
3790: 29 20 69 74 65 6d 70 61 74 68 29 29 29 0a 09 09 ) itempath)))...
37a0: 09 23 74 0a 09 09 09 28 69 66 20 28 6e 75 6c 6c .#t....(if (null
37b0: 3f 20 74 61 6c 29 0a 09 09 09 20 20 20 20 23 66 ? tal).... #f
37c0: 0a 09 09 09 20 20 20 20 28 6c 6f 6f 70 20 28 63 .... (loop (c
37d0: 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 ar tal)(cdr tal)
37e0: 29 29 29 29 29 29 29 29 29 29 0a 0a 3b 3b 20 69 ))))))))))..;; i
37f0: 66 20 69 74 65 6d 70 61 74 68 20 69 73 20 23 66 f itempath is #f
3800: 20 74 68 65 6e 20 6c 6f 6f 6b 20 6f 6e 6c 79 20 then look only
3810: 61 74 20 74 68 65 20 74 65 73 74 6e 61 6d 65 20 at the testname
3820: 70 61 72 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 part.;;.(define
3830: 28 74 65 73 74 73 3a 6d 61 74 63 68 2d 3e 73 71 (tests:match->sq
3840: 6c 71 72 79 20 70 61 74 74 65 72 6e 73 29 0a 20 lqry patterns).
3850: 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 70 61 (if (string? pa
3860: 74 74 65 72 6e 73 29 0a 20 20 20 20 20 20 28 6c tterns). (l
3870: 65 74 20 28 28 70 61 74 74 73 20 28 73 74 72 69 et ((patts (stri
3880: 6e 67 2d 73 70 6c 69 74 20 70 61 74 74 65 72 6e ng-split pattern
3890: 73 20 22 2c 22 29 29 29 0a 09 28 69 66 20 28 6e s ",")))..(if (n
38a0: 75 6c 6c 3f 20 70 61 74 74 73 29 20 3b 3b 3b 20 ull? patts) ;;;
38b0: 6e 6f 20 70 61 74 74 65 72 6e 28 73 29 20 6d 65 no pattern(s) me
38c0: 61 6e 73 20 6e 6f 20 6d 61 74 63 68 2c 20 77 65 ans no match, we
38d0: 20 77 69 6c 6c 20 64 6f 20 6e 6f 20 71 75 65 72 will do no quer
38e0: 79 0a 09 20 20 20 20 23 66 0a 09 20 20 20 20 28 y.. #f.. (
38f0: 6c 65 74 20 6c 6f 6f 70 20 28 28 70 61 74 74 20 let loop ((patt
3900: 28 63 61 72 20 70 61 74 74 73 29 29 0a 09 09 20 (car patts))...
3910: 20 20 20 20 20 20 28 74 61 6c 20 20 28 63 64 72 (tal (cdr
3920: 20 70 61 74 74 73 29 29 0a 09 09 20 20 20 20 20 patts))...
3930: 20 20 28 72 65 73 20 20 27 28 29 29 29 0a 09 20 (res '()))..
3940: 20 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 ;; (print "
3950: 6c 6f 6f 70 3a 20 70 61 74 74 3a 20 22 20 70 61 loop: patt: " pa
3960: 74 74 20 22 2c 20 74 61 6c 20 22 20 74 61 6c 29 tt ", tal " tal)
3970: 0a 09 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 .. (let* ((
3980: 70 61 74 74 2d 70 61 72 74 73 20 28 73 74 72 69 patt-parts (stri
3990: 6e 67 2d 6d 61 74 63 68 20 28 72 65 67 65 78 70 ng-match (regexp
39a0: 20 22 5e 28 5b 5e 5c 5c 2f 5d 2a 29 28 5c 5c 2f "^([^\\/]*)(\\/
39b0: 28 2e 2a 29 7c 29 24 22 29 20 70 61 74 74 29 29 (.*)|)$") patt))
39c0: 0a 09 09 20 20 20 20 20 28 74 65 73 74 2d 70 61 ... (test-pa
39d0: 74 74 20 20 28 63 61 64 72 20 70 61 74 74 2d 70 tt (cadr patt-p
39e0: 61 72 74 73 29 29 0a 09 09 20 20 20 20 20 28 69 arts))... (i
39f0: 74 65 6d 2d 70 61 74 74 20 20 28 63 61 64 64 64 tem-patt (caddd
3a00: 72 20 70 61 74 74 2d 70 61 72 74 73 29 29 0a 09 r patt-parts))..
3a10: 09 20 20 20 20 20 28 74 65 73 74 2d 71 72 79 20 . (test-qry
3a20: 20 20 28 64 62 3a 70 61 74 74 2d 3e 6c 69 6b 65 (db:patt->like
3a30: 20 22 74 65 73 74 6e 61 6d 65 22 20 74 65 73 74 "testname" test
3a40: 2d 70 61 74 74 29 29 0a 09 09 20 20 20 20 20 28 -patt))... (
3a50: 69 74 65 6d 2d 71 72 79 20 20 20 28 64 62 3a 70 item-qry (db:p
3a60: 61 74 74 2d 3e 6c 69 6b 65 20 22 69 74 65 6d 5f att->like "item_
3a70: 70 61 74 68 22 20 69 74 65 6d 2d 70 61 74 74 29 path" item-patt)
3a80: 29 0a 09 09 20 20 20 20 20 28 71 72 79 20 20 20 )... (qry
3a90: 20 20 20 20 20 28 63 6f 6e 63 20 22 28 22 20 74 (conc "(" t
3aa0: 65 73 74 2d 71 72 79 20 22 20 41 4e 44 20 22 20 est-qry " AND "
3ab0: 69 74 65 6d 2d 71 72 79 20 22 29 22 29 29 29 0a item-qry ")"))).
3ac0: 09 09 3b 3b 20 28 70 72 69 6e 74 20 22 74 65 73 ..;; (print "tes
3ad0: 74 73 3a 6d 61 74 63 68 20 3d 3e 20 70 61 74 74 ts:match => patt
3ae0: 2d 70 61 72 74 73 3a 20 22 20 70 61 74 74 2d 70 -parts: " patt-p
3af0: 61 72 74 73 20 22 2c 20 74 65 73 74 2d 70 61 74 arts ", test-pat
3b00: 74 3a 20 22 20 74 65 73 74 2d 70 61 74 74 20 22 t: " test-patt "
3b10: 2c 20 69 74 65 6d 2d 70 61 74 74 3a 20 22 20 69 , item-patt: " i
3b20: 74 65 6d 2d 70 61 74 74 29 0a 09 09 28 69 66 20 tem-patt)...(if
3b30: 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 20 20 (null? tal)...
3b40: 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 (string-inters
3b50: 70 65 72 73 65 20 28 61 70 70 65 6e 64 20 28 72 perse (append (r
3b60: 65 76 65 72 73 65 20 72 65 73 29 28 6c 69 73 74 everse res)(list
3b70: 20 71 72 79 29 29 20 22 20 4f 52 20 22 29 0a 09 qry)) " OR ")..
3b80: 09 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 . (loop (car
3b90: 74 61 6c 29 28 63 64 72 20 74 61 6c 29 28 63 6f tal)(cdr tal)(co
3ba0: 6e 73 20 71 72 79 20 72 65 73 29 29 29 29 29 29 ns qry res))))))
3bb0: 29 0a 20 20 20 20 20 20 23 66 29 29 0a 0a 3b 3b ). #f))..;;
3bc0: 20 43 68 65 63 6b 20 66 6f 72 20 77 61 69 76 65 Check for waive
3bd0: 72 20 65 6c 69 67 69 62 69 6c 69 74 79 0a 3b 3b r eligibility.;;
3be0: 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a .(define (tests:
3bf0: 63 68 65 63 6b 2d 77 61 69 76 65 72 2d 65 6c 69 check-waiver-eli
3c00: 67 69 62 69 6c 69 74 79 20 74 65 73 74 64 61 74 gibility testdat
3c10: 20 70 72 65 76 2d 74 65 73 74 64 61 74 29 0a 20 prev-testdat).
3c20: 20 28 6c 65 74 2a 20 28 28 74 65 73 74 2d 72 65 (let* ((test-re
3c30: 67 69 73 74 72 79 20 28 6d 61 6b 65 2d 68 61 73 gistry (make-has
3c40: 68 2d 74 61 62 6c 65 29 29 0a 09 20 28 74 65 73 h-table)).. (tes
3c50: 74 63 6f 6e 66 69 67 20 20 28 74 65 73 74 73 3a tconfig (tests:
3c60: 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 28 get-testconfig (
3c70: 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 db:test-get-test
3c80: 6e 61 6d 65 20 74 65 73 74 64 61 74 29 20 28 64 name testdat) (d
3c90: 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d b:test-get-item-
3ca0: 70 61 74 68 20 74 65 73 74 64 61 74 29 20 74 65 path testdat) te
3cb0: 73 74 2d 72 65 67 69 73 74 72 79 20 23 66 29 29 st-registry #f))
3cc0: 0a 09 20 28 74 65 73 74 2d 72 75 6e 64 69 72 20 .. (test-rundir
3cd0: 3b 3b 20 28 73 64 62 3a 71 72 79 20 27 70 61 73 ;; (sdb:qry 'pas
3ce0: 73 73 74 72 20 0a 09 20 20 28 64 62 3a 74 65 73 sstr .. (db:tes
3cf0: 74 2d 67 65 74 2d 72 75 6e 64 69 72 20 74 65 73 t-get-rundir tes
3d00: 74 64 61 74 29 29 20 3b 3b 20 29 0a 09 20 28 70 tdat)) ;; ).. (p
3d10: 72 65 76 2d 72 75 6e 64 69 72 20 3b 3b 20 28 73 rev-rundir ;; (s
3d20: 64 62 3a 71 72 79 20 27 70 61 73 73 73 74 72 20 db:qry 'passstr
3d30: 0a 09 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 .. (db:test-get
3d40: 2d 72 75 6e 64 69 72 20 70 72 65 76 2d 74 65 73 -rundir prev-tes
3d50: 74 64 61 74 29 29 20 3b 3b 20 29 0a 09 20 28 77 tdat)) ;; ).. (w
3d60: 61 69 76 65 72 73 20 20 20 20 20 28 69 66 20 74 aivers (if t
3d70: 65 73 74 63 6f 6e 66 69 67 20 28 63 6f 6e 66 69 estconfig (confi
3d80: 67 66 3a 73 65 63 74 69 6f 6e 2d 76 61 72 73 20 gf:section-vars
3d90: 74 65 73 74 63 6f 6e 66 69 67 20 22 77 61 69 76 testconfig "waiv
3da0: 65 72 73 22 29 20 27 28 29 29 29 0a 09 20 28 77 ers") '())).. (w
3db0: 61 69 76 65 72 2d 72 78 20 20 20 28 72 65 67 65 aiver-rx (rege
3dc0: 78 70 20 22 5e 28 5c 5c 53 2b 29 5c 5c 73 2b 28 xp "^(\\S+)\\s+(
3dd0: 2e 2a 29 24 22 29 29 0a 09 20 28 64 69 66 66 2d .*)$")).. (diff-
3de0: 72 75 6c 65 20 20 20 22 64 69 66 66 20 25 66 69 rule "diff %fi
3df0: 6c 65 31 25 20 25 66 69 6c 65 32 25 22 29 0a 09 le1% %file2%")..
3e00: 20 28 6c 6f 67 70 72 6f 2d 72 75 6c 65 20 22 64 (logpro-rule "d
3e10: 69 66 66 20 25 66 69 6c 65 31 25 20 25 66 69 6c iff %file1% %fil
3e20: 65 32 25 20 7c 20 6c 6f 67 70 72 6f 20 25 77 61 e2% | logpro %wa
3e30: 69 76 65 72 6e 61 6d 65 25 2e 6c 6f 67 70 72 6f ivername%.logpro
3e40: 20 25 77 61 69 76 65 72 6e 61 6d 65 25 2e 68 74 %waivername%.ht
3e50: 6d 6c 22 29 29 0a 20 20 20 20 28 69 66 20 28 6e ml")). (if (n
3e60: 6f 74 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d ot (common:file-
3e70: 65 78 69 73 74 73 3f 20 74 65 73 74 2d 72 75 6e exists? test-run
3e80: 64 69 72 29 29 0a 09 28 62 65 67 69 6e 0a 09 20 dir))..(begin..
3e90: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 (debug:print-er
3ea0: 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c ror 0 *default-l
3eb0: 6f 67 2d 70 6f 72 74 2a 20 22 74 65 73 74 20 72 og-port* "test r
3ec0: 75 6e 20 64 69 72 65 63 74 6f 72 79 20 69 73 20 un directory is
3ed0: 67 6f 6e 65 2c 20 63 61 6e 6e 6f 74 20 70 72 6f gone, cannot pro
3ee0: 70 61 67 61 74 65 20 77 61 69 76 65 72 22 29 0a pagate waiver").
3ef0: 09 20 20 23 66 29 0a 09 28 62 65 67 69 6e 0a 09 . #f)..(begin..
3f00: 20 20 28 70 75 73 68 2d 64 69 72 65 63 74 6f 72 (push-director
3f10: 79 20 74 65 73 74 2d 72 75 6e 64 69 72 29 0a 09 y test-rundir)..
3f20: 20 20 28 6c 65 74 20 28 28 72 65 73 75 6c 74 20 (let ((result
3f30: 28 69 66 20 28 6e 75 6c 6c 3f 20 77 61 69 76 65 (if (null? waive
3f40: 72 73 29 0a 09 09 09 20 20 20 20 23 66 0a 09 09 rs).... #f...
3f50: 09 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 . (let loop (
3f60: 28 68 65 64 20 28 63 61 72 20 77 61 69 76 65 72 (hed (car waiver
3f70: 73 29 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 s))..... (
3f80: 74 61 6c 20 28 63 64 72 20 77 61 69 76 65 72 73 tal (cdr waivers
3f90: 29 29 29 0a 09 09 09 20 20 20 20 20 20 28 64 65 ))).... (de
3fa0: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
3fb0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
3fc0: 49 4e 46 4f 3a 20 41 70 70 6c 79 69 6e 67 20 77 INFO: Applying w
3fd0: 61 69 76 65 72 20 72 75 6c 65 20 5c 22 22 20 68 aiver rule \"" h
3fe0: 65 64 20 22 5c 22 22 29 0a 09 09 09 20 20 20 20 ed "\"")....
3ff0: 20 20 28 6c 65 74 2a 20 28 28 77 61 69 76 65 72 (let* ((waiver
4000: 20 20 20 20 20 20 28 63 6f 6e 66 69 67 66 3a 6c (configf:l
4010: 6f 6f 6b 75 70 20 74 65 73 74 63 6f 6e 66 69 67 ookup testconfig
4020: 20 22 77 61 69 76 65 72 73 22 20 68 65 64 29 29 "waivers" hed))
4030: 0a 09 09 09 09 20 20 20 20 20 28 77 70 61 72 74 ..... (wpart
4040: 73 20 20 20 20 20 20 28 69 66 20 77 61 69 76 65 s (if waive
4050: 72 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 r (string-match
4060: 77 61 69 76 65 72 2d 72 78 20 77 61 69 76 65 72 waiver-rx waiver
4070: 29 20 23 66 29 29 0a 09 09 09 09 20 20 20 20 20 ) #f)).....
4080: 28 77 61 69 76 65 72 2d 72 75 6c 65 20 28 69 66 (waiver-rule (if
4090: 20 77 70 61 72 74 73 20 28 63 61 64 72 20 77 70 wparts (cadr wp
40a0: 61 72 74 73 29 20 20 23 66 29 29 0a 09 09 09 09 arts) #f)).....
40b0: 20 20 20 20 20 28 77 61 69 76 65 72 2d 67 6c 6f (waiver-glo
40c0: 62 20 28 69 66 20 77 70 61 72 74 73 20 28 63 61 b (if wparts (ca
40d0: 64 64 72 20 77 70 61 72 74 73 29 20 23 66 29 29 ddr wparts) #f))
40e0: 0a 09 09 09 09 20 20 20 20 20 28 6c 6f 67 70 72 ..... (logpr
40f0: 6f 2d 66 69 6c 65 20 28 69 66 20 77 61 69 76 65 o-file (if waive
4100: 72 0a 09 09 09 09 09 09 20 20 20 20 20 20 28 6c r....... (l
4110: 65 74 20 28 28 66 6e 61 6d 65 20 28 63 6f 6e 63 et ((fname (conc
4120: 20 68 65 64 20 22 2e 6c 6f 67 70 72 6f 22 29 29 hed ".logpro"))
4130: 29 0a 09 09 09 09 09 09 09 28 69 66 20 28 63 6f )........(if (co
4140: 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 mmon:file-exists
4150: 3f 20 66 6e 61 6d 65 29 0a 09 09 09 09 09 09 09 ? fname)........
4160: 20 20 20 20 66 6e 61 6d 65 20 0a 09 09 09 09 09 fname ......
4170: 09 09 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 .. (begin....
4180: 09 09 09 09 20 20 20 20 20 20 28 64 65 62 75 67 .... (debug
4190: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
41a0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 4e 46 t-log-port* "INF
41b0: 4f 3a 20 4e 6f 20 6c 6f 67 70 72 6f 20 66 69 6c O: No logpro fil
41c0: 65 20 22 20 66 6e 61 6d 65 20 22 20 66 61 6c 6c e " fname " fall
41d0: 69 6e 67 20 62 61 63 6b 20 74 6f 20 64 69 66 66 ing back to diff
41e0: 22 29 0a 09 09 09 09 09 09 09 20 20 20 20 20 20 ")........
41f0: 23 66 29 29 29 0a 09 09 09 09 09 09 20 20 20 20 #f))).......
4200: 20 20 23 66 29 29 0a 09 09 09 09 20 20 20 20 20 #f)).....
4210: 3b 3b 20 69 66 20 72 75 6c 65 20 62 79 20 6e 61 ;; if rule by na
4220: 6d 65 20 6f 66 20 77 61 69 76 65 72 2d 72 75 6c me of waiver-rul
4230: 65 20 69 73 20 66 6f 75 6e 64 20 69 6e 20 74 65 e is found in te
4240: 73 74 63 6f 6e 66 69 67 20 2d 20 75 73 65 20 69 stconfig - use i
4250: 74 0a 09 09 09 09 20 20 20 20 20 3b 3b 20 65 6c t..... ;; el
4260: 73 65 20 69 66 20 77 61 69 76 65 72 6e 61 6d 65 se if waivername
4270: 2e 6c 6f 67 70 72 6f 20 65 78 69 73 74 73 20 75 .logpro exists u
4280: 73 65 20 6c 6f 67 70 72 6f 2d 72 75 6c 65 0a 09 se logpro-rule..
4290: 09 09 09 20 20 20 20 20 3b 3b 20 65 6c 73 65 20 ... ;; else
42a0: 64 65 66 61 75 6c 74 20 74 6f 20 64 69 66 66 2d default to diff-
42b0: 72 75 6c 65 0a 09 09 09 09 20 20 20 20 20 28 72 rule..... (r
42c0: 75 6c 65 2d 73 74 72 69 6e 67 20 28 6c 65 74 20 ule-string (let
42d0: 28 28 72 75 6c 65 20 28 63 6f 6e 66 69 67 66 3a ((rule (configf:
42e0: 6c 6f 6f 6b 75 70 20 74 65 73 74 63 6f 6e 66 69 lookup testconfi
42f0: 67 20 22 77 61 69 76 65 72 5f 72 75 6c 65 73 22 g "waiver_rules"
4300: 20 77 61 69 76 65 72 2d 72 75 6c 65 29 29 29 0a waiver-rule))).
4310: 09 09 09 09 09 09 20 20 20 20 28 69 66 20 72 75 ...... (if ru
4320: 6c 65 0a 09 09 09 09 09 09 09 72 75 6c 65 0a 09 le........rule..
4330: 09 09 09 09 09 09 28 69 66 20 6c 6f 67 70 72 6f ......(if logpro
4340: 2d 66 69 6c 65 0a 09 09 09 09 09 09 09 20 20 20 -file........
4350: 20 6c 6f 67 70 72 6f 2d 72 75 6c 65 0a 09 09 09 logpro-rule....
4360: 09 09 09 09 20 20 20 20 28 62 65 67 69 6e 0a 09 .... (begin..
4370: 09 09 09 09 09 09 20 20 20 20 20 20 28 64 65 62 ...... (deb
4380: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
4390: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 ult-log-port* "I
43a0: 4e 46 4f 3a 20 4e 6f 20 6c 6f 67 70 72 6f 20 66 NFO: No logpro f
43b0: 69 6c 65 20 22 20 6c 6f 67 70 72 6f 2d 66 69 6c ile " logpro-fil
43c0: 65 20 22 20 66 6f 75 6e 64 2c 20 75 73 69 6e 67 e " found, using
43d0: 20 64 69 66 66 20 72 75 6c 65 22 29 0a 09 09 09 diff rule")....
43e0: 09 09 09 09 20 20 20 20 20 20 64 69 66 66 2d 72 .... diff-r
43f0: 75 6c 65 29 29 29 29 29 0a 09 09 09 09 20 20 20 ule))))).....
4400: 20 20 3b 3b 20 28 73 74 72 69 6e 67 2d 73 75 62 ;; (string-sub
4410: 73 74 69 74 75 74 65 20 22 25 66 69 6c 65 31 25 stitute "%file1%
4420: 22 20 22 66 6f 6f 66 6f 6f 2e 74 78 74 22 20 22 " "foofoo.txt" "
4430: 54 68 69 73 20 69 73 20 25 66 69 6c 65 31 25 20 This is %file1%
4440: 61 6e 64 20 73 6f 20 69 73 20 74 68 69 73 20 25 and so is this %
4450: 66 69 6c 65 31 25 2e 22 20 23 74 29 0a 09 09 09 file1%." #t)....
4460: 09 20 20 20 20 20 28 70 72 6f 63 65 73 73 65 64 . (processed
4470: 2d 63 6d 64 20 28 73 74 72 69 6e 67 2d 73 75 62 -cmd (string-sub
4480: 73 74 69 74 75 74 65 20 0a 09 09 09 09 09 09 20 stitute .......
4490: 20 20 20 20 22 25 66 69 6c 65 31 25 22 20 28 63 "%file1%" (c
44a0: 6f 6e 63 20 74 65 73 74 2d 72 75 6e 64 69 72 20 onc test-rundir
44b0: 22 2f 22 20 77 61 69 76 65 72 2d 67 6c 6f 62 29 "/" waiver-glob)
44c0: 0a 09 09 09 09 09 09 20 20 20 20 20 28 73 74 72 ....... (str
44d0: 69 6e 67 2d 73 75 62 73 74 69 74 75 74 65 0a 09 ing-substitute..
44e0: 09 09 09 09 09 20 20 20 20 20 20 22 25 66 69 6c ..... "%fil
44f0: 65 32 25 22 20 28 63 6f 6e 63 20 70 72 65 76 2d e2%" (conc prev-
4500: 72 75 6e 64 69 72 20 22 2f 22 20 77 61 69 76 65 rundir "/" waive
4510: 72 2d 67 6c 6f 62 29 0a 09 09 09 09 09 09 20 20 r-glob).......
4520: 20 20 20 20 28 73 74 72 69 6e 67 2d 73 75 62 73 (string-subs
4530: 74 69 74 75 74 65 0a 09 09 09 09 09 09 20 20 20 titute.......
4540: 20 20 20 20 22 25 77 61 69 76 65 72 6e 61 6d 65 "%waivername
4550: 25 22 20 68 65 64 20 72 75 6c 65 2d 73 74 72 69 %" hed rule-stri
4560: 6e 67 20 23 74 29 20 23 74 29 20 23 74 29 29 0a ng #t) #t) #t)).
4570: 09 09 09 09 20 20 20 20 20 28 72 65 73 20 20 20 .... (res
4580: 20 20 20 20 20 20 20 20 20 23 66 29 29 0a 09 09 #f))...
4590: 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 ..(debug:print 0
45a0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
45b0: 72 74 2a 20 22 49 4e 46 4f 3a 20 77 61 69 76 65 rt* "INFO: waive
45c0: 72 20 63 6f 6d 6d 61 6e 64 20 69 73 20 5c 22 22 r command is \""
45d0: 20 70 72 6f 63 65 73 73 65 64 2d 63 6d 64 20 22 processed-cmd "
45e0: 5c 22 22 29 0a 09 09 09 09 28 69 66 20 28 65 71 \"").....(if (eq
45f0: 3f 20 28 73 79 73 74 65 6d 20 70 72 6f 63 65 73 ? (system proces
4600: 73 65 64 2d 63 6d 64 29 20 30 29 0a 09 09 09 09 sed-cmd) 0).....
4610: 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 (if (null? t
4620: 61 6c 29 0a 09 09 09 09 09 23 74 0a 09 09 09 09 al)......#t.....
4630: 09 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 .(loop (car tal)
4640: 28 63 64 72 20 74 61 6c 29 29 29 0a 09 09 09 09 (cdr tal))).....
4650: 20 20 20 20 23 66 29 29 29 29 29 29 0a 09 20 20 #f))))))..
4660: 20 20 28 70 6f 70 2d 64 69 72 65 63 74 6f 72 79 (pop-directory
4670: 29 0a 09 20 20 20 20 72 65 73 75 6c 74 29 29 29 ).. result)))
4680: 29 29 0a 0a 3b 3b 20 44 6f 20 6e 6f 74 20 72 70 ))..;; Do not rp
4690: 63 20 74 68 69 73 20 6f 6e 65 2c 20 64 6f 20 74 c this one, do t
46a0: 68 65 20 75 6e 64 65 72 6c 79 69 6e 67 20 63 61 he underlying ca
46b0: 6c 6c 73 21 21 21 0a 28 64 65 66 69 6e 65 20 28 lls!!!.(define (
46c0: 74 65 73 74 73 3a 74 65 73 74 2d 73 65 74 2d 73 tests:test-set-s
46d0: 74 61 74 75 73 21 20 72 75 6e 2d 69 64 20 74 65 tatus! run-id te
46e0: 73 74 2d 69 64 20 73 74 61 74 65 20 73 74 61 74 st-id state stat
46f0: 75 73 20 63 6f 6d 6d 65 6e 74 20 64 61 74 20 23 us comment dat #
4700: 21 6b 65 79 20 28 77 6f 72 6b 2d 61 72 65 61 20 !key (work-area
4710: 23 66 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 72 #f)). (let* ((r
4720: 65 61 6c 2d 73 74 61 74 75 73 20 73 74 61 74 75 eal-status statu
4730: 73 29 0a 09 20 28 6f 74 68 65 72 64 61 74 20 20 s).. (otherdat
4740: 20 20 28 69 66 20 64 61 74 20 64 61 74 20 28 6d (if dat dat (m
4750: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
4760: 29 0a 09 20 28 74 65 73 74 64 61 74 20 20 20 20 ).. (testdat
4770: 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 (rmt:get-test-i
4780: 6e 66 6f 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 nfo-by-id run-id
4790: 20 74 65 73 74 2d 69 64 29 29 0a 09 20 28 74 65 test-id)).. (te
47a0: 73 74 2d 6e 61 6d 65 20 20 20 28 64 62 3a 74 65 st-name (db:te
47b0: 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 st-get-testname
47c0: 20 74 65 73 74 64 61 74 29 29 0a 09 20 28 69 74 testdat)).. (it
47d0: 65 6d 2d 70 61 74 68 20 20 20 28 64 62 3a 74 65 em-path (db:te
47e0: 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 st-get-item-path
47f0: 20 74 65 73 74 64 61 74 29 29 0a 09 20 3b 3b 20 testdat)).. ;;
4800: 62 65 66 6f 72 65 20 70 72 6f 63 65 65 64 69 6e before proceedin
4810: 67 20 77 65 20 6d 75 73 74 20 66 69 6e 64 20 6f g we must find o
4820: 75 74 20 69 66 20 74 68 65 20 70 72 65 76 69 6f ut if the previo
4830: 75 73 20 74 65 73 74 20 28 77 68 65 72 65 20 61 us test (where a
4840: 6c 6c 20 6b 65 79 73 20 6d 61 74 63 68 65 64 20 ll keys matched
4850: 65 78 63 65 70 74 20 72 75 6e 6e 61 6d 65 29 0a except runname).
4860: 09 20 3b 3b 20 77 61 73 20 57 41 49 56 45 44 20 . ;; was WAIVED
4870: 69 66 20 74 68 69 73 20 74 65 73 74 20 69 73 20 if this test is
4880: 46 41 49 4c 0a 0a 09 20 3b 3b 20 4e 4f 54 45 53 FAIL... ;; NOTES
4890: 3a 0a 09 20 3b 3b 20 20 31 2e 20 49 73 20 74 68 :.. ;; 1. Is th
48a0: 65 20 63 61 6c 6c 20 74 6f 20 74 65 73 74 3a 67 e call to test:g
48b0: 65 74 2d 70 72 65 76 69 6f 75 73 2d 72 75 6e 2d et-previous-run-
48c0: 72 65 63 6f 72 64 20 72 65 6d 6f 74 69 66 69 65 record remotifie
48d0: 64 3f 0a 09 20 3b 3b 20 20 32 2e 20 41 64 64 20 d?.. ;; 2. Add
48e0: 74 65 73 74 20 66 6f 72 20 74 65 73 74 63 6f 6e test for testcon
48f0: 66 69 67 20 77 61 69 76 65 72 20 70 72 6f 70 61 fig waiver propa
4900: 67 61 74 69 6f 6e 20 63 6f 6e 74 72 6f 6c 20 68 gation control h
4910: 65 72 65 0a 09 20 3b 3b 0a 09 20 28 70 72 65 76 ere.. ;;.. (prev
4920: 2d 74 65 73 74 20 20 20 28 69 66 20 28 65 71 75 -test (if (equ
4930: 61 6c 3f 20 73 74 61 74 75 73 20 22 46 41 49 4c al? status "FAIL
4940: 22 29 0a 09 09 09 20 20 28 72 6d 74 3a 67 65 74 ").... (rmt:get
4950: 2d 70 72 65 76 69 6f 75 73 2d 74 65 73 74 2d 72 -previous-test-r
4960: 75 6e 2d 72 65 63 6f 72 64 20 72 75 6e 2d 69 64 un-record run-id
4970: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item-
4980: 70 61 74 68 29 0a 09 09 09 20 20 23 66 29 29 0a path).... #f)).
4990: 09 20 28 77 61 69 76 65 64 20 20 20 28 69 66 20 . (waived (if
49a0: 70 72 65 76 2d 74 65 73 74 0a 09 09 20 20 20 20 prev-test...
49b0: 20 20 20 28 69 66 20 70 72 65 76 2d 74 65 73 74 (if prev-test
49c0: 20 3b 3b 20 74 72 75 65 20 69 66 20 77 65 20 66 ;; true if we f
49d0: 6f 75 6e 64 20 61 20 70 72 65 76 69 6f 75 73 20 ound a previous
49e0: 74 65 73 74 20 69 6e 20 74 68 69 73 20 72 75 6e test in this run
49f0: 20 73 65 72 69 65 73 0a 09 09 09 20 20 20 28 6c series.... (l
4a00: 65 74 20 28 28 70 72 65 76 2d 73 74 61 74 75 73 et ((prev-status
4a10: 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 (db:test-get-s
4a20: 74 61 74 75 73 20 20 70 72 65 76 2d 74 65 73 74 tatus prev-test
4a30: 29 29 0a 09 09 09 09 20 28 70 72 65 76 2d 73 74 ))..... (prev-st
4a40: 61 74 65 20 20 20 28 64 62 3a 74 65 73 74 2d 67 ate (db:test-g
4a50: 65 74 2d 73 74 61 74 65 20 20 20 70 72 65 76 2d et-state prev-
4a60: 74 65 73 74 29 29 0a 09 09 09 09 20 28 70 72 65 test))..... (pre
4a70: 76 2d 63 6f 6d 6d 65 6e 74 20 28 64 62 3a 74 65 v-comment (db:te
4a80: 73 74 2d 67 65 74 2d 63 6f 6d 6d 65 6e 74 20 70 st-get-comment p
4a90: 72 65 76 2d 74 65 73 74 29 29 29 0a 09 09 09 20 rev-test)))....
4aa0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
4ab0: 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 4 *default-log-
4ac0: 70 6f 72 74 2a 20 22 70 72 65 76 2d 73 74 61 74 port* "prev-stat
4ad0: 75 73 20 22 20 70 72 65 76 2d 73 74 61 74 75 73 us " prev-status
4ae0: 20 22 2c 20 70 72 65 76 2d 73 74 61 74 65 20 22 ", prev-state "
4af0: 20 70 72 65 76 2d 73 74 61 74 65 20 22 2c 20 70 prev-state ", p
4b00: 72 65 76 2d 63 6f 6d 6d 65 6e 74 20 22 20 70 72 rev-comment " pr
4b10: 65 76 2d 63 6f 6d 6d 65 6e 74 29 0a 09 09 09 20 ev-comment)....
4b20: 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 65 71 (if (and (eq
4b30: 75 61 6c 3f 20 70 72 65 76 2d 73 74 61 74 65 20 ual? prev-state
4b40: 20 22 43 4f 4d 50 4c 45 54 45 44 22 29 0a 09 09 "COMPLETED")...
4b50: 09 09 20 20 20 20 20 20 28 65 71 75 61 6c 3f 20 .. (equal?
4b60: 70 72 65 76 2d 73 74 61 74 75 73 20 22 57 41 49 prev-status "WAI
4b70: 56 45 44 22 29 29 0a 09 09 09 09 20 28 69 66 20 VED"))..... (if
4b80: 63 6f 6d 6d 65 6e 74 0a 09 09 09 09 20 20 20 20 comment.....
4b90: 20 63 6f 6d 6d 65 6e 74 0a 09 09 09 09 20 20 20 comment.....
4ba0: 20 20 70 72 65 76 2d 63 6f 6d 6d 65 6e 74 29 20 prev-comment)
4bb0: 3b 3b 20 77 61 69 76 65 64 20 69 73 20 65 69 74 ;; waived is eit
4bc0: 68 65 72 20 74 68 65 20 63 6f 6d 6d 65 6e 74 20 her the comment
4bd0: 6f 72 20 23 66 0a 09 09 09 09 20 23 66 29 29 0a or #f..... #f)).
4be0: 09 09 09 20 20 20 23 66 29 0a 09 09 20 20 20 20 ... #f)...
4bf0: 20 20 20 23 66 29 29 29 0a 20 20 20 20 28 69 66 #f))). (if
4c00: 20 28 61 6e 64 20 77 61 69 76 65 64 20 0a 09 20 (and waived ..
4c10: 20 20 20 20 28 74 65 73 74 73 3a 63 68 65 63 6b (tests:check
4c20: 2d 77 61 69 76 65 72 2d 65 6c 69 67 69 62 69 6c -waiver-eligibil
4c30: 69 74 79 20 74 65 73 74 64 61 74 20 70 72 65 76 ity testdat prev
4c40: 2d 74 65 73 74 29 29 0a 09 28 73 65 74 21 20 72 -test))..(set! r
4c50: 65 61 6c 2d 73 74 61 74 75 73 20 22 57 41 49 56 eal-status "WAIV
4c60: 45 44 22 29 29 0a 0a 20 20 20 20 28 64 65 62 75 ED")).. (debu
4c70: 67 3a 70 72 69 6e 74 20 34 20 2a 64 65 66 61 75 g:print 4 *defau
4c80: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 65 lt-log-port* "re
4c90: 61 6c 2d 73 74 61 74 75 73 20 22 20 72 65 61 6c al-status " real
4ca0: 2d 73 74 61 74 75 73 20 22 2c 20 77 61 69 76 65 -status ", waive
4cb0: 64 20 22 20 77 61 69 76 65 64 20 22 2c 20 73 74 d " waived ", st
4cc0: 61 74 75 73 20 22 20 73 74 61 74 75 73 29 0a 0a atus " status)..
4cd0: 20 20 20 20 3b 3b 20 75 70 64 61 74 65 20 74 68 ;; update th
4ce0: 65 20 70 72 69 6d 61 72 79 20 72 65 63 6f 72 64 e primary record
4cf0: 20 49 46 20 73 74 61 74 65 20 41 4e 44 20 73 74 IF state AND st
4d00: 61 74 75 73 20 61 72 65 20 64 65 66 69 6e 65 64 atus are defined
4d10: 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 73 74 . (if (and st
4d20: 61 74 65 20 73 74 61 74 75 73 29 0a 09 28 62 65 ate status)..(be
4d30: 67 69 6e 0a 09 20 20 28 72 6d 74 3a 73 65 74 2d gin.. (rmt:set-
4d40: 73 74 61 74 65 2d 73 74 61 74 75 73 2d 61 6e 64 state-status-and
4d50: 2d 72 6f 6c 6c 2d 75 70 2d 69 74 65 6d 73 20 72 -roll-up-items r
4d60: 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 69 74 un-id test-id it
4d70: 65 6d 2d 70 61 74 68 20 73 74 61 74 65 20 72 65 em-path state re
4d80: 61 6c 2d 73 74 61 74 75 73 20 28 69 66 20 77 61 al-status (if wa
4d90: 69 76 65 64 20 77 61 69 76 65 64 20 63 6f 6d 6d ived waived comm
4da0: 65 6e 74 29 29 0a 09 20 20 3b 3b 20 28 6d 74 3a ent)).. ;; (mt:
4db0: 70 72 6f 63 65 73 73 2d 74 72 69 67 67 65 72 73 process-triggers
4dc0: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 run-id test-id
4dd0: 73 74 61 74 65 20 72 65 61 6c 2d 73 74 61 74 75 state real-statu
4de0: 73 29 20 3b 3b 20 74 72 69 67 67 65 72 73 20 61 s) ;; triggers a
4df0: 72 65 20 63 61 6c 6c 65 64 20 69 6e 20 74 65 73 re called in tes
4e00: 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 t-set-state-stat
4e10: 75 73 0a 09 20 20 29 29 0a 20 20 20 20 0a 20 20 us.. )). .
4e20: 20 20 3b 3b 20 69 66 20 73 74 61 74 75 73 20 69 ;; if status i
4e30: 73 20 22 41 55 54 4f 22 20 74 68 65 6e 20 63 61 s "AUTO" then ca
4e40: 6c 6c 20 72 6f 6c 6c 75 70 20 28 6e 6f 74 65 2c ll rollup (note,
4e50: 20 74 68 69 73 20 6f 6e 65 20 6d 6f 64 69 66 69 this one modifi
4e60: 65 73 20 64 61 74 61 20 69 6e 20 74 65 73 74 0a es data in test.
4e70: 20 20 20 20 3b 3b 20 72 75 6e 20 61 72 65 61 2c ;; run area,
4e80: 20 69 74 20 64 6f 65 73 20 72 65 6d 6f 74 65 20 it does remote
4e90: 63 61 6c 6c 73 20 75 6e 64 65 72 20 74 68 65 20 calls under the
4ea0: 68 6f 6f 64 2e 0a 20 20 20 20 3b 3b 20 28 69 66 hood.. ;; (if
4eb0: 20 28 61 6e 64 20 74 65 73 74 2d 69 64 20 73 74 (and test-id st
4ec0: 61 74 65 20 73 74 61 74 75 73 20 28 65 71 75 61 ate status (equa
4ed0: 6c 3f 20 73 74 61 74 75 73 20 22 41 55 54 4f 22 l? status "AUTO"
4ee0: 29 29 20 0a 20 20 20 20 3b 3b 20 09 28 72 6d 74 )) . ;; .(rmt
4ef0: 3a 74 65 73 74 2d 64 61 74 61 2d 72 6f 6c 6c 75 :test-data-rollu
4f00: 70 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 p run-id test-id
4f10: 20 73 74 61 74 75 73 29 29 0a 0a 20 20 20 20 3b status)).. ;
4f20: 3b 20 61 64 64 20 6d 65 74 61 64 61 74 61 20 28 ; add metadata (
4f30: 6e 65 65 64 20 74 6f 20 64 6f 20 74 68 69 73 20 need to do this
4f40: 77 61 79 20 74 6f 20 61 76 6f 69 64 20 53 51 4c way to avoid SQL
4f50: 20 69 6e 6a 65 63 74 69 6f 6e 20 69 73 73 75 65 injection issue
4f60: 73 29 0a 0a 20 20 20 20 3b 3b 20 3a 66 69 72 73 s).. ;; :firs
4f70: 74 5f 65 72 72 0a 20 20 20 20 3b 3b 20 28 6c 65 t_err. ;; (le
4f80: 74 20 28 28 76 61 6c 20 28 68 61 73 68 2d 74 61 t ((val (hash-ta
4f90: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
4fa0: 6f 74 68 65 72 64 61 74 20 22 3a 66 69 72 73 74 otherdat ":first
4fb0: 5f 65 72 72 22 20 23 66 29 29 29 0a 20 20 20 20 _err" #f))).
4fc0: 3b 3b 20 20 20 28 69 66 20 76 61 6c 0a 20 20 20 ;; (if val.
4fd0: 20 3b 3b 20 20 20 20 20 20 20 28 73 71 6c 69 74 ;; (sqlit
4fe0: 65 33 3a 65 78 65 63 75 74 65 20 64 62 20 22 55 e3:execute db "U
4ff0: 50 44 41 54 45 20 74 65 73 74 73 20 53 45 54 20 PDATE tests SET
5000: 66 69 72 73 74 5f 65 72 72 3d 3f 20 57 48 45 52 first_err=? WHER
5010: 45 20 72 75 6e 5f 69 64 3d 3f 20 41 4e 44 20 74 E run_id=? AND t
5020: 65 73 74 6e 61 6d 65 3d 3f 20 41 4e 44 20 69 74 estname=? AND it
5030: 65 6d 5f 70 61 74 68 3d 3f 3b 22 20 76 61 6c 20 em_path=?;" val
5040: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
5050: 20 69 74 65 6d 2d 70 61 74 68 29 29 29 0a 20 20 item-path))).
5060: 20 20 3b 3b 20 0a 20 20 20 20 3b 3b 20 3b 3b 20 ;; . ;; ;;
5070: 3a 66 69 72 73 74 5f 77 61 72 6e 0a 20 20 20 20 :first_warn.
5080: 3b 3b 20 28 6c 65 74 20 28 28 76 61 6c 20 28 68 ;; (let ((val (h
5090: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
50a0: 66 61 75 6c 74 20 6f 74 68 65 72 64 61 74 20 22 fault otherdat "
50b0: 3a 66 69 72 73 74 5f 77 61 72 6e 22 20 23 66 29 :first_warn" #f)
50c0: 29 29 0a 20 20 20 20 3b 3b 20 20 20 28 69 66 20 )). ;; (if
50d0: 76 61 6c 0a 20 20 20 20 3b 3b 20 20 20 20 20 20 val. ;;
50e0: 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 (sqlite3:execut
50f0: 65 20 64 62 20 22 55 50 44 41 54 45 20 74 65 73 e db "UPDATE tes
5100: 74 73 20 53 45 54 20 66 69 72 73 74 5f 77 61 72 ts SET first_war
5110: 6e 3d 3f 20 57 48 45 52 45 20 72 75 6e 5f 69 64 n=? WHERE run_id
5120: 3d 3f 20 41 4e 44 20 74 65 73 74 6e 61 6d 65 3d =? AND testname=
5130: 3f 20 41 4e 44 20 69 74 65 6d 5f 70 61 74 68 3d ? AND item_path=
5140: 3f 3b 22 20 76 61 6c 20 72 75 6e 2d 69 64 20 74 ?;" val run-id t
5150: 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 est-name item-pa
5160: 74 68 29 29 29 0a 0a 20 20 20 20 28 6c 65 74 20 th))).. (let
5170: 28 28 63 61 74 65 67 6f 72 79 20 28 68 61 73 68 ((category (hash
5180: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
5190: 6c 74 20 6f 74 68 65 72 64 61 74 20 22 3a 63 61 lt otherdat ":ca
51a0: 74 65 67 6f 72 79 22 20 22 22 29 29 0a 09 20 20 tegory" ""))..
51b0: 28 76 61 72 69 61 62 6c 65 20 28 68 61 73 68 2d (variable (hash-
51c0: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
51d0: 74 20 6f 74 68 65 72 64 61 74 20 22 3a 76 61 72 t otherdat ":var
51e0: 69 61 62 6c 65 22 20 22 22 29 29 0a 09 20 20 28 iable" "")).. (
51f0: 76 61 6c 75 65 20 20 20 20 28 68 61 73 68 2d 74 value (hash-t
5200: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
5210: 20 6f 74 68 65 72 64 61 74 20 22 3a 76 61 6c 75 otherdat ":valu
5220: 65 22 20 20 20 20 23 66 29 29 0a 09 20 20 28 65 e" #f)).. (e
5230: 78 70 65 63 74 65 64 20 28 68 61 73 68 2d 74 61 xpected (hash-ta
5240: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
5250: 6f 74 68 65 72 64 61 74 20 22 3a 65 78 70 65 63 otherdat ":expec
5260: 74 65 64 22 20 22 6e 2f 61 22 29 29 0a 09 20 20 ted" "n/a"))..
5270: 28 74 6f 6c 20 20 20 20 20 20 28 68 61 73 68 2d (tol (hash-
5280: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
5290: 74 20 6f 74 68 65 72 64 61 74 20 22 3a 74 6f 6c t otherdat ":tol
52a0: 22 20 20 20 20 20 20 22 6e 2f 61 22 29 29 0a 09 " "n/a"))..
52b0: 20 20 28 75 6e 69 74 73 20 20 20 20 28 68 61 73 (units (has
52c0: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
52d0: 75 6c 74 20 6f 74 68 65 72 64 61 74 20 22 3a 75 ult otherdat ":u
52e0: 6e 69 74 73 22 20 20 20 20 22 22 29 29 0a 09 20 nits" ""))..
52f0: 20 28 74 79 70 65 20 20 20 20 20 28 68 61 73 68 (type (hash
5300: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
5310: 6c 74 20 6f 74 68 65 72 64 61 74 20 22 3a 74 79 lt otherdat ":ty
5320: 70 65 22 20 20 20 20 20 22 22 29 29 0a 09 20 20 pe" ""))..
5330: 28 64 63 6f 6d 6d 65 6e 74 20 28 68 61 73 68 2d (dcomment (hash-
5340: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
5350: 74 20 6f 74 68 65 72 64 61 74 20 22 3a 63 6f 6d t otherdat ":com
5360: 6d 65 6e 74 22 20 20 22 22 29 29 29 0a 20 20 20 ment" ""))).
5370: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
5380: 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 4 *default-log-p
5390: 6f 72 74 2a 20 0a 09 09 20 20 20 22 63 61 74 65 ort* ... "cate
53a0: 67 6f 72 79 3a 20 22 20 63 61 74 65 67 6f 72 79 gory: " category
53b0: 20 22 2c 20 76 61 72 69 61 62 6c 65 3a 20 22 20 ", variable: "
53c0: 76 61 72 69 61 62 6c 65 20 22 2c 20 76 61 6c 75 variable ", valu
53d0: 65 3a 20 22 20 76 61 6c 75 65 0a 09 09 20 20 20 e: " value...
53e0: 22 2c 20 65 78 70 65 63 74 65 64 3a 20 22 20 65 ", expected: " e
53f0: 78 70 65 63 74 65 64 20 22 2c 20 74 6f 6c 3a 20 xpected ", tol:
5400: 22 20 74 6f 6c 20 22 2c 20 75 6e 69 74 73 3a 20 " tol ", units:
5410: 22 20 75 6e 69 74 73 29 0a 20 20 20 20 20 20 28 " units). (
5420: 69 66 20 28 61 6e 64 20 76 61 6c 75 65 29 20 3b if (and value) ;
5430: 3b 20 72 65 71 75 69 72 65 20 6f 6e 6c 79 20 76 ; require only v
5440: 61 6c 75 65 3b 20 42 42 20 77 61 73 2d 20 61 6c alue; BB was- al
5450: 6c 20 74 68 72 65 65 20 72 65 71 75 69 72 65 64 l three required
5460: 0a 09 20 20 28 6c 65 74 20 28 28 64 61 74 20 28 .. (let ((dat (
5470: 63 6f 6e 63 20 63 61 74 65 67 6f 72 79 20 22 2c conc category ",
5480: 22 0a 09 09 09 20 20 20 76 61 72 69 61 62 6c 65 ".... variable
5490: 20 22 2c 22 0a 09 09 09 20 20 20 76 61 6c 75 65 ",".... value
54a0: 20 20 20 20 22 2c 22 0a 09 09 09 20 20 20 65 78 ",".... ex
54b0: 70 65 63 74 65 64 20 22 2c 22 0a 09 09 09 20 20 pected ","....
54c0: 20 74 6f 6c 20 20 20 20 20 20 22 2c 22 0a 09 09 tol ","...
54d0: 09 20 20 20 75 6e 69 74 73 20 20 20 20 22 2c 22 . units ","
54e0: 0a 09 09 09 20 20 20 64 63 6f 6d 6d 65 6e 74 20 .... dcomment
54f0: 22 2c 2c 22 20 3b 3b 20 65 78 74 72 61 20 63 6f ",," ;; extra co
5500: 6d 6d 61 20 66 6f 72 20 73 74 61 74 75 73 0a 09 mma for status..
5510: 09 09 20 20 20 74 79 70 65 20 20 20 20 20 29 29 .. type ))
5520: 29 0a 09 20 20 20 20 3b 3b 20 54 68 69 73 20 77 ).. ;; This w
5530: 61 73 20 72 75 6e 20 72 65 6d 6f 74 65 2c 20 64 as run remote, d
5540: 6f 6e 27 74 20 74 68 69 6e 6b 20 74 68 61 74 20 on't think that
5550: 6d 61 6b 65 73 20 73 65 6e 73 65 2e 20 50 65 72 makes sense. Per
5560: 68 61 70 73 20 6e 6f 74 2c 20 62 75 74 20 74 68 haps not, but th
5570: 61 74 20 69 73 20 74 68 65 20 65 61 73 69 65 73 at is the easies
5580: 74 20 70 61 74 68 20 66 6f 72 20 74 68 65 20 6d t path for the m
5590: 6f 6d 65 6e 74 2e 0a 09 20 20 20 20 28 72 6d 74 oment... (rmt
55a0: 3a 63 73 76 2d 3e 74 65 73 74 2d 64 61 74 61 20 :csv->test-data
55b0: 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 0a 09 run-id test-id..
55c0: 09 09 09 64 61 74 29 0a 09 20 20 20 20 3b 3b 20 ...dat).. ;;
55d0: 54 68 69 73 20 77 61 73 20 61 64 64 65 64 20 69 This was added i
55e0: 6e 20 63 68 65 63 6b 2d 69 6e 20 61 35 61 64 66 n check-in a5adf
55f0: 61 33 66 39 61 2e 20 4d 65 73 73 61 67 65 20 77 a3f9a. Message w
5600: 61 73 3a 20 22 2e 2e 2e 61 64 64 65 64 20 64 65 as: "...added de
5610: 6c 61 79 20 69 6e 20 73 65 74 2d 76 61 6c 75 65 lay in set-value
5620: 73 20 74 6f 20 61 6c 6c 6f 77 20 66 6f 72 20 64 s to allow for d
5630: 65 6c 61 79 65 64 20 77 72 69 74 65 20 6f 6e 20 elayed write on
5640: 73 65 72 76 65 72 20 73 74 61 72 74 22 0a 09 20 server start"..
5650: 20 20 20 3b 3b 20 49 27 6d 20 69 6e 73 65 72 74 ;; I'm insert
5660: 69 6e 67 20 61 6e 20 61 72 62 69 74 72 61 72 79 ing an arbitrary
5670: 20 72 6d 74 3a 20 63 61 6c 6c 20 74 6f 20 66 6f rmt: call to fo
5680: 72 63 65 2f 65 6e 73 75 72 65 20 74 68 61 74 20 rce/ensure that
5690: 74 68 65 20 73 65 72 76 65 72 20 69 73 20 61 76 the server is av
56a0: 61 69 6c 61 62 6c 65 20 74 6f 20 28 68 6f 70 65 ailable to (hope
56b0: 66 75 6c 6c 79 29 20 70 72 65 76 65 6e 74 20 61 fully) prevent a
56c0: 20 63 6f 6d 6d 75 6e 69 63 61 74 69 6f 6e 20 69 communication i
56d0: 73 73 75 65 2e 0a 09 20 20 20 20 28 72 6d 74 3a ssue... (rmt:
56e0: 67 65 74 2d 76 61 72 20 22 4d 45 47 41 54 45 53 get-var "MEGATES
56f0: 54 5f 56 45 52 53 49 4f 4e 22 29 20 3b 3b 20 74 T_VERSION") ;; t
5700: 68 69 73 20 64 6f 65 73 20 4e 4f 54 48 49 4e 47 his does NOTHING
5710: 20 62 75 74 20 65 6e 73 75 72 65 20 74 68 65 20 but ensure the
5720: 73 65 72 76 65 72 20 69 73 20 72 65 61 63 68 61 server is reacha
5730: 62 6c 65 2e 20 54 68 69 73 20 69 73 20 61 6c 6d ble. This is alm
5740: 6f 73 74 20 63 65 72 74 61 69 6e 6c 79 20 4e 4f ost certainly NO
5750: 54 20 6e 65 65 64 65 64 20 3a 29 0a 20 20 20 20 T needed :).
5760: 20 20 20 20 20 20 20 20 3b 3b 20 42 42 20 2d 20 ;; BB -
5770: 63 6f 6d 6d 65 6e 74 69 6f 6e 67 20 6f 75 74 20 commentiong out
5780: 61 72 62 69 74 72 61 72 79 20 31 30 20 73 65 63 arbitrary 10 sec
5790: 6f 6e 64 20 77 61 69 74 20 28 74 68 72 65 61 64 ond wait (thread
57a0: 2d 73 6c 65 65 70 21 20 31 30 29 20 3b 3b 20 61 -sleep! 10) ;; a
57b0: 64 64 20 31 30 20 73 65 63 6f 6e 64 20 64 65 6c dd 10 second del
57c0: 61 79 20 62 65 66 6f 72 65 20 71 75 69 74 20 69 ay before quit i
57d0: 6e 63 61 73 65 20 72 6d 74 20 6e 65 65 64 73 20 ncase rmt needs
57e0: 74 69 6d 65 20 74 6f 20 73 74 61 72 74 20 61 20 time to start a
57f0: 73 65 72 76 65 72 2e 0a 20 20 20 20 20 20 20 20 server..
5800: 20 20 20 20 29 29 29 0a 20 20 20 20 20 20 0a 20 ))). .
5810: 20 20 20 3b 3b 20 6e 65 65 64 20 74 6f 20 75 70 ;; need to up
5820: 64 61 74 65 20 74 68 65 20 74 6f 70 20 74 65 73 date the top tes
5830: 74 20 72 65 63 6f 72 64 20 69 66 20 50 41 53 53 t record if PASS
5840: 20 6f 72 20 46 41 49 4c 20 61 6e 64 20 74 68 69 or FAIL and thi
5850: 73 20 69 73 20 61 20 73 75 62 74 65 73 74 0a 20 s is a subtest.
5860: 20 20 20 3b 3b 3b 3b 3b 3b 20 28 69 66 20 28 6e ;;;;;; (if (n
5870: 6f 74 20 28 65 71 75 61 6c 3f 20 69 74 65 6d 2d ot (equal? item-
5880: 70 61 74 68 20 22 22 29 29 0a 20 20 20 20 3b 3b path "")). ;;
5890: 3b 3b 3b 3b 20 20 20 20 20 28 72 6d 74 3a 73 65 ;;;; (rmt:se
58a0: 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d 61 t-state-status-a
58b0: 6e 64 2d 72 6f 6c 6c 2d 75 70 2d 69 74 65 6d 73 nd-roll-up-items
58c0: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
58d0: 65 20 69 74 65 6d 2d 70 61 74 68 20 73 74 61 74 e item-path stat
58e0: 65 20 73 74 61 74 75 73 20 23 66 29 20 3b 3b 3b e status #f) ;;;
58f0: 3b 3b 29 0a 0a 20 20 20 20 28 69 66 20 28 6f 72 ;;).. (if (or
5900: 20 28 61 6e 64 20 28 73 74 72 69 6e 67 3f 20 63 (and (string? c
5910: 6f 6d 6d 65 6e 74 29 0a 09 09 20 28 73 74 72 69 omment)... (stri
5920: 6e 67 2d 6d 61 74 63 68 20 28 72 65 67 65 78 70 ng-match (regexp
5930: 20 22 5c 5c 53 2b 22 29 20 63 6f 6d 6d 65 6e 74 "\\S+") comment
5940: 29 29 0a 09 20 20 20 20 77 61 69 76 65 64 29 0a )).. waived).
5950: 09 28 6c 65 74 20 28 28 63 6d 74 20 20 28 69 66 .(let ((cmt (if
5960: 20 77 61 69 76 65 64 20 77 61 69 76 65 64 20 63 waived waived c
5970: 6f 6d 6d 65 6e 74 29 29 29 0a 09 20 20 28 72 6d omment))).. (rm
5980: 74 3a 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 t:general-call '
5990: 73 65 74 2d 74 65 73 74 2d 63 6f 6d 6d 65 6e 74 set-test-comment
59a0: 20 72 75 6e 2d 69 64 20 63 6d 74 20 74 65 73 74 run-id cmt test
59b0: 2d 69 64 29 29 29 29 29 0a 0a 28 64 65 66 69 6e -id)))))..(defin
59c0: 65 20 28 74 65 73 74 73 3a 74 65 73 74 2d 73 65 e (tests:test-se
59d0: 74 2d 74 6f 70 6c 6f 67 21 20 72 75 6e 2d 69 64 t-toplog! run-id
59e0: 20 74 65 73 74 2d 6e 61 6d 65 20 6c 6f 67 66 29 test-name logf)
59f0: 20 0a 20 20 28 72 6d 74 3a 67 65 6e 65 72 61 6c . (rmt:general
5a00: 2d 63 61 6c 6c 20 27 74 65 73 74 73 3a 74 65 73 -call 'tests:tes
5a10: 74 2d 73 65 74 2d 74 6f 70 6c 6f 67 20 72 75 6e t-set-toplog run
5a20: 2d 69 64 20 6c 6f 67 66 20 72 75 6e 2d 69 64 20 -id logf run-id
5a30: 74 65 73 74 2d 6e 61 6d 65 29 29 0a 0a 28 64 65 test-name))..(de
5a40: 66 69 6e 65 20 28 74 65 73 74 73 3a 73 75 6d 6d fine (tests:summ
5a50: 61 72 69 7a 65 2d 69 74 65 6d 73 20 72 75 6e 2d arize-items run-
5a60: 69 64 20 74 65 73 74 2d 69 64 20 74 65 73 74 2d id test-id test-
5a70: 6e 61 6d 65 20 66 6f 72 63 65 29 0a 20 20 3b 3b name force). ;;
5a80: 20 69 66 20 6e 6f 74 20 66 6f 72 63 65 20 74 68 if not force th
5a90: 65 6e 20 6f 6e 6c 79 20 75 70 64 61 74 65 20 74 en only update t
5aa0: 68 65 20 72 65 63 6f 72 64 20 69 66 20 6f 6e 65 he record if one
5ab0: 20 6f 66 20 74 68 65 73 65 20 69 73 20 74 72 75 of these is tru
5ac0: 65 3a 0a 20 20 3b 3b 20 20 20 31 2e 20 6c 6f 67 e:. ;; 1. log
5ad0: 66 20 69 73 20 22 6c 6f 67 2f 66 69 6e 61 6c 2e f is "log/final.
5ae0: 6c 6f 67 0a 20 20 3b 3b 20 20 20 32 2e 20 6c 6f log. ;; 2. lo
5af0: 67 66 20 69 73 20 73 61 6d 65 20 61 73 20 6f 75 gf is same as ou
5b00: 74 70 75 74 66 69 6c 65 6e 61 6d 65 0a 20 20 28 tputfilename. (
5b10: 6c 65 74 2a 20 28 28 6f 75 74 70 75 74 66 69 6c let* ((outputfil
5b20: 65 6e 61 6d 65 20 28 63 6f 6e 63 20 22 6d 65 67 ename (conc "meg
5b30: 61 74 65 73 74 2d 72 6f 6c 6c 75 70 2d 22 20 74 atest-rollup-" t
5b40: 65 73 74 2d 6e 61 6d 65 20 22 2e 68 74 6d 6c 22 est-name ".html"
5b50: 29 29 0a 09 20 28 6f 72 69 67 2d 64 69 72 20 20 )).. (orig-dir
5b60: 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d 64 69 (current-di
5b70: 72 65 63 74 6f 72 79 29 29 0a 09 20 28 6c 6f 67 rectory)).. (log
5b80: 66 2d 69 6e 66 6f 20 20 20 20 20 20 28 72 6d 74 f-info (rmt
5b90: 3a 74 65 73 74 2d 67 65 74 2d 6c 6f 67 66 69 6c :test-get-logfil
5ba0: 65 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 20 74 65 e-info run-id te
5bb0: 73 74 2d 6e 61 6d 65 29 29 0a 09 20 28 6c 6f 67 st-name)).. (log
5bc0: 66 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 f (if
5bd0: 6c 6f 67 66 2d 69 6e 66 6f 20 28 63 61 64 72 20 logf-info (cadr
5be0: 6c 6f 67 66 2d 69 6e 66 6f 29 20 23 66 29 29 0a logf-info) #f)).
5bf0: 09 20 28 70 61 74 68 20 20 20 20 20 20 20 20 20 . (path
5c00: 20 20 28 69 66 20 6c 6f 67 66 2d 69 6e 66 6f 20 (if logf-info
5c10: 28 63 61 72 20 20 6c 6f 67 66 2d 69 6e 66 6f 29 (car logf-info)
5c20: 20 23 66 29 29 29 0a 20 20 20 20 3b 3b 20 54 68 #f))). ;; Th
5c30: 69 73 20 71 75 65 72 79 20 66 69 6e 64 73 20 74 is query finds t
5c40: 68 65 20 70 61 74 68 20 61 6e 64 20 63 68 61 6e he path and chan
5c50: 67 65 73 20 74 68 65 20 64 69 72 65 63 74 6f 72 ges the director
5c60: 79 20 74 6f 20 69 74 20 66 6f 72 20 74 68 65 20 y to it for the
5c70: 74 65 73 74 0a 20 20 20 20 28 69 66 20 28 61 6e test. (if (an
5c80: 64 20 28 73 74 72 69 6e 67 3f 20 70 61 74 68 29 d (string? path)
5c90: 0a 09 20 20 20 20 20 28 64 69 72 65 63 74 6f 72 .. (director
5ca0: 79 3f 20 70 61 74 68 29 29 20 3b 3b 20 63 61 6e y? path)) ;; can
5cb0: 20 67 65 74 20 23 66 20 68 65 72 65 20 75 6e 64 get #f here und
5cc0: 65 72 20 73 6f 6d 65 20 77 69 65 72 64 20 63 6f er some wierd co
5cd0: 6e 64 69 74 69 6f 6e 73 2e 20 77 68 79 2c 20 75 nditions. why, u
5ce0: 6e 6b 6e 6f 77 6e 20 2e 2e 2e 0a 09 28 62 65 67 nknown .....(beg
5cf0: 69 6e 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 in.. (debug:pri
5d00: 6e 74 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 4 *default-lo
5d10: 67 2d 70 6f 72 74 2a 20 22 46 6f 75 6e 64 20 70 g-port* "Found p
5d20: 61 74 68 3a 20 22 20 70 61 74 68 29 0a 09 20 20 ath: " path)..
5d30: 28 63 68 61 6e 67 65 2d 64 69 72 65 63 74 6f 72 (change-director
5d40: 79 20 70 61 74 68 29 29 0a 09 3b 3b 20 28 73 65 y path))..;; (se
5d50: 74 21 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d t! outputfilenam
5d60: 65 20 28 63 6f 6e 63 20 70 61 74 68 20 22 2f 22 e (conc path "/"
5d70: 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 29 outputfilename)
5d80: 29 29 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 ))..(debug:print
5d90: 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c -error 0 *defaul
5da0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 75 6d t-log-port* "sum
5db0: 6d 61 72 69 7a 65 2d 69 74 65 6d 73 20 66 6f 72 marize-items for
5dc0: 20 72 75 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 64 run-id=" run-id
5dd0: 20 22 2c 20 74 65 73 74 2d 6e 61 6d 65 3d 22 20 ", test-name="
5de0: 74 65 73 74 2d 6e 61 6d 65 20 22 2c 20 6e 6f 20 test-name ", no
5df0: 73 75 63 68 20 70 61 74 68 3a 20 22 20 70 61 74 such path: " pat
5e00: 68 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 h)). (debug:p
5e10: 72 69 6e 74 20 34 20 2a 64 65 66 61 75 6c 74 2d rint 4 *default-
5e20: 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 75 6d 6d 61 log-port* "summa
5e30: 72 69 7a 65 2d 69 74 65 6d 73 20 77 69 74 68 20 rize-items with
5e40: 6c 6f 67 66 20 22 20 6c 6f 67 66 20 22 2c 20 6f logf " logf ", o
5e50: 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 20 22 20 utputfilename "
5e60: 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 20 22 outputfilename "
5e70: 20 61 6e 64 20 66 6f 72 63 65 20 22 20 66 6f 72 and force " for
5e80: 63 65 29 0a 20 20 20 20 28 69 66 20 28 6f 72 20 ce). (if (or
5e90: 28 65 71 75 61 6c 3f 20 6c 6f 67 66 20 22 6c 6f (equal? logf "lo
5ea0: 67 73 2f 66 69 6e 61 6c 2e 6c 6f 67 22 29 0a 09 gs/final.log")..
5eb0: 20 20 20 20 28 65 71 75 61 6c 3f 20 6c 6f 67 66 (equal? logf
5ec0: 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 29 outputfilename)
5ed0: 0a 09 20 20 20 20 66 6f 72 63 65 29 0a 09 28 6c .. force)..(l
5ee0: 65 74 20 28 28 6d 79 2d 73 74 61 72 74 2d 74 69 et ((my-start-ti
5ef0: 6d 65 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f me (current-seco
5f00: 6e 64 73 29 29 0a 09 20 20 20 20 20 20 28 6c 6f nds)).. (lo
5f10: 63 6b 66 20 20 20 20 20 20 20 20 20 28 63 6f 6e ckf (con
5f20: 63 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 c outputfilename
5f30: 20 22 2e 6c 6f 63 6b 22 29 29 29 0a 09 20 20 28 ".lock"))).. (
5f40: 6c 65 74 20 6c 6f 6f 70 20 28 28 68 61 76 65 2d let loop ((have-
5f50: 6c 6f 63 6b 20 20 28 63 6f 6d 6d 6f 6e 3a 73 69 lock (common:si
5f60: 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 20 6c mple-file-lock l
5f70: 6f 63 6b 66 29 29 29 0a 09 20 20 20 20 28 69 66 ockf))).. (if
5f80: 20 68 61 76 65 2d 6c 6f 63 6b 0a 09 09 28 6c 65 have-lock...(le
5f90: 74 20 28 28 73 63 72 69 70 74 20 28 63 6f 6e 66 t ((script (conf
5fa0: 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 igf:lookup *conf
5fb0: 69 67 64 61 74 2a 20 22 74 65 73 74 72 6f 6c 6c igdat* "testroll
5fc0: 75 70 22 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 up" test-name)))
5fd0: 0a 09 09 20 20 28 70 72 69 6e 74 20 22 4f 62 74 ... (print "Obt
5fe0: 61 69 6e 65 64 20 6c 6f 63 6b 20 66 6f 72 20 22 ained lock for "
5ff0: 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 29 outputfilename)
6000: 0a 09 09 20 20 28 72 6d 74 3a 73 65 74 2d 73 74 ... (rmt:set-st
6010: 61 74 65 2d 73 74 61 74 75 73 2d 61 6e 64 2d 72 ate-status-and-r
6020: 6f 6c 6c 2d 75 70 2d 69 74 65 6d 73 20 72 75 6e oll-up-items run
6030: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 22 22 -id test-name ""
6040: 20 23 66 20 23 66 20 23 66 29 0a 09 09 20 20 28 #f #f #f)... (
6050: 69 66 20 73 63 72 69 70 74 0a 09 09 20 20 20 20 if script...
6060: 20 20 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 (system (conc
6070: 73 63 72 69 70 74 20 22 20 3e 20 22 20 6f 75 74 script " > " out
6080: 70 75 74 66 69 6c 65 6e 61 6d 65 20 22 20 26 20 putfilename " &
6090: 22 29 29 0a 09 09 20 20 20 20 20 20 28 74 65 73 "))... (tes
60a0: 74 73 3a 67 65 6e 65 72 61 74 65 2d 68 74 6d 6c ts:generate-html
60b0: 2d 73 75 6d 6d 61 72 79 2d 66 6f 72 2d 69 74 65 -summary-for-ite
60c0: 72 61 74 65 64 2d 74 65 73 74 20 72 75 6e 2d 69 rated-test run-i
60d0: 64 20 74 65 73 74 2d 69 64 20 74 65 73 74 2d 6e d test-id test-n
60e0: 61 6d 65 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 ame outputfilena
60f0: 6d 65 29 29 0a 09 09 20 20 28 63 6f 6d 6d 6f 6e me))... (common
6100: 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 72 65 6c :simple-file-rel
6110: 65 61 73 65 2d 6c 6f 63 6b 20 6c 6f 63 6b 66 29 ease-lock lockf)
6120: 0a 09 09 20 20 28 63 68 61 6e 67 65 2d 64 69 72 ... (change-dir
6130: 65 63 74 6f 72 79 20 6f 72 69 67 2d 64 69 72 29 ectory orig-dir)
6140: 0a 09 09 20 20 3b 3b 20 4e 42 2f 2f 20 74 65 73 ... ;; NB// tes
6150: 74 73 3a 74 65 73 74 2d 73 65 74 2d 74 6f 70 6c ts:test-set-topl
6160: 6f 67 21 20 69 73 20 72 65 6d 6f 74 65 20 69 6e og! is remote in
6170: 74 65 72 6e 61 6c 2e 2e 2e 0a 09 09 20 20 28 74 ternal...... (t
6180: 65 73 74 73 3a 74 65 73 74 2d 73 65 74 2d 74 6f ests:test-set-to
6190: 70 6c 6f 67 21 20 72 75 6e 2d 69 64 20 74 65 73 plog! run-id tes
61a0: 74 2d 6e 61 6d 65 20 6f 75 74 70 75 74 66 69 6c t-name outputfil
61b0: 65 6e 61 6d 65 29 29 0a 09 09 3b 3b 20 64 69 64 ename))...;; did
61c0: 6e 27 74 20 67 65 74 20 74 68 65 20 6c 6f 63 6b n't get the lock
61d0: 2c 20 63 68 65 63 6b 20 74 6f 20 73 65 65 20 69 , check to see i
61e0: 66 20 63 75 72 72 65 6e 74 20 75 70 64 61 74 65 f current update
61f0: 20 73 74 61 72 74 65 64 20 6c 61 74 65 72 20 74 started later t
6200: 68 61 6e 20 74 68 69 73 20 0a 09 09 3b 3b 20 75 han this ...;; u
6210: 70 64 61 74 65 2c 20 69 66 20 73 6f 20 77 65 20 pdate, if so we
6220: 63 61 6e 20 65 78 69 74 20 77 69 74 68 6f 75 74 can exit without
6230: 20 64 6f 69 6e 67 20 61 6e 79 20 77 6f 72 6b 0a doing any work.
6240: 09 09 28 69 66 20 28 3e 20 6d 79 2d 73 74 61 72 ..(if (> my-star
6250: 74 2d 74 69 6d 65 20 28 68 61 6e 64 6c 65 2d 65 t-time (handle-e
6260: 78 63 65 70 74 69 6f 6e 73 0a 09 09 09 09 09 20 xceptions......
6270: 65 78 6e 0a 09 09 09 09 20 20 20 20 20 20 20 28 exn..... (
6280: 62 65 67 69 6e 0a 09 09 09 09 09 20 28 70 72 69 begin...... (pri
6290: 6e 74 20 22 66 61 69 6c 65 64 20 74 6f 20 67 65 nt "failed to ge
62a0: 74 20 6d 6f 64 20 74 69 6d 65 20 6f 6e 20 22 20 t mod time on "
62b0: 6c 6f 63 6b 66 20 22 2c 20 65 78 6e 3d 22 20 65 lockf ", exn=" e
62c0: 78 6e 29 0a 09 09 09 09 09 20 30 29 0a 09 09 09 xn)...... 0)....
62d0: 09 20 20 20 20 20 20 20 28 66 69 6c 65 2d 6d 6f . (file-mo
62e0: 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 dification-time
62f0: 6c 6f 63 6b 66 29 29 29 0a 09 09 20 20 20 20 3b lockf)))... ;
6300: 3b 20 77 65 20 73 74 61 72 74 65 64 20 73 69 6e ; we started sin
6310: 63 65 20 63 75 72 72 65 6e 74 20 72 65 2d 67 65 ce current re-ge
6320: 6e 20 69 6e 20 66 6c 69 67 68 74 2c 20 64 65 6c n in flight, del
6330: 61 79 20 61 20 6c 69 74 74 6c 65 20 61 6e 64 20 ay a little and
6340: 74 72 79 20 61 67 61 69 6e 0a 09 09 20 20 20 20 try again...
6350: 28 62 65 67 69 6e 0a 09 09 20 20 20 20 20 20 28 (begin... (
6360: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
6370: 20 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 1 *default-log-
6380: 70 6f 72 74 2a 20 22 57 61 69 74 69 6e 67 20 74 port* "Waiting t
6390: 6f 20 75 70 64 61 74 65 20 22 20 6f 75 74 70 75 o update " outpu
63a0: 74 66 69 6c 65 6e 61 6d 65 20 22 2c 20 61 6e 6f tfilename ", ano
63b0: 74 68 65 72 20 74 65 73 74 20 63 75 72 72 65 6e ther test curren
63c0: 74 6c 79 20 75 70 64 61 74 69 6e 67 20 69 74 22 tly updating it"
63d0: 29 0a 09 09 20 20 20 20 20 20 28 74 68 72 65 61 )... (threa
63e0: 64 2d 73 6c 65 65 70 21 20 28 2b 20 35 20 28 72 d-sleep! (+ 5 (r
63f0: 61 6e 64 6f 6d 20 35 29 29 29 20 3b 3b 20 64 65 andom 5))) ;; de
6400: 6c 61 79 20 62 65 74 77 65 65 6e 20 35 20 61 6e lay between 5 an
6410: 64 20 31 30 20 73 65 63 6f 6e 64 73 0a 09 09 20 d 10 seconds...
6420: 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 6f 6d 6d (loop (comm
6430: 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 6c on:simple-file-l
6440: 6f 63 6b 20 6c 6f 63 6b 66 29 29 29 29 29 29 29 ock lockf)))))))
6450: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 )))..(define (te
6460: 73 74 73 3a 67 65 6e 65 72 61 74 65 2d 68 74 6d sts:generate-htm
6470: 6c 2d 73 75 6d 6d 61 72 79 2d 66 6f 72 2d 69 74 l-summary-for-it
6480: 65 72 61 74 65 64 2d 74 65 73 74 20 72 75 6e 2d erated-test run-
6490: 69 64 20 74 65 73 74 2d 69 64 20 74 65 73 74 2d id test-id test-
64a0: 6e 61 6d 65 20 6f 75 74 70 75 74 66 69 6c 65 6e name outputfilen
64b0: 61 6d 65 29 0a 20 20 28 6c 65 74 20 28 28 63 6f ame). (let ((co
64c0: 75 6e 74 73 20 20 20 20 20 20 20 20 20 20 20 20 unts
64d0: 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 (make-hash-tab
64e0: 6c 65 29 29 0a 09 28 73 74 61 74 65 63 6f 75 6e le))..(statecoun
64f0: 74 73 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 ts (make
6500: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 09 28 -hash-table))..(
6510: 6f 75 74 74 78 74 20 20 20 20 20 20 20 20 20 20 outtxt
6520: 20 20 20 20 22 22 29 0a 09 28 74 6f 74 20 20 20 "")..(tot
6530: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 30 29 0)
6540: 0a 09 28 74 65 73 74 64 61 74 20 20 20 20 20 20 ..(testdat
6550: 20 20 20 20 20 20 20 28 72 6d 74 3a 74 65 73 74 (rmt:test
6560: 2d 67 65 74 2d 72 65 63 6f 72 64 73 2d 66 6f 72 -get-records-for
6570: 2d 69 6e 64 65 78 2d 66 69 6c 65 20 72 75 6e 2d -index-file run-
6580: 69 64 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a id test-name))).
6590: 20 20 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 (with-output
65a0: 2d 74 6f 2d 66 69 6c 65 20 6f 75 74 70 75 74 66 -to-file outputf
65b0: 69 6c 65 6e 61 6d 65 0a 20 20 20 20 20 20 28 6c ilename. (l
65c0: 61 6d 62 64 61 20 28 29 0a 09 28 73 65 74 21 20 ambda ()..(set!
65d0: 6f 75 74 74 78 74 20 28 63 6f 6e 63 20 6f 75 74 outtxt (conc out
65e0: 74 78 74 20 22 3c 68 74 6d 6c 3e 3c 74 69 74 6c txt "<html><titl
65f0: 65 3e 53 75 6d 6d 61 72 79 3a 20 22 20 74 65 73 e>Summary: " tes
6600: 74 2d 6e 61 6d 65 20 0a 09 09 09 20 20 20 22 3c t-name .... "<
6610: 2f 74 69 74 6c 65 3e 3c 62 6f 64 79 3e 3c 68 32 /title><body><h2
6620: 3e 53 75 6d 6d 61 72 79 20 66 6f 72 20 22 20 74 >Summary for " t
6630: 65 73 74 2d 6e 61 6d 65 20 22 3c 2f 68 32 3e 22 est-name "</h2>"
6640: 29 29 0a 09 28 66 6f 72 2d 65 61 63 68 0a 09 20 ))..(for-each..
6650: 28 6c 61 6d 62 64 61 20 28 74 65 73 74 72 65 63 (lambda (testrec
6660: 6f 72 64 29 0a 09 20 20 20 28 6c 65 74 20 28 28 ord).. (let ((
6670: 69 64 20 20 20 20 20 20 20 20 20 20 20 20 20 28 id (
6680: 76 65 63 74 6f 72 2d 72 65 66 20 74 65 73 74 72 vector-ref testr
6690: 65 63 6f 72 64 20 30 29 29 0a 09 09 20 28 69 74 ecord 0))... (it
66a0: 65 6d 70 61 74 68 20 20 20 20 20 20 20 28 76 65 empath (ve
66b0: 63 74 6f 72 2d 72 65 66 20 74 65 73 74 72 65 63 ctor-ref testrec
66c0: 6f 72 64 20 31 29 29 0a 09 09 20 28 73 74 61 74 ord 1))... (stat
66d0: 65 20 20 20 20 20 20 20 20 20 20 28 76 65 63 74 e (vect
66e0: 6f 72 2d 72 65 66 20 74 65 73 74 72 65 63 6f 72 or-ref testrecor
66f0: 64 20 32 29 29 0a 09 09 20 28 73 74 61 74 75 73 d 2))... (status
6700: 20 20 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 (vector
6710: 2d 72 65 66 20 74 65 73 74 72 65 63 6f 72 64 20 -ref testrecord
6720: 33 29 29 0a 09 09 20 28 72 75 6e 5f 64 75 72 61 3))... (run_dura
6730: 74 69 6f 6e 20 20 20 28 76 65 63 74 6f 72 2d 72 tion (vector-r
6740: 65 66 20 74 65 73 74 72 65 63 6f 72 64 20 34 29 ef testrecord 4)
6750: 29 0a 09 09 20 28 6c 6f 67 66 20 20 20 20 20 20 )... (logf
6760: 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 (vector-ref
6770: 20 74 65 73 74 72 65 63 6f 72 64 20 35 29 29 0a testrecord 5)).
6780: 09 09 20 28 63 6f 6d 6d 65 6e 74 20 20 20 20 20 .. (comment
6790: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 (vector-ref t
67a0: 65 73 74 72 65 63 6f 72 64 20 36 29 29 29 0a 09 estrecord 6)))..
67b0: 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
67c0: 2d 73 65 74 21 20 63 6f 75 6e 74 73 20 73 74 61 -set! counts sta
67d0: 74 75 73 20 28 2b 20 31 20 28 68 61 73 68 2d 74 tus (+ 1 (hash-t
67e0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
67f0: 20 63 6f 75 6e 74 73 20 73 74 61 74 75 73 20 30 counts status 0
6800: 29 29 29 0a 09 20 20 20 20 20 28 68 61 73 68 2d ))).. (hash-
6810: 74 61 62 6c 65 2d 73 65 74 21 20 73 74 61 74 65 table-set! state
6820: 63 6f 75 6e 74 73 20 73 74 61 74 65 20 28 2b 20 counts state (+
6830: 31 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 1 (hash-table-re
6840: 66 2f 64 65 66 61 75 6c 74 20 73 74 61 74 65 63 f/default statec
6850: 6f 75 6e 74 73 20 73 74 61 74 65 20 30 29 29 29 ounts state 0)))
6860: 0a 09 20 20 20 20 20 28 73 65 74 21 20 6f 75 74 .. (set! out
6870: 74 78 74 20 28 63 6f 6e 63 20 6f 75 74 74 78 74 txt (conc outtxt
6880: 20 22 3c 74 72 3e 22 0a 09 09 09 09 3b 3b 20 22 "<tr>".....;; "
6890: 3c 74 64 3e 3c 61 20 68 72 65 66 3d 5c 22 22 20 <td><a href=\""
68a0: 69 74 65 6d 70 61 74 68 20 22 2f 22 20 6c 6f 67 itempath "/" log
68b0: 66 20 22 5c 22 3e 20 22 20 69 74 65 6d 70 61 74 f "\"> " itempat
68c0: 68 20 22 3c 2f 61 3e 3c 2f 74 64 3e 22 20 0a 09 h "</a></td>" ..
68d0: 09 09 09 22 3c 74 64 3e 3c 61 20 68 72 65 66 3d ..."<td><a href=
68e0: 5c 22 22 20 69 74 65 6d 70 61 74 68 20 22 2f 74 \"" itempath "/t
68f0: 65 73 74 2d 73 75 6d 6d 61 72 79 2e 68 74 6d 6c est-summary.html
6900: 5c 22 3e 20 22 20 69 74 65 6d 70 61 74 68 20 22 \"> " itempath "
6910: 3c 2f 61 3e 3c 2f 74 64 3e 22 20 0a 09 09 09 09 </a></td>" .....
6920: 22 3c 74 64 3e 22 20 73 74 61 74 65 20 20 20 20 "<td>" state
6930: 22 3c 2f 74 64 3e 22 20 0a 09 09 09 09 22 3c 74 "</td>" ....."<t
6940: 64 3e 3c 66 6f 6e 74 20 63 6f 6c 6f 72 3d 22 20 d><font color="
6950: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 6f 6c 6f (common:get-colo
6960: 72 2d 66 72 6f 6d 2d 73 74 61 74 75 73 20 73 74 r-from-status st
6970: 61 74 75 73 29 0a 09 09 09 09 22 3e 22 20 20 20 atus).....">"
6980: 73 74 61 74 75 73 20 20 20 22 3c 2f 66 6f 6e 74 status "</font
6990: 3e 3c 2f 74 64 3e 22 0a 09 09 09 09 22 3c 74 64 ></td>"....."<td
69a0: 3e 22 20 28 69 66 20 28 65 71 75 61 6c 3f 20 63 >" (if (equal? c
69b0: 6f 6d 6d 65 6e 74 20 22 22 29 0a 09 09 09 09 09 omment "")......
69c0: 20 20 20 22 26 6e 62 73 70 3b 22 0a 09 09 09 09 " ".....
69d0: 09 20 20 20 63 6f 6d 6d 65 6e 74 29 20 22 3c 2f . comment) "</
69e0: 74 64 3e 22 0a 09 09 09 09 09 20 20 20 22 3c 2f td>"...... "</
69f0: 74 72 3e 22 29 29 29 29 0a 09 20 28 69 66 20 28 tr>")))).. (if (
6a00: 6c 69 73 74 3f 20 74 65 73 74 64 61 74 29 0a 09 list? testdat)..
6a10: 20 20 20 20 20 74 65 73 74 64 61 74 0a 09 20 20 testdat..
6a20: 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 (begin..
6a30: 20 20 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a (print "ERROR:
6a40: 20 66 61 69 6c 65 64 20 74 6f 20 67 65 74 20 72 failed to get r
6a50: 65 63 6f 72 64 73 20 77 69 74 68 20 72 6d 74 3a ecords with rmt:
6a60: 74 65 73 74 2d 67 65 74 2d 72 65 63 6f 72 64 73 test-get-records
6a70: 2d 66 6f 72 2d 69 6e 64 65 78 2d 66 69 6c 65 20 -for-index-file
6a80: 72 75 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 64 20 run-id=" run-id
6a90: 22 74 65 73 74 2d 6e 61 6d 65 3d 22 20 74 65 73 "test-name=" tes
6aa0: 74 2d 6e 61 6d 65 29 0a 09 20 20 20 20 20 20 20 t-name)..
6ab0: 27 28 29 29 29 29 0a 09 0a 09 28 70 72 69 6e 74 '())))....(print
6ac0: 20 22 3c 74 61 62 6c 65 3e 3c 74 72 3e 3c 74 64 "<table><tr><td
6ad0: 20 76 61 6c 69 67 6e 3d 5c 22 74 6f 70 5c 22 3e valign=\"top\">
6ae0: 22 29 0a 09 3b 3b 20 50 72 69 6e 74 20 6f 75 74 ")..;; Print out
6af0: 20 73 74 61 74 73 20 66 6f 72 20 73 74 61 74 75 stats for statu
6b00: 73 0a 09 28 73 65 74 21 20 74 6f 74 20 30 29 0a s..(set! tot 0).
6b10: 09 28 70 72 69 6e 74 20 22 3c 74 61 62 6c 65 20 .(print "<table
6b20: 63 65 6c 6c 73 70 61 63 69 6e 67 3d 5c 22 30 5c cellspacing=\"0\
6b30: 22 20 62 6f 72 64 65 72 3d 5c 22 31 5c 22 3e 3c " border=\"1\"><
6b40: 74 72 3e 3c 74 64 20 63 6f 6c 73 70 61 6e 3d 5c tr><td colspan=\
6b50: 22 32 5c 22 3e 3c 68 32 3e 53 74 61 74 65 20 73 "2\"><h2>State s
6b60: 74 61 74 73 3c 2f 68 32 3e 3c 2f 74 64 3e 3c 2f tats</h2></td></
6b70: 74 72 3e 22 29 0a 09 28 66 6f 72 2d 65 61 63 68 tr>")..(for-each
6b80: 20 28 6c 61 6d 62 64 61 20 28 73 74 61 74 65 29 (lambda (state)
6b90: 0a 09 09 20 20 20 20 28 73 65 74 21 20 74 6f 74 ... (set! tot
6ba0: 20 28 2b 20 74 6f 74 20 28 68 61 73 68 2d 74 61 (+ tot (hash-ta
6bb0: 62 6c 65 2d 72 65 66 20 73 74 61 74 65 63 6f 75 ble-ref statecou
6bc0: 6e 74 73 20 73 74 61 74 65 29 29 29 0a 09 09 20 nts state)))...
6bd0: 20 20 20 28 70 72 69 6e 74 20 22 3c 74 72 3e 3c (print "<tr><
6be0: 74 64 3e 22 20 73 74 61 74 65 20 22 3c 2f 74 64 td>" state "</td
6bf0: 3e 3c 74 64 3e 22 20 28 68 61 73 68 2d 74 61 62 ><td>" (hash-tab
6c00: 6c 65 2d 72 65 66 20 73 74 61 74 65 63 6f 75 6e le-ref statecoun
6c10: 74 73 20 73 74 61 74 65 29 20 22 3c 2f 74 64 3e ts state) "</td>
6c20: 3c 2f 74 72 3e 22 29 29 0a 09 09 20 20 28 68 61 </tr>"))... (ha
6c30: 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 73 74 sh-table-keys st
6c40: 61 74 65 63 6f 75 6e 74 73 29 29 0a 09 28 70 72 atecounts))..(pr
6c50: 69 6e 74 20 22 3c 74 72 3e 3c 74 64 3e 54 6f 74 int "<tr><td>Tot
6c60: 61 6c 3c 2f 74 64 3e 3c 74 64 3e 22 20 74 6f 74 al</td><td>" tot
6c70: 20 22 3c 2f 74 64 3e 3c 2f 74 72 3e 3c 2f 74 61 "</td></tr></ta
6c80: 62 6c 65 3e 22 29 0a 09 28 70 72 69 6e 74 20 22 ble>")..(print "
6c90: 3c 2f 74 64 3e 3c 74 64 20 76 61 6c 69 67 6e 3d </td><td valign=
6ca0: 5c 22 74 6f 70 5c 22 3e 22 29 0a 09 3b 3b 20 50 \"top\">")..;; P
6cb0: 72 69 6e 74 20 6f 75 74 20 73 74 61 74 73 20 66 rint out stats f
6cc0: 6f 72 20 73 74 61 74 65 0a 09 28 73 65 74 21 20 or state..(set!
6cd0: 74 6f 74 20 30 29 0a 09 28 70 72 69 6e 74 20 22 tot 0)..(print "
6ce0: 3c 74 61 62 6c 65 20 63 65 6c 6c 73 70 61 63 69 <table cellspaci
6cf0: 6e 67 3d 5c 22 30 5c 22 20 62 6f 72 64 65 72 3d ng=\"0\" border=
6d00: 5c 22 31 5c 22 3e 3c 74 72 3e 3c 74 64 20 63 6f \"1\"><tr><td co
6d10: 6c 73 70 61 6e 3d 5c 22 32 5c 22 3e 3c 68 32 3e lspan=\"2\"><h2>
6d20: 53 74 61 74 75 73 20 73 74 61 74 73 3c 2f 68 32 Status stats</h2
6d30: 3e 3c 2f 74 64 3e 3c 2f 74 72 3e 22 29 0a 09 28 ></td></tr>")..(
6d40: 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 for-each (lambda
6d50: 20 28 73 74 61 74 75 73 29 0a 09 09 20 20 20 20 (status)...
6d60: 28 73 65 74 21 20 74 6f 74 20 28 2b 20 74 6f 74 (set! tot (+ tot
6d70: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
6d80: 20 63 6f 75 6e 74 73 20 73 74 61 74 75 73 29 29 counts status))
6d90: 29 0a 09 09 20 20 20 20 28 70 72 69 6e 74 20 22 )... (print "
6da0: 3c 74 72 3e 3c 74 64 3e 3c 66 6f 6e 74 20 63 6f <tr><td><font co
6db0: 6c 6f 72 3d 5c 22 22 20 28 63 6f 6d 6d 6f 6e 3a lor=\"" (common:
6dc0: 67 65 74 2d 63 6f 6c 6f 72 2d 66 72 6f 6d 2d 73 get-color-from-s
6dd0: 74 61 74 75 73 20 73 74 61 74 75 73 29 20 22 5c tatus status) "\
6de0: 22 3e 22 20 73 74 61 74 75 73 0a 09 09 09 20 20 ">" status....
6df0: 20 22 3c 2f 66 6f 6e 74 3e 3c 2f 74 64 3e 3c 74 "</font></td><t
6e00: 64 3e 22 20 28 68 61 73 68 2d 74 61 62 6c 65 2d d>" (hash-table-
6e10: 72 65 66 20 63 6f 75 6e 74 73 20 73 74 61 74 75 ref counts statu
6e20: 73 29 20 22 3c 2f 74 64 3e 3c 2f 74 72 3e 22 29 s) "</td></tr>")
6e30: 29 0a 09 09 20 20 28 68 61 73 68 2d 74 61 62 6c )... (hash-tabl
6e40: 65 2d 6b 65 79 73 20 63 6f 75 6e 74 73 29 29 0a e-keys counts)).
6e50: 09 28 70 72 69 6e 74 20 22 3c 74 72 3e 3c 74 64 .(print "<tr><td
6e60: 3e 54 6f 74 61 6c 3c 2f 74 64 3e 3c 74 64 3e 22 >Total</td><td>"
6e70: 20 74 6f 74 20 22 3c 2f 74 64 3e 3c 2f 74 72 3e tot "</td></tr>
6e80: 3c 2f 74 61 62 6c 65 3e 22 29 0a 09 28 70 72 69 </table>")..(pri
6e90: 6e 74 20 22 3c 2f 74 64 3e 3c 2f 74 64 3e 3c 2f nt "</td></td></
6ea0: 74 72 3e 3c 2f 74 61 62 6c 65 3e 22 29 0a 09 0a tr></table>")...
6eb0: 09 28 70 72 69 6e 74 20 22 3c 74 61 62 6c 65 20 .(print "<table
6ec0: 63 65 6c 6c 73 70 61 63 69 6e 67 3d 5c 22 30 5c cellspacing=\"0\
6ed0: 22 20 62 6f 72 64 65 72 3d 5c 22 31 5c 22 3e 22 " border=\"1\">"
6ee0: 20 0a 09 20 20 20 20 20 20 20 22 3c 74 72 3e 3c .. "<tr><
6ef0: 74 64 3e 49 74 65 6d 3c 2f 74 64 3e 3c 74 64 3e td>Item</td><td>
6f00: 53 74 61 74 65 3c 2f 74 64 3e 3c 74 64 3e 53 74 State</td><td>St
6f10: 61 74 75 73 3c 2f 74 64 3e 3c 74 64 3e 43 6f 6d atus</td><td>Com
6f20: 6d 65 6e 74 3c 2f 74 64 3e 22 0a 09 20 20 20 20 ment</td>"..
6f30: 20 20 20 6f 75 74 74 78 74 20 22 3c 2f 74 61 62 outtxt "</tab
6f40: 6c 65 3e 3c 2f 62 6f 64 79 3e 3c 2f 68 74 6d 6c le></body></html
6f50: 3e 22 29 0a 09 3b 3b 20 28 72 65 6c 65 61 73 65 >")..;; (release
6f60: 2d 64 6f 74 2d 6c 6f 63 6b 20 6f 75 74 70 75 74 -dot-lock output
6f70: 66 69 6c 65 6e 61 6d 65 29 0a 09 3b 3b 28 72 6d filename)..;;(rm
6f80: 74 3a 75 70 64 61 74 65 2d 72 75 6e 2d 73 74 61 t:update-run-sta
6f90: 74 73 20 0a 09 3b 3b 20 72 75 6e 2d 69 64 0a 09 ts ..;; run-id..
6fa0: 3b 3b 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6d ;; (hash-table-m
6fb0: 61 70 0a 09 3b 3b 20 20 73 74 61 74 65 2d 73 74 ap..;; state-st
6fc0: 61 74 75 73 2d 63 6f 75 6e 74 73 0a 09 3b 3b 20 atus-counts..;;
6fd0: 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 20 76 61 (lambda (key va
6fe0: 6c 29 0a 09 3b 3b 09 28 61 70 70 65 6e 64 20 6b l)..;;.(append k
6ff0: 65 79 20 28 6c 69 73 74 20 76 61 6c 29 29 29 29 ey (list val))))
7000: 29 0a 09 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 )..))))..(define
7010: 20 74 65 73 74 73 3a 63 73 73 2d 6a 73 63 72 69 tests:css-jscri
7020: 70 74 2d 62 6c 6f 63 6b 0a 23 3c 3c 45 4f 46 0a pt-block.#<<EOF.
7030: 3c 73 74 79 6c 65 20 74 79 70 65 3d 22 74 65 78 <style type="tex
7040: 74 2f 63 73 73 22 3e 0a 75 6c 2e 4c 69 6e 6b 65 t/css">.ul.Linke
7050: 64 4c 69 73 74 20 7b 20 64 69 73 70 6c 61 79 3a dList { display:
7060: 20 62 6c 6f 63 6b 3b 20 7d 0a 2f 2a 20 75 6c 2e block; }./* ul.
7070: 4c 69 6e 6b 65 64 4c 69 73 74 20 75 6c 20 7b 20 LinkedList ul {
7080: 64 69 73 70 6c 61 79 3a 20 6e 6f 6e 65 3b 20 7d display: none; }
7090: 20 2a 2f 0a 2e 48 61 6e 64 43 75 72 73 6f 72 53 */..HandCursorS
70a0: 74 79 6c 65 20 7b 20 63 75 72 73 6f 72 3a 20 70 tyle { cursor: p
70b0: 6f 69 6e 74 65 72 3b 20 63 75 72 73 6f 72 3a 20 ointer; cursor:
70c0: 68 61 6e 64 3b 20 7d 20 20 2f 2a 20 46 6f 72 20 hand; } /* For
70d0: 49 45 20 2a 2f 0a 74 68 20 7b 62 61 63 6b 67 72 IE */.th {backgr
70e0: 6f 75 6e 64 2d 63 6f 6c 6f 72 3a 20 23 38 63 38 ound-color: #8c8
70f0: 63 38 63 3b 7d 0a 74 64 2e 74 65 73 74 20 7b 62 c8c;}.td.test {b
7100: 61 63 6b 67 72 6f 75 6e 64 2d 63 6f 6c 6f 72 3a ackground-color:
7110: 20 23 64 39 64 62 64 64 3b 7d 0a 74 64 2e 50 41 #d9dbdd;}.td.PA
7120: 53 53 20 7b 62 61 63 6b 67 72 6f 75 6e 64 2d 63 SS {background-c
7130: 6f 6c 6f 72 3a 20 23 33 34 37 35 33 33 3b 7d 0a olor: #347533;}.
7140: 74 64 2e 46 41 49 4c 20 7b 62 61 63 6b 67 72 6f td.FAIL {backgro
7150: 75 6e 64 2d 63 6f 6c 6f 72 3a 20 23 63 63 32 38 und-color: #cc28
7160: 31 32 3b 7d 0a 74 64 2e 53 4b 49 50 7b 62 61 63 12;}.td.SKIP{bac
7170: 6b 67 72 6f 75 6e 64 2d 63 6f 6c 6f 72 3a 20 23 kground-color: #
7180: 46 46 44 37 33 33 3b 7d 0a 74 64 2e 57 41 52 4e FFD733;}.td.WARN
7190: 20 7b 62 61 63 6b 67 72 6f 75 6e 64 2d 63 6f 6c {background-col
71a0: 6f 72 3a 20 23 45 41 38 37 32 34 3b 7d 0a 74 64 or: #EA8724;}.td
71b0: 2e 57 41 49 56 45 44 20 7b 62 61 63 6b 67 72 6f .WAIVED {backgro
71c0: 75 6e 64 2d 63 6f 6c 6f 72 3a 20 23 38 33 38 41 und-color: #838A
71d0: 31 32 3b 7d 0a 74 64 2e 41 42 4f 52 54 7b 62 61 12;}.td.ABORT{ba
71e0: 63 6b 67 72 6f 75 6e 64 2d 63 6f 6c 6f 72 3a 20 ckground-color:
71f0: 23 45 41 32 34 42 37 3b 7d 0a 2e 50 41 53 53 20 #EA24B7;}..PASS
7200: 2e 6c 69 6e 6b 2c 20 2e 53 4b 49 50 20 2e 6c 69 .link, .SKIP .li
7210: 6e 6b 2c 20 2e 57 41 52 4e 20 2e 6c 69 6e 6b 2c nk, .WARN .link,
7220: 2e 57 41 49 56 45 44 20 2e 6c 69 6e 6b 2c 2e 41 .WAIVED .link,.A
7230: 42 4f 52 54 20 2e 6c 69 6e 6b 2c 20 2e 46 41 49 BORT .link, .FAI
7240: 4c 20 2e 6c 69 6e 6b 7b 63 6f 6c 6f 72 3a 20 23 L .link{color: #
7250: 46 46 46 46 46 46 3b 7d 0a 0a 0a 3c 2f 73 74 79 FFFFFF;}...</sty
7260: 6c 65 3e 0a 0a 0a 20 20 3c 73 63 72 69 70 74 20 le>... <script
7270: 74 79 70 65 3d 22 74 65 78 74 2f 4a 61 76 61 53 type="text/JavaS
7280: 63 72 69 70 74 22 3e 0a 0a 20 20 20 20 66 75 6e cript">.. fun
7290: 63 74 69 6f 6e 20 66 69 6c 74 65 72 73 6f 6d 65 ction filtersome
72a0: 28 29 20 7b 0a 20 20 24 28 22 74 72 22 29 2e 73 () {. $("tr").s
72b0: 68 6f 77 28 29 3b 0a 20 20 24 28 22 2e 74 65 73 how();. $(".tes
72c0: 74 22 29 2e 66 69 6c 74 65 72 28 0a 20 20 20 20 t").filter(.
72d0: 66 75 6e 63 74 69 6f 6e 28 29 20 7b 0a 20 20 20 function() {.
72e0: 20 20 20 76 61 72 20 6e 61 6d 65 73 20 3d 20 24 var names = $
72f0: 28 27 23 74 65 73 74 6e 61 6d 65 27 29 2e 76 61 ('#testname').va
7300: 6c 28 29 2e 73 70 6c 69 74 28 27 2c 27 29 3b 0a l().split(',');.
7310: 20 20 20 20 20 20 76 61 72 20 67 6f 6f 64 3d 31 var good=1
7320: 3b 0a 20 20 20 20 20 20 66 6f 72 20 28 76 61 72 ;. for (var
7330: 20 69 3d 30 2c 20 6c 65 6e 3d 6e 61 6d 65 73 2e i=0, len=names.
7340: 6c 65 6e 67 74 68 3b 20 69 3c 6c 65 6e 3b 20 69 length; i<len; i
7350: 2b 2b 29 20 7b 0a 20 20 20 20 20 20 20 20 76 61 ++) {. va
7360: 72 20 75 6e 61 6d 65 3d 6e 61 6d 65 73 5b 69 5d r uname=names[i]
7370: 3b 0a 20 20 20 20 20 20 20 20 63 6f 6e 73 6f 6c ;. consol
7380: 65 2e 6c 6f 67 28 22 54 72 79 69 6e 67 20 74 6f e.log("Trying to
7390: 20 63 68 65 63 6b 20 66 6f 72 20 22 20 2b 20 75 check for " + u
73a0: 6e 61 6d 65 29 3b 20 0a 20 20 20 20 20 20 20 20 name); .
73b0: 69 66 28 24 28 74 68 69 73 29 2e 74 65 78 74 28 if($(this).text(
73c0: 29 2e 69 6e 64 65 78 4f 66 28 75 6e 61 6d 65 29 ).indexOf(uname)
73d0: 20 21 3d 20 2d 31 29 20 7b 0a 20 20 20 20 20 20 != -1) {.
73e0: 20 20 20 20 67 6f 6f 64 3d 20 30 3b 0a 20 20 20 good= 0;.
73f0: 20 20 20 20 20 20 20 63 6f 6e 73 6f 6c 65 2e 6c console.l
7400: 6f 67 28 22 46 6f 75 6e 64 20 22 2b 75 6e 61 6d og("Found "+unam
7410: 65 29 3b 0a 20 20 20 20 20 20 20 20 7d 0a 20 20 e);. }.
7420: 20 20 20 20 7d 0a 20 20 20 20 20 20 72 65 74 75 }. retu
7430: 72 6e 20 67 6f 6f 64 3b 20 0a 20 20 20 20 7d 0a rn good; . }.
7440: 20 20 29 2e 70 61 72 65 6e 74 28 29 2e 68 69 64 ).parent().hid
7450: 65 28 29 3b 0a 2f 2f 20 20 24 28 22 2e 73 75 6d e();.// $(".sum
7460: 22 29 2e 73 68 6f 77 28 29 3b 0a 7d 0a 20 20 0a ").show();.}. .
7470: 20 20 20 20 2f 2f 20 41 64 64 20 74 68 69 73 20 // Add this
7480: 74 6f 20 74 68 65 20 6f 6e 6c 6f 61 64 20 65 76 to the onload ev
7490: 65 6e 74 20 6f 66 20 74 68 65 20 42 4f 44 59 20 ent of the BODY
74a0: 65 6c 65 6d 65 6e 74 0a 20 20 20 20 66 75 6e 63 element. func
74b0: 74 69 6f 6e 20 61 64 64 45 76 65 6e 74 73 28 29 tion addEvents()
74c0: 20 7b 0a 20 20 20 20 20 20 61 63 74 69 76 61 74 {. activat
74d0: 65 54 72 65 65 28 64 6f 63 75 6d 65 6e 74 2e 67 eTree(document.g
74e0: 65 74 45 6c 65 6d 65 6e 74 42 79 49 64 28 22 4c etElementById("L
74f0: 69 6e 6b 65 64 4c 69 73 74 31 22 29 29 3b 0a 20 inkedList1"));.
7500: 20 20 20 7d 0a 0a 20 20 20 20 2f 2f 20 54 68 69 }.. // Thi
7510: 73 20 66 75 6e 63 74 69 6f 6e 20 74 72 61 76 65 s function trave
7520: 72 73 65 73 20 74 68 65 20 6c 69 73 74 20 61 6e rses the list an
7530: 64 20 61 64 64 20 6c 69 6e 6b 73 20 0a 20 20 20 d add links .
7540: 20 2f 2f 20 74 6f 20 6e 65 73 74 65 64 20 6c 69 // to nested li
7550: 73 74 20 69 74 65 6d 73 0a 20 20 20 20 66 75 6e st items. fun
7560: 63 74 69 6f 6e 20 61 63 74 69 76 61 74 65 54 72 ction activateTr
7570: 65 65 28 6f 4c 69 73 74 29 20 7b 0a 20 20 20 20 ee(oList) {.
7580: 20 20 2f 2f 20 43 6f 6c 6c 61 70 73 65 20 74 68 // Collapse th
7590: 65 20 74 72 65 65 0a 20 20 20 20 20 20 66 6f 72 e tree. for
75a0: 20 28 76 61 72 20 69 3d 30 3b 20 69 20 3c 20 6f (var i=0; i < o
75b0: 4c 69 73 74 2e 67 65 74 45 6c 65 6d 65 6e 74 73 List.getElements
75c0: 42 79 54 61 67 4e 61 6d 65 28 22 75 6c 22 29 2e ByTagName("ul").
75d0: 6c 65 6e 67 74 68 3b 20 69 2b 2b 29 20 7b 0a 20 length; i++) {.
75e0: 20 20 20 20 20 20 20 6f 4c 69 73 74 2e 67 65 74 oList.get
75f0: 45 6c 65 6d 65 6e 74 73 42 79 54 61 67 4e 61 6d ElementsByTagNam
7600: 65 28 22 75 6c 22 29 5b 69 5d 2e 73 74 79 6c 65 e("ul")[i].style
7610: 2e 64 69 73 70 6c 61 79 3d 22 6e 6f 6e 65 22 3b .display="none";
7620: 20 20 20 20 20 20 20 20 20 20 20 20 0a 20 20 20 .
7630: 20 20 20 7d 20 20 20 20 20 20 20 20 20 20 20 20 }
7640: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7650: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7660: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7670: 20 20 20 20 20 20 0a 20 20 20 20 20 20 2f 2f 20 . //
7680: 41 64 64 20 74 68 65 20 63 6c 69 63 6b 2d 65 76 Add the click-ev
7690: 65 6e 74 20 68 61 6e 64 6c 65 72 20 74 6f 20 74 ent handler to t
76a0: 68 65 20 6c 69 73 74 20 69 74 65 6d 73 0a 20 20 he list items.
76b0: 20 20 20 20 69 66 20 28 6f 4c 69 73 74 2e 61 64 if (oList.ad
76c0: 64 45 76 65 6e 74 4c 69 73 74 65 6e 65 72 29 20 dEventListener)
76d0: 7b 0a 20 20 20 20 20 20 20 20 6f 4c 69 73 74 2e {. oList.
76e0: 61 64 64 45 76 65 6e 74 4c 69 73 74 65 6e 65 72 addEventListener
76f0: 28 22 63 6c 69 63 6b 22 2c 20 74 6f 67 67 6c 65 ("click", toggle
7700: 42 72 61 6e 63 68 2c 20 66 61 6c 73 65 29 3b 0a Branch, false);.
7710: 20 20 20 20 20 20 7d 20 65 6c 73 65 20 69 66 20 } else if
7720: 28 6f 4c 69 73 74 2e 61 74 74 61 63 68 45 76 65 (oList.attachEve
7730: 6e 74 29 20 7b 20 2f 2f 20 46 6f 72 20 49 45 0a nt) { // For IE.
7740: 20 20 20 20 20 20 20 20 6f 4c 69 73 74 2e 61 74 oList.at
7750: 74 61 63 68 45 76 65 6e 74 28 22 6f 6e 63 6c 69 tachEvent("oncli
7760: 63 6b 22 2c 20 74 6f 67 67 6c 65 42 72 61 6e 63 ck", toggleBranc
7770: 68 29 3b 0a 20 20 20 20 20 20 7d 0a 20 20 20 20 h);. }.
7780: 20 20 2f 2f 20 4d 61 6b 65 20 74 68 65 20 6e 65 // Make the ne
7790: 73 74 65 64 20 69 74 65 6d 73 20 6c 6f 6f 6b 20 sted items look
77a0: 6c 69 6b 65 20 6c 69 6e 6b 73 0a 20 20 20 20 20 like links.
77b0: 20 61 64 64 4c 69 6e 6b 73 54 6f 42 72 61 6e 63 addLinksToBranc
77c0: 68 65 73 28 6f 4c 69 73 74 29 3b 0a 20 20 20 20 hes(oList);.
77d0: 7d 0a 0a 20 20 20 20 2f 2f 20 54 68 69 73 20 69 }.. // This i
77e0: 73 20 74 68 65 20 63 6c 69 63 6b 2d 65 76 65 6e s the click-even
77f0: 74 20 68 61 6e 64 6c 65 72 0a 20 20 20 20 66 75 t handler. fu
7800: 6e 63 74 69 6f 6e 20 74 6f 67 67 6c 65 42 72 61 nction toggleBra
7810: 6e 63 68 28 65 76 65 6e 74 29 20 7b 0a 20 20 20 nch(event) {.
7820: 20 20 20 76 61 72 20 6f 42 72 61 6e 63 68 2c 20 var oBranch,
7830: 63 53 75 62 42 72 61 6e 63 68 65 73 3b 0a 20 20 cSubBranches;.
7840: 20 20 20 20 69 66 20 28 65 76 65 6e 74 2e 74 61 if (event.ta
7850: 72 67 65 74 29 20 7b 0a 20 20 20 20 20 20 20 20 rget) {.
7860: 6f 42 72 61 6e 63 68 20 3d 20 65 76 65 6e 74 2e oBranch = event.
7870: 74 61 72 67 65 74 3b 0a 20 20 20 20 20 20 7d 20 target;. }
7880: 65 6c 73 65 20 69 66 20 28 65 76 65 6e 74 2e 73 else if (event.s
7890: 72 63 45 6c 65 6d 65 6e 74 29 20 7b 20 2f 2f 20 rcElement) { //
78a0: 46 6f 72 20 49 45 0a 20 20 20 20 20 20 20 20 6f For IE. o
78b0: 42 72 61 6e 63 68 20 3d 20 65 76 65 6e 74 2e 73 Branch = event.s
78c0: 72 63 45 6c 65 6d 65 6e 74 3b 0a 20 20 20 20 20 rcElement;.
78d0: 20 7d 0a 20 20 20 20 20 20 63 53 75 62 42 72 61 }. cSubBra
78e0: 6e 63 68 65 73 20 3d 20 6f 42 72 61 6e 63 68 2e nches = oBranch.
78f0: 67 65 74 45 6c 65 6d 65 6e 74 73 42 79 54 61 67 getElementsByTag
7900: 4e 61 6d 65 28 22 75 6c 22 29 3b 0a 20 20 20 20 Name("ul");.
7910: 20 20 69 66 20 28 63 53 75 62 42 72 61 6e 63 68 if (cSubBranch
7920: 65 73 2e 6c 65 6e 67 74 68 20 3e 20 30 29 20 7b es.length > 0) {
7930: 0a 20 20 20 20 20 20 20 20 69 66 20 28 63 53 75 . if (cSu
7940: 62 42 72 61 6e 63 68 65 73 5b 30 5d 2e 73 74 79 bBranches[0].sty
7950: 6c 65 2e 64 69 73 70 6c 61 79 20 3d 3d 20 22 62 le.display == "b
7960: 6c 6f 63 6b 22 29 20 7b 0a 20 20 20 20 20 20 20 lock") {.
7970: 20 20 20 63 53 75 62 42 72 61 6e 63 68 65 73 5b cSubBranches[
7980: 30 5d 2e 73 74 79 6c 65 2e 64 69 73 70 6c 61 79 0].style.display
7990: 20 3d 20 22 6e 6f 6e 65 22 3b 0a 20 20 20 20 20 = "none";.
79a0: 20 20 20 7d 20 65 6c 73 65 20 7b 0a 20 20 20 20 } else {.
79b0: 20 20 20 20 20 20 63 53 75 62 42 72 61 6e 63 68 cSubBranch
79c0: 65 73 5b 30 5d 2e 73 74 79 6c 65 2e 64 69 73 70 es[0].style.disp
79d0: 6c 61 79 20 3d 20 22 62 6c 6f 63 6b 22 3b 0a 20 lay = "block";.
79e0: 20 20 20 20 20 20 20 7d 0a 20 20 20 20 20 20 7d }. }
79f0: 0a 20 20 20 20 7d 0a 0a 20 20 20 20 2f 2f 20 54 . }.. // T
7a00: 68 69 73 20 66 75 6e 63 74 69 6f 6e 20 6d 61 6b his function mak
7a10: 65 73 20 6e 65 73 74 65 64 20 6c 69 73 74 20 69 es nested list i
7a20: 74 65 6d 73 20 6c 6f 6f 6b 20 6c 69 6b 65 20 6c tems look like l
7a30: 69 6e 6b 73 0a 20 20 20 20 66 75 6e 63 74 69 6f inks. functio
7a40: 6e 20 61 64 64 4c 69 6e 6b 73 54 6f 42 72 61 6e n addLinksToBran
7a50: 63 68 65 73 28 6f 4c 69 73 74 29 20 7b 0a 20 20 ches(oList) {.
7a60: 20 20 20 20 76 61 72 20 63 42 72 61 6e 63 68 65 var cBranche
7a70: 73 20 3d 20 6f 4c 69 73 74 2e 67 65 74 45 6c 65 s = oList.getEle
7a80: 6d 65 6e 74 73 42 79 54 61 67 4e 61 6d 65 28 22 mentsByTagName("
7a90: 6c 69 22 29 3b 0a 20 20 20 20 20 20 76 61 72 20 li");. var
7aa0: 69 2c 20 6e 2c 20 63 53 75 62 42 72 61 6e 63 68 i, n, cSubBranch
7ab0: 65 73 3b 0a 20 20 20 20 20 20 69 66 20 28 63 42 es;. if (cB
7ac0: 72 61 6e 63 68 65 73 2e 6c 65 6e 67 74 68 20 3e ranches.length >
7ad0: 20 30 29 20 7b 0a 20 20 20 20 20 20 20 20 66 6f 0) {. fo
7ae0: 72 20 28 69 3d 30 2c 20 6e 20 3d 20 63 42 72 61 r (i=0, n = cBra
7af0: 6e 63 68 65 73 2e 6c 65 6e 67 74 68 3b 20 69 20 nches.length; i
7b00: 3c 20 6e 3b 20 69 2b 2b 29 20 7b 0a 20 20 20 20 < n; i++) {.
7b10: 20 20 20 20 20 20 63 53 75 62 42 72 61 6e 63 68 cSubBranch
7b20: 65 73 20 3d 20 63 42 72 61 6e 63 68 65 73 5b 69 es = cBranches[i
7b30: 5d 2e 67 65 74 45 6c 65 6d 65 6e 74 73 42 79 54 ].getElementsByT
7b40: 61 67 4e 61 6d 65 28 22 75 6c 22 29 3b 0a 20 20 agName("ul");.
7b50: 20 20 20 20 20 20 20 20 69 66 20 28 63 53 75 62 if (cSub
7b60: 42 72 61 6e 63 68 65 73 2e 6c 65 6e 67 74 68 20 Branches.length
7b70: 3e 20 30 29 20 7b 0a 20 20 20 20 20 20 20 20 20 > 0) {.
7b80: 20 20 20 61 64 64 4c 69 6e 6b 73 54 6f 42 72 61 addLinksToBra
7b90: 6e 63 68 65 73 28 63 53 75 62 42 72 61 6e 63 68 nches(cSubBranch
7ba0: 65 73 5b 30 5d 29 3b 0a 20 20 20 20 20 20 20 20 es[0]);.
7bb0: 20 20 20 20 63 42 72 61 6e 63 68 65 73 5b 69 5d cBranches[i]
7bc0: 2e 63 6c 61 73 73 4e 61 6d 65 20 3d 20 22 48 61 .className = "Ha
7bd0: 6e 64 43 75 72 73 6f 72 53 74 79 6c 65 22 3b 0a ndCursorStyle";.
7be0: 20 20 20 20 20 20 20 20 20 20 20 20 63 42 72 61 cBra
7bf0: 6e 63 68 65 73 5b 69 5d 2e 73 74 79 6c 65 2e 63 nches[i].style.c
7c00: 6f 6c 6f 72 20 3d 20 22 62 6c 75 65 22 3b 0a 20 olor = "blue";.
7c10: 20 20 20 20 20 20 20 20 20 20 20 63 53 75 62 42 cSubB
7c20: 72 61 6e 63 68 65 73 5b 30 5d 2e 73 74 79 6c 65 ranches[0].style
7c30: 2e 63 6f 6c 6f 72 20 3d 20 22 62 6c 61 63 6b 22 .color = "black"
7c40: 3b 0a 20 20 20 20 20 20 20 20 20 20 20 20 63 53 ;. cS
7c50: 75 62 42 72 61 6e 63 68 65 73 5b 30 5d 2e 73 74 ubBranches[0].st
7c60: 79 6c 65 2e 63 75 72 73 6f 72 20 3d 20 22 61 75 yle.cursor = "au
7c70: 74 6f 22 3b 0a 20 20 20 20 20 20 20 20 20 20 7d to";. }
7c80: 0a 20 20 20 20 20 20 20 20 7d 0a 20 20 20 20 20 . }.
7c90: 20 7d 0a 20 20 20 20 7d 0a 20 20 3c 2f 73 63 72 }. }. </scr
7ca0: 69 70 74 3e 0a 45 4f 46 0a 29 0a 0a 28 64 65 66 ipt>.EOF.)..(def
7cb0: 69 6e 65 20 74 65 73 74 73 3a 63 73 73 2d 6a 73 ine tests:css-js
7cc0: 63 72 69 70 74 2d 62 6c 6f 63 6b 2d 64 79 6e 61 cript-block-dyna
7cd0: 6d 69 63 20 0a 23 3c 3c 45 4f 46 0a 20 20 20 20 mic .#<<EOF.
7ce0: 20 20 20 20 20 20 20 3c 73 63 72 69 70 74 20 73 <script s
7cf0: 72 63 3d 20 2e 2f 6a 71 75 65 72 79 33 2e 31 2e rc= ./jquery3.1.
7d00: 30 2e 6a 73 3e 3c 2f 73 63 72 69 70 74 3e 20 0a 0.js></script> .
7d10: 45 4f 46 0a 29 0a 0a 28 64 65 66 69 6e 65 20 20 EOF.)..(define
7d20: 28 74 65 73 74 3a 6a 73 2d 62 6c 6f 63 6b 20 6a (test:js-block j
7d30: 61 76 61 73 63 72 69 70 74 2d 6c 69 62 29 0a 20 avascript-lib).
7d40: 20 20 28 63 6f 6e 63 20 20 22 3c 73 63 72 69 70 (conc "<scrip
7d50: 74 20 73 72 63 3d 22 20 6a 61 76 61 73 63 72 69 t src=" javascri
7d60: 70 74 2d 6c 69 62 20 22 3e 3c 2f 73 63 72 69 70 pt-lib "></scrip
7d70: 74 3e 22 20 29 29 0a 0a 0a 28 64 65 66 69 6e 65 t>" ))...(define
7d80: 20 74 65 73 74 73 3a 63 73 73 2d 6a 73 63 72 69 tests:css-jscri
7d90: 70 74 2d 62 6c 6f 63 6b 2d 73 74 61 74 69 63 20 pt-block-static
7da0: 28 74 65 73 74 3a 6a 73 2d 62 6c 6f 63 6b 20 2a (test:js-block *
7db0: 6a 61 76 61 2d 73 63 72 69 70 74 2d 6c 69 62 2a java-script-lib*
7dc0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 ))..(define (tes
7dd0: 74 73 3a 63 73 73 2d 6a 73 63 72 69 70 74 2d 62 ts:css-jscript-b
7de0: 6c 6f 63 6b 2d 63 6f 6e 64 20 64 79 6e 61 6d 69 lock-cond dynami
7df0: 63 29 20 0a 20 20 20 20 20 20 28 69 66 20 28 65 c) . (if (e
7e00: 71 75 61 6c 3f 20 64 79 6e 61 6d 69 63 20 20 23 qual? dynamic #
7e10: 74 29 0a 20 20 20 20 20 20 20 74 65 73 74 73 3a t). tests:
7e20: 63 73 73 2d 6a 73 63 72 69 70 74 2d 62 6c 6f 63 css-jscript-bloc
7e30: 6b 2d 64 79 6e 61 6d 69 63 0a 20 20 20 20 20 20 k-dynamic.
7e40: 20 74 65 73 74 73 3a 63 73 73 2d 6a 73 63 72 69 tests:css-jscri
7e50: 70 74 2d 62 6c 6f 63 6b 2d 73 74 61 74 69 63 29 pt-block-static)
7e60: 29 0a 0a 20 20 20 20 20 20 20 0a 28 64 65 66 69 ).. .(defi
7e70: 6e 65 20 28 74 65 73 74 73 3a 72 75 6e 2d 72 65 ne (tests:run-re
7e80: 63 6f 72 64 2d 3e 74 65 73 74 2d 70 61 74 68 20 cord->test-path
7e90: 72 75 6e 20 6e 75 6d 6b 65 79 73 29 0a 20 20 20 run numkeys).
7ea0: 28 61 70 70 65 6e 64 20 28 74 61 6b 65 20 28 76 (append (take (v
7eb0: 65 63 74 6f 72 2d 3e 6c 69 73 74 20 72 75 6e 29 ector->list run)
7ec0: 20 6e 75 6d 6b 65 79 73 29 0a 09 20 20 20 28 6c numkeys).. (l
7ed0: 69 73 74 20 28 76 65 63 74 6f 72 2d 72 65 66 20 ist (vector-ref
7ee0: 72 75 6e 20 28 2b 20 31 20 6e 75 6d 6b 65 79 73 run (+ 1 numkeys
7ef0: 29 29 29 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 )))))...(define
7f00: 28 74 65 73 74 73 3a 67 65 74 2d 72 65 73 74 2d (tests:get-rest-
7f10: 64 61 74 61 20 72 75 6e 73 20 68 65 61 64 65 72 data runs header
7f20: 20 6e 75 6d 6b 65 79 73 29 0a 20 20 20 28 6c 65 numkeys). (le
7f30: 74 20 28 28 72 65 73 68 20 28 6d 61 6b 65 2d 68 t ((resh (make-h
7f40: 61 73 68 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 ash-table))).
7f50: 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 (for-each. (
7f60: 6c 61 6d 62 64 61 20 28 72 75 6e 29 0a 20 20 20 lambda (run).
7f70: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 72 75 6e (let* ((run
7f80: 2d 69 64 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 -id (db:get-valu
7f90: 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 e-by-header run
7fa0: 68 65 61 64 65 72 20 22 69 64 22 29 29 0a 20 20 header "id")).
7fb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 75 (ru
7fc0: 6e 2d 64 69 72 20 20 20 20 20 20 28 74 65 73 74 n-dir (test
7fd0: 73 3a 72 75 6e 2d 72 65 63 6f 72 64 2d 3e 74 65 s:run-record->te
7fe0: 73 74 2d 70 61 74 68 20 72 75 6e 20 6e 75 6d 6b st-path run numk
7ff0: 65 79 73 29 29 0a 09 20 20 20 20 20 20 20 28 74 eys)).. (t
8000: 65 73 74 2d 64 61 74 61 20 20 20 20 28 72 6d 74 est-data (rmt
8010: 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 :get-tests-for-r
8020: 75 6e 0a 09 09 09 09 20 20 20 72 75 6e 2d 69 64 un..... run-id
8030: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
8040: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8050: 20 20 20 20 22 25 22 20 20 20 20 20 20 20 3b 3b "%" ;;
8060: 20 74 65 73 74 6e 61 6d 65 70 61 74 74 0a 09 09 testnamepatt...
8070: 09 09 20 20 20 27 28 29 20 20 20 20 20 20 20 20 .. '()
8080: 3b 3b 20 73 74 61 74 65 73 0a 09 09 09 09 20 20 ;; states.....
8090: 20 27 28 29 20 20 20 20 20 20 20 20 3b 3b 20 73 '() ;; s
80a0: 74 61 74 75 73 65 73 0a 09 09 09 09 20 20 20 23 tatuses..... #
80b0: 66 20 20 20 20 20 20 20 20 20 3b 3b 20 6f 66 66 f ;; off
80c0: 73 65 74 0a 09 09 09 09 20 20 20 23 66 20 20 20 set..... #f
80d0: 20 20 20 20 20 20 3b 3b 20 6e 75 6d 2d 74 6f 2d ;; num-to-
80e0: 67 65 74 0a 09 09 09 09 20 20 20 23 66 20 20 20 get..... #f
80f0: 20 20 20 20 20 20 3b 3b 20 68 69 64 65 2f 6e 6f ;; hide/no
8100: 74 2d 68 69 64 65 0a 09 09 09 09 20 20 20 23 66 t-hide..... #f
8110: 20 20 20 20 20 20 20 20 20 3b 3b 20 73 6f 72 74 ;; sort
8120: 2d 62 79 0a 09 09 09 09 20 20 20 23 66 20 20 20 -by..... #f
8130: 20 20 20 20 20 20 3b 3b 20 73 6f 72 74 2d 6f 72 ;; sort-or
8140: 64 65 72 0a 09 09 09 09 20 20 20 23 66 20 20 20 der..... #f
8150: 20 20 20 20 20 20 3b 3b 20 27 73 68 6f 72 74 6c ;; 'shortl
8160: 69 73 74 20 20 20 20 20 20 20 20 20 20 20 20 20 ist
8170: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b ;;
8180: 20 71 72 79 74 79 70 65 0a 20 20 20 20 20 20 20 qrytype.
8190: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
81a0: 20 20 20 20 20 20 20 20 20 20 20 20 30 20 20 20 0
81b0: 20 20 20 20 20 20 3b 3b 20 6c 61 73 74 20 75 70 ;; last up
81c0: 64 61 74 65 0a 09 09 09 09 20 20 20 23 66 29 29 date..... #f))
81d0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 0a 20 ). .
81e0: 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 70 20 (map
81f0: 28 6c 61 6d 62 64 61 20 28 74 65 73 74 29 0a 20 (lambda (test).
8200: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8210: 28 6c 65 74 2a 20 28 28 74 65 73 74 2d 6e 61 6d (let* ((test-nam
8220: 65 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 65 e (vector-ref te
8230: 73 74 20 32 29 29 0a 20 20 20 20 20 20 20 20 20 st 2)).
8240: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
8250: 74 65 73 74 2d 68 74 6d 6c 2d 70 61 74 68 20 28 test-html-path (
8260: 63 6f 6e 63 20 28 76 65 63 74 6f 72 2d 72 65 66 conc (vector-ref
8270: 20 74 65 73 74 20 31 30 29 20 22 2f 22 20 28 76 test 10) "/" (v
8280: 65 63 74 6f 72 2d 72 65 66 20 74 65 73 74 20 31 ector-ref test 1
8290: 33 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 3))).
82a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 74 65 (te
82b0: 73 74 2d 69 74 65 6d 20 28 63 6f 6e 63 20 74 65 st-item (conc te
82c0: 73 74 2d 6e 61 6d 65 20 22 3a 22 20 28 76 65 63 st-name ":" (vec
82d0: 74 6f 72 2d 72 65 66 20 74 65 73 74 20 31 31 29 tor-ref test 11)
82e0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
82f0: 20 20 20 20 20 20 20 20 20 20 20 28 74 65 73 74 (test
8300: 2d 73 74 61 74 75 73 20 28 76 65 63 74 6f 72 2d -status (vector-
8310: 72 65 66 20 74 65 73 74 20 34 29 29 29 0a 20 20 ref test 4))).
8320: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8330: 20 20 20 20 20 20 20 0a 20 20 20 20 20 20 20 20 .
8340: 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 (if (not
8350: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
8360: 2f 64 65 66 61 75 6c 74 20 72 65 73 68 20 74 65 /default resh te
8370: 73 74 2d 6e 61 6d 65 20 20 23 66 29 29 0a 20 20 st-name #f)).
8380: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8390: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
83a0: 73 65 74 21 20 72 65 73 68 20 74 65 73 74 2d 6e set! resh test-n
83b0: 61 6d 65 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 ame (make-hash
83c0: 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 20 20 20 -table))).
83d0: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e (if (n
83e0: 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 ot (hash-table-r
83f0: 65 66 2f 64 65 66 61 75 6c 74 20 28 68 61 73 68 ef/default (hash
8400: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
8410: 6c 74 20 72 65 73 68 20 74 65 73 74 2d 6e 61 6d lt resh test-nam
8420: 65 20 20 23 66 29 20 20 74 65 73 74 2d 69 74 65 e #f) test-ite
8430: 6d 20 20 23 66 29 29 0a 20 20 20 20 20 20 20 20 m #f)).
8440: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
8450: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
8460: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
8470: 64 65 66 61 75 6c 74 20 72 65 73 68 20 74 65 73 default resh tes
8480: 74 2d 6e 61 6d 65 20 20 23 66 29 20 74 65 73 74 t-name #f) test
8490: 2d 69 74 65 6d 20 20 20 28 6d 61 6b 65 2d 68 61 -item (make-ha
84a0: 73 68 2d 74 61 62 6c 65 29 29 29 20 0a 20 20 20 sh-table))) .
84b0: 20 20 20 20 20 20 20 20 20 20 20 20 28 68 61 73 (has
84c0: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 20 28 68 h-table-set! (h
84d0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
84e0: 66 61 75 6c 74 20 28 68 61 73 68 2d 74 61 62 6c fault (hash-tabl
84f0: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 72 65 e-ref/default re
8500: 73 68 20 74 65 73 74 2d 6e 61 6d 65 20 20 23 66 sh test-name #f
8510: 29 20 74 65 73 74 2d 69 74 65 6d 20 23 66 29 20 ) test-item #f)
8520: 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 74 65 73 run-id (list tes
8530: 74 2d 73 74 61 74 75 73 20 74 65 73 74 2d 68 74 t-status test-ht
8540: 6d 6c 2d 70 61 74 68 29 29 29 29 20 0a 20 20 20 ml-path)))) .
8550: 20 20 20 20 20 74 65 73 74 2d 64 61 74 61 29 29 test-data))
8560: 29 0a 20 20 20 20 20 20 72 75 6e 73 29 0a 20 20 ). runs).
8570: 20 72 65 73 68 29 29 0a 0a 0a 3b 3b 20 74 65 73 resh))...;; tes
8580: 74 73 3a 67 65 6e 72 61 74 65 20 64 61 73 68 62 ts:genrate dashb
8590: 6f 61 72 64 20 62 6f 64 79 20 0a 3b 3b 0a 0a 28 oard body .;;..(
85a0: 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 64 61 define (tests:da
85b0: 73 68 62 6f 61 72 64 2d 62 6f 64 79 20 70 61 67 shboard-body pag
85c0: 65 20 70 67 2d 73 69 7a 65 20 6b 65 79 73 20 6e e pg-size keys n
85d0: 75 6d 6b 65 79 73 20 20 74 6f 74 61 6c 2d 72 75 umkeys total-ru
85e0: 6e 73 20 6c 69 6e 6b 74 72 65 65 20 61 72 65 61 ns linktree area
85f0: 2d 6e 61 6d 65 20 67 65 74 2d 70 72 65 76 2d 6c -name get-prev-l
8600: 69 6e 6b 73 20 67 65 74 2d 6e 65 78 74 2d 6c 69 inks get-next-li
8610: 6e 6b 73 20 66 6c 61 67 20 72 75 6e 2d 70 61 74 nks flag run-pat
8620: 74 20 74 61 72 67 65 74 2d 70 61 74 74 29 0a 20 t target-patt).
8630: 20 28 6c 65 74 2a 20 28 28 73 74 61 72 74 20 28 (let* ((start (
8640: 2a 20 70 61 67 65 20 70 67 2d 73 69 7a 65 29 29 * page pg-size))
8650: 20 0a 09 09 09 09 09 3b 28 72 75 6e 73 64 61 74 ......;(runsdat
8660: 20 20 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e 73 (rmt:get-runs
8670: 20 22 25 22 20 70 67 2d 73 69 7a 65 20 73 74 61 "%" pg-size sta
8680: 72 74 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 rt (map (lambda
8690: 28 78 29 28 6c 69 73 74 20 78 20 22 25 22 29 29 (x)(list x "%"))
86a0: 20 6b 65 79 73 29 29 29 0a 20 20 20 20 20 20 20 keys))).
86b0: 20 20 28 72 75 6e 73 64 61 74 20 20 20 28 72 6d (runsdat (rm
86c0: 74 3a 67 65 74 2d 72 75 6e 73 2d 62 79 2d 70 61 t:get-runs-by-pa
86d0: 74 74 20 20 6b 65 79 73 20 72 75 6e 2d 70 61 74 tt keys run-pat
86e0: 74 20 74 61 72 67 65 74 2d 70 61 74 74 20 73 74 t target-patt st
86f0: 61 72 74 20 70 67 2d 73 69 7a 65 20 23 66 20 30 art pg-size #f 0
8700: 20 73 6f 72 74 2d 6f 72 64 65 72 3a 20 22 64 65 sort-order: "de
8710: 73 63 22 29 29 0a 09 09 09 09 09 3b 20 64 62 3a sc"))......; db:
8720: 67 65 74 2d 72 75 6e 73 2d 62 79 2d 70 61 74 74 get-runs-by-patt
8730: 20 20 20 6b 65 79 73 20 72 75 6e 6e 61 6d 65 70 keys runnamep
8740: 61 74 74 20 74 61 72 67 70 61 74 74 20 6f 66 66 att targpatt off
8750: 73 65 74 20 6c 69 6d 69 74 20 66 69 65 6c 64 73 set limit fields
8760: 20 6c 61 73 74 2d 75 70 64 61 74 65 20 20 20 0a last-update .
8770: 09 20 28 68 65 61 64 65 72 20 20 20 20 28 76 65 . (header (ve
8780: 63 74 6f 72 2d 72 65 66 20 72 75 6e 73 64 61 74 ctor-ref runsdat
8790: 20 30 29 29 0a 09 20 28 72 75 6e 73 20 20 20 20 0)).. (runs
87a0: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 75 (vector-ref ru
87b0: 6e 73 64 61 74 20 31 29 29 0a 20 20 20 20 20 20 nsdat 1)).
87c0: 20 20 20 28 63 74 72 20 30 29 0a 20 20 20 20 20 (ctr 0).
87d0: 20 20 20 20 28 74 65 73 74 2d 72 75 6e 73 2d 68 (test-runs-h
87e0: 61 73 68 20 28 74 65 73 74 73 3a 67 65 74 2d 72 ash (tests:get-r
87f0: 65 73 74 2d 64 61 74 61 20 72 75 6e 73 20 68 65 est-data runs he
8800: 61 64 65 72 20 6e 75 6d 6b 65 79 73 29 29 0a 20 ader numkeys)).
8810: 20 20 20 20 20 20 20 20 28 74 65 73 74 2d 6c 69 (test-li
8820: 73 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b st (hash-table-k
8830: 65 79 73 20 74 65 73 74 2d 72 75 6e 73 2d 68 61 eys test-runs-ha
8840: 73 68 29 29 29 20 0a 20 20 20 20 0a 20 20 20 20 sh))) . .
8850: 28 73 3a 68 74 6d 6c 20 74 65 73 74 73 3a 63 73 (s:html tests:cs
8860: 73 2d 6a 73 63 72 69 70 74 2d 62 6c 6f 63 6b 20 s-jscript-block
8870: 28 74 65 73 74 73 3a 63 73 73 2d 6a 73 63 72 69 (tests:css-jscri
8880: 70 74 2d 62 6c 6f 63 6b 2d 63 6f 6e 64 20 66 6c pt-block-cond fl
8890: 61 67 29 0a 09 20 20 20 20 28 73 3a 74 69 74 6c ag).. (s:titl
88a0: 65 20 22 53 75 6d 6d 61 72 79 20 66 6f 72 20 22 e "Summary for "
88b0: 20 61 72 65 61 2d 6e 61 6d 65 29 0a 09 20 20 20 area-name)..
88c0: 20 28 73 3a 62 6f 64 79 20 27 6f 6e 6c 6f 61 64 (s:body 'onload
88d0: 20 22 61 64 64 45 76 65 6e 74 73 28 29 3b 22 0a "addEvents();".
88e0: 09 09 20 20 20 20 28 67 65 74 2d 70 72 65 76 2d .. (get-prev-
88f0: 6c 69 6e 6b 73 20 70 61 67 65 20 6c 69 6e 6b 74 links page linkt
8900: 72 65 65 29 0a 09 09 20 20 20 20 28 67 65 74 2d ree)... (get-
8910: 6e 65 78 74 2d 6c 69 6e 6b 73 20 70 61 67 65 20 next-links page
8920: 6c 69 6e 6b 74 72 65 65 20 74 6f 74 61 6c 2d 72 linktree total-r
8930: 75 6e 73 29 0a 09 09 20 20 20 20 0a 09 09 20 20 uns)... ...
8940: 20 20 28 73 3a 68 31 20 22 53 75 6d 6d 61 72 79 (s:h1 "Summary
8950: 20 66 6f 72 20 22 20 61 72 65 61 2d 6e 61 6d 65 for " area-name
8960: 29 0a 09 09 20 20 20 20 28 73 3a 68 33 20 22 46 )... (s:h3 "F
8970: 69 6c 74 65 72 22 20 29 0a 09 09 20 20 20 20 28 ilter" )... (
8980: 73 3a 69 6e 70 75 74 20 27 74 79 70 65 20 22 74 s:input 'type "t
8990: 65 78 74 22 20 20 27 6e 61 6d 65 20 22 74 65 73 ext" 'name "tes
89a0: 74 6e 61 6d 65 22 20 27 69 64 20 22 74 65 73 74 tname" 'id "test
89b0: 6e 61 6d 65 22 20 27 6c 65 6e 67 74 68 20 22 33 name" 'length "3
89c0: 30 22 20 27 6f 6e 6b 65 79 75 70 20 22 66 69 6c 0" 'onkeyup "fil
89d0: 74 65 72 73 6f 6d 65 28 29 22 29 0a 09 09 20 20 tersome()")...
89e0: 20 20 3b 3b 20 74 6f 70 20 6c 69 73 74 0a 09 09 ;; top list...
89f0: 20 20 20 20 0a 09 09 20 20 20 20 28 73 3a 74 61 ... (s:ta
8a00: 62 6c 65 20 27 69 64 20 22 4c 69 6e 6b 65 64 4c ble 'id "LinkedL
8a10: 69 73 74 31 22 20 27 62 6f 72 64 65 72 20 22 31 ist1" 'border "1
8a20: 22 20 27 63 65 6c 6c 73 70 61 63 69 6e 67 20 30 " 'cellspacing 0
8a30: 0a 09 09 09 20 20 20 20 20 28 6d 61 70 20 28 6c .... (map (l
8a40: 61 6d 62 64 61 20 28 6b 65 79 29 0a 09 09 09 09 ambda (key).....
8a50: 20 20 20 20 28 6c 65 74 2a 20 28 28 72 65 73 20 (let* ((res
8a60: 28 73 3a 74 72 20 27 63 6c 61 73 73 20 22 73 6f (s:tr 'class "so
8a70: 6d 65 74 68 69 6e 67 22 20 0a 09 09 09 09 09 09 mething" .......
8a80: 20 20 20 20 20 20 28 73 3a 74 68 20 6b 65 79 20 (s:th key
8a90: 29 0a 09 09 09 09 09 09 20 20 20 20 20 20 28 6d )....... (m
8aa0: 61 70 20 28 6c 61 6d 62 64 61 20 28 72 75 6e 29 ap (lambda (run)
8ab0: 0a 09 09 09 09 09 09 09 20 20 20 20 20 28 73 3a ........ (s:
8ac0: 74 68 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 th (vector-ref
8ad0: 72 75 6e 20 63 74 72 29 29 29 0a 09 09 09 09 09 run ctr)))......
8ae0: 09 09 20 20 20 72 75 6e 73 29 29 29 29 0a 09 09 .. runs))))...
8af0: 09 09 20 20 20 20 20 20 28 73 65 74 21 20 63 74 .. (set! ct
8b00: 72 20 28 2b 20 63 74 72 20 31 29 29 0a 09 09 09 r (+ ctr 1))....
8b10: 09 20 20 20 20 20 20 72 65 73 29 29 0a 09 09 09 . res))....
8b20: 09 20 20 6b 65 79 73 29 0a 09 09 09 20 20 20 20 . keys)....
8b30: 20 28 73 3a 74 72 0a 09 09 09 20 20 20 20 20 20 (s:tr....
8b40: 28 73 3a 74 68 20 22 52 75 6e 20 4e 61 6d 65 22 (s:th "Run Name"
8b50: 29 0a 09 09 09 20 20 20 20 20 20 28 6d 61 70 20 ).... (map
8b60: 28 6c 61 6d 62 64 61 20 28 72 75 6e 29 0a 09 09 (lambda (run)...
8b70: 09 09 20 20 20 20 20 28 73 3a 74 68 20 28 64 62 .. (s:th (db
8b80: 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 :get-value-by-he
8b90: 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 ader run header
8ba0: 22 72 75 6e 6e 61 6d 65 22 29 29 29 0a 09 09 09 "runname")))....
8bb0: 09 20 20 20 72 75 6e 73 29 29 0a 09 09 09 20 20 . runs))....
8bc0: 20 20 20 0a 09 09 09 20 20 20 20 20 28 6d 61 70 .... (map
8bd0: 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 2d 6e (lambda (test-n
8be0: 61 6d 65 29 0a 09 09 09 09 20 20 20 20 28 6c 65 ame)..... (le
8bf0: 74 2a 20 28 28 69 74 65 6d 2d 68 61 73 68 20 28 t* ((item-hash (
8c00: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
8c10: 65 66 61 75 6c 74 20 74 65 73 74 2d 72 75 6e 73 efault test-runs
8c20: 2d 68 61 73 68 20 74 65 73 74 2d 6e 61 6d 65 20 -hash test-name
8c30: 20 23 66 29 29 0a 09 09 09 09 09 20 20 20 28 69 #f))...... (i
8c40: 74 65 6d 2d 6b 65 79 73 20 28 73 6f 72 74 20 28 tem-keys (sort (
8c50: 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 hash-table-keys
8c60: 69 74 65 6d 2d 68 61 73 68 29 20 73 74 72 69 6e item-hash) strin
8c70: 67 3c 3d 3f 29 29 29 20 0a 09 09 09 09 20 20 20 g<=?))) .....
8c80: 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 (map (lambda
8c90: 28 69 74 65 6d 2d 6e 61 6d 65 29 20 20 0a 20 20 (item-name) .
8ca0: 09 09 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ..
8cb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
8cc0: 6c 65 74 2a 20 28 28 72 65 73 20 28 73 3a 74 72 let* ((res (s:tr
8cd0: 20 20 27 63 6c 61 73 73 20 69 74 65 6d 2d 6e 61 'class item-na
8ce0: 6d 65 0a 09 09 09 09 09 09 09 09 28 73 3a 74 64 me.........(s:td
8cf0: 20 20 69 74 65 6d 2d 6e 61 6d 65 20 27 63 6c 61 item-name 'cla
8d00: 73 73 20 22 74 65 73 74 22 20 29 0a 09 09 09 09 ss "test" ).....
8d10: 09 09 09 09 28 6d 61 70 20 28 6c 61 6d 62 64 61 ....(map (lambda
8d20: 20 28 72 75 6e 29 0a 09 09 09 09 09 09 09 09 20 (run).........
8d30: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 72 75 (let* ((ru
8d40: 6e 2d 74 65 73 74 20 28 68 61 73 68 2d 74 61 62 n-test (hash-tab
8d50: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 69 le-ref/default i
8d60: 74 65 6d 2d 68 61 73 68 20 69 74 65 6d 2d 6e 61 tem-hash item-na
8d70: 6d 65 20 20 23 66 29 29 0a 09 09 09 09 09 09 09 me #f))........
8d80: 09 09 20 20 20 20 20 20 28 72 75 6e 2d 69 64 20 .. (run-id
8d90: 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 (db:get-value-by
8da0: 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 -header run head
8db0: 65 72 20 22 69 64 22 29 29 0a 09 09 09 09 09 09 er "id")).......
8dc0: 09 09 09 20 20 20 20 20 20 28 72 65 73 75 6c 74 ... (result
8dd0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
8de0: 2f 64 65 66 61 75 6c 74 20 72 75 6e 2d 74 65 73 /default run-tes
8df0: 74 20 72 75 6e 2d 69 64 20 22 6e 2f 61 22 29 29 t run-id "n/a"))
8e00: 0a 09 09 09 09 09 3b 28 72 65 6c 61 74 69 76 65 ......;(relative
8e10: 2d 70 61 74 68 20 28 67 65 74 2d 72 65 6c 61 74 -path (get-relat
8e20: 69 76 65 2d 70 61 74 68 29 29 20 0a 09 09 09 09 ive-path)) .....
8e30: 09 09 09 09 09 20 20 20 20 20 20 28 73 74 61 74 ..... (stat
8e40: 75 73 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 us (if (string?
8e50: 72 65 73 75 6c 74 29 0a 09 09 09 09 09 09 09 09 result).........
8e60: 09 09 09 20 20 72 65 73 75 6c 74 0a 09 09 09 09 ... result.....
8e70: 09 09 09 09 09 09 09 20 20 28 63 61 72 20 72 65 ....... (car re
8e80: 73 75 6c 74 29 29 29 0a 09 09 09 09 09 09 09 09 sult))).........
8e90: 09 20 20 20 20 20 20 28 6c 69 6e 6b 20 28 69 66 . (link (if
8ea0: 20 28 73 74 72 69 6e 67 3f 20 72 65 73 75 6c 74 (string? result
8eb0: 29 0a 09 09 09 09 09 09 09 09 09 09 09 72 65 73 )............res
8ec0: 75 6c 74 0a 09 09 09 09 09 09 09 09 09 09 09 28 ult............(
8ed0: 69 66 20 28 65 71 75 61 6c 3f 20 66 6c 61 67 20 if (equal? flag
8ee0: 23 74 29 20 0a 09 09 09 09 09 09 09 09 09 09 09 #t) ............
8ef0: 20 20 20 20 28 73 3a 61 20 28 63 61 72 20 72 65 (s:a (car re
8f00: 73 75 6c 74 29 20 27 68 72 65 66 20 28 63 6f 6e sult) 'href (con
8f10: 63 20 22 2e 2f 74 65 73 74 5f 6c 6f 67 3f 72 75 c "./test_log?ru
8f20: 6e 69 64 3d 22 20 72 75 6e 2d 69 64 20 22 26 74 nid=" run-id "&t
8f30: 65 73 74 6e 61 6d 65 3d 22 20 20 69 74 65 6d 2d estname=" item-
8f40: 6e 61 6d 65 20 29 29 0a 09 09 09 09 09 09 09 09 name )).........
8f50: 09 09 09 20 20 20 20 28 73 3a 61 20 28 63 61 72 ... (s:a (car
8f60: 20 72 65 73 75 6c 74 29 20 27 68 72 65 66 20 28 result) 'href (
8f70: 73 74 72 69 6e 67 2d 73 75 62 73 74 69 74 75 74 string-substitut
8f80: 65 20 20 28 63 6f 6e 63 20 6c 69 6e 6b 74 72 65 e (conc linktre
8f90: 65 20 22 2f 22 29 20 20 22 22 20 28 63 61 64 72 e "/") "" (cadr
8fa0: 20 72 65 73 75 6c 74 29 20 20 22 2d 22 29 29 29 result) "-")))
8fb0: 29 29 29 0a 09 09 09 09 09 09 09 09 09 20 28 73 ))).......... (s
8fc0: 3a 74 64 20 20 6c 69 6e 6b 20 27 63 6c 61 73 73 :td link 'class
8fd0: 20 73 74 61 74 75 73 29 29 29 0a 09 09 09 09 09 status)))......
8fe0: 09 09 09 20 20 20 20 20 72 75 6e 73 29 29 29 29 ... runs))))
8ff0: 0a 09 09 09 09 09 20 20 20 20 20 20 20 72 65 73 ...... res
9000: 29 29 0a 09 09 09 09 09 20 20 20 69 74 65 6d 2d ))...... item-
9010: 6b 65 79 73 29 29 29 0a 09 09 09 09 20 20 74 65 keys)))..... te
9020: 73 74 2d 6c 69 73 74 29 29 29 29 29 29 20 0a 0a st-list)))))) ..
9030: 3b 3b 20 28 74 65 73 74 73 3a 63 72 65 61 74 65 ;; (tests:create
9040: 2d 68 74 6d 6c 2d 74 72 65 65 20 22 74 65 73 74 -html-tree "test
9050: 2d 69 6e 64 65 78 2e 68 74 6d 6c 22 29 0a 3b 3b -index.html").;;
9060: 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a .(define (tests:
9070: 63 72 65 61 74 65 2d 68 74 6d 6c 2d 74 72 65 65 create-html-tree
9080: 20 6f 75 74 66 29 0a 20 20 28 6c 65 74 2a 20 28 outf). (let* (
9090: 28 6c 6f 63 6b 66 69 6c 65 20 20 28 63 6f 6e 63 (lockfile (conc
90a0: 20 6f 75 74 66 20 22 2e 6c 6f 63 6b 22 29 29 0a outf ".lock")).
90b0: 09 20 28 72 75 6e 73 2d 74 6f 2d 70 72 6f 63 65 . (runs-to-proce
90c0: 73 73 20 27 28 29 29 0a 20 20 20 20 20 20 20 20 ss '()).
90d0: 20 28 6c 69 6e 6b 74 72 65 65 20 20 28 63 6f 6d (linktree (com
90e0: 6d 6f 6e 3a 67 65 74 2d 6c 69 6e 6b 74 72 65 65 mon:get-linktree
90f0: 29 29 0a 20 20 20 20 20 20 20 20 20 28 61 72 65 )). (are
9100: 61 2d 6e 61 6d 65 20 28 63 6f 6d 6d 6f 6e 3a 67 a-name (common:g
9110: 65 74 2d 74 65 73 74 73 75 69 74 65 2d 6e 61 6d et-testsuite-nam
9120: 65 29 29 0a 09 20 28 6b 65 79 73 20 20 20 20 20 e)).. (keys
9130: 20 28 72 6d 74 3a 67 65 74 2d 6b 65 79 73 29 29 (rmt:get-keys))
9140: 0a 09 20 28 6e 75 6d 6b 65 79 73 20 20 20 28 6c .. (numkeys (l
9150: 65 6e 67 74 68 20 6b 65 79 73 29 29 0a 20 20 20 ength keys)).
9160: 20 20 20 20 20 20 28 72 75 6e 2d 70 61 74 74 20 (run-patt
9170: 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (or (args:get-ar
9180: 67 20 22 2d 72 75 6e 2d 70 61 74 74 22 29 0a 09 g "-run-patt")..
9190: 09 20 20 20 20 20 20 20 28 61 72 67 73 3a 67 65 . (args:ge
91a0: 74 2d 61 72 67 20 22 2d 72 75 6e 6e 61 6d 65 22 t-arg "-runname"
91b0: 29 0a 09 09 20 20 20 20 20 20 20 22 25 22 29 29 )... "%"))
91c0: 0a 20 20 20 20 20 20 20 20 20 28 74 61 72 67 65 . (targe
91d0: 74 20 28 6f 72 20 20 28 61 72 67 73 3a 67 65 74 t (or (args:get
91e0: 2d 61 72 67 20 22 2d 74 61 72 67 65 74 2d 70 61 -arg "-target-pa
91f0: 74 74 22 29 20 0a 09 09 20 20 20 20 20 20 28 61 tt") ... (a
9200: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 rgs:get-arg "-ta
9210: 72 67 65 74 22 29 0a 20 20 20 20 20 20 20 20 20 rget").
9220: 20 20 20 20 20 20 20 20 20 20 20 20 20 22 25 22 "%"
9230: 29 29 0a 20 20 20 20 20 20 20 20 20 28 74 61 72 )). (tar
9240: 67 6c 69 73 74 20 28 73 74 72 69 6e 67 2d 73 70 glist (string-sp
9250: 6c 69 74 20 74 61 72 67 65 74 20 22 2f 22 29 29 lit target "/"))
9260: 0a 20 20 20 20 20 20 20 20 20 28 6e 75 6d 74 61 . (numta
9270: 72 67 20 20 28 6c 65 6e 67 74 68 20 74 61 72 67 rg (length targ
9280: 6c 69 73 74 29 29 20 20 0a 20 20 20 20 20 20 20 list)) .
9290: 20 20 28 74 61 72 67 74 77 65 61 6b 65 64 20 28 (targtweaked (
92a0: 69 66 20 28 3e 20 6e 75 6d 6b 65 79 73 20 6e 75 if (> numkeys nu
92b0: 6d 74 61 72 67 29 0a 09 09 09 20 20 28 61 70 70 mtarg).... (app
92c0: 65 6e 64 20 74 61 72 67 6c 69 73 74 20 28 6d 61 end targlist (ma
92d0: 6b 65 2d 6c 69 73 74 20 28 2d 20 6e 75 6d 6b 65 ke-list (- numke
92e0: 79 73 20 6e 75 6d 74 61 72 67 29 20 22 25 22 29 ys numtarg) "%")
92f0: 29 0a 09 09 09 20 20 74 61 72 67 6c 69 73 74 29 ).... targlist)
9300: 29 0a 20 20 20 20 20 20 20 20 20 28 74 61 72 67 ). (targ
9310: 65 74 2d 70 61 74 74 20 28 73 74 72 69 6e 67 2d et-patt (string-
9320: 6a 6f 69 6e 20 74 61 72 67 74 77 65 61 6b 65 64 join targtweaked
9330: 20 22 2f 22 29 29 0a 09 09 09 09 09 3b 28 74 6f "/"))......;(to
9340: 74 61 6c 2d 72 75 6e 73 20 20 28 72 6d 74 3a 67 tal-runs (rmt:g
9350: 65 74 2d 6e 75 6d 2d 72 75 6e 73 20 22 25 22 29 et-num-runs "%")
9360: 29 20 3b 3b 74 68 69 73 20 6e 65 65 64 73 20 74 ) ;;this needs t
9370: 6f 20 62 65 20 63 68 61 6e 67 65 64 20 74 6f 20 o be changed to
9380: 66 69 6c 74 65 72 20 62 79 20 74 61 72 67 65 74 filter by target
9390: 0a 09 20 28 74 6f 74 61 6c 2d 72 75 6e 73 20 28 .. (total-runs (
93a0: 72 6d 74 3a 67 65 74 2d 72 75 6e 73 2d 63 6e 74 rmt:get-runs-cnt
93b0: 2d 62 79 2d 70 61 74 74 20 72 75 6e 2d 70 61 74 -by-patt run-pat
93c0: 74 20 74 61 72 67 65 74 2d 70 61 74 74 20 6b 65 t target-patt ke
93d0: 79 73 20 29 29 20 0a 20 20 20 20 20 20 20 20 20 ys )) .
93e0: 28 70 67 2d 73 69 7a 65 20 31 30 29 29 0a 20 20 (pg-size 10)).
93f0: 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 73 69 (if (common:si
9400: 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 20 6c mple-file-lock l
9410: 6f 63 6b 66 69 6c 65 29 0a 20 20 20 20 20 20 20 ockfile).
9420: 20 28 62 65 67 69 6e 0a 09 09 09 09 09 3b 28 70 (begin......;(p
9430: 72 69 6e 74 20 74 6f 74 61 6c 2d 72 75 6e 73 29 rint total-runs)
9440: 20 20 20 20 0a 09 20 20 28 6c 65 74 20 6c 6f 6f .. (let loo
9450: 70 20 28 28 70 61 67 65 20 30 29 29 0a 09 20 20 p ((page 0))..
9460: 20 20 28 6c 65 74 2a 20 28 28 6f 75 70 20 20 20 (let* ((oup
9470: 20 20 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 6f (open-o
9480: 75 74 70 75 74 2d 66 69 6c 65 20 28 6f 72 20 6f utput-file (or o
9490: 75 74 66 20 28 63 6f 6e 63 20 6c 69 6e 6b 74 72 utf (conc linktr
94a0: 65 65 20 22 2f 70 61 67 65 22 20 70 61 67 65 20 ee "/page" page
94b0: 22 2e 68 74 6d 6c 22 29 29 29 29 0a 09 09 20 20 ".html"))))...
94c0: 20 28 67 65 74 2d 70 72 65 76 2d 6c 69 6e 6b 73 (get-prev-links
94d0: 20 28 6c 61 6d 62 64 61 20 28 70 61 67 65 20 6c (lambda (page l
94e0: 69 6e 6b 74 72 65 65 20 29 20 20 20 0a 09 09 09 inktree ) ....
94f0: 09 20 20 20 20 20 28 6c 65 74 2a 20 28 28 6c 69 . (let* ((li
9500: 6e 6b 20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 nk (if (not (eq
9510: 3f 20 70 61 67 65 20 30 29 29 0a 09 09 09 09 09 ? page 0))......
9520: 09 20 20 20 20 20 20 20 28 73 3a 61 20 22 26 6c . (s:a "&l
9530: 74 3b 26 6c 74 3b 70 72 65 76 22 20 27 68 72 65 t;<prev" 'hre
9540: 66 20 28 63 6f 6e 63 20 20 22 70 61 67 65 22 20 f (conc "page"
9550: 28 2d 20 70 61 67 65 20 31 29 20 22 2e 68 74 6d (- page 1) ".htm
9560: 6c 22 29 29 0a 09 09 09 09 09 09 20 20 20 20 20 l")).......
9570: 20 20 28 73 3a 61 20 22 22 20 27 68 72 65 66 20 (s:a "" 'href
9580: 28 63 6f 6e 63 20 20 20 22 70 61 67 65 22 20 20 (conc "page"
9590: 70 61 67 65 20 22 2e 68 74 6d 6c 22 29 29 29 29 page ".html"))))
95a0: 29 0a 09 09 09 09 20 20 20 20 20 20 20 6c 69 6e )..... lin
95b0: 6b 29 29 29 0a 09 09 20 20 20 28 67 65 74 2d 6e k)))... (get-n
95c0: 65 78 74 2d 6c 69 6e 6b 73 20 28 6c 61 6d 62 64 ext-links (lambd
95d0: 61 20 28 70 61 67 65 20 6c 69 6e 6b 74 72 65 65 a (page linktree
95e0: 20 74 6f 74 61 6c 2d 72 75 6e 73 29 20 20 20 0a total-runs) .
95f0: 09 09 09 09 20 20 20 20 20 28 6c 65 74 2a 20 28 .... (let* (
9600: 28 6c 69 6e 6b 20 20 28 69 66 20 28 3e 20 74 6f (link (if (> to
9610: 74 61 6c 2d 72 75 6e 73 20 28 2b 20 31 30 20 28 tal-runs (+ 10 (
9620: 2a 20 70 61 67 65 20 70 67 2d 73 69 7a 65 29 29 * page pg-size))
9630: 29 0a 09 09 09 09 09 09 20 20 20 20 20 20 20 28 )....... (
9640: 73 3a 61 20 22 6e 65 78 74 26 67 74 3b 26 67 74 s:a "next>>
9650: 3b 22 20 27 68 72 65 66 20 28 63 6f 6e 63 20 20 ;" 'href (conc
9660: 22 70 61 67 65 22 20 20 28 2b 20 70 61 67 65 20 "page" (+ page
9670: 31 29 20 22 2e 68 74 6d 6c 22 29 29 0a 09 09 09 1) ".html"))....
9680: 09 09 09 20 20 20 20 20 20 20 28 73 3a 61 20 22 ... (s:a "
9690: 22 20 27 68 72 65 66 20 28 63 6f 6e 63 20 20 20 " 'href (conc
96a0: 22 70 61 67 65 22 20 70 61 67 65 20 20 22 2e 68 "page" page ".h
96b0: 74 6d 6c 22 29 29 29 29 29 0a 09 09 09 09 20 20 tml"))))).....
96c0: 20 20 20 20 20 6c 69 6e 6b 29 29 29 20 29 0a 09 link))) )..
96d0: 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 74 6f (print "to
96e0: 74 61 6c 20 72 75 6e 73 3a 20 22 20 74 6f 74 61 tal runs: " tota
96f0: 6c 2d 72 75 6e 73 29 20 0a 09 20 20 20 20 20 20 l-runs) ..
9700: 28 73 3a 6f 75 74 70 75 74 2d 6e 65 77 0a 09 20 (s:output-new..
9710: 20 20 20 20 20 20 6f 75 70 0a 09 20 20 20 20 20 oup..
9720: 20 20 28 74 65 73 74 73 3a 64 61 73 68 62 6f 61 (tests:dashboa
9730: 72 64 2d 62 6f 64 79 20 70 61 67 65 20 70 67 2d rd-body page pg-
9740: 73 69 7a 65 20 6b 65 79 73 20 6e 75 6d 6b 65 79 size keys numkey
9750: 73 20 74 6f 74 61 6c 2d 72 75 6e 73 20 6c 69 6e s total-runs lin
9760: 6b 74 72 65 65 20 61 72 65 61 2d 6e 61 6d 65 20 ktree area-name
9770: 67 65 74 2d 70 72 65 76 2d 6c 69 6e 6b 73 20 67 get-prev-links g
9780: 65 74 2d 6e 65 78 74 2d 6c 69 6e 6b 73 20 23 66 et-next-links #f
9790: 20 72 75 6e 2d 70 61 74 74 20 74 61 72 67 65 74 run-patt target
97a0: 2d 70 61 74 74 29 29 20 3b 3b 20 75 70 64 61 74 -patt)) ;; updat
97b0: 65 20 74 68 69 73 20 66 75 6e 63 74 69 6f 6e 0a e this function.
97c0: 09 20 20 20 20 20 20 28 63 6c 6f 73 65 2d 6f 75 . (close-ou
97d0: 74 70 75 74 2d 70 6f 72 74 20 6f 75 70 29 0a 09 tput-port oup)..
97e0: 09 09 09 09 3b 20 28 73 65 74 21 20 70 61 67 65 ....; (set! page
97f0: 20 28 2b 20 31 20 70 61 67 65 29 29 0a 09 20 20 (+ 1 page))..
9800: 20 20 20 20 28 69 66 20 28 3e 20 74 6f 74 61 6c (if (> total
9810: 2d 72 75 6e 73 20 28 2a 20 28 2b 20 31 20 70 61 -runs (* (+ 1 pa
9820: 67 65 29 20 70 67 2d 73 69 7a 65 29 29 0a 09 09 ge) pg-size))...
9830: 20 20 28 6c 6f 6f 70 20 28 2b 20 31 20 20 70 61 (loop (+ 1 pa
9840: 67 65 29 29 29 29 29 0a 09 20 20 28 63 6f 6d 6d ge))))).. (comm
9850: 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 72 on:simple-file-r
9860: 65 6c 65 61 73 65 2d 6c 6f 63 6b 20 6c 6f 63 6b elease-lock lock
9870: 66 69 6c 65 29 29 0a 09 28 62 65 67 69 6e 0a 09 file))..(begin..
9880: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
9890: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
98a0: 72 74 2a 20 22 46 61 69 6c 65 64 20 74 6f 20 67 rt* "Failed to g
98b0: 65 74 20 6c 6f 63 6b 20 6f 6e 20 66 69 6c 65 20 et lock on file
98c0: 6f 75 74 66 2c 20 6c 6f 63 6b 66 69 6c 65 3a 20 outf, lockfile:
98d0: 22 20 6c 6f 63 6b 66 69 6c 65 29 20 23 66 29 29 " lockfile) #f))
98e0: 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 ))...(define (te
98f0: 73 74 73 3a 72 65 61 64 6c 69 6e 65 73 20 66 69 sts:readlines fi
9900: 6c 65 6e 61 6d 65 29 0a 20 20 28 63 61 6c 6c 2d lename). (call-
9910: 77 69 74 68 2d 69 6e 70 75 74 2d 66 69 6c 65 20 with-input-file
9920: 66 69 6c 65 6e 61 6d 65 0a 20 20 20 20 28 6c 61 filename. (la
9930: 6d 62 64 61 20 28 70 29 0a 20 20 20 20 20 20 28 mbda (p). (
9940: 6c 65 74 20 6c 6f 6f 70 20 28 28 6c 69 6e 65 20 let loop ((line
9950: 28 72 65 61 64 2d 6c 69 6e 65 20 70 29 29 0a 20 (read-line p)).
9960: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9970: 28 72 65 73 75 6c 74 20 27 28 29 29 29 0a 20 20 (result '())).
9980: 20 20 20 20 20 20 28 69 66 20 28 65 6f 66 2d 6f (if (eof-o
9990: 62 6a 65 63 74 3f 20 6c 69 6e 65 29 0a 20 20 20 bject? line).
99a0: 20 20 20 20 20 20 20 20 20 28 72 65 76 65 72 73 (revers
99b0: 65 20 72 65 73 75 6c 74 29 0a 20 20 20 20 20 20 e result).
99c0: 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 72 65 61 (loop (rea
99d0: 64 2d 6c 69 6e 65 20 70 29 20 28 63 6f 6e 73 20 d-line p) (cons
99e0: 6c 69 6e 65 20 72 65 73 75 6c 74 29 29 29 29 29 line result)))))
99f0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 ))..(define (tes
9a00: 74 73 3a 67 65 74 2d 74 65 73 74 2d 6c 6f 67 20 ts:get-test-log
9a10: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
9a20: 20 69 74 65 6d 2d 6e 61 6d 65 29 0a 20 20 28 6c item-name). (l
9a30: 65 74 2a 20 28 28 74 65 73 74 2d 64 61 74 61 20 et* ((test-data
9a40: 20 20 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 (rmt:get-test
9a50: 73 2d 66 6f 72 2d 72 75 6e 0a 09 09 09 09 20 20 s-for-run.....
9a60: 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 (string->number
9a70: 20 72 75 6e 2d 69 64 29 0a 20 20 20 20 20 20 20 run-id).
9a80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9a90: 20 20 20 20 20 20 20 20 20 20 20 20 20 74 65 73 tes
9aa0: 74 2d 6e 61 6d 65 20 20 20 20 20 20 3b 3b 20 74 t-name ;; t
9ab0: 65 73 74 6e 61 6d 65 70 61 74 74 0a 09 09 09 09 estnamepatt.....
9ac0: 20 20 20 27 28 29 20 20 20 20 20 20 20 20 3b 3b '() ;;
9ad0: 20 73 74 61 74 65 73 0a 09 09 09 09 20 20 20 27 states..... '
9ae0: 28 29 20 20 20 20 20 20 20 20 3b 3b 20 73 74 61 () ;; sta
9af0: 74 75 73 65 73 0a 09 09 09 09 20 20 20 23 66 20 tuses..... #f
9b00: 20 20 20 20 20 20 20 20 3b 3b 20 6f 66 66 73 65 ;; offse
9b10: 74 0a 09 09 09 09 20 20 20 23 66 20 20 20 20 20 t..... #f
9b20: 20 20 20 20 3b 3b 20 6e 75 6d 2d 74 6f 2d 67 65 ;; num-to-ge
9b30: 74 0a 09 09 09 09 20 20 20 23 66 20 20 20 20 20 t..... #f
9b40: 20 20 20 20 3b 3b 20 68 69 64 65 2f 6e 6f 74 2d ;; hide/not-
9b50: 68 69 64 65 0a 09 09 09 09 20 20 20 23 66 20 20 hide..... #f
9b60: 20 20 20 20 20 20 20 3b 3b 20 73 6f 72 74 2d 62 ;; sort-b
9b70: 79 0a 09 09 09 09 20 20 20 23 66 20 20 20 20 20 y..... #f
9b80: 20 20 20 20 3b 3b 20 73 6f 72 74 2d 6f 72 64 65 ;; sort-orde
9b90: 72 0a 09 09 09 09 20 20 20 23 66 20 20 20 20 20 r..... #f
9ba0: 20 20 20 20 3b 3b 20 27 73 68 6f 72 74 6c 69 73 ;; 'shortlis
9bb0: 74 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 t
9bc0: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 71 ;; q
9bd0: 72 79 74 79 70 65 0a 20 20 20 20 20 20 20 20 20 rytype.
9be0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9bf0: 20 20 20 20 20 20 20 20 20 20 30 20 20 20 20 20 0
9c00: 20 20 20 20 3b 3b 20 6c 61 73 74 20 75 70 64 61 ;; last upda
9c10: 74 65 0a 09 09 09 09 20 20 20 23 66 29 29 0a 20 te..... #f)).
9c20: 20 20 20 20 20 20 20 20 28 70 61 74 68 20 22 22 (path ""
9c30: 29 0a 20 20 20 20 20 20 20 20 20 28 66 6f 75 6e ). (foun
9c40: 64 20 30 29 29 0a 20 20 20 20 28 64 65 62 75 67 d 0)). (debug
9c50: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 :print-info 0 *d
9c60: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
9c70: 20 22 66 6f 75 6e 64 3a 20 22 20 66 6f 75 6e 64 "found: " found
9c80: 20 29 0a 0a 20 20 20 28 6c 65 74 20 6c 6f 6f 70 ).. (let loop
9c90: 20 28 28 68 65 64 20 28 63 61 72 20 74 65 73 74 ((hed (car test
9ca0: 2d 64 61 74 61 29 29 0a 09 09 20 28 74 61 6c 20 -data))... (tal
9cb0: 28 63 64 72 20 74 65 73 74 2d 64 61 74 61 29 29 (cdr test-data))
9cc0: 29 0a 20 20 20 20 20 20 20 20 20 20 28 64 65 62 ). (deb
9cd0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
9ce0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
9cf0: 74 2a 20 22 69 74 65 6d 3a 20 22 20 28 76 65 63 t* "item: " (vec
9d00: 74 6f 72 2d 72 65 66 20 68 65 64 20 31 31 29 20 tor-ref hed 11)
9d10: 28 76 65 63 74 6f 72 2d 72 65 66 20 68 65 64 20 (vector-ref hed
9d20: 31 30 29 20 22 2f 22 20 28 76 65 63 74 6f 72 2d 10) "/" (vector-
9d30: 72 65 66 20 68 65 64 20 31 33 29 29 0a 0a 09 28 ref hed 13))...(
9d40: 69 66 20 28 65 71 75 61 6c 3f 20 28 76 65 63 74 if (equal? (vect
9d50: 6f 72 2d 72 65 66 20 68 65 64 20 31 31 29 20 69 or-ref hed 11) i
9d60: 74 65 6d 2d 6e 61 6d 65 29 0a 20 20 20 20 20 20 tem-name).
9d70: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 (begin.
9d80: 20 20 20 20 20 20 20 20 20 20 20 28 73 65 74 21 (set!
9d90: 20 66 6f 75 6e 64 20 31 29 20 0a 09 20 20 20 20 found 1) ..
9da0: 20 20 28 73 65 74 21 20 70 61 74 68 20 28 63 6f (set! path (co
9db0: 6e 63 20 28 76 65 63 74 6f 72 2d 72 65 66 20 68 nc (vector-ref h
9dc0: 65 64 20 31 30 29 20 22 2f 22 20 28 76 65 63 74 ed 10) "/" (vect
9dd0: 6f 72 2d 72 65 66 20 68 65 64 20 31 33 29 29 29 or-ref hed 13)))
9de0: 29 29 0a 09 20 20 20 20 28 69 66 20 28 61 6e 64 )).. (if (and
9df0: 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c (not (null? tal
9e00: 29 29 20 28 65 71 75 61 6c 3f 20 66 6f 75 6e 64 )) (equal? found
9e10: 20 30 29 29 0a 09 09 28 6c 6f 6f 70 20 28 63 61 0))...(loop (ca
9e20: 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 29 r tal)(cdr tal))
9e30: 29 29 0a 20 20 20 28 69 66 20 28 65 71 75 61 6c )). (if (equal
9e40: 3f 20 70 61 74 68 20 22 22 29 0a 20 20 20 20 20 ? path "").
9e50: 22 3c 48 32 3e 44 61 74 61 20 6e 6f 74 20 66 6f "<H2>Data not fo
9e60: 75 6e 64 3c 2f 48 32 3e 22 0a 20 20 20 20 20 28 und</H2>". (
9e70: 73 74 72 69 6e 67 2d 6a 6f 69 6e 20 28 74 65 73 string-join (tes
9e80: 74 73 3a 72 65 61 64 6c 69 6e 65 73 20 70 61 74 ts:readlines pat
9e90: 68 29 20 22 5c 6e 22 29 29 29 29 0a 0a 0a 28 64 h) "\n"))))...(d
9ea0: 65 66 69 6e 65 20 28 74 65 73 74 73 3a 64 79 6e efine (tests:dyn
9eb0: 61 6d 69 63 2d 64 62 6f 61 72 64 20 70 61 67 65 amic-dboard page
9ec0: 29 0a 3b 28 64 65 66 69 6e 65 20 28 74 65 73 74 ).;(define (test
9ed0: 73 3a 63 72 65 61 74 65 2d 68 74 6d 6c 2d 74 72 s:create-html-tr
9ee0: 65 65 20 6f 29 0a 20 28 6c 65 74 2a 20 28 0a 3b ee o). (let* (.;
9ef0: 28 70 61 67 65 20 22 31 22 29 0a 20 20 20 20 20 (page "1").
9f00: 20 20 20 20 20 28 6c 69 6e 6b 74 72 65 65 20 20 (linktree
9f10: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 69 6e 6b (common:get-link
9f20: 74 72 65 65 29 29 0a 20 20 20 20 20 20 20 20 20 tree)).
9f30: 28 61 72 65 61 2d 6e 61 6d 65 20 28 63 6f 6d 6d (area-name (comm
9f40: 6f 6e 3a 67 65 74 2d 74 65 73 74 73 75 69 74 65 on:get-testsuite
9f50: 2d 6e 61 6d 65 29 29 0a 09 20 20 20 20 20 20 20 -name))..
9f60: 28 6b 65 79 73 20 20 20 20 20 20 28 72 6d 74 3a (keys (rmt:
9f70: 67 65 74 2d 6b 65 79 73 29 29 0a 09 20 20 20 20 get-keys))..
9f80: 20 20 20 28 6e 75 6d 6b 65 79 73 20 20 20 28 6c (numkeys (l
9f90: 65 6e 67 74 68 20 6b 65 79 73 29 29 0a 20 20 20 ength keys)).
9fa0: 20 20 20 20 20 20 28 74 61 72 67 74 77 65 61 6b (targtweak
9fb0: 65 64 20 28 6d 61 6b 65 2d 6c 69 73 74 20 6e 75 ed (make-list nu
9fc0: 6d 6b 65 79 73 20 22 25 22 29 29 0a 20 20 20 20 mkeys "%")).
9fd0: 20 20 20 20 20 28 74 61 72 67 65 74 2d 70 61 74 (target-pat
9fe0: 74 20 28 73 74 72 69 6e 67 2d 6a 6f 69 6e 20 74 t (string-join t
9ff0: 61 72 67 74 77 65 61 6b 65 64 20 22 2f 22 29 29 argtweaked "/"))
a000: 0a 20 20 20 20 20 20 20 20 20 28 74 6f 74 61 6c . (total
a010: 2d 72 75 6e 73 20 20 28 72 6d 74 3a 67 65 74 2d -runs (rmt:get-
a020: 6e 75 6d 2d 72 75 6e 73 20 22 25 22 29 29 0a 20 num-runs "%")).
a030: 20 20 20 20 20 20 20 20 28 70 67 2d 73 69 7a 65 (pg-size
a040: 20 31 30 29 0a 20 20 20 20 20 20 20 20 20 28 70 10). (p
a050: 67 20 28 69 66 20 28 65 71 75 61 6c 3f 20 70 61 g (if (equal? pa
a060: 67 65 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 ge #f).
a070: 20 20 20 20 20 20 20 20 30 0a 20 20 20 20 20 20 0.
a080: 20 20 20 20 20 20 20 20 20 20 20 28 2d 20 28 73 (- (s
a090: 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 70 61 tring->number pa
a0a0: 67 65 29 20 31 29 29 29 0a 20 20 20 20 20 20 20 ge) 1))).
a0b0: 20 20 20 28 67 65 74 2d 70 72 65 76 2d 6c 69 6e (get-prev-lin
a0c0: 6b 73 20 20 28 6c 61 6d 62 64 61 20 28 70 67 20 ks (lambda (pg
a0d0: 6c 69 6e 6b 74 72 65 65 29 0a 20 20 20 20 20 20 linktree).
a0e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a0f0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
a100: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
a110: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 76 61 6c t-log-port* "val
a120: 3a 20 22 20 28 2d 20 31 20 70 67 29 29 0a 20 20 : " (- 1 pg)).
a130: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a140: 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 (let* ((
a150: 6c 69 6e 6b 20 20 28 69 66 20 28 6e 6f 74 20 28 link (if (not (
a160: 65 71 3f 20 70 67 20 30 29 29 0a 20 20 20 20 20 eq? pg 0)).
a170: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a180: 20 20 20 20 20 20 20 20 20 20 28 73 3a 61 20 20 (s:a
a190: 22 26 6c 74 3b 26 6c 74 3b 70 72 65 76 20 22 20 "<<prev "
a1a0: 27 68 72 65 66 20 28 63 6f 6e 63 20 20 22 64 61 'href (conc "da
a1b0: 73 68 62 6f 61 72 64 3f 70 61 67 65 3d 22 20 20 shboard?page="
a1c0: 70 67 20 20 29 29 0a 20 20 20 20 20 20 20 20 20 pg )).
a1d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a1e0: 20 20 20 20 20 20 28 73 3a 61 20 22 22 20 27 68 (s:a "" 'h
a1f0: 72 65 66 20 28 63 6f 6e 63 20 20 22 64 61 73 68 ref (conc "dash
a200: 62 6f 61 72 64 3f 70 61 67 65 3d 22 20 70 67 29 board?page=" pg)
a210: 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 )))).
a220: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a230: 20 20 20 20 6c 69 6e 6b 29 29 29 0a 20 20 20 20 link))).
a240: 20 20 20 20 20 20 28 67 65 74 2d 6e 65 78 74 2d (get-next-
a250: 6c 69 6e 6b 73 20 20 20 28 6c 61 6d 62 64 61 20 links (lambda
a260: 28 70 67 20 6c 69 6e 6b 74 72 65 65 20 74 6f 74 (pg linktree tot
a270: 61 6c 2d 72 75 6e 73 29 20 20 0a 20 20 20 20 20 al-runs) .
a280: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a290: 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 (debug:pr
a2a0: 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 int-info 0 *defa
a2b0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 76 ult-log-port* "v
a2c0: 61 6c 3a 20 22 20 70 67 29 0a 20 20 20 20 20 20 al: " pg).
a2d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a2e0: 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 (debug:pr
a2f0: 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 int-info 0 *defa
a300: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 76 ult-log-port* "v
a310: 61 6c 3a 20 22 20 74 6f 74 61 6c 2d 72 75 6e 73 al: " total-runs
a320: 20 22 20 73 69 7a 65 22 20 70 67 2d 73 69 7a 65 " size" pg-size
a330: 29 0a 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 ). .
a340: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a350: 28 6c 65 74 2a 20 28 28 6c 69 6e 6b 20 20 28 69 (let* ((link (i
a360: 66 20 28 3e 20 74 6f 74 61 6c 2d 72 75 6e 73 20 f (> total-runs
a370: 28 2b 20 31 30 20 28 2a 20 70 67 20 70 67 2d 73 (+ 10 (* pg pg-s
a380: 69 7a 65 29 29 29 0a 20 20 20 20 20 20 20 20 20 ize))).
a390: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a3a0: 20 20 20 20 20 28 73 3a 61 20 20 22 6e 65 78 74 (s:a "next
a3b0: 26 67 74 3b 26 67 74 3b 20 22 20 20 27 68 72 65 >> " 'hre
a3c0: 66 20 28 63 6f 6e 63 20 20 22 64 61 73 68 62 6f f (conc "dashbo
a3d0: 61 72 64 3f 70 61 67 65 3d 22 20 20 28 2b 20 70 ard?page=" (+ p
a3e0: 67 20 32 29 20 20 29 29 0a 20 20 20 20 20 20 20 g 2) )).
a3f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a400: 20 20 20 20 20 20 28 73 3a 61 20 22 22 20 27 68 (s:a "" 'h
a410: 72 65 66 20 28 63 6f 6e 63 20 20 22 64 61 73 68 ref (conc "dash
a420: 62 6f 61 72 64 3f 70 61 67 65 3d 22 20 70 67 20 board?page=" pg
a430: 20 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 ))))).
a440: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a450: 20 20 20 20 6c 69 6e 6b 29 29 29 0a 20 20 20 20 link))).
a460: 20 20 20 20 20 28 68 74 6d 6c 2d 62 6f 64 79 20 (html-body
a470: 28 74 65 73 74 73 3a 64 61 73 68 62 6f 61 72 64 (tests:dashboard
a480: 2d 62 6f 64 79 20 70 67 20 70 67 2d 73 69 7a 65 -body pg pg-size
a490: 20 6b 65 79 73 20 6e 75 6d 6b 65 79 73 20 74 6f keys numkeys to
a4a0: 74 61 6c 2d 72 75 6e 73 20 6c 69 6e 6b 74 72 65 tal-runs linktre
a4b0: 65 20 61 72 65 61 2d 6e 61 6d 65 20 67 65 74 2d e area-name get-
a4c0: 70 72 65 76 2d 6c 69 6e 6b 73 20 67 65 74 2d 6e prev-links get-n
a4d0: 65 78 74 2d 6c 69 6e 6b 73 20 23 74 20 22 25 22 ext-links #t "%"
a4e0: 20 74 61 72 67 65 74 2d 70 61 74 74 29 29 29 20 target-patt)))
a4f0: 3b 3b 20 75 70 64 61 74 65 20 74 69 73 20 66 75 ;; update tis fu
a500: 6e 63 74 69 6f 6e 0a 20 20 20 20 20 20 20 20 68 nction. h
a510: 74 6d 6c 2d 62 6f 64 79 29 29 0a 0a 28 64 65 66 tml-body))..(def
a520: 69 6e 65 20 28 74 65 73 74 73 3a 63 72 65 61 74 ine (tests:creat
a530: 65 2d 68 74 6d 6c 2d 73 75 6d 6d 61 72 79 20 6f e-html-summary o
a540: 75 74 66 29 0a 20 28 6c 65 74 2a 20 28 28 6c 6f utf). (let* ((lo
a550: 63 6b 66 69 6c 65 20 20 28 63 6f 6e 63 20 6f 75 ckfile (conc ou
a560: 74 66 20 22 2e 6c 6f 63 6b 22 29 29 0a 20 20 20 tf ".lock")).
a570: 20 20 20 20 20 28 6c 69 6e 6b 74 72 65 65 20 20 (linktree
a580: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 69 6e 6b (common:get-link
a590: 74 72 65 65 29 29 0a 09 09 09 09 28 6b 65 79 73 tree)).....(keys
a5a0: 20 20 20 20 20 20 28 72 6d 74 3a 67 65 74 2d 6b (rmt:get-k
a5b0: 65 79 73 29 29 0a 20 20 20 20 20 20 20 20 28 61 eys)). (a
a5c0: 72 65 61 2d 6e 61 6d 65 20 28 63 6f 6d 6d 6f 6e rea-name (common
a5d0: 3a 67 65 74 2d 74 65 73 74 73 75 69 74 65 2d 6e :get-testsuite-n
a5e0: 61 6d 65 29 29 0a 20 20 20 20 20 20 20 20 28 72 ame)). (r
a5f0: 75 6e 2d 70 61 74 74 20 28 6f 72 20 28 61 72 67 un-patt (or (arg
a600: 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 75 6e 2d s:get-arg "-run-
a610: 70 61 74 74 22 29 0a 20 20 20 20 20 20 20 20 20 patt").
a620: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
a630: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 args:get-arg "-r
a640: 75 6e 6e 61 6d 65 22 29 0a 20 20 20 20 20 20 20 unname").
a650: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a660: 20 22 25 22 29 29 0a 20 20 20 20 20 20 20 20 28 "%")). (
a670: 74 61 72 67 65 74 20 28 6f 72 20 28 61 72 67 73 target (or (args
a680: 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 72 67 65 :get-arg "-targe
a690: 74 2d 70 61 74 74 22 29 0a 20 20 20 20 20 20 20 t-patt").
a6a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a6b0: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
a6c0: 2d 74 61 72 67 65 74 22 29 0a 20 20 20 20 20 20 -target").
a6d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a6e0: 20 20 22 25 22 29 29 0a 20 20 20 20 20 20 20 20 "%")).
a6f0: 20 28 74 61 72 67 6c 69 73 74 20 28 73 74 72 69 (targlist (stri
a700: 6e 67 2d 73 70 6c 69 74 20 74 61 72 67 65 74 20 ng-split target
a710: 22 2f 22 29 29 0a 20 20 20 20 20 20 20 20 20 28 "/")). (
a720: 6e 75 6d 6b 65 79 73 20 20 28 6c 65 6e 67 74 68 numkeys (length
a730: 20 6b 65 79 73 29 29 0a 09 20 20 20 20 20 20 20 keys))..
a740: 28 6e 75 6d 74 61 72 67 20 20 28 6c 65 6e 67 74 (numtarg (lengt
a750: 68 20 74 61 72 67 6c 69 73 74 29 29 20 20 0a 20 h targlist)) .
a760: 20 20 20 20 20 20 20 20 28 74 61 72 67 74 77 65 (targtwe
a770: 61 6b 65 64 20 28 69 66 20 28 3e 20 6e 75 6d 6b aked (if (> numk
a780: 65 79 73 20 6e 75 6d 74 61 72 67 29 0a 09 09 09 eys numtarg)....
a790: 20 20 20 09 09 09 09 09 09 09 09 28 61 70 70 65 ........(appe
a7a0: 6e 64 20 74 61 72 67 6c 69 73 74 20 28 6d 61 6b nd targlist (mak
a7b0: 65 2d 6c 69 73 74 20 28 2d 20 6e 75 6d 6b 65 79 e-list (- numkey
a7c0: 73 20 6e 75 6d 74 61 72 67 29 20 22 25 22 29 29 s numtarg) "%"))
a7d0: 0a 09 09 09 20 20 09 09 09 09 09 09 09 09 74 61 .... ........ta
a7e0: 72 67 6c 69 73 74 29 29 0a 20 20 20 20 20 20 20 rglist)).
a7f0: 20 28 74 61 72 67 65 74 2d 70 61 74 74 20 28 73 (target-patt (s
a800: 74 72 69 6e 67 2d 6a 6f 69 6e 20 74 61 72 67 74 tring-join targt
a810: 77 65 61 6b 65 64 20 22 2f 22 29 29 29 0a 20 20 weaked "/"))).
a820: 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 73 69 (if (common:si
a830: 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 20 6c mple-file-lock l
a840: 6f 63 6b 66 69 6c 65 29 0a 20 20 20 20 20 20 20 ockfile).
a850: 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 (begin.
a860: 20 20 28 6c 65 74 2a 20 28 3b 28 72 75 6e 73 64 (let* (;(runsd
a870: 61 74 31 20 20 20 28 72 6d 74 3a 67 65 74 2d 72 at1 (rmt:get-r
a880: 75 6e 73 20 72 75 6e 2d 70 61 74 74 20 23 66 20 uns run-patt #f
a890: 23 66 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 #f (map (lambda
a8a0: 28 78 29 28 6c 69 73 74 20 78 20 22 25 22 29 29 (x)(list x "%"))
a8b0: 20 6b 65 79 73 29 29 29 0a 20 20 20 20 20 20 20 keys))).
a8c0: 20 20 20 20 20 20 20 20 20 20 28 72 75 6e 73 64 (runsd
a8d0: 61 74 20 20 20 28 72 6d 74 3a 67 65 74 2d 72 75 at (rmt:get-ru
a8e0: 6e 73 2d 62 79 2d 70 61 74 74 20 20 6b 65 79 73 ns-by-patt keys
a8f0: 20 72 75 6e 2d 70 61 74 74 20 74 61 72 67 65 74 run-patt target
a900: 2d 70 61 74 74 20 23 66 20 23 66 20 23 66 20 30 -patt #f #f #f 0
a910: 29 29 0a 09 09 09 09 09 20 20 20 20 20 20 20 28 ))...... (
a920: 72 75 6e 73 20 20 20 20 20 20 28 76 65 63 74 6f runs (vecto
a930: 72 2d 72 65 66 20 72 75 6e 73 64 61 74 20 31 29 r-ref runsdat 1)
a940: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
a950: 20 20 20 28 68 65 61 64 65 72 20 20 20 20 20 20 (header
a960: 28 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 73 (vector-ref runs
a970: 64 61 74 20 30 29 29 0a 20 20 20 20 20 20 20 20 dat 0)).
a980: 09 20 20 20 20 20 20 20 28 6f 75 70 20 20 20 20 . (oup
a990: 20 20 20 28 6f 70 65 6e 2d 6f 75 74 70 75 74 2d (open-output-
a9a0: 66 69 6c 65 20 28 6f 72 20 6f 75 74 66 20 28 63 file (or outf (c
a9b0: 6f 6e 63 20 6c 69 6e 6b 74 72 65 65 20 22 2f 74 onc linktree "/t
a9c0: 61 72 67 65 74 73 2e 68 74 6d 6c 22 29 29 29 29 argets.html"))))
a9d0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
a9e0: 20 20 28 74 61 72 67 65 74 2d 68 61 73 68 20 28 (target-hash (
a9f0: 74 65 73 74 3a 63 72 65 61 74 65 2d 74 61 72 67 test:create-targ
aa00: 65 74 2d 68 61 73 68 20 72 75 6e 73 20 68 65 61 et-hash runs hea
aa10: 64 65 72 20 28 6c 65 6e 67 74 68 20 6b 65 79 73 der (length keys
aa20: 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 )))).
aa30: 28 74 65 73 74 3a 63 72 65 61 74 65 2d 74 61 72 (test:create-tar
aa40: 67 65 74 2d 68 74 6d 6c 20 74 61 72 67 65 74 2d get-html target-
aa50: 68 61 73 68 20 6f 75 70 20 61 72 65 61 2d 6e 61 hash oup area-na
aa60: 6d 65 20 6c 69 6e 6b 74 72 65 65 29 0a 20 20 20 me linktree).
aa70: 20 20 20 20 20 20 20 28 74 65 73 74 3a 63 72 65 (test:cre
aa80: 61 74 65 2d 72 75 6e 2d 68 74 6d 6c 20 20 72 75 ate-run-html ru
aa90: 6e 73 20 61 72 65 61 2d 6e 61 6d 65 20 6c 69 6e ns area-name lin
aaa0: 6b 74 72 65 65 20 28 6c 65 6e 67 74 68 20 6b 65 ktree (length ke
aab0: 79 73 29 20 68 65 61 64 65 72 29 29 0a 09 20 20 ys) header))..
aac0: 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 2d 66 (common:simple-f
aad0: 69 6c 65 2d 72 65 6c 65 61 73 65 2d 6c 6f 63 6b ile-release-lock
aae0: 20 6c 6f 63 6b 66 69 6c 65 29 29 0a 09 23 66 29 lockfile))..#f)
aaf0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 ))..(define (tes
ab00: 74 3a 67 65 74 2d 74 65 73 74 2d 68 61 73 68 20 t:get-test-hash
ab10: 74 65 73 74 2d 64 61 74 61 29 0a 09 28 6c 65 74 test-data)..(let
ab20: 20 28 28 72 65 73 68 20 28 6d 61 6b 65 2d 68 61 ((resh (make-ha
ab30: 73 68 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 20 sh-table))).
ab40: 09 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 74 .(map (lambda (t
ab50: 65 73 74 29 0a 20 20 20 20 20 20 20 20 28 6c 65 est). (le
ab60: 74 2a 20 28 28 74 65 73 74 2d 6e 61 6d 65 20 28 t* ((test-name (
ab70: 76 65 63 74 6f 72 2d 72 65 66 20 74 65 73 74 20 vector-ref test
ab80: 32 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 2)).
ab90: 20 20 20 28 74 65 73 74 2d 68 74 6d 6c 2d 70 61 (test-html-pa
aba0: 74 68 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 th (if (file-exi
abb0: 73 74 73 3f 20 28 63 6f 6e 63 20 28 76 65 63 74 sts? (conc (vect
abc0: 6f 72 2d 72 65 66 20 74 65 73 74 20 31 30 29 20 or-ref test 10)
abd0: 22 2f 74 65 73 74 2d 73 75 6d 6d 61 72 79 2e 68 "/test-summary.h
abe0: 74 6d 6c 22 29 29 0a 09 09 09 09 09 09 09 09 09 tml"))..........
abf0: 09 09 09 09 09 09 09 20 28 63 6f 6e 63 20 28 76 ....... (conc (v
ac00: 65 63 74 6f 72 2d 72 65 66 20 74 65 73 74 20 31 ector-ref test 1
ac10: 30 29 20 22 2f 74 65 73 74 2d 73 75 6d 6d 61 72 0) "/test-summar
ac20: 79 2e 68 74 6d 6c 22 20 29 0a 09 09 09 09 09 09 y.html" ).......
ac30: 09 20 09 09 09 09 09 09 09 09 09 20 28 63 6f 6e . ......... (con
ac40: 63 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 65 c (vector-ref te
ac50: 73 74 20 31 30 29 20 22 2f 22 20 28 76 65 63 74 st 10) "/" (vect
ac60: 6f 72 2d 72 65 66 20 74 65 73 74 20 31 33 29 29 or-ref test 13))
ac70: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
ac80: 20 20 28 74 65 73 74 2d 69 74 65 6d 20 20 28 76 (test-item (v
ac90: 65 63 74 6f 72 2d 72 65 66 20 74 65 73 74 20 31 ector-ref test 1
aca0: 31 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 1)).
acb0: 20 20 20 28 74 65 73 74 2d 73 74 61 74 75 73 20 (test-status
acc0: 28 76 65 63 74 6f 72 2d 72 65 66 20 74 65 73 74 (vector-ref test
acd0: 20 34 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 4))).
ace0: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 68 (if (not (h
acf0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
ad00: 66 61 75 6c 74 20 72 65 73 68 20 74 65 73 74 2d fault resh test-
ad10: 69 74 65 6d 20 20 23 66 29 29 0a 20 20 20 20 20 item #f)).
ad20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 68 (h
ad30: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 72 ash-table-set! r
ad40: 65 73 68 20 74 65 73 74 2d 69 74 65 6d 20 20 20 esh test-item
ad50: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
ad60: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
ad70: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 (hash-table-s
ad80: 65 74 21 20 28 68 61 73 68 2d 74 61 62 6c 65 2d et! (hash-table-
ad90: 72 65 66 2f 64 65 66 61 75 6c 74 20 72 65 73 68 ref/default resh
ada0: 20 74 65 73 74 2d 69 74 65 6d 20 20 23 66 29 20 test-item #f)
adb0: 74 65 73 74 2d 6e 61 6d 65 20 28 6c 69 73 74 20 test-name (list
adc0: 74 65 73 74 2d 73 74 61 74 75 73 20 74 65 73 74 test-status test
add0: 2d 68 74 6d 6c 2d 70 61 74 68 29 29 29 29 20 0a -html-path)))) .
ade0: 20 20 20 20 20 20 20 20 74 65 73 74 2d 64 61 74 test-dat
adf0: 61 29 0a 72 65 73 68 29 29 0a 0a 28 64 65 66 69 a).resh))..(defi
ae00: 6e 65 20 28 74 65 73 74 3a 67 65 74 2d 64 61 74 ne (test:get-dat
ae10: 61 2d 3e 62 2d 6b 65 79 73 20 6f 72 64 65 72 65 a->b-keys ordere
ae20: 64 2d 64 61 74 61 20 61 2d 6b 65 79 73 29 0a 20 d-data a-keys).
ae30: 20 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 (delete-duplica
ae40: 74 65 73 0a 20 20 20 28 73 6f 72 74 20 28 61 70 tes. (sort (ap
ae50: 70 6c 79 0a 09 20 20 61 70 70 65 6e 64 0a 09 20 ply.. append..
ae60: 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 73 (map (lambda (s
ae70: 75 62 2d 6b 65 79 29 0a 09 09 20 28 6c 65 74 20 ub-key)... (let
ae80: 28 28 73 75 62 64 61 74 20 28 68 61 73 68 2d 74 ((subdat (hash-t
ae90: 61 62 6c 65 2d 72 65 66 20 6f 72 64 65 72 65 64 able-ref ordered
aea0: 2d 64 61 74 61 20 73 75 62 2d 6b 65 79 29 29 29 -data sub-key)))
aeb0: 0a 09 09 20 20 20 28 68 61 73 68 2d 74 61 62 6c ... (hash-tabl
aec0: 65 2d 6b 65 79 73 20 73 75 62 64 61 74 29 29 29 e-keys subdat)))
aed0: 0a 09 20 20 20 20 20 20 20 61 2d 6b 65 79 73 29 .. a-keys)
aee0: 29 0a 09 20 73 74 72 69 6e 67 3e 3d 3f 29 29 29 ).. string>=?)))
aef0: 0a 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 ...(define (test
af00: 3a 63 72 65 61 74 65 2d 72 75 6e 2d 68 74 6d 6c :create-run-html
af10: 20 72 75 6e 73 20 61 72 65 61 2d 6e 61 6d 65 20 runs area-name
af20: 6c 69 6e 6b 74 72 65 65 20 6e 75 6d 6b 65 79 73 linktree numkeys
af30: 20 68 65 61 64 65 72 29 0a 20 20 28 6d 61 70 20 header). (map
af40: 28 6c 61 6d 62 64 61 20 28 72 75 6e 29 0a 09 09 (lambda (run)...
af50: 20 28 6c 65 74 2a 20 28 28 74 61 72 67 65 74 20 (let* ((target
af60: 28 73 74 72 69 6e 67 2d 6a 6f 69 6e 20 28 74 61 (string-join (ta
af70: 6b 65 20 28 76 65 63 74 6f 72 2d 3e 6c 69 73 74 ke (vector->list
af80: 20 72 75 6e 29 20 6e 75 6d 6b 65 79 73 29 20 22 run) numkeys) "
af90: 2f 22 29 29 0a 09 09 09 09 09 09 28 72 75 6e 2d /")).......(run-
afa0: 6e 61 6d 65 20 28 64 62 3a 67 65 74 2d 76 61 6c name (db:get-val
afb0: 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e ue-by-header run
afc0: 20 68 65 61 64 65 72 20 22 72 75 6e 6e 61 6d 65 header "runname
afd0: 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ")).
afe0: 28 72 75 6e 2d 74 69 6d 65 20 28 73 65 63 6f 6e (run-time (secon
aff0: 64 73 2d 3e 77 6f 72 6b 2d 77 65 65 6b 2f 64 61 ds->work-week/da
b000: 79 2d 74 69 6d 65 20 28 64 62 3a 67 65 74 2d 76 y-time (db:get-v
b010: 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 alue-by-header r
b020: 75 6e 20 68 65 61 64 65 72 20 22 65 76 65 6e 74 un header "event
b030: 5f 74 69 6d 65 22 29 29 29 0a 09 09 09 09 09 09 _time"))).......
b040: 28 6f 75 70 20 28 69 66 20 28 66 69 6c 65 2d 65 (oup (if (file-e
b050: 78 69 73 74 73 3f 20 28 63 6f 6e 63 20 6c 69 6e xists? (conc lin
b060: 6b 74 72 65 65 20 22 2f 22 20 74 61 72 67 65 74 ktree "/" target
b070: 20 22 2f 22 20 72 75 6e 2d 6e 61 6d 65 29 29 0a "/" run-name)).
b080: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b090: 20 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 6f 75 (open-ou
b0a0: 74 70 75 74 2d 66 69 6c 65 20 28 63 6f 6e 63 20 tput-file (conc
b0b0: 6c 69 6e 6b 74 72 65 65 20 22 2f 22 20 74 61 72 linktree "/" tar
b0c0: 67 65 74 20 22 2f 22 20 72 75 6e 2d 6e 61 6d 65 get "/" run-name
b0d0: 20 22 2f 72 75 6e 2e 68 74 6d 6c 22 29 29 0a 20 "/run.html")).
b0e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b0f0: 20 20 20 20 20 20 20 20 23 66 29 29 0a 20 20 20 #f)).
b100: 20 20 20 20 20 20 20 20 20 28 72 75 6e 2d 69 64 (run-id
b110: 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 (db:get-value-b
b120: 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 y-header run hea
b130: 64 65 72 20 22 69 64 22 29 29 0a 20 20 20 20 20 der "id")).
b140: 20 20 20 20 20 20 20 28 74 65 73 74 2d 64 61 74 (test-dat
b150: 61 20 20 20 20 28 72 6d 74 3a 67 65 74 2d 74 65 a (rmt:get-te
b160: 73 74 73 2d 66 6f 72 2d 72 75 6e 0a 09 09 09 09 sts-for-run.....
b170: 20 20 09 09 09 09 09 09 09 09 20 72 75 6e 2d 69 ........ run-i
b180: 64 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 d.
b190: 20 20 20 20 20 20 20 20 20 20 20 20 20 22 25 22 "%"
b1a0: 20 20 20 20 20 20 20 3b 3b 20 74 65 73 74 6e 61 ;; testna
b1b0: 6d 65 70 61 74 74 0a 09 09 09 09 20 20 09 09 09 mepatt..... ...
b1c0: 09 09 09 09 09 20 27 28 29 20 20 20 20 20 20 20 ..... '()
b1d0: 20 3b 3b 20 73 74 61 74 65 73 0a 09 09 09 09 20 ;; states.....
b1e0: 20 20 09 09 09 09 09 09 09 09 20 27 28 29 20 20 ........ '()
b1f0: 20 20 20 20 20 20 3b 3b 20 73 74 61 74 75 73 65 ;; statuse
b200: 73 0a 09 09 09 09 20 20 09 09 09 09 09 09 09 09 s..... ........
b210: 20 09 23 66 20 20 20 20 20 20 20 20 20 3b 3b 20 .#f ;;
b220: 6f 66 66 73 65 74 0a 09 09 09 09 20 20 09 09 09 offset..... ...
b230: 09 09 09 20 09 09 09 23 66 20 20 20 20 20 20 20 ... ...#f
b240: 20 20 3b 3b 20 6e 75 6d 2d 74 6f 2d 67 65 74 0a ;; num-to-get.
b250: 09 09 09 09 20 20 20 09 09 09 09 09 09 09 09 09 .... .........
b260: 23 66 20 20 20 20 20 20 20 20 20 3b 3b 20 68 69 #f ;; hi
b270: 64 65 2f 6e 6f 74 2d 68 69 64 65 0a 09 09 09 09 de/not-hide.....
b280: 20 20 09 09 09 09 09 09 09 09 20 20 23 66 20 20 ........ #f
b290: 20 20 20 20 20 20 20 3b 3b 20 73 6f 72 74 2d 62 ;; sort-b
b2a0: 79 0a 09 09 09 09 20 20 20 09 09 09 09 09 09 09 y..... .......
b2b0: 09 09 23 66 20 20 20 20 20 20 20 20 20 3b 3b 20 ..#f ;;
b2c0: 73 6f 72 74 2d 6f 72 64 65 72 0a 09 09 09 09 20 sort-order.....
b2d0: 20 20 09 09 09 09 09 09 09 09 09 23 66 20 20 20 .........#f
b2e0: 20 20 20 20 20 20 3b 3b 20 27 73 68 6f 72 74 6c ;; 'shortl
b2f0: 69 73 74 20 20 20 20 20 20 20 20 20 20 20 20 20 ist
b300: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b ;;
b310: 20 71 72 79 74 79 70 65 0a 20 20 20 20 20 20 20 qrytype.
b320: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b330: 20 20 20 20 20 30 20 20 20 20 20 20 20 20 20 3b 0 ;
b340: 3b 20 6c 61 73 74 20 75 70 64 61 74 65 0a 09 09 ; last update...
b350: 09 09 20 20 09 09 09 09 09 09 09 09 09 23 66 29 .. .........#f)
b360: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 69 ). (i
b370: 74 65 6d 2d 74 65 73 74 2d 68 61 73 68 20 28 74 tem-test-hash (t
b380: 65 73 74 3a 67 65 74 2d 74 65 73 74 2d 68 61 73 est:get-test-has
b390: 68 20 74 65 73 74 2d 64 61 74 61 29 29 0a 20 20 h test-data)).
b3a0: 20 20 20 20 20 20 20 20 20 20 28 69 74 65 6d 73 (items
b3b0: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 (hash-table-ke
b3c0: 79 73 20 69 74 65 6d 2d 74 65 73 74 2d 68 61 73 ys item-test-has
b3d0: 68 29 29 0a 20 09 09 09 09 09 09 28 74 65 73 74 h)). ......(test
b3e0: 2d 6e 61 6d 65 73 20 28 74 65 73 74 3a 67 65 74 -names (test:get
b3f0: 2d 64 61 74 61 2d 3e 62 2d 6b 65 79 73 20 69 74 -data->b-keys it
b400: 65 6d 2d 74 65 73 74 2d 68 61 73 68 20 69 74 65 em-test-hash ite
b410: 6d 73 29 29 29 0a 20 20 20 20 28 69 66 20 6f 75 ms))). (if ou
b420: 70 0a 20 20 20 20 20 20 28 62 65 67 69 6e 20 0a p. (begin .
b430: 20 20 20 20 20 28 73 3a 6f 75 74 70 75 74 2d 6e (s:output-n
b440: 65 77 0a 09 20 20 20 6f 75 70 0a 09 20 20 20 28 ew.. oup.. (
b450: 73 3a 68 74 6d 6c 20 74 65 73 74 73 3a 63 73 73 s:html tests:css
b460: 2d 6a 73 63 72 69 70 74 2d 62 6c 6f 63 6b 20 28 -jscript-block (
b470: 74 65 73 74 73 3a 63 73 73 2d 6a 73 63 72 69 70 tests:css-jscrip
b480: 74 2d 62 6c 6f 63 6b 2d 63 6f 6e 64 20 23 66 29 t-block-cond #f)
b490: 0a 09 09 20 20 20 28 73 3a 74 69 74 6c 65 20 22 ... (s:title "
b4a0: 52 75 6e 73 20 56 69 65 77 20 22 20 72 75 6e 2d Runs View " run-
b4b0: 6e 61 6d 65 29 0a 09 09 20 20 20 28 73 3a 62 6f name)... (s:bo
b4c0: 64 79 0a 09 09 20 20 20 20 20 28 73 3a 68 31 20 dy... (s:h1
b4d0: 22 52 75 6e 73 20 56 69 65 77 20 22 20 29 0a 20 "Runs View " ).
b4e0: 20 20 20 20 20 20 20 20 28 73 3a 68 33 20 22 54 (s:h3 "T
b4f0: 61 72 67 65 74 22 20 74 61 72 67 65 74 29 0a 09 arget" target)..
b500: 09 09 09 20 28 73 3a 70 20 0a 09 09 09 09 09 28 ... (s:p ......(
b510: 73 3a 62 20 22 52 75 6e 20 6e 61 6d 65 22 20 29 s:b "Run name" )
b520: 20 72 75 6e 2d 6e 61 6d 65 29 0a 20 20 20 20 20 run-name).
b530: 20 20 20 20 28 73 3a 70 20 0a 09 09 09 09 09 28 (s:p ......(
b540: 73 3a 62 20 22 52 75 6e 20 44 61 74 65 22 20 29 s:b "Run Date" )
b550: 20 72 75 6e 2d 74 69 6d 65 29 0a 20 20 20 20 20 run-time).
b560: 20 20 20 20 28 73 3a 74 61 62 6c 65 20 27 62 6f (s:table 'bo
b570: 72 64 65 72 20 31 20 27 63 65 6c 6c 73 70 61 63 rder 1 'cellspac
b580: 69 6e 67 20 30 0a 20 20 20 20 20 20 20 20 20 20 ing 0.
b590: 20 28 73 3a 74 72 0a 20 20 20 20 20 20 20 20 20 (s:tr.
b5a0: 20 20 28 73 3a 74 68 20 22 49 74 65 6d 73 22 29 (s:th "Items")
b5b0: 0a 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 70 . (map
b5c0: 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 29 0a (lambda (test).
b5d0: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 3a 74 (s:t
b5e0: 68 20 74 65 73 74 29 29 0a 20 20 20 20 20 20 20 h test)).
b5f0: 20 20 20 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 test-names))
b600: 20 20 0a 20 20 20 20 20 20 20 20 20 20 20 28 6d . (m
b610: 61 70 20 28 6c 61 6d 62 64 61 20 28 69 74 65 6d ap (lambda (item
b620: 29 20 0a 09 09 09 09 09 20 20 28 6c 65 74 2a 20 ) ...... (let*
b630: 28 28 74 65 73 74 2d 68 61 73 68 20 28 68 61 73 ((test-hash (has
b640: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
b650: 75 6c 74 20 69 74 65 6d 2d 74 65 73 74 2d 68 61 ult item-test-ha
b660: 73 68 20 69 74 65 6d 20 20 23 66 29 29 29 0a 09 sh item #f)))..
b670: 09 09 09 09 09 09 09 20 28 69 66 20 74 65 73 74 ....... (if test
b680: 2d 68 61 73 68 0a 20 20 20 20 20 20 20 20 20 20 -hash.
b690: 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 (begin..
b6a0: 09 09 09 09 09 09 09 09 28 73 3a 74 72 0a 09 09 ........(s:tr...
b6b0: 09 09 09 20 20 09 09 09 28 73 3a 74 64 20 27 63 ... ...(s:td 'c
b6c0: 6c 61 73 73 20 22 74 65 73 74 22 20 69 74 65 6d lass "test" item
b6d0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 09 09 ). ..
b6e0: 09 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 74 .(map (lambda (t
b6f0: 65 73 74 29 0a 09 09 09 09 09 09 20 20 09 09 28 est)....... ..(
b700: 6c 65 74 2a 20 28 28 74 65 73 74 2d 64 65 74 61 let* ((test-deta
b710: 69 6c 73 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ils (hash-table-
b720: 72 65 66 2f 64 65 66 61 75 6c 74 20 74 65 73 74 ref/default test
b730: 2d 68 61 73 68 20 74 65 73 74 20 20 23 66 29 29 -hash test #f))
b740: 0a 09 09 09 09 09 09 09 09 09 09 09 09 28 73 74 .............(st
b750: 61 74 75 73 20 28 69 66 20 74 65 73 74 2d 64 65 atus (if test-de
b760: 74 61 69 6c 73 0a 09 09 09 09 09 09 09 09 09 09 tails...........
b770: 09 09 09 09 09 09 28 63 61 72 20 74 65 73 74 2d ......(car test-
b780: 64 65 74 61 69 6c 73 29 29 29 0a 20 20 20 20 20 details))).
b790: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b7a0: 20 20 20 28 6c 69 6e 6b 20 28 69 66 20 74 65 73 (link (if tes
b7b0: 74 2d 64 65 74 61 69 6c 73 20 0a 09 09 09 09 09 t-details ......
b7c0: 09 09 09 09 09 09 09 09 09 28 73 74 72 69 6e 67 .........(string
b7d0: 2d 73 75 62 73 74 69 74 75 74 65 20 20 28 63 6f -substitute (co
b7e0: 6e 63 20 6c 69 6e 6b 74 72 65 65 20 22 2f 22 20 nc linktree "/"
b7f0: 74 61 72 67 65 74 20 22 2f 22 20 72 75 6e 2d 6e target "/" run-n
b800: 61 6d 65 20 22 2f 22 29 20 20 22 22 20 28 63 61 ame "/") "" (ca
b810: 64 72 20 74 65 73 74 2d 64 65 74 61 69 6c 73 29 dr test-details)
b820: 20 22 2d 22 29 29 29 29 0a 20 20 20 20 20 20 20 "-")))).
b830: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
b840: 74 65 73 74 2d 64 65 74 61 69 6c 73 0a 09 09 09 test-details....
b850: 09 09 09 09 09 09 09 09 28 73 3a 74 64 20 27 63 ........(s:td 'c
b860: 6c 61 73 73 20 73 74 61 74 75 73 0a 09 09 09 09 lass status.....
b870: 09 09 09 09 09 09 09 09 28 73 3a 61 20 27 63 6c ........(s:a 'cl
b880: 61 73 73 20 22 6c 69 6e 6b 22 20 27 68 72 65 66 ass "link" 'href
b890: 20 6c 69 6e 6b 20 73 74 61 74 75 73 20 29 29 0a link status )).
b8a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b8b0: 20 20 20 20 20 20 28 73 3a 74 64 20 22 22 29 29 (s:td ""))
b8c0: 29 29 20 09 09 09 0a 09 09 09 09 09 09 09 09 09 )) .............
b8d0: 74 65 73 74 2d 6e 61 6d 65 73 29 29 29 29 29 29 test-names))))))
b8e0: 0a 09 09 09 09 20 20 28 73 6f 72 74 20 69 74 65 ..... (sort ite
b8f0: 6d 73 20 73 74 72 69 6e 67 3c 3d 3f 29 29 29 29 ms string<=?))))
b900: 29 29 0a 09 09 28 63 6c 6f 73 65 2d 6f 75 74 70 ))...(close-outp
b910: 75 74 2d 70 6f 72 74 20 6f 75 70 29 29 0a 20 20 ut-port oup)).
b920: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
b930: 6e 66 6f 20 30 20 22 53 6b 69 70 3a 20 44 69 72 nfo 0 "Skip: Dir
b940: 63 74 6f 72 79 20 73 74 72 75 63 74 75 72 65 20 ctory structure
b950: 22 20 6c 69 6e 6b 74 72 65 65 20 22 2f 22 20 74 " linktree "/" t
b960: 61 72 67 65 74 20 22 2f 22 20 72 75 6e 2d 6e 61 arget "/" run-na
b970: 6d 65 20 22 20 64 6f 65 73 20 6e 6f 74 20 65 78 me " does not ex
b980: 69 73 74 2e 20 4d 65 67 61 74 65 73 74 20 77 69 ist. Megatest wi
b990: 6c 6c 20 6e 6f 74 20 63 72 65 61 74 65 20 72 75 ll not create ru
b9a0: 6e 2e 68 74 6d 6c 22 29 29 29 29 0a 72 75 6e 73 n.html")))).runs
b9b0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 ))..(define (tes
b9c0: 74 3a 63 72 65 61 74 65 2d 74 61 72 67 65 74 2d t:create-target-
b9d0: 68 61 73 68 20 72 75 6e 73 20 68 65 61 64 65 72 hash runs header
b9e0: 20 6e 75 6d 6b 65 79 73 29 0a 20 20 28 6c 65 74 numkeys). (let
b9f0: 20 28 28 72 65 73 68 20 28 6d 61 6b 65 2d 68 61 ((resh (make-ha
ba00: 73 68 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 28 sh-table))). (
ba10: 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 6c for-each. (l
ba20: 61 6d 62 64 61 20 28 72 75 6e 29 0a 20 20 20 20 ambda (run).
ba30: 20 20 20 20 28 6c 65 74 2a 20 28 28 72 75 6e 2d (let* ((run-
ba40: 6e 61 6d 65 20 28 64 62 3a 67 65 74 2d 76 61 6c name (db:get-val
ba50: 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e ue-by-header run
ba60: 20 68 65 61 64 65 72 20 22 72 75 6e 6e 61 6d 65 header "runname
ba70: 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ")).
ba80: 20 20 20 28 74 61 72 67 65 74 20 20 20 28 73 74 (target (st
ba90: 72 69 6e 67 2d 6a 6f 69 6e 20 28 74 61 6b 65 20 ring-join (take
baa0: 28 76 65 63 74 6f 72 2d 3e 6c 69 73 74 20 72 75 (vector->list ru
bab0: 6e 29 20 6e 75 6d 6b 65 79 73 29 20 22 2f 22 29 n) numkeys) "/")
bac0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
bad0: 20 28 72 75 6e 2d 6c 69 73 74 20 28 68 61 73 68 (run-list (hash
bae0: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
baf0: 6c 74 20 72 65 73 68 20 74 61 72 67 65 74 20 20 lt resh target
bb00: 23 66 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 #f))).
bb10: 20 20 20 20 20 0a 20 20 20 20 20 20 20 20 20 20 .
bb20: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 72 75 (if (not ru
bb30: 6e 2d 6c 69 73 74 29 0a 20 20 20 20 20 20 20 20 n-list).
bb40: 20 20 20 20 20 20 20 20 20 20 20 28 68 61 73 68 (hash
bb50: 2d 74 61 62 6c 65 2d 73 65 74 21 20 72 65 73 68 -table-set! resh
bb60: 20 74 61 72 67 65 74 20 20 20 28 6c 69 73 74 20 target (list
bb70: 72 75 6e 2d 6e 61 6d 65 29 29 0a 20 20 20 20 20 run-name)).
bb80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 68 (h
bb90: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 72 ash-table-set! r
bba0: 65 73 68 20 74 61 72 67 65 74 20 20 20 28 63 6f esh target (co
bbb0: 6e 73 20 72 75 6e 2d 6e 61 6d 65 20 72 75 6e 2d ns run-name run-
bbc0: 6c 69 73 74 29 29 29 29 29 0a 20 20 20 20 20 20 list))))).
bbd0: 72 75 6e 73 29 0a 20 20 20 72 65 73 68 29 29 0a runs). resh)).
bbe0: 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 3a 67 .(define (test:g
bbf0: 65 74 2d 6d 61 78 2d 72 75 6e 2d 63 6e 74 20 74 et-max-run-cnt t
bc00: 61 72 67 65 74 2d 68 61 73 68 20 74 61 72 67 65 arget-hash targe
bc10: 74 73 29 0a 20 20 20 28 6c 65 74 2a 20 28 28 63 ts). (let* ((c
bc20: 6e 74 20 30 20 29 29 0a 20 20 20 28 6d 61 70 20 nt 0 )). (map
bc30: 28 6c 61 6d 62 64 61 20 28 74 61 72 67 65 74 29 (lambda (target)
bc40: 0a 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 . (let* (
bc50: 28 72 75 6e 73 20 20 28 68 61 73 68 2d 74 61 62 (runs (hash-tab
bc60: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 le-ref/default t
bc70: 61 72 67 65 74 2d 68 61 73 68 20 74 61 72 67 65 arget-hash targe
bc80: 74 20 20 23 66 29 29 0a 20 20 20 20 20 20 20 20 t #f)).
bc90: 20 20 20 20 20 20 20 28 72 75 6e 2d 6c 65 6e 67 (run-leng
bca0: 74 68 20 28 69 66 20 72 75 6e 73 0a 09 09 09 09 th (if runs.....
bcb0: 09 09 09 09 09 09 09 09 09 09 09 09 28 6c 65 6e ............(len
bcc0: 67 74 68 20 72 75 6e 73 29 0a 20 20 20 20 20 20 gth runs).
bcd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bce0: 20 20 20 20 20 20 20 20 20 20 20 30 29 29 29 0a 0))).
bcf0: 20 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 .
bd00: 20 28 69 66 20 28 3c 20 63 6e 74 20 72 75 6e 2d (if (< cnt run-
bd10: 6c 65 6e 67 74 68 29 0a 20 20 20 20 20 20 20 20 length).
bd20: 20 20 20 20 20 20 20 28 73 65 74 21 20 63 6e 74 (set! cnt
bd30: 20 20 72 75 6e 2d 6c 65 6e 67 74 68 29 29 29 29 run-length))))
bd40: 20 0a 09 09 74 61 72 67 65 74 73 29 20 0a 63 6e ...targets) .cn
bd50: 74 29 29 0a 20 0a 28 64 65 66 69 6e 65 20 28 74 t)). .(define (t
bd60: 65 73 74 3a 70 61 64 2d 72 75 6e 73 20 74 61 72 est:pad-runs tar
bd70: 67 65 74 2d 68 61 73 68 20 74 61 72 67 65 74 73 get-hash targets
bd80: 20 6d 61 78 2d 72 6f 77 2d 6c 65 6e 67 74 68 29 max-row-length)
bd90: 0a 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 . (map (lambda (
bda0: 74 61 72 67 65 74 29 0a 20 20 20 20 20 20 20 20 target).
bdb0: 28 6c 65 74 20 6c 6f 6f 70 20 28 28 72 75 6e 2d (let loop ((run-
bdc0: 6c 69 73 74 20 20 28 68 61 73 68 2d 74 61 62 6c list (hash-tabl
bdd0: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 61 e-ref/default ta
bde0: 72 67 65 74 2d 68 61 73 68 20 74 61 72 67 65 74 rget-hash target
bdf0: 20 20 23 66 29 29 29 0a 20 20 20 20 20 20 20 20 #f))).
be00: 20 20 20 20 20 20 20 28 69 66 20 28 3c 20 28 6c (if (< (l
be10: 65 6e 67 74 68 20 72 75 6e 2d 6c 69 73 74 29 20 ength run-list)
be20: 6d 61 78 2d 72 6f 77 2d 6c 65 6e 67 74 68 29 0a max-row-length).
be30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
be40: 20 28 62 65 67 69 6e 20 20 0a 20 20 20 20 20 20 (begin .
be50: 20 20 20 20 20 20 20 20 20 09 09 20 28 68 61 73 .. (has
be60: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 61 72 h-table-set! tar
be70: 67 65 74 2d 68 61 73 68 20 74 61 72 67 65 74 20 get-hash target
be80: 20 20 28 63 6f 6e 73 20 22 22 20 72 75 6e 2d 6c (cons "" run-l
be90: 69 73 74 29 29 0a 20 20 20 20 20 20 20 20 20 20 ist)).
bea0: 20 20 20 20 20 09 09 20 28 6c 6f 6f 70 20 28 68 .. (loop (h
beb0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
bec0: 66 61 75 6c 74 20 74 61 72 67 65 74 2d 68 61 73 fault target-has
bed0: 68 20 74 61 72 67 65 74 20 20 23 66 29 20 29 29 h target #f) ))
bee0: 29 29 29 20 0a 09 09 74 61 72 67 65 74 73 29 0a ))) ...targets).
bef0: 20 20 20 74 61 72 67 65 74 2d 68 61 73 68 29 0a target-hash).
bf00: 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 3a 63 .(define (test:c
bf10: 72 65 61 74 65 2d 74 61 72 67 65 74 2d 68 74 6d reate-target-htm
bf20: 6c 20 74 61 72 67 65 74 2d 68 61 73 68 20 6f 75 l target-hash ou
bf30: 70 20 61 72 65 61 2d 6e 61 6d 65 20 6c 69 6e 6b p area-name link
bf40: 74 72 65 65 29 0a 20 20 28 6c 65 74 2a 20 28 28 tree). (let* ((
bf50: 74 61 72 67 65 74 73 20 28 68 61 73 68 2d 74 61 targets (hash-ta
bf60: 62 6c 65 2d 6b 65 79 73 20 74 61 72 67 65 74 2d ble-keys target-
bf70: 68 61 73 68 29 29 0a 20 20 20 20 20 20 20 20 20 hash)).
bf80: 28 6d 61 78 2d 72 6f 77 2d 6c 65 6e 67 74 68 20 (max-row-length
bf90: 28 74 65 73 74 3a 67 65 74 2d 6d 61 78 2d 72 75 (test:get-max-ru
bfa0: 6e 2d 63 6e 74 20 74 61 72 67 65 74 2d 68 61 73 n-cnt target-has
bfb0: 68 20 74 61 72 67 65 74 73 29 29 0a 20 20 20 20 h targets)).
bfc0: 20 20 20 20 20 28 70 61 64 2d 72 75 6e 73 2d 68 (pad-runs-h
bfd0: 61 73 68 20 28 74 65 73 74 3a 70 61 64 2d 72 75 ash (test:pad-ru
bfe0: 6e 73 20 74 61 72 67 65 74 2d 68 61 73 68 20 74 ns target-hash t
bff0: 61 72 67 65 74 73 20 6d 61 78 2d 72 6f 77 2d 6c argets max-row-l
c000: 65 6e 67 74 68 29 29 29 0a 20 20 20 28 73 3a 6f ength))). (s:o
c010: 75 74 70 75 74 2d 6e 65 77 0a 09 20 20 20 6f 75 utput-new.. ou
c020: 70 0a 09 20 20 20 28 73 3a 68 74 6d 6c 20 74 65 p.. (s:html te
c030: 73 74 73 3a 63 73 73 2d 6a 73 63 72 69 70 74 2d sts:css-jscript-
c040: 62 6c 6f 63 6b 20 28 74 65 73 74 73 3a 63 73 73 block (tests:css
c050: 2d 6a 73 63 72 69 70 74 2d 62 6c 6f 63 6b 2d 63 -jscript-block-c
c060: 6f 6e 64 20 23 66 29 0a 0a 09 09 20 20 20 28 73 ond #f).... (s
c070: 3a 74 69 74 6c 65 20 22 54 61 72 67 65 74 20 56 :title "Target V
c080: 69 65 77 20 22 20 61 72 65 61 2d 6e 61 6d 65 29 iew " area-name)
c090: 0a 09 09 20 20 20 28 73 3a 62 6f 64 79 0a 09 09 ... (s:body...
c0a0: 20 20 20 28 73 3a 68 31 20 22 54 61 72 67 65 74 (s:h1 "Target
c0b0: 20 56 69 65 77 20 22 20 61 72 65 61 2d 6e 61 6d View " area-nam
c0c0: 65 29 0a 09 09 09 09 09 28 73 3a 74 61 62 6c 65 e)......(s:table
c0d0: 20 27 69 64 20 22 4c 69 6e 6b 65 64 4c 69 73 74 'id "LinkedList
c0e0: 31 22 20 27 62 6f 72 64 65 72 20 22 31 22 20 27 1" 'border "1" '
c0f0: 63 65 6c 6c 73 70 61 63 69 6e 67 20 30 0a 20 20 cellspacing 0.
c100: 20 20 20 20 20 20 20 20 20 20 20 28 73 3a 74 72 (s:tr
c110: 20 27 63 6c 61 73 73 20 22 73 6f 6d 65 74 68 69 'class "somethi
c120: 6e 67 22 20 0a 20 20 20 20 20 20 20 20 20 20 20 ng" .
c130: 20 20 20 20 28 73 3a 74 68 20 22 54 61 72 67 65 (s:th "Targe
c140: 74 22 29 0a 09 09 09 09 09 09 09 09 28 73 3a 74 t").........(s:t
c150: 68 20 27 63 6f 6c 73 70 61 6e 20 6d 61 78 2d 72 h 'colspan max-r
c160: 6f 77 2d 6c 65 6e 67 74 68 20 22 52 75 6e 73 22 ow-length "Runs"
c170: 29 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ))
c180: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c190: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c1a0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
c1b0: 20 28 6c 65 74 2a 20 28 28 74 62 6c 20 28 6d 61 (let* ((tbl (ma
c1c0: 70 20 28 6c 61 6d 62 64 61 20 28 74 61 72 67 65 p (lambda (targe
c1d0: 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 t).
c1e0: 20 20 20 20 20 20 20 20 20 28 73 3a 74 72 0a 20 (s:tr.
c1f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c200: 20 20 20 20 20 28 73 3a 74 64 20 27 63 6c 61 73 (s:td 'clas
c210: 73 20 22 74 65 73 74 22 20 74 61 72 67 65 74 29 s "test" target)
c220: 0a 09 09 09 09 09 09 09 09 09 09 20 20 28 6c 65 ........... (le
c230: 74 2a 20 28 28 72 75 6e 73 20 20 28 68 61 73 68 t* ((runs (hash
c240: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
c250: 6c 74 20 74 61 72 67 65 74 2d 68 61 73 68 20 74 lt target-hash t
c260: 61 72 67 65 74 20 20 23 66 29 29 0a 09 09 09 09 arget #f)).....
c270: 09 09 09 09 09 09 09 09 09 09 20 28 72 65 73 74 .......... (rest
c280: 2d 72 6f 77 20 28 6d 61 70 20 28 6c 61 6d 62 64 -row (map (lambd
c290: 61 20 28 72 75 6e 29 0a 09 09 09 09 09 09 09 09 a (run).........
c2a0: 09 09 09 09 09 09 09 09 09 09 09 09 28 69 66 20 ............(if
c2b0: 28 65 71 75 61 6c 3f 20 72 75 6e 20 22 22 29 0a (equal? run "").
c2c0: 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 ................
c2d0: 09 09 09 09 09 09 28 73 3a 74 64 20 72 75 6e 29 ......(s:td run)
c2e0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
c2f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c300: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
c310: 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 28 63 (file-exists?(c
c320: 6f 6e 63 20 6c 69 6e 6b 74 72 65 65 20 22 2f 22 onc linktree "/"
c330: 20 74 61 72 67 65 74 20 22 2f 22 20 72 75 6e 20 target "/" run
c340: 29 29 0a 09 09 09 09 09 09 09 09 09 09 09 09 09 ))..............
c350: 09 09 09 09 09 09 09 09 09 28 62 65 67 69 6e 20 .........(begin
c360: 0a 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 ................
c370: 09 09 09 09 09 09 09 09 28 73 3a 74 64 20 0a 09 ........(s:td ..
c380: 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 ................
c390: 09 09 09 09 09 09 28 73 3a 61 20 27 68 72 65 66 ......(s:a 'href
c3a0: 20 28 63 6f 6e 63 20 20 74 61 72 67 65 74 20 22 (conc target "
c3b0: 2f 22 20 72 75 6e 20 22 2f 72 75 6e 2e 68 74 6d /" run "/run.htm
c3c0: 6c 22 29 20 72 75 6e 29 29 29 29 29 29 0a 09 09 l") run))))))...
c3d0: 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 ................
c3e0: 09 09 28 72 65 76 65 72 73 65 20 72 75 6e 73 29 ..(reverse runs)
c3f0: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
c400: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c410: 20 20 72 65 73 74 2d 72 6f 77 29 29 29 0a 20 20 rest-row))).
c420: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c430: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c440: 20 74 61 72 67 65 74 73 29 29 29 0a 20 20 20 20 targets))).
c450: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c460: 20 20 20 20 20 20 20 74 62 6c 29 29 29 29 29 0a tbl))))).
c470: 20 20 20 20 20 20 20 20 20 20 28 63 6c 6f 73 65 (close
c480: 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 6f 75 70 -output-port oup
c490: 29 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 74 )))...(define (t
c4a0: 65 73 74 73 3a 63 72 65 61 74 65 2d 68 74 6d 6c ests:create-html
c4b0: 2d 74 72 65 65 2d 6f 6c 64 20 6f 75 74 66 29 0a -tree-old outf).
c4c0: 20 20 20 28 6c 65 74 2a 20 28 28 6c 6f 63 6b 66 (let* ((lockf
c4d0: 69 6c 65 20 20 28 63 6f 6e 63 20 6f 75 74 66 20 ile (conc outf
c4e0: 22 2e 6c 6f 63 6b 22 29 29 0a 09 20 28 72 75 6e ".lock")).. (run
c4f0: 73 2d 74 6f 2d 70 72 6f 63 65 73 73 20 27 28 29 s-to-process '()
c500: 29 29 0a 20 20 20 20 28 69 66 20 28 63 6f 6d 6d )). (if (comm
c510: 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 6c on:simple-file-l
c520: 6f 63 6b 20 6c 6f 63 6b 66 69 6c 65 29 0a 09 28 ock lockfile)..(
c530: 6c 65 74 2a 20 28 28 6c 69 6e 6b 74 72 65 65 20 let* ((linktree
c540: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 69 6e (common:get-lin
c550: 6b 74 72 65 65 29 29 0a 09 20 20 20 20 20 20 20 ktree))..
c560: 28 6f 75 70 20 20 20 20 20 20 20 28 6f 70 65 6e (oup (open
c570: 2d 6f 75 74 70 75 74 2d 66 69 6c 65 20 28 6f 72 -output-file (or
c580: 20 6f 75 74 66 20 28 63 6f 6e 63 20 6c 69 6e 6b outf (conc link
c590: 74 72 65 65 20 22 2f 72 75 6e 73 2d 69 6e 64 65 tree "/runs-inde
c5a0: 78 2e 68 74 6d 6c 22 29 29 29 29 0a 09 20 20 20 x.html"))))..
c5b0: 20 20 20 20 28 61 72 65 61 2d 6e 61 6d 65 20 28 (area-name (
c5c0: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 74 65 73 74 73 common:get-tests
c5d0: 75 69 74 65 2d 6e 61 6d 65 29 29 0a 09 20 20 20 uite-name))..
c5e0: 20 20 20 20 28 6b 65 79 73 20 20 20 20 20 20 28 (keys (
c5f0: 72 6d 74 3a 67 65 74 2d 6b 65 79 73 29 29 0a 09 rmt:get-keys))..
c600: 20 20 20 20 20 20 20 28 6e 75 6d 6b 65 79 73 20 (numkeys
c610: 20 20 28 6c 65 6e 67 74 68 20 6b 65 79 73 29 29 (length keys))
c620: 0a 09 20 20 20 20 20 20 20 28 72 75 6e 73 64 61 .. (runsda
c630: 74 20 20 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e t (rmt:get-run
c640: 73 20 22 25 22 20 23 66 20 23 66 20 28 6d 61 70 s "%" #f #f (map
c650: 20 28 6c 61 6d 62 64 61 20 28 78 29 28 6c 69 73 (lambda (x)(lis
c660: 74 20 78 20 22 25 22 29 29 20 6b 65 79 73 29 29 t x "%")) keys))
c670: 29 0a 09 20 20 20 20 20 20 20 28 68 65 61 64 65 ).. (heade
c680: 72 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 r (vector-ref
c690: 20 72 75 6e 73 64 61 74 20 30 29 29 0a 09 20 20 runsdat 0))..
c6a0: 20 20 20 20 20 28 72 75 6e 73 20 20 20 20 20 20 (runs
c6b0: 28 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 73 (vector-ref runs
c6c0: 64 61 74 20 31 29 29 0a 09 20 20 20 20 20 20 20 dat 1))..
c6d0: 28 72 75 6e 74 72 65 65 64 61 74 20 28 6d 61 70 (runtreedat (map
c6e0: 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 09 09 (lambda (x)....
c6f0: 09 20 20 28 74 65 73 74 73 3a 72 75 6e 2d 72 65 . (tests:run-re
c700: 63 6f 72 64 2d 3e 74 65 73 74 2d 70 61 74 68 20 cord->test-path
c710: 78 20 6e 75 6d 6b 65 79 73 29 29 0a 09 09 09 09 x numkeys)).....
c720: 72 75 6e 73 29 29 0a 09 20 20 20 20 20 20 20 28 runs)).. (
c730: 72 75 6e 73 2d 68 74 72 65 65 20 28 63 6f 6d 6d runs-htree (comm
c740: 6f 6e 3a 6c 69 73 74 2d 3e 68 74 72 65 65 20 72 on:list->htree r
c750: 75 6e 74 72 65 65 64 61 74 29 29 29 0a 09 20 20 untreedat)))..
c760: 28 73 65 74 21 20 72 75 6e 73 2d 74 6f 2d 70 72 (set! runs-to-pr
c770: 6f 63 65 73 73 20 72 75 6e 73 29 0a 09 20 20 28 ocess runs).. (
c780: 73 3a 6f 75 74 70 75 74 2d 6e 65 77 0a 09 20 20 s:output-new..
c790: 20 6f 75 70 0a 09 20 20 20 28 73 3a 68 74 6d 6c oup.. (s:html
c7a0: 20 74 65 73 74 73 3a 63 73 73 2d 6a 73 63 72 69 tests:css-jscri
c7b0: 70 74 2d 62 6c 6f 63 6b 0a 09 09 20 20 20 28 73 pt-block... (s
c7c0: 3a 74 69 74 6c 65 20 22 53 75 6d 6d 61 72 79 20 :title "Summary
c7d0: 66 6f 72 20 22 20 61 72 65 61 2d 6e 61 6d 65 29 for " area-name)
c7e0: 0a 09 09 20 20 20 28 73 3a 62 6f 64 79 20 27 6f ... (s:body 'o
c7f0: 6e 6c 6f 61 64 20 22 61 64 64 45 76 65 6e 74 73 nload "addEvents
c800: 28 29 3b 22 0a 09 09 09 20 20 20 28 73 3a 68 31 ();".... (s:h1
c810: 20 22 53 75 6d 6d 61 72 79 20 66 6f 72 20 22 20 "Summary for "
c820: 61 72 65 61 2d 6e 61 6d 65 29 0a 09 09 09 20 20 area-name)....
c830: 20 3b 3b 20 74 6f 70 20 6c 69 73 74 0a 09 09 09 ;; top list....
c840: 20 20 20 28 73 3a 75 6c 20 27 69 64 20 22 4c 69 (s:ul 'id "Li
c850: 6e 6b 65 64 4c 69 73 74 31 22 20 27 63 6c 61 73 nkedList1" 'clas
c860: 73 20 22 4c 69 6e 6b 65 64 4c 69 73 74 22 0a 09 s "LinkedList"..
c870: 09 09 09 20 28 73 3a 6c 69 0a 09 09 09 09 20 20 ... (s:li.....
c880: 22 52 75 6e 73 22 0a 09 09 09 09 20 20 28 63 6f "Runs"..... (co
c890: 6d 6d 6f 6e 3a 68 74 72 65 65 2d 3e 68 74 6d 6c mmon:htree->html
c8a0: 20 72 75 6e 73 2d 68 74 72 65 65 0a 09 09 09 09 runs-htree.....
c8b0: 09 09 20 20 20 20 20 20 27 28 29 0a 09 09 09 09 .. '().....
c8c0: 09 09 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 .. (lambda
c8d0: 28 78 20 70 29 0a 09 09 09 09 09 09 09 28 6c 65 (x p)........(le
c8e0: 74 2a 20 28 28 74 61 72 67 2d 70 61 74 68 20 28 t* ((targ-path (
c8f0: 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
c900: 73 65 20 70 20 22 2f 22 29 29 0a 20 20 20 20 20 se p "/")).
c910: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c920: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c930: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c940: 20 20 20 20 20 20 20 20 20 20 28 66 75 6c 6c 2d (full-
c950: 70 61 74 68 20 28 63 6f 6e 63 20 6c 69 6e 6b 74 path (conc linkt
c960: 72 65 65 20 22 2f 22 20 74 61 72 67 2d 70 61 74 ree "/" targ-pat
c970: 68 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 h)).
c980: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c990: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c9a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c9b0: 20 20 20 28 72 75 6e 2d 6e 61 6d 65 20 20 28 63 (run-name (c
c9c0: 61 72 20 28 72 65 76 65 72 73 65 20 70 29 29 29 ar (reverse p)))
c9d0: 29 0a 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 20 20 20 20 20 20 20 20 20 20 20 20 20
ca00: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
ca10: 28 61 6e 64 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c (and (common:fil
ca20: 65 2d 65 78 69 73 74 73 3f 20 66 75 6c 6c 2d 70 e-exists? full-p
ca30: 61 74 68 29 0a 20 20 20 20 20 20 20 20 20 20 20 ath).
ca40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ca50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ca60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ca70: 20 20 20 20 20 20 20 20 28 64 69 72 65 63 74 6f (directo
ca80: 72 79 3f 20 20 20 66 75 6c 6c 2d 70 61 74 68 29 ry? full-path)
ca90: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
caa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cab0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cac0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cad0: 20 20 20 20 28 66 69 6c 65 2d 77 72 69 74 65 2d (file-write-
cae0: 61 63 63 65 73 73 3f 20 66 75 6c 6c 2d 70 61 74 access? full-pat
caf0: 68 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 h)).
cb00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cb10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cb20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cb30: 20 20 28 73 3a 61 20 72 75 6e 2d 6e 61 6d 65 20 (s:a run-name
cb40: 27 68 72 65 66 20 28 63 6f 6e 63 20 74 61 72 67 'href (conc targ
cb50: 2d 70 61 74 68 20 22 2f 72 75 6e 2d 73 75 6d 6d -path "/run-summ
cb60: 61 72 79 2e 68 74 6d 6c 22 29 29 0a 20 20 20 20 ary.html")).
cb70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cb80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cb90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cba0: 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e (begin
cbb0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
cbc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cbd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cbe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cbf0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
cc00: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
cc10: 74 2a 20 22 49 4e 46 4f 3a 20 43 61 6e 27 74 20 t* "INFO: Can't
cc20: 63 72 65 61 74 65 20 22 20 74 61 72 67 2d 70 61 create " targ-pa
cc30: 74 68 20 22 2f 72 75 6e 2d 73 75 6d 6d 61 72 79 th "/run-summary
cc40: 2e 68 74 6d 6c 22 29 0a 20 20 20 20 20 20 20 20 .html").
cc50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cc60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cc70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cc80: 20 20 20 20 20 20 20 20 28 63 6f 6e 63 20 72 75 (conc ru
cc90: 6e 2d 6e 61 6d 65 20 22 20 28 4e 6f 74 20 61 62 n-name " (Not ab
cca0: 6c 65 20 74 6f 20 63 72 65 61 74 65 20 73 75 6d le to create sum
ccb0: 6d 61 72 79 20 61 74 20 22 20 74 61 72 67 2d 70 mary at " targ-p
ccc0: 61 74 68 20 22 29 22 29 29 29 29 29 29 29 29 29 ath ")")))))))))
ccd0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 63 6c )). (cl
cce0: 6f 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 ose-output-port
ccf0: 6f 75 70 29 0a 09 20 20 28 63 6f 6d 6d 6f 6e 3a oup).. (common:
cd00: 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 72 65 6c 65 simple-file-rele
cd10: 61 73 65 2d 6c 6f 63 6b 20 6c 6f 63 6b 66 69 6c ase-lock lockfil
cd20: 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 e).
cd30: 20 20 0a 09 20 20 28 66 6f 72 2d 65 61 63 68 0a .. (for-each.
cd40: 09 20 20 20 28 6c 61 6d 62 64 61 20 28 72 75 6e . (lambda (run
cd50: 29 0a 09 20 20 20 20 20 28 6c 65 74 2a 20 28 28 ).. (let* ((
cd60: 74 65 73 74 2d 73 75 62 70 61 74 68 20 28 74 65 test-subpath (te
cd70: 73 74 73 3a 72 75 6e 2d 72 65 63 6f 72 64 2d 3e sts:run-record->
cd80: 74 65 73 74 2d 70 61 74 68 20 72 75 6e 20 6e 75 test-path run nu
cd90: 6d 6b 65 79 73 29 29 0a 09 09 20 20 20 20 28 72 mkeys))... (r
cda0: 75 6e 2d 69 64 20 20 20 20 20 20 20 28 64 62 3a un-id (db:
cdb0: 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 get-value-by-hea
cdc0: 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 der run header "
cdd0: 69 64 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 id")).
cde0: 20 20 20 20 20 20 20 20 20 20 28 72 75 6e 2d 64 (run-d
cdf0: 69 72 20 20 20 20 20 20 28 74 65 73 74 73 3a 72 ir (tests:r
ce00: 75 6e 2d 72 65 63 6f 72 64 2d 3e 74 65 73 74 2d un-record->test-
ce10: 70 61 74 68 20 72 75 6e 20 6e 75 6d 6b 65 79 73 path run numkeys
ce20: 29 29 0a 09 09 20 20 20 20 28 74 65 73 74 2d 64 ))... (test-d
ce30: 61 74 73 20 20 20 20 28 72 6d 74 3a 67 65 74 2d ats (rmt:get-
ce40: 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 0a 09 09 tests-for-run...
ce50: 09 09 20 20 20 72 75 6e 2d 69 64 0a 20 20 20 20 .. run-id.
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 22 "
ce80: 25 2f 22 20 20 20 20 20 20 20 3b 3b 20 74 65 73 %/" ;; tes
ce90: 74 6e 61 6d 65 70 61 74 74 0a 09 09 09 09 20 20 tnamepatt.....
cea0: 20 27 28 29 20 20 20 20 20 20 20 20 3b 3b 20 73 '() ;; s
ceb0: 74 61 74 65 73 0a 09 09 09 09 20 20 20 27 28 29 tates..... '()
cec0: 20 20 20 20 20 20 20 20 3b 3b 20 73 74 61 74 75 ;; statu
ced0: 73 65 73 0a 09 09 09 09 20 20 20 23 66 20 20 20 ses..... #f
cee0: 20 20 20 20 20 20 3b 3b 20 6f 66 66 73 65 74 0a ;; offset.
cef0: 09 09 09 09 20 20 20 23 66 20 20 20 20 20 20 20 .... #f
cf00: 20 20 3b 3b 20 6e 75 6d 2d 74 6f 2d 67 65 74 0a ;; num-to-get.
cf10: 09 09 09 09 20 20 20 23 66 20 20 20 20 20 20 20 .... #f
cf20: 20 20 3b 3b 20 68 69 64 65 2f 6e 6f 74 2d 68 69 ;; hide/not-hi
cf30: 64 65 0a 09 09 09 09 20 20 20 23 66 20 20 20 20 de..... #f
cf40: 20 20 20 20 20 3b 3b 20 73 6f 72 74 2d 62 79 0a ;; sort-by.
cf50: 09 09 09 09 20 20 20 23 66 20 20 20 20 20 20 20 .... #f
cf60: 20 20 3b 3b 20 73 6f 72 74 2d 6f 72 64 65 72 0a ;; sort-order.
cf70: 09 09 09 09 20 20 20 23 66 20 20 20 20 20 20 20 .... #f
cf80: 20 20 3b 3b 20 27 73 68 6f 72 74 6c 69 73 74 20 ;; 'shortlist
cf90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cfa0: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 71 72 79 ;; qry
cfb0: 74 79 70 65 0a 20 20 20 20 20 20 20 20 20 20 20 type.
cfc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cfd0: 20 20 20 20 20 20 20 20 30 20 20 20 20 20 20 20 0
cfe0: 20 20 3b 3b 20 6c 61 73 74 20 75 70 64 61 74 65 ;; last update
cff0: 0a 09 09 09 09 20 20 20 23 66 29 29 0a 20 20 20 ..... #f)).
d000: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d010: 20 28 74 65 73 74 73 2d 74 72 65 65 2d 64 61 74 (tests-tree-dat
d020: 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 74 (map (lambda (t
d030: 65 73 74 2d 64 61 74 29 0a 20 20 20 20 20 20 20 est-dat).
d040: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d050: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d060: 20 20 3b 3b 20 28 74 65 73 74 73 3a 72 75 6e 2d ;; (tests:run-
d070: 72 65 63 6f 72 64 2d 3e 74 65 73 74 2d 70 61 74 record->test-pat
d080: 68 20 78 20 6e 75 6d 6b 65 79 73 29 29 0a 20 20 h x numkeys)).
d090: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d0a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d0b0: 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 (let* ((t
d0c0: 65 73 74 2d 6e 61 6d 65 20 20 28 64 62 3a 74 65 est-name (db:te
d0d0: 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 st-get-testname
d0e0: 74 65 73 74 2d 64 61 74 29 29 0a 20 20 20 20 20 test-dat)).
d0f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d100: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d110: 20 20 20 20 20 20 20 20 20 20 20 28 69 74 65 6d (item
d120: 2d 70 61 74 68 20 20 28 64 62 3a 74 65 73 74 2d -path (db:test-
d130: 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 65 get-item-path te
d140: 73 74 2d 64 61 74 29 29 0a 20 20 20 20 20 20 20 st-dat)).
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 20 28 66 75 6c 6c 2d 6e (full-n
d180: 61 6d 65 20 20 28 64 62 3a 74 65 73 74 2d 6d 61 ame (db:test-ma
d190: 6b 65 2d 66 75 6c 6c 2d 6e 61 6d 65 20 74 65 73 ke-full-name tes
d1a0: 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 t-name item-path
d1b0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
d1c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d1d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d1e0: 20 20 20 28 70 61 74 68 2d 70 61 72 74 73 20 28 (path-parts (
d1f0: 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 66 75 6c string-split ful
d200: 6c 2d 6e 61 6d 65 29 29 29 0a 20 20 20 20 20 20 l-name))).
d210: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d220: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d230: 20 20 20 20 20 70 61 74 68 2d 70 61 72 74 73 29 path-parts)
d240: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
d250: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d260: 20 20 20 20 20 20 20 20 20 74 65 73 74 2d 64 61 test-da
d270: 74 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 ts)).
d280: 20 20 20 20 20 20 20 20 20 28 74 65 73 74 73 2d (tests-
d290: 68 74 72 65 65 20 28 63 6f 6d 6d 6f 6e 3a 6c 69 htree (common:li
d2a0: 73 74 2d 3e 68 74 72 65 65 20 74 65 73 74 73 2d st->htree tests-
d2b0: 74 72 65 65 2d 64 61 74 29 29 0a 20 20 20 20 20 tree-dat)).
d2c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
d2d0: 68 74 6d 6c 2d 64 69 72 20 20 20 20 28 63 6f 6e html-dir (con
d2e0: 63 20 6c 69 6e 6b 74 72 65 65 20 22 2f 22 20 28 c linktree "/" (
d2f0: 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
d300: 73 65 20 72 75 6e 2d 64 69 72 20 22 2f 22 29 29 se run-dir "/"))
d310: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
d320: 20 20 20 20 20 20 28 68 74 6d 6c 2d 70 61 74 68 (html-path
d330: 20 20 20 28 63 6f 6e 63 20 68 74 6d 6c 2d 64 69 (conc html-di
d340: 72 20 22 2f 72 75 6e 2d 73 75 6d 6d 61 72 79 2e r "/run-summary.
d350: 68 74 6d 6c 22 29 29 0a 20 20 20 20 20 20 20 20 html")).
d360: 20 20 20 20 20 20 20 20 20 20 20 20 28 6f 75 70 (oup
d370: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 61 6e (if (an
d380: 64 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 d (common:file-e
d390: 78 69 73 74 73 3f 20 68 74 6d 6c 2d 64 69 72 29 xists? html-dir)
d3a0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
d3b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d3c0: 20 20 20 20 20 20 20 20 20 20 20 28 64 69 72 65 (dire
d3d0: 63 74 6f 72 79 3f 20 20 20 68 74 6d 6c 2d 64 69 ctory? html-di
d3e0: 72 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 r).
d3f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d400: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 66 69 (fi
d410: 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 73 73 3f le-write-access?
d420: 20 68 74 6d 6c 2d 64 69 72 29 29 0a 20 20 20 20 html-dir)).
d430: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d440: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d450: 20 28 6f 70 65 6e 2d 6f 75 74 70 75 74 2d 66 69 (open-output-fi
d460: 6c 65 20 20 68 74 6d 6c 2d 70 61 74 68 29 0a 20 le html-path).
d470: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d480: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d490: 20 20 20 20 23 66 29 29 29 0a 20 20 20 20 20 20 #f))).
d4a0: 20 20 20 20 20 20 20 20 20 3b 3b 20 28 70 72 69 ;; (pri
d4b0: 6e 74 20 22 72 75 6e 2d 64 69 72 3a 20 22 20 72 nt "run-dir: " r
d4c0: 75 6e 2d 64 69 72 20 22 2c 20 74 65 73 74 73 2d un-dir ", tests-
d4d0: 74 72 65 65 2d 64 61 74 3a 20 22 20 74 65 73 74 tree-dat: " test
d4e0: 73 2d 74 72 65 65 2d 64 61 74 29 0a 20 20 20 20 s-tree-dat).
d4f0: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 6f (if o
d500: 75 70 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 up.
d510: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 (begin.
d520: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d530: 20 20 28 73 3a 6f 75 74 70 75 74 2d 6e 65 77 0a (s:output-new.
d540: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d550: 20 20 20 20 20 20 6f 75 70 0a 20 20 20 20 20 20 oup.
d560: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d570: 28 73 3a 68 74 6d 6c 20 74 65 73 74 73 3a 63 73 (s:html tests:cs
d580: 73 2d 6a 73 63 72 69 70 74 2d 62 6c 6f 63 6b 0a s-jscript-block.
d590: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d5a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s
d5b0: 3a 74 69 74 6c 65 20 22 53 75 6d 6d 61 72 79 20 :title "Summary
d5c0: 66 6f 72 20 22 20 61 72 65 61 2d 6e 61 6d 65 29 for " area-name)
d5d0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
d5e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
d5f0: 73 3a 62 6f 64 79 20 27 6f 6e 6c 6f 61 64 20 22 s:body 'onload "
d600: 61 64 64 45 76 65 6e 74 73 28 29 3b 22 0a 20 20 addEvents();".
d610: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d620: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d630: 20 20 20 20 28 73 3a 68 31 20 22 53 75 6d 6d 61 (s:h1 "Summa
d640: 72 79 20 66 6f 72 20 22 20 28 73 74 72 69 6e 67 ry for " (string
d650: 2d 69 6e 74 65 72 73 70 65 72 73 65 20 72 75 6e -intersperse run
d660: 2d 64 69 72 20 22 2f 22 29 29 0a 20 20 20 20 20 -dir "/")).
d670: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d680: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d690: 20 3b 3b 20 74 6f 70 20 6c 69 73 74 0a 20 20 20 ;; top list.
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 20 20 20 20 20
d6c0: 20 20 20 28 73 3a 75 6c 20 27 69 64 20 22 4c 69 (s:ul 'id "Li
d6d0: 6e 6b 65 64 4c 69 73 74 31 22 20 27 63 6c 61 73 nkedList1" 'clas
d6e0: 73 20 22 4c 69 6e 6b 65 64 4c 69 73 74 22 0a 20 s "LinkedList".
d6f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d700: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d710: 20 20 20 20 20 20 20 20 20 20 20 28 73 3a 6c 69 (s:li
d720: 0a 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 20 20 20 20 20 20 20 20 20 20 20 20 20 22 54 "T
d750: 65 73 74 73 22 0a 20 20 20 20 20 20 20 20 20 20 ests".
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 28 63 6f 6d 6d 6f 6e 3a 68 74 72 65 65 (common:htree
d790: 2d 3e 68 74 6d 6c 20 74 65 73 74 73 2d 68 74 72 ->html tests-htr
d7a0: 65 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ee.
d7b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d7c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d7d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d7e0: 20 20 20 20 27 28 29 0a 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 20 20 20 20 20
d820: 20 20 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 (lambda
d830: 20 28 78 20 70 29 0a 20 20 20 20 20 20 20 20 20 (x p).
d840: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d850: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d860: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d870: 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 (let*
d880: 28 28 74 61 72 67 2d 70 61 74 68 20 28 73 74 72 ((targ-path (str
d890: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
d8a0: 70 20 22 2f 22 29 29 0a 20 20 20 20 20 20 20 20 p "/")).
d8b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d8c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d8d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d8e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d8f0: 20 20 28 74 65 73 74 2d 6e 61 6d 65 20 28 63 61 (test-name (ca
d900: 72 20 70 29 29 0a 20 20 20 20 20 20 20 20 20 20 r p)).
d910: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d920: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d930: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d940: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d950: 28 69 74 65 6d 2d 70 61 74 68 20 3b 3b 20 28 69 (item-path ;; (i
d960: 66 20 28 3e 20 28 6c 65 6e 67 74 68 20 70 29 20 f (> (length p)
d970: 32 29 20 3b 3b 20 74 65 73 74 2d 6e 61 6d 65 20 2) ;; test-name
d980: 2b 20 72 75 6e 2d 6e 61 6d 65 0a 20 20 20 20 20 + run-name.
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 20 20 20 20 20
d9b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d9c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d9d0: 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 69 6e (string-in
d9e0: 74 65 72 73 70 65 72 73 65 20 70 20 22 2f 22 29 tersperse p "/")
d9f0: 29 0a 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 20 20 20
da10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
da20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
da30: 20 20 20 20 20 20 20 20 20 20 20 20 28 66 75 6c (ful
da40: 6c 2d 74 61 72 67 20 28 63 6f 6e 63 20 68 74 6d l-targ (conc htm
da50: 6c 2d 64 69 72 20 22 2f 22 20 74 61 72 67 2d 70 l-dir "/" targ-p
da60: 61 74 68 29 29 0a 20 20 20 20 20 20 20 20 20 20 ath)).
da70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
da80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
da90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
daa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dab0: 28 73 74 64 2d 66 69 6c 65 20 20 28 63 6f 6e 63 (std-file (conc
dac0: 20 66 75 6c 6c 2d 74 61 72 67 20 22 2f 74 65 73 full-targ "/tes
dad0: 74 2d 73 75 6d 6d 61 72 79 2e 68 74 6d 6c 22 29 t-summary.html")
dae0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
daf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
db00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
db10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
db20: 20 20 20 20 20 20 20 20 20 20 20 20 28 61 6c 74 (alt
db30: 2d 66 69 6c 65 20 20 28 63 6f 6e 63 20 66 75 6c -file (conc ful
db40: 6c 2d 74 61 72 67 20 22 2f 6d 65 67 61 74 65 73 l-targ "/megates
db50: 74 2d 72 6f 6c 6c 75 70 2d 22 20 74 65 73 74 2d t-rollup-" test-
db60: 6e 61 6d 65 20 22 2e 68 74 6d 6c 22 29 29 0a 20 name ".html")).
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 20 20 20 20 20 20 20 20
dbb0: 20 20 20 20 20 20 20 20 20 28 68 74 6d 6c 2d 66 (html-f
dbc0: 69 6c 65 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a ile (if (common:
dbd0: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 61 6c 74 file-exists? alt
dbe0: 2d 66 69 6c 65 29 0a 20 20 20 20 20 20 20 20 20 -file).
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 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dc20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dc30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dc40: 61 6c 74 2d 66 69 6c 65 0a 20 20 20 20 20 20 20 alt-file.
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 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dc80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dc90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dca0: 20 20 73 74 64 2d 66 69 6c 65 29 29 0a 20 20 20 std-file)).
dcb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dcc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dcd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dce0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dcf0: 20 20 20 20 20 20 20 28 72 75 6e 2d 6e 61 6d 65 (run-name
dd00: 20 20 28 63 61 72 20 28 72 65 76 65 72 73 65 20 (car (reverse
dd10: 70 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 p)))).
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 20 20 20 20 20 20 20 20
dd40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dd50: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 (if (
dd60: 61 6e 64 20 28 6e 6f 74 20 28 63 6f 6d 6d 6f 6e and (not (common
dd70: 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 66 75 :file-exists? fu
dd80: 6c 6c 2d 74 61 72 67 29 29 0a 20 20 20 20 20 20 ll-targ)).
dd90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dda0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ddb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ddc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ddd0: 20 20 20 20 20 20 20 20 28 64 69 72 65 63 74 6f (directo
dde0: 72 79 3f 20 66 75 6c 6c 2d 74 61 72 67 29 0a 20 ry? full-targ).
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 20 20 20
de10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
de20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
de30: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 66 69 (fi
de40: 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 73 73 3f le-write-access?
de50: 20 66 75 6c 6c 2d 74 61 72 67 29 29 0a 20 20 20 full-targ)).
de60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
de70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
de80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
de90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dea0: 20 20 20 20 20 20 28 74 65 73 74 73 3a 73 75 6d (tests:sum
deb0: 6d 61 72 69 7a 65 2d 74 65 73 74 20 0a 20 20 20 marize-test .
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 20 20
def0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
df00: 20 20 20 20 20 20 20 72 75 6e 2d 69 64 20 0a 20 run-id .
df10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
df20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
df30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
df40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
df50: 20 20 20 20 20 20 20 20 20 28 72 6d 74 3a 67 65 (rmt:ge
df60: 74 2d 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 t-test-id run-id
df70: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item-
df80: 70 61 74 68 29 29 29 0a 20 20 20 20 20 20 20 20 path))).
df90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dfa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dfb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dfc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
dfd0: 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 (common:file-ex
dfe0: 69 73 74 73 3f 20 66 75 6c 6c 2d 74 61 72 67 29 ists? full-targ)
dff0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
e000: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e010: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e020: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e030: 20 20 20 20 20 20 20 20 20 20 28 73 3a 61 20 72 (s:a r
e040: 75 6e 2d 6e 61 6d 65 20 27 68 72 65 66 20 68 74 un-name 'href ht
e050: 6d 6c 2d 66 69 6c 65 29 0a 20 20 20 20 20 20 20 ml-file).
e060: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e070: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e080: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e090: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e0a0: 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 (begin.
e0b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e0c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e0d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e0e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e0f0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
e100: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
e110: 70 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 63 61 port* "ERROR: ca
e120: 6e 27 74 20 61 63 63 65 73 73 20 22 20 66 75 6c n't access " ful
e130: 6c 2d 74 61 72 67 29 0a 20 20 20 20 20 20 20 20 l-targ).
e140: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e150: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e160: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e170: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e180: 20 20 20 28 63 6f 6e 63 20 22 4e 6f 20 73 75 6d (conc "No sum
e190: 6d 61 72 79 20 66 6f 72 20 22 20 72 75 6e 2d 6e mary for " run-n
e1a0: 61 6d 65 29 29 29 29 29 0a 20 20 20 20 20 20 20 ame))))).
e1b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e1c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e1d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e1e0: 20 20 20 20 20 20 20 20 20 20 29 29 29 29 29 29 ))))))
e1f0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
e200: 20 20 20 20 20 20 28 63 6c 6f 73 65 2d 6f 75 74 (close-out
e210: 70 75 74 2d 70 6f 72 74 20 6f 75 70 29 29 29 29 put-port oup))))
e220: 29 0a 20 20 20 20 20 20 20 20 20 20 20 72 75 6e ). run
e230: 73 29 0a 20 20 20 20 20 20 20 20 20 20 23 74 29 s). #t)
e240: 0a 09 23 66 29 29 29 0a 0a 0a 0a 0a 0a 0a 0a 3b ..#f)))........;
e250: 3b 20 43 48 45 43 4b 20 2d 20 57 41 53 20 54 48 ; CHECK - WAS TH
e260: 49 53 20 41 44 44 45 44 20 4f 52 20 52 45 4d 4f IS ADDED OR REMO
e270: 56 45 44 3f 20 4d 41 4e 55 41 4c 20 4d 45 52 47 VED? MANUAL MERG
e280: 45 20 57 49 54 48 20 41 50 49 20 53 54 55 46 46 E WITH API STUFF
e290: 21 21 21 0a 3b 3b 0a 3b 3b 20 67 65 74 20 61 20 !!!.;;.;; get a
e2a0: 70 72 65 74 74 79 20 74 61 62 6c 65 20 74 6f 20 pretty table to
e2b0: 73 75 6d 6d 61 72 69 7a 65 20 73 74 65 70 73 0a summarize steps.
e2c0: 3b 3b 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 64 ;;.;; (define (d
e2d0: 63 6f 6d 6d 6f 6e 3a 70 72 6f 63 65 73 73 2d 73 common:process-s
e2e0: 74 65 70 73 2d 74 61 62 6c 65 20 73 74 65 70 73 teps-table steps
e2f0: 29 3b 3b 20 64 62 20 74 65 73 74 2d 69 64 20 23 );; db test-id #
e300: 21 6b 65 79 20 28 77 6f 72 6b 2d 61 72 65 61 20 !key (work-area
e310: 23 66 29 29 0a 28 64 65 66 69 6e 65 20 28 74 65 #f)).(define (te
e320: 73 74 73 3a 70 72 6f 63 65 73 73 2d 73 74 65 70 sts:process-step
e330: 73 2d 74 61 62 6c 65 20 73 74 65 70 73 29 3b 3b s-table steps);;
e340: 20 64 62 20 74 65 73 74 2d 69 64 20 23 21 6b 65 db test-id #!ke
e350: 79 20 28 77 6f 72 6b 2d 61 72 65 61 20 23 66 29 y (work-area #f)
e360: 29 0a 3b 3b 20 20 28 6c 65 74 20 28 28 73 74 65 ).;; (let ((ste
e370: 70 73 20 20 20 28 64 62 3a 67 65 74 2d 73 74 65 ps (db:get-ste
e380: 70 73 2d 66 6f 72 2d 74 65 73 74 20 64 62 20 74 ps-for-test db t
e390: 65 73 74 2d 69 64 20 77 6f 72 6b 2d 61 72 65 61 est-id work-area
e3a0: 3a 20 77 6f 72 6b 2d 61 72 65 61 29 29 29 0a 20 : work-area))).
e3b0: 20 20 20 3b 3b 20 6f 72 67 61 6e 69 73 65 20 74 ;; organise t
e3c0: 68 65 20 73 74 65 70 73 20 66 6f 72 20 62 65 74 he steps for bet
e3d0: 74 65 72 20 72 65 61 64 61 62 69 6c 69 74 79 0a ter readability.
e3e0: 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 20 28 (let ((res (
e3f0: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
e400: 29 29 0a 20 20 20 20 20 20 28 66 6f 72 2d 65 61 )). (for-ea
e410: 63 68 20 0a 20 20 20 20 20 20 20 28 6c 61 6d 62 ch . (lamb
e420: 64 61 20 28 73 74 65 70 29 0a 09 20 28 64 65 62 da (step).. (deb
e430: 75 67 3a 70 72 69 6e 74 20 36 20 2a 64 65 66 61 ug:print 6 *defa
e440: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 ult-log-port* "s
e450: 74 65 70 3d 22 20 73 74 65 70 29 0a 09 20 28 6c tep=" step).. (l
e460: 65 74 20 28 28 72 65 63 6f 72 64 20 28 68 61 73 et ((record (has
e470: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
e480: 75 6c 74 20 0a 09 09 09 72 65 73 20 0a 09 09 09 ult ....res ....
e490: 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 (tdb:step-get-st
e4a0: 65 70 6e 61 6d 65 20 73 74 65 70 29 0a 09 09 09 epname step)....
e4b0: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 30 20 20 ;; 0
e4c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e4d0: 20 20 20 20 31 20 20 20 20 32 20 20 20 20 33 20 1 2 3
e4e0: 20 20 20 20 20 20 34 20 20 20 20 20 20 20 20 20 4
e4f0: 35 20 20 20 20 20 20 20 36 20 20 20 20 20 20 20 5 6
e500: 37 0a 09 09 09 3b 3b 20 20 20 20 20 20 20 20 73 7....;; s
e510: 74 65 70 6e 61 6d 65 20 20 20 20 20 20 20 20 20 tepname
e520: 20 20 20 20 20 20 20 73 74 61 72 74 20 65 6e 64 start end
e530: 20 73 74 61 74 75 73 20 44 75 72 61 74 69 6f 6e status Duration
e540: 20 20 4c 6f 67 66 69 6c 65 20 43 6f 6d 6d 65 6e Logfile Commen
e550: 74 20 20 66 69 72 73 74 2d 69 64 0a 09 09 09 28 t first-id....(
e560: 76 65 63 74 6f 72 20 28 74 64 62 3a 73 74 65 70 vector (tdb:step
e570: 2d 67 65 74 2d 73 74 65 70 6e 61 6d 65 20 73 74 -get-stepname st
e580: 65 70 29 20 22 22 20 20 20 22 22 20 22 22 20 20 ep) "" "" ""
e590: 20 20 20 22 22 20 20 20 20 20 20 20 20 22 22 20 "" ""
e5a0: 20 20 20 20 22 22 20 20 20 20 20 20 20 23 66 29 "" #f)
e5b0: 29 29 29 0a 09 20 20 20 28 64 65 62 75 67 3a 70 ))).. (debug:p
e5c0: 72 69 6e 74 20 36 20 2a 64 65 66 61 75 6c 74 2d rint 6 *default-
e5d0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 65 63 6f 72 log-port* "recor
e5e0: 64 28 62 65 66 6f 72 65 29 20 3d 20 22 20 72 65 d(before) = " re
e5f0: 63 6f 72 64 20 0a 09 09 09 22 5c 6e 69 64 3a 20 cord ...."\nid:
e600: 20 20 20 20 20 20 22 20 28 74 64 62 3a 73 74 65 " (tdb:ste
e610: 70 2d 67 65 74 2d 69 64 20 73 74 65 70 29 0a 09 p-get-id step)..
e620: 09 09 22 5c 6e 73 74 65 70 6e 61 6d 65 3a 20 22 .."\nstepname: "
e630: 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 (tdb:step-get-s
e640: 74 65 70 6e 61 6d 65 20 73 74 65 70 29 0a 09 09 tepname step)...
e650: 09 22 5c 6e 73 74 61 74 65 3a 20 20 20 20 22 20 ."\nstate: "
e660: 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 (tdb:step-get-st
e670: 61 74 65 20 73 74 65 70 29 0a 09 09 09 22 5c 6e ate step)...."\n
e680: 73 74 61 74 75 73 3a 20 20 20 22 20 28 74 64 62 status: " (tdb
e690: 3a 73 74 65 70 2d 67 65 74 2d 73 74 61 74 75 73 :step-get-status
e6a0: 20 73 74 65 70 29 0a 09 09 09 22 5c 6e 74 69 6d step)...."\ntim
e6b0: 65 3a 20 20 20 20 20 22 20 28 74 64 62 3a 73 74 e: " (tdb:st
e6c0: 65 70 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 6d ep-get-event_tim
e6d0: 65 20 73 74 65 70 29 29 0a 09 20 20 20 28 69 66 e step)).. (if
e6e0: 20 28 6e 6f 74 20 28 76 65 63 74 6f 72 2d 72 65 (not (vector-re
e6f0: 66 20 72 65 63 6f 72 64 20 37 29 29 28 76 65 63 f record 7))(vec
e700: 74 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 64 20 tor-set! record
e710: 37 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 7 (tdb:step-get-
e720: 69 64 20 73 74 65 70 29 29 29 20 3b 3b 20 64 6f id step))) ;; do
e730: 20 6e 6f 74 20 63 6c 6f 62 62 65 72 20 74 68 65 not clobber the
e740: 20 69 64 20 69 66 20 70 72 65 76 69 6f 75 73 6c id if previousl
e750: 79 20 73 65 74 0a 09 20 20 20 28 63 61 73 65 20 y set.. (case
e760: 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 (string->symbol
e770: 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 (tdb:step-get-st
e780: 61 74 65 20 73 74 65 70 29 29 0a 09 20 20 20 20 ate step))..
e790: 20 28 28 73 74 61 72 74 29 28 76 65 63 74 6f 72 ((start)(vector
e7a0: 2d 73 65 74 21 20 72 65 63 6f 72 64 20 31 20 28 -set! record 1 (
e7b0: 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 65 76 65 tdb:step-get-eve
e7c0: 6e 74 5f 74 69 6d 65 20 73 74 65 70 29 29 0a 09 nt_time step))..
e7d0: 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 73 65 (vector-se
e7e0: 74 21 20 72 65 63 6f 72 64 20 33 20 28 69 66 20 t! record 3 (if
e7f0: 28 65 71 75 61 6c 3f 20 28 76 65 63 74 6f 72 2d (equal? (vector-
e800: 72 65 66 20 72 65 63 6f 72 64 20 33 29 20 22 22 ref record 3) ""
e810: 29 0a 09 09 09 09 09 28 74 64 62 3a 73 74 65 70 )......(tdb:step
e820: 2d 67 65 74 2d 73 74 61 74 75 73 20 73 74 65 70 -get-status step
e830: 29 29 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 ))).. (if (
e840: 3e 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 > (string-length
e850: 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 6c (tdb:step-get-l
e860: 6f 67 66 69 6c 65 20 73 74 65 70 29 29 0a 09 09 ogfile step))...
e870: 20 20 20 20 20 30 29 0a 09 09 20 20 28 76 65 63 0)... (vec
e880: 74 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 64 20 tor-set! record
e890: 35 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 5 (tdb:step-get-
e8a0: 6c 6f 67 66 69 6c 65 20 73 74 65 70 29 29 29 29 logfile step))))
e8b0: 0a 09 20 20 20 20 20 28 28 65 6e 64 29 20 20 0a .. ((end) .
e8c0: 09 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 73 . (vector-s
e8d0: 65 74 21 20 72 65 63 6f 72 64 20 32 20 28 61 6e et! record 2 (an
e8e0: 79 2d 3e 6e 75 6d 62 65 72 20 28 74 64 62 3a 73 y->number (tdb:s
e8f0: 74 65 70 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 tep-get-event_ti
e900: 6d 65 20 73 74 65 70 29 29 29 0a 09 20 20 20 20 me step)))..
e910: 20 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 72 (vector-set! r
e920: 65 63 6f 72 64 20 33 20 28 74 64 62 3a 73 74 65 ecord 3 (tdb:ste
e930: 70 2d 67 65 74 2d 73 74 61 74 75 73 20 73 74 65 p-get-status ste
e940: 70 29 29 0a 09 20 20 20 20 20 20 28 76 65 63 74 p)).. (vect
e950: 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 64 20 34 or-set! record 4
e960: 20 28 6c 65 74 20 28 28 73 74 61 72 74 74 20 28 (let ((startt (
e970: 61 6e 79 2d 3e 6e 75 6d 62 65 72 20 28 76 65 63 any->number (vec
e980: 74 6f 72 2d 72 65 66 20 72 65 63 6f 72 64 20 31 tor-ref record 1
e990: 29 29 29 0a 09 09 09 09 09 20 20 28 65 6e 64 74 )))...... (endt
e9a0: 20 20 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 20 (any->number
e9b0: 28 76 65 63 74 6f 72 2d 72 65 66 20 72 65 63 6f (vector-ref reco
e9c0: 72 64 20 32 29 29 29 29 0a 09 09 09 09 20 20 20 rd 2)))).....
e9d0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
e9e0: 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 4 *default-log-p
e9f0: 6f 72 74 2a 20 22 72 65 63 6f 72 64 5b 31 5d 3d ort* "record[1]=
ea00: 22 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 65 " (vector-ref re
ea10: 63 6f 72 64 20 31 29 20 0a 09 09 09 09 09 09 20 cord 1) .......
ea20: 20 20 22 2c 20 73 74 61 72 74 74 3d 22 20 73 74 ", startt=" st
ea30: 61 72 74 74 20 22 2c 20 65 6e 64 74 3d 22 20 65 artt ", endt=" e
ea40: 6e 64 74 0a 09 09 09 09 09 09 20 20 20 22 2c 20 ndt....... ",
ea50: 67 65 74 2d 73 74 61 74 75 73 3a 20 22 20 28 74 get-status: " (t
ea60: 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 61 74 db:step-get-stat
ea70: 75 73 20 73 74 65 70 29 29 0a 09 09 09 09 20 20 us step)).....
ea80: 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 6e 75 (if (and (nu
ea90: 6d 62 65 72 3f 20 73 74 61 72 74 74 29 28 6e 75 mber? startt)(nu
eaa0: 6d 62 65 72 3f 20 65 6e 64 74 29 29 0a 09 09 09 mber? endt))....
eab0: 09 09 20 20 28 73 65 63 6f 6e 64 73 2d 3e 68 72 .. (seconds->hr
eac0: 2d 6d 69 6e 2d 73 65 63 20 28 2d 20 65 6e 64 74 -min-sec (- endt
ead0: 20 73 74 61 72 74 74 29 29 20 22 2d 31 22 29 29 startt)) "-1"))
eae0: 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 3e 20 ).. (if (>
eaf0: 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 28 (string-length (
eb00: 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 6c 6f 67 tdb:step-get-log
eb10: 66 69 6c 65 20 73 74 65 70 29 29 0a 09 09 20 20 file step))...
eb20: 20 20 20 30 29 0a 09 09 20 20 28 76 65 63 74 6f 0)... (vecto
eb30: 72 2d 73 65 74 21 20 72 65 63 6f 72 64 20 35 20 r-set! record 5
eb40: 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 6c 6f (tdb:step-get-lo
eb50: 67 66 69 6c 65 20 73 74 65 70 29 29 29 0a 09 20 gfile step)))..
eb60: 20 20 20 20 20 28 69 66 20 28 3e 20 28 73 74 72 (if (> (str
eb70: 69 6e 67 2d 6c 65 6e 67 74 68 20 28 74 64 62 3a ing-length (tdb:
eb80: 73 74 65 70 2d 67 65 74 2d 63 6f 6d 6d 65 6e 74 step-get-comment
eb90: 20 73 74 65 70 29 29 0a 09 09 20 20 20 20 20 30 step))... 0
eba0: 29 0a 09 09 20 20 28 76 65 63 74 6f 72 2d 73 65 )... (vector-se
ebb0: 74 21 20 72 65 63 6f 72 64 20 36 20 28 74 64 62 t! record 6 (tdb
ebc0: 3a 73 74 65 70 2d 67 65 74 2d 63 6f 6d 6d 65 6e :step-get-commen
ebd0: 74 20 73 74 65 70 29 29 29 29 0a 09 20 20 20 20 t step))))..
ebe0: 20 28 65 6c 73 65 0a 09 20 20 20 20 20 20 28 76 (else.. (v
ebf0: 65 63 74 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 ector-set! recor
ec00: 64 20 32 20 28 74 64 62 3a 73 74 65 70 2d 67 65 d 2 (tdb:step-ge
ec10: 74 2d 73 74 61 74 65 20 73 74 65 70 29 29 0a 09 t-state step))..
ec20: 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 73 65 (vector-se
ec30: 74 21 20 72 65 63 6f 72 64 20 33 20 28 74 64 62 t! record 3 (tdb
ec40: 3a 73 74 65 70 2d 67 65 74 2d 73 74 61 74 75 73 :step-get-status
ec50: 20 73 74 65 70 29 29 0a 09 20 20 20 20 20 20 28 step)).. (
ec60: 76 65 63 74 6f 72 2d 73 65 74 21 20 72 65 63 6f vector-set! reco
ec70: 72 64 20 34 20 28 74 64 62 3a 73 74 65 70 2d 67 rd 4 (tdb:step-g
ec80: 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 73 74 et-event_time st
ec90: 65 70 29 29 0a 09 20 20 20 20 20 20 28 76 65 63 ep)).. (vec
eca0: 74 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 64 20 tor-set! record
ecb0: 36 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 6 (tdb:step-get-
ecc0: 63 6f 6d 6d 65 6e 74 20 73 74 65 70 29 29 29 29 comment step))))
ecd0: 0a 09 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 .. (hash-table
ece0: 2d 73 65 74 21 20 72 65 73 20 28 74 64 62 3a 73 -set! res (tdb:s
ecf0: 74 65 70 2d 67 65 74 2d 73 74 65 70 6e 61 6d 65 tep-get-stepname
ed00: 20 73 74 65 70 29 20 72 65 63 6f 72 64 29 0a 09 step) record)..
ed10: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
ed20: 36 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6 *default-log-p
ed30: 6f 72 74 2a 20 22 72 65 63 6f 72 64 28 61 66 74 ort* "record(aft
ed40: 65 72 29 20 20 3d 20 22 20 72 65 63 6f 72 64 20 er) = " record
ed50: 0a 09 09 09 22 5c 6e 69 64 3a 20 20 20 20 20 20 ...."\nid:
ed60: 20 22 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 " (tdb:step-get
ed70: 2d 69 64 20 73 74 65 70 29 0a 09 09 09 22 5c 6e -id step)...."\n
ed80: 73 74 65 70 6e 61 6d 65 3a 20 22 20 28 74 64 62 stepname: " (tdb
ed90: 3a 73 74 65 70 2d 67 65 74 2d 73 74 65 70 6e 61 :step-get-stepna
eda0: 6d 65 20 73 74 65 70 29 0a 09 09 09 22 5c 6e 73 me step)...."\ns
edb0: 74 61 74 65 3a 20 20 20 20 22 20 28 74 64 62 3a tate: " (tdb:
edc0: 73 74 65 70 2d 67 65 74 2d 73 74 61 74 65 20 73 step-get-state s
edd0: 74 65 70 29 0a 09 09 09 22 5c 6e 73 74 61 74 75 tep)...."\nstatu
ede0: 73 3a 20 20 20 22 20 28 74 64 62 3a 73 74 65 70 s: " (tdb:step
edf0: 2d 67 65 74 2d 73 74 61 74 75 73 20 73 74 65 70 -get-status step
ee00: 29 0a 09 09 09 22 5c 6e 74 69 6d 65 3a 20 20 20 )...."\ntime:
ee10: 20 20 22 20 28 74 64 62 3a 73 74 65 70 2d 67 65 " (tdb:step-ge
ee20: 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 73 74 65 t-event_time ste
ee30: 70 29 29 29 29 0a 20 20 20 20 20 20 20 3b 3b 20 p)))). ;;
ee40: 28 65 6c 73 65 20 20 20 28 76 65 63 74 6f 72 2d (else (vector-
ee50: 73 65 74 21 20 72 65 63 6f 72 64 20 31 20 28 74 set! record 1 (t
ee60: 64 62 3a 73 74 65 70 2d 67 65 74 2d 65 76 65 6e db:step-get-even
ee70: 74 5f 74 69 6d 65 20 73 74 65 70 29 29 29 0a 20 t_time step))).
ee80: 20 20 20 20 20 20 28 73 6f 72 74 20 73 74 65 70 (sort step
ee90: 73 20 28 6c 61 6d 62 64 61 20 28 61 20 62 29 0a s (lambda (a b).
eea0: 09 09 20 20 20 20 20 28 63 6f 6e 64 0a 09 09 20 .. (cond...
eeb0: 20 20 20 20 20 28 28 3c 20 20 20 28 74 64 62 3a ((< (tdb:
eec0: 73 74 65 70 2d 67 65 74 2d 65 76 65 6e 74 5f 74 step-get-event_t
eed0: 69 6d 65 20 61 29 28 74 64 62 3a 73 74 65 70 2d ime a)(tdb:step-
eee0: 67 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 62 get-event_time b
eef0: 29 29 20 23 74 29 0a 09 09 20 20 20 20 20 20 28 )) #t)... (
ef00: 28 65 71 3f 20 28 74 64 62 3a 73 74 65 70 2d 67 (eq? (tdb:step-g
ef10: 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 61 29 et-event_time a)
ef20: 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 65 76 (tdb:step-get-ev
ef30: 65 6e 74 5f 74 69 6d 65 20 62 29 29 20 0a 09 09 ent_time b)) ...
ef40: 20 20 20 20 20 20 20 28 3c 20 20 20 28 74 64 62 (< (tdb
ef50: 3a 73 74 65 70 2d 67 65 74 2d 69 64 20 61 29 20 :step-get-id a)
ef60: 20 20 20 20 20 20 20 28 74 64 62 3a 73 74 65 70 (tdb:step
ef70: 2d 67 65 74 2d 69 64 20 62 29 29 29 0a 09 09 20 -get-id b)))...
ef80: 20 20 20 20 20 28 65 6c 73 65 20 23 66 29 29 29 (else #f)))
ef90: 29 29 0a 20 20 20 20 20 20 72 65 73 29 29 0a 0a )). res))..
efa0: 3b 3b 20 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 ;; .;;.(define (
efb0: 74 65 73 74 73 3a 67 65 74 2d 63 6f 6d 70 72 65 tests:get-compre
efc0: 73 73 65 64 2d 73 74 65 70 73 20 72 75 6e 2d 69 ssed-steps run-i
efd0: 64 20 74 65 73 74 2d 69 64 29 0a 20 20 28 6c 65 d test-id). (le
efe0: 74 2a 20 28 28 73 74 65 70 73 2d 64 61 74 61 20 t* ((steps-data
eff0: 20 28 72 6d 74 3a 67 65 74 2d 73 74 65 70 73 2d (rmt:get-steps-
f000: 66 6f 72 2d 74 65 73 74 20 72 75 6e 2d 69 64 20 for-test run-id
f010: 74 65 73 74 2d 69 64 29 29 20 3b 3b 20 20 20 20 test-id)) ;;
f020: 20 20 30 20 20 20 20 20 20 20 31 20 20 20 20 32 0 1 2
f030: 20 20 20 20 33 20 20 20 20 20 20 20 34 20 20 20 3 4
f040: 20 20 20 20 35 20 20 20 20 20 20 20 36 20 20 20 5 6
f050: 20 20 20 37 20 20 20 20 20 20 20 0a 09 20 28 63 7 .. (c
f060: 6f 6d 70 72 73 74 65 70 73 20 20 28 74 65 73 74 omprsteps (test
f070: 73 3a 70 72 6f 63 65 73 73 2d 73 74 65 70 73 2d s:process-steps-
f080: 74 61 62 6c 65 20 73 74 65 70 73 2d 64 61 74 61 table steps-data
f090: 29 29 29 20 3b 3b 20 23 3c 73 74 65 70 6e 61 6d ))) ;; #<stepnam
f0a0: 65 20 73 74 61 72 74 20 65 6e 64 20 73 74 61 74 e start end stat
f0b0: 75 73 20 44 75 72 61 74 69 6f 6e 20 4c 6f 67 66 us Duration Logf
f0c0: 69 6c 65 20 43 6f 6d 6d 65 6e 74 20 69 64 3e 0a ile Comment id>.
f0d0: 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 (map (lambda
f0e0: 20 28 78 29 0a 09 20 20 20 3b 3b 20 74 61 6b 65 (x).. ;; take
f0f0: 20 61 64 76 61 6e 74 61 67 65 20 6f 66 20 74 68 advantage of th
f100: 65 20 5c 6e 20 6f 6e 20 74 69 6d 65 2d 3e 73 74 e \n on time->st
f110: 72 69 6e 67 0a 09 20 20 20 28 76 65 63 74 6f 72 ring.. (vector
f120: 20 20 20 20 3b 3b 20 77 65 20 61 72 65 20 63 6f ;; we are co
f130: 6e 73 74 72 75 63 74 69 6e 67 20 62 61 73 69 63 nstructing basic
f140: 61 6c 6c 79 20 74 68 65 20 6f 72 69 67 69 6e 61 ally the origina
f150: 6c 20 76 65 63 74 6f 72 20 62 75 74 20 63 6f 6c l vector but col
f160: 6c 61 70 73 69 6e 67 20 73 74 61 72 74 20 65 6e lapsing start en
f170: 64 20 72 65 63 6f 72 64 73 0a 09 20 20 20 20 28 d records.. (
f180: 76 65 63 74 6f 72 2d 72 65 66 20 78 20 30 29 20 vector-ref x 0)
f190: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
f1a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ;;
f1b0: 69 64 20 20 20 20 20 20 20 20 30 0a 09 20 20 20 id 0..
f1c0: 20 28 6c 65 74 20 28 28 73 20 28 76 65 63 74 6f (let ((s (vecto
f1d0: 72 2d 72 65 66 20 78 20 31 29 29 29 0a 09 20 20 r-ref x 1)))..
f1e0: 20 20 20 20 28 69 66 20 28 6e 75 6d 62 65 72 3f (if (number?
f1f0: 20 73 29 28 73 65 63 6f 6e 64 73 2d 3e 74 69 6d s)(seconds->tim
f200: 65 2d 73 74 72 69 6e 67 20 73 29 20 73 29 29 20 e-string s) s))
f210: 3b 3b 20 73 74 61 72 74 74 69 6d 65 20 31 0a 09 ;; starttime 1..
f220: 20 20 20 20 28 6c 65 74 20 28 28 73 20 28 76 65 (let ((s (ve
f230: 63 74 6f 72 2d 72 65 66 20 78 20 32 29 29 29 0a ctor-ref x 2))).
f240: 09 20 20 20 20 20 20 28 69 66 20 28 6e 75 6d 62 . (if (numb
f250: 65 72 3f 20 73 29 28 73 65 63 6f 6e 64 73 2d 3e er? s)(seconds->
f260: 74 69 6d 65 2d 73 74 72 69 6e 67 20 73 29 20 73 time-string s) s
f270: 29 29 20 3b 3b 20 65 6e 64 74 69 6d 65 20 20 20 )) ;; endtime
f280: 32 0a 09 20 20 20 20 28 76 65 63 74 6f 72 2d 72 2.. (vector-r
f290: 65 66 20 78 20 33 29 20 20 20 20 20 20 20 20 20 ef x 3)
f2a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
f2b0: 20 20 20 20 20 3b 3b 20 73 74 61 74 75 73 20 20 ;; status
f2c0: 20 20 33 20 20 20 20 0a 09 20 20 20 20 28 76 65 3 .. (ve
f2d0: 63 74 6f 72 2d 72 65 66 20 78 20 34 29 20 20 20 ctor-ref x 4)
f2e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
f2f0: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 64 75 ;; du
f300: 72 61 74 69 6f 6e 20 20 34 0a 09 20 20 20 20 28 ration 4.. (
f310: 76 65 63 74 6f 72 2d 72 65 66 20 78 20 35 29 20 vector-ref x 5)
f320: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
f330: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ;;
f340: 6c 6f 67 66 69 6c 65 20 20 20 35 0a 09 20 20 20 logfile 5..
f350: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 78 20 36 (vector-ref x 6
f360: 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 )
f370: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
f380: 3b 20 63 6f 6d 6d 65 6e 74 20 20 20 36 0a 09 20 ; comment 6..
f390: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 78 (vector-ref x
f3a0: 20 37 29 29 29 20 20 20 20 20 20 20 20 20 20 20 7)))
f3b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
f3c0: 20 3b 3b 20 69 64 20 20 20 20 20 20 20 20 37 0a ;; id 7.
f3d0: 09 20 28 73 6f 72 74 20 28 68 61 73 68 2d 74 61 . (sort (hash-ta
f3e0: 62 6c 65 2d 76 61 6c 75 65 73 20 63 6f 6d 70 72 ble-values compr
f3f0: 73 74 65 70 73 29 0a 09 20 20 20 20 20 20 20 28 steps).. (
f400: 6c 61 6d 62 64 61 20 28 61 20 62 29 0a 09 09 20 lambda (a b)...
f410: 28 6c 65 74 20 28 28 74 69 6d 65 2d 61 20 28 76 (let ((time-a (v
f420: 65 63 74 6f 72 2d 72 65 66 20 61 20 31 29 29 0a ector-ref a 1)).
f430: 09 09 20 20 20 20 20 20 20 28 74 69 6d 65 2d 62 .. (time-b
f440: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 62 20 31 (vector-ref b 1
f450: 29 29 0a 09 09 20 20 20 20 20 20 20 28 69 64 2d ))... (id-
f460: 61 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 a (vector-ref
f470: 61 20 37 29 29 0a 09 09 20 20 20 20 20 20 20 28 a 7))... (
f480: 69 64 2d 62 20 20 20 28 76 65 63 74 6f 72 2d 72 id-b (vector-r
f490: 65 66 20 62 20 37 29 29 29 0a 09 09 20 20 20 28 ef b 7)))... (
f4a0: 69 66 20 28 61 6e 64 20 28 6e 75 6d 62 65 72 3f if (and (number?
f4b0: 20 74 69 6d 65 2d 61 29 28 6e 75 6d 62 65 72 3f time-a)(number?
f4c0: 20 74 69 6d 65 2d 62 29 29 0a 09 09 20 20 20 20 time-b))...
f4d0: 20 20 20 28 69 66 20 28 3c 20 74 69 6d 65 2d 61 (if (< time-a
f4e0: 20 74 69 6d 65 2d 62 29 0a 09 09 09 20 20 20 23 time-b).... #
f4f0: 74 0a 09 09 09 20 20 20 28 69 66 20 28 65 71 3f t.... (if (eq?
f500: 20 74 69 6d 65 2d 61 20 74 69 6d 65 2d 62 29 0a time-a time-b).
f510: 09 09 09 20 20 20 20 20 20 20 28 3c 20 69 64 2d ... (< id-
f520: 61 20 69 64 2d 62 29 0a 09 09 09 20 20 20 20 20 a id-b)....
f530: 20 20 3b 3b 20 28 73 74 72 69 6e 67 3c 3f 20 28 ;; (string<? (
f540: 63 6f 6e 63 20 28 76 65 63 74 6f 72 2d 72 65 66 conc (vector-ref
f550: 20 61 20 32 29 29 0a 09 09 09 20 20 20 20 20 20 a 2))....
f560: 20 3b 3b 09 20 20 20 20 28 63 6f 6e 63 20 28 76 ;;. (conc (v
f570: 65 63 74 6f 72 2d 72 65 66 20 62 20 32 29 29 29 ector-ref b 2)))
f580: 0a 09 09 09 20 20 20 20 20 20 20 23 66 29 29 0a .... #f)).
f590: 09 09 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 .. (string
f5a0: 3c 3f 20 28 63 6f 6e 63 20 74 69 6d 65 2d 61 29 <? (conc time-a)
f5b0: 28 63 6f 6e 63 20 74 69 6d 65 2d 62 29 29 29 29 (conc time-b))))
f5c0: 29 29 29 29 29 0a 0a 0a 3b 3b 20 53 61 76 65 20 )))))...;; Save
f5d0: 74 65 73 74 20 73 74 61 74 65 20 61 6e 64 20 73 test state and s
f5e0: 74 61 74 75 73 20 69 6e 20 74 6f 20 61 20 66 69 tatus in to a fi
f5f0: 6c 65 20 2e 66 69 6e 61 6c 2d 73 74 61 74 75 73 le .final-status
f600: 20 69 6e 20 74 68 65 20 74 65 73 74 20 64 69 72 in the test dir
f610: 65 63 74 6f 72 79 0a 3b 3b 0a 28 64 65 66 69 6e ectory.;;.(defin
f620: 65 20 28 74 65 73 74 73 3a 73 61 76 65 2d 66 69 e (tests:save-fi
f630: 6e 61 6c 2d 73 74 61 74 75 73 20 72 75 6e 2d 69 nal-status run-i
f640: 64 20 74 65 73 74 2d 69 64 29 0a 20 20 28 6c 65 d test-id). (le
f650: 74 2a 20 28 28 74 65 73 74 2d 64 61 74 20 20 28 t* ((test-dat (
f660: 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 rmt:get-test-inf
f670: 6f 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 74 o-by-id run-id t
f680: 65 73 74 2d 69 64 29 29 0a 09 20 28 6f 75 74 2d est-id)).. (out-
f690: 64 69 72 20 20 20 28 64 62 3a 74 65 73 74 2d 67 dir (db:test-g
f6a0: 65 74 2d 72 75 6e 64 69 72 20 74 65 73 74 2d 64 et-rundir test-d
f6b0: 61 74 29 29 0a 09 20 28 73 74 61 74 75 73 2d 66 at)).. (status-f
f6c0: 69 6c 65 20 20 28 63 6f 6e 63 20 6f 75 74 2d 64 ile (conc out-d
f6d0: 69 72 20 22 2f 2e 66 69 6e 61 6c 2d 73 74 61 74 ir "/.final-stat
f6e0: 75 73 22 29 29 0a 20 20 20 29 0a 20 20 20 20 3b us")). ). ;
f6f0: 3b 20 66 69 72 73 74 20 76 65 72 69 66 79 20 77 ; first verify w
f700: 65 20 61 72 65 20 61 62 6c 65 20 74 6f 20 77 72 e are able to wr
f710: 69 74 65 20 74 68 65 20 6f 75 74 70 75 74 20 66 ite the output f
f720: 69 6c 65 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 ile. (if (not
f730: 20 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 (file-write-acc
f740: 65 73 73 3f 20 6f 75 74 2d 64 69 72 29 29 0a 09 ess? out-dir))..
f750: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
f760: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
f770: 70 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 63 61 port* "ERROR: ca
f780: 6e 6e 6f 74 20 77 72 69 74 65 20 2e 66 69 6e 61 nnot write .fina
f790: 6c 2d 73 74 61 74 75 73 20 74 6f 20 22 20 6f 75 l-status to " ou
f7a0: 74 2d 64 69 72 29 0a 09 20 20 20 20 28 6c 65 74 t-dir).. (let
f7b0: 2a 20 0a 20 20 20 20 20 20 20 20 20 28 28 6f 75 * . ((ou
f7c0: 74 70 20 20 20 20 20 20 28 6f 70 65 6e 2d 6f 75 tp (open-ou
f7d0: 74 70 75 74 2d 66 69 6c 65 20 73 74 61 74 75 73 tput-file status
f7e0: 2d 66 69 6c 65 29 29 0a 09 20 20 20 20 20 20 20 -file))..
f7f0: 28 73 74 61 74 75 73 20 20 20 20 28 64 62 3a 74 (status (db:t
f800: 65 73 74 2d 67 65 74 2d 73 74 61 74 75 73 20 20 est-get-status
f810: 20 74 65 73 74 2d 64 61 74 29 29 0a 20 20 20 20 test-dat)).
f820: 20 20 20 20 20 28 73 74 61 74 65 20 20 20 20 20 (state
f830: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 (db:test-get-sta
f840: 74 65 20 20 20 20 74 65 73 74 2d 64 61 74 29 29 te test-dat))
f850: 29 0a 20 20 20 20 20 20 20 20 28 66 70 72 69 6e ). (fprin
f860: 74 66 20 6f 75 74 70 20 22 7e 53 5c 6e 22 20 73 tf outp "~S\n" s
f870: 74 61 74 65 29 20 0a 20 20 20 20 20 20 20 20 28 tate) . (
f880: 66 70 72 69 6e 74 66 20 6f 75 74 70 20 22 7e 53 fprintf outp "~S
f890: 5c 6e 22 20 73 74 61 74 75 73 29 20 0a 20 20 20 \n" status) .
f8a0: 20 20 20 20 20 28 63 6c 6f 73 65 2d 6f 75 74 70 (close-outp
f8b0: 75 74 2d 70 6f 72 74 20 6f 75 74 70 29 29 29 29 ut-port outp))))
f8c0: 29 0a 0a 0a 3b 3b 20 73 75 6d 6d 61 72 69 7a 65 )...;; summarize
f8d0: 20 74 65 73 74 20 69 6e 20 74 6f 20 61 20 66 69 test in to a fi
f8e0: 6c 65 20 74 65 73 74 2d 73 75 6d 6d 61 72 79 2e le test-summary.
f8f0: 68 74 6d 6c 20 69 6e 20 74 68 65 20 74 65 73 74 html in the test
f900: 20 64 69 72 65 63 74 6f 72 79 0a 3b 3b 0a 28 64 directory.;;.(d
f910: 65 66 69 6e 65 20 28 74 65 73 74 73 3a 73 75 6d efine (tests:sum
f920: 6d 61 72 69 7a 65 2d 74 65 73 74 20 72 75 6e 2d marize-test run-
f930: 69 64 20 74 65 73 74 2d 69 64 29 0a 20 20 28 6c id test-id). (l
f940: 65 74 2a 20 28 28 74 65 73 74 2d 64 61 74 20 20 et* ((test-dat
f950: 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 6e (rmt:get-test-in
f960: 66 6f 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 fo-by-id run-id
f970: 74 65 73 74 2d 69 64 29 29 0a 09 20 28 6f 75 74 test-id)).. (out
f980: 2d 64 69 72 20 20 20 28 64 62 3a 74 65 73 74 2d -dir (db:test-
f990: 67 65 74 2d 72 75 6e 64 69 72 20 74 65 73 74 2d get-rundir test-
f9a0: 64 61 74 29 29 0a 09 20 28 6f 75 74 2d 66 69 6c dat)).. (out-fil
f9b0: 65 20 20 28 63 6f 6e 63 20 6f 75 74 2d 64 69 72 e (conc out-dir
f9c0: 20 22 2f 74 65 73 74 2d 73 75 6d 6d 61 72 79 2e "/test-summary.
f9d0: 68 74 6d 6c 22 29 29 29 0a 20 20 20 20 3b 3b 20 html"))). ;;
f9e0: 66 69 72 73 74 20 76 65 72 69 66 79 20 77 65 20 first verify we
f9f0: 61 72 65 20 61 62 6c 65 20 74 6f 20 77 72 69 74 are able to writ
fa00: 65 20 74 68 65 20 6f 75 74 70 75 74 20 66 69 6c e the output fil
fa10: 65 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 e. (if (not (
fa20: 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 73 file-write-acces
fa30: 73 3f 20 6f 75 74 2d 64 69 72 29 29 0a 09 28 64 s? out-dir))..(d
fa40: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
fa50: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
fa60: 22 45 52 52 4f 52 3a 20 63 61 6e 6e 6f 74 20 77 "ERROR: cannot w
fa70: 72 69 74 65 20 74 65 73 74 2d 73 75 6d 6d 61 72 rite test-summar
fa80: 79 2e 68 74 6d 6c 20 74 6f 20 22 20 6f 75 74 2d y.html to " out-
fa90: 64 69 72 29 0a 09 28 6c 65 74 2a 20 28 3b 3b 20 dir)..(let* (;;
faa0: 28 73 74 65 70 73 2d 64 61 74 20 28 72 6d 74 3a (steps-dat (rmt:
fab0: 67 65 74 2d 73 74 65 70 73 2d 66 6f 72 2d 74 65 get-steps-for-te
fac0: 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 st run-id test-i
fad0: 64 29 29 0a 09 20 20 20 20 20 20 20 28 74 65 73 d)).. (tes
fae0: 74 2d 6e 61 6d 65 20 28 64 62 3a 74 65 73 74 2d t-name (db:test-
faf0: 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 get-testname tes
fb00: 74 2d 64 61 74 29 29 0a 09 20 20 20 20 20 20 20 t-dat))..
fb10: 28 69 74 65 6d 2d 70 61 74 68 20 28 64 62 3a 74 (item-path (db:t
fb20: 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 est-get-item-pat
fb30: 68 20 74 65 73 74 2d 64 61 74 29 29 0a 09 20 20 h test-dat))..
fb40: 20 20 20 20 20 28 66 75 6c 6c 2d 6e 61 6d 65 20 (full-name
fb50: 28 64 62 3a 74 65 73 74 2d 6d 61 6b 65 2d 66 75 (db:test-make-fu
fb60: 6c 6c 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d ll-name test-nam
fb70: 65 20 69 74 65 6d 2d 70 61 74 68 29 29 0a 09 20 e item-path))..
fb80: 20 20 20 20 20 20 28 6f 75 70 20 20 20 20 20 20 (oup
fb90: 20 28 6f 70 65 6e 2d 6f 75 74 70 75 74 2d 66 69 (open-output-fi
fba0: 6c 65 20 6f 75 74 2d 66 69 6c 65 29 29 0a 09 20 le out-file))..
fbb0: 20 20 20 20 20 20 28 73 74 61 74 75 73 20 20 20 (status
fbc0: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 (db:test-get-st
fbd0: 61 74 75 73 20 20 20 74 65 73 74 2d 64 61 74 29 atus test-dat)
fbe0: 29 0a 09 20 20 20 20 20 20 20 28 63 6f 6c 6f 72 ).. (color
fbf0: 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 (common:get
fc00: 2d 63 6f 6c 6f 72 2d 66 72 6f 6d 2d 73 74 61 74 -color-from-stat
fc10: 75 73 20 73 74 61 74 75 73 29 29 0a 09 20 20 20 us status))..
fc20: 20 20 20 20 28 6c 6f 67 66 20 20 20 20 20 20 28 (logf (
fc30: 64 62 3a 74 65 73 74 2d 67 65 74 2d 66 69 6e 61 db:test-get-fina
fc40: 6c 5f 6c 6f 67 66 20 74 65 73 74 2d 64 61 74 29 l_logf test-dat)
fc50: 29 0a 09 20 20 20 20 20 20 20 28 73 74 65 70 73 ).. (steps
fc60: 2d 64 61 74 20 28 74 65 73 74 73 3a 67 65 74 2d -dat (tests:get-
fc70: 63 6f 6d 70 72 65 73 73 65 64 2d 73 74 65 70 73 compressed-steps
fc80: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 run-id test-id)
fc90: 29 29 0a 09 20 20 3b 3b 20 28 64 63 6f 6d 6d 6f )).. ;; (dcommo
fca0: 6e 3a 67 65 74 2d 63 6f 6d 70 72 65 73 73 65 64 n:get-compressed
fcb0: 2d 73 74 65 70 73 20 23 66 20 31 20 33 30 30 34 -steps #f 1 3004
fcc0: 35 29 0a 09 20 20 3b 3b 20 28 23 28 22 77 61 73 5).. ;; (#("was
fcd0: 74 69 6e 67 5f 74 69 6d 65 22 20 22 32 33 3a 33 ting_time" "23:3
fce0: 36 3a 31 33 22 20 22 32 33 3a 33 36 3a 32 31 22 6:13" "23:36:21"
fcf0: 20 22 30 22 20 22 38 2e 30 73 22 20 22 77 61 73 "0" "8.0s" "was
fd00: 74 69 6e 67 5f 74 69 6d 65 2e 6c 6f 67 22 29 29 ting_time.log"))
fd10: 0a 09 0a 09 20 20 28 73 3a 6f 75 74 70 75 74 2d .... (s:output-
fd20: 6e 65 77 0a 09 20 20 20 6f 75 70 0a 09 20 20 20 new.. oup..
fd30: 28 73 3a 68 74 6d 6c 0a 09 20 20 20 20 28 73 3a (s:html.. (s:
fd40: 74 69 74 6c 65 20 22 53 75 6d 6d 61 72 79 20 66 title "Summary f
fd50: 6f 72 20 22 20 66 75 6c 6c 2d 6e 61 6d 65 29 0a or " full-name).
fd60: 09 20 20 20 20 28 73 3a 62 6f 64 79 20 0a 09 20 . (s:body ..
fd70: 20 20 20 20 28 73 3a 68 32 20 22 53 75 6d 6d 61 (s:h2 "Summa
fd80: 72 79 20 66 6f 72 20 22 20 66 75 6c 6c 2d 6e 61 ry for " full-na
fd90: 6d 65 29 0a 09 20 20 20 20 20 28 73 3a 74 61 62 me).. (s:tab
fda0: 6c 65 20 27 63 65 6c 6c 73 70 61 63 69 6e 67 20 le 'cellspacing
fdb0: 22 30 22 20 27 62 6f 72 64 65 72 20 22 31 22 0a "0" 'border "1".
fdc0: 09 09 20 20 20 20 20 20 28 73 3a 74 72 20 28 73 .. (s:tr (s
fdd0: 3a 74 64 20 22 72 75 6e 20 69 64 22 29 20 20 20 :td "run id")
fde0: 28 73 3a 74 64 20 28 64 62 3a 74 65 73 74 2d 67 (s:td (db:test-g
fdf0: 65 74 2d 72 75 6e 5f 69 64 20 20 20 74 65 73 74 et-run_id test
fe00: 2d 64 61 74 29 29 0a 09 09 09 20 20 20 20 28 73 -dat)).... (s
fe10: 3a 74 64 20 22 74 65 73 74 20 69 64 22 29 20 20 :td "test id")
fe20: 28 73 3a 74 64 20 28 64 62 3a 74 65 73 74 2d 67 (s:td (db:test-g
fe30: 65 74 2d 69 64 20 20 20 20 20 20 20 74 65 73 74 et-id test
fe40: 2d 64 61 74 29 29 29 0a 09 09 20 20 20 20 20 20 -dat)))...
fe50: 28 73 3a 74 72 20 28 73 3a 74 64 20 22 74 65 73 (s:tr (s:td "tes
fe60: 74 6e 61 6d 65 22 29 20 28 73 3a 74 64 20 74 65 tname") (s:td te
fe70: 73 74 2d 6e 61 6d 65 29 0a 09 09 09 20 20 20 20 st-name)....
fe80: 28 73 3a 74 64 20 22 69 74 65 6d 70 61 74 68 22 (s:td "itempath"
fe90: 29 20 28 73 3a 74 64 20 69 74 65 6d 2d 70 61 74 ) (s:td item-pat
fea0: 68 29 29 0a 09 09 20 20 20 20 20 20 28 73 3a 74 h))... (s:t
feb0: 72 20 28 73 3a 74 64 20 22 73 74 61 74 65 22 29 r (s:td "state")
fec0: 20 20 20 20 28 73 3a 74 64 20 28 64 62 3a 74 65 (s:td (db:te
fed0: 73 74 2d 67 65 74 2d 73 74 61 74 65 20 20 20 20 st-get-state
fee0: 74 65 73 74 2d 64 61 74 29 29 0a 09 09 09 20 20 test-dat))....
fef0: 20 20 28 73 3a 74 64 20 22 73 74 61 74 75 73 22 (s:td "status"
ff00: 29 20 20 20 28 73 3a 74 64 20 28 73 3a 61 20 27 ) (s:td (s:a '
ff10: 68 72 65 66 20 6c 6f 67 66 20 28 73 3a 66 6f 6e href logf (s:fon
ff20: 74 20 27 63 6f 6c 6f 72 20 63 6f 6c 6f 72 20 73 t 'color color s
ff30: 74 61 74 75 73 29 29 29 29 0a 09 09 20 20 20 20 tatus))))...
ff40: 20 20 28 73 3a 74 72 20 28 73 3a 74 64 20 22 54 (s:tr (s:td "T
ff50: 65 73 74 44 61 74 65 22 29 20 28 73 3a 74 64 20 estDate") (s:td
ff60: 28 73 65 63 6f 6e 64 73 2d 3e 77 6f 72 6b 2d 77 (seconds->work-w
ff70: 65 65 6b 2f 64 61 79 2d 74 69 6d 65 20 0a 09 09 eek/day-time ...
ff80: 09 09 09 09 20 20 20 20 20 28 64 62 3a 74 65 73 .... (db:tes
ff90: 74 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 t-get-event_time
ffa0: 20 74 65 73 74 2d 64 61 74 29 29 29 0a 09 09 09 test-dat)))....
ffb0: 20 20 20 20 28 73 3a 74 64 20 22 44 75 72 61 74 (s:td "Durat
ffc0: 69 6f 6e 22 29 20 28 73 3a 74 64 20 28 73 65 63 ion") (s:td (sec
ffd0: 6f 6e 64 73 2d 3e 68 72 2d 6d 69 6e 2d 73 65 63 onds->hr-min-sec
ffe0: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 (db:test-get-ru
fff0: 6e 5f 64 75 72 61 74 69 6f 6e 20 74 65 73 74 2d n_duration test-
10000 64 61 74 29 29 29 29 29 0a 09 20 20 20 20 20 28 dat))))).. (
10010 73 3a 68 33 20 22 4c 6f 67 20 66 69 6c 65 73 22 s:h3 "Log files"
10020 29 0a 09 20 20 20 20 20 28 73 3a 74 61 62 6c 65 ).. (s:table
10030 20 0a 09 20 20 20 20 20 20 27 63 65 6c 6c 73 70 .. 'cellsp
10040 61 63 69 6e 67 20 22 30 22 20 27 62 6f 72 64 65 acing "0" 'borde
10050 72 20 22 31 22 0a 09 20 20 20 20 20 20 28 73 3a r "1".. (s:
10060 74 72 20 28 73 3a 74 64 20 22 46 69 6e 61 6c 20 tr (s:td "Final
10070 6c 6f 67 22 29 28 73 3a 74 64 20 28 73 3a 61 20 log")(s:td (s:a
10080 27 68 72 65 66 20 6c 6f 67 66 20 6c 6f 67 66 29 'href logf logf)
10090 29 29 29 0a 09 20 20 20 20 20 28 73 3a 74 61 62 ))).. (s:tab
100a0 6c 65 0a 09 20 20 20 20 20 20 27 63 65 6c 6c 73 le.. 'cells
100b0 70 61 63 69 6e 67 20 22 30 22 20 27 62 6f 72 64 pacing "0" 'bord
100c0 65 72 20 22 31 22 0a 09 20 20 20 20 20 20 28 73 er "1".. (s
100d0 3a 74 72 20 28 73 3a 74 64 20 22 53 74 65 70 20 :tr (s:td "Step
100e0 4e 61 6d 65 22 29 28 73 3a 74 64 20 22 53 74 61 Name")(s:td "Sta
100f0 72 74 22 29 28 73 3a 74 64 20 22 45 6e 64 22 29 rt")(s:td "End")
10100 28 73 3a 74 64 20 22 53 74 61 74 75 73 22 29 28 (s:td "Status")(
10110 73 3a 74 64 20 22 44 75 72 61 74 69 6f 6e 22 29 s:td "Duration")
10120 28 73 3a 74 64 20 22 4c 6f 67 20 46 69 6c 65 22 (s:td "Log File"
10130 29 29 0a 09 20 20 20 20 20 20 28 6d 61 70 20 28 )).. (map (
10140 6c 61 6d 62 64 61 20 28 73 74 65 70 2d 64 61 74 lambda (step-dat
10150 29 0a 09 09 20 20 20 20 20 28 73 3a 74 72 20 28 )... (s:tr (
10160 73 3a 74 64 20 28 74 64 62 3a 73 74 65 70 73 2d s:td (tdb:steps-
10170 74 61 62 6c 65 2d 67 65 74 2d 73 74 65 70 6e 61 table-get-stepna
10180 6d 65 20 73 74 65 70 2d 64 61 74 29 29 0a 09 09 me step-dat))...
10190 09 20 20 20 28 73 3a 74 64 20 28 74 64 62 3a 73 . (s:td (tdb:s
101a0 74 65 70 73 2d 74 61 62 6c 65 2d 67 65 74 2d 73 teps-table-get-s
101b0 74 61 72 74 20 20 20 20 73 74 65 70 2d 64 61 74 tart step-dat
101c0 29 29 0a 09 09 09 20 20 20 28 73 3a 74 64 20 28 )).... (s:td (
101d0 74 64 62 3a 73 74 65 70 73 2d 74 61 62 6c 65 2d tdb:steps-table-
101e0 67 65 74 2d 65 6e 64 20 20 20 20 20 20 73 74 65 get-end ste
101f0 70 2d 64 61 74 29 29 0a 09 09 09 20 20 20 28 73 p-dat)).... (s
10200 3a 74 64 20 28 74 64 62 3a 73 74 65 70 73 2d 74 :td (tdb:steps-t
10210 61 62 6c 65 2d 67 65 74 2d 73 74 61 74 75 73 20 able-get-status
10220 20 20 73 74 65 70 2d 64 61 74 29 29 0a 09 09 09 step-dat))....
10230 20 20 20 28 73 3a 74 64 20 28 74 64 62 3a 73 74 (s:td (tdb:st
10240 65 70 73 2d 74 61 62 6c 65 2d 67 65 74 2d 72 75 eps-table-get-ru
10250 6e 74 69 6d 65 20 20 73 74 65 70 2d 64 61 74 29 ntime step-dat)
10260 29 0a 09 09 09 20 20 20 28 73 3a 74 64 20 28 6c ).... (s:td (l
10270 65 74 20 28 28 73 74 65 70 2d 6c 6f 67 20 28 74 et ((step-log (t
10280 64 62 3a 73 74 65 70 73 2d 74 61 62 6c 65 2d 67 db:steps-table-g
10290 65 74 2d 6c 6f 67 2d 66 69 6c 65 20 73 74 65 70 et-log-file step
102a0 2d 64 61 74 29 29 29 0a 09 09 09 09 20 20 20 28 -dat)))..... (
102b0 73 3a 61 20 27 68 72 65 66 20 73 74 65 70 2d 6c s:a 'href step-l
102c0 6f 67 20 73 74 65 70 2d 6c 6f 67 29 29 29 29 29 og step-log)))))
102d0 0a 09 09 20 20 20 73 74 65 70 73 2d 64 61 74 29 ... steps-dat)
102e0 29 0a 09 20 20 20 20 20 29 29 29 0a 09 20 20 28 ).. ))).. (
102f0 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 close-output-por
10300 74 20 6f 75 70 29 29 29 29 29 0a 09 20 20 0a 09 t oup))))).. ..
10310 20 20 0a 3b 3b 20 4d 55 53 54 20 42 45 20 43 41 .;; MUST BE CA
10320 4c 4c 45 44 20 6c 6f 63 61 6c 21 0a 3b 3b 0a 28 LLED local!.;;.(
10330 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 74 65 define (tests:te
10340 73 74 2d 67 65 74 2d 70 61 74 68 73 2d 6d 61 74 st-get-paths-mat
10350 63 68 69 6e 67 20 6b 65 79 6e 61 6d 65 73 20 74 ching keynames t
10360 61 72 67 65 74 20 66 6e 61 6d 65 70 61 74 74 20 arget fnamepatt
10370 23 21 6b 65 79 20 28 72 65 73 20 27 28 29 29 29 #!key (res '()))
10380 0a 20 20 3b 3b 20 42 55 47 3a 20 4d 6f 76 65 20 . ;; BUG: Move
10390 74 68 65 20 76 61 6c 75 65 73 20 64 65 72 69 76 the values deriv
103a0 65 64 20 66 72 6f 6d 20 61 72 67 73 20 74 6f 20 ed from args to
103b0 70 61 72 61 6d 65 74 65 72 73 20 61 6e 64 20 70 parameters and p
103c0 75 73 68 20 74 6f 20 6d 65 67 61 74 65 73 74 2e ush to megatest.
103d0 73 63 6d 0a 20 20 28 6c 65 74 2a 20 28 28 74 65 scm. (let* ((te
103e0 73 74 70 61 74 74 20 20 20 28 6f 72 20 28 61 72 stpatt (or (ar
103f0 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 65 73 gs:get-arg "-tes
10400 74 70 61 74 74 22 29 28 61 72 67 73 3a 67 65 74 tpatt")(args:get
10410 2d 61 72 67 20 22 2d 74 65 73 74 70 61 74 74 22 -arg "-testpatt"
10420 29 20 22 25 22 29 29 0a 09 20 28 73 74 61 74 65 ) "%")).. (state
10430 70 61 74 74 20 20 28 6f 72 20 28 61 72 67 73 3a patt (or (args:
10440 67 65 74 2d 61 72 67 20 22 2d 73 74 61 74 65 22 get-arg "-state"
10450 29 20 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 ) (args:get-ar
10460 67 20 22 3a 73 74 61 74 65 22 29 20 20 20 20 22 g ":state") "
10470 25 22 29 29 0a 09 20 28 73 74 61 74 75 73 70 61 %")).. (statuspa
10480 74 74 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 tt (or (args:get
10490 2d 61 72 67 20 22 2d 73 74 61 74 75 73 22 29 20 -arg "-status")
104a0 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
104b0 3a 73 74 61 74 75 73 22 29 20 20 20 22 25 22 29 :status") "%")
104c0 29 0a 09 20 28 72 75 6e 6e 61 6d 65 20 20 20 20 ).. (runname
104d0 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (or (args:get-ar
104e0 67 20 22 2d 72 75 6e 6e 61 6d 65 22 29 20 28 61 g "-runname") (a
104f0 72 67 73 3a 67 65 74 2d 61 72 67 20 22 3a 72 75 rgs:get-arg ":ru
10500 6e 6e 61 6d 65 22 29 20 20 22 25 22 29 29 0a 09 nname") "%"))..
10510 20 28 70 61 74 68 73 2d 66 72 6f 6d 2d 64 62 20 (paths-from-db
10520 28 72 6d 74 3a 74 65 73 74 2d 67 65 74 2d 70 61 (rmt:test-get-pa
10530 74 68 73 2d 6d 61 74 63 68 69 6e 67 2d 6b 65 79 ths-matching-key
10540 6e 61 6d 65 73 2d 74 61 72 67 65 74 2d 6e 65 77 names-target-new
10550 20 6b 65 79 6e 61 6d 65 73 20 74 61 72 67 65 74 keynames target
10560 20 72 65 73 0a 09 09 09 09 09 74 65 73 74 70 61 res......testpa
10570 74 74 0a 09 09 09 09 09 73 74 61 74 65 70 61 74 tt......statepat
10580 74 0a 09 09 09 09 09 73 74 61 74 75 73 70 61 74 t......statuspat
10590 74 0a 09 09 09 09 09 72 75 6e 6e 61 6d 65 29 29 t......runname))
105a0 29 0a 20 20 20 20 28 69 66 20 66 6e 61 6d 65 70 ). (if fnamep
105b0 61 74 74 0a 09 28 61 70 70 6c 79 20 61 70 70 65 att..(apply appe
105c0 6e 64 20 0a 09 20 20 20 20 20 20 20 28 6d 61 70 nd .. (map
105d0 20 28 6c 61 6d 62 64 61 20 28 70 29 0a 09 09 20 (lambda (p)...
105e0 20 20 20 20 20 28 69 66 20 28 64 69 72 65 63 74 (if (direct
105f0 6f 72 79 2d 65 78 69 73 74 73 3f 20 70 29 0a 09 ory-exists? p)..
10600 09 09 20 20 28 6c 65 74 20 28 28 67 6c 6f 62 2d .. (let ((glob-
10610 71 75 65 72 79 20 28 63 6f 6e 63 20 70 20 22 2f query (conc p "/
10620 22 20 66 6e 61 6d 65 70 61 74 74 29 29 29 0a 09 " fnamepatt)))..
10630 09 09 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 .. (handle-ex
10640 63 65 70 74 69 6f 6e 73 0a 09 09 09 09 65 78 6e ceptions.....exn
10650 0a 09 09 09 20 20 20 20 20 20 28 62 65 67 69 6e .... (begin
10660 0a 09 09 09 09 28 70 72 69 6e 74 20 22 62 75 69 .....(print "bui
10670 6c 74 2d 69 6e 20 67 6c 6f 62 20 6f 6e 20 22 20 lt-in glob on "
10680 67 6c 6f 62 2d 71 75 65 72 79 20 22 2c 20 66 61 glob-query ", fa
10690 69 6c 65 64 2c 20 74 72 79 20 75 73 69 6e 67 20 iled, try using
106a0 74 68 65 20 73 68 65 6c 6c 2e 20 65 78 6e 3d 22 the shell. exn="
106b0 20 65 78 6e 29 0a 09 09 09 09 28 77 69 74 68 2d exn).....(with-
106c0 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 0a input-from-pipe.
106d0 09 09 09 09 20 28 63 6f 6e 63 20 22 65 63 68 6f .... (conc "echo
106e0 20 22 20 67 6c 6f 62 2d 71 75 65 72 79 29 0a 09 " glob-query)..
106f0 09 09 09 20 72 65 61 64 2d 6c 69 6e 65 73 29 29 ... read-lines))
10700 20 20 3b 3b 20 77 65 20 61 72 65 6e 27 74 20 67 ;; we aren't g
10710 6f 69 6e 67 20 74 6f 20 74 72 79 20 74 6f 6f 20 oing to try too
10720 68 61 72 64 2e 20 49 66 20 67 6c 6f 62 20 62 72 hard. If glob br
10730 65 61 6b 73 20 69 74 20 69 73 20 6c 69 6b 65 6c eaks it is likel
10740 79 20 62 65 63 61 75 73 65 20 73 6f 6d 65 6f 6e y because someon
10750 65 20 74 72 69 65 64 20 74 6f 20 64 6f 20 2a 2f e tried to do */
10760 2a 2f 2a 2e 6c 6f 67 20 6f 72 20 73 69 6d 69 6c */*.log or simil
10770 61 72 0a 09 09 09 20 20 20 20 20 20 28 67 6c 6f ar.... (glo
10780 62 20 67 6c 6f 62 2d 71 75 65 72 79 29 29 29 0a b glob-query))).
10790 09 09 09 20 20 27 28 29 29 29 0a 09 09 20 20 20 ... '()))...
107a0 20 70 61 74 68 73 2d 66 72 6f 6d 2d 64 62 29 29 paths-from-db))
107b0 0a 09 70 61 74 68 73 2d 66 72 6f 6d 2d 64 62 29 ..paths-from-db)
107c0 29 29 0a 0a 09 09 09 20 20 20 20 20 20 0a 3b 3b ))..... .;;
107d0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
107e0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
107f0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10800 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10810 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 47 61 74 68 65 72 ======.;; Gather
10820 20 64 61 74 61 20 66 72 6f 6d 20 74 65 73 74 2f data from test/
10830 74 61 73 6b 20 73 70 65 63 69 66 69 63 61 74 69 task specificati
10840 6f 6e 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ons.;;==========
10850 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10860 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10870 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10880 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b ============..;;
10890 20 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a (define (tests:
108a0 67 65 74 2d 76 61 6c 69 64 2d 74 65 73 74 73 20 get-valid-tests
108b0 74 65 73 74 73 64 69 72 20 74 65 73 74 2d 70 61 testsdir test-pa
108c0 74 74 73 29 20 3b 3b 20 20 23 21 6b 65 79 20 28 tts) ;; #!key (
108d0 74 65 73 74 2d 6e 61 6d 65 73 20 27 28 29 29 29 test-names '()))
108e0 0a 3b 3b 20 20 20 28 6c 65 74 20 28 28 74 65 73 .;; (let ((tes
108f0 74 73 20 28 67 6c 6f 62 20 28 63 6f 6e 63 20 74 ts (glob (conc t
10900 65 73 74 73 64 69 72 20 22 2f 74 65 73 74 73 2f estsdir "/tests/
10910 2a 22 29 29 29 29 20 3b 3b 20 22 20 28 73 74 72 *")))) ;; " (str
10920 69 6e 67 2d 74 72 61 6e 73 6c 61 74 65 20 70 61 ing-translate pa
10930 74 74 20 22 25 22 20 22 2a 22 29 29 29 29 29 0a tt "%" "*"))))).
10940 3b 3b 20 20 20 20 20 28 73 65 74 21 20 74 65 73 ;; (set! tes
10950 74 73 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 ts (filter (lamb
10960 64 61 20 28 74 65 73 74 29 28 63 6f 6d 6d 6f 6e da (test)(common
10970 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 28 63 :file-exists? (c
10980 6f 6e 63 20 74 65 73 74 20 22 2f 74 65 73 74 63 onc test "/testc
10990 6f 6e 66 69 67 22 29 29 29 20 74 65 73 74 73 29 onfig"))) tests)
109a0 29 0a 3b 3b 20 20 20 20 20 28 64 65 6c 65 74 65 ).;; (delete
109b0 2d 64 75 70 6c 69 63 61 74 65 73 0a 3b 3b 20 20 -duplicates.;;
109c0 20 20 20 20 28 66 69 6c 74 65 72 20 28 6c 61 6d (filter (lam
109d0 62 64 61 20 28 74 65 73 74 6e 61 6d 65 29 0a 3b bda (testname).;
109e0 3b 20 09 20 20 20 20 20 20 20 28 74 65 73 74 73 ; . (tests
109f0 3a 6d 61 74 63 68 20 74 65 73 74 2d 70 61 74 74 :match test-patt
10a00 73 20 74 65 73 74 6e 61 6d 65 20 23 66 29 29 0a s testname #f)).
10a10 3b 3b 20 09 20 20 20 20 20 28 6d 61 70 20 28 6c ;; . (map (l
10a20 61 6d 62 64 61 20 28 74 65 73 74 70 29 0a 3b 3b ambda (testp).;;
10a30 20 09 09 20 20 20 20 28 6c 61 73 74 20 28 73 74 .. (last (st
10a40 72 69 6e 67 2d 73 70 6c 69 74 20 74 65 73 74 70 ring-split testp
10a50 20 22 2f 22 29 29 29 0a 3b 3b 20 09 09 20 20 74 "/"))).;; .. t
10a60 65 73 74 73 29 29 29 29 29 0a 0a 28 64 65 66 69 ests)))))..(defi
10a70 6e 65 20 28 74 65 73 74 73 3a 67 65 74 2d 74 65 ne (tests:get-te
10a80 73 74 2d 70 61 74 68 2d 66 72 6f 6d 2d 65 6e 76 st-path-from-env
10a90 69 72 6f 6e 6d 65 6e 74 29 0a 20 20 28 69 66 20 ironment). (if
10aa0 28 61 6e 64 20 28 67 65 74 65 6e 76 20 22 4d 54 (and (getenv "MT
10ab0 5f 4c 49 4e 4b 54 52 45 45 22 29 0a 09 20 20 20 _LINKTREE")..
10ac0 28 67 65 74 65 6e 76 20 22 4d 54 5f 54 41 52 47 (getenv "MT_TARG
10ad0 45 54 22 29 0a 09 20 20 20 28 67 65 74 65 6e 76 ET").. (getenv
10ae0 20 22 4d 54 5f 52 55 4e 4e 41 4d 45 22 29 0a 09 "MT_RUNNAME")..
10af0 20 20 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 54 (getenv "MT_T
10b00 45 53 54 5f 4e 41 4d 45 22 29 0a 09 20 20 20 28 EST_NAME").. (
10b10 67 65 74 65 6e 76 20 22 4d 54 5f 49 54 45 4d 50 getenv "MT_ITEMP
10b20 41 54 48 22 29 29 0a 20 20 20 20 20 20 28 63 6f ATH")). (co
10b30 6e 63 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 4c nc (getenv "MT_L
10b40 49 4e 4b 54 52 45 45 22 29 20 20 22 2f 22 0a 09 INKTREE") "/"..
10b50 20 20 20 20 28 67 65 74 65 6e 76 20 22 4d 54 5f (getenv "MT_
10b60 54 41 52 47 45 54 22 29 20 20 20 20 22 2f 22 0a TARGET") "/".
10b70 09 20 20 20 20 28 67 65 74 65 6e 76 20 22 4d 54 . (getenv "MT
10b80 5f 52 55 4e 4e 41 4d 45 22 29 20 20 20 22 2f 22 _RUNNAME") "/"
10b90 0a 09 20 20 20 20 28 67 65 74 65 6e 76 20 22 4d .. (getenv "M
10ba0 54 5f 54 45 53 54 5f 4e 41 4d 45 22 29 0a 09 20 T_TEST_NAME")..
10bb0 20 20 20 28 69 66 20 28 61 6e 64 20 28 67 65 74 (if (and (get
10bc0 65 6e 76 20 22 4d 54 5f 49 54 45 4d 50 41 54 48 env "MT_ITEMPATH
10bd0 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ").
10be0 20 20 20 20 20 20 20 20 28 6e 6f 74 20 28 73 74 (not (st
10bf0 72 69 6e 67 3d 3f 20 22 22 20 28 67 65 74 65 6e ring=? "" (geten
10c00 76 20 22 4d 54 5f 49 54 45 4d 50 41 54 48 22 29 v "MT_ITEMPATH")
10c10 29 29 29 0a 09 09 28 63 6f 6e 63 20 22 2f 22 20 )))...(conc "/"
10c20 28 67 65 74 65 6e 76 20 22 4d 54 5f 49 54 45 4d (getenv "MT_ITEM
10c30 50 41 54 48 22 29 29 0a 20 20 20 20 20 20 20 20 PATH")).
10c40 20 20 20 20 20 20 20 20 22 22 29 29 0a 20 20 20 "")).
10c50 20 20 20 23 66 29 29 0a 0a 3b 3b 20 69 66 20 2e #f))..;; if .
10c60 74 65 73 74 63 6f 6e 66 69 67 20 65 78 69 73 74 testconfig exist
10c70 73 20 69 6e 20 74 65 73 74 20 64 69 72 65 63 74 s in test direct
10c80 6f 72 79 20 72 65 61 64 20 61 6e 64 20 72 65 74 ory read and ret
10c90 75 72 6e 20 69 74 0a 3b 3b 20 65 6c 73 65 20 69 urn it.;; else i
10ca0 66 20 68 61 76 65 20 63 61 63 68 65 64 20 63 6f f have cached co
10cb0 70 79 20 69 6e 20 2a 74 65 73 74 63 6f 6e 66 69 py in *testconfi
10cc0 67 73 2a 20 72 65 74 75 72 6e 20 69 74 20 49 46 gs* return it IF
10cd0 46 20 74 68 65 72 65 20 69 73 20 61 20 73 65 63 F there is a sec
10ce0 74 69 6f 6e 20 22 68 61 76 65 20 66 75 6c 6c 64 tion "have fulld
10cf0 61 74 61 22 0a 3b 3b 20 65 6c 73 65 20 72 65 61 ata".;; else rea
10d00 64 20 74 68 65 20 74 65 73 74 63 6f 6e 66 69 67 d the testconfig
10d10 20 66 69 6c 65 0a 3b 3b 20 20 20 69 66 20 68 61 file.;; if ha
10d20 76 65 20 70 61 74 68 20 74 6f 20 74 65 73 74 20 ve path to test
10d30 64 69 72 65 63 74 6f 72 79 20 73 61 76 65 20 74 directory save t
10d40 68 65 20 63 6f 6e 66 69 67 20 61 73 20 2e 74 65 he config as .te
10d50 73 74 63 6f 6e 66 69 67 20 61 6e 64 20 72 65 74 stconfig and ret
10d60 75 72 6e 20 69 74 0a 3b 3b 0a 28 64 65 66 69 6e urn it.;;.(defin
10d70 65 20 28 74 65 73 74 73 3a 67 65 74 2d 74 65 73 e (tests:get-tes
10d80 74 63 6f 6e 66 69 67 20 74 65 73 74 2d 6e 61 6d tconfig test-nam
10d90 65 20 69 74 65 6d 2d 70 61 74 68 20 74 65 73 74 e item-path test
10da0 2d 72 65 67 69 73 74 72 79 20 73 79 73 74 65 6d -registry system
10db0 2d 61 6c 6c 6f 77 65 64 20 23 21 6b 65 79 20 28 -allowed #!key (
10dc0 66 6f 72 63 65 2d 63 72 65 61 74 65 20 23 66 29 force-create #f)
10dd0 28 61 6c 6c 6f 77 2d 77 72 69 74 65 2d 63 61 63 (allow-write-cac
10de0 68 65 20 23 74 29 28 77 61 69 74 2d 61 2d 6d 69 he #t)(wait-a-mi
10df0 6e 75 74 65 20 23 66 29 29 0a 20 20 28 6c 65 74 nute #f)). (let
10e00 2a 20 28 28 75 73 65 2d 63 61 63 68 65 20 20 20 * ((use-cache
10e10 20 28 63 6f 6d 6d 6f 6e 3a 75 73 65 2d 63 61 63 (common:use-cac
10e20 68 65 3f 29 29 0a 09 20 28 63 61 63 68 65 2d 70 he?)).. (cache-p
10e30 61 74 68 20 20 20 28 74 65 73 74 73 3a 67 65 74 ath (tests:get
10e40 2d 74 65 73 74 2d 70 61 74 68 2d 66 72 6f 6d 2d -test-path-from-
10e50 65 6e 76 69 72 6f 6e 6d 65 6e 74 29 29 0a 09 20 environment))..
10e60 28 63 61 63 68 65 2d 66 69 6c 65 20 20 20 28 61 (cache-file (a
10e70 6e 64 20 63 61 63 68 65 2d 70 61 74 68 20 28 63 nd cache-path (c
10e80 6f 6e 63 20 63 61 63 68 65 2d 70 61 74 68 20 22 onc cache-path "
10e90 2f 2e 74 65 73 74 63 6f 6e 66 69 67 22 29 29 29 /.testconfig")))
10ea0 0a 09 20 28 63 61 63 68 65 2d 65 78 69 73 74 73 .. (cache-exists
10eb0 20 28 61 6e 64 20 63 61 63 68 65 2d 66 69 6c 65 (and cache-file
10ec0 0a 09 09 09 20 20 20 20 28 6e 6f 74 20 66 6f 72 .... (not for
10ed0 63 65 2d 63 72 65 61 74 65 29 20 20 3b 3b 20 69 ce-create) ;; i
10ee0 66 20 66 6f 72 63 65 2d 63 72 65 61 74 65 20 74 f force-create t
10ef0 68 65 6e 20 70 72 65 74 65 6e 64 20 74 68 65 72 hen pretend ther
10f00 65 20 69 73 20 6e 6f 20 63 61 63 68 65 20 74 6f e is no cache to
10f10 20 72 65 61 64 0a 09 09 09 20 20 20 20 28 63 6f read.... (co
10f20 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 mmon:file-exists
10f30 3f 20 63 61 63 68 65 2d 66 69 6c 65 29 29 29 0a ? cache-file))).
10f40 09 20 28 63 61 63 68 65 64 2d 64 61 74 20 20 20 . (cached-dat
10f50 28 69 66 20 28 61 6e 64 20 28 6e 6f 74 20 66 6f (if (and (not fo
10f60 72 63 65 2d 63 72 65 61 74 65 29 0a 09 09 09 09 rce-create).....
10f70 63 61 63 68 65 2d 65 78 69 73 74 73 0a 09 09 09 cache-exists....
10f80 09 75 73 65 2d 63 61 63 68 65 29 0a 09 09 09 20 .use-cache)....
10f90 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 (handle-except
10fa0 69 6f 6e 73 0a 09 09 09 20 20 20 20 20 20 20 65 ions.... e
10fb0 78 6e 0a 09 09 09 20 20 20 20 20 28 62 65 67 69 xn.... (begi
10fc0 6e 0a 09 09 09 20 20 20 20 20 20 20 28 64 65 62 n.... (deb
10fd0 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
10fe0 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 66 ult-log-port* "f
10ff0 61 69 6c 65 64 20 74 6f 20 72 65 61 64 20 22 20 ailed to read "
11000 63 61 63 68 65 2d 66 69 6c 65 20 22 2c 20 65 78 cache-file ", ex
11010 6e 3d 22 20 65 78 6e 29 0a 09 09 09 20 20 20 20 n=" exn)....
11020 20 20 20 23 66 29 20 3b 3b 20 61 6e 79 20 69 73 #f) ;; any is
11030 73 75 65 73 2c 20 6a 75 73 74 20 67 69 76 65 20 sues, just give
11040 75 70 20 77 69 74 68 20 74 68 65 20 63 61 63 68 up with the cach
11050 65 64 20 76 65 72 73 69 6f 6e 20 61 6e 64 20 72 ed version and r
11060 65 2d 72 65 61 64 0a 09 09 09 20 20 20 20 20 28 e-read.... (
11070 63 6f 6e 66 69 67 66 3a 72 65 61 64 2d 61 6c 69 configf:read-ali
11080 73 74 20 63 61 63 68 65 2d 66 69 6c 65 29 29 0a st cache-file)).
11090 09 09 09 20 20 20 23 66 29 29 0a 20 20 20 20 20 ... #f)).
110a0 20 20 20 20 28 74 65 73 74 2d 66 75 6c 6c 2d 6e (test-full-n
110b0 61 6d 65 20 28 69 66 20 28 61 6e 64 20 69 74 65 ame (if (and ite
110c0 6d 2d 70 61 74 68 20 28 6e 6f 74 20 28 73 74 72 m-path (not (str
110d0 69 6e 67 2d 6e 75 6c 6c 3f 20 69 74 65 6d 2d 70 ing-null? item-p
110e0 61 74 68 29 29 29 0a 20 20 20 20 20 20 20 20 20 ath))).
110f0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11100 20 20 20 20 28 63 6f 6e 63 20 74 65 73 74 2d 6e (conc test-n
11110 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 ame "/" item-pat
11120 68 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 h).
11130 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11140 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a 20 20 20 test-name))).
11150 20 28 69 66 20 63 61 63 68 65 64 2d 64 61 74 0a (if cached-dat.
11160 09 63 61 63 68 65 64 2d 64 61 74 0a 09 28 6c 65 .cached-dat..(le
11170 74 20 28 28 64 61 74 20 28 68 61 73 68 2d 74 61 t ((dat (hash-ta
11180 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
11190 2a 74 65 73 74 63 6f 6e 66 69 67 73 2a 20 74 65 *testconfigs* te
111a0 73 74 2d 66 75 6c 6c 2d 6e 61 6d 65 20 23 66 29 st-full-name #f)
111b0 29 29 0a 09 20 20 28 69 66 20 28 61 6e 64 20 20 )).. (if (and
111c0 64 61 74 20 3b 3b 20 68 61 76 65 20 61 20 6c 6f dat ;; have a lo
111d0 63 61 6c 6c 79 20 63 61 63 68 65 64 20 76 65 72 cally cached ver
111e0 73 69 6f 6e 0a 09 09 20 20 20 20 28 68 61 73 68 sion... (hash
111f0 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
11200 6c 74 20 64 61 74 20 22 68 61 76 65 20 66 75 6c lt dat "have ful
11210 6c 64 61 74 61 22 20 23 66 29 29 20 3b 3b 20 6d ldata" #f)) ;; m
11220 61 72 6b 65 64 20 61 73 20 67 6f 6f 64 20 64 61 arked as good da
11230 74 61 3f 0a 09 20 20 20 20 20 20 64 61 74 0a 09 ta?.. dat..
11240 20 20 20 20 20 20 3b 3b 20 6e 6f 20 63 61 63 68 ;; no cach
11250 65 64 20 64 61 74 61 20 61 76 61 69 6c 61 62 6c ed data availabl
11260 65 0a 09 20 20 20 20 20 20 28 6c 65 74 2a 20 28 e.. (let* (
11270 28 74 72 65 67 20 20 20 20 20 20 20 20 20 28 6f (treg (o
11280 72 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 0a r test-registry.
11290 09 09 09 09 20 20 20 20 20 20 20 28 74 65 73 74 .... (test
112a0 73 3a 67 65 74 2d 61 6c 6c 29 29 29 0a 09 09 20 s:get-all)))...
112b0 20 20 20 20 28 74 65 73 74 2d 70 61 74 68 20 20 (test-path
112c0 20 20 28 6f 72 20 28 68 61 73 68 2d 74 61 62 6c (or (hash-tabl
112d0 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 72 e-ref/default tr
112e0 65 67 20 74 65 73 74 2d 6e 61 6d 65 20 23 66 29 eg test-name #f)
112f0 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
11300 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11310 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 (let* ((
11320 6c 6f 63 61 6c 2d 74 63 64 69 72 20 28 63 6f 6e local-tcdir (con
11330 63 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 4c 49 c (getenv "MT_LI
11340 4e 4b 54 52 45 45 22 29 20 22 2f 22 0a 20 20 20 NKTREE") "/".
11350 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11360 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11370 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11380 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 67 (g
11390 65 74 65 6e 76 20 22 4d 54 5f 54 41 52 47 45 54 etenv "MT_TARGET
113a0 22 29 20 22 2f 22 0a 20 20 20 20 20 20 20 20 20 ") "/".
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 20 20 20 20 20 20 20 20
113d0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
113e0 20 20 20 20 20 20 20 20 28 67 65 74 65 6e 76 20 (getenv
113f0 22 4d 54 5f 52 55 4e 4e 41 4d 45 22 29 20 22 2f "MT_RUNNAME") "/
11400 22 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ".
11410 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11420 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11430 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11440 20 20 20 74 65 73 74 2d 6e 61 6d 65 20 22 2f 22 test-name "/"
11450 20 69 74 65 6d 2d 70 61 74 68 29 29 0a 20 20 20 item-path)).
11460 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11470 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11480 20 20 20 20 20 20 20 20 20 20 20 28 6c 6f 63 61 (loca
11490 6c 2d 74 63 66 67 20 28 63 6f 6e 63 20 6c 6f 63 l-tcfg (conc loc
114a0 61 6c 2d 74 63 64 69 72 20 22 2f 74 65 73 74 63 al-tcdir "/testc
114b0 6f 6e 66 69 67 22 29 29 29 0a 20 20 20 20 20 20 onfig"))).
114c0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
114d0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
114e0 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 66 (if (common:f
114f0 69 6c 65 2d 65 78 69 73 74 73 3f 20 6c 6f 63 61 ile-exists? loca
11500 6c 2d 74 63 66 67 29 0a 20 20 20 20 20 20 20 20 l-tcfg).
11510 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11520 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11530 20 20 20 20 20 6c 6f 63 61 6c 2d 74 63 64 69 72 local-tcdir
11540 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
11550 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11560 20 20 20 20 20 20 20 20 20 20 20 20 20 20 23 66 #f
11570 29 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 63 ))..... (c
11580 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f onc *toppath* "/
11590 74 65 73 74 73 2f 22 20 74 65 73 74 2d 6e 61 6d tests/" test-nam
115a0 65 29 29 29 0a 09 09 20 20 20 20 20 28 74 65 73 e)))... (tes
115b0 74 2d 63 6f 6e 66 69 67 66 20 28 63 6f 6e 63 20 t-configf (conc
115c0 74 65 73 74 2d 70 61 74 68 20 22 2f 74 65 73 74 test-path "/test
115d0 63 6f 6e 66 69 67 22 29 29 0a 09 09 20 20 20 20 config"))...
115e0 20 28 74 65 73 74 65 78 69 73 74 73 20 20 20 28 (testexists (
115f0 6c 65 74 20 6c 6f 6f 70 61 20 28 28 74 72 69 65 let loopa ((trie
11600 73 2d 6c 65 66 74 20 33 30 29 29 0a 20 20 20 20 s-left 30)).
11610 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11620 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11630 20 28 63 6f 6e 64 0a 20 20 20 20 20 20 20 20 20 (cond.
11640 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11650 20 20 20 20 20 20 20 20 20 20 20 20 20 28 0a 20 (.
11660 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11670 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11680 20 20 20 20 20 20 28 61 6e 64 20 28 63 6f 6d 6d (and (comm
11690 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 on:file-exists?
116a0 74 65 73 74 2d 63 6f 6e 66 69 67 66 29 28 66 69 test-configf)(fi
116b0 6c 65 2d 72 65 61 64 2d 61 63 63 65 73 73 3f 20 le-read-access?
116c0 74 65 73 74 2d 63 6f 6e 66 69 67 66 29 29 0a 20 test-configf)).
116d0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
116e0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
116f0 20 20 20 20 20 20 23 74 29 0a 20 20 20 20 20 20 #t).
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 20 20
11720 28 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 (.
11730 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11740 20 20 20 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e (common
11750 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 74 65 :file-exists? te
11760 73 74 2d 63 6f 6e 66 69 67 66 29 0a 20 20 20 20 st-configf).
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 20 20 20 20
11790 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
117a0 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
117b0 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 43 ort* "WARNING: C
117c0 61 6e 6e 6f 74 20 72 65 61 64 20 74 65 73 74 63 annot read testc
117d0 6f 6e 66 69 67 20 66 69 6c 65 3a 20 22 74 65 73 onfig file: "tes
117e0 74 2d 63 6f 6e 66 69 67 66 29 0a 20 20 20 20 20 t-configf).
117f0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11800 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11810 20 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 #f).
11820 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11830 20 20 20 20 20 20 20 20 20 20 20 20 28 0a 20 20 (.
11840 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11850 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11860 20 20 20 20 20 28 61 6e 64 20 77 61 69 74 2d 61 (and wait-a
11870 2d 6d 69 6e 75 74 65 20 28 3e 20 74 72 69 65 73 -minute (> tries
11880 2d 6c 65 66 74 20 30 29 29 0a 20 20 20 20 20 20 -left 0)).
11890 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
118a0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
118b0 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
118c0 31 30 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 10).
118d0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
118e0 20 20 20 20 20 20 20 20 20 20 20 28 64 65 62 75 (debu
118f0 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
11900 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 lt-log-port* "WA
11910 52 4e 49 4e 47 3a 20 74 65 73 74 63 6f 6e 66 69 RNING: testconfi
11920 67 20 66 69 6c 65 20 64 6f 65 73 20 6e 6f 74 20 g file does not
11930 65 78 69 73 74 3a 20 22 74 65 73 74 2d 63 6f 6e exist: "test-con
11940 66 69 67 66 22 20 77 69 6c 6c 20 72 65 74 72 79 figf" will retry
11950 20 69 6e 20 31 30 20 73 65 63 6f 6e 64 73 2e 20 in 10 seconds.
11960 20 54 72 69 65 73 20 6c 65 66 74 3a 20 22 74 72 Tries left: "tr
11970 69 65 73 2d 6c 65 66 74 29 20 3b 3b 20 42 42 3a ies-left) ;; BB:
11980 20 74 68 69 73 20 66 69 72 65 73 0a 20 20 20 20 this fires.
11990 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
119a0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
119b0 20 20 20 28 6c 6f 6f 70 61 20 28 73 75 62 31 20 (loopa (sub1
119c0 74 72 69 65 73 2d 6c 65 66 74 29 29 29 0a 20 20 tries-left))).
119d0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
119e0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
119f0 20 20 20 20 28 65 6c 73 65 0a 20 20 20 20 20 20 (else.
11a00 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11a10 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11a20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 (debug:print 2
11a30 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
11a40 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 74 65 73 t* "WARNING: tes
11a50 74 63 6f 6e 66 69 67 20 66 69 6c 65 20 64 6f 65 tconfig file doe
11a60 73 20 6e 6f 74 20 65 78 69 73 74 3a 20 22 74 65 s not exist: "te
11a70 73 74 2d 63 6f 6e 66 69 67 66 29 20 3b 3b 20 42 st-configf) ;; B
11a80 42 3a 20 74 68 69 73 20 66 69 72 65 73 0a 20 20 B: this fires.
11a90 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11aa0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11ab0 20 20 20 20 20 23 66 29 29 29 29 0a 09 09 20 20 #f))))...
11ac0 20 20 20 28 74 63 66 67 20 20 20 20 20 20 20 20 (tcfg
11ad0 20 28 69 66 20 74 65 73 74 65 78 69 73 74 73 0a (if testexists.
11ae0 09 09 09 09 20 20 20 20 20 20 20 28 72 65 61 64 .... (read
11af0 2d 63 6f 6e 66 69 67 20 74 65 73 74 2d 63 6f 6e -config test-con
11b00 66 69 67 66 20 23 66 20 73 79 73 74 65 6d 2d 61 figf #f system-a
11b10 6c 6c 6f 77 65 64 0a 09 09 09 09 09 09 20 20 20 llowed.......
11b20 20 65 6e 76 69 72 6f 6e 2d 70 61 74 74 3a 20 28 environ-patt: (
11b30 69 66 20 73 79 73 74 65 6d 2d 61 6c 6c 6f 77 65 if system-allowe
11b40 64 0a 09 09 09 09 09 09 09 09 20 20 20 20 20 20 d.........
11b50 22 70 72 65 2d 6c 61 75 6e 63 68 2d 65 6e 76 2d "pre-launch-env-
11b60 76 61 72 73 22 0a 09 09 09 09 09 09 09 09 20 20 vars".........
11b70 20 20 20 20 23 66 29 29 0a 09 09 09 09 20 20 20 #f)).....
11b80 20 20 20 20 23 66 29 29 29 0a 09 09 28 69 66 20 #f)))...(if
11b90 28 61 6e 64 20 74 63 66 67 20 63 61 63 68 65 2d (and tcfg cache-
11ba0 66 69 6c 65 29 20 28 68 61 73 68 2d 74 61 62 6c file) (hash-tabl
11bb0 65 2d 73 65 74 21 20 74 63 66 67 20 22 68 61 76 e-set! tcfg "hav
11bc0 65 20 66 75 6c 6c 64 61 74 61 22 20 23 74 29 29 e fulldata" #t))
11bd0 20 3b 3b 20 6d 61 72 6b 20 74 68 69 73 20 61 73 ;; mark this as
11be0 20 66 75 6c 6c 79 20 72 65 61 64 20 64 61 74 61 fully read data
11bf0 0a 09 09 28 69 66 20 74 63 66 67 20 28 68 61 73 ...(if tcfg (has
11c00 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a 74 65 h-table-set! *te
11c10 73 74 63 6f 6e 66 69 67 73 2a 20 74 65 73 74 2d stconfigs* test-
11c20 66 75 6c 6c 2d 6e 61 6d 65 20 74 63 66 67 29 29 full-name tcfg))
11c30 0a 09 09 28 69 66 20 28 61 6e 64 20 74 65 73 74 ...(if (and test
11c40 65 78 69 73 74 73 0a 09 09 09 20 63 61 63 68 65 exists.... cache
11c50 2d 66 69 6c 65 0a 09 09 09 20 28 66 69 6c 65 2d -file.... (file-
11c60 77 72 69 74 65 2d 61 63 63 65 73 73 3f 20 63 61 write-access? ca
11c70 63 68 65 2d 70 61 74 68 29 0a 09 09 09 20 61 6c che-path).... al
11c80 6c 6f 77 2d 77 72 69 74 65 2d 63 61 63 68 65 29 low-write-cache)
11c90 0a 09 09 20 20 20 20 28 6c 65 74 20 28 28 74 70 ... (let ((tp
11ca0 61 74 68 20 28 63 6f 6e 63 20 63 61 63 68 65 2d ath (conc cache-
11cb0 70 61 74 68 20 22 2f 2e 74 65 73 74 63 6f 6e 66 path "/.testconf
11cc0 69 67 22 29 29 29 0a 09 09 20 20 20 20 20 20 28 ig")))... (
11cd0 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
11ce0 20 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 1 *default-log-
11cf0 70 6f 72 74 2a 20 22 43 61 63 68 69 6e 67 20 74 port* "Caching t
11d00 65 73 74 63 6f 6e 66 69 67 20 66 6f 72 20 22 20 estconfig for "
11d10 74 65 73 74 2d 6e 61 6d 65 20 22 20 69 6e 20 22 test-name " in "
11d20 20 74 70 61 74 68 29 0a 20 20 20 20 20 20 20 20 tpath).
11d30 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i
11d40 66 20 28 61 6e 64 20 74 63 66 67 20 28 6e 6f 74 f (and tcfg (not
11d50 20 28 63 6f 6d 6d 6f 6e 3a 69 6e 2d 72 75 6e 6e (common:in-runn
11d60 69 6e 67 2d 74 65 73 74 3f 29 29 29 0a 20 20 20 ing-test?))).
11d70 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11d80 20 20 20 20 20 20 20 28 63 6f 6e 66 69 67 66 3a (configf:
11d90 77 72 69 74 65 2d 61 6c 69 73 74 20 74 63 66 67 write-alist tcfg
11da0 20 74 70 61 74 68 29 29 29 29 0a 09 09 74 63 66 tpath))))...tcf
11db0 67 29 29 29 29 29 29 0a 20 20 0a 3b 3b 20 73 6f g)))))). .;; so
11dc0 72 74 20 74 65 73 74 73 20 62 79 20 70 72 69 6f rt tests by prio
11dd0 72 69 74 79 20 61 6e 64 20 77 61 69 74 6f 6e 0a rity and waiton.
11de0 3b 3b 20 4d 6f 76 65 20 74 65 73 74 20 73 70 65 ;; Move test spe
11df0 63 69 66 69 63 20 73 74 75 66 66 20 74 6f 20 61 cific stuff to a
11e00 20 74 65 73 74 20 75 6e 69 74 20 46 49 58 4d 45 test unit FIXME
11e10 20 6f 6e 65 20 6f 66 20 74 68 65 73 65 20 64 61 one of these da
11e20 79 73 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 ys.(define (test
11e30 73 3a 73 6f 72 74 2d 62 79 2d 70 72 69 6f 72 69 s:sort-by-priori
11e40 74 79 2d 61 6e 64 2d 77 61 69 74 6f 6e 20 74 65 ty-and-waiton te
11e50 73 74 2d 72 65 63 6f 72 64 73 29 0a 20 20 28 69 st-records). (i
11e60 66 20 28 65 71 3f 20 28 68 61 73 68 2d 74 61 62 f (eq? (hash-tab
11e70 6c 65 2d 73 69 7a 65 20 74 65 73 74 2d 72 65 63 le-size test-rec
11e80 6f 72 64 73 29 20 30 29 0a 20 20 20 20 20 20 27 ords) 0). '
11e90 28 29 0a 20 20 20 20 20 20 28 6c 65 74 2a 20 28 (). (let* (
11ea0 28 6d 75 6e 67 65 70 72 69 6f 72 69 74 79 20 28 (mungepriority (
11eb0 6c 61 6d 62 64 61 20 28 70 72 69 6f 72 69 74 79 lambda (priority
11ec0 29 0a 09 09 09 20 20 20 20 20 20 28 69 66 20 70 ).... (if p
11ed0 72 69 6f 72 69 74 79 0a 09 09 09 09 20 20 28 6c riority..... (l
11ee0 65 74 20 28 28 74 6d 70 20 28 61 6e 79 2d 3e 6e et ((tmp (any->n
11ef0 75 6d 62 65 72 20 70 72 69 6f 72 69 74 79 29 29 umber priority))
11f00 29 0a 09 09 09 09 20 20 20 20 28 69 66 20 74 6d )..... (if tm
11f10 70 20 74 6d 70 20 28 62 65 67 69 6e 20 28 64 65 p tmp (begin (de
11f20 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 bug:print-error
11f30 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
11f40 6f 72 74 2a 20 22 62 61 64 20 70 72 69 6f 72 69 ort* "bad priori
11f50 74 79 20 76 61 6c 75 65 20 22 20 70 72 69 6f 72 ty value " prior
11f60 69 74 79 20 22 2c 20 75 73 69 6e 67 20 30 22 29 ity ", using 0")
11f70 20 30 29 29 29 0a 09 09 09 09 20 20 30 29 29 29 0)))..... 0)))
11f80 0a 09 20 20 20 20 20 28 61 6c 6c 2d 74 65 73 74 .. (all-test
11f90 73 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 s (hash-tab
11fa0 6c 65 2d 6b 65 79 73 20 74 65 73 74 2d 72 65 63 le-keys test-rec
11fb0 6f 72 64 73 29 29 0a 09 20 20 20 20 20 28 61 6c ords)).. (al
11fc0 6c 2d 77 61 69 74 65 64 2d 6f 6e 20 20 28 6c 65 l-waited-on (le
11fd0 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 61 t loop ((hed (ca
11fe0 72 20 61 6c 6c 2d 74 65 73 74 73 29 29 0a 09 09 r all-tests))...
11ff0 09 09 09 28 74 61 6c 20 28 63 64 72 20 61 6c 6c ...(tal (cdr all
12000 2d 74 65 73 74 73 29 29 0a 09 09 09 09 09 28 72 -tests))......(r
12010 65 73 20 27 28 29 29 29 0a 09 09 09 20 20 20 20 es '()))....
12020 20 20 20 28 6c 65 74 2a 20 28 28 74 72 65 63 20 (let* ((trec
12030 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 (hash-table-r
12040 65 66 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 ef test-records
12050 68 65 64 29 29 0a 09 09 09 09 20 20 20 20 20 20 hed)).....
12060 28 77 61 69 74 6f 6e 73 20 28 6f 72 20 28 74 65 (waitons (or (te
12070 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 sts:testqueue-ge
12080 74 2d 77 61 69 74 6f 6e 73 20 74 72 65 63 29 20 t-waitons trec)
12090 27 28 29 29 29 29 0a 09 09 09 09 20 28 69 66 20 '())))..... (if
120a0 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 09 09 (null? tal).....
120b0 20 20 20 20 20 28 61 70 70 65 6e 64 20 72 65 73 (append res
120c0 20 77 61 69 74 6f 6e 73 29 0a 09 09 09 09 20 20 waitons).....
120d0 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 (loop (car ta
120e0 6c 29 28 63 64 72 20 74 61 6c 29 28 61 70 70 65 l)(cdr tal)(appe
120f0 6e 64 20 72 65 73 20 77 61 69 74 6f 6e 73 29 29 nd res waitons))
12100 29 29 29 29 0a 09 20 20 20 20 20 28 73 6f 72 74 )))).. (sort
12110 2d 66 6e 31 20 0a 09 20 20 20 20 20 20 28 6c 61 -fn1 .. (la
12120 6d 62 64 61 20 28 61 20 62 29 0a 09 09 28 6c 65 mbda (a b)...(le
12130 74 2a 20 28 28 61 2d 72 65 63 6f 72 64 20 20 20 t* ((a-record
12140 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 (hash-table-ref
12150 74 65 73 74 2d 72 65 63 6f 72 64 73 20 61 29 29 test-records a))
12160 0a 09 09 20 20 20 20 20 20 20 28 62 2d 72 65 63 ... (b-rec
12170 6f 72 64 20 20 20 28 68 61 73 68 2d 74 61 62 6c ord (hash-tabl
12180 65 2d 72 65 66 20 74 65 73 74 2d 72 65 63 6f 72 e-ref test-recor
12190 64 73 20 62 29 29 0a 09 09 20 20 20 20 20 20 20 ds b))...
121a0 28 61 2d 77 61 69 74 6f 6e 73 20 20 28 6f 72 20 (a-waitons (or
121b0 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 (tests:testqueue
121c0 2d 67 65 74 2d 77 61 69 74 6f 6e 73 20 61 2d 72 -get-waitons a-r
121d0 65 63 6f 72 64 29 20 27 28 29 29 29 0a 09 09 20 ecord) '()))...
121e0 20 20 20 20 20 20 28 62 2d 77 61 69 74 6f 6e 73 (b-waitons
121f0 20 20 28 6f 72 20 28 74 65 73 74 73 3a 74 65 73 (or (tests:tes
12200 74 71 75 65 75 65 2d 67 65 74 2d 77 61 69 74 6f tqueue-get-waito
12210 6e 73 20 62 2d 72 65 63 6f 72 64 29 20 27 28 29 ns b-record) '()
12220 29 29 0a 09 09 20 20 20 20 20 20 20 28 61 2d 63 ))... (a-c
12230 6f 6e 66 69 67 20 20 20 28 74 65 73 74 73 3a 74 onfig (tests:t
12240 65 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 73 estqueue-get-tes
12250 74 63 6f 6e 66 69 67 20 20 61 2d 72 65 63 6f 72 tconfig a-recor
12260 64 29 29 0a 09 09 20 20 20 20 20 20 20 28 62 2d d))... (b-
12270 63 6f 6e 66 69 67 20 20 20 28 74 65 73 74 73 3a config (tests:
12280 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 testqueue-get-te
12290 73 74 63 6f 6e 66 69 67 20 20 62 2d 72 65 63 6f stconfig b-reco
122a0 72 64 29 29 0a 09 09 20 20 20 20 20 20 20 28 61 rd))... (a
122b0 2d 72 61 77 2d 70 72 69 20 20 28 63 6f 6e 66 69 -raw-pri (confi
122c0 67 66 3a 6c 6f 6f 6b 75 70 20 61 2d 63 6f 6e 66 gf:lookup a-conf
122d0 69 67 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 ig "requirements
122e0 22 20 22 70 72 69 6f 72 69 74 79 22 29 29 0a 09 " "priority"))..
122f0 09 20 20 20 20 20 20 20 28 62 2d 72 61 77 2d 70 . (b-raw-p
12300 72 69 20 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f ri (configf:loo
12310 6b 75 70 20 62 2d 63 6f 6e 66 69 67 20 22 72 65 kup b-config "re
12320 71 75 69 72 65 6d 65 6e 74 73 22 20 22 70 72 69 quirements" "pri
12330 6f 72 69 74 79 22 29 29 0a 09 09 20 20 20 20 20 ority"))...
12340 20 20 28 61 2d 70 72 69 6f 72 69 74 79 20 28 6d (a-priority (m
12350 75 6e 67 65 70 72 69 6f 72 69 74 79 20 61 2d 72 ungepriority a-r
12360 61 77 2d 70 72 69 29 29 0a 09 09 20 20 20 20 20 aw-pri))...
12370 20 20 28 62 2d 70 72 69 6f 72 69 74 79 20 28 6d (b-priority (m
12380 75 6e 67 65 70 72 69 6f 72 69 74 79 20 62 2d 72 ungepriority b-r
12390 61 77 2d 70 72 69 29 29 29 0a 09 09 20 20 28 74 aw-pri)))... (t
123a0 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 73 ests:testqueue-s
123b0 65 74 2d 70 72 69 6f 72 69 74 79 21 20 61 2d 72 et-priority! a-r
123c0 65 63 6f 72 64 20 61 2d 70 72 69 6f 72 69 74 79 ecord a-priority
123d0 29 0a 09 09 20 20 28 74 65 73 74 73 3a 74 65 73 )... (tests:tes
123e0 74 71 75 65 75 65 2d 73 65 74 2d 70 72 69 6f 72 tqueue-set-prior
123f0 69 74 79 21 20 62 2d 72 65 63 6f 72 64 20 62 2d ity! b-record b-
12400 70 72 69 6f 72 69 74 79 29 0a 09 09 20 20 3b 3b priority)... ;;
12410 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
12420 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
12430 74 2a 20 22 61 3d 22 20 61 20 22 2c 20 62 3d 22 t* "a=" a ", b="
12440 20 62 20 22 2c 20 61 2d 77 61 69 74 6f 6e 73 3d b ", a-waitons=
12450 22 20 61 2d 77 61 69 74 6f 6e 73 20 22 2c 20 62 " a-waitons ", b
12460 2d 77 61 69 74 6f 6e 73 3d 22 20 62 2d 77 61 69 -waitons=" b-wai
12470 74 6f 6e 73 29 0a 09 09 20 20 28 63 6f 6e 64 0a tons)... (cond.
12480 09 09 20 20 20 3b 3b 20 69 73 20 0a 09 09 20 20 .. ;; is ...
12490 20 28 28 6d 65 6d 62 65 72 20 61 20 62 2d 77 61 ((member a b-wa
124a0 69 74 6f 6e 73 29 20 20 20 20 20 20 20 20 20 20 itons)
124b0 3b 3b 20 69 73 20 62 20 77 61 69 74 69 6e 67 20 ;; is b waiting
124c0 6f 6e 20 61 3f 0a 09 09 20 20 20 20 3b 3b 20 28 on a?... ;; (
124d0 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
124e0 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
124f0 20 22 63 61 73 65 31 22 29 0a 09 09 20 20 20 20 "case1")...
12500 23 74 29 0a 09 09 20 20 20 28 28 6d 65 6d 62 65 #t)... ((membe
12510 72 20 62 20 61 2d 77 61 69 74 6f 6e 73 29 20 20 r b a-waitons)
12520 20 20 20 20 20 20 20 20 3b 3b 20 69 73 20 61 20 ;; is a
12530 77 61 69 74 69 6e 67 20 6f 6e 20 62 3f 0a 09 09 waiting on b?...
12540 20 20 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 ;; (debug:pr
12550 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
12560 6f 67 2d 70 6f 72 74 2a 20 22 63 61 73 65 32 22 og-port* "case2"
12570 29 0a 09 09 20 20 20 20 23 66 29 0a 09 09 20 20 )... #f)...
12580 20 28 28 61 6e 64 20 28 6e 6f 74 20 28 6e 75 6c ((and (not (nul
12590 6c 3f 20 61 2d 77 61 69 74 6f 6e 73 29 29 20 20 l? a-waitons))
125a0 3b 3b 20 62 6f 74 68 20 68 61 76 65 20 77 61 69 ;; both have wai
125b0 74 6f 6e 73 20 2d 20 64 6f 20 6e 6f 74 20 64 69 tons - do not di
125c0 73 74 75 72 62 0a 09 09 09 20 28 6e 6f 74 20 28 sturb.... (not (
125d0 6e 75 6c 6c 3f 20 62 2d 77 61 69 74 6f 6e 73 29 null? b-waitons)
125e0 29 29 0a 09 09 20 20 20 20 3b 3b 20 28 64 65 62 ))... ;; (deb
125f0 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
12600 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 63 ult-log-port* "c
12610 61 73 65 32 2e 31 22 29 0a 09 09 20 20 20 20 23 ase2.1")... #
12620 74 29 0a 09 09 20 20 20 28 28 61 6e 64 20 28 6e t)... ((and (n
12630 75 6c 6c 3f 20 61 2d 77 61 69 74 6f 6e 73 29 20 ull? a-waitons)
12640 20 20 20 20 20 20 20 3b 3b 20 6e 6f 20 77 61 69 ;; no wai
12650 74 6f 6e 73 20 66 6f 72 20 61 20 62 75 74 20 62 tons for a but b
12660 20 68 61 73 20 77 61 69 74 6f 6e 73 0a 09 09 09 has waitons....
12670 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 62 2d 77 (not (null? b-w
12680 61 69 74 6f 6e 73 29 29 29 0a 09 09 20 20 20 20 aitons)))...
12690 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 ;; (debug:print
126a0 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
126b0 6f 72 74 2a 20 22 63 61 73 65 33 22 29 0a 09 09 ort* "case3")...
126c0 20 20 20 20 23 66 29 0a 09 09 20 20 20 28 28 61 #f)... ((a
126d0 6e 64 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 61 nd (not (null? a
126e0 2d 77 61 69 74 6f 6e 73 29 29 20 20 3b 3b 20 61 -waitons)) ;; a
126f0 20 68 61 73 20 77 61 69 74 6f 6e 73 20 62 75 74 has waitons but
12700 20 62 20 64 6f 65 73 20 6e 6f 74 0a 09 09 09 20 b does not....
12710 28 6e 75 6c 6c 3f 20 62 2d 77 61 69 74 6f 6e 73 (null? b-waitons
12720 29 29 20 0a 09 09 20 20 20 20 3b 3b 20 28 64 65 )) ... ;; (de
12730 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
12740 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
12750 63 61 73 65 34 22 29 0a 09 09 20 20 20 20 23 74 case4")... #t
12760 29 0a 09 09 20 20 20 28 28 6e 6f 74 20 28 65 71 )... ((not (eq
12770 3f 20 61 2d 70 72 69 6f 72 69 74 79 20 62 2d 70 ? a-priority b-p
12780 72 69 6f 72 69 74 79 29 29 20 3b 3b 20 75 73 65 riority)) ;; use
12790 0a 09 09 20 20 20 20 28 3e 20 61 2d 70 72 69 6f ... (> a-prio
127a0 72 69 74 79 20 62 2d 70 72 69 6f 72 69 74 79 29 rity b-priority)
127b0 29 0a 09 09 20 20 20 28 65 6c 73 65 0a 09 09 20 )... (else...
127c0 20 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 ;; (debug:pri
127d0 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
127e0 67 2d 70 6f 72 74 2a 20 22 63 61 73 65 35 22 29 g-port* "case5")
127f0 0a 09 09 20 20 20 20 28 73 74 72 69 6e 67 3e 3f ... (string>?
12800 20 61 20 62 29 29 29 29 29 29 0a 09 20 20 20 20 a b))))))..
12810 20 0a 09 20 20 20 20 20 28 73 6f 72 74 2d 66 6e .. (sort-fn
12820 32 0a 09 20 20 20 20 20 20 28 6c 61 6d 62 64 61 2.. (lambda
12830 20 28 61 20 62 29 0a 09 09 28 3e 20 28 6d 75 6e (a b)...(> (mun
12840 67 65 70 72 69 6f 72 69 74 79 20 28 74 65 73 74 gepriority (test
12850 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d s:testqueue-get-
12860 70 72 69 6f 72 69 74 79 20 28 68 61 73 68 2d 74 priority (hash-t
12870 61 62 6c 65 2d 72 65 66 20 74 65 73 74 2d 72 65 able-ref test-re
12880 63 6f 72 64 73 20 61 29 29 29 0a 09 09 20 20 20 cords a)))...
12890 28 6d 75 6e 67 65 70 72 69 6f 72 69 74 79 20 28 (mungepriority (
128a0 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d tests:testqueue-
128b0 67 65 74 2d 70 72 69 6f 72 69 74 79 20 28 68 61 get-priority (ha
128c0 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 74 65 73 sh-table-ref tes
128d0 74 2d 72 65 63 6f 72 64 73 20 62 29 29 29 29 29 t-records b)))))
128e0 29 29 0a 09 3b 3b 20 28 6c 65 74 20 28 28 64 6f ))..;; (let ((do
128f0 74 2d 72 65 73 20 28 74 65 73 74 73 3a 72 75 6e t-res (tests:run
12900 2d 64 6f 74 20 28 74 65 73 74 73 3a 74 65 73 74 -dot (tests:test
12910 73 2d 3e 64 6f 74 20 74 65 73 74 2d 72 65 63 6f s->dot test-reco
12920 72 64 73 29 20 22 70 6c 61 69 6e 22 29 29 29 0a rds) "plain"))).
12930 09 3b 3b 20 20 20 28 64 65 62 75 67 3a 70 72 69 .;; (debug:pri
12940 6e 74 20 22 64 6f 74 2d 72 65 73 3d 22 20 64 6f nt "dot-res=" do
12950 74 2d 72 65 73 29 29 0a 09 3b 3b 20 28 6c 65 74 t-res))..;; (let
12960 20 28 28 64 61 74 61 20 28 6d 61 70 20 63 64 72 ((data (map cdr
12970 20 28 66 69 6c 74 65 72 0a 09 3b 3b 20 20 20 20 (filter..;;
12980 20 09 09 20 20 28 6c 61 6d 62 64 61 20 28 78 29 .. (lambda (x)
12990 28 65 71 75 61 6c 3f 20 22 6e 6f 64 65 22 20 28 (equal? "node" (
129a0 63 61 72 20 78 29 29 29 0a 09 3b 3b 20 20 20 20 car x)))..;;
129b0 20 09 09 20 20 28 6d 61 70 20 73 74 72 69 6e 67 .. (map string
129c0 2d 73 70 6c 69 74 20 28 74 65 73 74 73 3a 65 61 -split (tests:ea
129d0 73 79 2d 64 6f 74 20 74 65 73 74 2d 72 65 63 6f sy-dot test-reco
129e0 72 64 73 20 22 70 6c 61 69 6e 22 29 29 29 29 29 rds "plain")))))
129f0 29 0a 09 3b 3b 20 20 20 28 6d 61 70 20 63 61 72 )..;; (map car
12a00 20 28 73 6f 72 74 20 64 61 74 61 20 28 6c 61 6d (sort data (lam
12a10 62 64 61 20 28 61 20 62 29 0a 09 3b 3b 20 20 20 bda (a b)..;;
12a20 20 20 09 09 20 20 20 20 28 3e 20 28 73 74 72 69 .. (> (stri
12a30 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 63 61 64 64 ng->number (cadd
12a40 72 20 61 29 29 28 73 74 72 69 6e 67 2d 3e 6e 75 r a))(string->nu
12a50 6d 62 65 72 20 28 63 61 64 64 72 20 62 29 29 29 mber (caddr b)))
12a60 29 29 29 29 0a 09 3b 3b 20 29 29 0a 09 28 73 6f ))))..;; ))..(so
12a70 72 74 20 61 6c 6c 2d 74 65 73 74 73 20 73 6f 72 rt all-tests sor
12a80 74 2d 66 6e 31 29 29 29 29 20 3b 3b 20 61 76 6f t-fn1)))) ;; avo
12a90 69 64 20 64 65 61 6c 69 6e 67 20 77 69 74 68 20 id dealing with
12aa0 64 65 6c 65 74 65 64 20 74 65 73 74 73 2c 20 6c deleted tests, l
12ab0 6f 6f 6b 20 61 74 20 74 68 65 20 68 61 73 68 20 ook at the hash
12ac0 74 61 62 6c 65 0a 0a 28 64 65 66 69 6e 65 20 28 table..(define (
12ad0 74 65 73 74 73 3a 65 61 73 79 2d 64 6f 74 20 74 tests:easy-dot t
12ae0 65 73 74 2d 72 65 63 6f 72 64 73 20 6f 75 74 74 est-records outt
12af0 79 70 65 29 0a 20 20 28 6c 65 74 2d 76 61 6c 75 ype). (let-valu
12b00 65 73 20 28 28 28 66 64 20 74 65 6d 70 2d 70 61 es (((fd temp-pa
12b10 74 68 29 20 28 66 69 6c 65 2d 6d 6b 73 74 65 6d th) (file-mkstem
12b20 70 20 28 63 6f 6e 63 20 22 2f 74 6d 70 2f 22 20 p (conc "/tmp/"
12b30 28 63 75 72 72 65 6e 74 2d 75 73 65 72 2d 6e 61 (current-user-na
12b40 6d 65 29 20 22 2e 58 58 58 58 58 58 22 29 29 29 me) ".XXXXXX")))
12b50 29 0a 20 20 20 20 28 6c 65 74 20 28 28 61 6c 6c ). (let ((all
12b60 2d 74 65 73 74 6e 61 6d 65 73 20 28 68 61 73 68 -testnames (hash
12b70 2d 74 61 62 6c 65 2d 6b 65 79 73 20 74 65 73 74 -table-keys test
12b80 2d 72 65 63 6f 72 64 73 29 29 0a 09 20 20 28 74 -records)).. (t
12b90 65 6d 70 2d 70 6f 72 74 20 20 20 20 20 28 6f 70 emp-port (op
12ba0 65 6e 2d 6f 75 74 70 75 74 2d 66 69 6c 65 2a 20 en-output-file*
12bb0 66 64 29 29 29 0a 20 20 20 20 20 20 3b 3b 20 28 fd))). ;; (
12bc0 66 6f 72 6d 61 74 20 74 65 6d 70 2d 70 6f 72 74 format temp-port
12bd0 20 22 54 68 69 73 20 66 69 6c 65 20 69 73 20 7e "This file is ~
12be0 41 2e 7e 25 22 20 74 65 6d 70 2d 70 61 74 68 29 A.~%" temp-path)
12bf0 0a 20 20 20 20 20 20 28 66 6f 72 6d 61 74 20 74 . (format t
12c00 65 6d 70 2d 70 6f 72 74 20 22 64 69 67 72 61 70 emp-port "digrap
12c10 68 20 74 65 73 74 73 20 7b 5c 6e 22 29 0a 20 20 h tests {\n").
12c20 20 20 20 20 28 66 6f 72 6d 61 74 20 74 65 6d 70 (format temp
12c30 2d 70 6f 72 74 20 22 20 20 73 69 7a 65 3d 34 2c -port " size=4,
12c40 38 5c 6e 22 29 0a 20 20 20 20 20 20 3b 3b 20 28 8\n"). ;; (
12c50 66 6f 72 6d 61 74 20 74 65 6d 70 2d 70 6f 72 74 format temp-port
12c60 20 22 20 20 20 73 70 6c 69 6e 65 73 3d 6e 6f 6e " splines=non
12c70 65 5c 6e 22 29 0a 20 20 20 20 20 20 28 66 6f 72 e\n"). (for
12c80 2d 65 61 63 68 0a 20 20 20 20 20 20 20 28 6c 61 -each. (la
12c90 6d 62 64 61 20 28 74 65 73 74 6e 61 6d 65 29 0a mbda (testname).
12ca0 09 20 28 6c 65 74 2a 20 28 28 74 65 73 74 72 65 . (let* ((testre
12cb0 63 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 c (hash-table-re
12cc0 66 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 74 f test-records t
12cd0 65 73 74 6e 61 6d 65 29 29 0a 09 09 28 77 61 69 estname))...(wai
12ce0 74 6f 6e 73 20 28 6f 72 20 28 74 65 73 74 73 3a tons (or (tests:
12cf0 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 77 61 testqueue-get-wa
12d00 69 74 6f 6e 73 20 74 65 73 74 72 65 63 29 20 27 itons testrec) '
12d10 28 29 29 29 29 0a 09 20 20 20 28 66 6f 72 2d 65 ()))).. (for-e
12d20 61 63 68 0a 09 20 20 20 20 28 6c 61 6d 62 64 61 ach.. (lambda
12d30 20 28 77 61 69 74 6f 6e 29 0a 09 20 20 20 20 20 (waiton)..
12d40 20 28 66 6f 72 6d 61 74 20 74 65 6d 70 2d 70 6f (format temp-po
12d50 72 74 20 28 63 6f 6e 63 20 22 20 20 20 22 20 77 rt (conc " " w
12d60 61 69 74 6f 6e 20 22 20 2d 3e 20 22 20 74 65 73 aiton " -> " tes
12d70 74 6e 61 6d 65 20 22 20 5b 73 70 6c 69 6e 65 73 tname " [splines
12d80 3d 6f 72 74 68 6f 5d 5c 6e 22 29 29 29 0a 09 20 =ortho]\n")))..
12d90 20 20 20 77 61 69 74 6f 6e 73 29 29 29 0a 20 20 waitons))).
12da0 20 20 20 20 20 61 6c 6c 2d 74 65 73 74 6e 61 6d all-testnam
12db0 65 73 29 0a 20 20 20 20 20 20 28 66 6f 72 6d 61 es). (forma
12dc0 74 20 74 65 6d 70 2d 70 6f 72 74 20 22 7d 5c 6e t temp-port "}\n
12dd0 22 29 0a 20 20 20 20 20 20 28 63 6c 6f 73 65 2d "). (close-
12de0 6f 75 74 70 75 74 2d 70 6f 72 74 20 74 65 6d 70 output-port temp
12df0 2d 70 6f 72 74 29 0a 20 20 20 20 20 20 28 77 69 -port). (wi
12e00 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 th-input-from-pi
12e10 70 65 0a 20 20 20 20 20 20 20 28 63 6f 6e 63 20 pe. (conc
12e20 22 65 6e 76 20 2d 69 20 50 41 54 48 3d 24 50 41 "env -i PATH=$PA
12e30 54 48 20 64 6f 74 20 2d 54 22 20 6f 75 74 74 79 TH dot -T" outty
12e40 70 65 20 22 20 3c 20 22 20 74 65 6d 70 2d 70 61 pe " < " temp-pa
12e50 74 68 29 0a 20 20 20 20 20 20 20 28 6c 61 6d 62 th). (lamb
12e60 64 61 20 28 29 0a 09 20 28 6c 65 74 20 28 28 72 da ().. (let ((r
12e70 65 73 20 28 72 65 61 64 2d 6c 69 6e 65 73 29 29 es (read-lines))
12e80 29 0a 09 20 20 20 3b 3b 20 28 64 65 6c 65 74 65 ).. ;; (delete
12e90 2d 66 69 6c 65 20 74 65 6d 70 2d 70 61 74 68 29 -file temp-path)
12ea0 0a 09 20 20 20 72 65 73 29 29 29 29 29 29 0a 0a .. res))))))..
12eb0 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 77 (define (tests:w
12ec0 72 69 74 65 2d 64 6f 74 2d 66 69 6c 65 20 74 65 rite-dot-file te
12ed0 73 74 2d 72 65 63 6f 72 64 73 20 66 6e 61 6d 65 st-records fname
12ee0 20 73 69 7a 65 78 20 73 69 7a 65 79 29 0a 20 20 sizex sizey).
12ef0 28 69 66 20 28 66 69 6c 65 2d 77 72 69 74 65 2d (if (file-write-
12f00 61 63 63 65 73 73 3f 20 28 70 61 74 68 6e 61 6d access? (pathnam
12f10 65 2d 64 69 72 65 63 74 6f 72 79 20 66 6e 61 6d e-directory fnam
12f20 65 29 29 0a 20 20 20 20 20 20 28 77 69 74 68 2d e)). (with-
12f30 6f 75 74 70 75 74 2d 74 6f 2d 66 69 6c 65 20 66 output-to-file f
12f40 6e 61 6d 65 0a 09 28 6c 61 6d 62 64 61 20 28 29 name..(lambda ()
12f50 0a 09 20 20 28 6d 61 70 20 70 72 69 6e 74 20 28 .. (map print (
12f60 74 65 73 74 73 3a 74 65 73 74 73 2d 3e 64 6f 74 tests:tests->dot
12f70 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 73 69 test-records si
12f80 7a 65 78 20 73 69 7a 65 79 29 29 29 29 29 29 0a zex sizey)))))).
12f90 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a .(define (tests:
12fa0 74 65 73 74 73 2d 3e 64 6f 74 20 74 65 73 74 2d tests->dot test-
12fb0 72 65 63 6f 72 64 73 20 73 69 7a 65 78 20 73 69 records sizex si
12fc0 7a 65 79 29 0a 20 20 28 6c 65 74 20 28 28 61 6c zey). (let ((al
12fd0 6c 2d 74 65 73 74 6e 61 6d 65 73 20 28 68 61 73 l-testnames (has
12fe0 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 74 65 73 h-table-keys tes
12ff0 74 2d 72 65 63 6f 72 64 73 29 29 29 0a 20 20 20 t-records))).
13000 20 28 69 66 20 28 6e 75 6c 6c 3f 20 61 6c 6c 2d (if (null? all-
13010 74 65 73 74 6e 61 6d 65 73 29 0a 09 27 28 29 0a testnames)..'().
13020 09 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 .(let loop ((hed
13030 20 28 63 61 72 20 61 6c 6c 2d 74 65 73 74 6e 61 (car all-testna
13040 6d 65 73 29 29 0a 09 09 20 20 20 28 74 61 6c 20 mes))... (tal
13050 28 63 64 72 20 61 6c 6c 2d 74 65 73 74 6e 61 6d (cdr all-testnam
13060 65 73 29 29 0a 09 09 20 20 20 28 72 65 73 20 28 es))... (res (
13070 6c 69 73 74 20 22 64 69 67 72 61 70 68 20 74 65 list "digraph te
13080 73 74 73 20 7b 22 0a 09 09 09 20 20 20 20 20 20 sts {"....
13090 28 63 6f 6e 63 20 22 20 73 69 7a 65 3d 5c 22 22 (conc " size=\""
130a0 20 28 6f 72 20 73 69 7a 65 78 20 31 31 29 20 22 (or sizex 11) "
130b0 2c 22 20 28 6f 72 20 73 69 7a 65 79 20 31 31 29 ," (or sizey 11)
130c0 20 22 5c 22 3b 22 29 0a 09 09 09 20 20 20 20 20 "\";")....
130d0 20 22 20 72 61 74 69 6f 3d 30 2e 39 35 3b 22 0a " ratio=0.95;".
130e0 09 09 09 20 20 20 20 20 20 29 29 29 0a 09 20 20 ... )))..
130f0 28 6c 65 74 2a 20 28 28 74 65 73 74 72 65 63 20 (let* ((testrec
13100 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 (hash-table-ref
13110 74 65 73 74 2d 72 65 63 6f 72 64 73 20 68 65 64 test-records hed
13120 29 29 0a 09 09 20 28 77 61 69 74 6f 6e 73 20 28 ))... (waitons (
13130 6f 72 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 or (tests:testqu
13140 65 75 65 2d 67 65 74 2d 77 61 69 74 6f 6e 73 20 eue-get-waitons
13150 74 65 73 74 72 65 63 29 20 27 28 29 29 29 0a 09 testrec) '()))..
13160 09 20 28 6e 65 77 72 65 73 20 20 28 61 70 70 65 . (newres (appe
13170 6e 64 20 72 65 73 0a 09 09 09 09 20 20 28 69 66 nd res..... (if
13180 20 28 6e 75 6c 6c 3f 20 77 61 69 74 6f 6e 73 29 (null? waitons)
13190 0a 09 09 09 09 20 20 20 20 20 20 28 6c 69 73 74 ..... (list
131a0 20 28 63 6f 6e 63 20 22 20 20 20 5c 22 22 20 68 (conc " \"" h
131b0 65 64 20 22 5c 22 20 5b 73 68 61 70 65 3d 62 6f ed "\" [shape=bo
131c0 78 5d 3b 22 29 29 0a 09 09 09 09 20 20 20 20 20 x];")).....
131d0 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 77 (map (lambda (w
131e0 61 69 74 6f 6e 29 0a 09 09 09 09 09 20 20 20 20 aiton)......
131f0 20 28 63 6f 6e 63 20 22 20 20 20 5c 22 22 20 77 (conc " \"" w
13200 61 69 74 6f 6e 20 22 5c 22 20 2d 3e 20 5c 22 22 aiton "\" -> \""
13210 20 68 65 64 20 22 5c 22 20 5b 73 68 61 70 65 3d hed "\" [shape=
13220 62 6f 78 5d 3b 22 29 29 0a 09 09 09 09 09 20 20 box];"))......
13230 20 77 61 69 74 6f 6e 73 29 0a 09 09 09 09 20 20 waitons).....
13240 20 20 20 20 29 29 29 29 0a 09 20 20 20 20 28 69 )))).. (i
13250 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 f (null? tal)...
13260 28 61 70 70 65 6e 64 20 6e 65 77 72 65 73 20 28 (append newres (
13270 6c 69 73 74 20 22 7d 22 29 29 0a 09 09 28 6c 6f list "}"))...(lo
13280 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 op (car tal)(cdr
13290 20 74 61 6c 29 20 6e 65 77 72 65 73 29 0a 09 09 tal) newres)...
132a0 29 29 29 29 29 29 0a 0a 3b 3b 20 28 74 65 73 74 ))))))..;; (test
132b0 73 3a 72 75 6e 2d 64 6f 74 20 28 6c 69 73 74 20 s:run-dot (list
132c0 22 64 69 67 72 61 70 68 20 74 65 73 74 73 20 7b "digraph tests {
132d0 22 20 22 61 20 2d 3e 20 62 22 20 22 7d 22 29 20 " "a -> b" "}")
132e0 22 70 6c 61 69 6e 22 29 0a 0a 28 64 65 66 69 6e "plain")..(defin
132f0 65 20 28 74 65 73 74 73 3a 72 75 6e 2d 64 6f 74 e (tests:run-dot
13300 20 69 6e 64 61 74 20 6f 75 74 74 79 70 65 29 20 indat outtype)
13310 3b 3b 20 6f 75 74 74 79 70 65 20 69 73 20 70 6c ;; outtype is pl
13320 61 69 6e 2c 20 66 69 67 2c 20 64 6f 74 2c 20 65 ain, fig, dot, e
13330 74 63 2e 20 68 74 74 70 3a 2f 2f 77 77 77 2e 67 tc. http://www.g
13340 72 61 70 68 76 69 7a 2e 6f 72 67 2f 63 6f 6e 74 raphviz.org/cont
13350 65 6e 74 2f 6f 75 74 70 75 74 2d 66 6f 72 6d 61 ent/output-forma
13360 74 73 0a 20 20 28 6c 65 74 2d 76 61 6c 75 65 73 ts. (let-values
13370 20 28 28 28 69 6e 70 20 6f 75 70 20 70 69 64 29 (((inp oup pid)
13380 28 70 72 6f 63 65 73 73 20 22 65 6e 76 20 2d 69 (process "env -i
13390 20 50 41 54 48 3d 24 50 41 54 48 20 64 6f 74 22 PATH=$PATH dot"
133a0 20 28 6c 69 73 74 20 22 2d 54 22 20 6f 75 74 74 (list "-T" outt
133b0 79 70 65 29 29 29 29 0a 20 20 20 20 28 77 69 74 ype)))). (wit
133c0 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 70 6f 72 74 h-output-to-port
133d0 20 6f 75 70 0a 20 20 20 20 20 20 28 6c 61 6d 62 oup. (lamb
133e0 64 61 20 28 29 0a 09 28 6d 61 70 20 70 72 69 6e da ()..(map prin
133f0 74 20 69 6e 64 61 74 29 29 29 0a 20 20 20 20 28 t indat))). (
13400 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 close-output-por
13410 74 20 6f 75 70 29 0a 20 20 20 20 28 6c 65 74 20 t oup). (let
13420 28 28 72 65 73 20 28 77 69 74 68 2d 69 6e 70 75 ((res (with-inpu
13430 74 2d 66 72 6f 6d 2d 70 6f 72 74 20 69 6e 70 0a t-from-port inp.
13440 09 09 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 .. (lambda ()...
13450 20 20 20 28 72 65 61 64 2d 6c 69 6e 65 73 29 29 (read-lines))
13460 29 29 29 0a 20 20 20 20 20 20 28 63 6c 6f 73 65 ))). (close
13470 2d 69 6e 70 75 74 2d 70 6f 72 74 20 69 6e 70 29 -input-port inp)
13480 0a 20 20 20 20 20 20 72 65 73 29 29 29 0a 0a 3b . res)))..;
13490 3b 20 72 65 61 64 20 64 61 74 61 20 66 72 6f 6d ; read data from
134a0 20 74 6d 70 20 66 69 6c 65 20 6f 72 20 63 72 65 tmp file or cre
134b0 61 74 65 20 69 66 20 6e 6f 74 20 65 78 69 73 74 ate if not exist
134c0 73 0a 3b 3b 20 69 66 20 65 78 69 73 74 73 20 72 s.;; if exists r
134d0 65 67 65 6e 20 69 6e 20 62 61 63 6b 67 72 6f 75 egen in backgrou
134e0 6e 64 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 nd.;;.(define (t
134f0 65 73 74 73 3a 6c 61 7a 79 2d 64 6f 74 20 74 65 ests:lazy-dot te
13500 73 74 72 65 63 6f 72 64 73 20 20 6f 75 74 74 79 strecords outty
13510 70 65 20 73 69 7a 65 78 20 73 69 7a 65 79 29 0a pe sizex sizey).
13520 20 20 28 6c 65 74 20 28 28 64 66 69 6c 65 20 28 (let ((dfile (
13530 63 6f 6e 63 20 22 2f 74 6d 70 2f 2e 22 20 28 63 conc "/tmp/." (c
13540 75 72 72 65 6e 74 2d 75 73 65 72 2d 6e 61 6d 65 urrent-user-name
13550 29 20 22 2d 22 20 28 73 65 72 76 65 72 3a 6d 6b ) "-" (server:mk
13560 2d 73 69 67 6e 61 74 75 72 65 29 20 22 2e 64 6f -signature) ".do
13570 74 22 29 29 0a 09 28 66 6e 61 6d 65 20 28 63 6f t"))..(fname (co
13580 6e 63 20 22 2f 74 6d 70 2f 2e 22 20 28 63 75 72 nc "/tmp/." (cur
13590 72 65 6e 74 2d 75 73 65 72 2d 6e 61 6d 65 29 20 rent-user-name)
135a0 22 2d 22 20 28 73 65 72 76 65 72 3a 6d 6b 2d 73 "-" (server:mk-s
135b0 69 67 6e 61 74 75 72 65 29 20 22 2e 64 6f 74 64 ignature) ".dotd
135c0 61 74 22 29 29 29 0a 20 20 20 20 28 74 65 73 74 at"))). (test
135d0 73 3a 77 72 69 74 65 2d 64 6f 74 2d 66 69 6c 65 s:write-dot-file
135e0 20 74 65 73 74 72 65 63 6f 72 64 73 20 64 66 69 testrecords dfi
135f0 6c 65 20 73 69 7a 65 78 20 73 69 7a 65 79 29 0a le sizex sizey).
13600 20 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a (if (common:
13610 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 66 6e 61 file-exists? fna
13620 6d 65 29 0a 09 28 6c 65 74 20 28 28 72 65 73 20 me)..(let ((res
13630 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d (with-input-from
13640 2d 66 69 6c 65 20 66 6e 61 6d 65 0a 09 09 20 20 -file fname...
13650 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 (lambda ()...
13660 20 20 20 20 20 20 20 28 72 65 61 64 2d 6c 69 6e (read-lin
13670 65 73 29 29 29 29 29 0a 09 20 20 28 73 79 73 74 es))))).. (syst
13680 65 6d 20 28 63 6f 6e 63 20 22 65 6e 76 20 2d 69 em (conc "env -i
13690 20 50 41 54 48 3d 24 50 41 54 48 20 64 6f 74 20 PATH=$PATH dot
136a0 2d 54 20 22 20 6f 75 74 74 79 70 65 20 22 20 3c -T " outtype " <
136b0 20 22 20 64 66 69 6c 65 20 22 20 3e 20 22 20 66 " dfile " > " f
136c0 6e 61 6d 65 20 22 26 22 29 29 0a 09 20 20 72 65 name "&")).. re
136d0 73 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 73 s)..(begin.. (s
136e0 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 65 6e 76 ystem (conc "env
136f0 20 2d 69 20 50 41 54 48 3d 24 50 41 54 48 20 64 -i PATH=$PATH d
13700 6f 74 20 2d 54 20 22 20 6f 75 74 74 79 70 65 20 ot -T " outtype
13710 22 20 3c 20 22 20 64 66 69 6c 65 20 22 20 3e 20 " < " dfile " >
13720 22 20 66 6e 61 6d 65 29 29 0a 09 20 20 28 77 69 " fname)).. (wi
13730 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 66 69 th-input-from-fi
13740 6c 65 20 66 6e 61 6d 65 0a 09 20 20 20 20 28 6c le fname.. (l
13750 61 6d 62 64 61 20 28 29 0a 09 20 20 20 20 20 20 ambda ()..
13760 28 72 65 61 64 2d 6c 69 6e 65 73 29 29 29 29 29 (read-lines)))))
13770 29 29 0a 09 20 20 0a 0a 3b 3b 20 66 6f 72 20 65 )).. ..;; for e
13780 61 63 68 20 74 65 73 74 3a 0a 3b 3b 20 20 20 0a ach test:.;; .
13790 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 66 (define (tests:f
137a0 69 6c 74 65 72 2d 6e 6f 6e 2d 72 75 6e 6e 61 62 ilter-non-runnab
137b0 6c 65 20 72 75 6e 2d 69 64 20 74 65 73 74 6b 65 le run-id testke
137c0 79 6e 61 6d 65 73 20 74 65 73 74 72 65 63 6f 72 ynames testrecor
137d0 64 73 68 61 73 68 29 0a 20 20 28 6c 65 74 20 28 dshash). (let (
137e0 28 72 75 6e 6e 61 62 6c 65 73 20 27 28 29 29 29 (runnables '()))
137f0 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 . (for-each.
13800 20 20 20 20 28 6c 61 6d 62 64 61 20 28 74 65 73 (lambda (tes
13810 74 6b 65 79 6e 61 6d 65 29 0a 20 20 20 20 20 20 tkeyname).
13820 20 28 6c 65 74 2a 20 28 28 74 65 73 74 2d 72 65 (let* ((test-re
13830 63 6f 72 64 20 28 68 61 73 68 2d 74 61 62 6c 65 cord (hash-table
13840 2d 72 65 66 20 74 65 73 74 72 65 63 6f 72 64 73 -ref testrecords
13850 68 61 73 68 20 74 65 73 74 6b 65 79 6e 61 6d 65 hash testkeyname
13860 29 29 0a 09 20 20 20 20 20 20 28 74 65 73 74 2d )).. (test-
13870 6e 61 6d 65 20 20 20 28 74 65 73 74 73 3a 74 65 name (tests:te
13880 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 73 74 stqueue-get-test
13890 6e 61 6d 65 20 20 74 65 73 74 2d 72 65 63 6f 72 name test-recor
138a0 64 29 29 0a 09 20 20 20 20 20 20 28 69 74 65 6d d)).. (item
138b0 64 61 74 20 20 20 20 20 28 74 65 73 74 73 3a 74 dat (tests:t
138c0 65 73 74 71 75 65 75 65 2d 67 65 74 2d 69 74 65 estqueue-get-ite
138d0 6d 64 61 74 20 20 20 74 65 73 74 2d 72 65 63 6f mdat test-reco
138e0 72 64 29 29 0a 09 20 20 20 20 20 20 28 69 74 65 rd)).. (ite
138f0 6d 2d 70 61 74 68 20 20 20 28 74 65 73 74 73 3a m-path (tests:
13900 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 69 74 testqueue-get-it
13910 65 6d 5f 70 61 74 68 20 74 65 73 74 2d 72 65 63 em_path test-rec
13920 6f 72 64 29 29 0a 09 20 20 20 20 20 20 28 77 61 ord)).. (wa
13930 69 74 6f 6e 73 20 20 20 20 20 28 74 65 73 74 73 itons (tests
13940 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 77 :testqueue-get-w
13950 61 69 74 6f 6e 73 20 20 20 74 65 73 74 2d 72 65 aitons test-re
13960 63 6f 72 64 29 29 0a 09 20 20 20 20 20 20 28 6b cord)).. (k
13970 65 65 70 2d 74 65 73 74 20 20 20 23 74 29 0a 09 eep-test #t)..
13980 20 20 20 20 20 20 28 74 65 73 74 2d 69 64 20 20 (test-id
13990 20 20 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 (rmt:get-test
139a0 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d -id run-id test-
139b0 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 name item-path))
139c0 0a 09 20 20 20 20 20 20 28 74 64 61 74 20 20 20 .. (tdat
139d0 20 20 20 20 20 28 72 6d 74 3a 67 65 74 2d 74 65 (rmt:get-te
139e0 73 74 69 6e 66 6f 2d 73 74 61 74 65 2d 73 74 61 stinfo-state-sta
139f0 74 75 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d tus run-id test-
13a00 69 64 29 29 29 20 3b 3b 20 28 63 64 62 3a 67 65 id))) ;; (cdb:ge
13a10 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 t-test-info-by-i
13a20 64 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 74 65 d *runremote* te
13a30 73 74 2d 69 64 29 29 29 0a 09 20 28 69 66 20 74 st-id))).. (if t
13a40 64 61 74 0a 09 20 20 20 20 20 28 62 65 67 69 6e dat.. (begin
13a50 0a 09 20 20 20 20 20 20 20 3b 3b 20 4c 6f 6f 6b .. ;; Look
13a60 20 61 74 20 74 68 65 20 74 65 73 74 20 73 74 61 at the test sta
13a70 74 65 20 61 6e 64 20 73 74 61 74 75 73 0a 09 20 te and status..
13a80 20 20 20 20 20 20 28 69 66 20 28 6f 72 20 28 61 (if (or (a
13a90 6e 64 20 28 6d 65 6d 62 65 72 20 28 64 62 3a 74 nd (member (db:t
13aa0 65 73 74 2d 67 65 74 2d 73 74 61 74 75 73 20 74 est-get-status t
13ab0 64 61 74 29 20 0a 09 09 09 09 20 20 20 20 27 28 dat) ..... '(
13ac0 22 50 41 53 53 22 20 22 57 41 52 4e 22 20 22 57 "PASS" "WARN" "W
13ad0 41 49 56 45 44 22 20 22 43 48 45 43 4b 22 20 22 AIVED" "CHECK" "
13ae0 53 4b 49 50 22 29 29 0a 09 09 09 20 20 20 20 28 SKIP")).... (
13af0 65 71 75 61 6c 3f 20 28 64 62 3a 74 65 73 74 2d equal? (db:test-
13b00 67 65 74 2d 73 74 61 74 65 20 74 64 61 74 29 20 get-state tdat)
13b10 22 43 4f 4d 50 4c 45 54 45 44 22 29 29 0a 09 09 "COMPLETED"))...
13b20 20 20 20 20 20 20 20 28 6d 65 6d 62 65 72 20 28 (member (
13b30 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 db:test-get-stat
13b40 65 20 74 64 61 74 29 0a 09 09 09 09 20 20 20 20 e tdat).....
13b50 27 28 22 49 4e 43 4f 4d 50 4c 45 54 45 22 20 22 '("INCOMPLETE" "
13b60 4b 49 4c 4c 45 44 22 29 29 29 0a 09 09 20 20 20 KILLED")))...
13b70 28 73 65 74 21 20 6b 65 65 70 2d 74 65 73 74 20 (set! keep-test
13b80 23 66 29 29 0a 0a 09 20 20 20 20 20 20 20 3b 3b #f))... ;;
13b90 20 65 78 61 6d 69 6e 65 20 77 61 69 74 6f 6e 73 examine waitons
13ba0 20 66 6f 72 20 61 6e 79 20 66 61 69 6c 73 2e 20 for any fails.
13bb0 49 66 20 69 74 20 69 73 20 46 41 49 4c 20 6f 72 If it is FAIL or
13bc0 20 49 4e 43 4f 4d 50 4c 45 54 45 20 74 68 65 6e INCOMPLETE then
13bd0 20 65 6c 69 6d 69 6e 61 74 65 20 74 68 69 73 20 eliminate this
13be0 74 65 73 74 0a 09 20 20 20 20 20 20 20 3b 3b 20 test.. ;;
13bf0 66 72 6f 6d 20 74 68 65 20 72 75 6e 6e 61 62 6c from the runnabl
13c00 65 20 6c 69 73 74 0a 09 20 20 20 20 20 20 20 28 e list.. (
13c10 69 66 20 6b 65 65 70 2d 74 65 73 74 0a 09 09 20 if keep-test...
13c20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d (for-each (lam
13c30 62 64 61 20 28 77 61 69 74 6f 6e 29 0a 09 09 09 bda (waiton)....
13c40 20 20 20 20 20 20 20 3b 3b 20 66 6f 72 20 6e 6f ;; for no
13c50 77 20 77 65 20 61 72 65 20 77 61 69 74 69 6e 67 w we are waiting
13c60 20 6f 6e 6c 79 20 6f 6e 20 74 68 65 20 70 61 72 only on the par
13c70 65 6e 74 20 74 65 73 74 0a 09 09 09 20 20 20 20 ent test....
13c80 20 20 20 28 6c 65 74 2a 20 28 28 70 61 72 65 6e (let* ((paren
13c90 74 2d 74 65 73 74 2d 69 64 20 28 72 6d 74 3a 67 t-test-id (rmt:g
13ca0 65 74 2d 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 et-test-id run-i
13cb0 64 20 77 61 69 74 6f 6e 20 22 22 29 29 0a 09 09 d waiton ""))...
13cc0 09 09 20 20 20 20 20 20 28 77 74 64 61 74 20 20 .. (wtdat
13cd0 20 20 20 20 20 20 20 20 28 72 6d 74 3a 67 65 74 (rmt:get
13ce0 2d 74 65 73 74 69 6e 66 6f 2d 73 74 61 74 65 2d -testinfo-state-
13cf0 73 74 61 74 75 73 20 72 75 6e 2d 69 64 20 74 65 status run-id te
13d00 73 74 2d 69 64 29 29 29 20 3b 3b 20 28 63 64 62 st-id))) ;; (cdb
13d10 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 :get-test-info-b
13d20 79 2d 69 64 20 2a 72 75 6e 72 65 6d 6f 74 65 2a y-id *runremote*
13d30 20 74 65 73 74 2d 69 64 29 29 29 0a 09 09 09 09 test-id))).....
13d40 20 28 69 66 20 28 6f 72 20 28 61 6e 64 20 28 65 (if (or (and (e
13d50 71 75 61 6c 3f 20 28 64 62 3a 74 65 73 74 2d 67 qual? (db:test-g
13d60 65 74 2d 73 74 61 74 65 20 77 74 64 61 74 29 20 et-state wtdat)
13d70 22 43 4f 4d 50 4c 45 54 45 44 22 29 0a 09 09 09 "COMPLETED")....
13d80 09 09 20 20 20 20 20 20 28 6d 65 6d 62 65 72 20 .. (member
13d90 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 (db:test-get-sta
13da0 74 75 73 20 77 74 64 61 74 29 20 27 28 22 46 41 tus wtdat) '("FA
13db0 49 4c 22 20 22 41 42 4f 52 54 22 29 29 29 0a 09 IL" "ABORT")))..
13dc0 09 09 09 09 20 28 6d 65 6d 62 65 72 20 28 64 62 .... (member (db
13dd0 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 73 :test-get-status
13de0 20 77 74 64 61 74 29 20 20 27 28 22 4b 49 4c 4c wtdat) '("KILL
13df0 45 44 22 29 29 0a 09 09 09 09 09 20 28 6d 65 6d ED"))...... (mem
13e00 62 65 72 20 28 64 62 3a 74 65 73 74 2d 67 65 74 ber (db:test-get
13e10 2d 73 74 61 74 65 20 77 74 64 61 74 29 20 20 20 -state wtdat)
13e20 27 28 22 49 4e 43 4f 4d 50 45 54 45 22 29 29 29 '("INCOMPETE")))
13e30 0a 09 09 09 09 20 3b 3b 20 28 69 66 20 28 6f 72 ..... ;; (if (or
13e40 20 28 6d 65 6d 62 65 72 20 28 64 62 3a 74 65 73 (member (db:tes
13e50 74 2d 67 65 74 2d 73 74 61 74 75 73 20 77 74 64 t-get-status wtd
13e60 61 74 29 0a 09 09 09 09 20 3b 3b 20 20 20 20 20 at)..... ;;
13e70 20 20 20 09 20 27 28 22 46 41 49 4c 22 20 22 4b . '("FAIL" "K
13e80 49 4c 4c 45 44 22 29 29 0a 09 09 09 09 20 3b 3b ILLED"))..... ;;
13e90 20 20 20 20 20 20 20 20 20 28 6d 65 6d 62 65 72 (member
13ea0 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 (db:test-get-st
13eb0 61 74 65 20 77 74 64 61 74 29 0a 09 09 09 09 20 ate wtdat).....
13ec0 3b 3b 20 20 20 20 20 20 20 20 09 20 27 28 22 49 ;; . '("I
13ed0 4e 43 4f 4d 50 45 54 45 22 29 29 29 0a 09 09 09 NCOMPETE")))....
13ee0 09 20 20 20 20 20 28 73 65 74 21 20 6b 65 65 70 . (set! keep
13ef0 2d 74 65 73 74 20 23 66 29 29 29 29 20 3b 3b 20 -test #f)))) ;;
13f00 6e 6f 20 70 6f 69 6e 74 20 69 6e 20 72 75 6e 6e no point in runn
13f10 69 6e 67 20 74 68 69 73 20 6f 6e 65 20 61 67 61 ing this one aga
13f20 69 6e 0a 09 09 09 20 20 20 20 20 77 61 69 74 6f in.... waito
13f30 6e 73 29 29 29 29 0a 09 20 28 69 66 20 6b 65 65 ns)))).. (if kee
13f40 70 2d 74 65 73 74 20 28 73 65 74 21 20 72 75 6e p-test (set! run
13f50 6e 61 62 6c 65 73 20 28 63 6f 6e 73 20 74 65 73 nables (cons tes
13f60 74 6b 65 79 6e 61 6d 65 20 72 75 6e 6e 61 62 6c tkeyname runnabl
13f70 65 73 29 29 29 29 29 0a 20 20 20 20 20 74 65 73 es))))). tes
13f80 74 6b 65 79 6e 61 6d 65 73 29 0a 20 20 20 20 72 tkeynames). r
13f90 75 6e 6e 61 62 6c 65 73 29 29 0a 0a 3b 3b 3d 3d unnables))..;;==
13fa0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13fb0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13fc0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13fd0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13fe0 3d 3d 3d 3d 0a 3b 3b 20 72 65 66 61 63 74 6f 72 ====.;; refactor
13ff0 69 6e 67 20 74 68 69 73 20 62 6c 6f 63 6b 20 69 ing this block i
14000 6e 74 6f 20 74 65 73 74 73 3a 67 65 74 2d 66 75 nto tests:get-fu
14010 6c 6c 2d 64 61 74 61 20 66 72 6f 6d 20 6c 69 6e ll-data from lin
14020 65 20 32 36 33 20 6f 66 20 72 75 6e 73 2e 73 63 e 263 of runs.sc
14030 6d 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d m.;;============
14040 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14050 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14060 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14070 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 68 65 ==========.;; he
14080 64 20 69 73 20 74 68 65 20 74 65 73 74 20 6e 61 d is the test na
14090 6d 65 0a 3b 3b 20 74 65 73 74 2d 72 65 63 6f 72 me.;; test-recor
140a0 64 73 20 69 73 20 61 20 68 61 73 68 20 6f 66 20 ds is a hash of
140b0 74 65 73 74 2d 6e 61 6d 65 20 3d 3e 20 74 65 73 test-name => tes
140c0 74 20 72 65 63 6f 72 64 0a 28 64 65 66 69 6e 65 t record.(define
140d0 20 28 74 65 73 74 73 3a 67 65 74 2d 66 75 6c 6c (tests:get-full
140e0 2d 64 61 74 61 20 74 65 73 74 2d 6e 61 6d 65 73 -data test-names
140f0 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 72 65 test-records re
14100 71 75 69 72 65 64 2d 74 65 73 74 73 20 61 6c 6c quired-tests all
14110 2d 74 65 73 74 73 2d 72 65 67 69 73 74 72 79 29 -tests-registry)
14120 0a 20 20 28 6c 65 74 20 28 28 6d 69 73 73 69 6e . (let ((missin
14130 67 2d 77 61 69 74 6f 6e 73 20 28 6d 61 6b 65 2d g-waitons (make-
14140 68 61 73 68 2d 74 61 62 6c 65 29 29 29 0a 20 20 hash-table))).
14150 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c (if (not (null
14160 3f 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 0a 20 ? test-names)).
14170 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 (let loop (
14180 28 68 65 64 20 28 63 61 72 20 74 65 73 74 2d 6e (hed (car test-n
14190 61 6d 65 73 29 29 0a 09 09 20 28 74 61 6c 20 28 ames))... (tal (
141a0 63 64 72 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 cdr test-names))
141b0 29 20 20 20 20 20 20 20 20 20 3b 3b 20 27 72 65 ) ;; 're
141c0 74 75 72 6e 2d 70 72 6f 63 73 20 74 65 6c 6c 73 turn-procs tells
141d0 20 74 68 65 20 63 6f 6e 66 69 67 20 72 65 61 64 the config read
141e0 65 72 20 74 6f 20 70 72 65 70 20 72 75 6e 6e 69 er to prep runni
141f0 6e 67 20 73 79 73 74 65 6d 20 62 75 74 20 72 65 ng system but re
14200 74 75 72 6e 20 61 20 70 72 6f 63 0a 09 28 64 65 turn a proc..(de
14210 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 bug:print-info 4
14220 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
14230 72 74 2a 20 22 68 65 64 3d 22 20 68 65 64 20 22 rt* "hed=" hed "
14240 20 61 74 20 74 6f 70 20 6f 66 20 6c 6f 6f 70 22 at top of loop"
14250 29 0a 20 20 20 20 20 20 20 20 3b 3b 20 64 6f 6e ). ;; don
14260 27 74 20 6b 6e 6f 77 20 69 74 65 6d 2d 70 61 74 't know item-pat
14270 68 20 61 74 20 74 68 69 73 20 74 69 6d 65 2c 20 h at this time,
14280 6c 65 74 20 74 68 65 20 74 65 73 74 63 6f 6e 66 let the testconf
14290 69 67 20 67 65 74 20 74 68 65 20 74 6f 70 20 6c ig get the top l
142a0 65 76 65 6c 20 74 65 73 74 63 6f 6e 66 69 67 0a evel testconfig.
142b0 09 28 6c 65 74 2a 20 28 28 63 6f 6e 66 69 67 20 .(let* ((config
142c0 20 28 74 65 73 74 73 3a 67 65 74 2d 74 65 73 74 (tests:get-test
142d0 63 6f 6e 66 69 67 20 68 65 64 20 23 66 20 61 6c config hed #f al
142e0 6c 2d 74 65 73 74 73 2d 72 65 67 69 73 74 72 79 l-tests-registry
142f0 20 27 72 65 74 75 72 6e 2d 70 72 6f 63 73 29 29 'return-procs))
14300 0a 09 20 20 20 20 20 20 20 28 77 61 69 74 6f 6e .. (waiton
14310 73 20 28 6c 65 74 20 28 28 69 6e 73 74 72 20 28 s (let ((instr (
14320 69 66 20 63 6f 6e 66 69 67 20 0a 09 09 09 09 09 if config ......
14330 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 (configf:lookup
14340 20 63 6f 6e 66 69 67 20 22 72 65 71 75 69 72 65 config "require
14350 6d 65 6e 74 73 22 20 22 77 61 69 74 6f 6e 22 29 ments" "waiton")
14360 0a 09 09 09 09 09 20 28 62 65 67 69 6e 20 3b 3b ...... (begin ;;
14370 20 4e 6f 20 63 6f 6e 66 69 67 20 6d 65 61 6e 73 No config means
14380 20 74 68 69 73 20 69 73 20 61 20 6e 6f 6e 2d 65 this is a non-e
14390 78 69 73 74 65 6e 74 20 74 65 73 74 0a 20 20 20 xistent test.
143a0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
143b0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
143c0 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 77 (let ((w
143d0 61 69 74 65 72 73 20 27 28 29 29 29 0a 20 20 20 aiters '())).
143e0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
143f0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14400 20 20 20 20 20 20 20 20 20 20 3b 3b 20 66 69 6e ;; fin
14410 64 20 74 68 65 20 77 61 69 74 65 72 28 73 29 20 d the waiter(s)
14420 66 6f 72 20 74 68 69 73 20 77 61 69 74 6f 6e 2e for this waiton.
14430 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
14440 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14450 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 66 (f
14460 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 20 20 20 or-each .
14470 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14480 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14490 20 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 28 (lambda(
144a0 77 61 69 74 65 72 29 0a 20 20 20 20 20 20 20 20 waiter).
144b0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
144c0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
144d0 20 20 20 20 20 20 20 20 20 3b 3b 20 28 70 72 69 ;; (pri
144e0 6e 74 20 22 74 65 73 74 2d 72 65 63 6f 72 64 20 nt "test-record
144f0 3d 20 22 20 28 68 61 73 68 2d 74 61 62 6c 65 2d = " (hash-table-
14500 72 65 66 20 74 65 73 74 2d 72 65 63 6f 72 64 73 ref test-records
14510 20 77 61 69 74 65 72 29 29 0a 20 20 20 20 20 20 waiter)).
14520 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14530 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14540 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 28 70 ;; (p
14550 72 69 6e 74 20 22 77 61 69 74 6f 6e 73 20 3d 20 rint "waitons =
14560 22 20 28 76 65 63 74 6f 72 2d 72 65 66 20 28 68 " (vector-ref (h
14570 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 74 65 ash-table-ref te
14580 73 74 2d 72 65 63 6f 72 64 73 20 77 61 69 74 65 st-records waite
14590 72 29 20 32 29 29 0a 20 20 20 20 20 20 20 20 20 r) 2)).
145a0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
145b0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
145c0 20 20 20 20 20 20 20 20 28 69 66 20 28 6d 65 6d (if (mem
145d0 62 65 72 20 68 65 64 20 28 76 65 63 74 6f 72 2d ber hed (vector-
145e0 72 65 66 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ref (hash-table-
145f0 72 65 66 20 74 65 73 74 2d 72 65 63 6f 72 64 73 ref test-records
14600 20 77 61 69 74 65 72 29 20 32 29 29 0a 20 20 20 waiter) 2)).
14610 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14620 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14630 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14640 20 28 73 65 74 21 20 77 61 69 74 65 72 73 20 28 (set! waiters (
14650 63 6f 6e 73 20 77 61 69 74 65 72 20 77 61 69 74 cons waiter wait
14660 65 72 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 ers)).
14670 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14680 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14690 20 20 20 20 20 20 20 29 0a 20 20 20 20 20 20 20 ).
146a0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
146b0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
146c0 20 20 20 20 20 20 20 20 29 0a 20 20 20 20 20 20 ).
146d0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
146e0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
146f0 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 (hash-tab
14700 6c 65 2d 6b 65 79 73 20 74 65 73 74 2d 72 65 63 le-keys test-rec
14710 6f 72 64 73 29 29 0a 20 20 20 20 20 20 20 20 20 ords)).
14720 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14730 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14740 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
14750 73 65 74 21 20 6d 69 73 73 69 6e 67 2d 77 61 69 set! missing-wai
14760 74 6f 6e 73 20 68 65 64 20 77 61 69 74 65 72 73 tons hed waiters
14770 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
14780 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14790 20 20 20 20 20 20 20 20 20 20 20 20 20 29 0a 09 )..
147a0 09 09 09 09 20 20 20 22 22 29 29 29 29 0a 09 09 .... ""))))...
147b0 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d . (debug:print-
147c0 69 6e 66 6f 20 38 20 2a 64 65 66 61 75 6c 74 2d info 8 *default-
147d0 6c 6f 67 2d 70 6f 72 74 2a 20 22 77 61 69 74 6f log-port* "waito
147e0 6e 73 20 73 74 72 69 6e 67 20 69 73 20 22 20 69 ns string is " i
147f0 6e 73 74 72 29 0a 09 09 09 20 20 28 73 74 72 69 nstr).... (stri
14800 6e 67 2d 73 70 6c 69 74 20 28 63 6f 6e 64 0a 09 ng-split (cond..
14810 09 09 09 09 20 28 28 70 72 6f 63 65 64 75 72 65 .... ((procedure
14820 3f 20 69 6e 73 74 72 29 0a 09 09 09 09 09 20 20 ? instr)......
14830 28 6c 65 74 20 28 28 72 65 73 20 28 69 6e 73 74 (let ((res (inst
14840 72 29 29 29 0a 09 09 09 09 09 20 20 20 20 28 64 r)))...... (d
14850 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
14860 38 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 8 *default-log-p
14870 6f 72 74 2a 20 22 77 61 69 74 6f 6e 20 70 72 6f ort* "waiton pro
14880 63 65 64 75 72 65 20 72 65 73 75 6c 74 73 20 69 cedure results i
14890 6e 20 73 74 72 69 6e 67 20 22 20 72 65 73 20 22 n string " res "
148a0 20 66 6f 72 20 74 65 73 74 20 22 20 68 65 64 29 for test " hed)
148b0 0a 09 09 09 09 09 20 20 20 20 72 65 73 29 29 0a ...... res)).
148c0 09 09 09 09 09 20 28 28 73 74 72 69 6e 67 3f 20 ..... ((string?
148d0 69 6e 73 74 72 29 20 20 20 20 20 69 6e 73 74 72 instr) instr
148e0 29 0a 09 09 09 09 09 20 28 65 6c 73 65 20 0a 09 )...... (else ..
148f0 09 09 09 09 20 20 3b 3b 20 4e 4f 54 45 3a 20 54 .... ;; NOTE: T
14900 68 69 73 20 69 73 20 61 63 74 75 61 6c 6c 79 20 his is actually
14910 74 68 65 20 63 61 73 65 20 6f 66 20 2a 6e 6f 2a the case of *no*
14920 20 77 61 69 74 6f 6e 73 21 20 3b 3b 20 0a 09 09 waitons! ;; ...
14930 09 09 09 20 20 22 22 29 29 29 29 29 29 0a 09 20 ... ""))))))..
14940 20 28 69 66 20 28 6e 6f 74 20 63 6f 6e 66 69 67 (if (not config
14950 29 20 3b 3b 20 74 68 69 73 20 69 73 20 61 20 6e ) ;; this is a n
14960 6f 6e 2d 65 78 69 73 74 61 6e 74 20 74 65 73 74 on-existant test
14970 20 63 61 6c 6c 65 64 20 69 6e 20 61 20 77 61 69 called in a wai
14980 74 6f 6e 2e 20 0a 09 20 20 20 20 20 20 28 69 66 ton. .. (if
14990 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 20 (null? tal)...
149a0 20 74 65 73 74 2d 72 65 63 6f 72 64 73 0a 09 09 test-records...
149b0 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c (loop (car tal
149c0 29 28 63 64 72 20 74 61 6c 29 29 29 0a 09 20 20 )(cdr tal)))..
149d0 20 20 20 20 28 62 65 67 69 6e 0a 09 09 28 64 65 (begin...(de
149e0 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 38 bug:print-info 8
149f0 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
14a00 72 74 2a 20 22 77 61 69 74 6f 6e 73 3a 20 22 20 rt* "waitons: "
14a10 77 61 69 74 6f 6e 73 29 0a 09 09 3b 3b 20 63 68 waitons)...;; ch
14a20 65 63 6b 20 66 6f 72 20 68 65 64 20 69 6e 20 77 eck for hed in w
14a30 61 69 74 6f 6e 73 20 3d 3e 20 74 68 69 73 20 77 aitons => this w
14a40 6f 75 6c 64 20 62 65 20 63 69 72 63 75 6c 61 72 ould be circular
14a50 2c 20 72 65 6d 6f 76 65 20 69 74 20 61 6e 64 20 , remove it and
14a60 69 73 73 75 65 20 61 6e 0a 09 09 3b 3b 20 65 72 issue an...;; er
14a70 72 6f 72 0a 09 09 28 69 66 20 28 6d 65 6d 62 65 ror...(if (membe
14a80 72 20 68 65 64 20 77 61 69 74 6f 6e 73 29 0a 09 r hed waitons)..
14a90 09 20 20 20 20 28 62 65 67 69 6e 0a 09 09 20 20 . (begin...
14aa0 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
14ab0 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c -error 0 *defaul
14ac0 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 74 65 73 t-log-port* "tes
14ad0 74 20 22 20 68 65 64 20 22 20 68 61 73 20 6c 69 t " hed " has li
14ae0 73 74 65 64 20 69 74 73 65 6c 66 20 61 73 20 61 sted itself as a
14af0 20 77 61 69 74 6f 6e 2c 20 70 6c 65 61 73 65 20 waiton, please
14b00 63 6f 72 72 65 63 74 20 74 68 69 73 21 22 29 0a correct this!").
14b10 09 09 20 20 20 20 20 20 28 73 65 74 21 20 77 61 .. (set! wa
14b20 69 74 6f 6e 73 20 28 66 69 6c 74 65 72 20 28 6c itons (filter (l
14b30 61 6d 62 64 61 20 28 78 29 28 6e 6f 74 20 28 65 ambda (x)(not (e
14b40 71 75 61 6c 3f 20 78 20 68 65 64 29 29 29 20 77 qual? x hed))) w
14b50 61 69 74 6f 6e 73 29 29 29 29 0a 09 09 0a 09 09 aitons))))......
14b60 3b 3b 20 28 69 74 65 6d 73 20 20 20 28 69 74 65 ;; (items (ite
14b70 6d 73 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f ms:get-items-fro
14b80 6d 2d 63 6f 6e 66 69 67 20 63 6f 6e 66 69 67 29 m-config config)
14b90 29 29 0a 09 09 28 69 66 20 28 6e 6f 74 20 28 68 ))...(if (not (h
14ba0 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
14bb0 66 61 75 6c 74 20 74 65 73 74 2d 72 65 63 6f 72 fault test-recor
14bc0 64 73 20 68 65 64 20 23 66 29 29 0a 09 09 20 20 ds hed #f))...
14bd0 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
14be0 74 21 20 74 65 73 74 2d 72 65 63 6f 72 64 73 0a t! test-records.
14bf0 09 09 09 09 20 20 20 20 20 68 65 64 20 28 76 65 .... hed (ve
14c00 63 74 6f 72 20 68 65 64 20 20 20 20 20 3b 3b 20 ctor hed ;;
14c10 30 0a 09 09 09 09 09 09 20 63 6f 6e 66 69 67 20 0....... config
14c20 20 3b 3b 20 31 0a 09 09 09 09 09 09 20 77 61 69 ;; 1....... wai
14c30 74 6f 6e 73 20 3b 3b 20 32 0a 09 09 09 09 09 09 tons ;; 2.......
14c40 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 (configf:lookup
14c50 20 63 6f 6e 66 69 67 20 22 72 65 71 75 69 72 65 config "require
14c60 6d 65 6e 74 73 22 20 22 70 72 69 6f 72 69 74 79 ments" "priority
14c70 22 29 20 20 20 20 20 3b 3b 20 70 72 69 6f 72 69 ") ;; priori
14c80 74 79 20 33 0a 09 09 09 09 09 09 20 28 6c 65 74 ty 3....... (let
14c90 20 28 28 69 74 65 6d 73 20 20 20 20 20 20 28 68 ((items (h
14ca0 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
14cb0 66 61 75 6c 74 20 63 6f 6e 66 69 67 20 22 69 74 fault config "it
14cc0 65 6d 73 22 20 23 66 29 29 20 3b 3b 20 69 74 65 ems" #f)) ;; ite
14cd0 6d 73 20 34 0a 09 09 09 09 09 09 20 20 20 20 20 ms 4.......
14ce0 20 20 28 69 74 65 6d 73 74 61 62 6c 65 20 28 68 (itemstable (h
14cf0 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
14d00 66 61 75 6c 74 20 63 6f 6e 66 69 67 20 22 69 74 fault config "it
14d10 65 6d 73 74 61 62 6c 65 22 20 23 66 29 29 29 20 emstable" #f)))
14d20 0a 09 09 09 09 09 09 20 20 20 3b 3b 20 69 66 20 ....... ;; if
14d30 65 69 74 68 65 72 20 69 74 65 6d 73 20 6f 72 20 either items or
14d40 69 74 65 6d 73 20 74 61 62 6c 65 20 69 73 20 61 items table is a
14d50 20 70 72 6f 63 20 72 65 74 75 72 6e 20 69 74 20 proc return it
14d60 73 6f 20 74 65 73 74 20 72 75 6e 6e 69 6e 67 0a so test running.
14d70 09 09 09 09 09 09 20 20 20 3b 3b 20 70 72 6f 63 ...... ;; proc
14d80 65 73 73 20 63 61 6e 20 6b 6e 6f 77 20 74 6f 20 ess can know to
14d90 63 61 6c 6c 20 69 74 65 6d 73 3a 67 65 74 2d 69 call items:get-i
14da0 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 tems-from-config
14db0 0a 09 09 09 09 09 09 20 20 20 3b 3b 20 69 66 20 ....... ;; if
14dc0 65 69 74 68 65 72 20 69 73 20 61 20 6c 69 73 74 either is a list
14dd0 20 61 6e 64 20 6e 6f 6e 65 20 69 73 20 61 20 70 and none is a p
14de0 72 6f 63 20 67 6f 20 61 68 65 61 64 20 61 6e 64 roc go ahead and
14df0 20 63 61 6c 6c 20 67 65 74 2d 69 74 65 6d 73 0a call get-items.
14e00 09 09 09 09 09 09 20 20 20 3b 3b 20 6f 74 68 65 ...... ;; othe
14e10 72 77 69 73 65 20 72 65 74 75 72 6e 20 23 66 20 rwise return #f
14e20 2d 20 74 68 69 73 20 69 73 20 6e 6f 74 20 61 6e - this is not an
14e30 20 69 74 65 72 61 74 65 64 20 74 65 73 74 0a 09 iterated test..
14e40 09 09 09 09 09 20 20 20 28 63 6f 6e 64 0a 09 09 ..... (cond...
14e50 09 09 09 09 20 20 20 20 28 28 70 72 6f 63 65 64 .... ((proced
14e60 75 72 65 3f 20 69 74 65 6d 73 29 20 20 20 20 20 ure? items)
14e70 20 0a 09 09 09 09 09 09 20 20 20 20 20 28 64 65 ....... (de
14e80 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 bug:print-info 4
14e90 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
14ea0 72 74 2a 20 22 69 74 65 6d 73 20 69 73 20 61 20 rt* "items is a
14eb0 70 72 6f 63 65 64 75 72 65 2c 20 77 69 6c 6c 20 procedure, will
14ec0 63 61 6c 63 20 6c 61 74 65 72 22 29 0a 09 09 09 calc later")....
14ed0 09 09 09 20 20 20 20 20 69 74 65 6d 73 29 20 20 ... items)
14ee0 20 20 20 20 20 20 20 20 20 20 3b 3b 20 63 61 6c ;; cal
14ef0 63 20 6c 61 74 65 72 0a 09 09 09 09 09 09 20 20 c later.......
14f00 20 20 28 28 70 72 6f 63 65 64 75 72 65 3f 20 69 ((procedure? i
14f10 74 65 6d 73 74 61 62 6c 65 29 0a 09 09 09 09 09 temstable)......
14f20 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 . (debug:pri
14f30 6e 74 2d 69 6e 66 6f 20 34 20 2a 64 65 66 61 75 nt-info 4 *defau
14f40 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 69 74 lt-log-port* "it
14f50 65 6d 73 74 61 62 6c 65 20 69 73 20 61 20 70 72 emstable is a pr
14f60 6f 63 65 64 75 72 65 2c 20 77 69 6c 6c 20 63 61 ocedure, will ca
14f70 6c 63 20 6c 61 74 65 72 22 29 0a 09 09 09 09 09 lc later")......
14f80 09 20 20 20 20 20 69 74 65 6d 73 74 61 62 6c 65 . itemstable
14f90 29 20 20 20 20 20 20 20 3b 3b 20 63 61 6c 63 20 ) ;; calc
14fa0 6c 61 74 65 72 0a 09 09 09 09 09 09 20 20 20 20 later.......
14fb0 28 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 ((filter (lambda
14fc0 20 28 78 29 0a 09 09 09 09 09 09 09 20 20 20 20 (x)........
14fd0 20 20 20 28 6c 65 74 20 28 28 76 61 6c 20 28 63 (let ((val (c
14fe0 61 72 20 78 29 29 29 0a 09 09 09 09 09 09 09 09 ar x))).........
14ff0 20 28 69 66 20 28 70 72 6f 63 65 64 75 72 65 3f (if (procedure?
15000 20 76 61 6c 29 20 76 61 6c 20 23 66 29 29 29 0a val) val #f))).
15010 09 09 09 09 09 09 09 20 20 20 20 20 28 61 70 70 ....... (app
15020 65 6e 64 20 28 69 66 20 28 6c 69 73 74 3f 20 69 end (if (list? i
15030 74 65 6d 73 29 20 69 74 65 6d 73 20 27 28 29 29 tems) items '())
15040 0a 09 09 09 09 09 09 09 09 20 20 20 20 20 28 69 ......... (i
15050 66 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 74 61 f (list? itemsta
15060 62 6c 65 29 20 69 74 65 6d 73 74 61 62 6c 65 20 ble) itemstable
15070 27 28 29 29 29 29 0a 09 09 09 09 09 09 20 20 20 '()))).......
15080 20 20 27 68 61 76 65 2d 70 72 6f 63 65 64 75 72 'have-procedur
15090 65 29 0a 09 09 09 09 09 09 20 20 20 20 28 28 6f e)....... ((o
150a0 72 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 28 r (list? items)(
150b0 6c 69 73 74 3f 20 69 74 65 6d 73 74 61 62 6c 65 list? itemstable
150c0 29 29 20 3b 3b 20 63 61 6c 63 20 6e 6f 77 0a 09 )) ;; calc now..
150d0 09 09 09 09 09 20 20 20 20 20 28 64 65 62 75 67 ..... (debug
150e0 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 2a 64 :print-info 4 *d
150f0 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
15100 20 22 69 74 65 6d 73 20 61 6e 64 20 69 74 65 6d "items and item
15110 73 74 61 62 6c 65 20 61 72 65 20 6c 69 73 74 73 stable are lists
15120 2c 20 63 61 6c 63 20 6e 6f 77 5c 6e 22 0a 09 09 , calc now\n"...
15130 09 09 09 09 09 09 20 20 20 20 20 20 20 22 20 20 ...... "
15140 20 20 69 74 65 6d 73 3a 20 22 20 69 74 65 6d 73 items: " items
15150 20 22 20 69 74 65 6d 73 74 61 62 6c 65 3a 20 22 " itemstable: "
15160 20 69 74 65 6d 73 74 61 62 6c 65 29 0a 09 09 09 itemstable)....
15170 09 09 09 20 20 20 20 20 28 69 74 65 6d 73 3a 67 ... (items:g
15180 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f et-items-from-co
15190 6e 66 69 67 20 63 6f 6e 66 69 67 29 29 0a 09 09 nfig config))...
151a0 09 09 09 09 20 20 20 20 28 65 6c 73 65 20 23 66 .... (else #f
151b0 29 29 29 20 20 20 20 20 20 20 20 20 20 20 20 20 )))
151c0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b ;;
151d0 20 6e 6f 74 20 69 74 65 72 61 74 65 64 0a 09 09 not iterated...
151e0 09 09 09 09 20 23 66 20 20 20 20 20 20 3b 3b 20 .... #f ;;
151f0 69 74 65 6d 73 64 61 74 20 35 0a 09 09 09 09 09 itemsdat 5......
15200 09 20 23 66 20 20 20 20 20 20 3b 3b 20 73 70 61 . #f ;; spa
15210 72 65 20 2d 20 75 73 65 64 20 66 6f 72 20 69 74 re - used for it
15220 65 6d 2d 70 61 74 68 0a 09 09 09 09 09 09 20 29 em-path....... )
15230 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
15240 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 09 09 (for-each ...
15250 20 28 6c 61 6d 62 64 61 20 28 77 61 69 74 6f 6e (lambda (waiton
15260 29 0a 09 09 20 20 20 28 69 66 20 28 61 6e 64 20 )... (if (and
15270 77 61 69 74 6f 6e 20 28 6e 6f 74 20 28 73 74 72 waiton (not (str
15280 69 6e 67 3d 20 22 23 66 22 20 77 61 69 74 6f 6e ing= "#f" waiton
15290 29 29 20 28 6e 6f 74 20 28 6d 65 6d 62 65 72 20 )) (not (member
152a0 77 61 69 74 6f 6e 20 74 65 73 74 2d 6e 61 6d 65 waiton test-name
152b0 73 29 29 29 0a 09 09 20 20 20 20 20 20 20 28 62 s)))... (b
152c0 65 67 69 6e 0a 09 09 09 20 28 73 65 74 21 20 72 egin.... (set! r
152d0 65 71 75 69 72 65 64 2d 74 65 73 74 73 20 28 63 equired-tests (c
152e0 6f 6e 73 20 77 61 69 74 6f 6e 20 72 65 71 75 69 ons waiton requi
152f0 72 65 64 2d 74 65 73 74 73 29 29 0a 09 09 09 20 red-tests))....
15300 28 73 65 74 21 20 74 65 73 74 2d 6e 61 6d 65 73 (set! test-names
15310 20 28 63 6f 6e 73 20 77 61 69 74 6f 6e 20 74 65 (cons waiton te
15320 73 74 2d 6e 61 6d 65 73 29 29 29 29 29 20 3b 3b st-names))))) ;;
15330 20 77 61 73 20 61 6e 20 61 70 70 65 6e 64 2c 20 was an append,
15340 6e 6f 77 20 61 20 63 6f 6e 73 0a 09 09 20 77 61 now a cons... wa
15350 69 74 6f 6e 73 29 0a 09 09 28 6c 65 74 20 28 28 itons)...(let ((
15360 72 65 6d 74 65 73 74 73 20 28 64 65 6c 65 74 65 remtests (delete
15370 2d 64 75 70 6c 69 63 61 74 65 73 20 28 61 70 70 -duplicates (app
15380 65 6e 64 20 77 61 69 74 6f 6e 73 20 74 61 6c 29 end waitons tal)
15390 29 29 29 0a 09 09 20 20 28 69 66 20 28 6e 6f 74 )))... (if (not
153a0 20 28 6e 75 6c 6c 3f 20 72 65 6d 74 65 73 74 73 (null? remtests
153b0 29 29 0a 09 09 20 20 20 20 20 20 28 6c 6f 6f 70 ))... (loop
153c0 20 28 63 61 72 20 72 65 6d 74 65 73 74 73 29 28 (car remtests)(
153d0 63 64 72 20 72 65 6d 74 65 73 74 73 29 29 0a 09 cdr remtests))..
153e0 09 20 20 20 20 20 20 74 65 73 74 2d 72 65 63 6f . test-reco
153f0 72 64 73 29 29 29 29 29 29 29 0a 20 20 20 20 20 rds))))))).
15400 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 (for-each.
15410 20 20 20 20 28 6c 61 6d 62 64 61 20 28 6d 69 73 (lambda (mis
15420 73 69 6e 67 2d 77 61 69 74 6f 6e 29 0a 20 20 20 sing-waiton).
15430 20 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a (debug:
15440 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 print-error 0 *d
15450 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
15460 20 22 6e 6f 6e 2d 65 78 69 73 74 65 6e 74 20 74 "non-existent t
15470 65 73 74 20 5c 22 22 20 6d 69 73 73 69 6e 67 2d est \"" missing-
15480 77 61 69 74 6f 6e 20 22 5c 22 20 69 73 20 61 20 waiton "\" is a
15490 77 61 69 74 6f 6e 20 66 6f 72 20 74 65 73 74 73 waiton for tests
154a0 20 22 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 " (hash-table-r
154b0 65 66 20 6d 69 73 73 69 6e 67 2d 77 61 69 74 6f ef missing-waito
154c0 6e 73 20 6d 69 73 73 69 6e 67 2d 77 61 69 74 6f ns missing-waito
154d0 6e 29 29 0a 20 20 20 20 20 20 20 20 20 29 0a 20 n)). ).
154e0 20 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 (hash-ta
154f0 62 6c 65 2d 6b 65 79 73 20 6d 69 73 73 69 6e 67 ble-keys missing
15500 2d 77 61 69 74 6f 6e 73 29 0a 20 20 20 20 20 20 -waitons).
15510 29 0a 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d ).))..;;========
15520 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15530 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15540 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15550 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
15560 3b 20 74 65 73 74 20 73 74 65 70 73 0a 3b 3b 3d ; test steps.;;=
15570 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15580 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15590 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
155a0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
155b0 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 74 65 73 74 73 74 =====..;; testst
155c0 65 70 2d 73 65 74 2d 73 74 61 74 75 73 21 20 75 ep-set-status! u
155d0 73 65 64 20 74 6f 20 62 65 20 68 65 72 65 0a 0a sed to be here..
155e0 28 64 65 66 69 6e 65 20 28 74 65 73 74 2d 67 65 (define (test-ge
155f0 74 2d 6b 69 6c 6c 2d 72 65 71 75 65 73 74 20 72 t-kill-request r
15600 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 20 3b un-id test-id) ;
15610 3b 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 ; run-id test-na
15620 6d 65 20 69 74 65 6d 64 61 74 29 0a 20 20 28 6c me itemdat). (l
15630 65 74 2a 20 28 28 74 65 73 74 64 61 74 20 20 20 et* ((testdat
15640 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 6e (rmt:get-test-in
15650 66 6f 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 fo-by-id run-id
15660 74 65 73 74 2d 69 64 29 29 29 0a 20 20 20 20 28 test-id))). (
15670 61 6e 64 20 74 65 73 74 64 61 74 0a 09 20 28 65 and testdat.. (e
15680 71 75 61 6c 3f 20 28 74 65 73 74 3a 67 65 74 2d qual? (test:get-
15690 73 74 61 74 65 20 74 65 73 74 64 61 74 29 20 22 state testdat) "
156a0 4b 49 4c 4c 52 45 51 22 29 29 29 29 0a 0a 28 64 KILLREQ"))))..(d
156b0 65 66 69 6e 65 20 28 74 65 73 74 3a 74 64 62 2d efine (test:tdb-
156c0 67 65 74 2d 72 75 6e 64 61 74 2d 63 6f 75 6e 74 get-rundat-count
156d0 20 74 64 62 29 0a 20 20 28 69 66 20 74 64 62 0a tdb). (if tdb.
156e0 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 (let ((res
156f0 20 30 29 29 0a 09 28 73 71 6c 69 74 65 33 3a 66 0))..(sqlite3:f
15700 6f 72 2d 65 61 63 68 2d 72 6f 77 0a 09 20 28 6c or-each-row.. (l
15710 61 6d 62 64 61 20 28 63 6f 75 6e 74 29 0a 09 20 ambda (count)..
15720 20 20 28 73 65 74 21 20 72 65 73 20 63 6f 75 6e (set! res coun
15730 74 29 29 0a 09 20 74 64 62 0a 09 20 22 53 45 4c t)).. tdb.. "SEL
15740 45 43 54 20 63 6f 75 6e 74 28 69 64 29 20 46 52 ECT count(id) FR
15750 4f 4d 20 74 65 73 74 5f 72 75 6e 64 61 74 3b 22 OM test_rundat;"
15760 29 0a 09 72 65 73 29 29 0a 20 20 30 29 0a 0a 28 )..res)). 0)..(
15770 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 75 70 define (tests:up
15780 64 61 74 65 2d 63 65 6e 74 72 61 6c 2d 6d 65 74 date-central-met
15790 61 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 20 74 65 a-info run-id te
157a0 73 74 2d 69 64 20 63 70 75 6c 6f 61 64 20 64 69 st-id cpuload di
157b0 73 6b 66 72 65 65 20 6d 69 6e 75 74 65 73 20 75 skfree minutes u
157c0 6e 61 6d 65 20 68 6f 73 74 6e 61 6d 65 29 0a 20 name hostname).
157d0 20 28 72 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 61 (rmt:general-ca
157e0 6c 6c 20 27 75 70 64 61 74 65 2d 74 65 73 74 2d ll 'update-test-
157f0 72 75 6e 64 61 74 20 72 75 6e 2d 69 64 20 74 65 rundat run-id te
15800 73 74 2d 69 64 20 28 63 75 72 72 65 6e 74 2d 73 st-id (current-s
15810 65 63 6f 6e 64 73 29 20 28 6f 72 20 63 70 75 6c econds) (or cpul
15820 6f 61 64 20 2d 31 29 28 6f 72 20 64 69 73 6b 66 oad -1)(or diskf
15830 72 65 65 20 2d 31 29 20 2d 31 20 28 6f 72 20 6d ree -1) -1 (or m
15840 69 6e 75 74 65 73 20 2d 31 29 29 0a 20 20 28 69 inutes -1)). (i
15850 66 20 28 61 6e 64 20 63 70 75 6c 6f 61 64 20 64 f (and cpuload d
15860 69 73 6b 66 72 65 65 29 0a 20 20 20 20 20 20 28 iskfree). (
15870 72 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 61 6c 6c rmt:general-call
15880 20 27 75 70 64 61 74 65 2d 63 70 75 6c 6f 61 64 'update-cpuload
15890 2d 64 69 73 6b 66 72 65 65 20 72 75 6e 2d 69 64 -diskfree run-id
158a0 20 63 70 75 6c 6f 61 64 20 64 69 73 6b 66 72 65 cpuload diskfre
158b0 65 20 74 65 73 74 2d 69 64 29 29 0a 20 20 28 69 e test-id)). (i
158c0 66 20 6d 69 6e 75 74 65 73 20 0a 20 20 20 20 20 f minutes .
158d0 20 28 72 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 61 (rmt:general-ca
158e0 6c 6c 20 27 75 70 64 61 74 65 2d 72 75 6e 2d 64 ll 'update-run-d
158f0 75 72 61 74 69 6f 6e 20 72 75 6e 2d 69 64 20 6d uration run-id m
15900 69 6e 75 74 65 73 20 74 65 73 74 2d 69 64 29 29 inutes test-id))
15910 0a 20 20 28 69 66 20 28 61 6e 64 20 75 6e 61 6d . (if (and unam
15920 65 20 68 6f 73 74 6e 61 6d 65 29 0a 20 20 20 20 e hostname).
15930 20 20 28 72 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 (rmt:general-c
15940 61 6c 6c 20 27 75 70 64 61 74 65 2d 75 6e 61 6d all 'update-unam
15950 65 2d 68 6f 73 74 20 72 75 6e 2d 69 64 20 75 6e e-host run-id un
15960 61 6d 65 20 68 6f 73 74 6e 61 6d 65 20 74 65 73 ame hostname tes
15970 74 2d 69 64 29 29 29 0a 20 20 0a 3b 3b 20 54 68 t-id))). .;; Th
15980 69 73 20 6f 6e 65 20 69 73 20 66 6f 72 20 72 75 is one is for ru
15990 6e 6e 69 6e 67 20 77 69 74 68 20 6e 6f 20 64 62 nning with no db
159a0 20 61 63 63 65 73 73 20 28 69 2e 65 2e 20 76 69 access (i.e. vi
159b0 61 20 72 6d 74 3a 20 69 6e 74 65 72 6e 61 6c 6c a rmt: internall
159c0 79 29 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 y).(define (test
159d0 73 3a 73 65 74 2d 66 75 6c 6c 2d 6d 65 74 61 2d s:set-full-meta-
159e0 69 6e 66 6f 20 64 62 20 74 65 73 74 2d 69 64 20 info db test-id
159f0 72 75 6e 2d 69 64 20 6d 69 6e 75 74 65 73 20 77 run-id minutes w
15a00 6f 72 6b 2d 61 72 65 61 20 72 65 6d 74 72 69 65 ork-area remtrie
15a10 73 29 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 74 s).;; (define (t
15a20 65 73 74 73 3a 73 65 74 2d 66 75 6c 6c 2d 6d 65 ests:set-full-me
15a30 74 61 2d 69 6e 66 6f 20 74 65 73 74 2d 69 64 20 ta-info test-id
15a40 72 75 6e 2d 69 64 20 6d 69 6e 75 74 65 73 20 77 run-id minutes w
15a50 6f 72 6b 2d 61 72 65 61 29 0a 3b 3b 20 20 28 6c ork-area).;; (l
15a60 65 74 20 28 28 72 65 6d 74 72 69 65 73 20 31 30 et ((remtries 10
15a70 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 63 70 75 )). (let* ((cpu
15a80 6c 6f 61 64 20 20 28 67 65 74 2d 63 70 75 2d 6c load (get-cpu-l
15a90 6f 61 64 29 29 0a 09 20 28 64 69 73 6b 66 72 65 oad)).. (diskfre
15aa0 65 20 28 67 65 74 2d 64 66 20 28 63 75 72 72 65 e (get-df (curre
15ab0 6e 74 2d 64 69 72 65 63 74 6f 72 79 29 29 29 0a nt-directory))).
15ac0 09 20 28 75 6e 61 6d 65 20 20 20 20 28 67 65 74 . (uname (get
15ad0 2d 75 6e 61 6d 65 20 22 2d 73 72 76 70 69 6f 22 -uname "-srvpio"
15ae0 29 29 0a 09 20 28 68 6f 73 74 6e 61 6d 65 20 28 )).. (hostname (
15af0 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 29 get-host-name)))
15b00 0a 20 20 20 20 28 74 65 73 74 73 3a 75 70 64 61 . (tests:upda
15b10 74 65 2d 63 65 6e 74 72 61 6c 2d 6d 65 74 61 2d te-central-meta-
15b20 69 6e 66 6f 20 72 75 6e 2d 69 64 20 74 65 73 74 info run-id test
15b30 2d 69 64 20 63 70 75 6c 6f 61 64 20 64 69 73 6b -id cpuload disk
15b40 66 72 65 65 20 6d 69 6e 75 74 65 73 20 75 6e 61 free minutes una
15b50 6d 65 20 68 6f 73 74 6e 61 6d 65 29 29 29 0a 20 me hostname))).
15b60 20 20 20 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 .;; (define (
15b70 74 65 73 74 73 3a 73 65 74 2d 70 61 72 74 69 61 tests:set-partia
15b80 6c 2d 6d 65 74 61 2d 69 6e 66 6f 20 74 65 73 74 l-meta-info test
15b90 2d 69 64 20 72 75 6e 2d 69 64 20 6d 69 6e 75 74 -id run-id minut
15ba0 65 73 20 77 6f 72 6b 2d 61 72 65 61 29 0a 23 3b es work-area).#;
15bb0 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 73 (define (tests:s
15bc0 65 74 2d 70 61 72 74 69 61 6c 2d 6d 65 74 61 2d et-partial-meta-
15bd0 69 6e 66 6f 20 74 65 73 74 2d 69 64 20 72 75 6e info test-id run
15be0 2d 69 64 20 6d 69 6e 75 74 65 73 20 77 6f 72 6b -id minutes work
15bf0 2d 61 72 65 61 20 72 65 6d 74 72 69 65 73 29 0a -area remtries).
15c00 20 20 28 6c 65 74 2a 20 28 28 63 70 75 6c 6f 61 (let* ((cpuloa
15c10 64 20 20 28 67 65 74 2d 63 70 75 2d 6c 6f 61 64 d (get-cpu-load
15c20 29 29 0a 09 20 28 64 69 73 6b 66 72 65 65 20 28 )).. (diskfree (
15c30 67 65 74 2d 64 66 20 28 63 75 72 72 65 6e 74 2d get-df (current-
15c40 64 69 72 65 63 74 6f 72 79 29 29 29 0a 09 20 28 directory))).. (
15c50 72 65 6d 74 72 69 65 73 20 31 30 29 29 0a 20 20 remtries 10)).
15c60 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 (handle-except
15c70 69 6f 6e 73 0a 20 20 20 20 20 65 78 6e 0a 20 20 ions. exn.
15c80 20 20 20 28 69 66 20 28 3e 20 72 65 6d 74 72 69 (if (> remtri
15c90 65 73 20 30 29 0a 09 20 28 62 65 67 69 6e 0a 09 es 0).. (begin..
15ca0 20 20 20 28 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 (print-call-c
15cb0 68 61 69 6e 20 28 63 75 72 72 65 6e 74 2d 65 72 hain (current-er
15cc0 72 6f 72 2d 70 6f 72 74 29 29 0a 09 20 20 20 28 ror-port)).. (
15cd0 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
15ce0 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
15cf0 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 port* "WARNING:
15d00 66 61 69 6c 65 64 20 74 6f 20 73 65 74 20 6d 65 failed to set me
15d10 74 61 20 69 6e 66 6f 2e 20 57 69 6c 6c 20 74 72 ta info. Will tr
15d20 79 20 22 20 72 65 6d 74 72 69 65 73 20 22 20 6d y " remtries " m
15d30 6f 72 65 20 74 69 6d 65 73 22 29 0a 09 20 20 20 ore times")..
15d40 28 73 65 74 21 20 72 65 6d 74 72 69 65 73 20 28 (set! remtries (
15d50 2d 20 72 65 6d 74 72 69 65 73 20 31 29 29 0a 09 - remtries 1))..
15d60 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 (thread-sleep
15d70 21 20 31 30 29 0a 09 20 20 20 28 74 65 73 74 73 ! 10).. (tests
15d80 3a 73 65 74 2d 66 75 6c 6c 2d 6d 65 74 61 2d 69 :set-full-meta-i
15d90 6e 66 6f 20 64 62 20 74 65 73 74 2d 69 64 20 72 nfo db test-id r
15da0 75 6e 2d 69 64 20 6d 69 6e 75 74 65 73 20 77 6f un-id minutes wo
15db0 72 6b 2d 61 72 65 61 20 28 2d 20 72 65 6d 74 72 rk-area (- remtr
15dc0 69 65 73 20 31 29 29 29 0a 09 20 28 6c 65 74 20 ies 1))).. (let
15dd0 28 28 65 72 72 2d 73 74 61 74 75 73 20 28 28 63 ((err-status ((c
15de0 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 ondition-propert
15df0 79 2d 61 63 63 65 73 73 6f 72 20 27 73 71 6c 69 y-accessor 'sqli
15e00 74 65 33 20 27 73 74 61 74 75 73 20 23 66 29 20 te3 'status #f)
15e10 65 78 6e 29 29 29 0a 09 20 20 20 28 64 65 62 75 exn))).. (debu
15e20 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 g:print-error 0
15e30 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
15e40 74 2a 20 22 74 72 69 65 64 20 66 6f 72 20 6f 76 t* "tried for ov
15e50 65 72 20 61 20 6d 69 6e 75 74 65 20 74 6f 20 75 er a minute to u
15e60 70 64 61 74 65 20 6d 65 74 61 20 69 6e 66 6f 20 pdate meta info
15e70 61 6e 64 20 66 61 69 6c 65 64 2e 20 47 69 76 69 and failed. Givi
15e80 6e 67 20 75 70 22 29 0a 09 20 20 20 28 64 65 62 ng up").. (deb
15e90 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
15ea0 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 ult-log-port* "E
15eb0 58 43 45 50 54 49 4f 4e 3a 20 64 61 74 61 62 61 XCEPTION: databa
15ec0 73 65 20 70 72 6f 62 61 62 6c 79 20 6f 76 65 72 se probably over
15ed0 6c 6f 61 64 65 64 20 6f 72 20 75 6e 72 65 61 64 loaded or unread
15ee0 61 62 6c 65 2e 22 29 0a 09 20 20 20 28 64 65 62 able.").. (deb
15ef0 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
15f00 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 ult-log-port* "
15f10 6d 65 73 73 61 67 65 3a 20 22 20 28 28 63 6f 6e message: " ((con
15f20 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d dition-property-
15f30 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d accessor 'exn 'm
15f40 65 73 73 61 67 65 29 20 65 78 6e 29 29 0a 09 20 essage) exn))..
15f50 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 35 (debug:print 5
15f60 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
15f70 72 74 2a 20 22 65 78 6e 3d 22 20 28 63 6f 6e 64 rt* "exn=" (cond
15f80 69 74 69 6f 6e 2d 3e 6c 69 73 74 20 65 78 6e 29 ition->list exn)
15f90 29 0a 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 ).. (debug:pri
15fa0 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
15fb0 67 2d 70 6f 72 74 2a 20 22 20 73 74 61 74 75 73 g-port* " status
15fc0 3a 20 20 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e : " ((condition
15fd0 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 -property-access
15fe0 6f 72 20 27 73 71 6c 69 74 65 33 20 27 73 74 61 or 'sqlite3 'sta
15ff0 74 75 73 29 20 65 78 6e 29 29 0a 09 20 20 20 28 tus) exn)).. (
16000 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e print-call-chain
16010 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d (current-error-
16020 70 6f 72 74 29 29 29 29 0a 20 20 20 20 20 28 74 port)))). (t
16030 65 73 74 73 3a 75 70 64 61 74 65 2d 74 65 73 74 ests:update-test
16040 64 61 74 2d 6d 65 74 61 2d 69 6e 66 6f 20 64 62 dat-meta-info db
16050 20 74 65 73 74 2d 69 64 20 77 6f 72 6b 2d 61 72 test-id work-ar
16060 65 61 20 63 70 75 6c 6f 61 64 20 64 69 73 6b 66 ea cpuload diskf
16070 72 65 65 20 6d 69 6e 75 74 65 73 29 0a 20 20 29 ree minutes). )
16080 29 29 0a 09 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d )).. .;;========
16090 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
160a0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
160b0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
160c0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
160d0 3b 20 41 20 52 20 43 20 48 20 49 20 56 20 49 20 ; A R C H I V I
160e0 4e 20 47 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d N G.;;==========
160f0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
16100 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
16110 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
16120 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 ============..(d
16130 65 66 69 6e 65 20 28 74 65 73 74 3a 61 72 63 68 efine (test:arch
16140 69 76 65 20 64 62 20 74 65 73 74 2d 69 64 29 0a ive db test-id).
16150 20 20 23 66 29 0a 0a 28 64 65 66 69 6e 65 20 28 #f)..(define (
16160 74 65 73 74 3a 61 72 63 68 69 76 65 2d 74 65 73 test:archive-tes
16170 74 73 20 64 62 20 6b 65 79 6e 61 6d 65 73 20 74 ts db keynames t
16180 61 72 67 65 74 29 0a 20 20 23 66 29 0a 0a arget). #f)..