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 28 64 65 ses common)).(de
04a0: 63 6c 61 72 65 20 28 75 73 65 73 20 63 6f 6d 6d clare (uses comm
04b0: 6f 6e 6d 6f 64 29 29 0a 3b 3b 20 28 64 65 63 6c onmod)).;; (decl
04c0: 61 72 65 20 28 75 73 65 73 20 64 63 6f 6d 6d 6f are (uses dcommo
04d0: 6e 29 29 20 3b 3b 20 6e 65 65 64 65 64 20 66 6f n)) ;; needed fo
04e0: 72 20 74 68 65 20 73 74 65 70 73 20 70 72 6f 63 r the steps proc
04f0: 65 73 73 69 6e 67 0a 28 64 65 63 6c 61 72 65 20 essing.(declare
0500: 28 75 73 65 73 20 69 74 65 6d 73 29 29 0a 28 64 (uses items)).(d
0510: 65 63 6c 61 72 65 20 28 75 73 65 73 20 72 75 6e eclare (uses run
0520: 63 6f 6e 66 69 67 29 29 0a 3b 3b 20 28 64 65 63 config)).;; (dec
0530: 6c 61 72 65 20 28 75 73 65 73 20 73 64 62 29 29 lare (uses sdb))
0540: 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 .(declare (uses
0550: 73 65 72 76 65 72 29 29 0a 3b 3b 28 64 65 63 6c server)).;;(decl
0560: 61 72 65 20 28 75 73 65 73 20 73 74 6d 6c 32 29 are (uses stml2)
0570: 29 0a 0a 28 75 73 65 20 73 71 6c 69 74 65 33 20 )..(use sqlite3
0580: 73 72 66 69 2d 31 20 70 6f 73 69 78 20 72 65 67 srfi-1 posix reg
0590: 65 78 20 72 65 67 65 78 2d 63 61 73 65 20 73 72 ex regex-case sr
05a0: 66 69 2d 36 39 20 64 6f 74 2d 6c 6f 63 6b 69 6e fi-69 dot-lockin
05b0: 67 20 74 63 70 20 64 69 72 65 63 74 6f 72 79 2d g tcp directory-
05c0: 75 74 69 6c 73 29 0a 28 69 6d 70 6f 72 74 20 28 utils).(import (
05d0: 70 72 65 66 69 78 20 73 71 6c 69 74 65 33 20 73 prefix sqlite3 s
05e0: 71 6c 69 74 65 33 3a 29 29 0a 28 69 6d 70 6f 72 qlite3:)).(impor
05f0: 74 20 63 6f 6d 6d 6f 6e 6d 6f 64 29 0a 28 72 65 t commonmod).(re
0600: 71 75 69 72 65 2d 6c 69 62 72 61 72 79 20 73 74 quire-library st
0610: 6d 6c 29 0a 0a 28 69 6e 63 6c 75 64 65 20 22 63 ml)..(include "c
0620: 6f 6d 6d 6f 6e 5f 72 65 63 6f 72 64 73 2e 73 63 ommon_records.sc
0630: 6d 22 29 0a 28 69 6e 63 6c 75 64 65 20 22 6b 65 m").(include "ke
0640: 79 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a y_records.scm").
0650: 28 69 6e 63 6c 75 64 65 20 22 64 62 5f 72 65 63 (include "db_rec
0660: 6f 72 64 73 2e 73 63 6d 22 29 0a 28 69 6e 63 6c ords.scm").(incl
0670: 75 64 65 20 22 72 75 6e 5f 72 65 63 6f 72 64 73 ude "run_records
0680: 2e 73 63 6d 22 29 0a 28 69 6e 63 6c 75 64 65 20 .scm").(include
0690: 22 74 65 73 74 5f 72 65 63 6f 72 64 73 2e 73 63 "test_records.sc
06a0: 6d 22 29 0a 28 69 6e 63 6c 75 64 65 20 22 6a 73 m").(include "js
06b0: 2d 70 61 74 68 2e 73 63 6d 22 29 0a 0a 28 64 65 -path.scm")..(de
06c0: 66 69 6e 65 20 28 69 6e 69 74 2d 6a 61 76 61 2d fine (init-java-
06d0: 73 63 72 69 70 74 2d 6c 69 62 29 0a 20 20 28 73 script-lib). (s
06e0: 65 74 21 20 2a 6a 61 76 61 2d 73 63 72 69 70 74 et! *java-script
06f0: 2d 6c 69 62 2a 20 28 63 6f 6e 63 20 20 28 63 6f -lib* (conc (co
0700: 6d 6d 6f 6e 3a 67 65 74 2d 69 6e 73 74 61 6c 6c mmon:get-install
0710: 2d 61 72 65 61 29 20 22 2f 73 68 61 72 65 2f 6a -area) "/share/j
0720: 73 2f 6a 71 75 65 72 79 2d 33 2e 31 2e 30 2e 73 s/jquery-3.1.0.s
0730: 6c 69 6d 2e 6d 69 6e 2e 6a 73 22 29 29 0a 20 20 lim.min.js")).
0740: 29 0a 0a 3b 3b 20 43 61 6c 6c 20 74 68 69 73 20 )..;; Call this
0750: 6f 6e 65 20 74 6f 20 64 6f 20 61 6c 6c 20 74 68 one to do all th
0760: 65 20 77 6f 72 6b 20 61 6e 64 20 67 65 74 20 61 e work and get a
0770: 20 73 74 61 6e 64 61 72 64 69 7a 65 64 20 6c 69 standardized li
0780: 73 74 20 6f 66 20 74 65 73 74 73 0a 3b 3b 20 20 st of tests.;;
0790: 20 67 65 74 73 20 70 61 74 68 73 20 66 72 6f 6d gets paths from
07a0: 20 63 6f 6e 66 69 67 73 20 61 6e 64 20 66 69 6e configs and fin
07b0: 64 73 20 76 61 6c 69 64 20 74 65 73 74 73 20 0a ds valid tests .
07c0: 3b 3b 20 20 20 72 65 74 75 72 6e 73 20 68 61 73 ;; returns has
07d0: 68 20 6f 66 20 74 65 73 74 6e 61 6d 65 20 2d 2d h of testname --
07e0: 3e 20 66 75 6c 6c 70 61 74 68 0a 3b 3b 0a 28 64 > fullpath.;;.(d
07f0: 65 66 69 6e 65 20 28 74 65 73 74 73 3a 67 65 74 efine (tests:get
0800: 2d 61 6c 6c 29 0a 20 20 28 6c 65 74 2a 20 28 28 -all). (let* ((
0810: 74 65 73 74 2d 73 65 61 72 63 68 2d 70 61 74 68 test-search-path
0820: 20 20 20 28 74 65 73 74 73 3a 67 65 74 2d 74 65 (tests:get-te
0830: 73 74 73 2d 73 65 61 72 63 68 2d 70 61 74 68 20 sts-search-path
0840: 2a 63 6f 6e 66 69 67 64 61 74 2a 29 29 29 0a 20 *configdat*))).
0850: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
0860: 38 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 8 *default-log-p
0870: 6f 72 74 2a 20 22 74 65 73 74 2d 73 65 61 72 63 ort* "test-searc
0880: 68 2d 70 61 74 68 3a 20 22 20 74 65 73 74 2d 73 h-path: " test-s
0890: 65 61 72 63 68 2d 70 61 74 68 29 0a 20 20 20 20 earch-path).
08a0: 28 74 65 73 74 73 3a 67 65 74 2d 76 61 6c 69 64 (tests:get-valid
08b0: 2d 74 65 73 74 73 20 28 6d 61 6b 65 2d 68 61 73 -tests (make-has
08c0: 68 2d 74 61 62 6c 65 29 20 74 65 73 74 2d 73 65 h-table) test-se
08d0: 61 72 63 68 2d 70 61 74 68 29 29 29 0a 0a 28 64 arch-path)))..(d
08e0: 65 66 69 6e 65 20 28 74 65 73 74 73 3a 67 65 74 efine (tests:get
08f0: 2d 74 65 73 74 73 2d 73 65 61 72 63 68 2d 70 61 -tests-search-pa
0900: 74 68 20 63 66 67 64 61 74 29 0a 20 20 28 6c 65 th cfgdat). (le
0910: 74 20 28 28 70 61 74 68 73 20 28 6c 65 74 20 28 t ((paths (let (
0920: 28 73 65 63 74 69 6f 6e 20 28 69 66 20 63 66 67 (section (if cfg
0930: 64 61 74 0a 09 09 09 09 20 20 28 63 6f 6e 66 69 dat..... (confi
0940: 67 66 3a 67 65 74 2d 73 65 63 74 69 6f 6e 20 63 gf:get-section c
0950: 66 67 64 61 74 20 22 74 65 73 74 73 2d 70 61 74 fgdat "tests-pat
0960: 68 73 22 29 0a 09 09 09 09 20 20 23 66 29 29 29 hs")..... #f)))
0970: 0a 09 09 20 28 69 66 20 73 65 63 74 69 6f 6e 0a ... (if section.
0980: 09 09 20 20 20 20 20 28 6d 61 70 20 63 61 64 72 .. (map cadr
0990: 20 73 65 63 74 69 6f 6e 29 0a 09 09 20 20 20 20 section)...
09a0: 20 27 28 29 29 29 29 29 0a 20 20 20 20 28 66 69 '())))). (fi
09b0: 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 64 29 lter (lambda (d)
09c0: 0a 09 20 20 20 20 20 20 28 69 66 20 28 64 69 72 .. (if (dir
09d0: 65 63 74 6f 72 79 2d 65 78 69 73 74 73 3f 20 64 ectory-exists? d
09e0: 29 0a 09 09 20 20 64 0a 09 09 20 20 28 62 65 67 )... d... (beg
09f0: 69 6e 0a 09 09 20 20 20 20 3b 3b 20 28 69 66 20 in... ;; (if
0a00: 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 (common:low-nois
0a10: 65 2d 70 72 69 6e 74 20 36 30 20 22 74 65 73 74 e-print 60 "test
0a20: 73 3a 67 65 74 2d 74 65 73 74 73 2d 73 65 61 72 s:get-tests-sear
0a30: 63 68 2d 70 61 74 68 22 20 64 29 0a 09 09 20 20 ch-path" d)...
0a40: 20 20 3b 3b 09 28 64 65 62 75 67 3a 70 72 69 6e ;;.(debug:prin
0a50: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
0a60: 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a -port* "WARNING:
0a70: 20 70 72 6f 62 6c 65 6d 20 77 69 74 68 20 64 69 problem with di
0a80: 72 65 63 74 6f 72 79 20 22 20 64 20 22 2c 20 64 rectory " d ", d
0a90: 72 6f 70 70 69 6e 67 20 69 74 20 66 72 6f 6d 20 ropping it from
0aa0: 74 65 73 74 73 20 70 61 74 68 22 29 29 0a 09 09 tests path"))...
0ab0: 20 20 20 20 23 66 29 29 29 0a 09 20 20 20 20 28 #f))).. (
0ac0: 61 70 70 65 6e 64 20 70 61 74 68 73 20 28 6c 69 append paths (li
0ad0: 73 74 20 28 63 6f 6e 63 20 2a 74 6f 70 70 61 74 st (conc *toppat
0ae0: 68 2a 20 22 2f 74 65 73 74 73 22 29 29 29 29 29 h* "/tests")))))
0af0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 )..(define (test
0b00: 73 3a 67 65 74 2d 76 61 6c 69 64 2d 74 65 73 74 s:get-valid-test
0b10: 73 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 s test-registry
0b20: 74 65 73 74 73 2d 70 61 74 68 73 29 0a 20 20 28 tests-paths). (
0b30: 69 66 20 28 6e 75 6c 6c 3f 20 74 65 73 74 73 2d if (null? tests-
0b40: 70 61 74 68 73 29 20 0a 20 20 20 20 20 20 74 65 paths) . te
0b50: 73 74 2d 72 65 67 69 73 74 72 79 0a 20 20 20 20 st-registry.
0b60: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 (let loop ((he
0b70: 64 20 28 63 61 72 20 74 65 73 74 73 2d 70 61 74 d (car tests-pat
0b80: 68 73 29 29 0a 09 09 20 28 74 61 6c 20 28 63 64 hs))... (tal (cd
0b90: 72 20 74 65 73 74 73 2d 70 61 74 68 73 29 29 29 r tests-paths)))
0ba0: 0a 09 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 66 69 ..(if (common:fi
0bb0: 6c 65 2d 65 78 69 73 74 73 3f 20 68 65 64 29 0a le-exists? hed).
0bc0: 09 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 . (for-each (
0bd0: 6c 61 6d 62 64 61 20 28 74 65 73 74 2d 70 61 74 lambda (test-pat
0be0: 68 29 0a 09 09 09 28 6c 65 74 2a 20 28 28 74 6e h)....(let* ((tn
0bf0: 61 6d 65 20 20 20 28 6c 61 73 74 20 28 73 74 72 ame (last (str
0c00: 69 6e 67 2d 73 70 6c 69 74 20 74 65 73 74 2d 70 ing-split test-p
0c10: 61 74 68 20 22 2f 22 29 29 29 0a 09 09 09 20 20 ath "/")))....
0c20: 20 20 20 20 20 28 74 63 6f 6e 66 69 67 20 28 63 (tconfig (c
0c30: 6f 6e 63 20 74 65 73 74 2d 70 61 74 68 20 22 2f onc test-path "/
0c40: 74 65 73 74 63 6f 6e 66 69 67 22 29 29 29 0a 09 testconfig")))..
0c50: 09 09 20 20 28 69 66 20 28 61 6e 64 20 28 6e 6f .. (if (and (no
0c60: 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 t (hash-table-re
0c70: 66 2f 64 65 66 61 75 6c 74 20 74 65 73 74 2d 72 f/default test-r
0c80: 65 67 69 73 74 72 79 20 74 6e 61 6d 65 20 23 66 egistry tname #f
0c90: 29 29 0a 09 09 09 09 20 20 20 28 63 6f 6d 6d 6f ))..... (commo
0ca0: 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 74 n:file-exists? t
0cb0: 63 6f 6e 66 69 67 29 29 0a 09 09 09 20 20 20 20 config))....
0cc0: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
0cd0: 74 21 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 t! test-registry
0ce0: 20 74 6e 61 6d 65 20 74 65 73 74 2d 70 61 74 68 tname test-path
0cf0: 29 29 29 29 0a 09 09 20 20 20 20 20 20 28 67 6c ))))... (gl
0d00: 6f 62 20 28 63 6f 6e 63 20 68 65 64 20 22 2f 2a ob (conc hed "/*
0d10: 22 29 29 29 29 0a 09 28 69 66 20 28 6e 75 6c 6c "))))..(if (null
0d20: 3f 20 74 61 6c 29 0a 09 20 20 20 20 74 65 73 74 ? tal).. test
0d30: 2d 72 65 67 69 73 74 72 79 0a 09 20 20 20 20 28 -registry.. (
0d40: 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 loop (car tal)(c
0d50: 64 72 20 74 61 6c 29 29 29 29 29 29 0a 0a 28 64 dr tal))))))..(d
0d60: 65 66 69 6e 65 20 28 74 65 73 74 73 3a 66 69 6c efine (tests:fil
0d70: 74 65 72 2d 74 65 73 74 2d 6e 61 6d 65 73 2d 6e ter-test-names-n
0d80: 6f 74 2d 6d 61 74 63 68 65 64 20 74 65 73 74 2d ot-matched test-
0d90: 6e 61 6d 65 73 20 74 65 73 74 2d 70 61 74 74 73 names test-patts
0da0: 29 0a 20 20 28 64 65 6c 65 74 65 2d 64 75 70 6c ). (delete-dupl
0db0: 69 63 61 74 65 73 0a 20 20 20 28 66 69 6c 74 65 icates. (filte
0dc0: 72 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 6e r (lambda (testn
0dd0: 61 6d 65 29 0a 09 20 20 20 20 20 28 6e 6f 74 20 ame).. (not
0de0: 28 74 65 73 74 73 3a 6d 61 74 63 68 20 74 65 73 (tests:match tes
0df0: 74 2d 70 61 74 74 73 20 74 65 73 74 6e 61 6d 65 t-patts testname
0e00: 20 23 66 29 29 29 0a 09 20 20 20 74 65 73 74 2d #f))).. test-
0e10: 6e 61 6d 65 73 29 29 29 0a 0a 0a 28 64 65 66 69 names)))...(defi
0e20: 6e 65 20 28 74 65 73 74 73 3a 66 69 6c 74 65 72 ne (tests:filter
0e30: 2d 74 65 73 74 2d 6e 61 6d 65 73 20 74 65 73 74 -test-names test
0e40: 2d 6e 61 6d 65 73 20 74 65 73 74 2d 70 61 74 74 -names test-patt
0e50: 73 29 0a 20 20 28 64 65 6c 65 74 65 2d 64 75 70 s). (delete-dup
0e60: 6c 69 63 61 74 65 73 0a 20 20 20 28 66 69 6c 74 licates. (filt
0e70: 65 72 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 er (lambda (test
0e80: 6e 61 6d 65 29 0a 09 20 20 20 20 20 28 74 65 73 name).. (tes
0e90: 74 73 3a 6d 61 74 63 68 20 74 65 73 74 2d 70 61 ts:match test-pa
0ea0: 74 74 73 20 74 65 73 74 6e 61 6d 65 20 23 66 29 tts testname #f)
0eb0: 29 0a 09 20 20 20 74 65 73 74 2d 6e 61 6d 65 73 ).. test-names
0ec0: 29 29 29 0a 0a 3b 3b 20 69 74 65 6d 6d 61 70 20 )))..;; itemmap
0ed0: 69 73 20 61 20 6c 69 73 74 20 6f 66 20 74 65 73 is a list of tes
0ee0: 74 6e 61 6d 65 20 70 61 74 74 65 72 6e 73 20 74 tname patterns t
0ef0: 6f 20 6d 61 70 73 0a 3b 3b 20 20 20 20 20 74 65 o maps.;; te
0f00: 73 74 31 20 2e 2a 2f 62 61 72 2f 28 5c 64 2b 29 st1 .*/bar/(\d+)
0f10: 20 66 6f 6f 2f 5c 31 0a 3b 3b 20 20 20 20 20 25 foo/\1.;; %
0f20: 20 20 20 20 20 66 6f 6f 2f 28 5b 5e 2f 5d 2b 29 foo/([^/]+)
0f30: 20 20 5c 31 2f 62 61 72 0a 3b 3b 0a 3b 3b 20 23 \1/bar.;;.;; #
0f40: 20 4e 4f 54 45 3a 20 74 68 65 20 6c 69 6e 65 20 NOTE: the line
0f50: 77 69 74 68 20 74 68 65 20 73 69 6e 67 6c 65 20 with the single
0f60: 25 20 63 6f 75 6c 64 20 62 65 20 74 68 65 20 72 % could be the r
0f70: 65 73 75 6c 74 20 6f 66 0a 3b 3b 20 23 20 20 20 esult of.;; #
0f80: 20 20 20 20 69 74 65 6d 6d 61 70 20 65 6e 74 72 itemmap entr
0f90: 79 20 69 6e 20 72 65 71 75 69 72 65 6d 65 6e 74 y in requirement
0fa0: 73 20 28 6c 65 67 61 63 79 29 2e 20 54 68 65 20 s (legacy). The
0fb0: 69 74 65 6d 6d 61 70 0a 3b 3b 20 23 20 20 20 20 itemmap.;; #
0fc0: 20 20 20 72 65 71 75 69 72 65 6d 65 6e 74 73 20 requirements
0fd0: 65 6e 74 72 79 20 69 73 20 64 65 70 72 65 63 61 entry is depreca
0fe0: 74 65 64 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 ted.;;.(define (
0ff0: 74 65 73 74 73 3a 67 65 74 2d 69 74 65 6d 6d 61 tests:get-itemma
1000: 70 73 20 74 63 6f 6e 66 69 67 29 0a 20 20 28 6c ps tconfig). (l
1010: 65 74 20 28 28 62 61 73 65 2d 69 74 65 6d 6d 61 et ((base-itemma
1020: 70 20 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b p (configf:look
1030: 75 70 20 74 63 6f 6e 66 69 67 20 22 72 65 71 75 up tconfig "requ
1040: 69 72 65 6d 65 6e 74 73 22 20 22 69 74 65 6d 6d irements" "itemm
1050: 61 70 22 29 29 0a 09 28 69 74 65 6d 6d 61 70 2d ap"))..(itemmap-
1060: 74 61 62 6c 65 20 28 63 6f 6e 66 69 67 66 3a 67 table (configf:g
1070: 65 74 2d 73 65 63 74 69 6f 6e 20 74 63 6f 6e 66 et-section tconf
1080: 69 67 20 22 69 74 65 6d 6d 61 70 22 29 29 29 0a ig "itemmap"))).
1090: 20 20 20 20 28 61 70 70 65 6e 64 20 28 69 66 20 (append (if
10a0: 62 61 73 65 2d 69 74 65 6d 6d 61 70 0a 09 09 28 base-itemmap...(
10b0: 6c 69 73 74 20 28 6c 69 73 74 20 22 25 22 20 62 list (list "%" b
10c0: 61 73 65 2d 69 74 65 6d 6d 61 70 29 29 0a 09 09 ase-itemmap))...
10d0: 27 28 29 29 0a 09 20 20 20 20 28 69 66 20 69 74 '()).. (if it
10e0: 65 6d 6d 61 70 2d 74 61 62 6c 65 0a 09 09 69 74 emmap-table...it
10f0: 65 6d 6d 61 70 2d 74 61 62 6c 65 0a 09 09 27 28 emmap-table...'(
1100: 29 29 29 29 29 0a 0a 3b 3b 20 67 69 76 65 6e 20 )))))..;; given
1110: 61 20 6c 69 73 74 20 6f 66 20 69 74 65 6d 6d 61 a list of itemma
1120: 70 73 20 28 74 65 73 74 6e 61 6d 65 20 2e 20 6d ps (testname . m
1130: 61 70 29 2c 20 72 65 74 75 72 6e 20 74 68 65 20 ap), return the
1140: 66 69 72 73 74 20 6d 61 74 63 68 0a 3b 3b 0a 28 first match.;;.(
1150: 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 6c 6f define (tests:lo
1160: 6f 6b 75 70 2d 69 74 65 6d 6d 61 70 20 69 74 65 okup-itemmap ite
1170: 6d 6d 61 70 73 20 74 65 73 74 6e 61 6d 65 29 0a mmaps testname).
1180: 20 20 28 6c 65 74 20 28 28 62 65 73 74 2d 6d 61 (let ((best-ma
1190: 74 63 68 65 73 20 28 66 69 6c 74 65 72 20 28 6c tches (filter (l
11a0: 61 6d 62 64 61 20 28 69 74 65 6d 6d 61 70 29 0a ambda (itemmap).
11b0: 09 09 09 09 28 74 65 73 74 73 3a 6d 61 74 63 68 ....(tests:match
11c0: 20 28 63 61 72 20 69 74 65 6d 6d 61 70 29 20 74 (car itemmap) t
11d0: 65 73 74 6e 61 6d 65 20 23 66 29 29 0a 09 09 09 estname #f))....
11e0: 20 20 20 20 20 20 69 74 65 6d 6d 61 70 73 29 29 itemmaps))
11f0: 29 0a 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f ). (if (null?
1200: 20 62 65 73 74 2d 6d 61 74 63 68 65 73 29 0a 09 best-matches)..
1210: 23 66 0a 09 28 6c 65 74 20 28 28 72 65 73 20 28 #f..(let ((res (
1220: 63 61 72 20 62 65 73 74 2d 6d 61 74 63 68 65 73 car best-matches
1230: 29 29 29 0a 09 20 20 3b 3b 20 28 64 65 62 75 67 ))).. ;; (debug
1240: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
1250: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 65 73 t-log-port* "res
1260: 3d 22 20 72 65 73 29 0a 09 20 20 28 63 6f 6e 64 =" res).. (cond
1270: 0a 09 20 20 20 28 28 73 74 72 69 6e 67 3f 20 72 .. ((string? r
1280: 65 73 29 20 72 65 73 29 20 3b 3b 3b 20 46 49 58 es) res) ;;; FIX
1290: 20 54 48 45 20 52 4f 4f 54 20 43 41 55 53 45 20 THE ROOT CAUSE
12a0: 48 45 52 45 20 2e 2e 2e 2e 0a 09 20 20 20 28 28 HERE ...... ((
12b0: 6e 75 6c 6c 3f 20 72 65 73 29 20 20 20 23 66 29 null? res) #f)
12c0: 0a 09 20 20 20 28 28 73 74 72 69 6e 67 3f 20 28 .. ((string? (
12d0: 63 64 72 20 72 65 73 29 29 20 28 63 64 72 20 72 cdr res)) (cdr r
12e0: 65 73 29 29 20 20 3b 3b 20 69 74 20 69 73 20 61 es)) ;; it is a
12f0: 20 70 61 69 72 0a 09 20 20 20 28 28 73 74 72 69 pair.. ((stri
1300: 6e 67 3f 20 28 63 61 64 72 20 72 65 73 29 29 28 ng? (cadr res))(
1310: 63 61 64 72 20 72 65 73 29 29 20 3b 3b 20 69 74 cadr res)) ;; it
1320: 20 69 73 20 61 20 6c 69 73 74 0a 09 20 20 20 28 is a list.. (
1330: 65 6c 73 65 20 63 61 64 72 20 72 65 73 29 29 29 else cadr res)))
1340: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 )))..(define (te
1350: 73 74 73 3a 67 65 74 2d 67 6c 6f 62 61 6c 2d 77 sts:get-global-w
1360: 61 69 74 6f 6e 73 20 72 63 6f 6e 66 69 67 29 0a aitons rconfig).
1370: 20 20 28 6c 65 74 2a 20 28 28 67 6c 6f 62 61 6c (let* ((global
1380: 2d 77 61 69 74 6f 6e 73 20 28 72 75 6e 63 6f 6e -waitons (runcon
1390: 66 69 67 73 2d 67 65 74 20 72 63 6f 6e 66 69 67 figs-get rconfig
13a0: 20 22 21 47 4c 4f 42 41 4c 5f 57 41 49 54 4f 4e "!GLOBAL_WAITON
13b0: 53 22 29 29 29 0a 20 20 20 20 28 69 66 20 28 73 S"))). (if (s
13c0: 74 72 69 6e 67 3f 20 67 6c 6f 62 61 6c 2d 77 61 tring? global-wa
13d0: 69 74 6f 6e 73 29 0a 09 28 73 74 72 69 6e 67 2d itons)..(string-
13e0: 73 70 6c 69 74 20 67 6c 6f 62 61 6c 2d 77 61 69 split global-wai
13f0: 74 6f 6e 73 29 0a 09 27 28 29 29 29 29 0a 0a 3b tons)..'())))..;
1400: 3b 20 72 65 74 75 72 6e 20 69 74 65 6d 73 20 67 ; return items g
1410: 69 76 65 6e 20 63 6f 6e 66 69 67 0a 3b 3b 0a 28 iven config.;;.(
1420: 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 67 65 define (tests:ge
1430: 74 2d 69 74 65 6d 73 20 74 63 6f 6e 66 69 67 29 t-items tconfig)
1440: 0a 20 20 28 6c 65 74 20 28 28 69 74 65 6d 73 20 . (let ((items
1450: 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
1460: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 63 6f -ref/default tco
1470: 6e 66 69 67 20 22 69 74 65 6d 73 22 20 23 66 29 nfig "items" #f)
1480: 29 20 3b 3b 20 69 74 65 6d 73 20 34 0a 09 28 69 ) ;; items 4..(i
1490: 74 65 6d 73 74 61 62 6c 65 20 28 68 61 73 68 2d temstable (hash-
14a0: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
14b0: 74 20 74 63 6f 6e 66 69 67 20 22 69 74 65 6d 73 t tconfig "items
14c0: 74 61 62 6c 65 22 20 23 66 29 29 29 20 0a 20 20 table" #f))) .
14d0: 20 20 3b 3b 20 69 66 20 65 69 74 68 65 72 20 69 ;; if either i
14e0: 74 65 6d 73 20 6f 72 20 69 74 65 6d 73 20 74 61 tems or items ta
14f0: 62 6c 65 20 69 73 20 61 20 70 72 6f 63 20 72 65 ble is a proc re
1500: 74 75 72 6e 20 69 74 20 73 6f 20 74 65 73 74 20 turn it so test
1510: 72 75 6e 6e 69 6e 67 0a 20 20 20 20 3b 3b 20 70 running. ;; p
1520: 72 6f 63 65 73 73 20 63 61 6e 20 6b 6e 6f 77 20 rocess can know
1530: 74 6f 20 63 61 6c 6c 20 69 74 65 6d 73 3a 67 65 to call items:ge
1540: 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e t-items-from-con
1550: 66 69 67 0a 20 20 20 20 3b 3b 20 69 66 20 65 69 fig. ;; if ei
1560: 74 68 65 72 20 69 73 20 61 20 6c 69 73 74 20 61 ther is a list a
1570: 6e 64 20 6e 6f 6e 65 20 69 73 20 61 20 70 72 6f nd none is a pro
1580: 63 20 67 6f 20 61 68 65 61 64 20 61 6e 64 20 63 c go ahead and c
1590: 61 6c 6c 20 67 65 74 2d 69 74 65 6d 73 0a 20 20 all get-items.
15a0: 20 20 3b 3b 20 6f 74 68 65 72 77 69 73 65 20 72 ;; otherwise r
15b0: 65 74 75 72 6e 20 23 66 20 2d 20 74 68 69 73 20 eturn #f - this
15c0: 69 73 20 6e 6f 74 20 61 6e 20 69 74 65 72 61 74 is not an iterat
15d0: 65 64 20 74 65 73 74 0a 20 20 20 20 28 63 6f 6e ed test. (con
15e0: 64 0a 20 20 20 20 20 28 28 70 72 6f 63 65 64 75 d. ((procedu
15f0: 72 65 3f 20 69 74 65 6d 73 29 20 20 20 20 20 20 re? items)
1600: 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
1610: 69 6e 74 2d 69 6e 66 6f 20 34 20 2a 64 65 66 61 int-info 4 *defa
1620: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 69 ult-log-port* "i
1630: 74 65 6d 73 20 69 73 20 61 20 70 72 6f 63 65 64 tems is a proced
1640: 75 72 65 2c 20 77 69 6c 6c 20 63 61 6c 63 20 6c ure, will calc l
1650: 61 74 65 72 22 29 0a 20 20 20 20 20 20 69 74 65 ater"). ite
1660: 6d 73 29 20 20 20 20 20 20 20 20 20 20 20 20 3b ms) ;
1670: 3b 20 63 61 6c 63 20 6c 61 74 65 72 0a 20 20 20 ; calc later.
1680: 20 20 28 28 70 72 6f 63 65 64 75 72 65 3f 20 69 ((procedure? i
1690: 74 65 6d 73 74 61 62 6c 65 29 0a 20 20 20 20 20 temstable).
16a0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
16b0: 66 6f 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 4 *default-lo
16c0: 67 2d 70 6f 72 74 2a 20 22 69 74 65 6d 73 74 61 g-port* "itemsta
16d0: 62 6c 65 20 69 73 20 61 20 70 72 6f 63 65 64 75 ble is a procedu
16e0: 72 65 2c 20 77 69 6c 6c 20 63 61 6c 63 20 6c 61 re, will calc la
16f0: 74 65 72 22 29 0a 20 20 20 20 20 20 69 74 65 6d ter"). item
1700: 73 74 61 62 6c 65 29 20 20 20 20 20 20 20 3b 3b stable) ;;
1710: 20 63 61 6c 63 20 6c 61 74 65 72 0a 20 20 20 20 calc later.
1720: 20 28 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 ((filter (lambd
1730: 61 20 28 78 29 0a 09 09 28 6c 65 74 20 28 28 76 a (x)...(let ((v
1740: 61 6c 20 28 63 61 72 20 78 29 29 29 0a 09 09 20 al (car x)))...
1750: 20 28 69 66 20 28 70 72 6f 63 65 64 75 72 65 3f (if (procedure?
1760: 20 76 61 6c 29 20 76 61 6c 20 23 66 29 29 29 0a val) val #f))).
1770: 09 20 20 20 20 20 20 28 61 70 70 65 6e 64 20 28 . (append (
1780: 69 66 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 if (list? items)
1790: 20 69 74 65 6d 73 20 27 28 29 29 0a 09 09 20 20 items '())...
17a0: 20 20 20 20 28 69 66 20 28 6c 69 73 74 3f 20 69 (if (list? i
17b0: 74 65 6d 73 74 61 62 6c 65 29 20 69 74 65 6d 73 temstable) items
17c0: 74 61 62 6c 65 20 27 28 29 29 29 29 0a 20 20 20 table '()))).
17d0: 20 20 20 27 68 61 76 65 2d 70 72 6f 63 65 64 75 'have-procedu
17e0: 72 65 29 0a 20 20 20 20 20 28 28 6f 72 20 28 6c re). ((or (l
17f0: 69 73 74 3f 20 69 74 65 6d 73 29 28 6c 69 73 74 ist? items)(list
1800: 3f 20 69 74 65 6d 73 74 61 62 6c 65 29 29 20 3b ? itemstable)) ;
1810: 3b 20 63 61 6c 63 20 6e 6f 77 0a 20 20 20 20 20 ; calc now.
1820: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
1830: 66 6f 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 4 *default-lo
1840: 67 2d 70 6f 72 74 2a 20 22 69 74 65 6d 73 20 61 g-port* "items a
1850: 6e 64 20 69 74 65 6d 73 74 61 62 6c 65 20 61 72 nd itemstable ar
1860: 65 20 6c 69 73 74 73 2c 20 63 61 6c 63 20 6e 6f e lists, calc no
1870: 77 5c 6e 22 0a 09 09 09 22 20 20 20 20 69 74 65 w\n"...." ite
1880: 6d 73 3a 20 22 20 69 74 65 6d 73 20 22 20 69 74 ms: " items " it
1890: 65 6d 73 74 61 62 6c 65 3a 20 22 20 69 74 65 6d emstable: " item
18a0: 73 74 61 62 6c 65 29 0a 20 20 20 20 20 20 28 69 stable). (i
18b0: 74 65 6d 73 3a 67 65 74 2d 69 74 65 6d 73 2d 66 tems:get-items-f
18c0: 72 6f 6d 2d 63 6f 6e 66 69 67 20 74 63 6f 6e 66 rom-config tconf
18d0: 69 67 29 29 0a 20 20 20 20 20 28 65 6c 73 65 20 ig)). (else
18e0: 23 66 29 29 29 29 20 20 20 20 20 20 20 20 20 20 #f))))
18f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1900: 20 3b 3b 20 6e 6f 74 20 69 74 65 72 61 74 65 64 ;; not iterated
1910: 0a 0a 0a 3b 3b 20 72 65 74 75 72 6e 73 20 77 61 ...;; returns wa
1920: 69 74 6f 6e 73 20 77 61 69 74 6f 72 73 20 74 63 itons waitors tc
1930: 6f 6e 66 69 67 64 61 74 0a 3b 3b 0a 28 64 65 66 onfigdat.;;.(def
1940: 69 6e 65 20 28 74 65 73 74 73 3a 67 65 74 2d 77 ine (tests:get-w
1950: 61 69 74 6f 6e 73 20 74 65 73 74 2d 6e 61 6d 65 aitons test-name
1960: 20 61 6c 6c 2d 74 65 73 74 73 2d 72 65 67 69 73 all-tests-regis
1970: 74 72 79 20 67 6c 6f 62 61 6c 2d 77 61 69 74 6f try global-waito
1980: 6e 73 29 0a 20 20 20 28 6c 65 74 2a 20 28 28 63 ns). (let* ((c
1990: 6f 6e 66 69 67 20 20 28 74 65 73 74 73 3a 67 65 onfig (tests:ge
19a0: 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 74 65 73 t-testconfig tes
19b0: 74 2d 6e 61 6d 65 20 23 66 20 61 6c 6c 2d 74 65 t-name #f all-te
19c0: 73 74 73 2d 72 65 67 69 73 74 72 79 20 27 72 65 sts-registry 're
19d0: 74 75 72 6e 2d 70 72 6f 63 73 29 29 29 20 3b 3b turn-procs))) ;;
19e0: 20 61 73 73 75 6d 69 6e 67 20 6e 6f 20 70 72 6f assuming no pro
19f0: 62 6c 65 6d 73 20 77 69 74 68 20 69 6d 6d 65 64 blems with immed
1a00: 69 61 74 65 20 65 76 61 6c 75 61 74 69 6f 6e 2c iate evaluation,
1a10: 20 74 68 69 73 20 63 6f 75 6c 64 20 62 65 20 73 this could be s
1a20: 69 6d 70 6c 69 66 69 65 64 20 28 27 72 65 74 75 implified ('retu
1a30: 72 6e 2d 70 72 6f 63 73 20 2d 3e 20 23 74 29 0a rn-procs -> #t).
1a40: 20 20 20 20 20 28 6c 65 74 20 28 28 69 6e 73 74 (let ((inst
1a50: 72 20 28 69 66 20 63 6f 6e 66 69 67 20 0a 09 09 r (if config ...
1a60: 20 20 20 20 20 20 28 63 6f 6e 66 69 67 66 3a 6c (configf:l
1a70: 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 20 22 72 65 ookup config "re
1a80: 71 75 69 72 65 6d 65 6e 74 73 22 20 22 77 61 69 quirements" "wai
1a90: 74 6f 6e 22 29 0a 09 09 20 20 20 20 20 20 28 62 ton")... (b
1aa0: 65 67 69 6e 20 3b 3b 20 4e 6f 20 63 6f 6e 66 69 egin ;; No confi
1ab0: 67 20 6d 65 61 6e 73 20 74 68 69 73 20 69 73 20 g means this is
1ac0: 61 20 6e 6f 6e 2d 65 78 69 73 74 61 6e 74 20 74 a non-existant t
1ad0: 65 73 74 0a 09 09 09 28 64 65 62 75 67 3a 70 72 est....(debug:pr
1ae0: 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 int-error 0 *def
1af0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
1b00: 6e 6f 6e 2d 65 78 69 73 74 65 6e 74 20 72 65 71 non-existent req
1b10: 75 69 72 65 64 20 74 65 73 74 20 5c 22 22 20 74 uired test \"" t
1b20: 65 73 74 2d 6e 61 6d 65 20 22 5c 22 22 29 0a 09 est-name "\"")..
1b30: 09 09 28 65 78 69 74 20 31 29 29 29 29 0a 09 20 ..(exit 1))))..
1b40: 20 20 28 69 6e 73 74 72 32 20 28 69 66 20 63 6f (instr2 (if co
1b50: 6e 66 69 67 0a 09 09 20 20 20 20 20 20 20 28 63 nfig... (c
1b60: 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 63 6f onfigf:lookup co
1b70: 6e 66 69 67 20 22 72 65 71 75 69 72 65 6d 65 6e nfig "requiremen
1b80: 74 73 22 20 22 77 61 69 74 6f 72 22 29 0a 09 09 ts" "waitor")...
1b90: 20 20 20 20 20 20 20 22 22 29 29 29 0a 20 20 20 ""))).
1ba0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
1bb0: 2d 69 6e 66 6f 20 38 20 2a 64 65 66 61 75 6c 74 -info 8 *default
1bc0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 77 61 69 74 -log-port* "wait
1bd0: 6f 6e 73 20 73 74 72 69 6e 67 20 69 73 20 22 20 ons string is "
1be0: 69 6e 73 74 72 20 22 2c 20 77 61 69 74 6f 72 73 instr ", waitors
1bf0: 20 73 74 72 69 6e 67 20 69 73 20 22 20 69 6e 73 string is " ins
1c00: 74 72 32 29 0a 20 20 20 20 20 20 20 28 6c 65 74 tr2). (let
1c10: 2a 20 28 28 6e 65 77 77 61 69 74 6f 6e 73 2d 74 * ((newwaitons-t
1c20: 6d 70 0a 09 20 20 20 20 20 20 28 73 74 72 69 6e mp.. (strin
1c30: 67 2d 73 70 6c 69 74 20 28 63 6f 6e 64 0a 09 09 g-split (cond...
1c40: 09 20 20 20 20 20 28 28 70 72 6f 63 65 64 75 72 . ((procedur
1c50: 65 3f 20 69 6e 73 74 72 29 20 3b 3b 20 68 65 72 e? instr) ;; her
1c60: 65 20 0a 09 09 09 20 20 20 20 20 20 28 6c 65 74 e .... (let
1c70: 20 28 28 72 65 73 20 28 69 6e 73 74 72 29 29 29 ((res (instr)))
1c80: 0a 09 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e .....(debug:prin
1c90: 74 2d 69 6e 66 6f 20 38 20 2a 64 65 66 61 75 6c t-info 8 *defaul
1ca0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 77 61 69 t-log-port* "wai
1cb0: 74 6f 6e 20 70 72 6f 63 65 64 75 72 65 20 72 65 ton procedure re
1cc0: 73 75 6c 74 73 20 69 6e 20 73 74 72 69 6e 67 20 sults in string
1cd0: 22 20 72 65 73 20 22 20 66 6f 72 20 74 65 73 74 " res " for test
1ce0: 20 22 20 74 65 73 74 2d 6e 61 6d 65 29 0a 09 09 " test-name)...
1cf0: 09 09 72 65 73 29 29 0a 09 09 09 20 20 20 20 20 ..res))....
1d00: 28 28 73 74 72 69 6e 67 3f 20 69 6e 73 74 72 29 ((string? instr)
1d10: 20 20 20 20 20 69 6e 73 74 72 29 0a 09 09 09 20 instr)....
1d20: 20 20 20 20 28 65 6c 73 65 20 0a 09 09 09 20 20 (else ....
1d30: 20 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 54 68 69 ;; NOTE: Thi
1d40: 73 20 69 73 20 61 63 74 75 61 6c 6c 79 20 74 68 s is actually th
1d50: 65 20 63 61 73 65 20 6f 66 20 2a 6e 6f 2a 20 77 e case of *no* w
1d60: 61 69 74 6f 6e 73 21 20 3b 3b 20 28 64 65 62 75 aitons! ;; (debu
1d70: 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 g:print-error 0
1d80: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
1d90: 74 2a 20 22 73 6f 6d 65 74 68 69 6e 67 20 77 65 t* "something we
1da0: 6e 74 20 77 72 6f 6e 67 20 69 6e 20 70 72 6f 63 nt wrong in proc
1db0: 65 73 73 69 6e 67 20 77 61 69 74 6f 6e 73 20 66 essing waitons f
1dc0: 6f 72 20 74 65 73 74 20 22 20 74 65 73 74 2d 6e or test " test-n
1dd0: 61 6d 65 29 0a 09 09 09 20 20 20 20 20 20 22 22 ame).... ""
1de0: 29 29 29 29 0a 09 20 20 20 20 20 28 6e 65 77 77 )))).. (neww
1df0: 61 69 74 6f 72 73 0a 09 20 20 20 20 20 20 28 73 aitors.. (s
1e00: 74 72 69 6e 67 2d 73 70 6c 69 74 20 28 63 6f 6e tring-split (con
1e10: 64 0a 09 09 09 20 20 20 20 20 28 28 70 72 6f 63 d.... ((proc
1e20: 65 64 75 72 65 3f 20 69 6e 73 74 72 32 29 0a 09 edure? instr2)..
1e30: 09 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 .. (let ((r
1e40: 65 73 20 28 69 6e 73 74 72 32 29 29 29 0a 09 09 es (instr2)))...
1e50: 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 ..(debug:print-i
1e60: 6e 66 6f 20 38 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 8 *default-l
1e70: 6f 67 2d 70 6f 72 74 2a 20 22 77 61 69 74 6f 72 og-port* "waitor
1e80: 20 70 72 6f 63 65 64 75 72 65 20 72 65 73 75 6c procedure resul
1e90: 74 73 20 69 6e 20 73 74 72 69 6e 67 20 22 20 72 ts in string " r
1ea0: 65 73 20 22 20 66 6f 72 20 74 65 73 74 20 22 20 es " for test "
1eb0: 74 65 73 74 2d 6e 61 6d 65 29 0a 09 09 09 09 72 test-name).....r
1ec0: 65 73 29 29 0a 09 09 09 20 20 20 20 20 28 28 73 es)).... ((s
1ed0: 74 72 69 6e 67 3f 20 69 6e 73 74 72 32 29 20 20 tring? instr2)
1ee0: 20 20 20 69 6e 73 74 72 32 29 0a 09 09 09 20 20 instr2)....
1ef0: 20 20 20 28 65 6c 73 65 20 0a 09 09 09 20 20 20 (else ....
1f00: 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 54 68 69 73 ;; NOTE: This
1f10: 20 69 73 20 61 63 74 75 61 6c 6c 79 20 74 68 65 is actually the
1f20: 20 63 61 73 65 20 6f 66 20 2a 6e 6f 2a 20 77 61 case of *no* wa
1f30: 69 74 6f 6e 73 21 20 3b 3b 20 28 64 65 62 75 67 itons! ;; (debug
1f40: 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a :print-error 0 *
1f50: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
1f60: 2a 20 22 73 6f 6d 65 74 68 69 6e 67 20 77 65 6e * "something wen
1f70: 74 20 77 72 6f 6e 67 20 69 6e 20 70 72 6f 63 65 t wrong in proce
1f80: 73 73 69 6e 67 20 77 61 69 74 6f 6e 73 20 66 6f ssing waitons fo
1f90: 72 20 74 65 73 74 20 22 20 74 65 73 74 2d 6e 61 r test " test-na
1fa0: 6d 65 29 0a 09 09 09 20 20 20 20 20 20 22 22 29 me).... "")
1fb0: 29 29 29 0a 09 20 20 20 20 20 28 6e 65 77 77 61 ))).. (newwa
1fc0: 69 74 6f 6e 73 20 28 69 66 20 28 61 6e 64 20 28 itons (if (and (
1fd0: 6c 69 73 74 3f 20 67 6c 6f 62 61 6c 2d 77 61 69 list? global-wai
1fe0: 74 6f 6e 73 29 0a 09 09 09 09 20 20 28 6e 6f 74 tons)..... (not
1ff0: 20 28 6e 75 6c 6c 3f 20 67 6c 6f 62 61 6c 2d 77 (null? global-w
2000: 61 69 74 6f 6e 73 29 29 29 0a 09 09 09 20 20 20 aitons)))....
2010: 20 20 28 62 65 67 69 6e 0a 09 09 09 20 20 20 20 (begin....
2020: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
2030: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
2040: 6f 72 74 2a 20 22 41 64 64 69 6e 67 20 67 6c 6f ort* "Adding glo
2050: 62 61 6c 20 77 61 69 74 6f 6e 73 20 22 20 67 6c bal waitons " gl
2060: 6f 62 61 6c 2d 77 61 69 74 6f 6e 73 29 0a 09 09 obal-waitons)...
2070: 09 20 20 20 20 20 20 20 28 61 70 70 65 6e 64 20 . (append
2080: 6e 65 77 77 61 69 74 6f 6e 73 2d 74 6d 70 20 20 newwaitons-tmp
2090: 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 (filter (lambda
20a0: 28 78 29 20 3b 3b 20 72 65 6d 6f 76 65 20 73 65 (x) ;; remove se
20b0: 6c 66 20 66 72 6f 6d 20 67 6c 6f 62 61 6c 20 77 lf from global w
20c0: 61 69 74 6f 6e 73 0a 09 09 09 09 09 09 09 09 20 aitons.........
20d0: 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 78 20 74 (not (equal? x t
20e0: 65 73 74 2d 6e 61 6d 65 29 29 29 0a 09 09 09 09 est-name))).....
20f0: 09 09 09 20 20 20 20 20 20 20 67 6c 6f 62 61 6c ... global
2100: 2d 77 61 69 74 6f 6e 73 29 29 29 0a 09 09 09 20 -waitons)))....
2110: 20 20 20 20 6e 65 77 77 61 69 74 6f 6e 73 2d 74 newwaitons-t
2120: 6d 70 29 29 29 0a 09 20 28 76 61 6c 75 65 73 0a mp))).. (values.
2130: 09 20 20 3b 3b 20 74 68 65 20 77 61 69 74 6f 6e . ;; the waiton
2140: 73 0a 09 20 20 28 66 69 6c 74 65 72 20 28 6c 61 s.. (filter (la
2150: 6d 62 64 61 20 28 78 29 0a 09 09 20 20 20 20 28 mbda (x)... (
2160: 69 66 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 if (hash-table-r
2170: 65 66 2f 64 65 66 61 75 6c 74 20 61 6c 6c 2d 74 ef/default all-t
2180: 65 73 74 73 2d 72 65 67 69 73 74 72 79 20 78 20 ests-registry x
2190: 23 66 29 0a 09 09 09 23 74 0a 09 09 09 28 62 65 #f)....#t....(be
21a0: 67 69 6e 0a 09 09 09 20 20 28 64 65 62 75 67 3a gin.... (debug:
21b0: 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 print-error 0 *d
21c0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
21d0: 20 22 74 65 73 74 20 22 20 74 65 73 74 2d 6e 61 "test " test-na
21e0: 6d 65 20 22 20 68 61 73 20 75 6e 72 65 63 6f 67 me " has unrecog
21f0: 6e 69 73 65 64 20 77 61 69 74 6f 6e 20 74 65 73 nised waiton tes
2200: 74 6e 61 6d 65 20 22 20 78 29 0a 09 09 09 20 20 tname " x)....
2210: 23 66 29 29 29 0a 09 09 20 20 6e 65 77 77 61 69 #f)))... newwai
2220: 74 6f 6e 73 29 0a 09 20 20 28 66 69 6c 74 65 72 tons).. (filter
2230: 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 09 20 (lambda (x)...
2240: 20 20 20 28 69 66 20 28 68 61 73 68 2d 74 61 62 (if (hash-tab
2250: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 61 le-ref/default a
2260: 6c 6c 2d 74 65 73 74 73 2d 72 65 67 69 73 74 72 ll-tests-registr
2270: 79 20 78 20 23 66 29 0a 09 09 09 23 74 0a 09 09 y x #f)....#t...
2280: 09 28 62 65 67 69 6e 0a 09 09 09 20 20 28 64 65 .(begin.... (de
2290: 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 bug:print-error
22a0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
22b0: 6f 72 74 2a 20 22 74 65 73 74 20 22 20 74 65 73 ort* "test " tes
22c0: 74 2d 6e 61 6d 65 20 22 20 68 61 73 20 75 6e 72 t-name " has unr
22d0: 65 63 6f 67 6e 69 73 65 64 20 77 61 69 74 6f 6e ecognised waiton
22e0: 20 74 65 73 74 6e 61 6d 65 20 22 20 78 29 0a 09 testname " x)..
22f0: 09 09 20 20 23 66 29 29 29 0a 09 09 20 20 6e 65 .. #f)))... ne
2300: 77 77 61 69 74 6f 72 73 29 0a 09 20 20 63 6f 6e wwaitors).. con
2310: 66 69 67 29 29 29 29 29 0a 09 09 09 09 09 20 20 fig)))))......
2320: 20 20 20 0a 3b 3b 20 67 69 76 65 6e 20 77 61 69 .;; given wai
2330: 74 69 6e 67 2d 74 65 73 74 20 74 68 61 74 20 69 ting-test that i
2340: 73 20 77 61 69 74 69 6e 67 20 6f 6e 20 77 61 69 s waiting on wai
2350: 74 6f 6e 2d 74 65 73 74 20 65 78 74 65 6e 64 20 ton-test extend
2360: 74 65 73 74 2d 70 61 74 74 20 61 70 70 72 6f 70 test-patt approp
2370: 72 69 61 74 65 6c 79 0a 3b 3b 0a 3b 3b 20 20 67 riately.;;.;; g
2380: 65 6e 6c 69 62 2f 74 65 73 74 63 6f 6e 66 69 67 enlib/testconfig
2390: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 73 s
23a0: 69 6d 2f 74 65 73 74 63 6f 6e 66 69 67 0a 3b 3b im/testconfig.;;
23b0: 20 20 67 65 6e 6c 69 62 2f 73 63 68 20 20 20 20 genlib/sch
23c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
23d0: 20 20 73 69 6d 2f 73 63 68 2f 63 65 6c 6c 31 0a sim/sch/cell1.
23e0: 3b 3b 0a 3b 3b 20 20 5b 72 65 71 75 69 72 65 6d ;;.;; [requirem
23f0: 65 6e 74 73 5d 20 20 20 20 20 20 20 20 20 20 20 ents]
2400: 20 20 20 20 20 20 20 5b 72 65 71 75 69 72 65 6d [requirem
2410: 65 6e 74 73 5d 0a 3b 3b 20 20 20 20 20 20 20 20 ents].;;
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 6d 6f 64 65 20 69 mode i
2440: 74 65 6d 77 61 69 74 0a 3b 3b 20 20 20 20 20 20 temwait.;;
2450: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2460: 20 20 20 20 20 20 20 20 20 20 20 20 23 20 74 72 # tr
2470: 69 6d 20 6f 66 66 20 74 68 65 20 63 65 6c 6c 20 im off the cell
2480: 74 6f 20 64 65 74 65 72 6d 69 6e 65 20 77 68 61 to determine wha
2490: 74 20 74 6f 20 72 75 6e 20 66 6f 72 20 67 65 6e t to run for gen
24a0: 6c 69 62 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 lib.;;
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 69 74 65 6d 6d 61 70 20 itemmap
24d0: 2f 2e 2a 0a 3b 3b 0a 3b 3b 20 20 20 20 20 20 20 /.*.;;.;;
24e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
24f0: 20 20 20 20 20 20 20 20 20 20 20 77 61 69 74 69 waiti
2500: 6e 67 2d 74 65 73 74 20 69 73 20 77 61 69 74 69 ng-test is waiti
2510: 6e 67 20 6f 6e 20 77 61 69 74 6f 6e 2d 74 65 73 ng on waiton-tes
2520: 74 20 73 6f 20 77 65 20 6e 65 65 64 20 74 6f 20 t so we need to
2530: 63 72 65 61 74 65 20 61 20 70 61 74 74 65 72 6e create a pattern
2540: 20 66 6f 72 20 77 61 69 74 6f 6e 2d 74 65 73 74 for waiton-test
2550: 20 67 69 76 65 6e 20 77 61 69 74 69 6e 67 2d 74 given waiting-t
2560: 65 73 74 20 61 6e 64 20 69 74 65 6d 6d 61 70 0a est and itemmap.
2570: 3b 3b 20 42 42 3e 20 28 74 65 73 74 73 3a 65 78 ;; BB> (tests:ex
2580: 74 65 6e 64 2d 74 65 73 74 2d 70 61 74 74 73 20 tend-test-patts
2590: 22 6e 6f 72 6d 61 6c 2d 73 65 63 6f 6e 64 2f 32 "normal-second/2
25a0: 22 20 22 6e 6f 72 6d 61 6c 2d 73 65 63 6f 6e 64 " "normal-second
25b0: 22 20 22 6e 6f 72 6d 61 6c 2d 66 69 72 73 74 22 " "normal-first"
25c0: 20 27 28 29 29 0a 3b 3b 20 6f 62 73 65 72 76 65 '()).;; observe
25d0: 64 20 2d 3e 20 22 6e 6f 72 6d 61 6c 2d 66 69 72 d -> "normal-fir
25e0: 73 74 2f 32 2c 6e 6f 72 6d 61 6c 2d 66 69 72 73 st/2,normal-firs
25f0: 74 2f 2c 6e 6f 72 6d 61 6c 2d 73 65 63 6f 6e 64 t/,normal-second
2600: 2f 32 2c 6e 6f 72 6d 61 6c 2d 73 65 63 6f 6e 64 /2,normal-second
2610: 2f 22 0a 3b 3b 20 65 78 70 65 63 74 65 64 20 2d /".;; expected -
2620: 3e 20 22 6e 6f 72 6d 61 6c 2d 66 69 72 73 74 2c > "normal-first,
2630: 6e 6f 72 6d 61 6c 2d 73 65 63 6f 6e 64 2f 32 2c normal-second/2,
2640: 6e 6f 72 6d 61 6c 2d 73 65 63 6f 6e 64 2f 22 0a normal-second/".
2650: 3b 3b 20 74 65 73 74 70 61 74 74 20 3d 20 6e 6f ;; testpatt = no
2660: 72 6d 61 6c 2d 73 65 63 6f 6e 64 2f 32 0a 3b 3b rmal-second/2.;;
2670: 20 77 61 69 74 69 6e 67 2d 74 65 73 74 20 3d 20 waiting-test =
2680: 6e 6f 72 6d 61 6c 2d 73 65 63 6f 6e 64 0a 3b 3b normal-second.;;
2690: 20 77 61 69 74 6f 6e 2d 74 65 73 74 20 3d 20 6e waiton-test = n
26a0: 6f 72 6d 61 6c 2d 66 69 72 73 74 0a 3b 3b 20 69 ormal-first.;; i
26b0: 74 65 6d 6d 61 70 73 20 3d 20 28 29 0a 0a 28 64 temmaps = ()..(d
26c0: 65 66 69 6e 65 20 28 74 65 73 74 73 3a 65 78 74 efine (tests:ext
26d0: 65 6e 64 2d 74 65 73 74 2d 70 61 74 74 73 20 74 end-test-patts t
26e0: 65 73 74 2d 70 61 74 74 20 77 61 69 74 69 6e 67 est-patt waiting
26f0: 2d 74 65 73 74 20 77 61 69 74 6f 6e 2d 74 65 73 -test waiton-tes
2700: 74 20 69 74 65 6d 6d 61 70 73 20 69 74 65 6d 69 t itemmaps itemi
2710: 7a 65 64 2d 77 61 69 74 6f 6e 29 0a 20 20 28 63 zed-waiton). (c
2720: 6f 6e 64 0a 20 20 20 28 69 74 65 6d 69 7a 65 64 ond. (itemized
2730: 2d 77 61 69 74 6f 6e 0a 20 20 20 20 28 6c 65 74 -waiton. (let
2740: 2a 20 28 28 69 74 65 6d 6d 61 70 20 20 20 20 20 * ((itemmap
2750: 20 20 20 20 20 28 74 65 73 74 73 3a 6c 6f 6f 6b (tests:look
2760: 75 70 2d 69 74 65 6d 6d 61 70 20 69 74 65 6d 6d up-itemmap itemm
2770: 61 70 73 20 77 61 69 74 6f 6e 2d 74 65 73 74 29 aps waiton-test)
2780: 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 70 61 ). (pa
2790: 74 74 73 20 20 20 20 20 20 20 20 20 20 20 20 28 tts (
27a0: 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 74 65 73 string-split tes
27b0: 74 2d 70 61 74 74 20 22 2c 22 29 29 0a 20 20 20 t-patt ",")).
27c0: 20 20 20 20 20 20 20 20 28 77 61 69 74 69 6e 67 (waiting
27d0: 2d 74 65 73 74 2d 6c 65 6e 20 28 2b 20 28 73 74 -test-len (+ (st
27e0: 72 69 6e 67 2d 6c 65 6e 67 74 68 20 77 61 69 74 ring-length wait
27f0: 69 6e 67 2d 74 65 73 74 29 20 31 29 29 0a 20 20 ing-test) 1)).
2800: 20 20 20 20 20 20 20 20 20 28 70 61 74 74 73 2d (patts-
2810: 77 61 69 74 6f 6e 20 20 20 20 20 28 6d 61 70 20 waiton (map
2820: 28 6c 61 6d 62 64 61 20 28 78 29 20 20 3b 3b 20 (lambda (x) ;;
2830: 66 6f 72 20 65 61 63 68 20 69 6e 63 6f 6d 69 6e for each incomin
2840: 67 20 70 61 74 74 20 74 68 61 74 20 6d 61 74 63 g patt that matc
2850: 68 65 73 20 74 68 65 20 77 61 69 74 69 6e 67 20 hes the waiting
2860: 74 65 73 74 0a 20 20 20 20 20 20 20 20 20 20 20 test.
2870: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2880: 20 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 (let* (
2890: 28 6d 6f 64 70 61 74 74 20 28 69 66 20 69 74 65 (modpatt (if ite
28a0: 6d 6d 61 70 20 28 64 62 3a 63 6f 6e 76 65 72 74 mmap (db:convert
28b0: 2d 74 65 73 74 2d 69 74 65 6d 70 61 74 68 20 78 -test-itempath x
28c0: 20 69 74 65 6d 6d 61 70 29 20 78 29 29 20 0a 20 itemmap) x)) .
28d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
28e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
28f0: 20 20 20 20 20 20 20 20 20 20 28 6e 65 77 70 61 (newpa
2900: 74 74 20 28 63 6f 6e 63 20 77 61 69 74 6f 6e 2d tt (conc waiton-
2910: 74 65 73 74 20 22 2f 22 20 28 73 75 62 73 74 72 test "/" (substr
2920: 69 6e 67 20 6d 6f 64 70 61 74 74 20 77 61 69 74 ing modpatt wait
2930: 69 6e 67 2d 74 65 73 74 2d 6c 65 6e 20 28 73 74 ing-test-len (st
2940: 72 69 6e 67 2d 6c 65 6e 67 74 68 20 6d 6f 64 70 ring-length modp
2950: 61 74 74 29 29 29 29 29 0a 20 20 20 20 20 20 20 att))))).
2960: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2970: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
2980: 3b 20 28 63 6f 6e 63 20 77 61 69 74 69 6e 67 2d ; (conc waiting-
2990: 74 65 73 74 20 22 2f 2c 22 20 77 61 69 74 69 6e test "/," waitin
29a0: 67 2d 74 65 73 74 20 22 2f 22 20 28 73 75 62 73 g-test "/" (subs
29b0: 74 72 69 6e 67 20 6d 6f 64 70 61 74 74 20 77 61 tring modpatt wa
29c0: 69 74 6f 6e 2d 74 65 73 74 2d 6c 65 6e 20 28 73 iton-test-len (s
29d0: 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 6d 6f 64 tring-length mod
29e0: 70 61 74 74 29 29 29 29 29 0a 20 20 20 20 20 20 patt))))).
29f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2a00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2a10: 3b 3b 20 28 70 72 69 6e 74 20 22 69 6e 20 6d 61 ;; (print "in ma
2a20: 70 2c 20 78 3d 22 20 78 20 22 2c 20 6e 65 77 70 p, x=" x ", newp
2a30: 61 74 74 3d 22 20 6e 65 77 70 61 74 74 29 0a 20 att=" newpatt).
2a40: 20 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 20 20 6e 65 77 70 61 74 74 29 29 0a 20 newpatt)).
2a70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2a80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2a90: 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 (filter (lambda
2aa0: 20 28 78 29 0a 20 20 20 20 20 20 20 20 20 20 20 (x).
2ab0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2ac0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2ad0: 20 28 65 71 3f 20 28 73 75 62 73 74 72 69 6e 67 (eq? (substring
2ae0: 2d 69 6e 64 65 78 20 28 63 6f 6e 63 20 77 61 69 -index (conc wai
2af0: 74 69 6e 67 2d 74 65 73 74 20 22 2f 22 29 20 78 ting-test "/") x
2b00: 29 20 30 29 29 20 3b 3b 20 69 73 20 74 68 69 73 ) 0)) ;; is this
2b10: 20 70 61 74 74 20 70 65 72 74 69 6e 65 6e 74 20 patt pertinent
2b20: 74 6f 20 74 68 65 20 77 61 69 74 69 6e 67 20 74 to the waiting t
2b30: 65 73 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 est.
2b40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2b50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 70 61 pa
2b60: 74 74 73 29 29 29 0a 20 20 20 20 20 20 20 20 20 tts))).
2b70: 20 20 28 65 78 74 65 6e 64 65 64 2d 74 65 73 74 (extended-test
2b80: 2d 70 61 74 74 20 20 20 28 61 70 70 65 6e 64 20 -patt (append
2b90: 70 61 74 74 73 20 28 69 66 20 28 6e 75 6c 6c 3f patts (if (null?
2ba0: 20 70 61 74 74 73 2d 77 61 69 74 6f 6e 29 0a 20 patts-waiton).
2bb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2bc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2bd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2be0: 20 20 28 6c 69 73 74 20 28 63 6f 6e 63 20 77 61 (list (conc wa
2bf0: 69 74 6f 6e 2d 74 65 73 74 20 22 2f 25 22 29 29 iton-test "/%"))
2c00: 20 3b 3b 20 72 65 61 6c 6c 79 20 73 68 6f 75 6c ;; really shoul
2c10: 64 6e 27 74 20 61 64 64 20 74 68 65 20 77 61 69 dn't add the wai
2c20: 74 6f 6e 20 66 6f 72 63 65 66 75 6c 6c 79 20 6c ton forcefully l
2c30: 69 6b 65 20 74 68 69 73 0a 20 20 20 20 20 20 20 ike this.
2c40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2c50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2c60: 20 20 20 20 20 20 20 20 20 20 20 20 70 61 74 74 patt
2c70: 73 2d 77 61 69 74 6f 6e 29 29 29 0a 20 20 20 20 s-waiton))).
2c80: 20 20 20 20 20 20 20 28 65 78 74 65 6e 64 65 64 (extended
2c90: 2d 74 65 73 74 2d 70 61 74 74 2d 77 69 74 68 2d -test-patt-with-
2ca0: 74 6f 70 6c 65 76 65 6c 73 0a 20 20 20 20 20 20 toplevels.
2cb0: 20 20 20 20 20 20 28 66 6f 6c 64 20 28 6c 61 6d (fold (lam
2cc0: 62 64 61 20 28 74 65 73 74 70 61 74 74 2d 69 74 bda (testpatt-it
2cd0: 65 6d 20 61 63 63 75 6d 20 29 0a 20 20 20 20 20 em accum ).
2ce0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
2cf0: 6c 65 74 20 28 28 6d 79 2d 6d 61 74 63 68 20 28 let ((my-match (
2d00: 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 22 5e 28 string-match "^(
2d10: 5b 5e 25 5c 5c 2f 5d 2b 29 5c 5c 2f 2e 2b 24 22 [^%\\/]+)\\/.+$"
2d20: 20 74 65 73 74 70 61 74 74 2d 69 74 65 6d 29 29 testpatt-item))
2d30: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
2d40: 20 20 20 20 20 20 20 20 28 63 6f 6e 73 20 74 65 (cons te
2d50: 73 74 70 61 74 74 2d 69 74 65 6d 0a 20 20 20 20 stpatt-item.
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 20 28 69 66 20 6d 79 2d 6d (if my-m
2d80: 61 74 63 68 0a 20 20 20 20 20 20 20 20 20 20 20 atch.
2d90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2da0: 20 20 20 20 20 28 63 6f 6e 73 0a 20 20 20 20 20 (cons.
2db0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2dc0: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e (con
2dd0: 63 20 28 63 61 64 72 20 6d 79 2d 6d 61 74 63 68 c (cadr my-match
2de0: 29 20 22 2f 22 29 0a 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 20 20 20 20 20 20 20 61 63 63 75 6d 29 0a 20 accum).
2e10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2e20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 61 a
2e30: 63 63 75 6d 29 29 29 29 0a 20 20 20 20 20 20 20 ccum)))).
2e40: 20 20 20 20 20 20 20 20 20 20 20 27 28 29 0a 20 '().
2e50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2e60: 20 65 78 74 65 6e 64 65 64 2d 74 65 73 74 2d 70 extended-test-p
2e70: 61 74 74 29 29 29 0a 20 20 20 20 20 20 28 73 74 att))). (st
2e80: 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
2e90: 20 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 (delete-duplica
2ea0: 74 65 73 20 65 78 74 65 6e 64 65 64 2d 74 65 73 tes extended-tes
2eb0: 74 2d 70 61 74 74 2d 77 69 74 68 2d 74 6f 70 6c t-patt-with-topl
2ec0: 65 76 65 6c 73 29 20 22 2c 22 29 29 29 0a 20 20 evels) ","))).
2ed0: 20 28 65 6c 73 65 20 3b 3b 20 6e 6f 74 20 77 61 (else ;; not wa
2ee0: 69 74 69 6e 67 20 6f 6e 20 69 74 65 6d 73 2c 20 iting on items,
2ef0: 77 61 69 74 69 6e 67 20 6f 6e 20 65 6e 74 69 72 waiting on entir
2f00: 65 20 77 61 69 74 6f 6e 20 74 65 73 74 2e 0a 20 e waiton test..
2f10: 20 20 20 28 6c 65 74 2a 20 28 28 70 61 74 74 73 (let* ((patts
2f20: 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 74 (string-split t
2f30: 65 73 74 2d 70 61 74 74 20 22 2c 22 29 29 0a 20 est-patt ",")).
2f40: 20 20 20 20 20 20 20 20 20 20 28 6e 65 77 2d 70 (new-p
2f50: 61 74 74 73 20 28 69 66 20 28 6d 65 6d 62 65 72 atts (if (member
2f60: 20 77 61 69 74 6f 6e 2d 74 65 73 74 20 70 61 74 waiton-test pat
2f70: 74 73 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ts).
2f80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 70 61 pa
2f90: 74 74 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 tts.
2fa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c
2fb0: 6f 6e 73 20 77 61 69 74 6f 6e 2d 74 65 73 74 20 ons waiton-test
2fc0: 70 61 74 74 73 29 29 29 29 0a 20 20 20 20 20 20 patts)))).
2fd0: 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 (string-interspe
2fe0: 72 73 65 20 28 64 65 6c 65 74 65 2d 64 75 70 6c rse (delete-dupl
2ff0: 69 63 61 74 65 73 20 6e 65 77 2d 70 61 74 74 73 icates new-patts
3000: 29 20 22 2c 22 29 29 29 29 29 0a 0a 28 64 65 66 ) ",")))))..(def
3010: 69 6e 65 20 2a 67 6c 6f 62 2d 6c 69 6b 65 2d 6d ine *glob-like-m
3020: 61 74 63 68 2d 63 61 63 68 65 2a 20 28 6d 61 6b atch-cache* (mak
3030: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 28 e-hash-table)).(
3040: 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 63 61 define (tests:ca
3050: 63 68 65 2d 72 65 67 65 78 70 20 73 74 72 2d 69 che-regexp str-i
3060: 6e 20 66 6c 61 67 29 0a 20 20 28 6c 65 74 2a 20 n flag). (let*
3070: 28 28 6b 65 79 20 28 63 6f 6e 63 20 73 74 72 2d ((key (conc str-
3080: 69 6e 20 66 6c 61 67 29 29 29 0a 20 20 20 20 28 in flag))). (
3090: 6f 72 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 or (hash-table-r
30a0: 65 66 2f 64 65 66 61 75 6c 74 20 2a 67 6c 6f 62 ef/default *glob
30b0: 2d 6c 69 6b 65 2d 6d 61 74 63 68 2d 63 61 63 68 -like-match-cach
30c0: 65 2a 20 6b 65 79 20 23 66 29 0a 09 28 6c 65 74 e* key #f)..(let
30d0: 2a 20 28 28 6e 65 77 72 78 20 28 72 65 67 65 78 * ((newrx (regex
30e0: 70 20 73 74 72 2d 69 6e 20 66 6c 61 67 29 29 29 p str-in flag)))
30f0: 0a 09 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d .. (hash-table-
3100: 73 65 74 21 20 2a 67 6c 6f 62 2d 6c 69 6b 65 2d set! *glob-like-
3110: 6d 61 74 63 68 2d 63 61 63 68 65 2a 20 6b 65 79 match-cache* key
3120: 20 6e 65 77 72 78 29 0a 09 20 20 6e 65 77 72 78 newrx).. newrx
3130: 29 29 29 29 0a 0a 3b 3b 20 74 65 73 74 73 3a 67 ))))..;; tests:g
3140: 6c 6f 62 2d 6c 69 6b 65 2d 6d 61 74 63 68 20 0a lob-like-match .
3150: 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 67 (define (tests:g
3160: 6c 6f 62 2d 6c 69 6b 65 2d 6d 61 74 63 68 20 70 lob-like-match p
3170: 61 74 74 20 73 74 72 29 20 0a 20 20 28 6c 65 74 att str) . (let
3180: 2a 20 28 28 6c 69 6b 65 20 20 20 20 20 28 73 75 * ((like (su
3190: 62 73 74 72 69 6e 67 2d 69 6e 64 65 78 20 22 25 bstring-index "%
31a0: 22 20 70 61 74 74 29 29 0a 09 20 28 6e 6f 74 70 " patt)).. (notp
31b0: 61 74 74 20 20 28 65 71 75 61 6c 3f 20 28 73 75 att (equal? (su
31c0: 62 73 74 72 69 6e 67 2d 69 6e 64 65 78 20 22 7e bstring-index "~
31d0: 22 20 70 61 74 74 29 20 30 29 29 0a 09 20 28 6e " patt) 0)).. (n
31e0: 65 77 70 61 74 74 20 20 28 69 66 20 6e 6f 74 70 ewpatt (if notp
31f0: 61 74 74 20 28 73 75 62 73 74 72 69 6e 67 20 70 att (substring p
3200: 61 74 74 20 31 29 20 70 61 74 74 29 29 0a 09 20 att 1) patt))..
3210: 28 66 69 6e 70 61 74 74 20 20 28 69 66 20 6c 69 (finpatt (if li
3220: 6b 65 0a 09 09 20 20 20 20 20 20 20 28 73 74 72 ke... (str
3230: 69 6e 67 2d 73 75 62 73 74 69 74 75 74 65 20 28 ing-substitute (
3240: 72 65 67 65 78 70 20 22 25 22 29 20 22 2e 2a 22 regexp "%") ".*"
3250: 20 6e 65 77 70 61 74 74 20 23 66 29 0a 09 09 20 newpatt #f)...
3260: 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 73 75 (string-su
3270: 62 73 74 69 74 75 74 65 20 28 72 65 67 65 78 70 bstitute (regexp
3280: 20 22 5c 5c 2a 22 29 20 22 2e 2a 22 20 6e 65 77 "\\*") ".*" new
3290: 70 61 74 74 20 23 66 29 29 29 0a 09 20 28 72 78 patt #f))).. (rx
32a0: 20 20 20 20 20 20 20 28 74 65 73 74 73 3a 63 61 (tests:ca
32b0: 63 68 65 2d 72 65 67 65 78 70 20 66 69 6e 70 61 che-regexp finpa
32c0: 74 74 20 28 69 66 20 6c 69 6b 65 20 23 74 20 23 tt (if like #t #
32d0: 66 29 29 29 0a 09 20 28 72 65 73 20 20 20 20 20 f))).. (res
32e0: 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 72 (string-match r
32f0: 78 20 73 74 72 29 29 29 0a 20 20 20 20 28 69 66 x str))). (if
3300: 20 6e 6f 74 70 61 74 74 20 28 6e 6f 74 20 72 65 notpatt (not re
3310: 73 29 20 72 65 73 29 29 29 0a 0a 3b 3b 20 69 66 s) res)))..;; if
3320: 20 69 74 65 6d 70 61 74 68 20 69 73 20 23 66 20 itempath is #f
3330: 74 68 65 6e 20 6c 6f 6f 6b 20 6f 6e 6c 79 20 61 then look only a
3340: 74 20 74 68 65 20 74 65 73 74 6e 61 6d 65 20 70 t the testname p
3350: 61 72 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 art.;;.(define (
3360: 74 65 73 74 73 3a 6d 61 74 63 68 20 70 61 74 74 tests:match patt
3370: 65 72 6e 73 20 74 65 73 74 6e 61 6d 65 20 69 74 erns testname it
3380: 65 6d 70 61 74 68 20 23 21 6b 65 79 20 28 72 65 empath #!key (re
3390: 71 75 69 72 65 64 20 27 28 29 29 29 0a 20 20 28 quired '())). (
33a0: 69 66 20 28 73 74 72 69 6e 67 3f 20 70 61 74 74 if (string? patt
33b0: 65 72 6e 73 29 0a 20 20 20 20 20 20 28 6c 65 74 erns). (let
33c0: 20 28 28 70 61 74 74 73 20 28 61 70 70 65 6e 64 ((patts (append
33d0: 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 70 (string-split p
33e0: 61 74 74 65 72 6e 73 20 22 2c 22 29 20 72 65 71 atterns ",") req
33f0: 75 69 72 65 64 29 29 29 0a 09 28 69 66 20 28 6e uired)))..(if (n
3400: 75 6c 6c 3f 20 70 61 74 74 73 29 20 3b 3b 3b 20 ull? patts) ;;;
3410: 6e 6f 20 70 61 74 74 65 72 6e 28 73 29 20 6d 65 no pattern(s) me
3420: 61 6e 73 20 6e 6f 20 6d 61 74 63 68 0a 09 20 20 ans no match..
3430: 20 20 23 66 0a 09 20 20 20 20 28 6c 65 74 20 6c #f.. (let l
3440: 6f 6f 70 20 28 28 70 61 74 74 20 28 63 61 72 20 oop ((patt (car
3450: 70 61 74 74 73 29 29 0a 09 09 20 20 20 20 20 20 patts))...
3460: 20 28 74 61 6c 20 20 28 63 64 72 20 70 61 74 74 (tal (cdr patt
3470: 73 29 29 29 0a 09 20 20 20 20 20 20 3b 3b 20 28 s))).. ;; (
3480: 70 72 69 6e 74 20 22 6c 6f 6f 70 3a 20 70 61 74 print "loop: pat
3490: 74 3a 20 22 20 70 61 74 74 20 22 2c 20 74 61 6c t: " patt ", tal
34a0: 20 22 20 74 61 6c 29 0a 09 20 20 20 20 20 20 28 " tal).. (
34b0: 69 66 20 28 73 74 72 69 6e 67 3d 3f 20 70 61 74 if (string=? pat
34c0: 74 20 22 22 29 0a 09 09 20 20 23 66 20 3b 3b 20 t "")... #f ;;
34d0: 6e 6f 74 68 69 6e 67 20 65 76 65 72 20 6d 61 74 nothing ever mat
34e0: 63 68 65 73 20 65 6d 70 74 79 20 73 74 72 69 6e ches empty strin
34f0: 67 20 2d 20 70 6f 6c 69 63 79 0a 09 09 20 20 28 g - policy... (
3500: 6c 65 74 2a 20 28 28 70 61 74 74 2d 70 61 72 74 let* ((patt-part
3510: 73 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 s (string-match
3520: 28 72 65 67 65 78 70 20 22 5e 28 5b 5e 5c 5c 2f (regexp "^([^\\/
3530: 5d 2a 29 28 5c 5c 2f 28 2e 2a 29 7c 29 24 22 29 ]*)(\\/(.*)|)$")
3540: 20 70 61 74 74 29 29 0a 09 09 09 20 28 74 65 73 patt)).... (tes
3550: 74 2d 70 61 74 74 20 20 28 63 61 64 72 20 70 61 t-patt (cadr pa
3560: 74 74 2d 70 61 72 74 73 29 29 0a 09 09 09 20 28 tt-parts)).... (
3570: 69 74 65 6d 2d 70 61 74 74 20 20 28 63 61 64 64 item-patt (cadd
3580: 64 72 20 70 61 74 74 2d 70 61 72 74 73 29 29 29 dr patt-parts)))
3590: 0a 09 09 20 20 20 20 3b 3b 20 73 70 65 63 69 61 ... ;; specia
35a0: 6c 20 63 61 73 65 3a 20 74 65 73 74 20 76 73 2e l case: test vs.
35b0: 20 74 65 73 74 2f 0a 09 09 20 20 20 20 3b 3b 20 test/... ;;
35c0: 20 20 74 65 73 74 20 20 3d 3e 20 22 74 65 73 74 test => "test
35d0: 22 20 22 25 22 0a 09 09 20 20 20 20 3b 3b 20 20 " "%"... ;;
35e0: 20 74 65 73 74 2f 20 3d 3e 20 22 74 65 73 74 22 test/ => "test"
35f0: 20 22 22 0a 09 09 20 20 20 20 28 69 66 20 28 61 ""... (if (a
3600: 6e 64 20 28 6e 6f 74 20 28 73 75 62 73 74 72 69 nd (not (substri
3610: 6e 67 2d 69 6e 64 65 78 20 22 2f 22 20 70 61 74 ng-index "/" pat
3620: 74 29 29 20 3b 3b 20 6e 6f 20 73 6c 61 73 68 20 t)) ;; no slash
3630: 69 6e 20 74 68 65 20 6f 72 69 67 69 6e 61 6c 0a in the original.
3640: 09 09 09 20 20 20 20 20 28 6f 72 20 28 6e 6f 74 ... (or (not
3650: 20 69 74 65 6d 2d 70 61 74 74 29 0a 09 09 09 09 item-patt).....
3660: 20 28 65 71 75 61 6c 3f 20 69 74 65 6d 2d 70 61 (equal? item-pa
3670: 74 74 20 22 22 29 29 29 20 20 20 20 20 20 3b 3b tt ""))) ;;
3680: 20 73 68 6f 75 6c 64 20 61 6c 77 61 79 73 20 62 should always b
3690: 65 20 74 72 75 65 20 74 68 61 74 20 69 74 65 6d e true that item
36a0: 2d 70 61 74 74 20 69 73 20 22 22 0a 09 09 09 28 -patt is ""....(
36b0: 73 65 74 21 20 69 74 65 6d 2d 70 61 74 74 20 22 set! item-patt "
36c0: 25 22 29 29 0a 09 09 20 20 20 20 3b 3b 20 28 70 %"))... ;; (p
36d0: 72 69 6e 74 20 22 74 65 73 74 73 3a 6d 61 74 63 rint "tests:matc
36e0: 68 20 3d 3e 20 70 61 74 74 2d 70 61 72 74 73 3a h => patt-parts:
36f0: 20 22 20 70 61 74 74 2d 70 61 72 74 73 20 22 2c " patt-parts ",
3700: 20 74 65 73 74 2d 70 61 74 74 3a 20 22 20 74 65 test-patt: " te
3710: 73 74 2d 70 61 74 74 20 22 2c 20 69 74 65 6d 2d st-patt ", item-
3720: 70 61 74 74 3a 20 22 20 69 74 65 6d 2d 70 61 74 patt: " item-pat
3730: 74 29 0a 09 09 20 20 20 20 28 69 66 20 28 61 6e t)... (if (an
3740: 64 20 28 74 65 73 74 73 3a 67 6c 6f 62 2d 6c 69 d (tests:glob-li
3750: 6b 65 2d 6d 61 74 63 68 20 74 65 73 74 2d 70 61 ke-match test-pa
3760: 74 74 20 74 65 73 74 6e 61 6d 65 29 0a 09 09 09 tt testname)....
3770: 20 20 20 20 20 28 6f 72 20 28 6e 6f 74 20 69 74 (or (not it
3780: 65 6d 70 61 74 68 29 0a 09 09 09 09 20 28 74 65 empath)..... (te
3790: 73 74 73 3a 67 6c 6f 62 2d 6c 69 6b 65 2d 6d 61 sts:glob-like-ma
37a0: 74 63 68 20 28 69 66 20 69 74 65 6d 2d 70 61 74 tch (if item-pat
37b0: 74 20 69 74 65 6d 2d 70 61 74 74 20 22 22 29 20 t item-patt "")
37c0: 69 74 65 6d 70 61 74 68 29 29 29 0a 09 09 09 23 itempath)))....#
37d0: 74 0a 09 09 09 28 69 66 20 28 6e 75 6c 6c 3f 20 t....(if (null?
37e0: 74 61 6c 29 0a 09 09 09 20 20 20 20 23 66 0a 09 tal).... #f..
37f0: 09 09 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 .. (loop (car
3800: 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 29 29 tal)(cdr tal)))
3810: 29 29 29 29 29 29 29 29 0a 0a 3b 3b 20 69 66 20 ))))))))..;; if
3820: 69 74 65 6d 70 61 74 68 20 69 73 20 23 66 20 74 itempath is #f t
3830: 68 65 6e 20 6c 6f 6f 6b 20 6f 6e 6c 79 20 61 74 hen look only at
3840: 20 74 68 65 20 74 65 73 74 6e 61 6d 65 20 70 61 the testname pa
3850: 72 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 rt.;;.(define (t
3860: 65 73 74 73 3a 6d 61 74 63 68 2d 3e 73 71 6c 71 ests:match->sqlq
3870: 72 79 20 70 61 74 74 65 72 6e 73 29 0a 20 20 28 ry patterns). (
3880: 69 66 20 28 73 74 72 69 6e 67 3f 20 70 61 74 74 if (string? patt
3890: 65 72 6e 73 29 0a 20 20 20 20 20 20 28 6c 65 74 erns). (let
38a0: 20 28 28 70 61 74 74 73 20 28 73 74 72 69 6e 67 ((patts (string
38b0: 2d 73 70 6c 69 74 20 70 61 74 74 65 72 6e 73 20 -split patterns
38c0: 22 2c 22 29 29 29 0a 09 28 69 66 20 28 6e 75 6c ",")))..(if (nul
38d0: 6c 3f 20 70 61 74 74 73 29 20 3b 3b 3b 20 6e 6f l? patts) ;;; no
38e0: 20 70 61 74 74 65 72 6e 28 73 29 20 6d 65 61 6e pattern(s) mean
38f0: 73 20 6e 6f 20 6d 61 74 63 68 2c 20 77 65 20 77 s no match, we w
3900: 69 6c 6c 20 64 6f 20 6e 6f 20 71 75 65 72 79 0a ill do no query.
3910: 09 20 20 20 20 23 66 0a 09 20 20 20 20 28 6c 65 . #f.. (le
3920: 74 20 6c 6f 6f 70 20 28 28 70 61 74 74 20 28 63 t loop ((patt (c
3930: 61 72 20 70 61 74 74 73 29 29 0a 09 09 20 20 20 ar patts))...
3940: 20 20 20 20 28 74 61 6c 20 20 28 63 64 72 20 70 (tal (cdr p
3950: 61 74 74 73 29 29 0a 09 09 20 20 20 20 20 20 20 atts))...
3960: 28 72 65 73 20 20 27 28 29 29 29 0a 09 20 20 20 (res '()))..
3970: 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 6c 6f ;; (print "lo
3980: 6f 70 3a 20 70 61 74 74 3a 20 22 20 70 61 74 74 op: patt: " patt
3990: 20 22 2c 20 74 61 6c 20 22 20 74 61 6c 29 0a 09 ", tal " tal)..
39a0: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 70 61 (let* ((pa
39b0: 74 74 2d 70 61 72 74 73 20 28 73 74 72 69 6e 67 tt-parts (string
39c0: 2d 6d 61 74 63 68 20 28 72 65 67 65 78 70 20 22 -match (regexp "
39d0: 5e 28 5b 5e 5c 5c 2f 5d 2a 29 28 5c 5c 2f 28 2e ^([^\\/]*)(\\/(.
39e0: 2a 29 7c 29 24 22 29 20 70 61 74 74 29 29 0a 09 *)|)$") patt))..
39f0: 09 20 20 20 20 20 28 74 65 73 74 2d 70 61 74 74 . (test-patt
3a00: 20 20 28 63 61 64 72 20 70 61 74 74 2d 70 61 72 (cadr patt-par
3a10: 74 73 29 29 0a 09 09 20 20 20 20 20 28 69 74 65 ts))... (ite
3a20: 6d 2d 70 61 74 74 20 20 28 63 61 64 64 64 72 20 m-patt (cadddr
3a30: 70 61 74 74 2d 70 61 72 74 73 29 29 0a 09 09 20 patt-parts))...
3a40: 20 20 20 20 28 74 65 73 74 2d 71 72 79 20 20 20 (test-qry
3a50: 28 64 62 3a 70 61 74 74 2d 3e 6c 69 6b 65 20 22 (db:patt->like "
3a60: 74 65 73 74 6e 61 6d 65 22 20 74 65 73 74 2d 70 testname" test-p
3a70: 61 74 74 29 29 0a 09 09 20 20 20 20 20 28 69 74 att))... (it
3a80: 65 6d 2d 71 72 79 20 20 20 28 64 62 3a 70 61 74 em-qry (db:pat
3a90: 74 2d 3e 6c 69 6b 65 20 22 69 74 65 6d 5f 70 61 t->like "item_pa
3aa0: 74 68 22 20 69 74 65 6d 2d 70 61 74 74 29 29 0a th" item-patt)).
3ab0: 09 09 20 20 20 20 20 28 71 72 79 20 20 20 20 20 .. (qry
3ac0: 20 20 20 28 63 6f 6e 63 20 22 28 22 20 74 65 73 (conc "(" tes
3ad0: 74 2d 71 72 79 20 22 20 41 4e 44 20 22 20 69 74 t-qry " AND " it
3ae0: 65 6d 2d 71 72 79 20 22 29 22 29 29 29 0a 09 09 em-qry ")")))...
3af0: 3b 3b 20 28 70 72 69 6e 74 20 22 74 65 73 74 73 ;; (print "tests
3b00: 3a 6d 61 74 63 68 20 3d 3e 20 70 61 74 74 2d 70 :match => patt-p
3b10: 61 72 74 73 3a 20 22 20 70 61 74 74 2d 70 61 72 arts: " patt-par
3b20: 74 73 20 22 2c 20 74 65 73 74 2d 70 61 74 74 3a ts ", test-patt:
3b30: 20 22 20 74 65 73 74 2d 70 61 74 74 20 22 2c 20 " test-patt ",
3b40: 69 74 65 6d 2d 70 61 74 74 3a 20 22 20 69 74 65 item-patt: " ite
3b50: 6d 2d 70 61 74 74 29 0a 09 09 28 69 66 20 28 6e m-patt)...(if (n
3b60: 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 20 20 20 20 ull? tal)...
3b70: 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 (string-interspe
3b80: 72 73 65 20 28 61 70 70 65 6e 64 20 28 72 65 76 rse (append (rev
3b90: 65 72 73 65 20 72 65 73 29 28 6c 69 73 74 20 71 erse res)(list q
3ba0: 72 79 29 29 20 22 20 4f 52 20 22 29 0a 09 09 20 ry)) " OR ")...
3bb0: 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 (loop (car ta
3bc0: 6c 29 28 63 64 72 20 74 61 6c 29 28 63 6f 6e 73 l)(cdr tal)(cons
3bd0: 20 71 72 79 20 72 65 73 29 29 29 29 29 29 29 0a qry res))))))).
3be0: 20 20 20 20 20 20 23 66 29 29 0a 0a 3b 3b 20 43 #f))..;; C
3bf0: 68 65 63 6b 20 66 6f 72 20 77 61 69 76 65 72 20 heck for waiver
3c00: 65 6c 69 67 69 62 69 6c 69 74 79 0a 3b 3b 0a 28 eligibility.;;.(
3c10: 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 63 68 define (tests:ch
3c20: 65 63 6b 2d 77 61 69 76 65 72 2d 65 6c 69 67 69 eck-waiver-eligi
3c30: 62 69 6c 69 74 79 20 74 65 73 74 64 61 74 20 70 bility testdat p
3c40: 72 65 76 2d 74 65 73 74 64 61 74 29 0a 20 20 28 rev-testdat). (
3c50: 6c 65 74 2a 20 28 28 74 65 73 74 2d 72 65 67 69 let* ((test-regi
3c60: 73 74 72 79 20 28 6d 61 6b 65 2d 68 61 73 68 2d stry (make-hash-
3c70: 74 61 62 6c 65 29 29 0a 09 20 28 74 65 73 74 63 table)).. (testc
3c80: 6f 6e 66 69 67 20 20 28 74 65 73 74 73 3a 67 65 onfig (tests:ge
3c90: 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 28 64 62 t-testconfig (db
3ca0: 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 :test-get-testna
3cb0: 6d 65 20 74 65 73 74 64 61 74 29 20 28 64 62 3a me testdat) (db:
3cc0: 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 test-get-item-pa
3cd0: 74 68 20 74 65 73 74 64 61 74 29 20 74 65 73 74 th testdat) test
3ce0: 2d 72 65 67 69 73 74 72 79 20 23 66 29 29 0a 09 -registry #f))..
3cf0: 20 28 74 65 73 74 2d 72 75 6e 64 69 72 20 3b 3b (test-rundir ;;
3d00: 20 28 73 64 62 3a 71 72 79 20 27 70 61 73 73 73 (sdb:qry 'passs
3d10: 74 72 20 0a 09 20 20 28 64 62 3a 74 65 73 74 2d tr .. (db:test-
3d20: 67 65 74 2d 72 75 6e 64 69 72 20 74 65 73 74 64 get-rundir testd
3d30: 61 74 29 29 20 3b 3b 20 29 0a 09 20 28 70 72 65 at)) ;; ).. (pre
3d40: 76 2d 72 75 6e 64 69 72 20 3b 3b 20 28 73 64 62 v-rundir ;; (sdb
3d50: 3a 71 72 79 20 27 70 61 73 73 73 74 72 20 0a 09 :qry 'passstr ..
3d60: 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 (db:test-get-r
3d70: 75 6e 64 69 72 20 70 72 65 76 2d 74 65 73 74 64 undir prev-testd
3d80: 61 74 29 29 20 3b 3b 20 29 0a 09 20 28 77 61 69 at)) ;; ).. (wai
3d90: 76 65 72 73 20 20 20 20 20 28 69 66 20 74 65 73 vers (if tes
3da0: 74 63 6f 6e 66 69 67 20 28 63 6f 6e 66 69 67 66 tconfig (configf
3db0: 3a 73 65 63 74 69 6f 6e 2d 76 61 72 73 20 74 65 :section-vars te
3dc0: 73 74 63 6f 6e 66 69 67 20 22 77 61 69 76 65 72 stconfig "waiver
3dd0: 73 22 29 20 27 28 29 29 29 0a 09 20 28 77 61 69 s") '())).. (wai
3de0: 76 65 72 2d 72 78 20 20 20 28 72 65 67 65 78 70 ver-rx (regexp
3df0: 20 22 5e 28 5c 5c 53 2b 29 5c 5c 73 2b 28 2e 2a "^(\\S+)\\s+(.*
3e00: 29 24 22 29 29 0a 09 20 28 64 69 66 66 2d 72 75 )$")).. (diff-ru
3e10: 6c 65 20 20 20 22 64 69 66 66 20 25 66 69 6c 65 le "diff %file
3e20: 31 25 20 25 66 69 6c 65 32 25 22 29 0a 09 20 28 1% %file2%").. (
3e30: 6c 6f 67 70 72 6f 2d 72 75 6c 65 20 22 64 69 66 logpro-rule "dif
3e40: 66 20 25 66 69 6c 65 31 25 20 25 66 69 6c 65 32 f %file1% %file2
3e50: 25 20 7c 20 6c 6f 67 70 72 6f 20 25 77 61 69 76 % | logpro %waiv
3e60: 65 72 6e 61 6d 65 25 2e 6c 6f 67 70 72 6f 20 25 ername%.logpro %
3e70: 77 61 69 76 65 72 6e 61 6d 65 25 2e 68 74 6d 6c waivername%.html
3e80: 22 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 ")). (if (not
3e90: 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 (common:file-ex
3ea0: 69 73 74 73 3f 20 74 65 73 74 2d 72 75 6e 64 69 ists? test-rundi
3eb0: 72 29 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 r))..(begin.. (
3ec0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f debug:print-erro
3ed0: 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 r 0 *default-log
3ee0: 2d 70 6f 72 74 2a 20 22 74 65 73 74 20 72 75 6e -port* "test run
3ef0: 20 64 69 72 65 63 74 6f 72 79 20 69 73 20 67 6f directory is go
3f00: 6e 65 2c 20 63 61 6e 6e 6f 74 20 70 72 6f 70 61 ne, cannot propa
3f10: 67 61 74 65 20 77 61 69 76 65 72 22 29 0a 09 20 gate waiver")..
3f20: 20 23 66 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 #f)..(begin..
3f30: 28 70 75 73 68 2d 64 69 72 65 63 74 6f 72 79 20 (push-directory
3f40: 74 65 73 74 2d 72 75 6e 64 69 72 29 0a 09 20 20 test-rundir)..
3f50: 28 6c 65 74 20 28 28 72 65 73 75 6c 74 20 28 69 (let ((result (i
3f60: 66 20 28 6e 75 6c 6c 3f 20 77 61 69 76 65 72 73 f (null? waivers
3f70: 29 0a 09 09 09 20 20 20 20 23 66 0a 09 09 09 20 ).... #f....
3f80: 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 (let loop ((h
3f90: 65 64 20 28 63 61 72 20 77 61 69 76 65 72 73 29 ed (car waivers)
3fa0: 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 74 61 )..... (ta
3fb0: 6c 20 28 63 64 72 20 77 61 69 76 65 72 73 29 29 l (cdr waivers))
3fc0: 29 0a 09 09 09 20 20 20 20 20 20 28 64 65 62 75 ).... (debu
3fd0: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
3fe0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 4e lt-log-port* "IN
3ff0: 46 4f 3a 20 41 70 70 6c 79 69 6e 67 20 77 61 69 FO: Applying wai
4000: 76 65 72 20 72 75 6c 65 20 5c 22 22 20 68 65 64 ver rule \"" hed
4010: 20 22 5c 22 22 29 0a 09 09 09 20 20 20 20 20 20 "\"")....
4020: 28 6c 65 74 2a 20 28 28 77 61 69 76 65 72 20 20 (let* ((waiver
4030: 20 20 20 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f (configf:loo
4040: 6b 75 70 20 74 65 73 74 63 6f 6e 66 69 67 20 22 kup testconfig "
4050: 77 61 69 76 65 72 73 22 20 68 65 64 29 29 0a 09 waivers" hed))..
4060: 09 09 09 20 20 20 20 20 28 77 70 61 72 74 73 20 ... (wparts
4070: 20 20 20 20 20 28 69 66 20 77 61 69 76 65 72 20 (if waiver
4080: 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 77 61 (string-match wa
4090: 69 76 65 72 2d 72 78 20 77 61 69 76 65 72 29 20 iver-rx waiver)
40a0: 23 66 29 29 0a 09 09 09 09 20 20 20 20 20 28 77 #f))..... (w
40b0: 61 69 76 65 72 2d 72 75 6c 65 20 28 69 66 20 77 aiver-rule (if w
40c0: 70 61 72 74 73 20 28 63 61 64 72 20 77 70 61 72 parts (cadr wpar
40d0: 74 73 29 20 20 23 66 29 29 0a 09 09 09 09 20 20 ts) #f)).....
40e0: 20 20 20 28 77 61 69 76 65 72 2d 67 6c 6f 62 20 (waiver-glob
40f0: 28 69 66 20 77 70 61 72 74 73 20 28 63 61 64 64 (if wparts (cadd
4100: 72 20 77 70 61 72 74 73 29 20 23 66 29 29 0a 09 r wparts) #f))..
4110: 09 09 09 20 20 20 20 20 28 6c 6f 67 70 72 6f 2d ... (logpro-
4120: 66 69 6c 65 20 28 69 66 20 77 61 69 76 65 72 0a file (if waiver.
4130: 09 09 09 09 09 09 20 20 20 20 20 20 28 6c 65 74 ...... (let
4140: 20 28 28 66 6e 61 6d 65 20 28 63 6f 6e 63 20 68 ((fname (conc h
4150: 65 64 20 22 2e 6c 6f 67 70 72 6f 22 29 29 29 0a ed ".logpro"))).
4160: 09 09 09 09 09 09 09 28 69 66 20 28 63 6f 6d 6d .......(if (comm
4170: 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 on:file-exists?
4180: 66 6e 61 6d 65 29 0a 09 09 09 09 09 09 09 20 20 fname)........
4190: 20 20 66 6e 61 6d 65 20 0a 09 09 09 09 09 09 09 fname ........
41a0: 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 09 09 (begin......
41b0: 09 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 .. (debug:p
41c0: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
41d0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a log-port* "INFO:
41e0: 20 4e 6f 20 6c 6f 67 70 72 6f 20 66 69 6c 65 20 No logpro file
41f0: 22 20 66 6e 61 6d 65 20 22 20 66 61 6c 6c 69 6e " fname " fallin
4200: 67 20 62 61 63 6b 20 74 6f 20 64 69 66 66 22 29 g back to diff")
4210: 0a 09 09 09 09 09 09 09 20 20 20 20 20 20 23 66 ........ #f
4220: 29 29 29 0a 09 09 09 09 09 09 20 20 20 20 20 20 ))).......
4230: 23 66 29 29 0a 09 09 09 09 20 20 20 20 20 3b 3b #f))..... ;;
4240: 20 69 66 20 72 75 6c 65 20 62 79 20 6e 61 6d 65 if rule by name
4250: 20 6f 66 20 77 61 69 76 65 72 2d 72 75 6c 65 20 of waiver-rule
4260: 69 73 20 66 6f 75 6e 64 20 69 6e 20 74 65 73 74 is found in test
4270: 63 6f 6e 66 69 67 20 2d 20 75 73 65 20 69 74 0a config - use it.
4280: 09 09 09 09 20 20 20 20 20 3b 3b 20 65 6c 73 65 .... ;; else
4290: 20 69 66 20 77 61 69 76 65 72 6e 61 6d 65 2e 6c if waivername.l
42a0: 6f 67 70 72 6f 20 65 78 69 73 74 73 20 75 73 65 ogpro exists use
42b0: 20 6c 6f 67 70 72 6f 2d 72 75 6c 65 0a 09 09 09 logpro-rule....
42c0: 09 20 20 20 20 20 3b 3b 20 65 6c 73 65 20 64 65 . ;; else de
42d0: 66 61 75 6c 74 20 74 6f 20 64 69 66 66 2d 72 75 fault to diff-ru
42e0: 6c 65 0a 09 09 09 09 20 20 20 20 20 28 72 75 6c le..... (rul
42f0: 65 2d 73 74 72 69 6e 67 20 28 6c 65 74 20 28 28 e-string (let ((
4300: 72 75 6c 65 20 28 63 6f 6e 66 69 67 66 3a 6c 6f rule (configf:lo
4310: 6f 6b 75 70 20 74 65 73 74 63 6f 6e 66 69 67 20 okup testconfig
4320: 22 77 61 69 76 65 72 5f 72 75 6c 65 73 22 20 77 "waiver_rules" w
4330: 61 69 76 65 72 2d 72 75 6c 65 29 29 29 0a 09 09 aiver-rule)))...
4340: 09 09 09 09 20 20 20 20 28 69 66 20 72 75 6c 65 .... (if rule
4350: 0a 09 09 09 09 09 09 09 72 75 6c 65 0a 09 09 09 ........rule....
4360: 09 09 09 09 28 69 66 20 6c 6f 67 70 72 6f 2d 66 ....(if logpro-f
4370: 69 6c 65 0a 09 09 09 09 09 09 09 20 20 20 20 6c ile........ l
4380: 6f 67 70 72 6f 2d 72 75 6c 65 0a 09 09 09 09 09 ogpro-rule......
4390: 09 09 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 .. (begin....
43a0: 09 09 09 09 20 20 20 20 20 20 28 64 65 62 75 67 .... (debug
43b0: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
43c0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 4e 46 t-log-port* "INF
43d0: 4f 3a 20 4e 6f 20 6c 6f 67 70 72 6f 20 66 69 6c O: No logpro fil
43e0: 65 20 22 20 6c 6f 67 70 72 6f 2d 66 69 6c 65 20 e " logpro-file
43f0: 22 20 66 6f 75 6e 64 2c 20 75 73 69 6e 67 20 64 " found, using d
4400: 69 66 66 20 72 75 6c 65 22 29 0a 09 09 09 09 09 iff rule")......
4410: 09 09 20 20 20 20 20 20 64 69 66 66 2d 72 75 6c .. diff-rul
4420: 65 29 29 29 29 29 0a 09 09 09 09 20 20 20 20 20 e))))).....
4430: 3b 3b 20 28 73 74 72 69 6e 67 2d 73 75 62 73 74 ;; (string-subst
4440: 69 74 75 74 65 20 22 25 66 69 6c 65 31 25 22 20 itute "%file1%"
4450: 22 66 6f 6f 66 6f 6f 2e 74 78 74 22 20 22 54 68 "foofoo.txt" "Th
4460: 69 73 20 69 73 20 25 66 69 6c 65 31 25 20 61 6e is is %file1% an
4470: 64 20 73 6f 20 69 73 20 74 68 69 73 20 25 66 69 d so is this %fi
4480: 6c 65 31 25 2e 22 20 23 74 29 0a 09 09 09 09 20 le1%." #t).....
4490: 20 20 20 20 28 70 72 6f 63 65 73 73 65 64 2d 63 (processed-c
44a0: 6d 64 20 28 73 74 72 69 6e 67 2d 73 75 62 73 74 md (string-subst
44b0: 69 74 75 74 65 20 0a 09 09 09 09 09 09 20 20 20 itute .......
44c0: 20 20 22 25 66 69 6c 65 31 25 22 20 28 63 6f 6e "%file1%" (con
44d0: 63 20 74 65 73 74 2d 72 75 6e 64 69 72 20 22 2f c test-rundir "/
44e0: 22 20 77 61 69 76 65 72 2d 67 6c 6f 62 29 0a 09 " waiver-glob)..
44f0: 09 09 09 09 09 20 20 20 20 20 28 73 74 72 69 6e ..... (strin
4500: 67 2d 73 75 62 73 74 69 74 75 74 65 0a 09 09 09 g-substitute....
4510: 09 09 09 20 20 20 20 20 20 22 25 66 69 6c 65 32 ... "%file2
4520: 25 22 20 28 63 6f 6e 63 20 70 72 65 76 2d 72 75 %" (conc prev-ru
4530: 6e 64 69 72 20 22 2f 22 20 77 61 69 76 65 72 2d ndir "/" waiver-
4540: 67 6c 6f 62 29 0a 09 09 09 09 09 09 20 20 20 20 glob).......
4550: 20 20 28 73 74 72 69 6e 67 2d 73 75 62 73 74 69 (string-substi
4560: 74 75 74 65 0a 09 09 09 09 09 09 20 20 20 20 20 tute.......
4570: 20 20 22 25 77 61 69 76 65 72 6e 61 6d 65 25 22 "%waivername%"
4580: 20 68 65 64 20 72 75 6c 65 2d 73 74 72 69 6e 67 hed rule-string
4590: 20 23 74 29 20 23 74 29 20 23 74 29 29 0a 09 09 #t) #t) #t))...
45a0: 09 09 20 20 20 20 20 28 72 65 73 20 20 20 20 20 .. (res
45b0: 20 20 20 20 20 20 20 23 66 29 29 0a 09 09 09 09 #f)).....
45c0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
45d0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
45e0: 2a 20 22 49 4e 46 4f 3a 20 77 61 69 76 65 72 20 * "INFO: waiver
45f0: 63 6f 6d 6d 61 6e 64 20 69 73 20 5c 22 22 20 70 command is \"" p
4600: 72 6f 63 65 73 73 65 64 2d 63 6d 64 20 22 5c 22 rocessed-cmd "\"
4610: 22 29 0a 09 09 09 09 28 69 66 20 28 65 71 3f 20 ").....(if (eq?
4620: 28 73 79 73 74 65 6d 20 70 72 6f 63 65 73 73 65 (system processe
4630: 64 2d 63 6d 64 29 20 30 29 0a 09 09 09 09 20 20 d-cmd) 0).....
4640: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c (if (null? tal
4650: 29 0a 09 09 09 09 09 23 74 0a 09 09 09 09 09 28 )......#t......(
4660: 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 loop (car tal)(c
4670: 64 72 20 74 61 6c 29 29 29 0a 09 09 09 09 20 20 dr tal))).....
4680: 20 20 23 66 29 29 29 29 29 29 0a 09 20 20 20 20 #f))))))..
4690: 28 70 6f 70 2d 64 69 72 65 63 74 6f 72 79 29 0a (pop-directory).
46a0: 09 20 20 20 20 72 65 73 75 6c 74 29 29 29 29 29 . result)))))
46b0: 0a 0a 3b 3b 20 44 6f 20 6e 6f 74 20 72 70 63 20 ..;; Do not rpc
46c0: 74 68 69 73 20 6f 6e 65 2c 20 64 6f 20 74 68 65 this one, do the
46d0: 20 75 6e 64 65 72 6c 79 69 6e 67 20 63 61 6c 6c underlying call
46e0: 73 21 21 21 0a 28 64 65 66 69 6e 65 20 28 74 65 s!!!.(define (te
46f0: 73 74 73 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 sts:test-set-sta
4700: 74 75 73 21 20 72 75 6e 2d 69 64 20 74 65 73 74 tus! run-id test
4710: 2d 69 64 20 73 74 61 74 65 20 73 74 61 74 75 73 -id state status
4720: 20 63 6f 6d 6d 65 6e 74 20 64 61 74 20 23 21 6b comment dat #!k
4730: 65 79 20 28 77 6f 72 6b 2d 61 72 65 61 20 23 66 ey (work-area #f
4740: 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 72 65 61 )). (let* ((rea
4750: 6c 2d 73 74 61 74 75 73 20 73 74 61 74 75 73 29 l-status status)
4760: 0a 09 20 28 6f 74 68 65 72 64 61 74 20 20 20 20 .. (otherdat
4770: 28 69 66 20 64 61 74 20 64 61 74 20 28 6d 61 6b (if dat dat (mak
4780: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 0a e-hash-table))).
4790: 09 20 28 74 65 73 74 64 61 74 20 20 20 20 20 28 . (testdat (
47a0: 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 rmt:get-test-inf
47b0: 6f 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 74 o-by-id run-id t
47c0: 65 73 74 2d 69 64 29 29 0a 09 20 28 74 65 73 74 est-id)).. (test
47d0: 2d 6e 61 6d 65 20 20 20 28 64 62 3a 74 65 73 74 -name (db:test
47e0: 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 20 74 -get-testname t
47f0: 65 73 74 64 61 74 29 29 0a 09 20 28 69 74 65 6d estdat)).. (item
4800: 2d 70 61 74 68 20 20 20 28 64 62 3a 74 65 73 74 -path (db:test
4810: 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 -get-item-path t
4820: 65 73 74 64 61 74 29 29 0a 09 20 3b 3b 20 62 65 estdat)).. ;; be
4830: 66 6f 72 65 20 70 72 6f 63 65 65 64 69 6e 67 20 fore proceeding
4840: 77 65 20 6d 75 73 74 20 66 69 6e 64 20 6f 75 74 we must find out
4850: 20 69 66 20 74 68 65 20 70 72 65 76 69 6f 75 73 if the previous
4860: 20 74 65 73 74 20 28 77 68 65 72 65 20 61 6c 6c test (where all
4870: 20 6b 65 79 73 20 6d 61 74 63 68 65 64 20 65 78 keys matched ex
4880: 63 65 70 74 20 72 75 6e 6e 61 6d 65 29 0a 09 20 cept runname)..
4890: 3b 3b 20 77 61 73 20 57 41 49 56 45 44 20 69 66 ;; was WAIVED if
48a0: 20 74 68 69 73 20 74 65 73 74 20 69 73 20 46 41 this test is FA
48b0: 49 4c 0a 0a 09 20 3b 3b 20 4e 4f 54 45 53 3a 0a IL... ;; NOTES:.
48c0: 09 20 3b 3b 20 20 31 2e 20 49 73 20 74 68 65 20 . ;; 1. Is the
48d0: 63 61 6c 6c 20 74 6f 20 74 65 73 74 3a 67 65 74 call to test:get
48e0: 2d 70 72 65 76 69 6f 75 73 2d 72 75 6e 2d 72 65 -previous-run-re
48f0: 63 6f 72 64 20 72 65 6d 6f 74 69 66 69 65 64 3f cord remotified?
4900: 0a 09 20 3b 3b 20 20 32 2e 20 41 64 64 20 74 65 .. ;; 2. Add te
4910: 73 74 20 66 6f 72 20 74 65 73 74 63 6f 6e 66 69 st for testconfi
4920: 67 20 77 61 69 76 65 72 20 70 72 6f 70 61 67 61 g waiver propaga
4930: 74 69 6f 6e 20 63 6f 6e 74 72 6f 6c 20 68 65 72 tion control her
4940: 65 0a 09 20 3b 3b 0a 09 20 28 70 72 65 76 2d 74 e.. ;;.. (prev-t
4950: 65 73 74 20 20 20 28 69 66 20 28 65 71 75 61 6c est (if (equal
4960: 3f 20 73 74 61 74 75 73 20 22 46 41 49 4c 22 29 ? status "FAIL")
4970: 0a 09 09 09 20 20 28 72 6d 74 3a 67 65 74 2d 70 .... (rmt:get-p
4980: 72 65 76 69 6f 75 73 2d 74 65 73 74 2d 72 75 6e revious-test-run
4990: 2d 72 65 63 6f 72 64 20 72 75 6e 2d 69 64 20 74 -record run-id t
49a0: 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 est-name item-pa
49b0: 74 68 29 0a 09 09 09 20 20 23 66 29 29 0a 09 20 th).... #f))..
49c0: 28 77 61 69 76 65 64 20 20 20 28 69 66 20 70 72 (waived (if pr
49d0: 65 76 2d 74 65 73 74 0a 09 09 20 20 20 20 20 20 ev-test...
49e0: 20 28 69 66 20 70 72 65 76 2d 74 65 73 74 20 3b (if prev-test ;
49f0: 3b 20 74 72 75 65 20 69 66 20 77 65 20 66 6f 75 ; true if we fou
4a00: 6e 64 20 61 20 70 72 65 76 69 6f 75 73 20 74 65 nd a previous te
4a10: 73 74 20 69 6e 20 74 68 69 73 20 72 75 6e 20 73 st in this run s
4a20: 65 72 69 65 73 0a 09 09 09 20 20 20 28 6c 65 74 eries.... (let
4a30: 20 28 28 70 72 65 76 2d 73 74 61 74 75 73 20 20 ((prev-status
4a40: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 (db:test-get-sta
4a50: 74 75 73 20 20 70 72 65 76 2d 74 65 73 74 29 29 tus prev-test))
4a60: 0a 09 09 09 09 20 28 70 72 65 76 2d 73 74 61 74 ..... (prev-stat
4a70: 65 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 e (db:test-get
4a80: 2d 73 74 61 74 65 20 20 20 70 72 65 76 2d 74 65 -state prev-te
4a90: 73 74 29 29 0a 09 09 09 09 20 28 70 72 65 76 2d st))..... (prev-
4aa0: 63 6f 6d 6d 65 6e 74 20 28 64 62 3a 74 65 73 74 comment (db:test
4ab0: 2d 67 65 74 2d 63 6f 6d 6d 65 6e 74 20 70 72 65 -get-comment pre
4ac0: 76 2d 74 65 73 74 29 29 29 0a 09 09 09 20 20 20 v-test)))....
4ad0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 (debug:print 4
4ae0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
4af0: 72 74 2a 20 22 70 72 65 76 2d 73 74 61 74 75 73 rt* "prev-status
4b00: 20 22 20 70 72 65 76 2d 73 74 61 74 75 73 20 22 " prev-status "
4b10: 2c 20 70 72 65 76 2d 73 74 61 74 65 20 22 20 70 , prev-state " p
4b20: 72 65 76 2d 73 74 61 74 65 20 22 2c 20 70 72 65 rev-state ", pre
4b30: 76 2d 63 6f 6d 6d 65 6e 74 20 22 20 70 72 65 76 v-comment " prev
4b40: 2d 63 6f 6d 6d 65 6e 74 29 0a 09 09 09 20 20 20 -comment)....
4b50: 20 20 28 69 66 20 28 61 6e 64 20 28 65 71 75 61 (if (and (equa
4b60: 6c 3f 20 70 72 65 76 2d 73 74 61 74 65 20 20 22 l? prev-state "
4b70: 43 4f 4d 50 4c 45 54 45 44 22 29 0a 09 09 09 09 COMPLETED").....
4b80: 20 20 20 20 20 20 28 65 71 75 61 6c 3f 20 70 72 (equal? pr
4b90: 65 76 2d 73 74 61 74 75 73 20 22 57 41 49 56 45 ev-status "WAIVE
4ba0: 44 22 29 29 0a 09 09 09 09 20 28 69 66 20 63 6f D"))..... (if co
4bb0: 6d 6d 65 6e 74 0a 09 09 09 09 20 20 20 20 20 63 mment..... c
4bc0: 6f 6d 6d 65 6e 74 0a 09 09 09 09 20 20 20 20 20 omment.....
4bd0: 70 72 65 76 2d 63 6f 6d 6d 65 6e 74 29 20 3b 3b prev-comment) ;;
4be0: 20 77 61 69 76 65 64 20 69 73 20 65 69 74 68 65 waived is eithe
4bf0: 72 20 74 68 65 20 63 6f 6d 6d 65 6e 74 20 6f 72 r the comment or
4c00: 20 23 66 0a 09 09 09 09 20 23 66 29 29 0a 09 09 #f..... #f))...
4c10: 09 20 20 20 23 66 29 0a 09 09 20 20 20 20 20 20 . #f)...
4c20: 20 23 66 29 29 29 0a 20 20 20 20 28 69 66 20 28 #f))). (if (
4c30: 61 6e 64 20 77 61 69 76 65 64 20 0a 09 20 20 20 and waived ..
4c40: 20 20 28 74 65 73 74 73 3a 63 68 65 63 6b 2d 77 (tests:check-w
4c50: 61 69 76 65 72 2d 65 6c 69 67 69 62 69 6c 69 74 aiver-eligibilit
4c60: 79 20 74 65 73 74 64 61 74 20 70 72 65 76 2d 74 y testdat prev-t
4c70: 65 73 74 29 29 0a 09 28 73 65 74 21 20 72 65 61 est))..(set! rea
4c80: 6c 2d 73 74 61 74 75 73 20 22 57 41 49 56 45 44 l-status "WAIVED
4c90: 22 29 29 0a 0a 20 20 20 20 28 64 65 62 75 67 3a ")).. (debug:
4ca0: 70 72 69 6e 74 20 34 20 2a 64 65 66 61 75 6c 74 print 4 *default
4cb0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 65 61 6c -log-port* "real
4cc0: 2d 73 74 61 74 75 73 20 22 20 72 65 61 6c 2d 73 -status " real-s
4cd0: 74 61 74 75 73 20 22 2c 20 77 61 69 76 65 64 20 tatus ", waived
4ce0: 22 20 77 61 69 76 65 64 20 22 2c 20 73 74 61 74 " waived ", stat
4cf0: 75 73 20 22 20 73 74 61 74 75 73 29 0a 0a 20 20 us " status)..
4d00: 20 20 3b 3b 20 75 70 64 61 74 65 20 74 68 65 20 ;; update the
4d10: 70 72 69 6d 61 72 79 20 72 65 63 6f 72 64 20 49 primary record I
4d20: 46 20 73 74 61 74 65 20 41 4e 44 20 73 74 61 74 F state AND stat
4d30: 75 73 20 61 72 65 20 64 65 66 69 6e 65 64 0a 20 us are defined.
4d40: 20 20 20 28 69 66 20 28 61 6e 64 20 73 74 61 74 (if (and stat
4d50: 65 20 73 74 61 74 75 73 29 0a 09 28 62 65 67 69 e status)..(begi
4d60: 6e 0a 09 20 20 28 72 6d 74 3a 73 65 74 2d 73 74 n.. (rmt:set-st
4d70: 61 74 65 2d 73 74 61 74 75 73 2d 61 6e 64 2d 72 ate-status-and-r
4d80: 6f 6c 6c 2d 75 70 2d 69 74 65 6d 73 20 72 75 6e oll-up-items run
4d90: 2d 69 64 20 74 65 73 74 2d 69 64 20 69 74 65 6d -id test-id item
4da0: 2d 70 61 74 68 20 73 74 61 74 65 20 72 65 61 6c -path state real
4db0: 2d 73 74 61 74 75 73 20 28 69 66 20 77 61 69 76 -status (if waiv
4dc0: 65 64 20 77 61 69 76 65 64 20 63 6f 6d 6d 65 6e ed waived commen
4dd0: 74 29 29 0a 09 20 20 3b 3b 20 28 6d 74 3a 70 72 t)).. ;; (mt:pr
4de0: 6f 63 65 73 73 2d 74 72 69 67 67 65 72 73 20 72 ocess-triggers r
4df0: 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 73 74 un-id test-id st
4e00: 61 74 65 20 72 65 61 6c 2d 73 74 61 74 75 73 29 ate real-status)
4e10: 20 3b 3b 20 74 72 69 67 67 65 72 73 20 61 72 65 ;; triggers are
4e20: 20 63 61 6c 6c 65 64 20 69 6e 20 74 65 73 74 2d called in test-
4e30: 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 set-state-status
4e40: 0a 09 20 20 29 29 0a 20 20 20 20 0a 20 20 20 20 .. )). .
4e50: 3b 3b 20 69 66 20 73 74 61 74 75 73 20 69 73 20 ;; if status is
4e60: 22 41 55 54 4f 22 20 74 68 65 6e 20 63 61 6c 6c "AUTO" then call
4e70: 20 72 6f 6c 6c 75 70 20 28 6e 6f 74 65 2c 20 74 rollup (note, t
4e80: 68 69 73 20 6f 6e 65 20 6d 6f 64 69 66 69 65 73 his one modifies
4e90: 20 64 61 74 61 20 69 6e 20 74 65 73 74 0a 20 20 data in test.
4ea0: 20 20 3b 3b 20 72 75 6e 20 61 72 65 61 2c 20 69 ;; run area, i
4eb0: 74 20 64 6f 65 73 20 72 65 6d 6f 74 65 20 63 61 t does remote ca
4ec0: 6c 6c 73 20 75 6e 64 65 72 20 74 68 65 20 68 6f lls under the ho
4ed0: 6f 64 2e 0a 20 20 20 20 3b 3b 20 28 69 66 20 28 od.. ;; (if (
4ee0: 61 6e 64 20 74 65 73 74 2d 69 64 20 73 74 61 74 and test-id stat
4ef0: 65 20 73 74 61 74 75 73 20 28 65 71 75 61 6c 3f e status (equal?
4f00: 20 73 74 61 74 75 73 20 22 41 55 54 4f 22 29 29 status "AUTO"))
4f10: 20 0a 20 20 20 20 3b 3b 20 09 28 72 6d 74 3a 74 . ;; .(rmt:t
4f20: 65 73 74 2d 64 61 74 61 2d 72 6f 6c 6c 75 70 20 est-data-rollup
4f30: 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 73 run-id test-id s
4f40: 74 61 74 75 73 29 29 0a 0a 20 20 20 20 3b 3b 20 tatus)).. ;;
4f50: 61 64 64 20 6d 65 74 61 64 61 74 61 20 28 6e 65 add metadata (ne
4f60: 65 64 20 74 6f 20 64 6f 20 74 68 69 73 20 77 61 ed to do this wa
4f70: 79 20 74 6f 20 61 76 6f 69 64 20 53 51 4c 20 69 y to avoid SQL i
4f80: 6e 6a 65 63 74 69 6f 6e 20 69 73 73 75 65 73 29 njection issues)
4f90: 0a 0a 20 20 20 20 3b 3b 20 3a 66 69 72 73 74 5f .. ;; :first_
4fa0: 65 72 72 0a 20 20 20 20 3b 3b 20 28 6c 65 74 20 err. ;; (let
4fb0: 28 28 76 61 6c 20 28 68 61 73 68 2d 74 61 62 6c ((val (hash-tabl
4fc0: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 6f 74 e-ref/default ot
4fd0: 68 65 72 64 61 74 20 22 3a 66 69 72 73 74 5f 65 herdat ":first_e
4fe0: 72 72 22 20 23 66 29 29 29 0a 20 20 20 20 3b 3b rr" #f))). ;;
4ff0: 20 20 20 28 69 66 20 76 61 6c 0a 20 20 20 20 3b (if val. ;
5000: 3b 20 20 20 20 20 20 20 28 73 71 6c 69 74 65 33 ; (sqlite3
5010: 3a 65 78 65 63 75 74 65 20 64 62 20 22 55 50 44 :execute db "UPD
5020: 41 54 45 20 74 65 73 74 73 20 53 45 54 20 66 69 ATE tests SET fi
5030: 72 73 74 5f 65 72 72 3d 3f 20 57 48 45 52 45 20 rst_err=? WHERE
5040: 72 75 6e 5f 69 64 3d 3f 20 41 4e 44 20 74 65 73 run_id=? AND tes
5050: 74 6e 61 6d 65 3d 3f 20 41 4e 44 20 69 74 65 6d tname=? AND item
5060: 5f 70 61 74 68 3d 3f 3b 22 20 76 61 6c 20 72 75 _path=?;" val ru
5070: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 n-id test-name i
5080: 74 65 6d 2d 70 61 74 68 29 29 29 0a 20 20 20 20 tem-path))).
5090: 3b 3b 20 0a 20 20 20 20 3b 3b 20 3b 3b 20 3a 66 ;; . ;; ;; :f
50a0: 69 72 73 74 5f 77 61 72 6e 0a 20 20 20 20 3b 3b irst_warn. ;;
50b0: 20 28 6c 65 74 20 28 28 76 61 6c 20 28 68 61 73 (let ((val (has
50c0: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
50d0: 75 6c 74 20 6f 74 68 65 72 64 61 74 20 22 3a 66 ult otherdat ":f
50e0: 69 72 73 74 5f 77 61 72 6e 22 20 23 66 29 29 29 irst_warn" #f)))
50f0: 0a 20 20 20 20 3b 3b 20 20 20 28 69 66 20 76 61 . ;; (if va
5100: 6c 0a 20 20 20 20 3b 3b 20 20 20 20 20 20 20 28 l. ;; (
5110: 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 sqlite3:execute
5120: 64 62 20 22 55 50 44 41 54 45 20 74 65 73 74 73 db "UPDATE tests
5130: 20 53 45 54 20 66 69 72 73 74 5f 77 61 72 6e 3d SET first_warn=
5140: 3f 20 57 48 45 52 45 20 72 75 6e 5f 69 64 3d 3f ? WHERE run_id=?
5150: 20 41 4e 44 20 74 65 73 74 6e 61 6d 65 3d 3f 20 AND testname=?
5160: 41 4e 44 20 69 74 65 6d 5f 70 61 74 68 3d 3f 3b AND item_path=?;
5170: 22 20 76 61 6c 20 72 75 6e 2d 69 64 20 74 65 73 " val run-id tes
5180: 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 t-name item-path
5190: 29 29 29 0a 0a 20 20 20 20 28 6c 65 74 20 28 28 ))).. (let ((
51a0: 63 61 74 65 67 6f 72 79 20 28 68 61 73 68 2d 74 category (hash-t
51b0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
51c0: 20 6f 74 68 65 72 64 61 74 20 22 3a 63 61 74 65 otherdat ":cate
51d0: 67 6f 72 79 22 20 22 22 29 29 0a 09 20 20 28 76 gory" "")).. (v
51e0: 61 72 69 61 62 6c 65 20 28 68 61 73 68 2d 74 61 ariable (hash-ta
51f0: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
5200: 6f 74 68 65 72 64 61 74 20 22 3a 76 61 72 69 61 otherdat ":varia
5210: 62 6c 65 22 20 22 22 29 29 0a 09 20 20 28 76 61 ble" "")).. (va
5220: 6c 75 65 20 20 20 20 28 68 61 73 68 2d 74 61 62 lue (hash-tab
5230: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 6f le-ref/default o
5240: 74 68 65 72 64 61 74 20 22 3a 76 61 6c 75 65 22 therdat ":value"
5250: 20 20 20 20 23 66 29 29 0a 09 20 20 28 65 78 70 #f)).. (exp
5260: 65 63 74 65 64 20 28 68 61 73 68 2d 74 61 62 6c ected (hash-tabl
5270: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 6f 74 e-ref/default ot
5280: 68 65 72 64 61 74 20 22 3a 65 78 70 65 63 74 65 herdat ":expecte
5290: 64 22 20 22 6e 2f 61 22 29 29 0a 09 20 20 28 74 d" "n/a")).. (t
52a0: 6f 6c 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 ol (hash-ta
52b0: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
52c0: 6f 74 68 65 72 64 61 74 20 22 3a 74 6f 6c 22 20 otherdat ":tol"
52d0: 20 20 20 20 20 22 6e 2f 61 22 29 29 0a 09 20 20 "n/a"))..
52e0: 28 75 6e 69 74 73 20 20 20 20 28 68 61 73 68 2d (units (hash-
52f0: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
5300: 74 20 6f 74 68 65 72 64 61 74 20 22 3a 75 6e 69 t otherdat ":uni
5310: 74 73 22 20 20 20 20 22 22 29 29 0a 09 20 20 28 ts" "")).. (
5320: 74 79 70 65 20 20 20 20 20 28 68 61 73 68 2d 74 type (hash-t
5330: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
5340: 20 6f 74 68 65 72 64 61 74 20 22 3a 74 79 70 65 otherdat ":type
5350: 22 20 20 20 20 20 22 22 29 29 0a 09 20 20 28 64 " "")).. (d
5360: 63 6f 6d 6d 65 6e 74 20 28 68 61 73 68 2d 74 61 comment (hash-ta
5370: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
5380: 6f 74 68 65 72 64 61 74 20 22 3a 63 6f 6d 6d 65 otherdat ":comme
5390: 6e 74 22 20 20 22 22 29 29 29 0a 20 20 20 20 20 nt" ""))).
53a0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 (debug:print 4
53b0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
53c0: 74 2a 20 0a 09 09 20 20 20 22 63 61 74 65 67 6f t* ... "catego
53d0: 72 79 3a 20 22 20 63 61 74 65 67 6f 72 79 20 22 ry: " category "
53e0: 2c 20 76 61 72 69 61 62 6c 65 3a 20 22 20 76 61 , variable: " va
53f0: 72 69 61 62 6c 65 20 22 2c 20 76 61 6c 75 65 3a riable ", value:
5400: 20 22 20 76 61 6c 75 65 0a 09 09 20 20 20 22 2c " value... ",
5410: 20 65 78 70 65 63 74 65 64 3a 20 22 20 65 78 70 expected: " exp
5420: 65 63 74 65 64 20 22 2c 20 74 6f 6c 3a 20 22 20 ected ", tol: "
5430: 74 6f 6c 20 22 2c 20 75 6e 69 74 73 3a 20 22 20 tol ", units: "
5440: 75 6e 69 74 73 29 0a 20 20 20 20 20 20 28 69 66 units). (if
5450: 20 28 61 6e 64 20 76 61 6c 75 65 29 20 3b 3b 20 (and value) ;;
5460: 72 65 71 75 69 72 65 20 6f 6e 6c 79 20 76 61 6c require only val
5470: 75 65 3b 20 42 42 20 77 61 73 2d 20 61 6c 6c 20 ue; BB was- all
5480: 74 68 72 65 65 20 72 65 71 75 69 72 65 64 0a 09 three required..
5490: 20 20 28 6c 65 74 20 28 28 64 61 74 20 28 63 6f (let ((dat (co
54a0: 6e 63 20 63 61 74 65 67 6f 72 79 20 22 2c 22 0a nc category ",".
54b0: 09 09 09 20 20 20 76 61 72 69 61 62 6c 65 20 22 ... variable "
54c0: 2c 22 0a 09 09 09 20 20 20 76 61 6c 75 65 20 20 ,".... value
54d0: 20 20 22 2c 22 0a 09 09 09 20 20 20 65 78 70 65 ",".... expe
54e0: 63 74 65 64 20 22 2c 22 0a 09 09 09 20 20 20 74 cted ",".... t
54f0: 6f 6c 20 20 20 20 20 20 22 2c 22 0a 09 09 09 20 ol ","....
5500: 20 20 75 6e 69 74 73 20 20 20 20 22 2c 22 0a 09 units ","..
5510: 09 09 20 20 20 64 63 6f 6d 6d 65 6e 74 20 22 2c .. dcomment ",
5520: 2c 22 20 3b 3b 20 65 78 74 72 61 20 63 6f 6d 6d ," ;; extra comm
5530: 61 20 66 6f 72 20 73 74 61 74 75 73 0a 09 09 09 a for status....
5540: 20 20 20 74 79 70 65 20 20 20 20 20 29 29 29 0a type ))).
5550: 09 20 20 20 20 3b 3b 20 54 68 69 73 20 77 61 73 . ;; This was
5560: 20 72 75 6e 20 72 65 6d 6f 74 65 2c 20 64 6f 6e run remote, don
5570: 27 74 20 74 68 69 6e 6b 20 74 68 61 74 20 6d 61 't think that ma
5580: 6b 65 73 20 73 65 6e 73 65 2e 20 50 65 72 68 61 kes sense. Perha
5590: 70 73 20 6e 6f 74 2c 20 62 75 74 20 74 68 61 74 ps not, but that
55a0: 20 69 73 20 74 68 65 20 65 61 73 69 65 73 74 20 is the easiest
55b0: 70 61 74 68 20 66 6f 72 20 74 68 65 20 6d 6f 6d path for the mom
55c0: 65 6e 74 2e 0a 09 20 20 20 20 28 72 6d 74 3a 63 ent... (rmt:c
55d0: 73 76 2d 3e 74 65 73 74 2d 64 61 74 61 20 72 75 sv->test-data ru
55e0: 6e 2d 69 64 20 74 65 73 74 2d 69 64 0a 09 09 09 n-id test-id....
55f0: 09 64 61 74 29 0a 09 20 20 20 20 3b 3b 20 54 68 .dat).. ;; Th
5600: 69 73 20 77 61 73 20 61 64 64 65 64 20 69 6e 20 is was added in
5610: 63 68 65 63 6b 2d 69 6e 20 61 35 61 64 66 61 33 check-in a5adfa3
5620: 66 39 61 2e 20 4d 65 73 73 61 67 65 20 77 61 73 f9a. Message was
5630: 3a 20 22 2e 2e 2e 61 64 64 65 64 20 64 65 6c 61 : "...added dela
5640: 79 20 69 6e 20 73 65 74 2d 76 61 6c 75 65 73 20 y in set-values
5650: 74 6f 20 61 6c 6c 6f 77 20 66 6f 72 20 64 65 6c to allow for del
5660: 61 79 65 64 20 77 72 69 74 65 20 6f 6e 20 73 65 ayed write on se
5670: 72 76 65 72 20 73 74 61 72 74 22 0a 09 20 20 20 rver start"..
5680: 20 3b 3b 20 49 27 6d 20 69 6e 73 65 72 74 69 6e ;; I'm insertin
5690: 67 20 61 6e 20 61 72 62 69 74 72 61 72 79 20 72 g an arbitrary r
56a0: 6d 74 3a 20 63 61 6c 6c 20 74 6f 20 66 6f 72 63 mt: call to forc
56b0: 65 2f 65 6e 73 75 72 65 20 74 68 61 74 20 74 68 e/ensure that th
56c0: 65 20 73 65 72 76 65 72 20 69 73 20 61 76 61 69 e server is avai
56d0: 6c 61 62 6c 65 20 74 6f 20 28 68 6f 70 65 66 75 lable to (hopefu
56e0: 6c 6c 79 29 20 70 72 65 76 65 6e 74 20 61 20 63 lly) prevent a c
56f0: 6f 6d 6d 75 6e 69 63 61 74 69 6f 6e 20 69 73 73 ommunication iss
5700: 75 65 2e 0a 09 20 20 20 20 28 72 6d 74 3a 67 65 ue... (rmt:ge
5710: 74 2d 76 61 72 20 22 4d 45 47 41 54 45 53 54 5f t-var "MEGATEST_
5720: 56 45 52 53 49 4f 4e 22 29 20 3b 3b 20 74 68 69 VERSION") ;; thi
5730: 73 20 64 6f 65 73 20 4e 4f 54 48 49 4e 47 20 62 s does NOTHING b
5740: 75 74 20 65 6e 73 75 72 65 20 74 68 65 20 73 65 ut ensure the se
5750: 72 76 65 72 20 69 73 20 72 65 61 63 68 61 62 6c rver is reachabl
5760: 65 2e 20 54 68 69 73 20 69 73 20 61 6c 6d 6f 73 e. This is almos
5770: 74 20 63 65 72 74 61 69 6e 6c 79 20 4e 4f 54 20 t certainly NOT
5780: 6e 65 65 64 65 64 20 3a 29 0a 20 20 20 20 20 20 needed :).
5790: 20 20 20 20 20 20 3b 3b 20 42 42 20 2d 20 63 6f ;; BB - co
57a0: 6d 6d 65 6e 74 69 6f 6e 67 20 6f 75 74 20 61 72 mmentiong out ar
57b0: 62 69 74 72 61 72 79 20 31 30 20 73 65 63 6f 6e bitrary 10 secon
57c0: 64 20 77 61 69 74 20 28 74 68 72 65 61 64 2d 73 d wait (thread-s
57d0: 6c 65 65 70 21 20 31 30 29 20 3b 3b 20 61 64 64 leep! 10) ;; add
57e0: 20 31 30 20 73 65 63 6f 6e 64 20 64 65 6c 61 79 10 second delay
57f0: 20 62 65 66 6f 72 65 20 71 75 69 74 20 69 6e 63 before quit inc
5800: 61 73 65 20 72 6d 74 20 6e 65 65 64 73 20 74 69 ase rmt needs ti
5810: 6d 65 20 74 6f 20 73 74 61 72 74 20 61 20 73 65 me to start a se
5820: 72 76 65 72 2e 0a 20 20 20 20 20 20 20 20 20 20 rver..
5830: 20 20 29 29 29 0a 20 20 20 20 20 20 0a 20 20 20 ))). .
5840: 20 3b 3b 20 6e 65 65 64 20 74 6f 20 75 70 64 61 ;; need to upda
5850: 74 65 20 74 68 65 20 74 6f 70 20 74 65 73 74 20 te the top test
5860: 72 65 63 6f 72 64 20 69 66 20 50 41 53 53 20 6f record if PASS o
5870: 72 20 46 41 49 4c 20 61 6e 64 20 74 68 69 73 20 r FAIL and this
5880: 69 73 20 61 20 73 75 62 74 65 73 74 0a 20 20 20 is a subtest.
5890: 20 3b 3b 3b 3b 3b 3b 20 28 69 66 20 28 6e 6f 74 ;;;;;; (if (not
58a0: 20 28 65 71 75 61 6c 3f 20 69 74 65 6d 2d 70 61 (equal? item-pa
58b0: 74 68 20 22 22 29 29 0a 20 20 20 20 3b 3b 3b 3b th "")). ;;;;
58c0: 3b 3b 20 20 20 20 20 28 72 6d 74 3a 73 65 74 2d ;; (rmt:set-
58d0: 73 74 61 74 65 2d 73 74 61 74 75 73 2d 61 6e 64 state-status-and
58e0: 2d 72 6f 6c 6c 2d 75 70 2d 69 74 65 6d 73 20 72 -roll-up-items r
58f0: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 un-id test-name
5900: 69 74 65 6d 2d 70 61 74 68 20 73 74 61 74 65 20 item-path state
5910: 73 74 61 74 75 73 20 23 66 29 20 3b 3b 3b 3b 3b status #f) ;;;;;
5920: 29 0a 0a 20 20 20 20 28 69 66 20 28 6f 72 20 28 ).. (if (or (
5930: 61 6e 64 20 28 73 74 72 69 6e 67 3f 20 63 6f 6d and (string? com
5940: 6d 65 6e 74 29 0a 09 09 20 28 73 74 72 69 6e 67 ment)... (string
5950: 2d 6d 61 74 63 68 20 28 72 65 67 65 78 70 20 22 -match (regexp "
5960: 5c 5c 53 2b 22 29 20 63 6f 6d 6d 65 6e 74 29 29 \\S+") comment))
5970: 0a 09 20 20 20 20 77 61 69 76 65 64 29 0a 09 28 .. waived)..(
5980: 6c 65 74 20 28 28 63 6d 74 20 20 28 69 66 20 77 let ((cmt (if w
5990: 61 69 76 65 64 20 77 61 69 76 65 64 20 63 6f 6d aived waived com
59a0: 6d 65 6e 74 29 29 29 0a 09 20 20 28 72 6d 74 3a ment))).. (rmt:
59b0: 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 73 65 general-call 'se
59c0: 74 2d 74 65 73 74 2d 63 6f 6d 6d 65 6e 74 20 72 t-test-comment r
59d0: 75 6e 2d 69 64 20 63 6d 74 20 74 65 73 74 2d 69 un-id cmt test-i
59e0: 64 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 d)))))..(define
59f0: 28 74 65 73 74 73 3a 74 65 73 74 2d 73 65 74 2d (tests:test-set-
5a00: 74 6f 70 6c 6f 67 21 20 72 75 6e 2d 69 64 20 74 toplog! run-id t
5a10: 65 73 74 2d 6e 61 6d 65 20 6c 6f 67 66 29 20 0a est-name logf) .
5a20: 20 20 28 72 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 (rmt:general-c
5a30: 61 6c 6c 20 27 74 65 73 74 73 3a 74 65 73 74 2d all 'tests:test-
5a40: 73 65 74 2d 74 6f 70 6c 6f 67 20 72 75 6e 2d 69 set-toplog run-i
5a50: 64 20 6c 6f 67 66 20 72 75 6e 2d 69 64 20 74 65 d logf run-id te
5a60: 73 74 2d 6e 61 6d 65 29 29 0a 0a 28 64 65 66 69 st-name))..(defi
5a70: 6e 65 20 28 74 65 73 74 73 3a 73 75 6d 6d 61 72 ne (tests:summar
5a80: 69 7a 65 2d 69 74 65 6d 73 20 72 75 6e 2d 69 64 ize-items run-id
5a90: 20 74 65 73 74 2d 69 64 20 74 65 73 74 2d 6e 61 test-id test-na
5aa0: 6d 65 20 66 6f 72 63 65 29 0a 20 20 3b 3b 20 69 me force). ;; i
5ab0: 66 20 6e 6f 74 20 66 6f 72 63 65 20 74 68 65 6e f not force then
5ac0: 20 6f 6e 6c 79 20 75 70 64 61 74 65 20 74 68 65 only update the
5ad0: 20 72 65 63 6f 72 64 20 69 66 20 6f 6e 65 20 6f record if one o
5ae0: 66 20 74 68 65 73 65 20 69 73 20 74 72 75 65 3a f these is true:
5af0: 0a 20 20 3b 3b 20 20 20 31 2e 20 6c 6f 67 66 20 . ;; 1. logf
5b00: 69 73 20 22 6c 6f 67 2f 66 69 6e 61 6c 2e 6c 6f is "log/final.lo
5b10: 67 0a 20 20 3b 3b 20 20 20 32 2e 20 6c 6f 67 66 g. ;; 2. logf
5b20: 20 69 73 20 73 61 6d 65 20 61 73 20 6f 75 74 70 is same as outp
5b30: 75 74 66 69 6c 65 6e 61 6d 65 0a 20 20 28 6c 65 utfilename. (le
5b40: 74 2a 20 28 28 6f 75 74 70 75 74 66 69 6c 65 6e t* ((outputfilen
5b50: 61 6d 65 20 28 63 6f 6e 63 20 22 6d 65 67 61 74 ame (conc "megat
5b60: 65 73 74 2d 72 6f 6c 6c 75 70 2d 22 20 74 65 73 est-rollup-" tes
5b70: 74 2d 6e 61 6d 65 20 22 2e 68 74 6d 6c 22 29 29 t-name ".html"))
5b80: 0a 09 20 28 6f 72 69 67 2d 64 69 72 20 20 20 20 .. (orig-dir
5b90: 20 20 20 28 63 75 72 72 65 6e 74 2d 64 69 72 65 (current-dire
5ba0: 63 74 6f 72 79 29 29 0a 09 20 28 6c 6f 67 66 2d ctory)).. (logf-
5bb0: 69 6e 66 6f 20 20 20 20 20 20 28 72 6d 74 3a 74 info (rmt:t
5bc0: 65 73 74 2d 67 65 74 2d 6c 6f 67 66 69 6c 65 2d est-get-logfile-
5bd0: 69 6e 66 6f 20 72 75 6e 2d 69 64 20 74 65 73 74 info run-id test
5be0: 2d 6e 61 6d 65 29 29 0a 09 20 28 6c 6f 67 66 20 -name)).. (logf
5bf0: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 6c 6f (if lo
5c00: 67 66 2d 69 6e 66 6f 20 28 63 61 64 72 20 6c 6f gf-info (cadr lo
5c10: 67 66 2d 69 6e 66 6f 29 20 23 66 29 29 0a 09 20 gf-info) #f))..
5c20: 28 70 61 74 68 20 20 20 20 20 20 20 20 20 20 20 (path
5c30: 28 69 66 20 6c 6f 67 66 2d 69 6e 66 6f 20 28 63 (if logf-info (c
5c40: 61 72 20 20 6c 6f 67 66 2d 69 6e 66 6f 29 20 23 ar logf-info) #
5c50: 66 29 29 29 0a 20 20 20 20 3b 3b 20 54 68 69 73 f))). ;; This
5c60: 20 71 75 65 72 79 20 66 69 6e 64 73 20 74 68 65 query finds the
5c70: 20 70 61 74 68 20 61 6e 64 20 63 68 61 6e 67 65 path and change
5c80: 73 20 74 68 65 20 64 69 72 65 63 74 6f 72 79 20 s the directory
5c90: 74 6f 20 69 74 20 66 6f 72 20 74 68 65 20 74 65 to it for the te
5ca0: 73 74 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 st. (if (and
5cb0: 28 73 74 72 69 6e 67 3f 20 70 61 74 68 29 0a 09 (string? path)..
5cc0: 20 20 20 20 20 28 64 69 72 65 63 74 6f 72 79 3f (directory?
5cd0: 20 70 61 74 68 29 29 20 3b 3b 20 63 61 6e 20 67 path)) ;; can g
5ce0: 65 74 20 23 66 20 68 65 72 65 20 75 6e 64 65 72 et #f here under
5cf0: 20 73 6f 6d 65 20 77 69 65 72 64 20 63 6f 6e 64 some wierd cond
5d00: 69 74 69 6f 6e 73 2e 20 77 68 79 2c 20 75 6e 6b itions. why, unk
5d10: 6e 6f 77 6e 20 2e 2e 2e 0a 09 28 62 65 67 69 6e nown .....(begin
5d20: 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
5d30: 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 4 *default-log-
5d40: 70 6f 72 74 2a 20 22 46 6f 75 6e 64 20 70 61 74 port* "Found pat
5d50: 68 3a 20 22 20 70 61 74 68 29 0a 09 20 20 28 63 h: " path).. (c
5d60: 68 61 6e 67 65 2d 64 69 72 65 63 74 6f 72 79 20 hange-directory
5d70: 70 61 74 68 29 29 0a 09 3b 3b 20 28 73 65 74 21 path))..;; (set!
5d80: 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 20 outputfilename
5d90: 28 63 6f 6e 63 20 70 61 74 68 20 22 2f 22 20 6f (conc path "/" o
5da0: 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 29 29 29 utputfilename)))
5db0: 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 ..(debug:print-e
5dc0: 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d rror 0 *default-
5dd0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 75 6d 6d 61 log-port* "summa
5de0: 72 69 7a 65 2d 69 74 65 6d 73 20 66 6f 72 20 72 rize-items for r
5df0: 75 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 64 20 22 un-id=" run-id "
5e00: 2c 20 74 65 73 74 2d 6e 61 6d 65 3d 22 20 74 65 , test-name=" te
5e10: 73 74 2d 6e 61 6d 65 20 22 2c 20 6e 6f 20 73 75 st-name ", no su
5e20: 63 68 20 70 61 74 68 3a 20 22 20 70 61 74 68 29 ch path: " path)
5e30: 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 ). (debug:pri
5e40: 6e 74 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 4 *default-lo
5e50: 67 2d 70 6f 72 74 2a 20 22 73 75 6d 6d 61 72 69 g-port* "summari
5e60: 7a 65 2d 69 74 65 6d 73 20 77 69 74 68 20 6c 6f ze-items with lo
5e70: 67 66 20 22 20 6c 6f 67 66 20 22 2c 20 6f 75 74 gf " logf ", out
5e80: 70 75 74 66 69 6c 65 6e 61 6d 65 20 22 20 6f 75 putfilename " ou
5e90: 74 70 75 74 66 69 6c 65 6e 61 6d 65 20 22 20 61 tputfilename " a
5ea0: 6e 64 20 66 6f 72 63 65 20 22 20 66 6f 72 63 65 nd force " force
5eb0: 29 0a 20 20 20 20 28 69 66 20 28 6f 72 20 28 65 ). (if (or (e
5ec0: 71 75 61 6c 3f 20 6c 6f 67 66 20 22 6c 6f 67 73 qual? logf "logs
5ed0: 2f 66 69 6e 61 6c 2e 6c 6f 67 22 29 0a 09 20 20 /final.log")..
5ee0: 20 20 28 65 71 75 61 6c 3f 20 6c 6f 67 66 20 6f (equal? logf o
5ef0: 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 29 0a 09 utputfilename)..
5f00: 20 20 20 20 66 6f 72 63 65 29 0a 09 28 6c 65 74 force)..(let
5f10: 20 28 28 6d 79 2d 73 74 61 72 74 2d 74 69 6d 65 ((my-start-time
5f20: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
5f30: 73 29 29 0a 09 20 20 20 20 20 20 28 6c 6f 63 6b s)).. (lock
5f40: 66 20 20 20 20 20 20 20 20 20 28 63 6f 6e 63 20 f (conc
5f50: 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 20 22 outputfilename "
5f60: 2e 6c 6f 63 6b 22 29 29 29 0a 09 20 20 28 6c 65 .lock"))).. (le
5f70: 74 20 6c 6f 6f 70 20 28 28 68 61 76 65 2d 6c 6f t loop ((have-lo
5f80: 63 6b 20 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 ck (common:simp
5f90: 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 20 6c 6f 63 le-file-lock loc
5fa0: 6b 66 29 29 29 0a 09 20 20 20 20 28 69 66 20 68 kf))).. (if h
5fb0: 61 76 65 2d 6c 6f 63 6b 0a 09 09 28 6c 65 74 20 ave-lock...(let
5fc0: 28 28 73 63 72 69 70 74 20 28 63 6f 6e 66 69 67 ((script (config
5fd0: 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 f:lookup *config
5fe0: 64 61 74 2a 20 22 74 65 73 74 72 6f 6c 6c 75 70 dat* "testrollup
5ff0: 22 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a 09 " test-name)))..
6000: 09 20 20 28 70 72 69 6e 74 20 22 4f 62 74 61 69 . (print "Obtai
6010: 6e 65 64 20 6c 6f 63 6b 20 66 6f 72 20 22 20 6f ned lock for " o
6020: 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 29 0a 09 utputfilename)..
6030: 09 20 20 28 72 6d 74 3a 73 65 74 2d 73 74 61 74 . (rmt:set-stat
6040: 65 2d 73 74 61 74 75 73 2d 61 6e 64 2d 72 6f 6c e-status-and-rol
6050: 6c 2d 75 70 2d 69 74 65 6d 73 20 72 75 6e 2d 69 l-up-items run-i
6060: 64 20 74 65 73 74 2d 6e 61 6d 65 20 22 22 20 23 d test-name "" #
6070: 66 20 23 66 20 23 66 29 0a 09 09 20 20 28 69 66 f #f #f)... (if
6080: 20 73 63 72 69 70 74 0a 09 09 20 20 20 20 20 20 script...
6090: 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 73 63 (system (conc sc
60a0: 72 69 70 74 20 22 20 3e 20 22 20 6f 75 74 70 75 ript " > " outpu
60b0: 74 66 69 6c 65 6e 61 6d 65 20 22 20 26 20 22 29 tfilename " & ")
60c0: 29 0a 09 09 20 20 20 20 20 20 28 74 65 73 74 73 )... (tests
60d0: 3a 67 65 6e 65 72 61 74 65 2d 68 74 6d 6c 2d 73 :generate-html-s
60e0: 75 6d 6d 61 72 79 2d 66 6f 72 2d 69 74 65 72 61 ummary-for-itera
60f0: 74 65 64 2d 74 65 73 74 20 72 75 6e 2d 69 64 20 ted-test run-id
6100: 74 65 73 74 2d 69 64 20 74 65 73 74 2d 6e 61 6d test-id test-nam
6110: 65 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 e outputfilename
6120: 29 29 0a 09 09 20 20 28 63 6f 6d 6d 6f 6e 3a 73 ))... (common:s
6130: 69 6d 70 6c 65 2d 66 69 6c 65 2d 72 65 6c 65 61 imple-file-relea
6140: 73 65 2d 6c 6f 63 6b 20 6c 6f 63 6b 66 29 0a 09 se-lock lockf)..
6150: 09 20 20 28 63 68 61 6e 67 65 2d 64 69 72 65 63 . (change-direc
6160: 74 6f 72 79 20 6f 72 69 67 2d 64 69 72 29 0a 09 tory orig-dir)..
6170: 09 20 20 3b 3b 20 4e 42 2f 2f 20 74 65 73 74 73 . ;; NB// tests
6180: 3a 74 65 73 74 2d 73 65 74 2d 74 6f 70 6c 6f 67 :test-set-toplog
6190: 21 20 69 73 20 72 65 6d 6f 74 65 20 69 6e 74 65 ! is remote inte
61a0: 72 6e 61 6c 2e 2e 2e 0a 09 09 20 20 28 74 65 73 rnal...... (tes
61b0: 74 73 3a 74 65 73 74 2d 73 65 74 2d 74 6f 70 6c ts:test-set-topl
61c0: 6f 67 21 20 72 75 6e 2d 69 64 20 74 65 73 74 2d og! run-id test-
61d0: 6e 61 6d 65 20 6f 75 74 70 75 74 66 69 6c 65 6e name outputfilen
61e0: 61 6d 65 29 29 0a 09 09 3b 3b 20 64 69 64 6e 27 ame))...;; didn'
61f0: 74 20 67 65 74 20 74 68 65 20 6c 6f 63 6b 2c 20 t get the lock,
6200: 63 68 65 63 6b 20 74 6f 20 73 65 65 20 69 66 20 check to see if
6210: 63 75 72 72 65 6e 74 20 75 70 64 61 74 65 20 73 current update s
6220: 74 61 72 74 65 64 20 6c 61 74 65 72 20 74 68 61 tarted later tha
6230: 6e 20 74 68 69 73 20 0a 09 09 3b 3b 20 75 70 64 n this ...;; upd
6240: 61 74 65 2c 20 69 66 20 73 6f 20 77 65 20 63 61 ate, if so we ca
6250: 6e 20 65 78 69 74 20 77 69 74 68 6f 75 74 20 64 n exit without d
6260: 6f 69 6e 67 20 61 6e 79 20 77 6f 72 6b 0a 09 09 oing any work...
6270: 28 69 66 20 28 3e 20 6d 79 2d 73 74 61 72 74 2d (if (> my-start-
6280: 74 69 6d 65 20 28 68 61 6e 64 6c 65 2d 65 78 63 time (handle-exc
6290: 65 70 74 69 6f 6e 73 0a 09 09 09 09 09 20 65 78 eptions...... ex
62a0: 6e 0a 09 09 09 09 20 20 20 20 20 20 20 28 62 65 n..... (be
62b0: 67 69 6e 0a 09 09 09 09 09 20 28 70 72 69 6e 74 gin...... (print
62c0: 20 22 66 61 69 6c 65 64 20 74 6f 20 67 65 74 20 "failed to get
62d0: 6d 6f 64 20 74 69 6d 65 20 6f 6e 20 22 20 6c 6f mod time on " lo
62e0: 63 6b 66 20 22 2c 20 65 78 6e 3d 22 20 65 78 6e ckf ", exn=" exn
62f0: 29 0a 09 09 09 09 09 20 30 29 0a 09 09 09 09 20 )...... 0).....
6300: 20 20 20 20 20 20 28 66 69 6c 65 2d 6d 6f 64 69 (file-modi
6310: 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 6c 6f fication-time lo
6320: 63 6b 66 29 29 29 0a 09 09 20 20 20 20 3b 3b 20 ckf)))... ;;
6330: 77 65 20 73 74 61 72 74 65 64 20 73 69 6e 63 65 we started since
6340: 20 63 75 72 72 65 6e 74 20 72 65 2d 67 65 6e 20 current re-gen
6350: 69 6e 20 66 6c 69 67 68 74 2c 20 64 65 6c 61 79 in flight, delay
6360: 20 61 20 6c 69 74 74 6c 65 20 61 6e 64 20 74 72 a little and tr
6370: 79 20 61 67 61 69 6e 0a 09 09 20 20 20 20 28 62 y again... (b
6380: 65 67 69 6e 0a 09 09 20 20 20 20 20 20 28 64 65 egin... (de
6390: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 bug:print-info 1
63a0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
63b0: 72 74 2a 20 22 57 61 69 74 69 6e 67 20 74 6f 20 rt* "Waiting to
63c0: 75 70 64 61 74 65 20 22 20 6f 75 74 70 75 74 66 update " outputf
63d0: 69 6c 65 6e 61 6d 65 20 22 2c 20 61 6e 6f 74 68 ilename ", anoth
63e0: 65 72 20 74 65 73 74 20 63 75 72 72 65 6e 74 6c er test currentl
63f0: 79 20 75 70 64 61 74 69 6e 67 20 69 74 22 29 0a y updating it").
6400: 09 09 20 20 20 20 20 20 28 74 68 72 65 61 64 2d .. (thread-
6410: 73 6c 65 65 70 21 20 28 2b 20 35 20 28 72 61 6e sleep! (+ 5 (ran
6420: 64 6f 6d 20 35 29 29 29 20 3b 3b 20 64 65 6c 61 dom 5))) ;; dela
6430: 79 20 62 65 74 77 65 65 6e 20 35 20 61 6e 64 20 y between 5 and
6440: 31 30 20 73 65 63 6f 6e 64 73 0a 09 09 20 20 20 10 seconds...
6450: 20 20 20 28 6c 6f 6f 70 20 28 63 6f 6d 6d 6f 6e (loop (common
6460: 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 :simple-file-loc
6470: 6b 20 6c 6f 63 6b 66 29 29 29 29 29 29 29 29 29 k lockf)))))))))
6480: 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 )..(define (test
6490: 73 3a 67 65 6e 65 72 61 74 65 2d 68 74 6d 6c 2d s:generate-html-
64a0: 73 75 6d 6d 61 72 79 2d 66 6f 72 2d 69 74 65 72 summary-for-iter
64b0: 61 74 65 64 2d 74 65 73 74 20 72 75 6e 2d 69 64 ated-test run-id
64c0: 20 74 65 73 74 2d 69 64 20 74 65 73 74 2d 6e 61 test-id test-na
64d0: 6d 65 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d me outputfilenam
64e0: 65 29 0a 20 20 28 6c 65 74 20 28 28 63 6f 75 6e e). (let ((coun
64f0: 74 73 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ts
6500: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
6510: 29 29 0a 09 28 73 74 61 74 65 63 6f 75 6e 74 73 ))..(statecounts
6520: 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 (make-h
6530: 61 73 68 2d 74 61 62 6c 65 29 29 0a 09 28 6f 75 ash-table))..(ou
6540: 74 74 78 74 20 20 20 20 20 20 20 20 20 20 20 20 ttxt
6550: 20 20 22 22 29 0a 09 28 74 6f 74 20 20 20 20 20 "")..(tot
6560: 20 20 20 20 20 20 20 20 20 20 20 20 30 29 0a 09 0)..
6570: 28 74 65 73 74 64 61 74 20 20 20 20 20 20 20 20 (testdat
6580: 20 20 20 20 20 28 72 6d 74 3a 74 65 73 74 2d 67 (rmt:test-g
6590: 65 74 2d 72 65 63 6f 72 64 73 2d 66 6f 72 2d 69 et-records-for-i
65a0: 6e 64 65 78 2d 66 69 6c 65 20 72 75 6e 2d 69 64 ndex-file run-id
65b0: 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a 20 20 test-name))).
65c0: 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 (with-output-t
65d0: 6f 2d 66 69 6c 65 20 6f 75 74 70 75 74 66 69 6c o-file outputfil
65e0: 65 6e 61 6d 65 0a 20 20 20 20 20 20 28 6c 61 6d ename. (lam
65f0: 62 64 61 20 28 29 0a 09 28 73 65 74 21 20 6f 75 bda ()..(set! ou
6600: 74 74 78 74 20 28 63 6f 6e 63 20 6f 75 74 74 78 ttxt (conc outtx
6610: 74 20 22 3c 68 74 6d 6c 3e 3c 74 69 74 6c 65 3e t "<html><title>
6620: 53 75 6d 6d 61 72 79 3a 20 22 20 74 65 73 74 2d Summary: " test-
6630: 6e 61 6d 65 20 0a 09 09 09 20 20 20 22 3c 2f 74 name .... "</t
6640: 69 74 6c 65 3e 3c 62 6f 64 79 3e 3c 68 32 3e 53 itle><body><h2>S
6650: 75 6d 6d 61 72 79 20 66 6f 72 20 22 20 74 65 73 ummary for " tes
6660: 74 2d 6e 61 6d 65 20 22 3c 2f 68 32 3e 22 29 29 t-name "</h2>"))
6670: 0a 09 28 66 6f 72 2d 65 61 63 68 0a 09 20 28 6c ..(for-each.. (l
6680: 61 6d 62 64 61 20 28 74 65 73 74 72 65 63 6f 72 ambda (testrecor
6690: 64 29 0a 09 20 20 20 28 6c 65 74 20 28 28 69 64 d).. (let ((id
66a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 76 65 (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 30 29 29 0a 09 09 20 28 69 74 65 6d ord 0))... (item
66d0: 70 61 74 68 20 20 20 20 20 20 20 28 76 65 63 74 path (vect
66e0: 6f 72 2d 72 65 66 20 74 65 73 74 72 65 63 6f 72 or-ref testrecor
66f0: 64 20 31 29 29 0a 09 09 20 28 73 74 61 74 65 20 d 1))... (state
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: 32 29 29 0a 09 09 20 28 73 74 61 74 75 73 20 20 2))... (status
6730: 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 (vector-r
6740: 65 66 20 74 65 73 74 72 65 63 6f 72 64 20 33 29 ef testrecord 3)
6750: 29 0a 09 09 20 28 72 75 6e 5f 64 75 72 61 74 69 )... (run_durati
6760: 6f 6e 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 on (vector-ref
6770: 20 74 65 73 74 72 65 63 6f 72 64 20 34 29 29 0a testrecord 4)).
6780: 09 09 20 28 6c 6f 67 66 20 20 20 20 20 20 20 20 .. (logf
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 35 29 29 0a 09 09 estrecord 5))...
67b0: 20 28 63 6f 6d 6d 65 6e 74 20 20 20 20 20 20 20 (comment
67c0: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 65 73 (vector-ref tes
67d0: 74 72 65 63 6f 72 64 20 36 29 29 29 0a 09 20 20 trecord 6)))..
67e0: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 (hash-table-s
67f0: 65 74 21 20 63 6f 75 6e 74 73 20 73 74 61 74 75 et! counts statu
6800: 73 20 28 2b 20 31 20 28 68 61 73 68 2d 74 61 62 s (+ 1 (hash-tab
6810: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 63 le-ref/default c
6820: 6f 75 6e 74 73 20 73 74 61 74 75 73 20 30 29 29 ounts status 0))
6830: 29 0a 09 20 20 20 20 20 28 68 61 73 68 2d 74 61 ).. (hash-ta
6840: 62 6c 65 2d 73 65 74 21 20 73 74 61 74 65 63 6f ble-set! stateco
6850: 75 6e 74 73 20 73 74 61 74 65 20 28 2b 20 31 20 unts state (+ 1
6860: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
6870: 64 65 66 61 75 6c 74 20 73 74 61 74 65 63 6f 75 default statecou
6880: 6e 74 73 20 73 74 61 74 65 20 30 29 29 29 0a 09 nts state 0)))..
6890: 20 20 20 20 20 28 73 65 74 21 20 6f 75 74 74 78 (set! outtx
68a0: 74 20 28 63 6f 6e 63 20 6f 75 74 74 78 74 20 22 t (conc outtxt "
68b0: 3c 74 72 3e 22 0a 09 09 09 09 3b 3b 20 22 3c 74 <tr>".....;; "<t
68c0: 64 3e 3c 61 20 68 72 65 66 3d 5c 22 22 20 69 74 d><a href=\"" it
68d0: 65 6d 70 61 74 68 20 22 2f 22 20 6c 6f 67 66 20 empath "/" logf
68e0: 22 5c 22 3e 20 22 20 69 74 65 6d 70 61 74 68 20 "\"> " itempath
68f0: 22 3c 2f 61 3e 3c 2f 74 64 3e 22 20 0a 09 09 09 "</a></td>" ....
6900: 09 22 3c 74 64 3e 3c 61 20 68 72 65 66 3d 5c 22 ."<td><a href=\"
6910: 22 20 69 74 65 6d 70 61 74 68 20 22 2f 74 65 73 " itempath "/tes
6920: 74 2d 73 75 6d 6d 61 72 79 2e 68 74 6d 6c 5c 22 t-summary.html\"
6930: 3e 20 22 20 69 74 65 6d 70 61 74 68 20 22 3c 2f > " itempath "</
6940: 61 3e 3c 2f 74 64 3e 22 20 0a 09 09 09 09 22 3c a></td>" ....."<
6950: 74 64 3e 22 20 73 74 61 74 65 20 20 20 20 22 3c td>" state "<
6960: 2f 74 64 3e 22 20 0a 09 09 09 09 22 3c 74 64 3e /td>" ....."<td>
6970: 3c 66 6f 6e 74 20 63 6f 6c 6f 72 3d 22 20 28 63 <font color=" (c
6980: 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 6f 6c 6f 72 2d ommon:get-color-
6990: 66 72 6f 6d 2d 73 74 61 74 75 73 20 73 74 61 74 from-status stat
69a0: 75 73 29 0a 09 09 09 09 22 3e 22 20 20 20 73 74 us).....">" st
69b0: 61 74 75 73 20 20 20 22 3c 2f 66 6f 6e 74 3e 3c atus "</font><
69c0: 2f 74 64 3e 22 0a 09 09 09 09 22 3c 74 64 3e 22 /td>"....."<td>"
69d0: 20 28 69 66 20 28 65 71 75 61 6c 3f 20 63 6f 6d (if (equal? com
69e0: 6d 65 6e 74 20 22 22 29 0a 09 09 09 09 09 20 20 ment "")......
69f0: 20 22 26 6e 62 73 70 3b 22 0a 09 09 09 09 09 20 " "......
6a00: 20 20 63 6f 6d 6d 65 6e 74 29 20 22 3c 2f 74 64 comment) "</td
6a10: 3e 22 0a 09 09 09 09 09 20 20 20 22 3c 2f 74 72 >"...... "</tr
6a20: 3e 22 29 29 29 29 0a 09 20 28 69 66 20 28 6c 69 >")))).. (if (li
6a30: 73 74 3f 20 74 65 73 74 64 61 74 29 0a 09 20 20 st? testdat)..
6a40: 20 20 20 74 65 73 74 64 61 74 0a 09 20 20 20 20 testdat..
6a50: 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 20 (begin..
6a60: 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 66 (print "ERROR: f
6a70: 61 69 6c 65 64 20 74 6f 20 67 65 74 20 72 65 63 ailed to get rec
6a80: 6f 72 64 73 20 77 69 74 68 20 72 6d 74 3a 74 65 ords with rmt:te
6a90: 73 74 2d 67 65 74 2d 72 65 63 6f 72 64 73 2d 66 st-get-records-f
6aa0: 6f 72 2d 69 6e 64 65 78 2d 66 69 6c 65 20 72 75 or-index-file ru
6ab0: 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 64 20 22 74 n-id=" run-id "t
6ac0: 65 73 74 2d 6e 61 6d 65 3d 22 20 74 65 73 74 2d est-name=" test-
6ad0: 6e 61 6d 65 29 0a 09 20 20 20 20 20 20 20 27 28 name).. '(
6ae0: 29 29 29 29 0a 09 0a 09 28 70 72 69 6e 74 20 22 ))))....(print "
6af0: 3c 74 61 62 6c 65 3e 3c 74 72 3e 3c 74 64 20 76 <table><tr><td v
6b00: 61 6c 69 67 6e 3d 5c 22 74 6f 70 5c 22 3e 22 29 align=\"top\">")
6b10: 0a 09 3b 3b 20 50 72 69 6e 74 20 6f 75 74 20 73 ..;; Print out s
6b20: 74 61 74 73 20 66 6f 72 20 73 74 61 74 75 73 0a tats for status.
6b30: 09 28 73 65 74 21 20 74 6f 74 20 30 29 0a 09 28 .(set! tot 0)..(
6b40: 70 72 69 6e 74 20 22 3c 74 61 62 6c 65 20 63 65 print "<table ce
6b50: 6c 6c 73 70 61 63 69 6e 67 3d 5c 22 30 5c 22 20 llspacing=\"0\"
6b60: 62 6f 72 64 65 72 3d 5c 22 31 5c 22 3e 3c 74 72 border=\"1\"><tr
6b70: 3e 3c 74 64 20 63 6f 6c 73 70 61 6e 3d 5c 22 32 ><td colspan=\"2
6b80: 5c 22 3e 3c 68 32 3e 53 74 61 74 65 20 73 74 61 \"><h2>State sta
6b90: 74 73 3c 2f 68 32 3e 3c 2f 74 64 3e 3c 2f 74 72 ts</h2></td></tr
6ba0: 3e 22 29 0a 09 28 66 6f 72 2d 65 61 63 68 20 28 >")..(for-each (
6bb0: 6c 61 6d 62 64 61 20 28 73 74 61 74 65 29 0a 09 lambda (state)..
6bc0: 09 20 20 20 20 28 73 65 74 21 20 74 6f 74 20 28 . (set! tot (
6bd0: 2b 20 74 6f 74 20 28 68 61 73 68 2d 74 61 62 6c + tot (hash-tabl
6be0: 65 2d 72 65 66 20 73 74 61 74 65 63 6f 75 6e 74 e-ref statecount
6bf0: 73 20 73 74 61 74 65 29 29 29 0a 09 09 20 20 20 s state)))...
6c00: 20 28 70 72 69 6e 74 20 22 3c 74 72 3e 3c 74 64 (print "<tr><td
6c10: 3e 22 20 73 74 61 74 65 20 22 3c 2f 74 64 3e 3c >" state "</td><
6c20: 74 64 3e 22 20 28 68 61 73 68 2d 74 61 62 6c 65 td>" (hash-table
6c30: 2d 72 65 66 20 73 74 61 74 65 63 6f 75 6e 74 73 -ref statecounts
6c40: 20 73 74 61 74 65 29 20 22 3c 2f 74 64 3e 3c 2f state) "</td></
6c50: 74 72 3e 22 29 29 0a 09 09 20 20 28 68 61 73 68 tr>"))... (hash
6c60: 2d 74 61 62 6c 65 2d 6b 65 79 73 20 73 74 61 74 -table-keys stat
6c70: 65 63 6f 75 6e 74 73 29 29 0a 09 28 70 72 69 6e ecounts))..(prin
6c80: 74 20 22 3c 74 72 3e 3c 74 64 3e 54 6f 74 61 6c t "<tr><td>Total
6c90: 3c 2f 74 64 3e 3c 74 64 3e 22 20 74 6f 74 20 22 </td><td>" tot "
6ca0: 3c 2f 74 64 3e 3c 2f 74 72 3e 3c 2f 74 61 62 6c </td></tr></tabl
6cb0: 65 3e 22 29 0a 09 28 70 72 69 6e 74 20 22 3c 2f e>")..(print "</
6cc0: 74 64 3e 3c 74 64 20 76 61 6c 69 67 6e 3d 5c 22 td><td valign=\"
6cd0: 74 6f 70 5c 22 3e 22 29 0a 09 3b 3b 20 50 72 69 top\">")..;; Pri
6ce0: 6e 74 20 6f 75 74 20 73 74 61 74 73 20 66 6f 72 nt out stats for
6cf0: 20 73 74 61 74 65 0a 09 28 73 65 74 21 20 74 6f state..(set! to
6d00: 74 20 30 29 0a 09 28 70 72 69 6e 74 20 22 3c 74 t 0)..(print "<t
6d10: 61 62 6c 65 20 63 65 6c 6c 73 70 61 63 69 6e 67 able cellspacing
6d20: 3d 5c 22 30 5c 22 20 62 6f 72 64 65 72 3d 5c 22 =\"0\" border=\"
6d30: 31 5c 22 3e 3c 74 72 3e 3c 74 64 20 63 6f 6c 73 1\"><tr><td cols
6d40: 70 61 6e 3d 5c 22 32 5c 22 3e 3c 68 32 3e 53 74 pan=\"2\"><h2>St
6d50: 61 74 75 73 20 73 74 61 74 73 3c 2f 68 32 3e 3c atus stats</h2><
6d60: 2f 74 64 3e 3c 2f 74 72 3e 22 29 0a 09 28 66 6f /td></tr>")..(fo
6d70: 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 r-each (lambda (
6d80: 73 74 61 74 75 73 29 0a 09 09 20 20 20 20 28 73 status)... (s
6d90: 65 74 21 20 74 6f 74 20 28 2b 20 74 6f 74 20 28 et! tot (+ tot (
6da0: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 63 hash-table-ref c
6db0: 6f 75 6e 74 73 20 73 74 61 74 75 73 29 29 29 0a ounts status))).
6dc0: 09 09 20 20 20 20 28 70 72 69 6e 74 20 22 3c 74 .. (print "<t
6dd0: 72 3e 3c 74 64 3e 3c 66 6f 6e 74 20 63 6f 6c 6f r><td><font colo
6de0: 72 3d 5c 22 22 20 28 63 6f 6d 6d 6f 6e 3a 67 65 r=\"" (common:ge
6df0: 74 2d 63 6f 6c 6f 72 2d 66 72 6f 6d 2d 73 74 61 t-color-from-sta
6e00: 74 75 73 20 73 74 61 74 75 73 29 20 22 5c 22 3e tus status) "\">
6e10: 22 20 73 74 61 74 75 73 0a 09 09 09 20 20 20 22 " status.... "
6e20: 3c 2f 66 6f 6e 74 3e 3c 2f 74 64 3e 3c 74 64 3e </font></td><td>
6e30: 22 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 " (hash-table-re
6e40: 66 20 63 6f 75 6e 74 73 20 73 74 61 74 75 73 29 f counts status)
6e50: 20 22 3c 2f 74 64 3e 3c 2f 74 72 3e 22 29 29 0a "</td></tr>")).
6e60: 09 09 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d .. (hash-table-
6e70: 6b 65 79 73 20 63 6f 75 6e 74 73 29 29 0a 09 28 keys counts))..(
6e80: 70 72 69 6e 74 20 22 3c 74 72 3e 3c 74 64 3e 54 print "<tr><td>T
6e90: 6f 74 61 6c 3c 2f 74 64 3e 3c 74 64 3e 22 20 74 otal</td><td>" t
6ea0: 6f 74 20 22 3c 2f 74 64 3e 3c 2f 74 72 3e 3c 2f ot "</td></tr></
6eb0: 74 61 62 6c 65 3e 22 29 0a 09 28 70 72 69 6e 74 table>")..(print
6ec0: 20 22 3c 2f 74 64 3e 3c 2f 74 64 3e 3c 2f 74 72 "</td></td></tr
6ed0: 3e 3c 2f 74 61 62 6c 65 3e 22 29 0a 09 0a 09 28 ></table>")....(
6ee0: 70 72 69 6e 74 20 22 3c 74 61 62 6c 65 20 63 65 print "<table ce
6ef0: 6c 6c 73 70 61 63 69 6e 67 3d 5c 22 30 5c 22 20 llspacing=\"0\"
6f00: 62 6f 72 64 65 72 3d 5c 22 31 5c 22 3e 22 20 0a border=\"1\">" .
6f10: 09 20 20 20 20 20 20 20 22 3c 74 72 3e 3c 74 64 . "<tr><td
6f20: 3e 49 74 65 6d 3c 2f 74 64 3e 3c 74 64 3e 53 74 >Item</td><td>St
6f30: 61 74 65 3c 2f 74 64 3e 3c 74 64 3e 53 74 61 74 ate</td><td>Stat
6f40: 75 73 3c 2f 74 64 3e 3c 74 64 3e 43 6f 6d 6d 65 us</td><td>Comme
6f50: 6e 74 3c 2f 74 64 3e 22 0a 09 20 20 20 20 20 20 nt</td>"..
6f60: 20 6f 75 74 74 78 74 20 22 3c 2f 74 61 62 6c 65 outtxt "</table
6f70: 3e 3c 2f 62 6f 64 79 3e 3c 2f 68 74 6d 6c 3e 22 ></body></html>"
6f80: 29 0a 09 3b 3b 20 28 72 65 6c 65 61 73 65 2d 64 )..;; (release-d
6f90: 6f 74 2d 6c 6f 63 6b 20 6f 75 74 70 75 74 66 69 ot-lock outputfi
6fa0: 6c 65 6e 61 6d 65 29 0a 09 3b 3b 28 72 6d 74 3a lename)..;;(rmt:
6fb0: 75 70 64 61 74 65 2d 72 75 6e 2d 73 74 61 74 73 update-run-stats
6fc0: 20 0a 09 3b 3b 20 72 75 6e 2d 69 64 0a 09 3b 3b ..;; run-id..;;
6fd0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6d 61 70 (hash-table-map
6fe0: 0a 09 3b 3b 20 20 73 74 61 74 65 2d 73 74 61 74 ..;; state-stat
6ff0: 75 73 2d 63 6f 75 6e 74 73 0a 09 3b 3b 20 20 28 us-counts..;; (
7000: 6c 61 6d 62 64 61 20 28 6b 65 79 20 76 61 6c 29 lambda (key val)
7010: 0a 09 3b 3b 09 28 61 70 70 65 6e 64 20 6b 65 79 ..;;.(append key
7020: 20 28 6c 69 73 74 20 76 61 6c 29 29 29 29 29 0a (list val))))).
7030: 09 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 74 .))))..(define t
7040: 65 73 74 73 3a 63 73 73 2d 6a 73 63 72 69 70 74 ests:css-jscript
7050: 2d 62 6c 6f 63 6b 0a 23 3c 3c 45 4f 46 0a 3c 73 -block.#<<EOF.<s
7060: 74 79 6c 65 20 74 79 70 65 3d 22 74 65 78 74 2f tyle type="text/
7070: 63 73 73 22 3e 0a 75 6c 2e 4c 69 6e 6b 65 64 4c css">.ul.LinkedL
7080: 69 73 74 20 7b 20 64 69 73 70 6c 61 79 3a 20 62 ist { display: b
7090: 6c 6f 63 6b 3b 20 7d 0a 2f 2a 20 75 6c 2e 4c 69 lock; }./* ul.Li
70a0: 6e 6b 65 64 4c 69 73 74 20 75 6c 20 7b 20 64 69 nkedList ul { di
70b0: 73 70 6c 61 79 3a 20 6e 6f 6e 65 3b 20 7d 20 2a splay: none; } *
70c0: 2f 0a 2e 48 61 6e 64 43 75 72 73 6f 72 53 74 79 /..HandCursorSty
70d0: 6c 65 20 7b 20 63 75 72 73 6f 72 3a 20 70 6f 69 le { cursor: poi
70e0: 6e 74 65 72 3b 20 63 75 72 73 6f 72 3a 20 68 61 nter; cursor: ha
70f0: 6e 64 3b 20 7d 20 20 2f 2a 20 46 6f 72 20 49 45 nd; } /* For IE
7100: 20 2a 2f 0a 74 68 20 7b 62 61 63 6b 67 72 6f 75 */.th {backgrou
7110: 6e 64 2d 63 6f 6c 6f 72 3a 20 23 38 63 38 63 38 nd-color: #8c8c8
7120: 63 3b 7d 0a 74 64 2e 74 65 73 74 20 7b 62 61 63 c;}.td.test {bac
7130: 6b 67 72 6f 75 6e 64 2d 63 6f 6c 6f 72 3a 20 23 kground-color: #
7140: 64 39 64 62 64 64 3b 7d 0a 74 64 2e 50 41 53 53 d9dbdd;}.td.PASS
7150: 20 7b 62 61 63 6b 67 72 6f 75 6e 64 2d 63 6f 6c {background-col
7160: 6f 72 3a 20 23 33 34 37 35 33 33 3b 7d 0a 74 64 or: #347533;}.td
7170: 2e 46 41 49 4c 20 7b 62 61 63 6b 67 72 6f 75 6e .FAIL {backgroun
7180: 64 2d 63 6f 6c 6f 72 3a 20 23 63 63 32 38 31 32 d-color: #cc2812
7190: 3b 7d 0a 74 64 2e 53 4b 49 50 7b 62 61 63 6b 67 ;}.td.SKIP{backg
71a0: 72 6f 75 6e 64 2d 63 6f 6c 6f 72 3a 20 23 46 46 round-color: #FF
71b0: 44 37 33 33 3b 7d 0a 74 64 2e 57 41 52 4e 20 7b D733;}.td.WARN {
71c0: 62 61 63 6b 67 72 6f 75 6e 64 2d 63 6f 6c 6f 72 background-color
71d0: 3a 20 23 45 41 38 37 32 34 3b 7d 0a 74 64 2e 57 : #EA8724;}.td.W
71e0: 41 49 56 45 44 20 7b 62 61 63 6b 67 72 6f 75 6e AIVED {backgroun
71f0: 64 2d 63 6f 6c 6f 72 3a 20 23 38 33 38 41 31 32 d-color: #838A12
7200: 3b 7d 0a 74 64 2e 41 42 4f 52 54 7b 62 61 63 6b ;}.td.ABORT{back
7210: 67 72 6f 75 6e 64 2d 63 6f 6c 6f 72 3a 20 23 45 ground-color: #E
7220: 41 32 34 42 37 3b 7d 0a 2e 50 41 53 53 20 2e 6c A24B7;}..PASS .l
7230: 69 6e 6b 2c 20 2e 53 4b 49 50 20 2e 6c 69 6e 6b ink, .SKIP .link
7240: 2c 20 2e 57 41 52 4e 20 2e 6c 69 6e 6b 2c 2e 57 , .WARN .link,.W
7250: 41 49 56 45 44 20 2e 6c 69 6e 6b 2c 2e 41 42 4f AIVED .link,.ABO
7260: 52 54 20 2e 6c 69 6e 6b 2c 20 2e 46 41 49 4c 20 RT .link, .FAIL
7270: 2e 6c 69 6e 6b 7b 63 6f 6c 6f 72 3a 20 23 46 46 .link{color: #FF
7280: 46 46 46 46 3b 7d 0a 0a 0a 3c 2f 73 74 79 6c 65 FFFF;}...</style
7290: 3e 0a 0a 0a 20 20 3c 73 63 72 69 70 74 20 74 79 >... <script ty
72a0: 70 65 3d 22 74 65 78 74 2f 4a 61 76 61 53 63 72 pe="text/JavaScr
72b0: 69 70 74 22 3e 0a 0a 20 20 20 20 66 75 6e 63 74 ipt">.. funct
72c0: 69 6f 6e 20 66 69 6c 74 65 72 73 6f 6d 65 28 29 ion filtersome()
72d0: 20 7b 0a 20 20 24 28 22 74 72 22 29 2e 73 68 6f {. $("tr").sho
72e0: 77 28 29 3b 0a 20 20 24 28 22 2e 74 65 73 74 22 w();. $(".test"
72f0: 29 2e 66 69 6c 74 65 72 28 0a 20 20 20 20 66 75 ).filter(. fu
7300: 6e 63 74 69 6f 6e 28 29 20 7b 0a 20 20 20 20 20 nction() {.
7310: 20 76 61 72 20 6e 61 6d 65 73 20 3d 20 24 28 27 var names = $('
7320: 23 74 65 73 74 6e 61 6d 65 27 29 2e 76 61 6c 28 #testname').val(
7330: 29 2e 73 70 6c 69 74 28 27 2c 27 29 3b 0a 20 20 ).split(',');.
7340: 20 20 20 20 76 61 72 20 67 6f 6f 64 3d 31 3b 0a var good=1;.
7350: 20 20 20 20 20 20 66 6f 72 20 28 76 61 72 20 69 for (var i
7360: 3d 30 2c 20 6c 65 6e 3d 6e 61 6d 65 73 2e 6c 65 =0, len=names.le
7370: 6e 67 74 68 3b 20 69 3c 6c 65 6e 3b 20 69 2b 2b ngth; i<len; i++
7380: 29 20 7b 0a 20 20 20 20 20 20 20 20 76 61 72 20 ) {. var
7390: 75 6e 61 6d 65 3d 6e 61 6d 65 73 5b 69 5d 3b 0a uname=names[i];.
73a0: 20 20 20 20 20 20 20 20 63 6f 6e 73 6f 6c 65 2e console.
73b0: 6c 6f 67 28 22 54 72 79 69 6e 67 20 74 6f 20 63 log("Trying to c
73c0: 68 65 63 6b 20 66 6f 72 20 22 20 2b 20 75 6e 61 heck for " + una
73d0: 6d 65 29 3b 20 0a 20 20 20 20 20 20 20 20 69 66 me); . if
73e0: 28 24 28 74 68 69 73 29 2e 74 65 78 74 28 29 2e ($(this).text().
73f0: 69 6e 64 65 78 4f 66 28 75 6e 61 6d 65 29 20 21 indexOf(uname) !
7400: 3d 20 2d 31 29 20 7b 0a 20 20 20 20 20 20 20 20 = -1) {.
7410: 20 20 67 6f 6f 64 3d 20 30 3b 0a 20 20 20 20 20 good= 0;.
7420: 20 20 20 20 20 63 6f 6e 73 6f 6c 65 2e 6c 6f 67 console.log
7430: 28 22 46 6f 75 6e 64 20 22 2b 75 6e 61 6d 65 29 ("Found "+uname)
7440: 3b 0a 20 20 20 20 20 20 20 20 7d 0a 20 20 20 20 ;. }.
7450: 20 20 7d 0a 20 20 20 20 20 20 72 65 74 75 72 6e }. return
7460: 20 67 6f 6f 64 3b 20 0a 20 20 20 20 7d 0a 20 20 good; . }.
7470: 29 2e 70 61 72 65 6e 74 28 29 2e 68 69 64 65 28 ).parent().hide(
7480: 29 3b 0a 2f 2f 20 20 24 28 22 2e 73 75 6d 22 29 );.// $(".sum")
7490: 2e 73 68 6f 77 28 29 3b 0a 7d 0a 20 20 0a 20 20 .show();.}. .
74a0: 20 20 2f 2f 20 41 64 64 20 74 68 69 73 20 74 6f // Add this to
74b0: 20 74 68 65 20 6f 6e 6c 6f 61 64 20 65 76 65 6e the onload even
74c0: 74 20 6f 66 20 74 68 65 20 42 4f 44 59 20 65 6c t of the BODY el
74d0: 65 6d 65 6e 74 0a 20 20 20 20 66 75 6e 63 74 69 ement. functi
74e0: 6f 6e 20 61 64 64 45 76 65 6e 74 73 28 29 20 7b on addEvents() {
74f0: 0a 20 20 20 20 20 20 61 63 74 69 76 61 74 65 54 . activateT
7500: 72 65 65 28 64 6f 63 75 6d 65 6e 74 2e 67 65 74 ree(document.get
7510: 45 6c 65 6d 65 6e 74 42 79 49 64 28 22 4c 69 6e ElementById("Lin
7520: 6b 65 64 4c 69 73 74 31 22 29 29 3b 0a 20 20 20 kedList1"));.
7530: 20 7d 0a 0a 20 20 20 20 2f 2f 20 54 68 69 73 20 }.. // This
7540: 66 75 6e 63 74 69 6f 6e 20 74 72 61 76 65 72 73 function travers
7550: 65 73 20 74 68 65 20 6c 69 73 74 20 61 6e 64 20 es the list and
7560: 61 64 64 20 6c 69 6e 6b 73 20 0a 20 20 20 20 2f add links . /
7570: 2f 20 74 6f 20 6e 65 73 74 65 64 20 6c 69 73 74 / to nested list
7580: 20 69 74 65 6d 73 0a 20 20 20 20 66 75 6e 63 74 items. funct
7590: 69 6f 6e 20 61 63 74 69 76 61 74 65 54 72 65 65 ion activateTree
75a0: 28 6f 4c 69 73 74 29 20 7b 0a 20 20 20 20 20 20 (oList) {.
75b0: 2f 2f 20 43 6f 6c 6c 61 70 73 65 20 74 68 65 20 // Collapse the
75c0: 74 72 65 65 0a 20 20 20 20 20 20 66 6f 72 20 28 tree. for (
75d0: 76 61 72 20 69 3d 30 3b 20 69 20 3c 20 6f 4c 69 var i=0; i < oLi
75e0: 73 74 2e 67 65 74 45 6c 65 6d 65 6e 74 73 42 79 st.getElementsBy
75f0: 54 61 67 4e 61 6d 65 28 22 75 6c 22 29 2e 6c 65 TagName("ul").le
7600: 6e 67 74 68 3b 20 69 2b 2b 29 20 7b 0a 20 20 20 ngth; i++) {.
7610: 20 20 20 20 20 6f 4c 69 73 74 2e 67 65 74 45 6c oList.getEl
7620: 65 6d 65 6e 74 73 42 79 54 61 67 4e 61 6d 65 28 ementsByTagName(
7630: 22 75 6c 22 29 5b 69 5d 2e 73 74 79 6c 65 2e 64 "ul")[i].style.d
7640: 69 73 70 6c 61 79 3d 22 6e 6f 6e 65 22 3b 20 20 isplay="none";
7650: 20 20 20 20 20 20 20 20 20 20 0a 20 20 20 20 20 .
7660: 20 7d 20 20 20 20 20 20 20 20 20 20 20 20 20 20 }
7670: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7680: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7690: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
76a0: 20 20 20 20 0a 20 20 20 20 20 20 2f 2f 20 41 64 . // Ad
76b0: 64 20 74 68 65 20 63 6c 69 63 6b 2d 65 76 65 6e d the click-even
76c0: 74 20 68 61 6e 64 6c 65 72 20 74 6f 20 74 68 65 t handler to the
76d0: 20 6c 69 73 74 20 69 74 65 6d 73 0a 20 20 20 20 list items.
76e0: 20 20 69 66 20 28 6f 4c 69 73 74 2e 61 64 64 45 if (oList.addE
76f0: 76 65 6e 74 4c 69 73 74 65 6e 65 72 29 20 7b 0a ventListener) {.
7700: 20 20 20 20 20 20 20 20 6f 4c 69 73 74 2e 61 64 oList.ad
7710: 64 45 76 65 6e 74 4c 69 73 74 65 6e 65 72 28 22 dEventListener("
7720: 63 6c 69 63 6b 22 2c 20 74 6f 67 67 6c 65 42 72 click", toggleBr
7730: 61 6e 63 68 2c 20 66 61 6c 73 65 29 3b 0a 20 20 anch, false);.
7740: 20 20 20 20 7d 20 65 6c 73 65 20 69 66 20 28 6f } else if (o
7750: 4c 69 73 74 2e 61 74 74 61 63 68 45 76 65 6e 74 List.attachEvent
7760: 29 20 7b 20 2f 2f 20 46 6f 72 20 49 45 0a 20 20 ) { // For IE.
7770: 20 20 20 20 20 20 6f 4c 69 73 74 2e 61 74 74 61 oList.atta
7780: 63 68 45 76 65 6e 74 28 22 6f 6e 63 6c 69 63 6b chEvent("onclick
7790: 22 2c 20 74 6f 67 67 6c 65 42 72 61 6e 63 68 29 ", toggleBranch)
77a0: 3b 0a 20 20 20 20 20 20 7d 0a 20 20 20 20 20 20 ;. }.
77b0: 2f 2f 20 4d 61 6b 65 20 74 68 65 20 6e 65 73 74 // Make the nest
77c0: 65 64 20 69 74 65 6d 73 20 6c 6f 6f 6b 20 6c 69 ed items look li
77d0: 6b 65 20 6c 69 6e 6b 73 0a 20 20 20 20 20 20 61 ke links. a
77e0: 64 64 4c 69 6e 6b 73 54 6f 42 72 61 6e 63 68 65 ddLinksToBranche
77f0: 73 28 6f 4c 69 73 74 29 3b 0a 20 20 20 20 7d 0a s(oList);. }.
7800: 0a 20 20 20 20 2f 2f 20 54 68 69 73 20 69 73 20 . // This is
7810: 74 68 65 20 63 6c 69 63 6b 2d 65 76 65 6e 74 20 the click-event
7820: 68 61 6e 64 6c 65 72 0a 20 20 20 20 66 75 6e 63 handler. func
7830: 74 69 6f 6e 20 74 6f 67 67 6c 65 42 72 61 6e 63 tion toggleBranc
7840: 68 28 65 76 65 6e 74 29 20 7b 0a 20 20 20 20 20 h(event) {.
7850: 20 76 61 72 20 6f 42 72 61 6e 63 68 2c 20 63 53 var oBranch, cS
7860: 75 62 42 72 61 6e 63 68 65 73 3b 0a 20 20 20 20 ubBranches;.
7870: 20 20 69 66 20 28 65 76 65 6e 74 2e 74 61 72 67 if (event.targ
7880: 65 74 29 20 7b 0a 20 20 20 20 20 20 20 20 6f 42 et) {. oB
7890: 72 61 6e 63 68 20 3d 20 65 76 65 6e 74 2e 74 61 ranch = event.ta
78a0: 72 67 65 74 3b 0a 20 20 20 20 20 20 7d 20 65 6c rget;. } el
78b0: 73 65 20 69 66 20 28 65 76 65 6e 74 2e 73 72 63 se if (event.src
78c0: 45 6c 65 6d 65 6e 74 29 20 7b 20 2f 2f 20 46 6f Element) { // Fo
78d0: 72 20 49 45 0a 20 20 20 20 20 20 20 20 6f 42 72 r IE. oBr
78e0: 61 6e 63 68 20 3d 20 65 76 65 6e 74 2e 73 72 63 anch = event.src
78f0: 45 6c 65 6d 65 6e 74 3b 0a 20 20 20 20 20 20 7d Element;. }
7900: 0a 20 20 20 20 20 20 63 53 75 62 42 72 61 6e 63 . cSubBranc
7910: 68 65 73 20 3d 20 6f 42 72 61 6e 63 68 2e 67 65 hes = oBranch.ge
7920: 74 45 6c 65 6d 65 6e 74 73 42 79 54 61 67 4e 61 tElementsByTagNa
7930: 6d 65 28 22 75 6c 22 29 3b 0a 20 20 20 20 20 20 me("ul");.
7940: 69 66 20 28 63 53 75 62 42 72 61 6e 63 68 65 73 if (cSubBranches
7950: 2e 6c 65 6e 67 74 68 20 3e 20 30 29 20 7b 0a 20 .length > 0) {.
7960: 20 20 20 20 20 20 20 69 66 20 28 63 53 75 62 42 if (cSubB
7970: 72 61 6e 63 68 65 73 5b 30 5d 2e 73 74 79 6c 65 ranches[0].style
7980: 2e 64 69 73 70 6c 61 79 20 3d 3d 20 22 62 6c 6f .display == "blo
7990: 63 6b 22 29 20 7b 0a 20 20 20 20 20 20 20 20 20 ck") {.
79a0: 20 63 53 75 62 42 72 61 6e 63 68 65 73 5b 30 5d cSubBranches[0]
79b0: 2e 73 74 79 6c 65 2e 64 69 73 70 6c 61 79 20 3d .style.display =
79c0: 20 22 6e 6f 6e 65 22 3b 0a 20 20 20 20 20 20 20 "none";.
79d0: 20 7d 20 65 6c 73 65 20 7b 0a 20 20 20 20 20 20 } else {.
79e0: 20 20 20 20 63 53 75 62 42 72 61 6e 63 68 65 73 cSubBranches
79f0: 5b 30 5d 2e 73 74 79 6c 65 2e 64 69 73 70 6c 61 [0].style.displa
7a00: 79 20 3d 20 22 62 6c 6f 63 6b 22 3b 0a 20 20 20 y = "block";.
7a10: 20 20 20 20 20 7d 0a 20 20 20 20 20 20 7d 0a 20 }. }.
7a20: 20 20 20 7d 0a 0a 20 20 20 20 2f 2f 20 54 68 69 }.. // Thi
7a30: 73 20 66 75 6e 63 74 69 6f 6e 20 6d 61 6b 65 73 s function makes
7a40: 20 6e 65 73 74 65 64 20 6c 69 73 74 20 69 74 65 nested list ite
7a50: 6d 73 20 6c 6f 6f 6b 20 6c 69 6b 65 20 6c 69 6e ms look like lin
7a60: 6b 73 0a 20 20 20 20 66 75 6e 63 74 69 6f 6e 20 ks. function
7a70: 61 64 64 4c 69 6e 6b 73 54 6f 42 72 61 6e 63 68 addLinksToBranch
7a80: 65 73 28 6f 4c 69 73 74 29 20 7b 0a 20 20 20 20 es(oList) {.
7a90: 20 20 76 61 72 20 63 42 72 61 6e 63 68 65 73 20 var cBranches
7aa0: 3d 20 6f 4c 69 73 74 2e 67 65 74 45 6c 65 6d 65 = oList.getEleme
7ab0: 6e 74 73 42 79 54 61 67 4e 61 6d 65 28 22 6c 69 ntsByTagName("li
7ac0: 22 29 3b 0a 20 20 20 20 20 20 76 61 72 20 69 2c ");. var i,
7ad0: 20 6e 2c 20 63 53 75 62 42 72 61 6e 63 68 65 73 n, cSubBranches
7ae0: 3b 0a 20 20 20 20 20 20 69 66 20 28 63 42 72 61 ;. if (cBra
7af0: 6e 63 68 65 73 2e 6c 65 6e 67 74 68 20 3e 20 30 nches.length > 0
7b00: 29 20 7b 0a 20 20 20 20 20 20 20 20 66 6f 72 20 ) {. for
7b10: 28 69 3d 30 2c 20 6e 20 3d 20 63 42 72 61 6e 63 (i=0, n = cBranc
7b20: 68 65 73 2e 6c 65 6e 67 74 68 3b 20 69 20 3c 20 hes.length; i <
7b30: 6e 3b 20 69 2b 2b 29 20 7b 0a 20 20 20 20 20 20 n; i++) {.
7b40: 20 20 20 20 63 53 75 62 42 72 61 6e 63 68 65 73 cSubBranches
7b50: 20 3d 20 63 42 72 61 6e 63 68 65 73 5b 69 5d 2e = cBranches[i].
7b60: 67 65 74 45 6c 65 6d 65 6e 74 73 42 79 54 61 67 getElementsByTag
7b70: 4e 61 6d 65 28 22 75 6c 22 29 3b 0a 20 20 20 20 Name("ul");.
7b80: 20 20 20 20 20 20 69 66 20 28 63 53 75 62 42 72 if (cSubBr
7b90: 61 6e 63 68 65 73 2e 6c 65 6e 67 74 68 20 3e 20 anches.length >
7ba0: 30 29 20 7b 0a 20 20 20 20 20 20 20 20 20 20 20 0) {.
7bb0: 20 61 64 64 4c 69 6e 6b 73 54 6f 42 72 61 6e 63 addLinksToBranc
7bc0: 68 65 73 28 63 53 75 62 42 72 61 6e 63 68 65 73 hes(cSubBranches
7bd0: 5b 30 5d 29 3b 0a 20 20 20 20 20 20 20 20 20 20 [0]);.
7be0: 20 20 63 42 72 61 6e 63 68 65 73 5b 69 5d 2e 63 cBranches[i].c
7bf0: 6c 61 73 73 4e 61 6d 65 20 3d 20 22 48 61 6e 64 lassName = "Hand
7c00: 43 75 72 73 6f 72 53 74 79 6c 65 22 3b 0a 20 20 CursorStyle";.
7c10: 20 20 20 20 20 20 20 20 20 20 63 42 72 61 6e 63 cBranc
7c20: 68 65 73 5b 69 5d 2e 73 74 79 6c 65 2e 63 6f 6c hes[i].style.col
7c30: 6f 72 20 3d 20 22 62 6c 75 65 22 3b 0a 20 20 20 or = "blue";.
7c40: 20 20 20 20 20 20 20 20 20 63 53 75 62 42 72 61 cSubBra
7c50: 6e 63 68 65 73 5b 30 5d 2e 73 74 79 6c 65 2e 63 nches[0].style.c
7c60: 6f 6c 6f 72 20 3d 20 22 62 6c 61 63 6b 22 3b 0a olor = "black";.
7c70: 20 20 20 20 20 20 20 20 20 20 20 20 63 53 75 62 cSub
7c80: 42 72 61 6e 63 68 65 73 5b 30 5d 2e 73 74 79 6c Branches[0].styl
7c90: 65 2e 63 75 72 73 6f 72 20 3d 20 22 61 75 74 6f e.cursor = "auto
7ca0: 22 3b 0a 20 20 20 20 20 20 20 20 20 20 7d 0a 20 ";. }.
7cb0: 20 20 20 20 20 20 20 7d 0a 20 20 20 20 20 20 7d }. }
7cc0: 0a 20 20 20 20 7d 0a 20 20 3c 2f 73 63 72 69 70 . }. </scrip
7cd0: 74 3e 0a 45 4f 46 0a 29 0a 0a 28 64 65 66 69 6e t>.EOF.)..(defin
7ce0: 65 20 74 65 73 74 73 3a 63 73 73 2d 6a 73 63 72 e tests:css-jscr
7cf0: 69 70 74 2d 62 6c 6f 63 6b 2d 64 79 6e 61 6d 69 ipt-block-dynami
7d00: 63 20 0a 23 3c 3c 45 4f 46 0a 20 20 20 20 20 20 c .#<<EOF.
7d10: 20 20 20 20 20 3c 73 63 72 69 70 74 20 73 72 63 <script src
7d20: 3d 20 2e 2f 6a 71 75 65 72 79 33 2e 31 2e 30 2e = ./jquery3.1.0.
7d30: 6a 73 3e 3c 2f 73 63 72 69 70 74 3e 20 0a 45 4f js></script> .EO
7d40: 46 0a 29 0a 0a 28 64 65 66 69 6e 65 20 20 28 74 F.)..(define (t
7d50: 65 73 74 3a 6a 73 2d 62 6c 6f 63 6b 20 6a 61 76 est:js-block jav
7d60: 61 73 63 72 69 70 74 2d 6c 69 62 29 0a 20 20 20 ascript-lib).
7d70: 28 63 6f 6e 63 20 20 22 3c 73 63 72 69 70 74 20 (conc "<script
7d80: 73 72 63 3d 22 20 6a 61 76 61 73 63 72 69 70 74 src=" javascript
7d90: 2d 6c 69 62 20 22 3e 3c 2f 73 63 72 69 70 74 3e -lib "></script>
7da0: 22 20 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 74 " ))...(define t
7db0: 65 73 74 73 3a 63 73 73 2d 6a 73 63 72 69 70 74 ests:css-jscript
7dc0: 2d 62 6c 6f 63 6b 2d 73 74 61 74 69 63 20 28 74 -block-static (t
7dd0: 65 73 74 3a 6a 73 2d 62 6c 6f 63 6b 20 2a 6a 61 est:js-block *ja
7de0: 76 61 2d 73 63 72 69 70 74 2d 6c 69 62 2a 29 29 va-script-lib*))
7df0: 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 ..(define (tests
7e00: 3a 63 73 73 2d 6a 73 63 72 69 70 74 2d 62 6c 6f :css-jscript-blo
7e10: 63 6b 2d 63 6f 6e 64 20 64 79 6e 61 6d 69 63 29 ck-cond dynamic)
7e20: 20 0a 20 20 20 20 20 20 28 69 66 20 28 65 71 75 . (if (equ
7e30: 61 6c 3f 20 64 79 6e 61 6d 69 63 20 20 23 74 29 al? dynamic #t)
7e40: 0a 20 20 20 20 20 20 20 74 65 73 74 73 3a 63 73 . tests:cs
7e50: 73 2d 6a 73 63 72 69 70 74 2d 62 6c 6f 63 6b 2d s-jscript-block-
7e60: 64 79 6e 61 6d 69 63 0a 20 20 20 20 20 20 20 74 dynamic. t
7e70: 65 73 74 73 3a 63 73 73 2d 6a 73 63 72 69 70 74 ests:css-jscript
7e80: 2d 62 6c 6f 63 6b 2d 73 74 61 74 69 63 29 29 0a -block-static)).
7e90: 0a 20 20 20 20 20 20 20 0a 28 64 65 66 69 6e 65 . .(define
7ea0: 20 28 74 65 73 74 73 3a 72 75 6e 2d 72 65 63 6f (tests:run-reco
7eb0: 72 64 2d 3e 74 65 73 74 2d 70 61 74 68 20 72 75 rd->test-path ru
7ec0: 6e 20 6e 75 6d 6b 65 79 73 29 0a 20 20 20 28 61 n numkeys). (a
7ed0: 70 70 65 6e 64 20 28 74 61 6b 65 20 28 76 65 63 ppend (take (vec
7ee0: 74 6f 72 2d 3e 6c 69 73 74 20 72 75 6e 29 20 6e tor->list run) n
7ef0: 75 6d 6b 65 79 73 29 0a 09 20 20 20 28 6c 69 73 umkeys).. (lis
7f00: 74 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 75 t (vector-ref ru
7f10: 6e 20 28 2b 20 31 20 6e 75 6d 6b 65 79 73 29 29 n (+ 1 numkeys))
7f20: 29 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 74 )))...(define (t
7f30: 65 73 74 73 3a 67 65 74 2d 72 65 73 74 2d 64 61 ests:get-rest-da
7f40: 74 61 20 72 75 6e 73 20 68 65 61 64 65 72 20 6e ta runs header n
7f50: 75 6d 6b 65 79 73 29 0a 20 20 20 28 6c 65 74 20 umkeys). (let
7f60: 28 28 72 65 73 68 20 28 6d 61 6b 65 2d 68 61 73 ((resh (make-has
7f70: 68 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 28 66 h-table))). (f
7f80: 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 6c 61 or-each. (la
7f90: 6d 62 64 61 20 28 72 75 6e 29 0a 20 20 20 20 20 mbda (run).
7fa0: 20 20 20 28 6c 65 74 2a 20 28 28 72 75 6e 2d 69 (let* ((run-i
7fb0: 64 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d d (db:get-value-
7fc0: 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 by-header run he
7fd0: 61 64 65 72 20 22 69 64 22 29 29 0a 20 20 20 20 ader "id")).
7fe0: 20 20 20 20 20 20 20 20 20 20 20 28 72 75 6e 2d (run-
7ff0: 64 69 72 20 20 20 20 20 20 28 74 65 73 74 73 3a dir (tests:
8000: 72 75 6e 2d 72 65 63 6f 72 64 2d 3e 74 65 73 74 run-record->test
8010: 2d 70 61 74 68 20 72 75 6e 20 6e 75 6d 6b 65 79 -path run numkey
8020: 73 29 29 0a 09 20 20 20 20 20 20 20 28 74 65 73 s)).. (tes
8030: 74 2d 64 61 74 61 20 20 20 20 28 72 6d 74 3a 67 t-data (rmt:g
8040: 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e et-tests-for-run
8050: 0a 09 09 09 09 20 20 20 72 75 6e 2d 69 64 0a 20 ..... run-id.
8060: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8070: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8080: 20 20 22 25 22 20 20 20 20 20 20 20 3b 3b 20 74 "%" ;; t
8090: 65 73 74 6e 61 6d 65 70 61 74 74 0a 09 09 09 09 estnamepatt.....
80a0: 20 20 20 27 28 29 20 20 20 20 20 20 20 20 3b 3b '() ;;
80b0: 20 73 74 61 74 65 73 0a 09 09 09 09 20 20 20 27 states..... '
80c0: 28 29 20 20 20 20 20 20 20 20 3b 3b 20 73 74 61 () ;; sta
80d0: 74 75 73 65 73 0a 09 09 09 09 20 20 20 23 66 20 tuses..... #f
80e0: 20 20 20 20 20 20 20 20 3b 3b 20 6f 66 66 73 65 ;; offse
80f0: 74 0a 09 09 09 09 20 20 20 23 66 20 20 20 20 20 t..... #f
8100: 20 20 20 20 3b 3b 20 6e 75 6d 2d 74 6f 2d 67 65 ;; num-to-ge
8110: 74 0a 09 09 09 09 20 20 20 23 66 20 20 20 20 20 t..... #f
8120: 20 20 20 20 3b 3b 20 68 69 64 65 2f 6e 6f 74 2d ;; hide/not-
8130: 68 69 64 65 0a 09 09 09 09 20 20 20 23 66 20 20 hide..... #f
8140: 20 20 20 20 20 20 20 3b 3b 20 73 6f 72 74 2d 62 ;; sort-b
8150: 79 0a 09 09 09 09 20 20 20 23 66 20 20 20 20 20 y..... #f
8160: 20 20 20 20 3b 3b 20 73 6f 72 74 2d 6f 72 64 65 ;; sort-orde
8170: 72 0a 09 09 09 09 20 20 20 23 66 20 20 20 20 20 r..... #f
8180: 20 20 20 20 3b 3b 20 27 73 68 6f 72 74 6c 69 73 ;; 'shortlis
8190: 74 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 t
81a0: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 71 ;; q
81b0: 72 79 74 79 70 65 0a 20 20 20 20 20 20 20 20 20 rytype.
81c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
81d0: 20 20 20 20 20 20 20 20 20 20 30 20 20 20 20 20 0
81e0: 20 20 20 20 3b 3b 20 6c 61 73 74 20 75 70 64 61 ;; last upda
81f0: 74 65 0a 09 09 09 09 20 20 20 23 66 29 29 29 0a te..... #f))).
8200: 20 20 20 20 20 20 20 20 20 20 20 20 0a 20 20 20 .
8210: 20 20 20 20 20 20 20 20 20 28 6d 61 70 20 28 6c (map (l
8220: 61 6d 62 64 61 20 28 74 65 73 74 29 0a 20 20 20 ambda (test).
8230: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l
8240: 65 74 2a 20 28 28 74 65 73 74 2d 6e 61 6d 65 20 et* ((test-name
8250: 28 76 65 63 74 6f 72 2d 72 65 66 20 74 65 73 74 (vector-ref test
8260: 20 32 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 2)).
8270: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 74 65 (te
8280: 73 74 2d 68 74 6d 6c 2d 70 61 74 68 20 28 63 6f st-html-path (co
8290: 6e 63 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 nc (vector-ref t
82a0: 65 73 74 20 31 30 29 20 22 2f 22 20 28 76 65 63 est 10) "/" (vec
82b0: 74 6f 72 2d 72 65 66 20 74 65 73 74 20 31 33 29 tor-ref test 13)
82c0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
82d0: 20 20 20 20 20 20 20 20 20 20 20 28 74 65 73 74 (test
82e0: 2d 69 74 65 6d 20 28 63 6f 6e 63 20 74 65 73 74 -item (conc test
82f0: 2d 6e 61 6d 65 20 22 3a 22 20 28 76 65 63 74 6f -name ":" (vecto
8300: 72 2d 72 65 66 20 74 65 73 74 20 31 31 29 29 29 r-ref test 11)))
8310: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
8320: 20 20 20 20 20 20 20 20 20 28 74 65 73 74 2d 73 (test-s
8330: 74 61 74 75 73 20 28 76 65 63 74 6f 72 2d 72 65 tatus (vector-re
8340: 66 20 74 65 73 74 20 34 29 29 29 0a 20 20 20 20 f test 4))).
8350: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8360: 20 20 20 20 20 0a 20 20 20 20 20 20 20 20 20 20 .
8370: 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 (if (not (
8380: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
8390: 65 66 61 75 6c 74 20 72 65 73 68 20 74 65 73 74 efault resh test
83a0: 2d 6e 61 6d 65 20 20 23 66 29 29 0a 20 20 20 20 -name #f)).
83b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
83c0: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
83d0: 74 21 20 72 65 73 68 20 74 65 73 74 2d 6e 61 6d t! resh test-nam
83e0: 65 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 e (make-hash-t
83f0: 61 62 6c 65 29 29 29 0a 20 20 20 20 20 20 20 20 able))).
8400: 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 (if (not
8410: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
8420: 2f 64 65 66 61 75 6c 74 20 28 68 61 73 68 2d 74 /default (hash-t
8430: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
8440: 20 72 65 73 68 20 74 65 73 74 2d 6e 61 6d 65 20 resh test-name
8450: 20 23 66 29 20 20 74 65 73 74 2d 69 74 65 6d 20 #f) test-item
8460: 20 23 66 29 29 0a 20 20 20 20 20 20 20 20 20 20 #f)).
8470: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 68 61 (ha
8480: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 28 68 sh-table-set! (h
8490: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
84a0: 66 61 75 6c 74 20 72 65 73 68 20 74 65 73 74 2d fault resh test-
84b0: 6e 61 6d 65 20 20 23 66 29 20 74 65 73 74 2d 69 name #f) test-i
84c0: 74 65 6d 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 tem (make-hash
84d0: 2d 74 61 62 6c 65 29 29 29 20 0a 20 20 20 20 20 -table))) .
84e0: 20 20 20 20 20 20 20 20 20 20 28 68 61 73 68 2d (hash-
84f0: 74 61 62 6c 65 2d 73 65 74 21 20 20 28 68 61 73 table-set! (has
8500: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
8510: 75 6c 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ult (hash-table-
8520: 72 65 66 2f 64 65 66 61 75 6c 74 20 72 65 73 68 ref/default resh
8530: 20 74 65 73 74 2d 6e 61 6d 65 20 20 23 66 29 20 test-name #f)
8540: 74 65 73 74 2d 69 74 65 6d 20 23 66 29 20 72 75 test-item #f) ru
8550: 6e 2d 69 64 20 28 6c 69 73 74 20 74 65 73 74 2d n-id (list test-
8560: 73 74 61 74 75 73 20 74 65 73 74 2d 68 74 6d 6c status test-html
8570: 2d 70 61 74 68 29 29 29 29 20 0a 20 20 20 20 20 -path)))) .
8580: 20 20 20 74 65 73 74 2d 64 61 74 61 29 29 29 0a test-data))).
8590: 20 20 20 20 20 20 72 75 6e 73 29 0a 20 20 20 72 runs). r
85a0: 65 73 68 29 29 0a 0a 0a 3b 3b 20 74 65 73 74 73 esh))...;; tests
85b0: 3a 67 65 6e 72 61 74 65 20 64 61 73 68 62 6f 61 :genrate dashboa
85c0: 72 64 20 62 6f 64 79 20 0a 3b 3b 0a 0a 28 64 65 rd body .;;..(de
85d0: 66 69 6e 65 20 28 74 65 73 74 73 3a 64 61 73 68 fine (tests:dash
85e0: 62 6f 61 72 64 2d 62 6f 64 79 20 70 61 67 65 20 board-body page
85f0: 70 67 2d 73 69 7a 65 20 6b 65 79 73 20 6e 75 6d pg-size keys num
8600: 6b 65 79 73 20 20 74 6f 74 61 6c 2d 72 75 6e 73 keys total-runs
8610: 20 6c 69 6e 6b 74 72 65 65 20 61 72 65 61 2d 6e linktree area-n
8620: 61 6d 65 20 67 65 74 2d 70 72 65 76 2d 6c 69 6e ame get-prev-lin
8630: 6b 73 20 67 65 74 2d 6e 65 78 74 2d 6c 69 6e 6b ks get-next-link
8640: 73 20 66 6c 61 67 20 72 75 6e 2d 70 61 74 74 20 s flag run-patt
8650: 74 61 72 67 65 74 2d 70 61 74 74 29 0a 20 20 28 target-patt). (
8660: 6c 65 74 2a 20 28 28 73 74 61 72 74 20 28 2a 20 let* ((start (*
8670: 70 61 67 65 20 70 67 2d 73 69 7a 65 29 29 20 0a page pg-size)) .
8680: 09 09 09 09 09 3b 28 72 75 6e 73 64 61 74 20 20 .....;(runsdat
8690: 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e 73 20 22 (rmt:get-runs "
86a0: 25 22 20 70 67 2d 73 69 7a 65 20 73 74 61 72 74 %" pg-size start
86b0: 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 78 (map (lambda (x
86c0: 29 28 6c 69 73 74 20 78 20 22 25 22 29 29 20 6b )(list x "%")) k
86d0: 65 79 73 29 29 29 0a 20 20 20 20 20 20 20 20 20 eys))).
86e0: 28 72 75 6e 73 64 61 74 20 20 20 28 72 6d 74 3a (runsdat (rmt:
86f0: 67 65 74 2d 72 75 6e 73 2d 62 79 2d 70 61 74 74 get-runs-by-patt
8700: 20 20 6b 65 79 73 20 72 75 6e 2d 70 61 74 74 20 keys run-patt
8710: 74 61 72 67 65 74 2d 70 61 74 74 20 73 74 61 72 target-patt star
8720: 74 20 70 67 2d 73 69 7a 65 20 23 66 20 30 20 73 t pg-size #f 0 s
8730: 6f 72 74 2d 6f 72 64 65 72 3a 20 22 64 65 73 63 ort-order: "desc
8740: 22 29 29 0a 09 09 09 09 09 3b 20 64 62 3a 67 65 "))......; db:ge
8750: 74 2d 72 75 6e 73 2d 62 79 2d 70 61 74 74 20 20 t-runs-by-patt
8760: 20 6b 65 79 73 20 72 75 6e 6e 61 6d 65 70 61 74 keys runnamepat
8770: 74 20 74 61 72 67 70 61 74 74 20 6f 66 66 73 65 t targpatt offse
8780: 74 20 6c 69 6d 69 74 20 66 69 65 6c 64 73 20 6c t limit fields l
8790: 61 73 74 2d 75 70 64 61 74 65 20 20 20 0a 09 20 ast-update ..
87a0: 28 68 65 61 64 65 72 20 20 20 20 28 76 65 63 74 (header (vect
87b0: 6f 72 2d 72 65 66 20 72 75 6e 73 64 61 74 20 30 or-ref runsdat 0
87c0: 29 29 0a 09 20 28 72 75 6e 73 20 20 20 20 20 20 )).. (runs
87d0: 28 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 73 (vector-ref runs
87e0: 64 61 74 20 31 29 29 0a 20 20 20 20 20 20 20 20 dat 1)).
87f0: 20 28 63 74 72 20 30 29 0a 20 20 20 20 20 20 20 (ctr 0).
8800: 20 20 28 74 65 73 74 2d 72 75 6e 73 2d 68 61 73 (test-runs-has
8810: 68 20 28 74 65 73 74 73 3a 67 65 74 2d 72 65 73 h (tests:get-res
8820: 74 2d 64 61 74 61 20 72 75 6e 73 20 68 65 61 64 t-data runs head
8830: 65 72 20 6e 75 6d 6b 65 79 73 29 29 0a 20 20 20 er numkeys)).
8840: 20 20 20 20 20 20 28 74 65 73 74 2d 6c 69 73 74 (test-list
8850: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 (hash-table-key
8860: 73 20 74 65 73 74 2d 72 75 6e 73 2d 68 61 73 68 s test-runs-hash
8870: 29 29 29 20 0a 20 20 20 20 0a 20 20 20 20 28 73 ))) . . (s
8880: 3a 68 74 6d 6c 20 74 65 73 74 73 3a 63 73 73 2d :html tests:css-
8890: 6a 73 63 72 69 70 74 2d 62 6c 6f 63 6b 20 28 74 jscript-block (t
88a0: 65 73 74 73 3a 63 73 73 2d 6a 73 63 72 69 70 74 ests:css-jscript
88b0: 2d 62 6c 6f 63 6b 2d 63 6f 6e 64 20 66 6c 61 67 -block-cond flag
88c0: 29 0a 09 20 20 20 20 28 73 3a 74 69 74 6c 65 20 ).. (s:title
88d0: 22 53 75 6d 6d 61 72 79 20 66 6f 72 20 22 20 61 "Summary for " a
88e0: 72 65 61 2d 6e 61 6d 65 29 0a 09 20 20 20 20 28 rea-name).. (
88f0: 73 3a 62 6f 64 79 20 27 6f 6e 6c 6f 61 64 20 22 s:body 'onload "
8900: 61 64 64 45 76 65 6e 74 73 28 29 3b 22 0a 09 09 addEvents();"...
8910: 20 20 20 20 28 67 65 74 2d 70 72 65 76 2d 6c 69 (get-prev-li
8920: 6e 6b 73 20 70 61 67 65 20 6c 69 6e 6b 74 72 65 nks page linktre
8930: 65 29 0a 09 09 20 20 20 20 28 67 65 74 2d 6e 65 e)... (get-ne
8940: 78 74 2d 6c 69 6e 6b 73 20 70 61 67 65 20 6c 69 xt-links page li
8950: 6e 6b 74 72 65 65 20 74 6f 74 61 6c 2d 72 75 6e nktree total-run
8960: 73 29 0a 09 09 20 20 20 20 0a 09 09 20 20 20 20 s)... ...
8970: 28 73 3a 68 31 20 22 53 75 6d 6d 61 72 79 20 66 (s:h1 "Summary f
8980: 6f 72 20 22 20 61 72 65 61 2d 6e 61 6d 65 29 0a or " area-name).
8990: 09 09 20 20 20 20 28 73 3a 68 33 20 22 46 69 6c .. (s:h3 "Fil
89a0: 74 65 72 22 20 29 0a 09 09 20 20 20 20 28 73 3a ter" )... (s:
89b0: 69 6e 70 75 74 20 27 74 79 70 65 20 22 74 65 78 input 'type "tex
89c0: 74 22 20 20 27 6e 61 6d 65 20 22 74 65 73 74 6e t" 'name "testn
89d0: 61 6d 65 22 20 27 69 64 20 22 74 65 73 74 6e 61 ame" 'id "testna
89e0: 6d 65 22 20 27 6c 65 6e 67 74 68 20 22 33 30 22 me" 'length "30"
89f0: 20 27 6f 6e 6b 65 79 75 70 20 22 66 69 6c 74 65 'onkeyup "filte
8a00: 72 73 6f 6d 65 28 29 22 29 0a 09 09 20 20 20 20 rsome()")...
8a10: 3b 3b 20 74 6f 70 20 6c 69 73 74 0a 09 09 20 20 ;; top list...
8a20: 20 20 0a 09 09 20 20 20 20 28 73 3a 74 61 62 6c ... (s:tabl
8a30: 65 20 27 69 64 20 22 4c 69 6e 6b 65 64 4c 69 73 e 'id "LinkedLis
8a40: 74 31 22 20 27 62 6f 72 64 65 72 20 22 31 22 20 t1" 'border "1"
8a50: 27 63 65 6c 6c 73 70 61 63 69 6e 67 20 30 0a 09 'cellspacing 0..
8a60: 09 09 20 20 20 20 20 28 6d 61 70 20 28 6c 61 6d .. (map (lam
8a70: 62 64 61 20 28 6b 65 79 29 0a 09 09 09 09 20 20 bda (key).....
8a80: 20 20 28 6c 65 74 2a 20 28 28 72 65 73 20 28 73 (let* ((res (s
8a90: 3a 74 72 20 27 63 6c 61 73 73 20 22 73 6f 6d 65 :tr 'class "some
8aa0: 74 68 69 6e 67 22 20 0a 09 09 09 09 09 09 20 20 thing" .......
8ab0: 20 20 20 20 28 73 3a 74 68 20 6b 65 79 20 29 0a (s:th key ).
8ac0: 09 09 09 09 09 09 20 20 20 20 20 20 28 6d 61 70 ...... (map
8ad0: 20 28 6c 61 6d 62 64 61 20 28 72 75 6e 29 0a 09 (lambda (run)..
8ae0: 09 09 09 09 09 09 20 20 20 20 20 28 73 3a 74 68 ...... (s:th
8af0: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 75 (vector-ref ru
8b00: 6e 20 63 74 72 29 29 29 0a 09 09 09 09 09 09 09 n ctr)))........
8b10: 20 20 20 72 75 6e 73 29 29 29 29 0a 09 09 09 09 runs)))).....
8b20: 20 20 20 20 20 20 28 73 65 74 21 20 63 74 72 20 (set! ctr
8b30: 28 2b 20 63 74 72 20 31 29 29 0a 09 09 09 09 20 (+ ctr 1)).....
8b40: 20 20 20 20 20 72 65 73 29 29 0a 09 09 09 09 20 res)).....
8b50: 20 6b 65 79 73 29 0a 09 09 09 20 20 20 20 20 28 keys).... (
8b60: 73 3a 74 72 0a 09 09 09 20 20 20 20 20 20 28 73 s:tr.... (s
8b70: 3a 74 68 20 22 52 75 6e 20 4e 61 6d 65 22 29 0a :th "Run Name").
8b80: 09 09 09 20 20 20 20 20 20 28 6d 61 70 20 28 6c ... (map (l
8b90: 61 6d 62 64 61 20 28 72 75 6e 29 0a 09 09 09 09 ambda (run).....
8ba0: 20 20 20 20 20 28 73 3a 74 68 20 28 64 62 3a 67 (s:th (db:g
8bb0: 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 et-value-by-head
8bc0: 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 72 er run header "r
8bd0: 75 6e 6e 61 6d 65 22 29 29 29 0a 09 09 09 09 20 unname"))).....
8be0: 20 20 72 75 6e 73 29 29 0a 09 09 09 20 20 20 20 runs))....
8bf0: 20 0a 09 09 09 20 20 20 20 20 28 6d 61 70 20 28 .... (map (
8c00: 6c 61 6d 62 64 61 20 28 74 65 73 74 2d 6e 61 6d lambda (test-nam
8c10: 65 29 0a 09 09 09 09 20 20 20 20 28 6c 65 74 2a e)..... (let*
8c20: 20 28 28 69 74 65 6d 2d 68 61 73 68 20 28 68 61 ((item-hash (ha
8c30: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
8c40: 61 75 6c 74 20 74 65 73 74 2d 72 75 6e 73 2d 68 ault test-runs-h
8c50: 61 73 68 20 74 65 73 74 2d 6e 61 6d 65 20 20 23 ash test-name #
8c60: 66 29 29 0a 09 09 09 09 09 20 20 20 28 69 74 65 f))...... (ite
8c70: 6d 2d 6b 65 79 73 20 28 73 6f 72 74 20 28 68 61 m-keys (sort (ha
8c80: 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 69 74 sh-table-keys it
8c90: 65 6d 2d 68 61 73 68 29 20 73 74 72 69 6e 67 3c em-hash) string<
8ca0: 3d 3f 29 29 29 20 0a 09 09 09 09 20 20 20 20 20 =?))) .....
8cb0: 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 69 (map (lambda (i
8cc0: 74 65 6d 2d 6e 61 6d 65 29 20 20 0a 20 20 09 09 tem-name) . ..
8cd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8ce0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 (le
8cf0: 74 2a 20 28 28 72 65 73 20 28 73 3a 74 72 20 20 t* ((res (s:tr
8d00: 27 63 6c 61 73 73 20 69 74 65 6d 2d 6e 61 6d 65 'class item-name
8d10: 0a 09 09 09 09 09 09 09 09 28 73 3a 74 64 20 20 .........(s:td
8d20: 69 74 65 6d 2d 6e 61 6d 65 20 27 63 6c 61 73 73 item-name 'class
8d30: 20 22 74 65 73 74 22 20 29 0a 09 09 09 09 09 09 "test" ).......
8d40: 09 09 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 ..(map (lambda (
8d50: 72 75 6e 29 0a 09 09 09 09 09 09 09 09 20 20 20 run).........
8d60: 20 20 20 20 28 6c 65 74 2a 20 28 28 72 75 6e 2d (let* ((run-
8d70: 74 65 73 74 20 28 68 61 73 68 2d 74 61 62 6c 65 test (hash-table
8d80: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 69 74 65 -ref/default ite
8d90: 6d 2d 68 61 73 68 20 69 74 65 6d 2d 6e 61 6d 65 m-hash item-name
8da0: 20 20 23 66 29 29 0a 09 09 09 09 09 09 09 09 09 #f))..........
8db0: 20 20 20 20 20 20 28 72 75 6e 2d 69 64 20 28 64 (run-id (d
8dc0: 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 b:get-value-by-h
8dd0: 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 eader run header
8de0: 20 22 69 64 22 29 29 0a 09 09 09 09 09 09 09 09 "id")).........
8df0: 09 20 20 20 20 20 20 28 72 65 73 75 6c 74 20 28 . (result (
8e00: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
8e10: 65 66 61 75 6c 74 20 72 75 6e 2d 74 65 73 74 20 efault run-test
8e20: 72 75 6e 2d 69 64 20 22 6e 2f 61 22 29 29 0a 09 run-id "n/a"))..
8e30: 09 09 09 09 3b 28 72 65 6c 61 74 69 76 65 2d 70 ....;(relative-p
8e40: 61 74 68 20 28 67 65 74 2d 72 65 6c 61 74 69 76 ath (get-relativ
8e50: 65 2d 70 61 74 68 29 29 20 0a 09 09 09 09 09 09 e-path)) .......
8e60: 09 09 09 20 20 20 20 20 20 28 73 74 61 74 75 73 ... (status
8e70: 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 72 65 (if (string? re
8e80: 73 75 6c 74 29 0a 09 09 09 09 09 09 09 09 09 09 sult)...........
8e90: 09 20 20 72 65 73 75 6c 74 0a 09 09 09 09 09 09 . result.......
8ea0: 09 09 09 09 09 20 20 28 63 61 72 20 72 65 73 75 ..... (car resu
8eb0: 6c 74 29 29 29 0a 09 09 09 09 09 09 09 09 09 20 lt)))..........
8ec0: 20 20 20 20 20 28 6c 69 6e 6b 20 28 69 66 20 28 (link (if (
8ed0: 73 74 72 69 6e 67 3f 20 72 65 73 75 6c 74 29 0a string? result).
8ee0: 09 09 09 09 09 09 09 09 09 09 09 72 65 73 75 6c ...........resul
8ef0: 74 0a 09 09 09 09 09 09 09 09 09 09 09 28 69 66 t............(if
8f00: 20 28 65 71 75 61 6c 3f 20 66 6c 61 67 20 23 74 (equal? flag #t
8f10: 29 20 0a 09 09 09 09 09 09 09 09 09 09 09 20 20 ) ............
8f20: 20 20 28 73 3a 61 20 28 63 61 72 20 72 65 73 75 (s:a (car resu
8f30: 6c 74 29 20 27 68 72 65 66 20 28 63 6f 6e 63 20 lt) 'href (conc
8f40: 22 2e 2f 74 65 73 74 5f 6c 6f 67 3f 72 75 6e 69 "./test_log?runi
8f50: 64 3d 22 20 72 75 6e 2d 69 64 20 22 26 74 65 73 d=" run-id "&tes
8f60: 74 6e 61 6d 65 3d 22 20 20 69 74 65 6d 2d 6e 61 tname=" item-na
8f70: 6d 65 20 29 29 0a 09 09 09 09 09 09 09 09 09 09 me ))...........
8f80: 09 20 20 20 20 28 73 3a 61 20 28 63 61 72 20 72 . (s:a (car r
8f90: 65 73 75 6c 74 29 20 27 68 72 65 66 20 28 73 74 esult) 'href (st
8fa0: 72 69 6e 67 2d 73 75 62 73 74 69 74 75 74 65 20 ring-substitute
8fb0: 20 28 63 6f 6e 63 20 6c 69 6e 6b 74 72 65 65 20 (conc linktree
8fc0: 22 2f 22 29 20 20 22 22 20 28 63 61 64 72 20 72 "/") "" (cadr r
8fd0: 65 73 75 6c 74 29 20 20 22 2d 22 29 29 29 29 29 esult) "-")))))
8fe0: 29 0a 09 09 09 09 09 09 09 09 09 20 28 73 3a 74 ).......... (s:t
8ff0: 64 20 20 6c 69 6e 6b 20 27 63 6c 61 73 73 20 73 d link 'class s
9000: 74 61 74 75 73 29 29 29 0a 09 09 09 09 09 09 09 tatus)))........
9010: 09 20 20 20 20 20 72 75 6e 73 29 29 29 29 0a 09 . runs))))..
9020: 09 09 09 09 20 20 20 20 20 20 20 72 65 73 29 29 .... res))
9030: 0a 09 09 09 09 09 20 20 20 69 74 65 6d 2d 6b 65 ...... item-ke
9040: 79 73 29 29 29 0a 09 09 09 09 20 20 74 65 73 74 ys)))..... test
9050: 2d 6c 69 73 74 29 29 29 29 29 29 20 0a 0a 3b 3b -list)))))) ..;;
9060: 20 28 74 65 73 74 73 3a 63 72 65 61 74 65 2d 68 (tests:create-h
9070: 74 6d 6c 2d 74 72 65 65 20 22 74 65 73 74 2d 69 tml-tree "test-i
9080: 6e 64 65 78 2e 68 74 6d 6c 22 29 0a 3b 3b 0a 28 ndex.html").;;.(
9090: 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 63 72 define (tests:cr
90a0: 65 61 74 65 2d 68 74 6d 6c 2d 74 72 65 65 20 6f eate-html-tree o
90b0: 75 74 66 29 0a 20 20 28 6c 65 74 2a 20 28 28 6c utf). (let* ((l
90c0: 6f 63 6b 66 69 6c 65 20 20 28 63 6f 6e 63 20 6f ockfile (conc o
90d0: 75 74 66 20 22 2e 6c 6f 63 6b 22 29 29 0a 09 20 utf ".lock"))..
90e0: 28 72 75 6e 73 2d 74 6f 2d 70 72 6f 63 65 73 73 (runs-to-process
90f0: 20 27 28 29 29 0a 20 20 20 20 20 20 20 20 20 28 '()). (
9100: 6c 69 6e 6b 74 72 65 65 20 20 28 63 6f 6d 6d 6f linktree (commo
9110: 6e 3a 67 65 74 2d 6c 69 6e 6b 74 72 65 65 29 29 n:get-linktree))
9120: 0a 20 20 20 20 20 20 20 20 20 28 61 72 65 61 2d . (area-
9130: 6e 61 6d 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 name (common:get
9140: 2d 74 65 73 74 73 75 69 74 65 2d 6e 61 6d 65 29 -testsuite-name)
9150: 29 0a 09 20 28 6b 65 79 73 20 20 20 20 20 20 28 ).. (keys (
9160: 72 6d 74 3a 67 65 74 2d 6b 65 79 73 29 29 0a 09 rmt:get-keys))..
9170: 20 28 6e 75 6d 6b 65 79 73 20 20 20 28 6c 65 6e (numkeys (len
9180: 67 74 68 20 6b 65 79 73 29 29 0a 20 20 20 20 20 gth keys)).
9190: 20 20 20 20 28 72 75 6e 2d 70 61 74 74 20 28 6f (run-patt (o
91a0: 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 r (args:get-arg
91b0: 22 2d 72 75 6e 2d 70 61 74 74 22 29 0a 09 09 20 "-run-patt")...
91c0: 20 20 20 20 20 20 28 61 72 67 73 3a 67 65 74 2d (args:get-
91d0: 61 72 67 20 22 2d 72 75 6e 6e 61 6d 65 22 29 0a arg "-runname").
91e0: 09 09 20 20 20 20 20 20 20 22 25 22 29 29 0a 20 .. "%")).
91f0: 20 20 20 20 20 20 20 20 28 74 61 72 67 65 74 20 (target
9200: 28 6f 72 20 20 28 61 72 67 73 3a 67 65 74 2d 61 (or (args:get-a
9210: 72 67 20 22 2d 74 61 72 67 65 74 2d 70 61 74 74 rg "-target-patt
9220: 22 29 20 0a 09 09 20 20 20 20 20 20 28 61 72 67 ") ... (arg
9230: 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 72 67 s:get-arg "-targ
9240: 65 74 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 et").
9250: 20 20 20 20 20 20 20 20 20 20 20 22 25 22 29 29 "%"))
9260: 0a 20 20 20 20 20 20 20 20 20 28 74 61 72 67 6c . (targl
9270: 69 73 74 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 ist (string-spli
9280: 74 20 74 61 72 67 65 74 20 22 2f 22 29 29 0a 20 t target "/")).
9290: 20 20 20 20 20 20 20 20 28 6e 75 6d 74 61 72 67 (numtarg
92a0: 20 20 28 6c 65 6e 67 74 68 20 74 61 72 67 6c 69 (length targli
92b0: 73 74 29 29 20 20 0a 20 20 20 20 20 20 20 20 20 st)) .
92c0: 28 74 61 72 67 74 77 65 61 6b 65 64 20 28 69 66 (targtweaked (if
92d0: 20 28 3e 20 6e 75 6d 6b 65 79 73 20 6e 75 6d 74 (> numkeys numt
92e0: 61 72 67 29 0a 09 09 09 20 20 28 61 70 70 65 6e arg).... (appen
92f0: 64 20 74 61 72 67 6c 69 73 74 20 28 6d 61 6b 65 d targlist (make
9300: 2d 6c 69 73 74 20 28 2d 20 6e 75 6d 6b 65 79 73 -list (- numkeys
9310: 20 6e 75 6d 74 61 72 67 29 20 22 25 22 29 29 0a numtarg) "%")).
9320: 09 09 09 20 20 74 61 72 67 6c 69 73 74 29 29 0a ... targlist)).
9330: 20 20 20 20 20 20 20 20 20 28 74 61 72 67 65 74 (target
9340: 2d 70 61 74 74 20 28 73 74 72 69 6e 67 2d 6a 6f -patt (string-jo
9350: 69 6e 20 74 61 72 67 74 77 65 61 6b 65 64 20 22 in targtweaked "
9360: 2f 22 29 29 0a 09 09 09 09 09 3b 28 74 6f 74 61 /"))......;(tota
9370: 6c 2d 72 75 6e 73 20 20 28 72 6d 74 3a 67 65 74 l-runs (rmt:get
9380: 2d 6e 75 6d 2d 72 75 6e 73 20 22 25 22 29 29 20 -num-runs "%"))
9390: 3b 3b 74 68 69 73 20 6e 65 65 64 73 20 74 6f 20 ;;this needs to
93a0: 62 65 20 63 68 61 6e 67 65 64 20 74 6f 20 66 69 be changed to fi
93b0: 6c 74 65 72 20 62 79 20 74 61 72 67 65 74 0a 09 lter by target..
93c0: 20 28 74 6f 74 61 6c 2d 72 75 6e 73 20 28 72 6d (total-runs (rm
93d0: 74 3a 67 65 74 2d 72 75 6e 73 2d 63 6e 74 2d 62 t:get-runs-cnt-b
93e0: 79 2d 70 61 74 74 20 72 75 6e 2d 70 61 74 74 20 y-patt run-patt
93f0: 74 61 72 67 65 74 2d 70 61 74 74 20 6b 65 79 73 target-patt keys
9400: 20 29 29 20 0a 20 20 20 20 20 20 20 20 20 28 70 )) . (p
9410: 67 2d 73 69 7a 65 20 31 30 29 29 0a 20 20 20 20 g-size 10)).
9420: 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 (if (common:simp
9430: 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 20 6c 6f 63 le-file-lock loc
9440: 6b 66 69 6c 65 29 0a 20 20 20 20 20 20 20 20 28 kfile). (
9450: 62 65 67 69 6e 0a 09 09 09 09 09 3b 28 70 72 69 begin......;(pri
9460: 6e 74 20 74 6f 74 61 6c 2d 72 75 6e 73 29 20 20 nt total-runs)
9470: 20 20 0a 09 20 20 28 6c 65 74 20 6c 6f 6f 70 20 .. (let loop
9480: 28 28 70 61 67 65 20 30 29 29 0a 09 20 20 20 20 ((page 0))..
9490: 28 6c 65 74 2a 20 28 28 6f 75 70 20 20 20 20 20 (let* ((oup
94a0: 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 6f 75 74 (open-out
94b0: 70 75 74 2d 66 69 6c 65 20 28 6f 72 20 6f 75 74 put-file (or out
94c0: 66 20 28 63 6f 6e 63 20 6c 69 6e 6b 74 72 65 65 f (conc linktree
94d0: 20 22 2f 70 61 67 65 22 20 70 61 67 65 20 22 2e "/page" page ".
94e0: 68 74 6d 6c 22 29 29 29 29 0a 09 09 20 20 20 28 html"))))... (
94f0: 67 65 74 2d 70 72 65 76 2d 6c 69 6e 6b 73 20 28 get-prev-links (
9500: 6c 61 6d 62 64 61 20 28 70 61 67 65 20 6c 69 6e lambda (page lin
9510: 6b 74 72 65 65 20 29 20 20 20 0a 09 09 09 09 20 ktree ) .....
9520: 20 20 20 20 28 6c 65 74 2a 20 28 28 6c 69 6e 6b (let* ((link
9530: 20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 (if (not (eq?
9540: 70 61 67 65 20 30 29 29 0a 09 09 09 09 09 09 20 page 0)).......
9550: 20 20 20 20 20 20 28 73 3a 61 20 22 26 6c 74 3b (s:a "<
9560: 26 6c 74 3b 70 72 65 76 22 20 27 68 72 65 66 20 <prev" 'href
9570: 28 63 6f 6e 63 20 20 22 70 61 67 65 22 20 28 2d (conc "page" (-
9580: 20 70 61 67 65 20 31 29 20 22 2e 68 74 6d 6c 22 page 1) ".html"
9590: 29 29 0a 09 09 09 09 09 09 20 20 20 20 20 20 20 )).......
95a0: 28 73 3a 61 20 22 22 20 27 68 72 65 66 20 28 63 (s:a "" 'href (c
95b0: 6f 6e 63 20 20 20 22 70 61 67 65 22 20 20 70 61 onc "page" pa
95c0: 67 65 20 22 2e 68 74 6d 6c 22 29 29 29 29 29 0a ge ".html"))))).
95d0: 09 09 09 09 20 20 20 20 20 20 20 6c 69 6e 6b 29 .... link)
95e0: 29 29 0a 09 09 20 20 20 28 67 65 74 2d 6e 65 78 ))... (get-nex
95f0: 74 2d 6c 69 6e 6b 73 20 28 6c 61 6d 62 64 61 20 t-links (lambda
9600: 28 70 61 67 65 20 6c 69 6e 6b 74 72 65 65 20 74 (page linktree t
9610: 6f 74 61 6c 2d 72 75 6e 73 29 20 20 20 0a 09 09 otal-runs) ...
9620: 09 09 20 20 20 20 20 28 6c 65 74 2a 20 28 28 6c .. (let* ((l
9630: 69 6e 6b 20 20 28 69 66 20 28 3e 20 74 6f 74 61 ink (if (> tota
9640: 6c 2d 72 75 6e 73 20 28 2b 20 31 30 20 28 2a 20 l-runs (+ 10 (*
9650: 70 61 67 65 20 70 67 2d 73 69 7a 65 29 29 29 0a page pg-size))).
9660: 09 09 09 09 09 09 20 20 20 20 20 20 20 28 73 3a ...... (s:
9670: 61 20 22 6e 65 78 74 26 67 74 3b 26 67 74 3b 22 a "next>>"
9680: 20 27 68 72 65 66 20 28 63 6f 6e 63 20 20 22 70 'href (conc "p
9690: 61 67 65 22 20 20 28 2b 20 70 61 67 65 20 31 29 age" (+ page 1)
96a0: 20 22 2e 68 74 6d 6c 22 29 29 0a 09 09 09 09 09 ".html"))......
96b0: 09 20 20 20 20 20 20 20 28 73 3a 61 20 22 22 20 . (s:a ""
96c0: 27 68 72 65 66 20 28 63 6f 6e 63 20 20 20 22 70 'href (conc "p
96d0: 61 67 65 22 20 70 61 67 65 20 20 22 2e 68 74 6d age" page ".htm
96e0: 6c 22 29 29 29 29 29 0a 09 09 09 09 20 20 20 20 l"))))).....
96f0: 20 20 20 6c 69 6e 6b 29 29 29 20 29 0a 09 20 20 link))) )..
9700: 20 20 20 20 28 70 72 69 6e 74 20 22 74 6f 74 61 (print "tota
9710: 6c 20 72 75 6e 73 3a 20 22 20 74 6f 74 61 6c 2d l runs: " total-
9720: 72 75 6e 73 29 20 0a 09 20 20 20 20 20 20 28 73 runs) .. (s
9730: 3a 6f 75 74 70 75 74 2d 6e 65 77 0a 09 20 20 20 :output-new..
9740: 20 20 20 20 6f 75 70 0a 09 20 20 20 20 20 20 20 oup..
9750: 28 74 65 73 74 73 3a 64 61 73 68 62 6f 61 72 64 (tests:dashboard
9760: 2d 62 6f 64 79 20 70 61 67 65 20 70 67 2d 73 69 -body page pg-si
9770: 7a 65 20 6b 65 79 73 20 6e 75 6d 6b 65 79 73 20 ze keys numkeys
9780: 74 6f 74 61 6c 2d 72 75 6e 73 20 6c 69 6e 6b 74 total-runs linkt
9790: 72 65 65 20 61 72 65 61 2d 6e 61 6d 65 20 67 65 ree area-name ge
97a0: 74 2d 70 72 65 76 2d 6c 69 6e 6b 73 20 67 65 74 t-prev-links get
97b0: 2d 6e 65 78 74 2d 6c 69 6e 6b 73 20 23 66 20 72 -next-links #f r
97c0: 75 6e 2d 70 61 74 74 20 74 61 72 67 65 74 2d 70 un-patt target-p
97d0: 61 74 74 29 29 20 3b 3b 20 75 70 64 61 74 65 20 att)) ;; update
97e0: 74 68 69 73 20 66 75 6e 63 74 69 6f 6e 0a 09 20 this function..
97f0: 20 20 20 20 20 28 63 6c 6f 73 65 2d 6f 75 74 70 (close-outp
9800: 75 74 2d 70 6f 72 74 20 6f 75 70 29 0a 09 09 09 ut-port oup)....
9810: 09 09 3b 20 28 73 65 74 21 20 70 61 67 65 20 28 ..; (set! page (
9820: 2b 20 31 20 70 61 67 65 29 29 0a 09 20 20 20 20 + 1 page))..
9830: 20 20 28 69 66 20 28 3e 20 74 6f 74 61 6c 2d 72 (if (> total-r
9840: 75 6e 73 20 28 2a 20 28 2b 20 31 20 70 61 67 65 uns (* (+ 1 page
9850: 29 20 70 67 2d 73 69 7a 65 29 29 0a 09 09 20 20 ) pg-size))...
9860: 28 6c 6f 6f 70 20 28 2b 20 31 20 20 70 61 67 65 (loop (+ 1 page
9870: 29 29 29 29 29 0a 09 20 20 28 63 6f 6d 6d 6f 6e ))))).. (common
9880: 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 72 65 6c :simple-file-rel
9890: 65 61 73 65 2d 6c 6f 63 6b 20 6c 6f 63 6b 66 69 ease-lock lockfi
98a0: 6c 65 29 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 le))..(begin..
98b0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
98c0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
98d0: 2a 20 22 46 61 69 6c 65 64 20 74 6f 20 67 65 74 * "Failed to get
98e0: 20 6c 6f 63 6b 20 6f 6e 20 66 69 6c 65 20 6f 75 lock on file ou
98f0: 74 66 2c 20 6c 6f 63 6b 66 69 6c 65 3a 20 22 20 tf, lockfile: "
9900: 6c 6f 63 6b 66 69 6c 65 29 20 23 66 29 29 29 29 lockfile) #f))))
9910: 0a 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 ...(define (test
9920: 73 3a 72 65 61 64 6c 69 6e 65 73 20 66 69 6c 65 s:readlines file
9930: 6e 61 6d 65 29 0a 20 20 28 63 61 6c 6c 2d 77 69 name). (call-wi
9940: 74 68 2d 69 6e 70 75 74 2d 66 69 6c 65 20 66 69 th-input-file fi
9950: 6c 65 6e 61 6d 65 0a 20 20 20 20 28 6c 61 6d 62 lename. (lamb
9960: 64 61 20 28 70 29 0a 20 20 20 20 20 20 28 6c 65 da (p). (le
9970: 74 20 6c 6f 6f 70 20 28 28 6c 69 6e 65 20 28 72 t loop ((line (r
9980: 65 61 64 2d 6c 69 6e 65 20 70 29 29 0a 20 20 20 ead-line p)).
9990: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 (r
99a0: 65 73 75 6c 74 20 27 28 29 29 29 0a 20 20 20 20 esult '())).
99b0: 20 20 20 20 28 69 66 20 28 65 6f 66 2d 6f 62 6a (if (eof-obj
99c0: 65 63 74 3f 20 6c 69 6e 65 29 0a 20 20 20 20 20 ect? line).
99d0: 20 20 20 20 20 20 20 28 72 65 76 65 72 73 65 20 (reverse
99e0: 72 65 73 75 6c 74 29 0a 20 20 20 20 20 20 20 20 result).
99f0: 20 20 20 20 28 6c 6f 6f 70 20 28 72 65 61 64 2d (loop (read-
9a00: 6c 69 6e 65 20 70 29 20 28 63 6f 6e 73 20 6c 69 line p) (cons li
9a10: 6e 65 20 72 65 73 75 6c 74 29 29 29 29 29 29 29 ne result)))))))
9a20: 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 ..(define (tests
9a30: 3a 67 65 74 2d 74 65 73 74 2d 6c 6f 67 20 72 75 :get-test-log ru
9a40: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 n-id test-name i
9a50: 74 65 6d 2d 6e 61 6d 65 29 0a 20 20 28 6c 65 74 tem-name). (let
9a60: 2a 20 28 28 74 65 73 74 2d 64 61 74 61 20 20 20 * ((test-data
9a70: 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 73 2d (rmt:get-tests-
9a80: 66 6f 72 2d 72 75 6e 0a 09 09 09 09 20 20 20 28 for-run..... (
9a90: 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 72 string->number r
9aa0: 75 6e 2d 69 64 29 0a 20 20 20 20 20 20 20 20 20 un-id).
9ab0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9ac0: 20 20 20 20 20 20 20 20 20 20 20 74 65 73 74 2d test-
9ad0: 6e 61 6d 65 20 20 20 20 20 20 3b 3b 20 74 65 73 name ;; tes
9ae0: 74 6e 61 6d 65 70 61 74 74 0a 09 09 09 09 20 20 tnamepatt.....
9af0: 20 27 28 29 20 20 20 20 20 20 20 20 3b 3b 20 73 '() ;; s
9b00: 74 61 74 65 73 0a 09 09 09 09 20 20 20 27 28 29 tates..... '()
9b10: 20 20 20 20 20 20 20 20 3b 3b 20 73 74 61 74 75 ;; statu
9b20: 73 65 73 0a 09 09 09 09 20 20 20 23 66 20 20 20 ses..... #f
9b30: 20 20 20 20 20 20 3b 3b 20 6f 66 66 73 65 74 0a ;; offset.
9b40: 09 09 09 09 20 20 20 23 66 20 20 20 20 20 20 20 .... #f
9b50: 20 20 3b 3b 20 6e 75 6d 2d 74 6f 2d 67 65 74 0a ;; num-to-get.
9b60: 09 09 09 09 20 20 20 23 66 20 20 20 20 20 20 20 .... #f
9b70: 20 20 3b 3b 20 68 69 64 65 2f 6e 6f 74 2d 68 69 ;; hide/not-hi
9b80: 64 65 0a 09 09 09 09 20 20 20 23 66 20 20 20 20 de..... #f
9b90: 20 20 20 20 20 3b 3b 20 73 6f 72 74 2d 62 79 0a ;; sort-by.
9ba0: 09 09 09 09 20 20 20 23 66 20 20 20 20 20 20 20 .... #f
9bb0: 20 20 3b 3b 20 73 6f 72 74 2d 6f 72 64 65 72 0a ;; sort-order.
9bc0: 09 09 09 09 20 20 20 23 66 20 20 20 20 20 20 20 .... #f
9bd0: 20 20 3b 3b 20 27 73 68 6f 72 74 6c 69 73 74 20 ;; 'shortlist
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 3b 3b 20 71 72 79 ;; qry
9c00: 74 79 70 65 0a 20 20 20 20 20 20 20 20 20 20 20 type.
9c10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9c20: 20 20 20 20 20 20 20 20 30 20 20 20 20 20 20 20 0
9c30: 20 20 3b 3b 20 6c 61 73 74 20 75 70 64 61 74 65 ;; last update
9c40: 0a 09 09 09 09 20 20 20 23 66 29 29 0a 20 20 20 ..... #f)).
9c50: 20 20 20 20 20 20 28 70 61 74 68 20 22 22 29 0a (path "").
9c60: 20 20 20 20 20 20 20 20 20 28 66 6f 75 6e 64 20 (found
9c70: 30 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 0)). (debug:p
9c80: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 rint-info 0 *def
9c90: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
9ca0: 66 6f 75 6e 64 3a 20 22 20 66 6f 75 6e 64 20 29 found: " found )
9cb0: 0a 0a 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 .. (let loop (
9cc0: 28 68 65 64 20 28 63 61 72 20 74 65 73 74 2d 64 (hed (car test-d
9cd0: 61 74 61 29 29 0a 09 09 20 28 74 61 6c 20 28 63 ata))... (tal (c
9ce0: 64 72 20 74 65 73 74 2d 64 61 74 61 29 29 29 0a dr test-data))).
9cf0: 20 20 20 20 20 20 20 20 20 20 28 64 65 62 75 67 (debug
9d00: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 :print-info 0 *d
9d10: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
9d20: 20 22 69 74 65 6d 3a 20 22 20 28 76 65 63 74 6f "item: " (vecto
9d30: 72 2d 72 65 66 20 68 65 64 20 31 31 29 20 28 76 r-ref hed 11) (v
9d40: 65 63 74 6f 72 2d 72 65 66 20 68 65 64 20 31 30 ector-ref hed 10
9d50: 29 20 22 2f 22 20 28 76 65 63 74 6f 72 2d 72 65 ) "/" (vector-re
9d60: 66 20 68 65 64 20 31 33 29 29 0a 0a 09 28 69 66 f hed 13))...(if
9d70: 20 28 65 71 75 61 6c 3f 20 28 76 65 63 74 6f 72 (equal? (vector
9d80: 2d 72 65 66 20 68 65 64 20 31 31 29 20 69 74 65 -ref hed 11) ite
9d90: 6d 2d 6e 61 6d 65 29 0a 20 20 20 20 20 20 20 20 m-name).
9da0: 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 (begin.
9db0: 20 20 20 20 20 20 20 20 20 28 73 65 74 21 20 66 (set! f
9dc0: 6f 75 6e 64 20 31 29 20 0a 09 20 20 20 20 20 20 ound 1) ..
9dd0: 28 73 65 74 21 20 70 61 74 68 20 28 63 6f 6e 63 (set! path (conc
9de0: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 68 65 64 (vector-ref hed
9df0: 20 31 30 29 20 22 2f 22 20 28 76 65 63 74 6f 72 10) "/" (vector
9e00: 2d 72 65 66 20 68 65 64 20 31 33 29 29 29 29 29 -ref hed 13)))))
9e10: 0a 09 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 .. (if (and (
9e20: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 not (null? tal))
9e30: 20 28 65 71 75 61 6c 3f 20 66 6f 75 6e 64 20 30 (equal? found 0
9e40: 29 29 0a 09 09 28 6c 6f 6f 70 20 28 63 61 72 20 ))...(loop (car
9e50: 74 61 6c 29 28 63 64 72 20 74 61 6c 29 29 29 29 tal)(cdr tal))))
9e60: 0a 20 20 20 28 69 66 20 28 65 71 75 61 6c 3f 20 . (if (equal?
9e70: 70 61 74 68 20 22 22 29 0a 20 20 20 20 20 22 3c path ""). "<
9e80: 48 32 3e 44 61 74 61 20 6e 6f 74 20 66 6f 75 6e H2>Data not foun
9e90: 64 3c 2f 48 32 3e 22 0a 20 20 20 20 20 28 73 74 d</H2>". (st
9ea0: 72 69 6e 67 2d 6a 6f 69 6e 20 28 74 65 73 74 73 ring-join (tests
9eb0: 3a 72 65 61 64 6c 69 6e 65 73 20 70 61 74 68 29 :readlines path)
9ec0: 20 22 5c 6e 22 29 29 29 29 0a 0a 0a 28 64 65 66 "\n"))))...(def
9ed0: 69 6e 65 20 28 74 65 73 74 73 3a 64 79 6e 61 6d ine (tests:dynam
9ee0: 69 63 2d 64 62 6f 61 72 64 20 70 61 67 65 29 0a ic-dboard page).
9ef0: 3b 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a ;(define (tests:
9f00: 63 72 65 61 74 65 2d 68 74 6d 6c 2d 74 72 65 65 create-html-tree
9f10: 20 6f 29 0a 20 28 6c 65 74 2a 20 28 0a 3b 28 70 o). (let* (.;(p
9f20: 61 67 65 20 22 31 22 29 0a 20 20 20 20 20 20 20 age "1").
9f30: 20 20 20 28 6c 69 6e 6b 74 72 65 65 20 20 28 63 (linktree (c
9f40: 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 69 6e 6b 74 72 ommon:get-linktr
9f50: 65 65 29 29 0a 20 20 20 20 20 20 20 20 20 28 61 ee)). (a
9f60: 72 65 61 2d 6e 61 6d 65 20 28 63 6f 6d 6d 6f 6e rea-name (common
9f70: 3a 67 65 74 2d 74 65 73 74 73 75 69 74 65 2d 6e :get-testsuite-n
9f80: 61 6d 65 29 29 0a 09 20 20 20 20 20 20 20 28 6b ame)).. (k
9f90: 65 79 73 20 20 20 20 20 20 28 72 6d 74 3a 67 65 eys (rmt:ge
9fa0: 74 2d 6b 65 79 73 29 29 0a 09 20 20 20 20 20 20 t-keys))..
9fb0: 20 28 6e 75 6d 6b 65 79 73 20 20 20 28 6c 65 6e (numkeys (len
9fc0: 67 74 68 20 6b 65 79 73 29 29 0a 20 20 20 20 20 gth keys)).
9fd0: 20 20 20 20 28 74 61 72 67 74 77 65 61 6b 65 64 (targtweaked
9fe0: 20 28 6d 61 6b 65 2d 6c 69 73 74 20 6e 75 6d 6b (make-list numk
9ff0: 65 79 73 20 22 25 22 29 29 0a 20 20 20 20 20 20 eys "%")).
a000: 20 20 20 28 74 61 72 67 65 74 2d 70 61 74 74 20 (target-patt
a010: 28 73 74 72 69 6e 67 2d 6a 6f 69 6e 20 74 61 72 (string-join tar
a020: 67 74 77 65 61 6b 65 64 20 22 2f 22 29 29 0a 20 gtweaked "/")).
a030: 20 20 20 20 20 20 20 20 28 74 6f 74 61 6c 2d 72 (total-r
a040: 75 6e 73 20 20 28 72 6d 74 3a 67 65 74 2d 6e 75 uns (rmt:get-nu
a050: 6d 2d 72 75 6e 73 20 22 25 22 29 29 0a 20 20 20 m-runs "%")).
a060: 20 20 20 20 20 20 28 70 67 2d 73 69 7a 65 20 31 (pg-size 1
a070: 30 29 0a 20 20 20 20 20 20 20 20 20 28 70 67 20 0). (pg
a080: 28 69 66 20 28 65 71 75 61 6c 3f 20 70 61 67 65 (if (equal? page
a090: 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 20 #f).
a0a0: 20 20 20 20 20 20 30 0a 20 20 20 20 20 20 20 20 0.
a0b0: 20 20 20 20 20 20 20 20 20 28 2d 20 28 73 74 72 (- (str
a0c0: 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 70 61 67 65 ing->number page
a0d0: 29 20 31 29 29 29 0a 20 20 20 20 20 20 20 20 20 ) 1))).
a0e0: 20 28 67 65 74 2d 70 72 65 76 2d 6c 69 6e 6b 73 (get-prev-links
a0f0: 20 20 28 6c 61 6d 62 64 61 20 28 70 67 20 6c 69 (lambda (pg li
a100: 6e 6b 74 72 65 65 29 0a 20 20 20 20 20 20 20 20 nktree).
a110: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a120: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
a130: 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d info 0 *default-
a140: 6c 6f 67 2d 70 6f 72 74 2a 20 22 76 61 6c 3a 20 log-port* "val:
a150: 22 20 28 2d 20 31 20 70 67 29 29 0a 20 20 20 20 " (- 1 pg)).
a160: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a170: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 6c 69 (let* ((li
a180: 6e 6b 20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 nk (if (not (eq
a190: 3f 20 70 67 20 30 29 29 0a 20 20 20 20 20 20 20 ? pg 0)).
a1a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a1b0: 20 20 20 20 20 20 20 20 28 73 3a 61 20 20 22 26 (s:a "&
a1c0: 6c 74 3b 26 6c 74 3b 70 72 65 76 20 22 20 27 68 lt;<prev " 'h
a1d0: 72 65 66 20 28 63 6f 6e 63 20 20 22 64 61 73 68 ref (conc "dash
a1e0: 62 6f 61 72 64 3f 70 61 67 65 3d 22 20 20 70 67 board?page=" pg
a1f0: 20 20 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 )).
a200: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a210: 20 20 20 20 28 73 3a 61 20 22 22 20 27 68 72 65 (s:a "" 'hre
a220: 66 20 28 63 6f 6e 63 20 20 22 64 61 73 68 62 6f f (conc "dashbo
a230: 61 72 64 3f 70 61 67 65 3d 22 20 70 67 29 29 29 ard?page=" pg)))
a240: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
a250: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a260: 20 20 6c 69 6e 6b 29 29 29 0a 20 20 20 20 20 20 link))).
a270: 20 20 20 20 28 67 65 74 2d 6e 65 78 74 2d 6c 69 (get-next-li
a280: 6e 6b 73 20 20 20 28 6c 61 6d 62 64 61 20 28 70 nks (lambda (p
a290: 67 20 6c 69 6e 6b 74 72 65 65 20 74 6f 74 61 6c g linktree total
a2a0: 2d 72 75 6e 73 29 20 20 0a 20 20 20 20 20 20 20 -runs) .
a2b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a2c0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
a2d0: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
a2e0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 76 61 6c t-log-port* "val
a2f0: 3a 20 22 20 70 67 29 0a 20 20 20 20 20 20 20 20 : " pg).
a300: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a310: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
a320: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
a330: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 76 61 6c t-log-port* "val
a340: 3a 20 22 20 74 6f 74 61 6c 2d 72 75 6e 73 20 22 : " total-runs "
a350: 20 73 69 7a 65 22 20 70 67 2d 73 69 7a 65 29 0a size" pg-size).
a360: 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
a370: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l
a380: 65 74 2a 20 28 28 6c 69 6e 6b 20 20 28 69 66 20 et* ((link (if
a390: 28 3e 20 74 6f 74 61 6c 2d 72 75 6e 73 20 28 2b (> total-runs (+
a3a0: 20 31 30 20 28 2a 20 70 67 20 70 67 2d 73 69 7a 10 (* pg pg-siz
a3b0: 65 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 e))).
a3c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a3d0: 20 20 20 28 73 3a 61 20 20 22 6e 65 78 74 26 67 (s:a "next&g
a3e0: 74 3b 26 67 74 3b 20 22 20 20 27 68 72 65 66 20 t;> " 'href
a3f0: 28 63 6f 6e 63 20 20 22 64 61 73 68 62 6f 61 72 (conc "dashboar
a400: 64 3f 70 61 67 65 3d 22 20 20 28 2b 20 70 67 20 d?page=" (+ pg
a410: 32 29 20 20 29 29 0a 20 20 20 20 20 20 20 20 20 2) )).
a420: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a430: 20 20 20 20 28 73 3a 61 20 22 22 20 27 68 72 65 (s:a "" 'hre
a440: 66 20 28 63 6f 6e 63 20 20 22 64 61 73 68 62 6f f (conc "dashbo
a450: 61 72 64 3f 70 61 67 65 3d 22 20 70 67 20 20 29 ard?page=" pg )
a460: 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 )))).
a470: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a480: 20 20 6c 69 6e 6b 29 29 29 0a 20 20 20 20 20 20 link))).
a490: 20 20 20 28 68 74 6d 6c 2d 62 6f 64 79 20 28 74 (html-body (t
a4a0: 65 73 74 73 3a 64 61 73 68 62 6f 61 72 64 2d 62 ests:dashboard-b
a4b0: 6f 64 79 20 70 67 20 70 67 2d 73 69 7a 65 20 6b ody pg pg-size k
a4c0: 65 79 73 20 6e 75 6d 6b 65 79 73 20 74 6f 74 61 eys numkeys tota
a4d0: 6c 2d 72 75 6e 73 20 6c 69 6e 6b 74 72 65 65 20 l-runs linktree
a4e0: 61 72 65 61 2d 6e 61 6d 65 20 67 65 74 2d 70 72 area-name get-pr
a4f0: 65 76 2d 6c 69 6e 6b 73 20 67 65 74 2d 6e 65 78 ev-links get-nex
a500: 74 2d 6c 69 6e 6b 73 20 23 74 20 22 25 22 20 74 t-links #t "%" t
a510: 61 72 67 65 74 2d 70 61 74 74 29 29 29 20 3b 3b arget-patt))) ;;
a520: 20 75 70 64 61 74 65 20 74 69 73 20 66 75 6e 63 update tis func
a530: 74 69 6f 6e 0a 20 20 20 20 20 20 20 20 68 74 6d tion. htm
a540: 6c 2d 62 6f 64 79 29 29 0a 0a 28 64 65 66 69 6e l-body))..(defin
a550: 65 20 28 74 65 73 74 73 3a 63 72 65 61 74 65 2d e (tests:create-
a560: 68 74 6d 6c 2d 73 75 6d 6d 61 72 79 20 6f 75 74 html-summary out
a570: 66 29 0a 20 28 6c 65 74 2a 20 28 28 6c 6f 63 6b f). (let* ((lock
a580: 66 69 6c 65 20 20 28 63 6f 6e 63 20 6f 75 74 66 file (conc outf
a590: 20 22 2e 6c 6f 63 6b 22 29 29 0a 20 20 20 20 20 ".lock")).
a5a0: 20 20 20 28 6c 69 6e 6b 74 72 65 65 20 20 28 63 (linktree (c
a5b0: 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 69 6e 6b 74 72 ommon:get-linktr
a5c0: 65 65 29 29 0a 09 09 09 09 28 6b 65 79 73 20 20 ee)).....(keys
a5d0: 20 20 20 20 28 72 6d 74 3a 67 65 74 2d 6b 65 79 (rmt:get-key
a5e0: 73 29 29 0a 20 20 20 20 20 20 20 20 28 61 72 65 s)). (are
a5f0: 61 2d 6e 61 6d 65 20 28 63 6f 6d 6d 6f 6e 3a 67 a-name (common:g
a600: 65 74 2d 74 65 73 74 73 75 69 74 65 2d 6e 61 6d et-testsuite-nam
a610: 65 29 29 0a 20 20 20 20 20 20 20 20 28 72 75 6e e)). (run
a620: 2d 70 61 74 74 20 28 6f 72 20 28 61 72 67 73 3a -patt (or (args:
a630: 67 65 74 2d 61 72 67 20 22 2d 72 75 6e 2d 70 61 get-arg "-run-pa
a640: 74 74 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 tt").
a650: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 61 72 (ar
a660: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 75 6e gs:get-arg "-run
a670: 6e 61 6d 65 22 29 0a 20 20 20 20 20 20 20 20 20 name").
a680: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 22 "
a690: 25 22 29 29 0a 20 20 20 20 20 20 20 20 28 74 61 %")). (ta
a6a0: 72 67 65 74 20 28 6f 72 20 28 61 72 67 73 3a 67 rget (or (args:g
a6b0: 65 74 2d 61 72 67 20 22 2d 74 61 72 67 65 74 2d et-arg "-target-
a6c0: 70 61 74 74 22 29 0a 20 20 20 20 20 20 20 20 20 patt").
a6d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
a6e0: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 args:get-arg "-t
a6f0: 61 72 67 65 74 22 29 0a 20 20 20 20 20 20 20 20 arget").
a700: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a710: 22 25 22 29 29 0a 20 20 20 20 20 20 20 20 20 28 "%")). (
a720: 74 61 72 67 6c 69 73 74 20 28 73 74 72 69 6e 67 targlist (string
a730: 2d 73 70 6c 69 74 20 74 61 72 67 65 74 20 22 2f -split target "/
a740: 22 29 29 0a 20 20 20 20 20 20 20 20 20 28 6e 75 ")). (nu
a750: 6d 6b 65 79 73 20 20 28 6c 65 6e 67 74 68 20 6b mkeys (length k
a760: 65 79 73 29 29 0a 09 20 20 20 20 20 20 20 28 6e eys)).. (n
a770: 75 6d 74 61 72 67 20 20 28 6c 65 6e 67 74 68 20 umtarg (length
a780: 74 61 72 67 6c 69 73 74 29 29 20 20 0a 20 20 20 targlist)) .
a790: 20 20 20 20 20 20 28 74 61 72 67 74 77 65 61 6b (targtweak
a7a0: 65 64 20 28 69 66 20 28 3e 20 6e 75 6d 6b 65 79 ed (if (> numkey
a7b0: 73 20 6e 75 6d 74 61 72 67 29 0a 09 09 09 20 20 s numtarg)....
a7c0: 20 09 09 09 09 09 09 09 09 28 61 70 70 65 6e 64 ........(append
a7d0: 20 74 61 72 67 6c 69 73 74 20 28 6d 61 6b 65 2d targlist (make-
a7e0: 6c 69 73 74 20 28 2d 20 6e 75 6d 6b 65 79 73 20 list (- numkeys
a7f0: 6e 75 6d 74 61 72 67 29 20 22 25 22 29 29 0a 09 numtarg) "%"))..
a800: 09 09 20 20 09 09 09 09 09 09 09 09 74 61 72 67 .. ........targ
a810: 6c 69 73 74 29 29 0a 20 20 20 20 20 20 20 20 28 list)). (
a820: 74 61 72 67 65 74 2d 70 61 74 74 20 28 73 74 72 target-patt (str
a830: 69 6e 67 2d 6a 6f 69 6e 20 74 61 72 67 74 77 65 ing-join targtwe
a840: 61 6b 65 64 20 22 2f 22 29 29 29 0a 20 20 20 20 aked "/"))).
a850: 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 (if (common:simp
a860: 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 20 6c 6f 63 le-file-lock loc
a870: 6b 66 69 6c 65 29 0a 20 20 20 20 20 20 20 20 28 kfile). (
a880: 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 begin.
a890: 28 6c 65 74 2a 20 28 3b 28 72 75 6e 73 64 61 74 (let* (;(runsdat
a8a0: 31 20 20 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e 1 (rmt:get-run
a8b0: 73 20 72 75 6e 2d 70 61 74 74 20 23 66 20 23 66 s run-patt #f #f
a8c0: 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 78 (map (lambda (x
a8d0: 29 28 6c 69 73 74 20 78 20 22 25 22 29 29 20 6b )(list x "%")) k
a8e0: 65 79 73 29 29 29 0a 20 20 20 20 20 20 20 20 20 eys))).
a8f0: 20 20 20 20 20 20 20 20 28 72 75 6e 73 64 61 74 (runsdat
a900: 20 20 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e 73 (rmt:get-runs
a910: 2d 62 79 2d 70 61 74 74 20 20 6b 65 79 73 20 72 -by-patt keys r
a920: 75 6e 2d 70 61 74 74 20 74 61 72 67 65 74 2d 70 un-patt target-p
a930: 61 74 74 20 23 66 20 23 66 20 23 66 20 30 29 29 att #f #f #f 0))
a940: 0a 09 09 09 09 09 20 20 20 20 20 20 20 28 72 75 ...... (ru
a950: 6e 73 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d ns (vector-
a960: 72 65 66 20 72 75 6e 73 64 61 74 20 31 29 29 0a ref runsdat 1)).
a970: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a980: 20 28 68 65 61 64 65 72 20 20 20 20 20 20 28 76 (header (v
a990: 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 73 64 61 ector-ref runsda
a9a0: 74 20 30 29 29 0a 20 20 20 20 20 20 20 20 09 20 t 0)). .
a9b0: 20 20 20 20 20 20 28 6f 75 70 20 20 20 20 20 20 (oup
a9c0: 20 28 6f 70 65 6e 2d 6f 75 74 70 75 74 2d 66 69 (open-output-fi
a9d0: 6c 65 20 28 6f 72 20 6f 75 74 66 20 28 63 6f 6e le (or outf (con
a9e0: 63 20 6c 69 6e 6b 74 72 65 65 20 22 2f 74 61 72 c linktree "/tar
a9f0: 67 65 74 73 2e 68 74 6d 6c 22 29 29 29 29 0a 20 gets.html")))).
aa00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
aa10: 28 74 61 72 67 65 74 2d 68 61 73 68 20 28 74 65 (target-hash (te
aa20: 73 74 3a 63 72 65 61 74 65 2d 74 61 72 67 65 74 st:create-target
aa30: 2d 68 61 73 68 20 72 75 6e 73 20 68 65 61 64 65 -hash runs heade
aa40: 72 20 28 6c 65 6e 67 74 68 20 6b 65 79 73 29 29 r (length keys))
aa50: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 74 )). (t
aa60: 65 73 74 3a 63 72 65 61 74 65 2d 74 61 72 67 65 est:create-targe
aa70: 74 2d 68 74 6d 6c 20 74 61 72 67 65 74 2d 68 61 t-html target-ha
aa80: 73 68 20 6f 75 70 20 61 72 65 61 2d 6e 61 6d 65 sh oup area-name
aa90: 20 6c 69 6e 6b 74 72 65 65 29 0a 20 20 20 20 20 linktree).
aaa0: 20 20 20 20 20 28 74 65 73 74 3a 63 72 65 61 74 (test:creat
aab0: 65 2d 72 75 6e 2d 68 74 6d 6c 20 20 72 75 6e 73 e-run-html runs
aac0: 20 61 72 65 61 2d 6e 61 6d 65 20 6c 69 6e 6b 74 area-name linkt
aad0: 72 65 65 20 28 6c 65 6e 67 74 68 20 6b 65 79 73 ree (length keys
aae0: 29 20 68 65 61 64 65 72 29 29 0a 09 20 20 28 63 ) header)).. (c
aaf0: 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c ommon:simple-fil
ab00: 65 2d 72 65 6c 65 61 73 65 2d 6c 6f 63 6b 20 6c e-release-lock l
ab10: 6f 63 6b 66 69 6c 65 29 29 0a 09 23 66 29 29 29 ockfile))..#f)))
ab20: 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 3a ..(define (test:
ab30: 67 65 74 2d 74 65 73 74 2d 68 61 73 68 20 74 65 get-test-hash te
ab40: 73 74 2d 64 61 74 61 29 0a 09 28 6c 65 74 20 28 st-data)..(let (
ab50: 28 72 65 73 68 20 28 6d 61 6b 65 2d 68 61 73 68 (resh (make-hash
ab60: 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 20 09 28 -table))). .(
ab70: 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 74 65 73 map (lambda (tes
ab80: 74 29 0a 20 20 20 20 20 20 20 20 28 6c 65 74 2a t). (let*
ab90: 20 28 28 74 65 73 74 2d 6e 61 6d 65 20 28 76 65 ((test-name (ve
aba0: 63 74 6f 72 2d 72 65 66 20 74 65 73 74 20 32 29 ctor-ref test 2)
abb0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
abc0: 20 28 74 65 73 74 2d 68 74 6d 6c 2d 70 61 74 68 (test-html-path
abd0: 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 (if (file-exist
abe0: 73 3f 20 28 63 6f 6e 63 20 28 76 65 63 74 6f 72 s? (conc (vector
abf0: 2d 72 65 66 20 74 65 73 74 20 31 30 29 20 22 2f -ref test 10) "/
ac00: 74 65 73 74 2d 73 75 6d 6d 61 72 79 2e 68 74 6d test-summary.htm
ac10: 6c 22 29 29 0a 09 09 09 09 09 09 09 09 09 09 09 l"))............
ac20: 09 09 09 09 09 20 28 63 6f 6e 63 20 28 76 65 63 ..... (conc (vec
ac30: 74 6f 72 2d 72 65 66 20 74 65 73 74 20 31 30 29 tor-ref test 10)
ac40: 20 22 2f 74 65 73 74 2d 73 75 6d 6d 61 72 79 2e "/test-summary.
ac50: 68 74 6d 6c 22 20 29 0a 09 09 09 09 09 09 09 20 html" )........
ac60: 09 09 09 09 09 09 09 09 09 20 28 63 6f 6e 63 20 ......... (conc
ac70: 28 76 65 63 74 6f 72 2d 72 65 66 20 74 65 73 74 (vector-ref test
ac80: 20 31 30 29 20 22 2f 22 20 28 76 65 63 74 6f 72 10) "/" (vector
ac90: 2d 72 65 66 20 74 65 73 74 20 31 33 29 29 29 29 -ref test 13))))
aca0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
acb0: 28 74 65 73 74 2d 69 74 65 6d 20 20 28 76 65 63 (test-item (vec
acc0: 74 6f 72 2d 72 65 66 20 74 65 73 74 20 31 31 29 tor-ref test 11)
acd0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
ace0: 20 28 74 65 73 74 2d 73 74 61 74 75 73 20 28 76 (test-status (v
acf0: 65 63 74 6f 72 2d 72 65 66 20 74 65 73 74 20 34 ector-ref test 4
ad00: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
ad10: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 68 61 73 (if (not (has
ad20: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
ad30: 75 6c 74 20 72 65 73 68 20 74 65 73 74 2d 69 74 ult resh test-it
ad40: 65 6d 20 20 23 66 29 29 0a 20 20 20 20 20 20 20 em #f)).
ad50: 20 20 20 20 20 20 20 20 20 20 20 20 28 68 61 73 (has
ad60: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 72 65 73 h-table-set! res
ad70: 68 20 74 65 73 74 2d 69 74 65 6d 20 20 20 28 6d h test-item (m
ad80: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
ad90: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
ada0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
adb0: 21 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 ! (hash-table-re
adc0: 66 2f 64 65 66 61 75 6c 74 20 72 65 73 68 20 74 f/default resh t
add0: 65 73 74 2d 69 74 65 6d 20 20 23 66 29 20 74 65 est-item #f) te
ade0: 73 74 2d 6e 61 6d 65 20 28 6c 69 73 74 20 74 65 st-name (list te
adf0: 73 74 2d 73 74 61 74 75 73 20 74 65 73 74 2d 68 st-status test-h
ae00: 74 6d 6c 2d 70 61 74 68 29 29 29 29 20 0a 20 20 tml-path)))) .
ae10: 20 20 20 20 20 20 74 65 73 74 2d 64 61 74 61 29 test-data)
ae20: 0a 72 65 73 68 29 29 0a 0a 28 64 65 66 69 6e 65 .resh))..(define
ae30: 20 28 74 65 73 74 3a 67 65 74 2d 64 61 74 61 2d (test:get-data-
ae40: 3e 62 2d 6b 65 79 73 20 6f 72 64 65 72 65 64 2d >b-keys ordered-
ae50: 64 61 74 61 20 61 2d 6b 65 79 73 29 0a 20 20 28 data a-keys). (
ae60: 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 74 65 delete-duplicate
ae70: 73 0a 20 20 20 28 73 6f 72 74 20 28 61 70 70 6c s. (sort (appl
ae80: 79 0a 09 20 20 61 70 70 65 6e 64 0a 09 20 20 28 y.. append.. (
ae90: 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 73 75 62 map (lambda (sub
aea0: 2d 6b 65 79 29 0a 09 09 20 28 6c 65 74 20 28 28 -key)... (let ((
aeb0: 73 75 62 64 61 74 20 28 68 61 73 68 2d 74 61 62 subdat (hash-tab
aec0: 6c 65 2d 72 65 66 20 6f 72 64 65 72 65 64 2d 64 le-ref ordered-d
aed0: 61 74 61 20 73 75 62 2d 6b 65 79 29 29 29 0a 09 ata sub-key)))..
aee0: 09 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d . (hash-table-
aef0: 6b 65 79 73 20 73 75 62 64 61 74 29 29 29 0a 09 keys subdat)))..
af00: 20 20 20 20 20 20 20 61 2d 6b 65 79 73 29 29 0a a-keys)).
af10: 09 20 73 74 72 69 6e 67 3e 3d 3f 29 29 29 0a 0a . string>=?)))..
af20: 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 3a 63 .(define (test:c
af30: 72 65 61 74 65 2d 72 75 6e 2d 68 74 6d 6c 20 72 reate-run-html r
af40: 75 6e 73 20 61 72 65 61 2d 6e 61 6d 65 20 6c 69 uns area-name li
af50: 6e 6b 74 72 65 65 20 6e 75 6d 6b 65 79 73 20 68 nktree numkeys h
af60: 65 61 64 65 72 29 0a 20 20 28 6d 61 70 20 28 6c eader). (map (l
af70: 61 6d 62 64 61 20 28 72 75 6e 29 0a 09 09 20 28 ambda (run)... (
af80: 6c 65 74 2a 20 28 28 74 61 72 67 65 74 20 28 73 let* ((target (s
af90: 74 72 69 6e 67 2d 6a 6f 69 6e 20 28 74 61 6b 65 tring-join (take
afa0: 20 28 76 65 63 74 6f 72 2d 3e 6c 69 73 74 20 72 (vector->list r
afb0: 75 6e 29 20 6e 75 6d 6b 65 79 73 29 20 22 2f 22 un) numkeys) "/"
afc0: 29 29 0a 09 09 09 09 09 09 28 72 75 6e 2d 6e 61 )).......(run-na
afd0: 6d 65 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 me (db:get-value
afe0: 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 -by-header run h
aff0: 65 61 64 65 72 20 22 72 75 6e 6e 61 6d 65 22 29 eader "runname")
b000: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 72 ). (r
b010: 75 6e 2d 74 69 6d 65 20 28 73 65 63 6f 6e 64 73 un-time (seconds
b020: 2d 3e 77 6f 72 6b 2d 77 65 65 6b 2f 64 61 79 2d ->work-week/day-
b030: 74 69 6d 65 20 28 64 62 3a 67 65 74 2d 76 61 6c time (db:get-val
b040: 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e ue-by-header run
b050: 20 68 65 61 64 65 72 20 22 65 76 65 6e 74 5f 74 header "event_t
b060: 69 6d 65 22 29 29 29 0a 09 09 09 09 09 09 28 6f ime"))).......(o
b070: 75 70 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 up (if (file-exi
b080: 73 74 73 3f 20 28 63 6f 6e 63 20 6c 69 6e 6b 74 sts? (conc linkt
b090: 72 65 65 20 22 2f 22 20 74 61 72 67 65 74 20 22 ree "/" target "
b0a0: 2f 22 20 72 75 6e 2d 6e 61 6d 65 29 29 0a 20 20 /" run-name)).
b0b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b0c0: 20 20 20 20 20 20 28 6f 70 65 6e 2d 6f 75 74 70 (open-outp
b0d0: 75 74 2d 66 69 6c 65 20 28 63 6f 6e 63 20 6c 69 ut-file (conc li
b0e0: 6e 6b 74 72 65 65 20 22 2f 22 20 74 61 72 67 65 nktree "/" targe
b0f0: 74 20 22 2f 22 20 72 75 6e 2d 6e 61 6d 65 20 22 t "/" run-name "
b100: 2f 72 75 6e 2e 68 74 6d 6c 22 29 29 0a 20 20 20 /run.html")).
b110: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b120: 20 20 20 20 20 20 23 66 29 29 0a 20 20 20 20 20 #f)).
b130: 20 20 20 20 20 20 20 28 72 75 6e 2d 69 64 20 28 (run-id (
b140: 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d db:get-value-by-
b150: 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 header run heade
b160: 72 20 22 69 64 22 29 29 0a 20 20 20 20 20 20 20 r "id")).
b170: 20 20 20 20 20 28 74 65 73 74 2d 64 61 74 61 20 (test-data
b180: 20 20 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 (rmt:get-test
b190: 73 2d 66 6f 72 2d 72 75 6e 0a 09 09 09 09 20 20 s-for-run.....
b1a0: 09 09 09 09 09 09 09 09 20 72 75 6e 2d 69 64 0a ........ run-id.
b1b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b1c0: 20 20 20 20 20 20 20 20 20 20 20 22 25 22 20 20 "%"
b1d0: 20 20 20 20 20 3b 3b 20 74 65 73 74 6e 61 6d 65 ;; testname
b1e0: 70 61 74 74 0a 09 09 09 09 20 20 09 09 09 09 09 patt..... .....
b1f0: 09 09 09 20 27 28 29 20 20 20 20 20 20 20 20 3b ... '() ;
b200: 3b 20 73 74 61 74 65 73 0a 09 09 09 09 20 20 20 ; states.....
b210: 09 09 09 09 09 09 09 09 20 27 28 29 20 20 20 20 ........ '()
b220: 20 20 20 20 3b 3b 20 73 74 61 74 75 73 65 73 0a ;; statuses.
b230: 09 09 09 09 20 20 09 09 09 09 09 09 09 09 20 09 .... ........ .
b240: 23 66 20 20 20 20 20 20 20 20 20 3b 3b 20 6f 66 #f ;; of
b250: 66 73 65 74 0a 09 09 09 09 20 20 09 09 09 09 09 fset..... .....
b260: 09 20 09 09 09 23 66 20 20 20 20 20 20 20 20 20 . ...#f
b270: 3b 3b 20 6e 75 6d 2d 74 6f 2d 67 65 74 0a 09 09 ;; num-to-get...
b280: 09 09 20 20 20 09 09 09 09 09 09 09 09 09 23 66 .. .........#f
b290: 20 20 20 20 20 20 20 20 20 3b 3b 20 68 69 64 65 ;; hide
b2a0: 2f 6e 6f 74 2d 68 69 64 65 0a 09 09 09 09 20 20 /not-hide.....
b2b0: 09 09 09 09 09 09 09 09 20 20 23 66 20 20 20 20 ........ #f
b2c0: 20 20 20 20 20 3b 3b 20 73 6f 72 74 2d 62 79 0a ;; sort-by.
b2d0: 09 09 09 09 20 20 20 09 09 09 09 09 09 09 09 09 .... .........
b2e0: 23 66 20 20 20 20 20 20 20 20 20 3b 3b 20 73 6f #f ;; so
b2f0: 72 74 2d 6f 72 64 65 72 0a 09 09 09 09 20 20 20 rt-order.....
b300: 09 09 09 09 09 09 09 09 09 23 66 20 20 20 20 20 .........#f
b310: 20 20 20 20 3b 3b 20 27 73 68 6f 72 74 6c 69 73 ;; 'shortlis
b320: 74 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 t
b330: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 71 ;; q
b340: 72 79 74 79 70 65 0a 20 20 20 20 20 20 20 20 20 rytype.
b350: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b360: 20 20 20 30 20 20 20 20 20 20 20 20 20 3b 3b 20 0 ;;
b370: 6c 61 73 74 20 75 70 64 61 74 65 0a 09 09 09 09 last update.....
b380: 20 20 09 09 09 09 09 09 09 09 09 23 66 29 29 0a .........#f)).
b390: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 74 65 (ite
b3a0: 6d 2d 74 65 73 74 2d 68 61 73 68 20 28 74 65 73 m-test-hash (tes
b3b0: 74 3a 67 65 74 2d 74 65 73 74 2d 68 61 73 68 20 t:get-test-hash
b3c0: 74 65 73 74 2d 64 61 74 61 29 29 0a 20 20 20 20 test-data)).
b3d0: 20 20 20 20 20 20 20 20 28 69 74 65 6d 73 20 20 (items
b3e0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 (hash-table-keys
b3f0: 20 69 74 65 6d 2d 74 65 73 74 2d 68 61 73 68 29 item-test-hash)
b400: 29 0a 20 09 09 09 09 09 09 28 74 65 73 74 2d 6e ). ......(test-n
b410: 61 6d 65 73 20 28 74 65 73 74 3a 67 65 74 2d 64 ames (test:get-d
b420: 61 74 61 2d 3e 62 2d 6b 65 79 73 20 69 74 65 6d ata->b-keys item
b430: 2d 74 65 73 74 2d 68 61 73 68 20 69 74 65 6d 73 -test-hash items
b440: 29 29 29 0a 20 20 20 20 28 69 66 20 6f 75 70 0a ))). (if oup.
b450: 20 20 20 20 20 20 28 62 65 67 69 6e 20 0a 20 20 (begin .
b460: 20 20 20 28 73 3a 6f 75 74 70 75 74 2d 6e 65 77 (s:output-new
b470: 0a 09 20 20 20 6f 75 70 0a 09 20 20 20 28 73 3a .. oup.. (s:
b480: 68 74 6d 6c 20 74 65 73 74 73 3a 63 73 73 2d 6a html tests:css-j
b490: 73 63 72 69 70 74 2d 62 6c 6f 63 6b 20 28 74 65 script-block (te
b4a0: 73 74 73 3a 63 73 73 2d 6a 73 63 72 69 70 74 2d sts:css-jscript-
b4b0: 62 6c 6f 63 6b 2d 63 6f 6e 64 20 23 66 29 0a 09 block-cond #f)..
b4c0: 09 20 20 20 28 73 3a 74 69 74 6c 65 20 22 52 75 . (s:title "Ru
b4d0: 6e 73 20 56 69 65 77 20 22 20 72 75 6e 2d 6e 61 ns View " run-na
b4e0: 6d 65 29 0a 09 09 20 20 20 28 73 3a 62 6f 64 79 me)... (s:body
b4f0: 0a 09 09 20 20 20 20 20 28 73 3a 68 31 20 22 52 ... (s:h1 "R
b500: 75 6e 73 20 56 69 65 77 20 22 20 29 0a 20 20 20 uns View " ).
b510: 20 20 20 20 20 20 28 73 3a 68 33 20 22 54 61 72 (s:h3 "Tar
b520: 67 65 74 22 20 74 61 72 67 65 74 29 0a 09 09 09 get" target)....
b530: 09 20 28 73 3a 70 20 0a 09 09 09 09 09 28 73 3a . (s:p ......(s:
b540: 62 20 22 52 75 6e 20 6e 61 6d 65 22 20 29 20 72 b "Run name" ) r
b550: 75 6e 2d 6e 61 6d 65 29 0a 20 20 20 20 20 20 20 un-name).
b560: 20 20 28 73 3a 70 20 0a 09 09 09 09 09 28 73 3a (s:p ......(s:
b570: 62 20 22 52 75 6e 20 44 61 74 65 22 20 29 20 72 b "Run Date" ) r
b580: 75 6e 2d 74 69 6d 65 29 0a 20 20 20 20 20 20 20 un-time).
b590: 20 20 28 73 3a 74 61 62 6c 65 20 27 62 6f 72 64 (s:table 'bord
b5a0: 65 72 20 31 20 27 63 65 6c 6c 73 70 61 63 69 6e er 1 'cellspacin
b5b0: 67 20 30 0a 20 20 20 20 20 20 20 20 20 20 20 28 g 0. (
b5c0: 73 3a 74 72 0a 20 20 20 20 20 20 20 20 20 20 20 s:tr.
b5d0: 28 73 3a 74 68 20 22 49 74 65 6d 73 22 29 0a 20 (s:th "Items").
b5e0: 20 20 20 20 20 20 20 20 20 20 28 6d 61 70 20 28 (map (
b5f0: 6c 61 6d 62 64 61 20 28 74 65 73 74 29 0a 20 20 lambda (test).
b600: 20 20 20 20 20 20 20 20 20 20 28 73 3a 74 68 20 (s:th
b610: 74 65 73 74 29 29 0a 20 20 20 20 20 20 20 20 20 test)).
b620: 20 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 20 20 test-names))
b630: 0a 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 70 . (map
b640: 20 28 6c 61 6d 62 64 61 20 28 69 74 65 6d 29 20 (lambda (item)
b650: 0a 09 09 09 09 09 20 20 28 6c 65 74 2a 20 28 28 ...... (let* ((
b660: 74 65 73 74 2d 68 61 73 68 20 28 68 61 73 68 2d test-hash (hash-
b670: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
b680: 74 20 69 74 65 6d 2d 74 65 73 74 2d 68 61 73 68 t item-test-hash
b690: 20 69 74 65 6d 20 20 23 66 29 29 29 0a 09 09 09 item #f)))....
b6a0: 09 09 09 09 09 20 28 69 66 20 74 65 73 74 2d 68 ..... (if test-h
b6b0: 61 73 68 0a 20 20 20 20 20 20 20 20 20 20 20 20 ash.
b6c0: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 (begin....
b6d0: 09 09 09 09 09 09 28 73 3a 74 72 0a 09 09 09 09 ......(s:tr.....
b6e0: 09 20 20 09 09 09 28 73 3a 74 64 20 27 63 6c 61 . ...(s:td 'cla
b6f0: 73 73 20 22 74 65 73 74 22 20 69 74 65 6d 29 0a ss "test" item).
b700: 20 20 20 20 20 20 20 20 20 20 20 20 09 09 09 28 ...(
b710: 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 74 65 73 map (lambda (tes
b720: 74 29 0a 09 09 09 09 09 09 20 20 09 09 28 6c 65 t)....... ..(le
b730: 74 2a 20 28 28 74 65 73 74 2d 64 65 74 61 69 6c t* ((test-detail
b740: 73 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 s (hash-table-re
b750: 66 2f 64 65 66 61 75 6c 74 20 74 65 73 74 2d 68 f/default test-h
b760: 61 73 68 20 74 65 73 74 20 20 23 66 29 29 0a 09 ash test #f))..
b770: 09 09 09 09 09 09 09 09 09 09 09 28 73 74 61 74 ...........(stat
b780: 75 73 20 28 69 66 20 74 65 73 74 2d 64 65 74 61 us (if test-deta
b790: 69 6c 73 0a 09 09 09 09 09 09 09 09 09 09 09 09 ils.............
b7a0: 09 09 09 09 28 63 61 72 20 74 65 73 74 2d 64 65 ....(car test-de
b7b0: 74 61 69 6c 73 29 29 29 0a 20 20 20 20 20 20 20 tails))).
b7c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b7d0: 20 28 6c 69 6e 6b 20 28 69 66 20 74 65 73 74 2d (link (if test-
b7e0: 64 65 74 61 69 6c 73 20 0a 09 09 09 09 09 09 09 details ........
b7f0: 09 09 09 09 09 09 09 28 73 74 72 69 6e 67 2d 73 .......(string-s
b800: 75 62 73 74 69 74 75 74 65 20 20 28 63 6f 6e 63 ubstitute (conc
b810: 20 6c 69 6e 6b 74 72 65 65 20 22 2f 22 20 74 61 linktree "/" ta
b820: 72 67 65 74 20 22 2f 22 20 72 75 6e 2d 6e 61 6d rget "/" run-nam
b830: 65 20 22 2f 22 29 20 20 22 22 20 28 63 61 64 72 e "/") "" (cadr
b840: 20 74 65 73 74 2d 64 65 74 61 69 6c 73 29 20 22 test-details) "
b850: 2d 22 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 -")))).
b860: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 74 65 (if te
b870: 73 74 2d 64 65 74 61 69 6c 73 0a 09 09 09 09 09 st-details......
b880: 09 09 09 09 09 09 28 73 3a 74 64 20 27 63 6c 61 ......(s:td 'cla
b890: 73 73 20 73 74 61 74 75 73 0a 09 09 09 09 09 09 ss status.......
b8a0: 09 09 09 09 09 09 28 73 3a 61 20 27 63 6c 61 73 ......(s:a 'clas
b8b0: 73 20 22 6c 69 6e 6b 22 20 27 68 72 65 66 20 6c s "link" 'href l
b8c0: 69 6e 6b 20 73 74 61 74 75 73 20 29 29 0a 20 20 ink status )).
b8d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b8e0: 20 20 20 20 28 73 3a 74 64 20 22 22 29 29 29 29 (s:td ""))))
b8f0: 20 09 09 09 0a 09 09 09 09 09 09 09 09 09 74 65 .............te
b900: 73 74 2d 6e 61 6d 65 73 29 29 29 29 29 29 0a 09 st-names))))))..
b910: 09 09 09 20 20 28 73 6f 72 74 20 69 74 65 6d 73 ... (sort items
b920: 20 73 74 72 69 6e 67 3c 3d 3f 29 29 29 29 29 29 string<=?))))))
b930: 0a 09 09 28 63 6c 6f 73 65 2d 6f 75 74 70 75 74 ...(close-output
b940: 2d 70 6f 72 74 20 6f 75 70 29 29 0a 20 20 20 20 -port oup)).
b950: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
b960: 6f 20 30 20 22 53 6b 69 70 3a 20 44 69 72 63 74 o 0 "Skip: Dirct
b970: 6f 72 79 20 73 74 72 75 63 74 75 72 65 20 22 20 ory structure "
b980: 6c 69 6e 6b 74 72 65 65 20 22 2f 22 20 74 61 72 linktree "/" tar
b990: 67 65 74 20 22 2f 22 20 72 75 6e 2d 6e 61 6d 65 get "/" run-name
b9a0: 20 22 20 64 6f 65 73 20 6e 6f 74 20 65 78 69 73 " does not exis
b9b0: 74 2e 20 4d 65 67 61 74 65 73 74 20 77 69 6c 6c t. Megatest will
b9c0: 20 6e 6f 74 20 63 72 65 61 74 65 20 72 75 6e 2e not create run.
b9d0: 68 74 6d 6c 22 29 29 29 29 0a 72 75 6e 73 29 29 html")))).runs))
b9e0: 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 3a ..(define (test:
b9f0: 63 72 65 61 74 65 2d 74 61 72 67 65 74 2d 68 61 create-target-ha
ba00: 73 68 20 72 75 6e 73 20 68 65 61 64 65 72 20 6e sh runs header n
ba10: 75 6d 6b 65 79 73 29 0a 20 20 28 6c 65 74 20 28 umkeys). (let (
ba20: 28 72 65 73 68 20 28 6d 61 6b 65 2d 68 61 73 68 (resh (make-hash
ba30: 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 28 66 6f -table))). (fo
ba40: 72 2d 65 61 63 68 0a 20 20 20 20 20 28 6c 61 6d r-each. (lam
ba50: 62 64 61 20 28 72 75 6e 29 0a 20 20 20 20 20 20 bda (run).
ba60: 20 20 28 6c 65 74 2a 20 28 28 72 75 6e 2d 6e 61 (let* ((run-na
ba70: 6d 65 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 me (db:get-value
ba80: 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 -by-header run h
ba90: 65 61 64 65 72 20 22 72 75 6e 6e 61 6d 65 22 29 eader "runname")
baa0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
bab0: 20 28 74 61 72 67 65 74 20 20 20 28 73 74 72 69 (target (stri
bac0: 6e 67 2d 6a 6f 69 6e 20 28 74 61 6b 65 20 28 76 ng-join (take (v
bad0: 65 63 74 6f 72 2d 3e 6c 69 73 74 20 72 75 6e 29 ector->list run)
bae0: 20 6e 75 6d 6b 65 79 73 29 20 22 2f 22 29 29 0a numkeys) "/")).
baf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
bb00: 72 75 6e 2d 6c 69 73 74 20 28 68 61 73 68 2d 74 run-list (hash-t
bb10: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
bb20: 20 72 65 73 68 20 74 61 72 67 65 74 20 20 23 66 resh target #f
bb30: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
bb40: 20 20 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 .
bb50: 20 20 20 28 69 66 20 28 6e 6f 74 20 72 75 6e 2d (if (not run-
bb60: 6c 69 73 74 29 0a 20 20 20 20 20 20 20 20 20 20 list).
bb70: 20 20 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 (hash-t
bb80: 61 62 6c 65 2d 73 65 74 21 20 72 65 73 68 20 74 able-set! resh t
bb90: 61 72 67 65 74 20 20 20 28 6c 69 73 74 20 72 75 arget (list ru
bba0: 6e 2d 6e 61 6d 65 29 29 0a 20 20 20 20 20 20 20 n-name)).
bbb0: 20 20 20 20 20 20 20 20 20 20 20 20 28 68 61 73 (has
bbc0: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 72 65 73 h-table-set! res
bbd0: 68 20 74 61 72 67 65 74 20 20 20 28 63 6f 6e 73 h target (cons
bbe0: 20 72 75 6e 2d 6e 61 6d 65 20 72 75 6e 2d 6c 69 run-name run-li
bbf0: 73 74 29 29 29 29 29 0a 20 20 20 20 20 20 72 75 st))))). ru
bc00: 6e 73 29 0a 20 20 20 72 65 73 68 29 29 0a 0a 28 ns). resh))..(
bc10: 64 65 66 69 6e 65 20 28 74 65 73 74 3a 67 65 74 define (test:get
bc20: 2d 6d 61 78 2d 72 75 6e 2d 63 6e 74 20 74 61 72 -max-run-cnt tar
bc30: 67 65 74 2d 68 61 73 68 20 74 61 72 67 65 74 73 get-hash targets
bc40: 29 0a 20 20 20 28 6c 65 74 2a 20 28 28 63 6e 74 ). (let* ((cnt
bc50: 20 30 20 29 29 0a 20 20 20 28 6d 61 70 20 28 6c 0 )). (map (l
bc60: 61 6d 62 64 61 20 28 74 61 72 67 65 74 29 0a 20 ambda (target).
bc70: 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 72 (let* ((r
bc80: 75 6e 73 20 20 28 68 61 73 68 2d 74 61 62 6c 65 uns (hash-table
bc90: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 61 72 -ref/default tar
bca0: 67 65 74 2d 68 61 73 68 20 74 61 72 67 65 74 20 get-hash target
bcb0: 20 23 66 29 29 0a 20 20 20 20 20 20 20 20 20 20 #f)).
bcc0: 20 20 20 20 20 28 72 75 6e 2d 6c 65 6e 67 74 68 (run-length
bcd0: 20 28 69 66 20 72 75 6e 73 0a 09 09 09 09 09 09 (if runs.......
bce0: 09 09 09 09 09 09 09 09 09 09 28 6c 65 6e 67 74 ..........(lengt
bcf0: 68 20 72 75 6e 73 29 0a 20 20 20 20 20 20 20 20 h runs).
bd00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bd10: 20 20 20 20 20 20 20 20 20 30 29 29 29 0a 20 20 0))).
bd20: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
bd30: 69 66 20 28 3c 20 63 6e 74 20 72 75 6e 2d 6c 65 if (< cnt run-le
bd40: 6e 67 74 68 29 0a 20 20 20 20 20 20 20 20 20 20 ngth).
bd50: 20 20 20 20 20 28 73 65 74 21 20 63 6e 74 20 20 (set! cnt
bd60: 72 75 6e 2d 6c 65 6e 67 74 68 29 29 29 29 20 0a run-length)))) .
bd70: 09 09 74 61 72 67 65 74 73 29 20 0a 63 6e 74 29 ..targets) .cnt)
bd80: 29 0a 20 0a 28 64 65 66 69 6e 65 20 28 74 65 73 ). .(define (tes
bd90: 74 3a 70 61 64 2d 72 75 6e 73 20 74 61 72 67 65 t:pad-runs targe
bda0: 74 2d 68 61 73 68 20 74 61 72 67 65 74 73 20 6d t-hash targets m
bdb0: 61 78 2d 72 6f 77 2d 6c 65 6e 67 74 68 29 0a 20 ax-row-length).
bdc0: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 74 61 (map (lambda (ta
bdd0: 72 67 65 74 29 0a 20 20 20 20 20 20 20 20 28 6c rget). (l
bde0: 65 74 20 6c 6f 6f 70 20 28 28 72 75 6e 2d 6c 69 et loop ((run-li
bdf0: 73 74 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d st (hash-table-
be00: 72 65 66 2f 64 65 66 61 75 6c 74 20 74 61 72 67 ref/default targ
be10: 65 74 2d 68 61 73 68 20 74 61 72 67 65 74 20 20 et-hash target
be20: 23 66 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 #f))).
be30: 20 20 20 20 20 28 69 66 20 28 3c 20 28 6c 65 6e (if (< (len
be40: 67 74 68 20 72 75 6e 2d 6c 69 73 74 29 20 6d 61 gth run-list) ma
be50: 78 2d 72 6f 77 2d 6c 65 6e 67 74 68 29 0a 20 20 x-row-length).
be60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
be70: 62 65 67 69 6e 20 20 0a 20 20 20 20 20 20 20 20 begin .
be80: 20 20 20 20 20 20 20 09 09 20 28 68 61 73 68 2d .. (hash-
be90: 74 61 62 6c 65 2d 73 65 74 21 20 74 61 72 67 65 table-set! targe
bea0: 74 2d 68 61 73 68 20 74 61 72 67 65 74 20 20 20 t-hash target
beb0: 28 63 6f 6e 73 20 22 22 20 72 75 6e 2d 6c 69 73 (cons "" run-lis
bec0: 74 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 t)).
bed0: 20 20 20 09 09 20 28 6c 6f 6f 70 20 28 68 61 73 .. (loop (has
bee0: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
bef0: 75 6c 74 20 74 61 72 67 65 74 2d 68 61 73 68 20 ult target-hash
bf00: 74 61 72 67 65 74 20 20 23 66 29 20 29 29 29 29 target #f) ))))
bf10: 29 20 0a 09 09 74 61 72 67 65 74 73 29 0a 20 20 ) ...targets).
bf20: 20 74 61 72 67 65 74 2d 68 61 73 68 29 0a 0a 28 target-hash)..(
bf30: 64 65 66 69 6e 65 20 28 74 65 73 74 3a 63 72 65 define (test:cre
bf40: 61 74 65 2d 74 61 72 67 65 74 2d 68 74 6d 6c 20 ate-target-html
bf50: 74 61 72 67 65 74 2d 68 61 73 68 20 6f 75 70 20 target-hash oup
bf60: 61 72 65 61 2d 6e 61 6d 65 20 6c 69 6e 6b 74 72 area-name linktr
bf70: 65 65 29 0a 20 20 28 6c 65 74 2a 20 28 28 74 61 ee). (let* ((ta
bf80: 72 67 65 74 73 20 28 68 61 73 68 2d 74 61 62 6c rgets (hash-tabl
bf90: 65 2d 6b 65 79 73 20 74 61 72 67 65 74 2d 68 61 e-keys target-ha
bfa0: 73 68 29 29 0a 20 20 20 20 20 20 20 20 20 28 6d sh)). (m
bfb0: 61 78 2d 72 6f 77 2d 6c 65 6e 67 74 68 20 28 74 ax-row-length (t
bfc0: 65 73 74 3a 67 65 74 2d 6d 61 78 2d 72 75 6e 2d est:get-max-run-
bfd0: 63 6e 74 20 74 61 72 67 65 74 2d 68 61 73 68 20 cnt target-hash
bfe0: 74 61 72 67 65 74 73 29 29 0a 20 20 20 20 20 20 targets)).
bff0: 20 20 20 28 70 61 64 2d 72 75 6e 73 2d 68 61 73 (pad-runs-has
c000: 68 20 28 74 65 73 74 3a 70 61 64 2d 72 75 6e 73 h (test:pad-runs
c010: 20 74 61 72 67 65 74 2d 68 61 73 68 20 74 61 72 target-hash tar
c020: 67 65 74 73 20 6d 61 78 2d 72 6f 77 2d 6c 65 6e gets max-row-len
c030: 67 74 68 29 29 29 0a 20 20 20 28 73 3a 6f 75 74 gth))). (s:out
c040: 70 75 74 2d 6e 65 77 0a 09 20 20 20 6f 75 70 0a put-new.. oup.
c050: 09 20 20 20 28 73 3a 68 74 6d 6c 20 74 65 73 74 . (s:html test
c060: 73 3a 63 73 73 2d 6a 73 63 72 69 70 74 2d 62 6c s:css-jscript-bl
c070: 6f 63 6b 20 28 74 65 73 74 73 3a 63 73 73 2d 6a ock (tests:css-j
c080: 73 63 72 69 70 74 2d 62 6c 6f 63 6b 2d 63 6f 6e script-block-con
c090: 64 20 23 66 29 0a 0a 09 09 20 20 20 28 73 3a 74 d #f).... (s:t
c0a0: 69 74 6c 65 20 22 54 61 72 67 65 74 20 56 69 65 itle "Target Vie
c0b0: 77 20 22 20 61 72 65 61 2d 6e 61 6d 65 29 0a 09 w " area-name)..
c0c0: 09 20 20 20 28 73 3a 62 6f 64 79 0a 09 09 20 20 . (s:body...
c0d0: 20 28 73 3a 68 31 20 22 54 61 72 67 65 74 20 56 (s:h1 "Target V
c0e0: 69 65 77 20 22 20 61 72 65 61 2d 6e 61 6d 65 29 iew " area-name)
c0f0: 0a 09 09 09 09 09 28 73 3a 74 61 62 6c 65 20 27 ......(s:table '
c100: 69 64 20 22 4c 69 6e 6b 65 64 4c 69 73 74 31 22 id "LinkedList1"
c110: 20 27 62 6f 72 64 65 72 20 22 31 22 20 27 63 65 'border "1" 'ce
c120: 6c 6c 73 70 61 63 69 6e 67 20 30 0a 20 20 20 20 llspacing 0.
c130: 20 20 20 20 20 20 20 20 20 28 73 3a 74 72 20 27 (s:tr '
c140: 63 6c 61 73 73 20 22 73 6f 6d 65 74 68 69 6e 67 class "something
c150: 22 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 " .
c160: 20 20 28 73 3a 74 68 20 22 54 61 72 67 65 74 22 (s:th "Target"
c170: 29 0a 09 09 09 09 09 09 09 09 28 73 3a 74 68 20 ).........(s:th
c180: 27 63 6f 6c 73 70 61 6e 20 6d 61 78 2d 72 6f 77 'colspan max-row
c190: 2d 6c 65 6e 67 74 68 20 22 52 75 6e 73 22 29 29 -length "Runs"))
c1a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c1b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c1c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0a 20 .
c1d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
c1e0: 6c 65 74 2a 20 28 28 74 62 6c 20 28 6d 61 70 20 let* ((tbl (map
c1f0: 28 6c 61 6d 62 64 61 20 28 74 61 72 67 65 74 29 (lambda (target)
c200: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
c210: 20 20 20 20 20 20 20 28 73 3a 74 72 0a 20 20 20 (s:tr.
c220: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c230: 20 20 20 28 73 3a 74 64 20 27 63 6c 61 73 73 20 (s:td 'class
c240: 22 74 65 73 74 22 20 74 61 72 67 65 74 29 0a 09 "test" target)..
c250: 09 09 09 09 09 09 09 09 09 20 20 28 6c 65 74 2a ......... (let*
c260: 20 28 28 72 75 6e 73 20 20 28 68 61 73 68 2d 74 ((runs (hash-t
c270: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
c280: 20 74 61 72 67 65 74 2d 68 61 73 68 20 74 61 72 target-hash tar
c290: 67 65 74 20 20 23 66 29 29 0a 09 09 09 09 09 09 get #f)).......
c2a0: 09 09 09 09 09 09 09 09 20 28 72 65 73 74 2d 72 ........ (rest-r
c2b0: 6f 77 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 ow (map (lambda
c2c0: 28 72 75 6e 29 0a 09 09 09 09 09 09 09 09 09 09 (run)...........
c2d0: 09 09 09 09 09 09 09 09 09 09 28 69 66 20 28 65 ..........(if (e
c2e0: 71 75 61 6c 3f 20 72 75 6e 20 22 22 29 0a 09 09 qual? run "")...
c2f0: 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 ................
c300: 09 09 09 09 28 73 3a 74 64 20 72 75 6e 29 0a 20 ....(s:td run).
c310: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c320: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c330: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 (if (
c340: 66 69 6c 65 2d 65 78 69 73 74 73 3f 28 63 6f 6e file-exists?(con
c350: 63 20 6c 69 6e 6b 74 72 65 65 20 22 2f 22 20 74 c linktree "/" t
c360: 61 72 67 65 74 20 22 2f 22 20 72 75 6e 20 29 29 arget "/" run ))
c370: 0a 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 ................
c380: 09 09 09 09 09 09 09 28 62 65 67 69 6e 20 0a 09 .......(begin ..
c390: 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 ................
c3a0: 09 09 09 09 09 09 28 73 3a 74 64 20 0a 09 09 09 ......(s:td ....
c3b0: 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 ................
c3c0: 09 09 09 09 28 73 3a 61 20 27 68 72 65 66 20 28 ....(s:a 'href (
c3d0: 63 6f 6e 63 20 20 74 61 72 67 65 74 20 22 2f 22 conc target "/"
c3e0: 20 72 75 6e 20 22 2f 72 75 6e 2e 68 74 6d 6c 22 run "/run.html"
c3f0: 29 20 72 75 6e 29 29 29 29 29 29 0a 09 09 09 09 ) run)))))).....
c400: 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 ................
c410: 28 72 65 76 65 72 73 65 20 72 75 6e 73 29 29 29 (reverse runs)))
c420: 29 0a 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: 72 65 73 74 2d 72 6f 77 29 29 29 0a 20 20 20 20 rest-row))).
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 20 20 20 20 20 20 20 20 74 t
c470: 61 72 67 65 74 73 29 29 29 0a 20 20 20 20 20 20 argets))).
c480: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c490: 20 20 20 20 20 74 62 6c 29 29 29 29 29 0a 20 20 tbl))))).
c4a0: 20 20 20 20 20 20 20 20 28 63 6c 6f 73 65 2d 6f (close-o
c4b0: 75 74 70 75 74 2d 70 6f 72 74 20 6f 75 70 29 29 utput-port oup))
c4c0: 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 )...(define (tes
c4d0: 74 73 3a 63 72 65 61 74 65 2d 68 74 6d 6c 2d 74 ts:create-html-t
c4e0: 72 65 65 2d 6f 6c 64 20 6f 75 74 66 29 0a 20 20 ree-old outf).
c4f0: 20 28 6c 65 74 2a 20 28 28 6c 6f 63 6b 66 69 6c (let* ((lockfil
c500: 65 20 20 28 63 6f 6e 63 20 6f 75 74 66 20 22 2e e (conc outf ".
c510: 6c 6f 63 6b 22 29 29 0a 09 20 28 72 75 6e 73 2d lock")).. (runs-
c520: 74 6f 2d 70 72 6f 63 65 73 73 20 27 28 29 29 29 to-process '()))
c530: 0a 20 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e . (if (common
c540: 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 :simple-file-loc
c550: 6b 20 6c 6f 63 6b 66 69 6c 65 29 0a 09 28 6c 65 k lockfile)..(le
c560: 74 2a 20 28 28 6c 69 6e 6b 74 72 65 65 20 20 28 t* ((linktree (
c570: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 69 6e 6b 74 common:get-linkt
c580: 72 65 65 29 29 0a 09 20 20 20 20 20 20 20 28 6f ree)).. (o
c590: 75 70 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 6f up (open-o
c5a0: 75 74 70 75 74 2d 66 69 6c 65 20 28 6f 72 20 6f utput-file (or o
c5b0: 75 74 66 20 28 63 6f 6e 63 20 6c 69 6e 6b 74 72 utf (conc linktr
c5c0: 65 65 20 22 2f 72 75 6e 73 2d 69 6e 64 65 78 2e ee "/runs-index.
c5d0: 68 74 6d 6c 22 29 29 29 29 0a 09 20 20 20 20 20 html"))))..
c5e0: 20 20 28 61 72 65 61 2d 6e 61 6d 65 20 28 63 6f (area-name (co
c5f0: 6d 6d 6f 6e 3a 67 65 74 2d 74 65 73 74 73 75 69 mmon:get-testsui
c600: 74 65 2d 6e 61 6d 65 29 29 0a 09 20 20 20 20 20 te-name))..
c610: 20 20 28 6b 65 79 73 20 20 20 20 20 20 28 72 6d (keys (rm
c620: 74 3a 67 65 74 2d 6b 65 79 73 29 29 0a 09 20 20 t:get-keys))..
c630: 20 20 20 20 20 28 6e 75 6d 6b 65 79 73 20 20 20 (numkeys
c640: 28 6c 65 6e 67 74 68 20 6b 65 79 73 29 29 0a 09 (length keys))..
c650: 20 20 20 20 20 20 20 28 72 75 6e 73 64 61 74 20 (runsdat
c660: 20 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e 73 20 (rmt:get-runs
c670: 22 25 22 20 23 66 20 23 66 20 28 6d 61 70 20 28 "%" #f #f (map (
c680: 6c 61 6d 62 64 61 20 28 78 29 28 6c 69 73 74 20 lambda (x)(list
c690: 78 20 22 25 22 29 29 20 6b 65 79 73 29 29 29 0a x "%")) keys))).
c6a0: 09 20 20 20 20 20 20 20 28 68 65 61 64 65 72 20 . (header
c6b0: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 (vector-ref r
c6c0: 75 6e 73 64 61 74 20 30 29 29 0a 09 20 20 20 20 unsdat 0))..
c6d0: 20 20 20 28 72 75 6e 73 20 20 20 20 20 20 28 76 (runs (v
c6e0: 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 73 64 61 ector-ref runsda
c6f0: 74 20 31 29 29 0a 09 20 20 20 20 20 20 20 28 72 t 1)).. (r
c700: 75 6e 74 72 65 65 64 61 74 20 28 6d 61 70 20 28 untreedat (map (
c710: 6c 61 6d 62 64 61 20 28 78 29 0a 09 09 09 09 20 lambda (x).....
c720: 20 28 74 65 73 74 73 3a 72 75 6e 2d 72 65 63 6f (tests:run-reco
c730: 72 64 2d 3e 74 65 73 74 2d 70 61 74 68 20 78 20 rd->test-path x
c740: 6e 75 6d 6b 65 79 73 29 29 0a 09 09 09 09 72 75 numkeys)).....ru
c750: 6e 73 29 29 0a 09 20 20 20 20 20 20 20 28 72 75 ns)).. (ru
c760: 6e 73 2d 68 74 72 65 65 20 28 63 6f 6d 6d 6f 6e ns-htree (common
c770: 3a 6c 69 73 74 2d 3e 68 74 72 65 65 20 72 75 6e :list->htree run
c780: 74 72 65 65 64 61 74 29 29 29 0a 09 20 20 28 73 treedat))).. (s
c790: 65 74 21 20 72 75 6e 73 2d 74 6f 2d 70 72 6f 63 et! runs-to-proc
c7a0: 65 73 73 20 72 75 6e 73 29 0a 09 20 20 28 73 3a ess runs).. (s:
c7b0: 6f 75 74 70 75 74 2d 6e 65 77 0a 09 20 20 20 6f output-new.. o
c7c0: 75 70 0a 09 20 20 20 28 73 3a 68 74 6d 6c 20 74 up.. (s:html t
c7d0: 65 73 74 73 3a 63 73 73 2d 6a 73 63 72 69 70 74 ests:css-jscript
c7e0: 2d 62 6c 6f 63 6b 0a 09 09 20 20 20 28 73 3a 74 -block... (s:t
c7f0: 69 74 6c 65 20 22 53 75 6d 6d 61 72 79 20 66 6f itle "Summary fo
c800: 72 20 22 20 61 72 65 61 2d 6e 61 6d 65 29 0a 09 r " area-name)..
c810: 09 20 20 20 28 73 3a 62 6f 64 79 20 27 6f 6e 6c . (s:body 'onl
c820: 6f 61 64 20 22 61 64 64 45 76 65 6e 74 73 28 29 oad "addEvents()
c830: 3b 22 0a 09 09 09 20 20 20 28 73 3a 68 31 20 22 ;".... (s:h1 "
c840: 53 75 6d 6d 61 72 79 20 66 6f 72 20 22 20 61 72 Summary for " ar
c850: 65 61 2d 6e 61 6d 65 29 0a 09 09 09 20 20 20 3b ea-name).... ;
c860: 3b 20 74 6f 70 20 6c 69 73 74 0a 09 09 09 20 20 ; top list....
c870: 20 28 73 3a 75 6c 20 27 69 64 20 22 4c 69 6e 6b (s:ul 'id "Link
c880: 65 64 4c 69 73 74 31 22 20 27 63 6c 61 73 73 20 edList1" 'class
c890: 22 4c 69 6e 6b 65 64 4c 69 73 74 22 0a 09 09 09 "LinkedList"....
c8a0: 09 20 28 73 3a 6c 69 0a 09 09 09 09 20 20 22 52 . (s:li..... "R
c8b0: 75 6e 73 22 0a 09 09 09 09 20 20 28 63 6f 6d 6d uns"..... (comm
c8c0: 6f 6e 3a 68 74 72 65 65 2d 3e 68 74 6d 6c 20 72 on:htree->html r
c8d0: 75 6e 73 2d 68 74 72 65 65 0a 09 09 09 09 09 09 uns-htree.......
c8e0: 20 20 20 20 20 20 27 28 29 0a 09 09 09 09 09 09 '().......
c8f0: 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 78 (lambda (x
c900: 20 70 29 0a 09 09 09 09 09 09 09 28 6c 65 74 2a p)........(let*
c910: 20 28 28 74 61 72 67 2d 70 61 74 68 20 28 73 74 ((targ-path (st
c920: 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
c930: 20 70 20 22 2f 22 29 29 0a 20 20 20 20 20 20 20 p "/")).
c940: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c950: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c960: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c970: 20 20 20 20 20 20 20 20 28 66 75 6c 6c 2d 70 61 (full-pa
c980: 74 68 20 28 63 6f 6e 63 20 6c 69 6e 6b 74 72 65 th (conc linktre
c990: 65 20 22 2f 22 20 74 61 72 67 2d 70 61 74 68 29 e "/" targ-path)
c9a0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
c9b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c9c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c9d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c9e0: 20 28 72 75 6e 2d 6e 61 6d 65 20 20 28 63 61 72 (run-name (car
c9f0: 20 28 72 65 76 65 72 73 65 20 70 29 29 29 29 0a (reverse p)))).
ca00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ca10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ca20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ca30: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 61 (if (a
ca40: 6e 64 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d nd (common:file-
ca50: 65 78 69 73 74 73 3f 20 66 75 6c 6c 2d 70 61 74 exists? full-pat
ca60: 68 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 h).
ca70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ca80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ca90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
caa0: 20 20 20 20 20 20 28 64 69 72 65 63 74 6f 72 79 (directory
cab0: 3f 20 20 20 66 75 6c 6c 2d 70 61 74 68 29 0a 20 ? full-path).
cac0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cad0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cae0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
caf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cb00: 20 20 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 (file-write-ac
cb10: 63 65 73 73 3f 20 66 75 6c 6c 2d 70 61 74 68 29 cess? full-path)
cb20: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
cb30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cb40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cb50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cb60: 28 73 3a 61 20 72 75 6e 2d 6e 61 6d 65 20 27 68 (s:a run-name 'h
cb70: 72 65 66 20 28 63 6f 6e 63 20 74 61 72 67 2d 70 ref (conc targ-p
cb80: 61 74 68 20 22 2f 72 75 6e 2d 73 75 6d 6d 61 72 ath "/run-summar
cb90: 79 2e 68 74 6d 6c 22 29 29 0a 20 20 20 20 20 20 y.html")).
cba0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cbb0: 20 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 28 62 65 67 69 6e 0a 20 (begin.
cbe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cbf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cc00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cc10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
cc20: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
cc30: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
cc40: 20 22 49 4e 46 4f 3a 20 43 61 6e 27 74 20 63 72 "INFO: Can't cr
cc50: 65 61 74 65 20 22 20 74 61 72 67 2d 70 61 74 68 eate " targ-path
cc60: 20 22 2f 72 75 6e 2d 73 75 6d 6d 61 72 79 2e 68 "/run-summary.h
cc70: 74 6d 6c 22 29 0a 20 20 20 20 20 20 20 20 20 20 tml").
cc80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cc90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cca0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ccb0: 20 20 20 20 20 20 28 63 6f 6e 63 20 72 75 6e 2d (conc run-
ccc0: 6e 61 6d 65 20 22 20 28 4e 6f 74 20 61 62 6c 65 name " (Not able
ccd0: 20 74 6f 20 63 72 65 61 74 65 20 73 75 6d 6d 61 to create summa
cce0: 72 79 20 61 74 20 22 20 74 61 72 67 2d 70 61 74 ry at " targ-pat
ccf0: 68 20 22 29 22 29 29 29 29 29 29 29 29 29 29 29 h ")")))))))))))
cd00: 0a 20 20 20 20 20 20 20 20 20 20 28 63 6c 6f 73 . (clos
cd10: 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 6f 75 e-output-port ou
cd20: 70 29 0a 09 20 20 28 63 6f 6d 6d 6f 6e 3a 73 69 p).. (common:si
cd30: 6d 70 6c 65 2d 66 69 6c 65 2d 72 65 6c 65 61 73 mple-file-releas
cd40: 65 2d 6c 6f 63 6b 20 6c 6f 63 6b 66 69 6c 65 29 e-lock lockfile)
cd50: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
cd60: 0a 09 20 20 28 66 6f 72 2d 65 61 63 68 0a 09 20 .. (for-each..
cd70: 20 20 28 6c 61 6d 62 64 61 20 28 72 75 6e 29 0a (lambda (run).
cd80: 09 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 65 . (let* ((te
cd90: 73 74 2d 73 75 62 70 61 74 68 20 28 74 65 73 74 st-subpath (test
cda0: 73 3a 72 75 6e 2d 72 65 63 6f 72 64 2d 3e 74 65 s:run-record->te
cdb0: 73 74 2d 70 61 74 68 20 72 75 6e 20 6e 75 6d 6b st-path run numk
cdc0: 65 79 73 29 29 0a 09 09 20 20 20 20 28 72 75 6e eys))... (run
cdd0: 2d 69 64 20 20 20 20 20 20 20 28 64 62 3a 67 65 -id (db:ge
cde0: 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 t-value-by-heade
cdf0: 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 69 64 r run header "id
ce00: 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ")).
ce10: 20 20 20 20 20 20 20 20 28 72 75 6e 2d 64 69 72 (run-dir
ce20: 20 20 20 20 20 20 28 74 65 73 74 73 3a 72 75 6e (tests:run
ce30: 2d 72 65 63 6f 72 64 2d 3e 74 65 73 74 2d 70 61 -record->test-pa
ce40: 74 68 20 72 75 6e 20 6e 75 6d 6b 65 79 73 29 29 th run numkeys))
ce50: 0a 09 09 20 20 20 20 28 74 65 73 74 2d 64 61 74 ... (test-dat
ce60: 73 20 20 20 20 28 72 6d 74 3a 67 65 74 2d 74 65 s (rmt:get-te
ce70: 73 74 73 2d 66 6f 72 2d 72 75 6e 0a 09 09 09 09 sts-for-run.....
ce80: 20 20 20 72 75 6e 2d 69 64 0a 20 20 20 20 20 20 run-id.
ce90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cea0: 20 20 20 20 20 20 20 20 20 20 20 20 20 22 25 2f "%/
ceb0: 22 20 20 20 20 20 20 20 3b 3b 20 74 65 73 74 6e " ;; testn
cec0: 61 6d 65 70 61 74 74 0a 09 09 09 09 20 20 20 27 amepatt..... '
ced0: 28 29 20 20 20 20 20 20 20 20 3b 3b 20 73 74 61 () ;; sta
cee0: 74 65 73 0a 09 09 09 09 20 20 20 27 28 29 20 20 tes..... '()
cef0: 20 20 20 20 20 20 3b 3b 20 73 74 61 74 75 73 65 ;; statuse
cf00: 73 0a 09 09 09 09 20 20 20 23 66 20 20 20 20 20 s..... #f
cf10: 20 20 20 20 3b 3b 20 6f 66 66 73 65 74 0a 09 09 ;; offset...
cf20: 09 09 20 20 20 23 66 20 20 20 20 20 20 20 20 20 .. #f
cf30: 3b 3b 20 6e 75 6d 2d 74 6f 2d 67 65 74 0a 09 09 ;; num-to-get...
cf40: 09 09 20 20 20 23 66 20 20 20 20 20 20 20 20 20 .. #f
cf50: 3b 3b 20 68 69 64 65 2f 6e 6f 74 2d 68 69 64 65 ;; hide/not-hide
cf60: 0a 09 09 09 09 20 20 20 23 66 20 20 20 20 20 20 ..... #f
cf70: 20 20 20 3b 3b 20 73 6f 72 74 2d 62 79 0a 09 09 ;; sort-by...
cf80: 09 09 20 20 20 23 66 20 20 20 20 20 20 20 20 20 .. #f
cf90: 3b 3b 20 73 6f 72 74 2d 6f 72 64 65 72 0a 09 09 ;; sort-order...
cfa0: 09 09 20 20 20 23 66 20 20 20 20 20 20 20 20 20 .. #f
cfb0: 3b 3b 20 27 73 68 6f 72 74 6c 69 73 74 20 20 20 ;; 'shortlist
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 3b 3b 20 71 72 79 74 79 ;; qryty
cfe0: 70 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 pe.
cff0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d000: 20 20 20 20 20 20 30 20 20 20 20 20 20 20 20 20 0
d010: 3b 3b 20 6c 61 73 74 20 75 70 64 61 74 65 0a 09 ;; last update..
d020: 09 09 09 20 20 20 23 66 29 29 0a 20 20 20 20 20 ... #f)).
d030: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
d040: 74 65 73 74 73 2d 74 72 65 65 2d 64 61 74 20 28 tests-tree-dat (
d050: 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 74 65 73 map (lambda (tes
d060: 74 2d 64 61 74 29 0a 20 20 20 20 20 20 20 20 20 t-dat).
d070: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d080: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d090: 3b 3b 20 28 74 65 73 74 73 3a 72 75 6e 2d 72 65 ;; (tests:run-re
d0a0: 63 6f 72 64 2d 3e 74 65 73 74 2d 70 61 74 68 20 cord->test-path
d0b0: 78 20 6e 75 6d 6b 65 79 73 29 29 0a 20 20 20 20 x numkeys)).
d0c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d0d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d0e0: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 65 73 (let* ((tes
d0f0: 74 2d 6e 61 6d 65 20 20 28 64 62 3a 74 65 73 74 t-name (db:test
d100: 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 -get-testname te
d110: 73 74 2d 64 61 74 29 29 0a 20 20 20 20 20 20 20 st-dat)).
d120: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d130: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d140: 20 20 20 20 20 20 20 20 20 28 69 74 65 6d 2d 70 (item-p
d150: 61 74 68 20 20 28 64 62 3a 74 65 73 74 2d 67 65 ath (db:test-ge
d160: 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 65 73 74 t-item-path test
d170: 2d 64 61 74 29 29 0a 20 20 20 20 20 20 20 20 20 -dat)).
d180: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d190: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d1a0: 20 20 20 20 20 20 20 28 66 75 6c 6c 2d 6e 61 6d (full-nam
d1b0: 65 20 20 28 64 62 3a 74 65 73 74 2d 6d 61 6b 65 e (db:test-make
d1c0: 2d 66 75 6c 6c 2d 6e 61 6d 65 20 74 65 73 74 2d -full-name test-
d1d0: 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 name item-path))
d1e0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
d1f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d200: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d210: 20 28 70 61 74 68 2d 70 61 72 74 73 20 28 73 74 (path-parts (st
d220: 72 69 6e 67 2d 73 70 6c 69 74 20 66 75 6c 6c 2d ring-split full-
d230: 6e 61 6d 65 29 29 29 0a 20 20 20 20 20 20 20 20 name))).
d240: 20 20 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 70 61 74 68 2d 70 61 72 74 73 29 29 0a path-parts)).
d270: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d280: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d290: 20 20 20 20 20 20 20 74 65 73 74 2d 64 61 74 73 test-dats
d2a0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
d2b0: 20 20 20 20 20 20 20 28 74 65 73 74 73 2d 68 74 (tests-ht
d2c0: 72 65 65 20 28 63 6f 6d 6d 6f 6e 3a 6c 69 73 74 ree (common:list
d2d0: 2d 3e 68 74 72 65 65 20 74 65 73 74 73 2d 74 72 ->htree tests-tr
d2e0: 65 65 2d 64 61 74 29 29 0a 20 20 20 20 20 20 20 ee-dat)).
d2f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 68 74 (ht
d300: 6d 6c 2d 64 69 72 20 20 20 20 28 63 6f 6e 63 20 ml-dir (conc
d310: 6c 69 6e 6b 74 72 65 65 20 22 2f 22 20 28 73 74 linktree "/" (st
d320: 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
d330: 20 72 75 6e 2d 64 69 72 20 22 2f 22 29 29 29 0a run-dir "/"))).
d340: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d350: 20 20 20 20 28 68 74 6d 6c 2d 70 61 74 68 20 20 (html-path
d360: 20 28 63 6f 6e 63 20 68 74 6d 6c 2d 64 69 72 20 (conc html-dir
d370: 22 2f 72 75 6e 2d 73 75 6d 6d 61 72 79 2e 68 74 "/run-summary.ht
d380: 6d 6c 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 ml")).
d390: 20 20 20 20 20 20 20 20 20 20 28 6f 75 70 20 20 (oup
d3a0: 20 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 (if (and
d3b0: 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 (common:file-exi
d3c0: 73 74 73 3f 20 68 74 6d 6c 2d 64 69 72 29 0a 20 sts? html-dir).
d3d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d3e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d3f0: 20 20 20 20 20 20 20 20 20 28 64 69 72 65 63 74 (direct
d400: 6f 72 79 3f 20 20 20 68 74 6d 6c 2d 64 69 72 29 ory? html-dir)
d410: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
d420: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d430: 20 20 20 20 20 20 20 20 20 20 20 28 66 69 6c 65 (file
d440: 2d 77 72 69 74 65 2d 61 63 63 65 73 73 3f 20 68 -write-access? h
d450: 74 6d 6c 2d 64 69 72 29 29 0a 20 20 20 20 20 20 tml-dir)).
d460: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d470: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
d480: 6f 70 65 6e 2d 6f 75 74 70 75 74 2d 66 69 6c 65 open-output-file
d490: 20 20 68 74 6d 6c 2d 70 61 74 68 29 0a 20 20 20 html-path).
d4a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d4b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d4c0: 20 20 23 66 29 29 29 0a 20 20 20 20 20 20 20 20 #f))).
d4d0: 20 20 20 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 ;; (print
d4e0: 20 22 72 75 6e 2d 64 69 72 3a 20 22 20 72 75 6e "run-dir: " run
d4f0: 2d 64 69 72 20 22 2c 20 74 65 73 74 73 2d 74 72 -dir ", tests-tr
d500: 65 65 2d 64 61 74 3a 20 22 20 74 65 73 74 73 2d ee-dat: " tests-
d510: 74 72 65 65 2d 64 61 74 29 0a 20 20 20 20 20 20 tree-dat).
d520: 20 20 20 20 20 20 20 20 20 28 69 66 20 6f 75 70 (if oup
d530: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
d540: 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 (begin.
d550: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d560: 28 73 3a 6f 75 74 70 75 74 2d 6e 65 77 0a 20 20 (s:output-new.
d570: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d580: 20 20 20 20 6f 75 70 0a 20 20 20 20 20 20 20 20 oup.
d590: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s
d5a0: 3a 68 74 6d 6c 20 74 65 73 74 73 3a 63 73 73 2d :html tests:css-
d5b0: 6a 73 63 72 69 70 74 2d 62 6c 6f 63 6b 0a 20 20 jscript-block.
d5c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d5d0: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 3a 74 (s:t
d5e0: 69 74 6c 65 20 22 53 75 6d 6d 61 72 79 20 66 6f itle "Summary fo
d5f0: 72 20 22 20 61 72 65 61 2d 6e 61 6d 65 29 0a 20 r " area-name).
d600: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d610: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 3a (s:
d620: 62 6f 64 79 20 27 6f 6e 6c 6f 61 64 20 22 61 64 body 'onload "ad
d630: 64 45 76 65 6e 74 73 28 29 3b 22 0a 20 20 20 20 dEvents();".
d640: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d650: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d660: 20 20 28 73 3a 68 31 20 22 53 75 6d 6d 61 72 79 (s:h1 "Summary
d670: 20 66 6f 72 20 22 20 28 73 74 72 69 6e 67 2d 69 for " (string-i
d680: 6e 74 65 72 73 70 65 72 73 65 20 72 75 6e 2d 64 ntersperse run-d
d690: 69 72 20 22 2f 22 29 29 0a 20 20 20 20 20 20 20 ir "/")).
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 3b ;
d6c0: 3b 20 74 6f 70 20 6c 69 73 74 0a 20 20 20 20 20 ; top list.
d6d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d6e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d6f0: 20 28 73 3a 75 6c 20 27 69 64 20 22 4c 69 6e 6b (s:ul 'id "Link
d700: 65 64 4c 69 73 74 31 22 20 27 63 6c 61 73 73 20 edList1" 'class
d710: 22 4c 69 6e 6b 65 64 4c 69 73 74 22 0a 20 20 20 "LinkedList".
d720: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d730: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d740: 20 20 20 20 20 20 20 20 20 28 73 3a 6c 69 0a 20 (s:li.
d750: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d760: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d770: 20 20 20 20 20 20 20 20 20 20 20 20 22 54 65 73 "Tes
d780: 74 73 22 0a 20 20 20 20 20 20 20 20 20 20 20 20 ts".
d790: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d7a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d7b0: 20 28 63 6f 6d 6d 6f 6e 3a 68 74 72 65 65 2d 3e (common:htree->
d7c0: 68 74 6d 6c 20 74 65 73 74 73 2d 68 74 72 65 65 html tests-htree
d7d0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
d7e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d7f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d800: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d810: 20 20 27 28 29 0a 20 20 20 20 20 20 20 20 20 20 '().
d820: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d830: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d840: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d850: 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 (lambda (
d860: 78 20 70 29 0a 20 20 20 20 20 20 20 20 20 20 20 x p).
d870: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d880: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d890: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d8a0: 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 (let* ((
d8b0: 74 61 72 67 2d 70 61 74 68 20 28 73 74 72 69 6e targ-path (strin
d8c0: 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 70 20 g-intersperse p
d8d0: 22 2f 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 "/")).
d8e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d8f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d900: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d910: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d920: 28 74 65 73 74 2d 6e 61 6d 65 20 28 63 61 72 20 (test-name (car
d930: 70 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 p)).
d940: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d950: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d960: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d970: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i
d980: 74 65 6d 2d 70 61 74 68 20 3b 3b 20 28 69 66 20 tem-path ;; (if
d990: 28 3e 20 28 6c 65 6e 67 74 68 20 70 29 20 32 29 (> (length p) 2)
d9a0: 20 3b 3b 20 74 65 73 74 2d 6e 61 6d 65 20 2b 20 ;; test-name +
d9b0: 72 75 6e 2d 6e 61 6d 65 0a 20 20 20 20 20 20 20 run-name.
d9c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d9d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d9e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d9f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
da00: 20 20 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 (string-inte
da10: 72 73 70 65 72 73 65 20 70 20 22 2f 22 29 29 0a rsperse p "/")).
da20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
da30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
da40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
da50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
da60: 20 20 20 20 20 20 20 20 20 20 28 66 75 6c 6c 2d (full-
da70: 74 61 72 67 20 28 63 6f 6e 63 20 68 74 6d 6c 2d targ (conc html-
da80: 64 69 72 20 22 2f 22 20 74 61 72 67 2d 70 61 74 dir "/" targ-pat
da90: 68 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 h)).
daa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dab0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dac0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dad0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s
dae0: 74 64 2d 66 69 6c 65 20 20 28 63 6f 6e 63 20 66 td-file (conc f
daf0: 75 6c 6c 2d 74 61 72 67 20 22 2f 74 65 73 74 2d ull-targ "/test-
db00: 73 75 6d 6d 61 72 79 2e 68 74 6d 6c 22 29 29 0a summary.html")).
db10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
db20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
db30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
db40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
db50: 20 20 20 20 20 20 20 20 20 20 28 61 6c 74 2d 66 (alt-f
db60: 69 6c 65 20 20 28 63 6f 6e 63 20 66 75 6c 6c 2d ile (conc full-
db70: 74 61 72 67 20 22 2f 6d 65 67 61 74 65 73 74 2d targ "/megatest-
db80: 72 6f 6c 6c 75 70 2d 22 20 74 65 73 74 2d 6e 61 rollup-" test-na
db90: 6d 65 20 22 2e 68 74 6d 6c 22 29 29 0a 20 20 20 me ".html")).
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 20 20 20 20 20 20 20
dbc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dbd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dbe0: 20 20 20 20 20 20 20 28 68 74 6d 6c 2d 66 69 6c (html-fil
dbf0: 65 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 66 69 e (if (common:fi
dc00: 6c 65 2d 65 78 69 73 74 73 3f 20 61 6c 74 2d 66 le-exists? alt-f
dc10: 69 6c 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 ile).
dc20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dc30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dc40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dc50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dc60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 61 6c al
dc70: 74 2d 66 69 6c 65 0a 20 20 20 20 20 20 20 20 20 t-file.
dc80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dc90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dca0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dcb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dcc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dcd0: 73 74 64 2d 66 69 6c 65 29 29 0a 20 20 20 20 20 std-file)).
dce0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dcf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dd00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dd10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dd20: 20 20 20 20 20 28 72 75 6e 2d 6e 61 6d 65 20 20 (run-name
dd30: 28 63 61 72 20 28 72 65 76 65 72 73 65 20 70 29 (car (reverse p)
dd40: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
dd50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dd60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dd70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dd80: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 61 6e (if (an
dd90: 64 20 28 6e 6f 74 20 28 63 6f 6d 6d 6f 6e 3a 66 d (not (common:f
dda0: 69 6c 65 2d 65 78 69 73 74 73 3f 20 66 75 6c 6c ile-exists? full
ddb0: 2d 74 61 72 67 29 29 0a 20 20 20 20 20 20 20 20 -targ)).
ddc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ddd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dde0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ddf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
de00: 20 20 20 20 20 20 28 64 69 72 65 63 74 6f 72 79 (directory
de10: 3f 20 66 75 6c 6c 2d 74 61 72 67 29 0a 20 20 20 ? full-targ).
de20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
de30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
de40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
de50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
de60: 20 20 20 20 20 20 20 20 20 20 20 28 66 69 6c 65 (file
de70: 2d 77 72 69 74 65 2d 61 63 63 65 73 73 3f 20 66 -write-access? f
de80: 75 6c 6c 2d 74 61 72 67 29 29 0a 20 20 20 20 20 ull-targ)).
de90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dea0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
deb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dec0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ded0: 20 20 20 20 28 74 65 73 74 73 3a 73 75 6d 6d 61 (tests:summa
dee0: 72 69 7a 65 2d 74 65 73 74 20 0a 20 20 20 20 20 rize-test .
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 20 20 20 20 20 20 20 20 20
df10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
df20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
df30: 20 20 20 20 20 72 75 6e 2d 69 64 20 0a 20 20 20 run-id .
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 20 20 20 20 20 20 20
df60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
df70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
df80: 20 20 20 20 20 20 20 28 72 6d 74 3a 67 65 74 2d (rmt:get-
df90: 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 74 test-id run-id t
dfa0: 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 est-name item-pa
dfb0: 74 68 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 th))).
dfc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dfd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dfe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dff0: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 (if (
e000: 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 common:file-exis
e010: 74 73 3f 20 66 75 6c 6c 2d 74 61 72 67 29 0a 20 ts? full-targ).
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 20 20 20 20 20 20
e040: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e050: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e060: 20 20 20 20 20 20 20 20 28 73 3a 61 20 72 75 6e (s:a run
e070: 2d 6e 61 6d 65 20 27 68 72 65 66 20 68 74 6d 6c -name 'href html
e080: 2d 66 69 6c 65 29 0a 20 20 20 20 20 20 20 20 20 -file).
e090: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e0a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
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: 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 (begin.
e0e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e0f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e100: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e110: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e120: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
e130: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
e140: 72 74 2a 20 22 45 52 52 4f 52 3a 20 63 61 6e 27 rt* "ERROR: can'
e150: 74 20 61 63 63 65 73 73 20 22 20 66 75 6c 6c 2d t access " full-
e160: 74 61 72 67 29 0a 20 20 20 20 20 20 20 20 20 20 targ).
e170: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e180: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e190: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e1a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e1b0: 20 28 63 6f 6e 63 20 22 4e 6f 20 73 75 6d 6d 61 (conc "No summa
e1c0: 72 79 20 66 6f 72 20 22 20 72 75 6e 2d 6e 61 6d ry for " run-nam
e1d0: 65 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 e))))).
e1e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e1f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e200: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e210: 20 20 20 20 20 20 20 20 29 29 29 29 29 29 0a 20 )))))).
e220: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e230: 20 20 20 20 28 63 6c 6f 73 65 2d 6f 75 74 70 75 (close-outpu
e240: 74 2d 70 6f 72 74 20 6f 75 70 29 29 29 29 29 0a t-port oup))))).
e250: 20 20 20 20 20 20 20 20 20 20 20 72 75 6e 73 29 runs)
e260: 0a 20 20 20 20 20 20 20 20 20 20 23 74 29 0a 09 . #t)..
e270: 23 66 29 29 29 0a 0a 0a 0a 0a 0a 0a 0a 3b 3b 20 #f)))........;;
e280: 43 48 45 43 4b 20 2d 20 57 41 53 20 54 48 49 53 CHECK - WAS THIS
e290: 20 41 44 44 45 44 20 4f 52 20 52 45 4d 4f 56 45 ADDED OR REMOVE
e2a0: 44 3f 20 4d 41 4e 55 41 4c 20 4d 45 52 47 45 20 D? MANUAL MERGE
e2b0: 57 49 54 48 20 41 50 49 20 53 54 55 46 46 21 21 WITH API STUFF!!
e2c0: 21 0a 3b 3b 0a 3b 3b 20 67 65 74 20 61 20 70 72 !.;;.;; get a pr
e2d0: 65 74 74 79 20 74 61 62 6c 65 20 74 6f 20 73 75 etty table to su
e2e0: 6d 6d 61 72 69 7a 65 20 73 74 65 70 73 0a 3b 3b mmarize steps.;;
e2f0: 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 64 63 6f .;; (define (dco
e300: 6d 6d 6f 6e 3a 70 72 6f 63 65 73 73 2d 73 74 65 mmon:process-ste
e310: 70 73 2d 74 61 62 6c 65 20 73 74 65 70 73 29 3b ps-table steps);
e320: 3b 20 64 62 20 74 65 73 74 2d 69 64 20 23 21 6b ; db test-id #!k
e330: 65 79 20 28 77 6f 72 6b 2d 61 72 65 61 20 23 66 ey (work-area #f
e340: 29 29 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 )).(define (test
e350: 73 3a 70 72 6f 63 65 73 73 2d 73 74 65 70 73 2d s:process-steps-
e360: 74 61 62 6c 65 20 73 74 65 70 73 29 3b 3b 20 64 table steps);; d
e370: 62 20 74 65 73 74 2d 69 64 20 23 21 6b 65 79 20 b test-id #!key
e380: 28 77 6f 72 6b 2d 61 72 65 61 20 23 66 29 29 0a (work-area #f)).
e390: 3b 3b 20 20 28 6c 65 74 20 28 28 73 74 65 70 73 ;; (let ((steps
e3a0: 20 20 20 28 64 62 3a 67 65 74 2d 73 74 65 70 73 (db:get-steps
e3b0: 2d 66 6f 72 2d 74 65 73 74 20 64 62 20 74 65 73 -for-test db tes
e3c0: 74 2d 69 64 20 77 6f 72 6b 2d 61 72 65 61 3a 20 t-id work-area:
e3d0: 77 6f 72 6b 2d 61 72 65 61 29 29 29 0a 20 20 20 work-area))).
e3e0: 20 3b 3b 20 6f 72 67 61 6e 69 73 65 20 74 68 65 ;; organise the
e3f0: 20 73 74 65 70 73 20 66 6f 72 20 62 65 74 74 65 steps for bette
e400: 72 20 72 65 61 64 61 62 69 6c 69 74 79 0a 20 20 r readability.
e410: 20 20 28 6c 65 74 20 28 28 72 65 73 20 28 6d 61 (let ((res (ma
e420: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 ke-hash-table)))
e430: 0a 20 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 . (for-each
e440: 20 0a 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 . (lambda
e450: 20 28 73 74 65 70 29 0a 09 20 28 64 65 62 75 67 (step).. (debug
e460: 3a 70 72 69 6e 74 20 36 20 2a 64 65 66 61 75 6c :print 6 *defaul
e470: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 74 65 t-log-port* "ste
e480: 70 3d 22 20 73 74 65 70 29 0a 09 20 28 6c 65 74 p=" step).. (let
e490: 20 28 28 72 65 63 6f 72 64 20 28 68 61 73 68 2d ((record (hash-
e4a0: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
e4b0: 74 20 0a 09 09 09 72 65 73 20 0a 09 09 09 28 74 t ....res ....(t
e4c0: 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 65 70 db:step-get-step
e4d0: 6e 61 6d 65 20 73 74 65 70 29 0a 09 09 09 3b 3b name step)....;;
e4e0: 20 20 20 20 20 20 20 20 20 20 20 30 20 20 20 20 0
e4f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e500: 20 20 31 20 20 20 20 32 20 20 20 20 33 20 20 20 1 2 3
e510: 20 20 20 20 34 20 20 20 20 20 20 20 20 20 35 20 4 5
e520: 20 20 20 20 20 20 36 20 20 20 20 20 20 20 37 0a 6 7.
e530: 09 09 09 3b 3b 20 20 20 20 20 20 20 20 73 74 65 ...;; ste
e540: 70 6e 61 6d 65 20 20 20 20 20 20 20 20 20 20 20 pname
e550: 20 20 20 20 20 73 74 61 72 74 20 65 6e 64 20 73 start end s
e560: 74 61 74 75 73 20 44 75 72 61 74 69 6f 6e 20 20 tatus Duration
e570: 4c 6f 67 66 69 6c 65 20 43 6f 6d 6d 65 6e 74 20 Logfile Comment
e580: 20 66 69 72 73 74 2d 69 64 0a 09 09 09 28 76 65 first-id....(ve
e590: 63 74 6f 72 20 28 74 64 62 3a 73 74 65 70 2d 67 ctor (tdb:step-g
e5a0: 65 74 2d 73 74 65 70 6e 61 6d 65 20 73 74 65 70 et-stepname step
e5b0: 29 20 22 22 20 20 20 22 22 20 22 22 20 20 20 20 ) "" "" ""
e5c0: 20 22 22 20 20 20 20 20 20 20 20 22 22 20 20 20 "" ""
e5d0: 20 20 22 22 20 20 20 20 20 20 20 23 66 29 29 29 "" #f)))
e5e0: 29 0a 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 ).. (debug:pri
e5f0: 6e 74 20 36 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 6 *default-lo
e600: 67 2d 70 6f 72 74 2a 20 22 72 65 63 6f 72 64 28 g-port* "record(
e610: 62 65 66 6f 72 65 29 20 3d 20 22 20 72 65 63 6f before) = " reco
e620: 72 64 20 0a 09 09 09 22 5c 6e 69 64 3a 20 20 20 rd ...."\nid:
e630: 20 20 20 20 22 20 28 74 64 62 3a 73 74 65 70 2d " (tdb:step-
e640: 67 65 74 2d 69 64 20 73 74 65 70 29 0a 09 09 09 get-id step)....
e650: 22 5c 6e 73 74 65 70 6e 61 6d 65 3a 20 22 20 28 "\nstepname: " (
e660: 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 65 tdb:step-get-ste
e670: 70 6e 61 6d 65 20 73 74 65 70 29 0a 09 09 09 22 pname step)...."
e680: 5c 6e 73 74 61 74 65 3a 20 20 20 20 22 20 28 74 \nstate: " (t
e690: 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 61 74 db:step-get-stat
e6a0: 65 20 73 74 65 70 29 0a 09 09 09 22 5c 6e 73 74 e step)...."\nst
e6b0: 61 74 75 73 3a 20 20 20 22 20 28 74 64 62 3a 73 atus: " (tdb:s
e6c0: 74 65 70 2d 67 65 74 2d 73 74 61 74 75 73 20 73 tep-get-status s
e6d0: 74 65 70 29 0a 09 09 09 22 5c 6e 74 69 6d 65 3a tep)...."\ntime:
e6e0: 20 20 20 20 20 22 20 28 74 64 62 3a 73 74 65 70 " (tdb:step
e6f0: 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 -get-event_time
e700: 73 74 65 70 29 29 0a 09 20 20 20 28 69 66 20 28 step)).. (if (
e710: 6e 6f 74 20 28 76 65 63 74 6f 72 2d 72 65 66 20 not (vector-ref
e720: 72 65 63 6f 72 64 20 37 29 29 28 76 65 63 74 6f record 7))(vecto
e730: 72 2d 73 65 74 21 20 72 65 63 6f 72 64 20 37 20 r-set! record 7
e740: 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 69 64 (tdb:step-get-id
e750: 20 73 74 65 70 29 29 29 20 3b 3b 20 64 6f 20 6e step))) ;; do n
e760: 6f 74 20 63 6c 6f 62 62 65 72 20 74 68 65 20 69 ot clobber the i
e770: 64 20 69 66 20 70 72 65 76 69 6f 75 73 6c 79 20 d if previously
e780: 73 65 74 0a 09 20 20 20 28 63 61 73 65 20 28 73 set.. (case (s
e790: 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 74 tring->symbol (t
e7a0: 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 61 74 db:step-get-stat
e7b0: 65 20 73 74 65 70 29 29 0a 09 20 20 20 20 20 28 e step)).. (
e7c0: 28 73 74 61 72 74 29 28 76 65 63 74 6f 72 2d 73 (start)(vector-s
e7d0: 65 74 21 20 72 65 63 6f 72 64 20 31 20 28 74 64 et! record 1 (td
e7e0: 62 3a 73 74 65 70 2d 67 65 74 2d 65 76 65 6e 74 b:step-get-event
e7f0: 5f 74 69 6d 65 20 73 74 65 70 29 29 0a 09 20 20 _time step))..
e800: 20 20 20 20 28 76 65 63 74 6f 72 2d 73 65 74 21 (vector-set!
e810: 20 72 65 63 6f 72 64 20 33 20 28 69 66 20 28 65 record 3 (if (e
e820: 71 75 61 6c 3f 20 28 76 65 63 74 6f 72 2d 72 65 qual? (vector-re
e830: 66 20 72 65 63 6f 72 64 20 33 29 20 22 22 29 0a f record 3) "").
e840: 09 09 09 09 09 28 74 64 62 3a 73 74 65 70 2d 67 .....(tdb:step-g
e850: 65 74 2d 73 74 61 74 75 73 20 73 74 65 70 29 29 et-status step))
e860: 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 3e 20 ).. (if (>
e870: 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 28 (string-length (
e880: 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 6c 6f 67 tdb:step-get-log
e890: 66 69 6c 65 20 73 74 65 70 29 29 0a 09 09 20 20 file step))...
e8a0: 20 20 20 30 29 0a 09 09 20 20 28 76 65 63 74 6f 0)... (vecto
e8b0: 72 2d 73 65 74 21 20 72 65 63 6f 72 64 20 35 20 r-set! record 5
e8c0: 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 6c 6f (tdb:step-get-lo
e8d0: 67 66 69 6c 65 20 73 74 65 70 29 29 29 29 0a 09 gfile step))))..
e8e0: 20 20 20 20 20 28 28 65 6e 64 29 20 20 0a 09 20 ((end) ..
e8f0: 20 20 20 20 20 28 76 65 63 74 6f 72 2d 73 65 74 (vector-set
e900: 21 20 72 65 63 6f 72 64 20 32 20 28 61 6e 79 2d ! record 2 (any-
e910: 3e 6e 75 6d 62 65 72 20 28 74 64 62 3a 73 74 65 >number (tdb:ste
e920: 70 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 p-get-event_time
e930: 20 73 74 65 70 29 29 29 0a 09 20 20 20 20 20 20 step)))..
e940: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 72 65 63 (vector-set! rec
e950: 6f 72 64 20 33 20 28 74 64 62 3a 73 74 65 70 2d ord 3 (tdb:step-
e960: 67 65 74 2d 73 74 61 74 75 73 20 73 74 65 70 29 get-status step)
e970: 29 0a 09 20 20 20 20 20 20 28 76 65 63 74 6f 72 ).. (vector
e980: 2d 73 65 74 21 20 72 65 63 6f 72 64 20 34 20 28 -set! record 4 (
e990: 6c 65 74 20 28 28 73 74 61 72 74 74 20 28 61 6e let ((startt (an
e9a0: 79 2d 3e 6e 75 6d 62 65 72 20 28 76 65 63 74 6f y->number (vecto
e9b0: 72 2d 72 65 66 20 72 65 63 6f 72 64 20 31 29 29 r-ref record 1))
e9c0: 29 0a 09 09 09 09 09 20 20 28 65 6e 64 74 20 20 )...... (endt
e9d0: 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 20 28 76 (any->number (v
e9e0: 65 63 74 6f 72 2d 72 65 66 20 72 65 63 6f 72 64 ector-ref record
e9f0: 20 32 29 29 29 29 0a 09 09 09 09 20 20 20 20 20 2)))).....
ea00: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 (debug:print 4
ea10: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
ea20: 74 2a 20 22 72 65 63 6f 72 64 5b 31 5d 3d 22 20 t* "record[1]="
ea30: 28 76 65 63 74 6f 72 2d 72 65 66 20 72 65 63 6f (vector-ref reco
ea40: 72 64 20 31 29 20 0a 09 09 09 09 09 09 20 20 20 rd 1) .......
ea50: 22 2c 20 73 74 61 72 74 74 3d 22 20 73 74 61 72 ", startt=" star
ea60: 74 74 20 22 2c 20 65 6e 64 74 3d 22 20 65 6e 64 tt ", endt=" end
ea70: 74 0a 09 09 09 09 09 09 20 20 20 22 2c 20 67 65 t....... ", ge
ea80: 74 2d 73 74 61 74 75 73 3a 20 22 20 28 74 64 62 t-status: " (tdb
ea90: 3a 73 74 65 70 2d 67 65 74 2d 73 74 61 74 75 73 :step-get-status
eaa0: 20 73 74 65 70 29 29 0a 09 09 09 09 20 20 20 20 step)).....
eab0: 20 20 28 69 66 20 28 61 6e 64 20 28 6e 75 6d 62 (if (and (numb
eac0: 65 72 3f 20 73 74 61 72 74 74 29 28 6e 75 6d 62 er? startt)(numb
ead0: 65 72 3f 20 65 6e 64 74 29 29 0a 09 09 09 09 09 er? endt))......
eae0: 20 20 28 73 65 63 6f 6e 64 73 2d 3e 68 72 2d 6d (seconds->hr-m
eaf0: 69 6e 2d 73 65 63 20 28 2d 20 65 6e 64 74 20 73 in-sec (- endt s
eb00: 74 61 72 74 74 29 29 20 22 2d 31 22 29 29 29 0a tartt)) "-1"))).
eb10: 09 20 20 20 20 20 20 28 69 66 20 28 3e 20 28 73 . (if (> (s
eb20: 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 28 74 64 tring-length (td
eb30: 62 3a 73 74 65 70 2d 67 65 74 2d 6c 6f 67 66 69 b:step-get-logfi
eb40: 6c 65 20 73 74 65 70 29 29 0a 09 09 20 20 20 20 le step))...
eb50: 20 30 29 0a 09 09 20 20 28 76 65 63 74 6f 72 2d 0)... (vector-
eb60: 73 65 74 21 20 72 65 63 6f 72 64 20 35 20 28 74 set! record 5 (t
eb70: 64 62 3a 73 74 65 70 2d 67 65 74 2d 6c 6f 67 66 db:step-get-logf
eb80: 69 6c 65 20 73 74 65 70 29 29 29 0a 09 20 20 20 ile step)))..
eb90: 20 20 20 28 69 66 20 28 3e 20 28 73 74 72 69 6e (if (> (strin
eba0: 67 2d 6c 65 6e 67 74 68 20 28 74 64 62 3a 73 74 g-length (tdb:st
ebb0: 65 70 2d 67 65 74 2d 63 6f 6d 6d 65 6e 74 20 73 ep-get-comment s
ebc0: 74 65 70 29 29 0a 09 09 20 20 20 20 20 30 29 0a tep))... 0).
ebd0: 09 09 20 20 28 76 65 63 74 6f 72 2d 73 65 74 21 .. (vector-set!
ebe0: 20 72 65 63 6f 72 64 20 36 20 28 74 64 62 3a 73 record 6 (tdb:s
ebf0: 74 65 70 2d 67 65 74 2d 63 6f 6d 6d 65 6e 74 20 tep-get-comment
ec00: 73 74 65 70 29 29 29 29 0a 09 20 20 20 20 20 28 step)))).. (
ec10: 65 6c 73 65 0a 09 20 20 20 20 20 20 28 76 65 63 else.. (vec
ec20: 74 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 64 20 tor-set! record
ec30: 32 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 2 (tdb:step-get-
ec40: 73 74 61 74 65 20 73 74 65 70 29 29 0a 09 20 20 state step))..
ec50: 20 20 20 20 28 76 65 63 74 6f 72 2d 73 65 74 21 (vector-set!
ec60: 20 72 65 63 6f 72 64 20 33 20 28 74 64 62 3a 73 record 3 (tdb:s
ec70: 74 65 70 2d 67 65 74 2d 73 74 61 74 75 73 20 73 tep-get-status s
ec80: 74 65 70 29 29 0a 09 20 20 20 20 20 20 28 76 65 tep)).. (ve
ec90: 63 74 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 64 ctor-set! record
eca0: 20 34 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 4 (tdb:step-get
ecb0: 2d 65 76 65 6e 74 5f 74 69 6d 65 20 73 74 65 70 -event_time step
ecc0: 29 29 0a 09 20 20 20 20 20 20 28 76 65 63 74 6f )).. (vecto
ecd0: 72 2d 73 65 74 21 20 72 65 63 6f 72 64 20 36 20 r-set! record 6
ece0: 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 63 6f (tdb:step-get-co
ecf0: 6d 6d 65 6e 74 20 73 74 65 70 29 29 29 29 0a 09 mment step))))..
ed00: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 (hash-table-s
ed10: 65 74 21 20 72 65 73 20 28 74 64 62 3a 73 74 65 et! res (tdb:ste
ed20: 70 2d 67 65 74 2d 73 74 65 70 6e 61 6d 65 20 73 p-get-stepname s
ed30: 74 65 70 29 20 72 65 63 6f 72 64 29 0a 09 20 20 tep) record)..
ed40: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 36 20 (debug:print 6
ed50: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
ed60: 74 2a 20 22 72 65 63 6f 72 64 28 61 66 74 65 72 t* "record(after
ed70: 29 20 20 3d 20 22 20 72 65 63 6f 72 64 20 0a 09 ) = " record ..
ed80: 09 09 22 5c 6e 69 64 3a 20 20 20 20 20 20 20 22 .."\nid: "
ed90: 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 69 (tdb:step-get-i
eda0: 64 20 73 74 65 70 29 0a 09 09 09 22 5c 6e 73 74 d step)...."\nst
edb0: 65 70 6e 61 6d 65 3a 20 22 20 28 74 64 62 3a 73 epname: " (tdb:s
edc0: 74 65 70 2d 67 65 74 2d 73 74 65 70 6e 61 6d 65 tep-get-stepname
edd0: 20 73 74 65 70 29 0a 09 09 09 22 5c 6e 73 74 61 step)...."\nsta
ede0: 74 65 3a 20 20 20 20 22 20 28 74 64 62 3a 73 74 te: " (tdb:st
edf0: 65 70 2d 67 65 74 2d 73 74 61 74 65 20 73 74 65 ep-get-state ste
ee00: 70 29 0a 09 09 09 22 5c 6e 73 74 61 74 75 73 3a p)...."\nstatus:
ee10: 20 20 20 22 20 28 74 64 62 3a 73 74 65 70 2d 67 " (tdb:step-g
ee20: 65 74 2d 73 74 61 74 75 73 20 73 74 65 70 29 0a et-status step).
ee30: 09 09 09 22 5c 6e 74 69 6d 65 3a 20 20 20 20 20 ..."\ntime:
ee40: 22 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d " (tdb:step-get-
ee50: 65 76 65 6e 74 5f 74 69 6d 65 20 73 74 65 70 29 event_time step)
ee60: 29 29 29 0a 20 20 20 20 20 20 20 3b 3b 20 28 65 ))). ;; (e
ee70: 6c 73 65 20 20 20 28 76 65 63 74 6f 72 2d 73 65 lse (vector-se
ee80: 74 21 20 72 65 63 6f 72 64 20 31 20 28 74 64 62 t! record 1 (tdb
ee90: 3a 73 74 65 70 2d 67 65 74 2d 65 76 65 6e 74 5f :step-get-event_
eea0: 74 69 6d 65 20 73 74 65 70 29 29 29 0a 20 20 20 time step))).
eeb0: 20 20 20 20 28 73 6f 72 74 20 73 74 65 70 73 20 (sort steps
eec0: 28 6c 61 6d 62 64 61 20 28 61 20 62 29 0a 09 09 (lambda (a b)...
eed0: 20 20 20 20 20 28 63 6f 6e 64 0a 09 09 20 20 20 (cond...
eee0: 20 20 20 28 28 3c 20 20 20 28 74 64 62 3a 73 74 ((< (tdb:st
eef0: 65 70 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 6d ep-get-event_tim
ef00: 65 20 61 29 28 74 64 62 3a 73 74 65 70 2d 67 65 e a)(tdb:step-ge
ef10: 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 62 29 29 t-event_time b))
ef20: 20 23 74 29 0a 09 09 20 20 20 20 20 20 28 28 65 #t)... ((e
ef30: 71 3f 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 q? (tdb:step-get
ef40: 2d 65 76 65 6e 74 5f 74 69 6d 65 20 61 29 28 74 -event_time a)(t
ef50: 64 62 3a 73 74 65 70 2d 67 65 74 2d 65 76 65 6e db:step-get-even
ef60: 74 5f 74 69 6d 65 20 62 29 29 20 0a 09 09 20 20 t_time b)) ...
ef70: 20 20 20 20 20 28 3c 20 20 20 28 74 64 62 3a 73 (< (tdb:s
ef80: 74 65 70 2d 67 65 74 2d 69 64 20 61 29 20 20 20 tep-get-id a)
ef90: 20 20 20 20 20 28 74 64 62 3a 73 74 65 70 2d 67 (tdb:step-g
efa0: 65 74 2d 69 64 20 62 29 29 29 0a 09 09 20 20 20 et-id b)))...
efb0: 20 20 20 28 65 6c 73 65 20 23 66 29 29 29 29 29 (else #f)))))
efc0: 0a 20 20 20 20 20 20 72 65 73 29 29 0a 0a 3b 3b . res))..;;
efd0: 20 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 65 .;;.(define (te
efe0: 73 74 73 3a 67 65 74 2d 63 6f 6d 70 72 65 73 73 sts:get-compress
eff0: 65 64 2d 73 74 65 70 73 20 72 75 6e 2d 69 64 20 ed-steps run-id
f000: 74 65 73 74 2d 69 64 29 0a 20 20 28 6c 65 74 2a test-id). (let*
f010: 20 28 28 73 74 65 70 73 2d 64 61 74 61 20 20 28 ((steps-data (
f020: 72 6d 74 3a 67 65 74 2d 73 74 65 70 73 2d 66 6f rmt:get-steps-fo
f030: 72 2d 74 65 73 74 20 72 75 6e 2d 69 64 20 74 65 r-test run-id te
f040: 73 74 2d 69 64 29 29 20 3b 3b 20 20 20 20 20 20 st-id)) ;;
f050: 30 20 20 20 20 20 20 20 31 20 20 20 20 32 20 20 0 1 2
f060: 20 20 33 20 20 20 20 20 20 20 34 20 20 20 20 20 3 4
f070: 20 20 35 20 20 20 20 20 20 20 36 20 20 20 20 20 5 6
f080: 20 37 20 20 20 20 20 20 20 0a 09 20 28 63 6f 6d 7 .. (com
f090: 70 72 73 74 65 70 73 20 20 28 74 65 73 74 73 3a prsteps (tests:
f0a0: 70 72 6f 63 65 73 73 2d 73 74 65 70 73 2d 74 61 process-steps-ta
f0b0: 62 6c 65 20 73 74 65 70 73 2d 64 61 74 61 29 29 ble steps-data))
f0c0: 29 20 3b 3b 20 23 3c 73 74 65 70 6e 61 6d 65 20 ) ;; #<stepname
f0d0: 73 74 61 72 74 20 65 6e 64 20 73 74 61 74 75 73 start end status
f0e0: 20 44 75 72 61 74 69 6f 6e 20 4c 6f 67 66 69 6c Duration Logfil
f0f0: 65 20 43 6f 6d 6d 65 6e 74 20 69 64 3e 0a 20 20 e Comment id>.
f100: 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 (map (lambda (
f110: 78 29 0a 09 20 20 20 3b 3b 20 74 61 6b 65 20 61 x).. ;; take a
f120: 64 76 61 6e 74 61 67 65 20 6f 66 20 74 68 65 20 dvantage of the
f130: 5c 6e 20 6f 6e 20 74 69 6d 65 2d 3e 73 74 72 69 \n on time->stri
f140: 6e 67 0a 09 20 20 20 28 76 65 63 74 6f 72 20 20 ng.. (vector
f150: 20 20 3b 3b 20 77 65 20 61 72 65 20 63 6f 6e 73 ;; we are cons
f160: 74 72 75 63 74 69 6e 67 20 62 61 73 69 63 61 6c tructing basical
f170: 6c 79 20 74 68 65 20 6f 72 69 67 69 6e 61 6c 20 ly the original
f180: 76 65 63 74 6f 72 20 62 75 74 20 63 6f 6c 6c 61 vector but colla
f190: 70 73 69 6e 67 20 73 74 61 72 74 20 65 6e 64 20 psing start end
f1a0: 72 65 63 6f 72 64 73 0a 09 20 20 20 20 28 76 65 records.. (ve
f1b0: 63 74 6f 72 2d 72 65 66 20 78 20 30 29 20 20 20 ctor-ref x 0)
f1c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
f1d0: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 69 64 ;; id
f1e0: 20 20 20 20 20 20 20 20 30 0a 09 20 20 20 20 28 0.. (
f1f0: 6c 65 74 20 28 28 73 20 28 76 65 63 74 6f 72 2d let ((s (vector-
f200: 72 65 66 20 78 20 31 29 29 29 0a 09 20 20 20 20 ref x 1)))..
f210: 20 20 28 69 66 20 28 6e 75 6d 62 65 72 3f 20 73 (if (number? s
f220: 29 28 73 65 63 6f 6e 64 73 2d 3e 74 69 6d 65 2d )(seconds->time-
f230: 73 74 72 69 6e 67 20 73 29 20 73 29 29 20 3b 3b string s) s)) ;;
f240: 20 73 74 61 72 74 74 69 6d 65 20 31 0a 09 20 20 starttime 1..
f250: 20 20 28 6c 65 74 20 28 28 73 20 28 76 65 63 74 (let ((s (vect
f260: 6f 72 2d 72 65 66 20 78 20 32 29 29 29 0a 09 20 or-ref x 2)))..
f270: 20 20 20 20 20 28 69 66 20 28 6e 75 6d 62 65 72 (if (number
f280: 3f 20 73 29 28 73 65 63 6f 6e 64 73 2d 3e 74 69 ? s)(seconds->ti
f290: 6d 65 2d 73 74 72 69 6e 67 20 73 29 20 73 29 29 me-string s) s))
f2a0: 20 3b 3b 20 65 6e 64 74 69 6d 65 20 20 20 32 0a ;; endtime 2.
f2b0: 09 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 . (vector-ref
f2c0: 20 78 20 33 29 20 20 20 20 20 20 20 20 20 20 20 x 3)
f2d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
f2e0: 20 20 20 3b 3b 20 73 74 61 74 75 73 20 20 20 20 ;; status
f2f0: 33 20 20 20 20 0a 09 20 20 20 20 28 76 65 63 74 3 .. (vect
f300: 6f 72 2d 72 65 66 20 78 20 34 29 20 20 20 20 20 or-ref x 4)
f310: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
f320: 20 20 20 20 20 20 20 20 20 3b 3b 20 64 75 72 61 ;; dura
f330: 74 69 6f 6e 20 20 34 0a 09 20 20 20 20 28 76 65 tion 4.. (ve
f340: 63 74 6f 72 2d 72 65 66 20 78 20 35 29 20 20 20 ctor-ref x 5)
f350: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
f360: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 6c 6f ;; lo
f370: 67 66 69 6c 65 20 20 20 35 0a 09 20 20 20 20 28 gfile 5.. (
f380: 76 65 63 74 6f 72 2d 72 65 66 20 78 20 36 29 20 vector-ref x 6)
f390: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
f3a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ;;
f3b0: 63 6f 6d 6d 65 6e 74 20 20 20 36 0a 09 20 20 20 comment 6..
f3c0: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 78 20 37 (vector-ref x 7
f3d0: 29 29 29 20 20 20 20 20 20 20 20 20 20 20 20 20 )))
f3e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
f3f0: 3b 20 69 64 20 20 20 20 20 20 20 20 37 0a 09 20 ; id 7..
f400: 28 73 6f 72 74 20 28 68 61 73 68 2d 74 61 62 6c (sort (hash-tabl
f410: 65 2d 76 61 6c 75 65 73 20 63 6f 6d 70 72 73 74 e-values comprst
f420: 65 70 73 29 0a 09 20 20 20 20 20 20 20 28 6c 61 eps).. (la
f430: 6d 62 64 61 20 28 61 20 62 29 0a 09 09 20 28 6c mbda (a b)... (l
f440: 65 74 20 28 28 74 69 6d 65 2d 61 20 28 76 65 63 et ((time-a (vec
f450: 74 6f 72 2d 72 65 66 20 61 20 31 29 29 0a 09 09 tor-ref a 1))...
f460: 20 20 20 20 20 20 20 28 74 69 6d 65 2d 62 20 28 (time-b (
f470: 76 65 63 74 6f 72 2d 72 65 66 20 62 20 31 29 29 vector-ref b 1))
f480: 0a 09 09 20 20 20 20 20 20 20 28 69 64 2d 61 20 ... (id-a
f490: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 61 20 (vector-ref a
f4a0: 37 29 29 0a 09 09 20 20 20 20 20 20 20 28 69 64 7))... (id
f4b0: 2d 62 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 -b (vector-ref
f4c0: 20 62 20 37 29 29 29 0a 09 09 20 20 20 28 69 66 b 7)))... (if
f4d0: 20 28 61 6e 64 20 28 6e 75 6d 62 65 72 3f 20 74 (and (number? t
f4e0: 69 6d 65 2d 61 29 28 6e 75 6d 62 65 72 3f 20 74 ime-a)(number? t
f4f0: 69 6d 65 2d 62 29 29 0a 09 09 20 20 20 20 20 20 ime-b))...
f500: 20 28 69 66 20 28 3c 20 74 69 6d 65 2d 61 20 74 (if (< time-a t
f510: 69 6d 65 2d 62 29 0a 09 09 09 20 20 20 23 74 0a ime-b).... #t.
f520: 09 09 09 20 20 20 28 69 66 20 28 65 71 3f 20 74 ... (if (eq? t
f530: 69 6d 65 2d 61 20 74 69 6d 65 2d 62 29 0a 09 09 ime-a time-b)...
f540: 09 20 20 20 20 20 20 20 28 3c 20 69 64 2d 61 20 . (< id-a
f550: 69 64 2d 62 29 0a 09 09 09 20 20 20 20 20 20 20 id-b)....
f560: 3b 3b 20 28 73 74 72 69 6e 67 3c 3f 20 28 63 6f ;; (string<? (co
f570: 6e 63 20 28 76 65 63 74 6f 72 2d 72 65 66 20 61 nc (vector-ref a
f580: 20 32 29 29 0a 09 09 09 20 20 20 20 20 20 20 3b 2)).... ;
f590: 3b 09 20 20 20 20 28 63 6f 6e 63 20 28 76 65 63 ;. (conc (vec
f5a0: 74 6f 72 2d 72 65 66 20 62 20 32 29 29 29 0a 09 tor-ref b 2)))..
f5b0: 09 09 20 20 20 20 20 20 20 23 66 29 29 0a 09 09 .. #f))...
f5c0: 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 3c 3f (string<?
f5d0: 20 28 63 6f 6e 63 20 74 69 6d 65 2d 61 29 28 63 (conc time-a)(c
f5e0: 6f 6e 63 20 74 69 6d 65 2d 62 29 29 29 29 29 29 onc time-b))))))
f5f0: 29 29 29 0a 0a 0a 3b 3b 20 53 61 76 65 20 74 65 )))...;; Save te
f600: 73 74 20 73 74 61 74 65 20 61 6e 64 20 73 74 61 st state and sta
f610: 74 75 73 20 69 6e 20 74 6f 20 61 20 66 69 6c 65 tus in to a file
f620: 20 2e 66 69 6e 61 6c 2d 73 74 61 74 75 73 20 69 .final-status i
f630: 6e 20 74 68 65 20 74 65 73 74 20 64 69 72 65 63 n the test direc
f640: 74 6f 72 79 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 tory.;;.(define
f650: 28 74 65 73 74 73 3a 73 61 76 65 2d 66 69 6e 61 (tests:save-fina
f660: 6c 2d 73 74 61 74 75 73 20 72 75 6e 2d 69 64 20 l-status run-id
f670: 74 65 73 74 2d 69 64 29 0a 20 20 28 6c 65 74 2a test-id). (let*
f680: 20 28 28 74 65 73 74 2d 64 61 74 20 20 28 72 6d ((test-dat (rm
f690: 74 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d t:get-test-info-
f6a0: 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 by-id run-id tes
f6b0: 74 2d 69 64 29 29 0a 09 20 28 6f 75 74 2d 64 69 t-id)).. (out-di
f6c0: 72 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 r (db:test-get
f6d0: 2d 72 75 6e 64 69 72 20 74 65 73 74 2d 64 61 74 -rundir test-dat
f6e0: 29 29 0a 09 20 28 73 74 61 74 75 73 2d 66 69 6c )).. (status-fil
f6f0: 65 20 20 28 63 6f 6e 63 20 6f 75 74 2d 64 69 72 e (conc out-dir
f700: 20 22 2f 2e 66 69 6e 61 6c 2d 73 74 61 74 75 73 "/.final-status
f710: 22 29 29 0a 20 20 20 29 0a 20 20 20 20 3b 3b 20 ")). ). ;;
f720: 66 69 72 73 74 20 76 65 72 69 66 79 20 77 65 20 first verify we
f730: 61 72 65 20 61 62 6c 65 20 74 6f 20 77 72 69 74 are able to writ
f740: 65 20 74 68 65 20 6f 75 74 70 75 74 20 66 69 6c e the output fil
f750: 65 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 e. (if (not (
f760: 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 73 file-write-acces
f770: 73 3f 20 6f 75 74 2d 64 69 72 29 29 0a 09 20 20 s? out-dir))..
f780: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
f790: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
f7a0: 72 74 2a 20 22 45 52 52 4f 52 3a 20 63 61 6e 6e rt* "ERROR: cann
f7b0: 6f 74 20 77 72 69 74 65 20 2e 66 69 6e 61 6c 2d ot write .final-
f7c0: 73 74 61 74 75 73 20 74 6f 20 22 20 6f 75 74 2d status to " out-
f7d0: 64 69 72 29 0a 09 20 20 20 20 28 6c 65 74 2a 20 dir).. (let*
f7e0: 0a 20 20 20 20 20 20 20 20 20 28 28 6f 75 74 70 . ((outp
f7f0: 20 20 20 20 20 20 28 6f 70 65 6e 2d 6f 75 74 70 (open-outp
f800: 75 74 2d 66 69 6c 65 20 73 74 61 74 75 73 2d 66 ut-file status-f
f810: 69 6c 65 29 29 0a 09 20 20 20 20 20 20 20 28 73 ile)).. (s
f820: 74 61 74 75 73 20 20 20 20 28 64 62 3a 74 65 73 tatus (db:tes
f830: 74 2d 67 65 74 2d 73 74 61 74 75 73 20 20 20 74 t-get-status t
f840: 65 73 74 2d 64 61 74 29 29 0a 20 20 20 20 20 20 est-dat)).
f850: 20 20 20 28 73 74 61 74 65 20 20 20 20 20 28 64 (state (d
f860: 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 b:test-get-state
f870: 20 20 20 20 74 65 73 74 2d 64 61 74 29 29 29 0a test-dat))).
f880: 20 20 20 20 20 20 20 20 28 66 70 72 69 6e 74 66 (fprintf
f890: 20 6f 75 74 70 20 22 7e 53 5c 6e 22 20 73 74 61 outp "~S\n" sta
f8a0: 74 65 29 20 0a 20 20 20 20 20 20 20 20 28 66 70 te) . (fp
f8b0: 72 69 6e 74 66 20 6f 75 74 70 20 22 7e 53 5c 6e rintf outp "~S\n
f8c0: 22 20 73 74 61 74 75 73 29 20 0a 20 20 20 20 20 " status) .
f8d0: 20 20 20 28 63 6c 6f 73 65 2d 6f 75 74 70 75 74 (close-output
f8e0: 2d 70 6f 72 74 20 6f 75 74 70 29 29 29 29 29 0a -port outp))))).
f8f0: 0a 0a 3b 3b 20 73 75 6d 6d 61 72 69 7a 65 20 74 ..;; summarize t
f900: 65 73 74 20 69 6e 20 74 6f 20 61 20 66 69 6c 65 est in to a file
f910: 20 74 65 73 74 2d 73 75 6d 6d 61 72 79 2e 68 74 test-summary.ht
f920: 6d 6c 20 69 6e 20 74 68 65 20 74 65 73 74 20 64 ml in the test d
f930: 69 72 65 63 74 6f 72 79 0a 3b 3b 0a 28 64 65 66 irectory.;;.(def
f940: 69 6e 65 20 28 74 65 73 74 73 3a 73 75 6d 6d 61 ine (tests:summa
f950: 72 69 7a 65 2d 74 65 73 74 20 72 75 6e 2d 69 64 rize-test run-id
f960: 20 74 65 73 74 2d 69 64 29 0a 20 20 28 6c 65 74 test-id). (let
f970: 2a 20 28 28 74 65 73 74 2d 64 61 74 20 20 28 72 * ((test-dat (r
f980: 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f mt:get-test-info
f990: 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 -by-id run-id te
f9a0: 73 74 2d 69 64 29 29 0a 09 20 28 6f 75 74 2d 64 st-id)).. (out-d
f9b0: 69 72 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 ir (db:test-ge
f9c0: 74 2d 72 75 6e 64 69 72 20 74 65 73 74 2d 64 61 t-rundir test-da
f9d0: 74 29 29 0a 09 20 28 6f 75 74 2d 66 69 6c 65 20 t)).. (out-file
f9e0: 20 28 63 6f 6e 63 20 6f 75 74 2d 64 69 72 20 22 (conc out-dir "
f9f0: 2f 74 65 73 74 2d 73 75 6d 6d 61 72 79 2e 68 74 /test-summary.ht
fa00: 6d 6c 22 29 29 29 0a 20 20 20 20 3b 3b 20 66 69 ml"))). ;; fi
fa10: 72 73 74 20 76 65 72 69 66 79 20 77 65 20 61 72 rst verify we ar
fa20: 65 20 61 62 6c 65 20 74 6f 20 77 72 69 74 65 20 e able to write
fa30: 74 68 65 20 6f 75 74 70 75 74 20 66 69 6c 65 0a the output file.
fa40: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 66 69 (if (not (fi
fa50: 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 73 73 3f le-write-access?
fa60: 20 6f 75 74 2d 64 69 72 29 29 0a 09 28 64 65 62 out-dir))..(deb
fa70: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
fa80: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 ult-log-port* "E
fa90: 52 52 4f 52 3a 20 63 61 6e 6e 6f 74 20 77 72 69 RROR: cannot wri
faa0: 74 65 20 74 65 73 74 2d 73 75 6d 6d 61 72 79 2e te test-summary.
fab0: 68 74 6d 6c 20 74 6f 20 22 20 6f 75 74 2d 64 69 html to " out-di
fac0: 72 29 0a 09 28 6c 65 74 2a 20 28 3b 3b 20 28 73 r)..(let* (;; (s
fad0: 74 65 70 73 2d 64 61 74 20 28 72 6d 74 3a 67 65 teps-dat (rmt:ge
fae0: 74 2d 73 74 65 70 73 2d 66 6f 72 2d 74 65 73 74 t-steps-for-test
faf0: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 run-id test-id)
fb00: 29 0a 09 20 20 20 20 20 20 20 28 74 65 73 74 2d ).. (test-
fb10: 6e 61 6d 65 20 28 64 62 3a 74 65 73 74 2d 67 65 name (db:test-ge
fb20: 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 2d t-testname test-
fb30: 64 61 74 29 29 0a 09 20 20 20 20 20 20 20 28 69 dat)).. (i
fb40: 74 65 6d 2d 70 61 74 68 20 28 64 62 3a 74 65 73 tem-path (db:tes
fb50: 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 t-get-item-path
fb60: 74 65 73 74 2d 64 61 74 29 29 0a 09 20 20 20 20 test-dat))..
fb70: 20 20 20 28 66 75 6c 6c 2d 6e 61 6d 65 20 28 64 (full-name (d
fb80: 62 3a 74 65 73 74 2d 6d 61 6b 65 2d 66 75 6c 6c b:test-make-full
fb90: 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 -name test-name
fba0: 69 74 65 6d 2d 70 61 74 68 29 29 0a 09 20 20 20 item-path))..
fbb0: 20 20 20 20 28 6f 75 70 20 20 20 20 20 20 20 28 (oup (
fbc0: 6f 70 65 6e 2d 6f 75 74 70 75 74 2d 66 69 6c 65 open-output-file
fbd0: 20 6f 75 74 2d 66 69 6c 65 29 29 0a 09 20 20 20 out-file))..
fbe0: 20 20 20 20 28 73 74 61 74 75 73 20 20 20 20 28 (status (
fbf0: 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 db:test-get-stat
fc00: 75 73 20 20 20 74 65 73 74 2d 64 61 74 29 29 0a us test-dat)).
fc10: 09 20 20 20 20 20 20 20 28 63 6f 6c 6f 72 20 20 . (color
fc20: 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 (common:get-c
fc30: 6f 6c 6f 72 2d 66 72 6f 6d 2d 73 74 61 74 75 73 olor-from-status
fc40: 20 73 74 61 74 75 73 29 29 0a 09 20 20 20 20 20 status))..
fc50: 20 20 28 6c 6f 67 66 20 20 20 20 20 20 28 64 62 (logf (db
fc60: 3a 74 65 73 74 2d 67 65 74 2d 66 69 6e 61 6c 5f :test-get-final_
fc70: 6c 6f 67 66 20 74 65 73 74 2d 64 61 74 29 29 0a logf test-dat)).
fc80: 09 20 20 20 20 20 20 20 28 73 74 65 70 73 2d 64 . (steps-d
fc90: 61 74 20 28 74 65 73 74 73 3a 67 65 74 2d 63 6f at (tests:get-co
fca0: 6d 70 72 65 73 73 65 64 2d 73 74 65 70 73 20 72 mpressed-steps r
fcb0: 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 29 29 un-id test-id)))
fcc0: 0a 09 20 20 3b 3b 20 28 64 63 6f 6d 6d 6f 6e 3a .. ;; (dcommon:
fcd0: 67 65 74 2d 63 6f 6d 70 72 65 73 73 65 64 2d 73 get-compressed-s
fce0: 74 65 70 73 20 23 66 20 31 20 33 30 30 34 35 29 teps #f 1 30045)
fcf0: 0a 09 20 20 3b 3b 20 28 23 28 22 77 61 73 74 69 .. ;; (#("wasti
fd00: 6e 67 5f 74 69 6d 65 22 20 22 32 33 3a 33 36 3a ng_time" "23:36:
fd10: 31 33 22 20 22 32 33 3a 33 36 3a 32 31 22 20 22 13" "23:36:21" "
fd20: 30 22 20 22 38 2e 30 73 22 20 22 77 61 73 74 69 0" "8.0s" "wasti
fd30: 6e 67 5f 74 69 6d 65 2e 6c 6f 67 22 29 29 0a 09 ng_time.log"))..
fd40: 0a 09 20 20 28 73 3a 6f 75 74 70 75 74 2d 6e 65 .. (s:output-ne
fd50: 77 0a 09 20 20 20 6f 75 70 0a 09 20 20 20 28 73 w.. oup.. (s
fd60: 3a 68 74 6d 6c 0a 09 20 20 20 20 28 73 3a 74 69 :html.. (s:ti
fd70: 74 6c 65 20 22 53 75 6d 6d 61 72 79 20 66 6f 72 tle "Summary for
fd80: 20 22 20 66 75 6c 6c 2d 6e 61 6d 65 29 0a 09 20 " full-name)..
fd90: 20 20 20 28 73 3a 62 6f 64 79 20 0a 09 20 20 20 (s:body ..
fda0: 20 20 28 73 3a 68 32 20 22 53 75 6d 6d 61 72 79 (s:h2 "Summary
fdb0: 20 66 6f 72 20 22 20 66 75 6c 6c 2d 6e 61 6d 65 for " full-name
fdc0: 29 0a 09 20 20 20 20 20 28 73 3a 74 61 62 6c 65 ).. (s:table
fdd0: 20 27 63 65 6c 6c 73 70 61 63 69 6e 67 20 22 30 'cellspacing "0
fde0: 22 20 27 62 6f 72 64 65 72 20 22 31 22 0a 09 09 " 'border "1"...
fdf0: 20 20 20 20 20 20 28 73 3a 74 72 20 28 73 3a 74 (s:tr (s:t
fe00: 64 20 22 72 75 6e 20 69 64 22 29 20 20 20 28 73 d "run id") (s
fe10: 3a 74 64 20 28 64 62 3a 74 65 73 74 2d 67 65 74 :td (db:test-get
fe20: 2d 72 75 6e 5f 69 64 20 20 20 74 65 73 74 2d 64 -run_id test-d
fe30: 61 74 29 29 0a 09 09 09 20 20 20 20 28 73 3a 74 at)).... (s:t
fe40: 64 20 22 74 65 73 74 20 69 64 22 29 20 20 28 73 d "test id") (s
fe50: 3a 74 64 20 28 64 62 3a 74 65 73 74 2d 67 65 74 :td (db:test-get
fe60: 2d 69 64 20 20 20 20 20 20 20 74 65 73 74 2d 64 -id test-d
fe70: 61 74 29 29 29 0a 09 09 20 20 20 20 20 20 28 73 at)))... (s
fe80: 3a 74 72 20 28 73 3a 74 64 20 22 74 65 73 74 6e :tr (s:td "testn
fe90: 61 6d 65 22 29 20 28 73 3a 74 64 20 74 65 73 74 ame") (s:td test
fea0: 2d 6e 61 6d 65 29 0a 09 09 09 20 20 20 20 28 73 -name).... (s
feb0: 3a 74 64 20 22 69 74 65 6d 70 61 74 68 22 29 20 :td "itempath")
fec0: 28 73 3a 74 64 20 69 74 65 6d 2d 70 61 74 68 29 (s:td item-path)
fed0: 29 0a 09 09 20 20 20 20 20 20 28 73 3a 74 72 20 )... (s:tr
fee0: 28 73 3a 74 64 20 22 73 74 61 74 65 22 29 20 20 (s:td "state")
fef0: 20 20 28 73 3a 74 64 20 28 64 62 3a 74 65 73 74 (s:td (db:test
ff00: 2d 67 65 74 2d 73 74 61 74 65 20 20 20 20 74 65 -get-state te
ff10: 73 74 2d 64 61 74 29 29 0a 09 09 09 20 20 20 20 st-dat))....
ff20: 28 73 3a 74 64 20 22 73 74 61 74 75 73 22 29 20 (s:td "status")
ff30: 20 20 28 73 3a 74 64 20 28 73 3a 61 20 27 68 72 (s:td (s:a 'hr
ff40: 65 66 20 6c 6f 67 66 20 28 73 3a 66 6f 6e 74 20 ef logf (s:font
ff50: 27 63 6f 6c 6f 72 20 63 6f 6c 6f 72 20 73 74 61 'color color sta
ff60: 74 75 73 29 29 29 29 0a 09 09 20 20 20 20 20 20 tus))))...
ff70: 28 73 3a 74 72 20 28 73 3a 74 64 20 22 54 65 73 (s:tr (s:td "Tes
ff80: 74 44 61 74 65 22 29 20 28 73 3a 74 64 20 28 73 tDate") (s:td (s
ff90: 65 63 6f 6e 64 73 2d 3e 77 6f 72 6b 2d 77 65 65 econds->work-wee
ffa0: 6b 2f 64 61 79 2d 74 69 6d 65 20 0a 09 09 09 09 k/day-time .....
ffb0: 09 09 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d .. (db:test-
ffc0: 67 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 74 get-event_time t
ffd0: 65 73 74 2d 64 61 74 29 29 29 0a 09 09 09 20 20 est-dat)))....
ffe0: 20 20 28 73 3a 74 64 20 22 44 75 72 61 74 69 6f (s:td "Duratio
fff0: 6e 22 29 20 28 73 3a 74 64 20 28 73 65 63 6f 6e n") (s:td (secon
10000 64 73 2d 3e 68 72 2d 6d 69 6e 2d 73 65 63 20 28 ds->hr-min-sec (
10010 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 5f db:test-get-run_
10020 64 75 72 61 74 69 6f 6e 20 74 65 73 74 2d 64 61 duration test-da
10030 74 29 29 29 29 29 0a 09 20 20 20 20 20 28 73 3a t))))).. (s:
10040 68 33 20 22 4c 6f 67 20 66 69 6c 65 73 22 29 0a h3 "Log files").
10050 09 20 20 20 20 20 28 73 3a 74 61 62 6c 65 20 0a . (s:table .
10060 09 20 20 20 20 20 20 27 63 65 6c 6c 73 70 61 63 . 'cellspac
10070 69 6e 67 20 22 30 22 20 27 62 6f 72 64 65 72 20 ing "0" 'border
10080 22 31 22 0a 09 20 20 20 20 20 20 28 73 3a 74 72 "1".. (s:tr
10090 20 28 73 3a 74 64 20 22 46 69 6e 61 6c 20 6c 6f (s:td "Final lo
100a0 67 22 29 28 73 3a 74 64 20 28 73 3a 61 20 27 68 g")(s:td (s:a 'h
100b0 72 65 66 20 6c 6f 67 66 20 6c 6f 67 66 29 29 29 ref logf logf)))
100c0 29 0a 09 20 20 20 20 20 28 73 3a 74 61 62 6c 65 ).. (s:table
100d0 0a 09 20 20 20 20 20 20 27 63 65 6c 6c 73 70 61 .. 'cellspa
100e0 63 69 6e 67 20 22 30 22 20 27 62 6f 72 64 65 72 cing "0" 'border
100f0 20 22 31 22 0a 09 20 20 20 20 20 20 28 73 3a 74 "1".. (s:t
10100 72 20 28 73 3a 74 64 20 22 53 74 65 70 20 4e 61 r (s:td "Step Na
10110 6d 65 22 29 28 73 3a 74 64 20 22 53 74 61 72 74 me")(s:td "Start
10120 22 29 28 73 3a 74 64 20 22 45 6e 64 22 29 28 73 ")(s:td "End")(s
10130 3a 74 64 20 22 53 74 61 74 75 73 22 29 28 73 3a :td "Status")(s:
10140 74 64 20 22 44 75 72 61 74 69 6f 6e 22 29 28 73 td "Duration")(s
10150 3a 74 64 20 22 4c 6f 67 20 46 69 6c 65 22 29 29 :td "Log File"))
10160 0a 09 20 20 20 20 20 20 28 6d 61 70 20 28 6c 61 .. (map (la
10170 6d 62 64 61 20 28 73 74 65 70 2d 64 61 74 29 0a mbda (step-dat).
10180 09 09 20 20 20 20 20 28 73 3a 74 72 20 28 73 3a .. (s:tr (s:
10190 74 64 20 28 74 64 62 3a 73 74 65 70 73 2d 74 61 td (tdb:steps-ta
101a0 62 6c 65 2d 67 65 74 2d 73 74 65 70 6e 61 6d 65 ble-get-stepname
101b0 20 73 74 65 70 2d 64 61 74 29 29 0a 09 09 09 20 step-dat))....
101c0 20 20 28 73 3a 74 64 20 28 74 64 62 3a 73 74 65 (s:td (tdb:ste
101d0 70 73 2d 74 61 62 6c 65 2d 67 65 74 2d 73 74 61 ps-table-get-sta
101e0 72 74 20 20 20 20 73 74 65 70 2d 64 61 74 29 29 rt step-dat))
101f0 0a 09 09 09 20 20 20 28 73 3a 74 64 20 28 74 64 .... (s:td (td
10200 62 3a 73 74 65 70 73 2d 74 61 62 6c 65 2d 67 65 b:steps-table-ge
10210 74 2d 65 6e 64 20 20 20 20 20 20 73 74 65 70 2d t-end step-
10220 64 61 74 29 29 0a 09 09 09 20 20 20 28 73 3a 74 dat)).... (s:t
10230 64 20 28 74 64 62 3a 73 74 65 70 73 2d 74 61 62 d (tdb:steps-tab
10240 6c 65 2d 67 65 74 2d 73 74 61 74 75 73 20 20 20 le-get-status
10250 73 74 65 70 2d 64 61 74 29 29 0a 09 09 09 20 20 step-dat))....
10260 20 28 73 3a 74 64 20 28 74 64 62 3a 73 74 65 70 (s:td (tdb:step
10270 73 2d 74 61 62 6c 65 2d 67 65 74 2d 72 75 6e 74 s-table-get-runt
10280 69 6d 65 20 20 73 74 65 70 2d 64 61 74 29 29 0a ime step-dat)).
10290 09 09 09 20 20 20 28 73 3a 74 64 20 28 6c 65 74 ... (s:td (let
102a0 20 28 28 73 74 65 70 2d 6c 6f 67 20 28 74 64 62 ((step-log (tdb
102b0 3a 73 74 65 70 73 2d 74 61 62 6c 65 2d 67 65 74 :steps-table-get
102c0 2d 6c 6f 67 2d 66 69 6c 65 20 73 74 65 70 2d 64 -log-file step-d
102d0 61 74 29 29 29 0a 09 09 09 09 20 20 20 28 73 3a at)))..... (s:
102e0 61 20 27 68 72 65 66 20 73 74 65 70 2d 6c 6f 67 a 'href step-log
102f0 20 73 74 65 70 2d 6c 6f 67 29 29 29 29 29 0a 09 step-log)))))..
10300 09 20 20 20 73 74 65 70 73 2d 64 61 74 29 29 0a . steps-dat)).
10310 09 20 20 20 20 20 29 29 29 0a 09 20 20 28 63 6c . ))).. (cl
10320 6f 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 ose-output-port
10330 6f 75 70 29 29 29 29 29 0a 09 20 20 0a 09 20 20 oup))))).. ..
10340 0a 3b 3b 20 4d 55 53 54 20 42 45 20 43 41 4c 4c .;; MUST BE CALL
10350 45 44 20 6c 6f 63 61 6c 21 0a 3b 3b 0a 28 64 65 ED local!.;;.(de
10360 66 69 6e 65 20 28 74 65 73 74 73 3a 74 65 73 74 fine (tests:test
10370 2d 67 65 74 2d 70 61 74 68 73 2d 6d 61 74 63 68 -get-paths-match
10380 69 6e 67 20 6b 65 79 6e 61 6d 65 73 20 74 61 72 ing keynames tar
10390 67 65 74 20 66 6e 61 6d 65 70 61 74 74 20 23 21 get fnamepatt #!
103a0 6b 65 79 20 28 72 65 73 20 27 28 29 29 29 0a 20 key (res '())).
103b0 20 3b 3b 20 42 55 47 3a 20 4d 6f 76 65 20 74 68 ;; BUG: Move th
103c0 65 20 76 61 6c 75 65 73 20 64 65 72 69 76 65 64 e values derived
103d0 20 66 72 6f 6d 20 61 72 67 73 20 74 6f 20 70 61 from args to pa
103e0 72 61 6d 65 74 65 72 73 20 61 6e 64 20 70 75 73 rameters and pus
103f0 68 20 74 6f 20 6d 65 67 61 74 65 73 74 2e 73 63 h to megatest.sc
10400 6d 0a 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 m. (let* ((test
10410 70 61 74 74 20 20 20 28 6f 72 20 28 61 72 67 73 patt (or (args
10420 3a 67 65 74 2d 61 72 67 20 22 2d 74 65 73 74 70 :get-arg "-testp
10430 61 74 74 22 29 28 61 72 67 73 3a 67 65 74 2d 61 att")(args:get-a
10440 72 67 20 22 2d 74 65 73 74 70 61 74 74 22 29 20 rg "-testpatt")
10450 22 25 22 29 29 0a 09 20 28 73 74 61 74 65 70 61 "%")).. (statepa
10460 74 74 20 20 28 6f 72 20 28 61 72 67 73 3a 67 65 tt (or (args:ge
10470 74 2d 61 72 67 20 22 2d 73 74 61 74 65 22 29 20 t-arg "-state")
10480 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 (args:get-arg
10490 22 3a 73 74 61 74 65 22 29 20 20 20 20 22 25 22 ":state") "%"
104a0 29 29 0a 09 20 28 73 74 61 74 75 73 70 61 74 74 )).. (statuspatt
104b0 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 (or (args:get-a
104c0 72 67 20 22 2d 73 74 61 74 75 73 22 29 20 20 28 rg "-status") (
104d0 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 3a 73 args:get-arg ":s
104e0 74 61 74 75 73 22 29 20 20 20 22 25 22 29 29 0a tatus") "%")).
104f0 09 20 28 72 75 6e 6e 61 6d 65 20 20 20 20 28 6f . (runname (o
10500 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 r (args:get-arg
10510 22 2d 72 75 6e 6e 61 6d 65 22 29 20 28 61 72 67 "-runname") (arg
10520 73 3a 67 65 74 2d 61 72 67 20 22 3a 72 75 6e 6e s:get-arg ":runn
10530 61 6d 65 22 29 20 20 22 25 22 29 29 0a 09 20 28 ame") "%")).. (
10540 70 61 74 68 73 2d 66 72 6f 6d 2d 64 62 20 28 72 paths-from-db (r
10550 6d 74 3a 74 65 73 74 2d 67 65 74 2d 70 61 74 68 mt:test-get-path
10560 73 2d 6d 61 74 63 68 69 6e 67 2d 6b 65 79 6e 61 s-matching-keyna
10570 6d 65 73 2d 74 61 72 67 65 74 2d 6e 65 77 20 6b mes-target-new k
10580 65 79 6e 61 6d 65 73 20 74 61 72 67 65 74 20 72 eynames target r
10590 65 73 0a 09 09 09 09 09 74 65 73 74 70 61 74 74 es......testpatt
105a0 0a 09 09 09 09 09 73 74 61 74 65 70 61 74 74 0a ......statepatt.
105b0 09 09 09 09 09 73 74 61 74 75 73 70 61 74 74 0a .....statuspatt.
105c0 09 09 09 09 09 72 75 6e 6e 61 6d 65 29 29 29 0a .....runname))).
105d0 20 20 20 20 28 69 66 20 66 6e 61 6d 65 70 61 74 (if fnamepat
105e0 74 0a 09 28 61 70 70 6c 79 20 61 70 70 65 6e 64 t..(apply append
105f0 20 0a 09 20 20 20 20 20 20 20 28 6d 61 70 20 28 .. (map (
10600 6c 61 6d 62 64 61 20 28 70 29 0a 09 09 20 20 20 lambda (p)...
10610 20 20 20 28 69 66 20 28 64 69 72 65 63 74 6f 72 (if (director
10620 79 2d 65 78 69 73 74 73 3f 20 70 29 0a 09 09 09 y-exists? p)....
10630 20 20 28 6c 65 74 20 28 28 67 6c 6f 62 2d 71 75 (let ((glob-qu
10640 65 72 79 20 28 63 6f 6e 63 20 70 20 22 2f 22 20 ery (conc p "/"
10650 66 6e 61 6d 65 70 61 74 74 29 29 29 0a 09 09 09 fnamepatt)))....
10660 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 (handle-exce
10670 70 74 69 6f 6e 73 0a 09 09 09 09 65 78 6e 0a 09 ptions.....exn..
10680 09 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 .. (begin..
10690 09 09 09 28 70 72 69 6e 74 20 22 62 75 69 6c 74 ...(print "built
106a0 2d 69 6e 20 67 6c 6f 62 20 6f 6e 20 22 20 67 6c -in glob on " gl
106b0 6f 62 2d 71 75 65 72 79 20 22 2c 20 66 61 69 6c ob-query ", fail
106c0 65 64 2c 20 74 72 79 20 75 73 69 6e 67 20 74 68 ed, try using th
106d0 65 20 73 68 65 6c 6c 2e 20 65 78 6e 3d 22 20 65 e shell. exn=" e
106e0 78 6e 29 0a 09 09 09 09 28 77 69 74 68 2d 69 6e xn).....(with-in
106f0 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 0a 09 09 put-from-pipe...
10700 09 09 20 28 63 6f 6e 63 20 22 65 63 68 6f 20 22 .. (conc "echo "
10710 20 67 6c 6f 62 2d 71 75 65 72 79 29 0a 09 09 09 glob-query)....
10720 09 20 72 65 61 64 2d 6c 69 6e 65 73 29 29 20 20 . read-lines))
10730 3b 3b 20 77 65 20 61 72 65 6e 27 74 20 67 6f 69 ;; we aren't goi
10740 6e 67 20 74 6f 20 74 72 79 20 74 6f 6f 20 68 61 ng to try too ha
10750 72 64 2e 20 49 66 20 67 6c 6f 62 20 62 72 65 61 rd. If glob brea
10760 6b 73 20 69 74 20 69 73 20 6c 69 6b 65 6c 79 20 ks it is likely
10770 62 65 63 61 75 73 65 20 73 6f 6d 65 6f 6e 65 20 because someone
10780 74 72 69 65 64 20 74 6f 20 64 6f 20 2a 2f 2a 2f tried to do */*/
10790 2a 2e 6c 6f 67 20 6f 72 20 73 69 6d 69 6c 61 72 *.log or similar
107a0 0a 09 09 09 20 20 20 20 20 20 28 67 6c 6f 62 20 .... (glob
107b0 67 6c 6f 62 2d 71 75 65 72 79 29 29 29 0a 09 09 glob-query)))...
107c0 09 20 20 27 28 29 29 29 0a 09 09 20 20 20 20 70 . '()))... p
107d0 61 74 68 73 2d 66 72 6f 6d 2d 64 62 29 29 0a 09 aths-from-db))..
107e0 70 61 74 68 73 2d 66 72 6f 6d 2d 64 62 29 29 29 paths-from-db)))
107f0 0a 0a 09 09 09 20 20 20 20 20 20 0a 3b 3b 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 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10820 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10830 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10840 3d 3d 3d 3d 0a 3b 3b 20 47 61 74 68 65 72 20 64 ====.;; Gather d
10850 61 74 61 20 66 72 6f 6d 20 74 65 73 74 2f 74 61 ata from test/ta
10860 73 6b 20 73 70 65 63 69 66 69 63 61 74 69 6f 6e sk specification
10870 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d s.;;============
10880 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10890 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
108a0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
108b0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 28 ==========..;; (
108c0 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 67 65 define (tests:ge
108d0 74 2d 76 61 6c 69 64 2d 74 65 73 74 73 20 74 65 t-valid-tests te
108e0 73 74 73 64 69 72 20 74 65 73 74 2d 70 61 74 74 stsdir test-patt
108f0 73 29 20 3b 3b 20 20 23 21 6b 65 79 20 28 74 65 s) ;; #!key (te
10900 73 74 2d 6e 61 6d 65 73 20 27 28 29 29 29 0a 3b st-names '())).;
10910 3b 20 20 20 28 6c 65 74 20 28 28 74 65 73 74 73 ; (let ((tests
10920 20 28 67 6c 6f 62 20 28 63 6f 6e 63 20 74 65 73 (glob (conc tes
10930 74 73 64 69 72 20 22 2f 74 65 73 74 73 2f 2a 22 tsdir "/tests/*"
10940 29 29 29 29 20 3b 3b 20 22 20 28 73 74 72 69 6e )))) ;; " (strin
10950 67 2d 74 72 61 6e 73 6c 61 74 65 20 70 61 74 74 g-translate patt
10960 20 22 25 22 20 22 2a 22 29 29 29 29 29 0a 3b 3b "%" "*"))))).;;
10970 20 20 20 20 20 28 73 65 74 21 20 74 65 73 74 73 (set! tests
10980 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 (filter (lambda
10990 20 28 74 65 73 74 29 28 63 6f 6d 6d 6f 6e 3a 66 (test)(common:f
109a0 69 6c 65 2d 65 78 69 73 74 73 3f 20 28 63 6f 6e ile-exists? (con
109b0 63 20 74 65 73 74 20 22 2f 74 65 73 74 63 6f 6e c test "/testcon
109c0 66 69 67 22 29 29 29 20 74 65 73 74 73 29 29 0a fig"))) tests)).
109d0 3b 3b 20 20 20 20 20 28 64 65 6c 65 74 65 2d 64 ;; (delete-d
109e0 75 70 6c 69 63 61 74 65 73 0a 3b 3b 20 20 20 20 uplicates.;;
109f0 20 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 (filter (lambd
10a00 61 20 28 74 65 73 74 6e 61 6d 65 29 0a 3b 3b 20 a (testname).;;
10a10 09 20 20 20 20 20 20 20 28 74 65 73 74 73 3a 6d . (tests:m
10a20 61 74 63 68 20 74 65 73 74 2d 70 61 74 74 73 20 atch test-patts
10a30 74 65 73 74 6e 61 6d 65 20 23 66 29 29 0a 3b 3b testname #f)).;;
10a40 20 09 20 20 20 20 20 28 6d 61 70 20 28 6c 61 6d . (map (lam
10a50 62 64 61 20 28 74 65 73 74 70 29 0a 3b 3b 20 09 bda (testp).;; .
10a60 09 20 20 20 20 28 6c 61 73 74 20 28 73 74 72 69 . (last (stri
10a70 6e 67 2d 73 70 6c 69 74 20 74 65 73 74 70 20 22 ng-split testp "
10a80 2f 22 29 29 29 0a 3b 3b 20 09 09 20 20 74 65 73 /"))).;; .. tes
10a90 74 73 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 ts)))))..(define
10aa0 20 28 74 65 73 74 73 3a 67 65 74 2d 74 65 73 74 (tests:get-test
10ab0 2d 70 61 74 68 2d 66 72 6f 6d 2d 65 6e 76 69 72 -path-from-envir
10ac0 6f 6e 6d 65 6e 74 29 0a 20 20 28 69 66 20 28 61 onment). (if (a
10ad0 6e 64 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 4c nd (getenv "MT_L
10ae0 49 4e 4b 54 52 45 45 22 29 0a 09 20 20 20 28 67 INKTREE").. (g
10af0 65 74 65 6e 76 20 22 4d 54 5f 54 41 52 47 45 54 etenv "MT_TARGET
10b00 22 29 0a 09 20 20 20 28 67 65 74 65 6e 76 20 22 ").. (getenv "
10b10 4d 54 5f 52 55 4e 4e 41 4d 45 22 29 0a 09 20 20 MT_RUNNAME")..
10b20 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 54 45 53 (getenv "MT_TES
10b30 54 5f 4e 41 4d 45 22 29 0a 09 20 20 20 28 67 65 T_NAME").. (ge
10b40 74 65 6e 76 20 22 4d 54 5f 49 54 45 4d 50 41 54 tenv "MT_ITEMPAT
10b50 48 22 29 29 0a 20 20 20 20 20 20 28 63 6f 6e 63 H")). (conc
10b60 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 4c 49 4e (getenv "MT_LIN
10b70 4b 54 52 45 45 22 29 20 20 22 2f 22 0a 09 20 20 KTREE") "/"..
10b80 20 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 54 41 (getenv "MT_TA
10b90 52 47 45 54 22 29 20 20 20 20 22 2f 22 0a 09 20 RGET") "/"..
10ba0 20 20 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 52 (getenv "MT_R
10bb0 55 4e 4e 41 4d 45 22 29 20 20 20 22 2f 22 0a 09 UNNAME") "/"..
10bc0 20 20 20 20 28 67 65 74 65 6e 76 20 22 4d 54 5f (getenv "MT_
10bd0 54 45 53 54 5f 4e 41 4d 45 22 29 0a 09 20 20 20 TEST_NAME")..
10be0 20 28 69 66 20 28 61 6e 64 20 28 67 65 74 65 6e (if (and (geten
10bf0 76 20 22 4d 54 5f 49 54 45 4d 50 41 54 48 22 29 v "MT_ITEMPATH")
10c00 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
10c10 20 20 20 20 20 20 28 6e 6f 74 20 28 73 74 72 69 (not (stri
10c20 6e 67 3d 3f 20 22 22 20 28 67 65 74 65 6e 76 20 ng=? "" (getenv
10c30 22 4d 54 5f 49 54 45 4d 50 41 54 48 22 29 29 29 "MT_ITEMPATH")))
10c40 29 0a 09 09 28 63 6f 6e 63 20 22 2f 22 20 28 67 )...(conc "/" (g
10c50 65 74 65 6e 76 20 22 4d 54 5f 49 54 45 4d 50 41 etenv "MT_ITEMPA
10c60 54 48 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 TH")).
10c70 20 20 20 20 20 20 22 22 29 29 0a 20 20 20 20 20 "")).
10c80 20 23 66 29 29 0a 0a 3b 3b 20 69 66 20 2e 74 65 #f))..;; if .te
10c90 73 74 63 6f 6e 66 69 67 20 65 78 69 73 74 73 20 stconfig exists
10ca0 69 6e 20 74 65 73 74 20 64 69 72 65 63 74 6f 72 in test director
10cb0 79 20 72 65 61 64 20 61 6e 64 20 72 65 74 75 72 y read and retur
10cc0 6e 20 69 74 0a 3b 3b 20 65 6c 73 65 20 69 66 20 n it.;; else if
10cd0 68 61 76 65 20 63 61 63 68 65 64 20 63 6f 70 79 have cached copy
10ce0 20 69 6e 20 2a 74 65 73 74 63 6f 6e 66 69 67 73 in *testconfigs
10cf0 2a 20 72 65 74 75 72 6e 20 69 74 20 49 46 46 20 * return it IFF
10d00 74 68 65 72 65 20 69 73 20 61 20 73 65 63 74 69 there is a secti
10d10 6f 6e 20 22 68 61 76 65 20 66 75 6c 6c 64 61 74 on "have fulldat
10d20 61 22 0a 3b 3b 20 65 6c 73 65 20 72 65 61 64 20 a".;; else read
10d30 74 68 65 20 74 65 73 74 63 6f 6e 66 69 67 20 66 the testconfig f
10d40 69 6c 65 0a 3b 3b 20 20 20 69 66 20 68 61 76 65 ile.;; if have
10d50 20 70 61 74 68 20 74 6f 20 74 65 73 74 20 64 69 path to test di
10d60 72 65 63 74 6f 72 79 20 73 61 76 65 20 74 68 65 rectory save the
10d70 20 63 6f 6e 66 69 67 20 61 73 20 2e 74 65 73 74 config as .test
10d80 63 6f 6e 66 69 67 20 61 6e 64 20 72 65 74 75 72 config and retur
10d90 6e 20 69 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 n it.;;.(define
10da0 28 74 65 73 74 73 3a 67 65 74 2d 74 65 73 74 63 (tests:get-testc
10db0 6f 6e 66 69 67 20 74 65 73 74 2d 6e 61 6d 65 20 onfig test-name
10dc0 69 74 65 6d 2d 70 61 74 68 20 74 65 73 74 2d 72 item-path test-r
10dd0 65 67 69 73 74 72 79 20 73 79 73 74 65 6d 2d 61 egistry system-a
10de0 6c 6c 6f 77 65 64 20 23 21 6b 65 79 20 28 66 6f llowed #!key (fo
10df0 72 63 65 2d 63 72 65 61 74 65 20 23 66 29 28 61 rce-create #f)(a
10e00 6c 6c 6f 77 2d 77 72 69 74 65 2d 63 61 63 68 65 llow-write-cache
10e10 20 23 74 29 28 77 61 69 74 2d 61 2d 6d 69 6e 75 #t)(wait-a-minu
10e20 74 65 20 23 66 29 29 0a 20 20 28 6c 65 74 2a 20 te #f)). (let*
10e30 28 28 75 73 65 2d 63 61 63 68 65 20 20 20 20 28 ((use-cache (
10e40 63 6f 6d 6d 6f 6e 3a 75 73 65 2d 63 61 63 68 65 common:use-cache
10e50 3f 29 29 0a 09 20 28 63 61 63 68 65 2d 70 61 74 ?)).. (cache-pat
10e60 68 20 20 20 28 74 65 73 74 73 3a 67 65 74 2d 74 h (tests:get-t
10e70 65 73 74 2d 70 61 74 68 2d 66 72 6f 6d 2d 65 6e est-path-from-en
10e80 76 69 72 6f 6e 6d 65 6e 74 29 29 0a 09 20 28 63 vironment)).. (c
10e90 61 63 68 65 2d 66 69 6c 65 20 20 20 28 61 6e 64 ache-file (and
10ea0 20 63 61 63 68 65 2d 70 61 74 68 20 28 63 6f 6e cache-path (con
10eb0 63 20 63 61 63 68 65 2d 70 61 74 68 20 22 2f 2e c cache-path "/.
10ec0 74 65 73 74 63 6f 6e 66 69 67 22 29 29 29 0a 09 testconfig")))..
10ed0 20 28 63 61 63 68 65 2d 65 78 69 73 74 73 20 28 (cache-exists (
10ee0 61 6e 64 20 63 61 63 68 65 2d 66 69 6c 65 0a 09 and cache-file..
10ef0 09 09 20 20 20 20 28 6e 6f 74 20 66 6f 72 63 65 .. (not force
10f00 2d 63 72 65 61 74 65 29 20 20 3b 3b 20 69 66 20 -create) ;; if
10f10 66 6f 72 63 65 2d 63 72 65 61 74 65 20 74 68 65 force-create the
10f20 6e 20 70 72 65 74 65 6e 64 20 74 68 65 72 65 20 n pretend there
10f30 69 73 20 6e 6f 20 63 61 63 68 65 20 74 6f 20 72 is no cache to r
10f40 65 61 64 0a 09 09 09 20 20 20 20 28 63 6f 6d 6d ead.... (comm
10f50 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 on:file-exists?
10f60 63 61 63 68 65 2d 66 69 6c 65 29 29 29 0a 09 20 cache-file)))..
10f70 28 63 61 63 68 65 64 2d 64 61 74 20 20 20 28 69 (cached-dat (i
10f80 66 20 28 61 6e 64 20 28 6e 6f 74 20 66 6f 72 63 f (and (not forc
10f90 65 2d 63 72 65 61 74 65 29 0a 09 09 09 09 63 61 e-create).....ca
10fa0 63 68 65 2d 65 78 69 73 74 73 0a 09 09 09 09 75 che-exists.....u
10fb0 73 65 2d 63 61 63 68 65 29 0a 09 09 09 20 20 20 se-cache)....
10fc0 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f (handle-exceptio
10fd0 6e 73 0a 09 09 09 20 20 20 20 20 20 20 65 78 6e ns.... exn
10fe0 0a 09 09 09 20 20 20 20 20 28 62 65 67 69 6e 0a .... (begin.
10ff0 09 09 09 20 20 20 20 20 20 20 28 64 65 62 75 67 ... (debug
11000 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
11010 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 66 61 69 t-log-port* "fai
11020 6c 65 64 20 74 6f 20 72 65 61 64 20 22 20 63 61 led to read " ca
11030 63 68 65 2d 66 69 6c 65 20 22 2c 20 65 78 6e 3d che-file ", exn=
11040 22 20 65 78 6e 29 0a 09 09 09 20 20 20 20 20 20 " exn)....
11050 20 23 66 29 20 3b 3b 20 61 6e 79 20 69 73 73 75 #f) ;; any issu
11060 65 73 2c 20 6a 75 73 74 20 67 69 76 65 20 75 70 es, just give up
11070 20 77 69 74 68 20 74 68 65 20 63 61 63 68 65 64 with the cached
11080 20 76 65 72 73 69 6f 6e 20 61 6e 64 20 72 65 2d version and re-
11090 72 65 61 64 0a 09 09 09 20 20 20 20 20 28 63 6f read.... (co
110a0 6e 66 69 67 66 3a 72 65 61 64 2d 61 6c 69 73 74 nfigf:read-alist
110b0 20 63 61 63 68 65 2d 66 69 6c 65 29 29 0a 09 09 cache-file))...
110c0 09 20 20 20 23 66 29 29 0a 20 20 20 20 20 20 20 . #f)).
110d0 20 20 28 74 65 73 74 2d 66 75 6c 6c 2d 6e 61 6d (test-full-nam
110e0 65 20 28 69 66 20 28 61 6e 64 20 69 74 65 6d 2d e (if (and item-
110f0 70 61 74 68 20 28 6e 6f 74 20 28 73 74 72 69 6e path (not (strin
11100 67 2d 6e 75 6c 6c 3f 20 69 74 65 6d 2d 70 61 74 g-null? item-pat
11110 68 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 h))).
11120 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11130 20 20 28 63 6f 6e 63 20 74 65 73 74 2d 6e 61 6d (conc test-nam
11140 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 e "/" item-path)
11150 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
11160 20 20 20 20 20 20 20 20 20 20 20 20 20 20 74 65 te
11170 73 74 2d 6e 61 6d 65 29 29 29 0a 20 20 20 20 28 st-name))). (
11180 69 66 20 63 61 63 68 65 64 2d 64 61 74 0a 09 63 if cached-dat..c
11190 61 63 68 65 64 2d 64 61 74 0a 09 28 6c 65 74 20 ached-dat..(let
111a0 28 28 64 61 74 20 28 68 61 73 68 2d 74 61 62 6c ((dat (hash-tabl
111b0 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 74 e-ref/default *t
111c0 65 73 74 63 6f 6e 66 69 67 73 2a 20 74 65 73 74 estconfigs* test
111d0 2d 66 75 6c 6c 2d 6e 61 6d 65 20 23 66 29 29 29 -full-name #f)))
111e0 0a 09 20 20 28 69 66 20 28 61 6e 64 20 20 64 61 .. (if (and da
111f0 74 20 3b 3b 20 68 61 76 65 20 61 20 6c 6f 63 61 t ;; have a loca
11200 6c 6c 79 20 63 61 63 68 65 64 20 76 65 72 73 69 lly cached versi
11210 6f 6e 0a 09 09 20 20 20 20 28 68 61 73 68 2d 74 on... (hash-t
11220 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
11230 20 64 61 74 20 22 68 61 76 65 20 66 75 6c 6c 64 dat "have fulld
11240 61 74 61 22 20 23 66 29 29 20 3b 3b 20 6d 61 72 ata" #f)) ;; mar
11250 6b 65 64 20 61 73 20 67 6f 6f 64 20 64 61 74 61 ked as good data
11260 3f 0a 09 20 20 20 20 20 20 64 61 74 0a 09 20 20 ?.. dat..
11270 20 20 20 20 3b 3b 20 6e 6f 20 63 61 63 68 65 64 ;; no cached
11280 20 64 61 74 61 20 61 76 61 69 6c 61 62 6c 65 0a data available.
11290 09 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 . (let* ((t
112a0 72 65 67 20 20 20 20 20 20 20 20 20 28 6f 72 20 reg (or
112b0 74 65 73 74 2d 72 65 67 69 73 74 72 79 0a 09 09 test-registry...
112c0 09 09 20 20 20 20 20 20 20 28 74 65 73 74 73 3a .. (tests:
112d0 67 65 74 2d 61 6c 6c 29 29 29 0a 09 09 20 20 20 get-all)))...
112e0 20 20 28 74 65 73 74 2d 70 61 74 68 20 20 20 20 (test-path
112f0 28 6f 72 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (or (hash-table-
11300 72 65 66 2f 64 65 66 61 75 6c 74 20 74 72 65 67 ref/default treg
11310 20 74 65 73 74 2d 6e 61 6d 65 20 23 66 29 0a 20 test-name #f).
11320 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11330 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11340 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 6c 6f (let* ((lo
11350 63 61 6c 2d 74 63 64 69 72 20 28 63 6f 6e 63 20 cal-tcdir (conc
11360 28 67 65 74 65 6e 76 20 22 4d 54 5f 4c 49 4e 4b (getenv "MT_LINK
11370 54 52 45 45 22 29 20 22 2f 22 0a 20 20 20 20 20 TREE") "/".
11380 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11390 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
113a0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
113b0 20 20 20 20 20 20 20 20 20 20 20 20 28 67 65 74 (get
113c0 65 6e 76 20 22 4d 54 5f 54 41 52 47 45 54 22 29 env "MT_TARGET")
113d0 20 22 2f 22 0a 20 20 20 20 20 20 20 20 20 20 20 "/".
113e0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
113f0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11400 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11410 20 20 20 20 20 20 28 67 65 74 65 6e 76 20 22 4d (getenv "M
11420 54 5f 52 55 4e 4e 41 4d 45 22 29 20 22 2f 22 0a T_RUNNAME") "/".
11430 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11440 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11450 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11460 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11470 20 74 65 73 74 2d 6e 61 6d 65 20 22 2f 22 20 69 test-name "/" i
11480 74 65 6d 2d 70 61 74 68 29 29 0a 20 20 20 20 20 tem-path)).
11490 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
114a0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
114b0 20 20 20 20 20 20 20 20 20 28 6c 6f 63 61 6c 2d (local-
114c0 74 63 66 67 20 28 63 6f 6e 63 20 6c 6f 63 61 6c tcfg (conc local
114d0 2d 74 63 64 69 72 20 22 2f 74 65 73 74 63 6f 6e -tcdir "/testcon
114e0 66 69 67 22 29 29 29 0a 20 20 20 20 20 20 20 20 fig"))).
114f0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11500 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11510 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c (if (common:fil
11520 65 2d 65 78 69 73 74 73 3f 20 6c 6f 63 61 6c 2d e-exists? local-
11530 74 63 66 67 29 0a 20 20 20 20 20 20 20 20 20 20 tcfg).
11540 20 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 6c 6f 63 61 6c 2d 74 63 64 69 72 0a 20 local-tcdir.
11570 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11580 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11590 20 20 20 20 20 20 20 20 20 20 20 20 23 66 29 29 #f))
115a0 0a 09 09 09 09 20 20 20 20 20 20 20 28 63 6f 6e ..... (con
115b0 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 74 65 c *toppath* "/te
115c0 73 74 73 2f 22 20 74 65 73 74 2d 6e 61 6d 65 29 sts/" test-name)
115d0 29 29 0a 09 09 20 20 20 20 20 28 74 65 73 74 2d ))... (test-
115e0 63 6f 6e 66 69 67 66 20 28 63 6f 6e 63 20 74 65 configf (conc te
115f0 73 74 2d 70 61 74 68 20 22 2f 74 65 73 74 63 6f st-path "/testco
11600 6e 66 69 67 22 29 29 0a 09 09 20 20 20 20 20 28 nfig"))... (
11610 74 65 73 74 65 78 69 73 74 73 20 20 20 28 6c 65 testexists (le
11620 74 20 6c 6f 6f 70 61 20 28 28 74 72 69 65 73 2d t loopa ((tries-
11630 6c 65 66 74 20 33 30 29 29 0a 20 20 20 20 20 20 left 30)).
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 20 20 28 (
11660 63 6f 6e 64 0a 20 20 20 20 20 20 20 20 20 20 20 cond.
11670 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11680 20 20 20 20 20 20 20 20 20 20 20 28 0a 20 20 20 (.
11690 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
116a0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
116b0 20 20 20 20 28 61 6e 64 20 28 63 6f 6d 6d 6f 6e (and (common
116c0 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 74 65 :file-exists? te
116d0 73 74 2d 63 6f 6e 66 69 67 66 29 28 66 69 6c 65 st-configf)(file
116e0 2d 72 65 61 64 2d 61 63 63 65 73 73 3f 20 74 65 -read-access? te
116f0 73 74 2d 63 6f 6e 66 69 67 66 29 29 0a 20 20 20 st-configf)).
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 20 20 20 20 23 74 29 0a 20 20 20 20 20 20 20 20 #t).
11730 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11740 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 0a (.
11750 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11760 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11770 20 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 66 (common:f
11780 69 6c 65 2d 65 78 69 73 74 73 3f 20 74 65 73 74 ile-exists? test
11790 2d 63 6f 6e 66 69 67 66 29 0a 20 20 20 20 20 20 -configf).
117a0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
117b0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
117c0 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
117d0 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
117e0 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 43 61 6e t* "WARNING: Can
117f0 6e 6f 74 20 72 65 61 64 20 74 65 73 74 63 6f 6e not read testcon
11800 66 69 67 20 66 69 6c 65 3a 20 22 74 65 73 74 2d fig file: "test-
11810 63 6f 6e 66 69 67 66 29 0a 20 20 20 20 20 20 20 configf).
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 20 20 20 20
11840 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 #f).
11850 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11860 20 20 20 20 20 20 20 20 20 20 28 0a 20 20 20 20 (.
11870 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11880 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11890 20 20 20 28 61 6e 64 20 77 61 69 74 2d 61 2d 6d (and wait-a-m
118a0 69 6e 75 74 65 20 28 3e 20 74 72 69 65 73 2d 6c inute (> tries-l
118b0 65 66 74 20 30 29 29 0a 20 20 20 20 20 20 20 20 eft 0)).
118c0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
118d0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
118e0 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 30 thread-sleep! 10
118f0 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
11900 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11910 20 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a (debug:
11920 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
11930 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e -log-port* "WARN
11940 49 4e 47 3a 20 74 65 73 74 63 6f 6e 66 69 67 20 ING: testconfig
11950 66 69 6c 65 20 64 6f 65 73 20 6e 6f 74 20 65 78 file does not ex
11960 69 73 74 3a 20 22 74 65 73 74 2d 63 6f 6e 66 69 ist: "test-confi
11970 67 66 22 20 77 69 6c 6c 20 72 65 74 72 79 20 69 gf" will retry i
11980 6e 20 31 30 20 73 65 63 6f 6e 64 73 2e 20 20 54 n 10 seconds. T
11990 72 69 65 73 20 6c 65 66 74 3a 20 22 74 72 69 65 ries left: "trie
119a0 73 2d 6c 65 66 74 29 20 3b 3b 20 42 42 3a 20 74 s-left) ;; BB: t
119b0 68 69 73 20 66 69 72 65 73 0a 20 20 20 20 20 20 his fires.
119c0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
119d0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
119e0 20 28 6c 6f 6f 70 61 20 28 73 75 62 31 20 74 72 (loopa (sub1 tr
119f0 69 65 73 2d 6c 65 66 74 29 29 29 0a 20 20 20 20 ies-left))).
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 20 28 65 6c 73 65 0a 20 20 20 20 20 20 20 20 (else.
11a30 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11a40 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
11a50 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 2a 64 debug:print 2 *d
11a60 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
11a70 20 22 57 41 52 4e 49 4e 47 3a 20 74 65 73 74 63 "WARNING: testc
11a80 6f 6e 66 69 67 20 66 69 6c 65 20 64 6f 65 73 20 onfig file does
11a90 6e 6f 74 20 65 78 69 73 74 3a 20 22 74 65 73 74 not exist: "test
11aa0 2d 63 6f 6e 66 69 67 66 29 20 3b 3b 20 42 42 3a -configf) ;; BB:
11ab0 20 74 68 69 73 20 66 69 72 65 73 0a 20 20 20 20 this fires.
11ac0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11ad0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11ae0 20 20 20 23 66 29 29 29 29 0a 09 09 20 20 20 20 #f))))...
11af0 20 28 74 63 66 67 20 20 20 20 20 20 20 20 20 28 (tcfg (
11b00 69 66 20 74 65 73 74 65 78 69 73 74 73 0a 09 09 if testexists...
11b10 09 09 20 20 20 20 20 20 20 28 72 65 61 64 2d 63 .. (read-c
11b20 6f 6e 66 69 67 20 74 65 73 74 2d 63 6f 6e 66 69 onfig test-confi
11b30 67 66 20 23 66 20 73 79 73 74 65 6d 2d 61 6c 6c gf #f system-all
11b40 6f 77 65 64 0a 09 09 09 09 09 09 20 20 20 20 65 owed....... e
11b50 6e 76 69 72 6f 6e 2d 70 61 74 74 3a 20 28 69 66 nviron-patt: (if
11b60 20 73 79 73 74 65 6d 2d 61 6c 6c 6f 77 65 64 0a system-allowed.
11b70 09 09 09 09 09 09 09 09 20 20 20 20 20 20 22 70 ........ "p
11b80 72 65 2d 6c 61 75 6e 63 68 2d 65 6e 76 2d 76 61 re-launch-env-va
11b90 72 73 22 0a 09 09 09 09 09 09 09 09 20 20 20 20 rs".........
11ba0 20 20 23 66 29 29 0a 09 09 09 09 20 20 20 20 20 #f)).....
11bb0 20 20 23 66 29 29 29 0a 09 09 28 69 66 20 28 61 #f)))...(if (a
11bc0 6e 64 20 74 63 66 67 20 63 61 63 68 65 2d 66 69 nd tcfg cache-fi
11bd0 6c 65 29 20 28 68 61 73 68 2d 74 61 62 6c 65 2d le) (hash-table-
11be0 73 65 74 21 20 74 63 66 67 20 22 68 61 76 65 20 set! tcfg "have
11bf0 66 75 6c 6c 64 61 74 61 22 20 23 74 29 29 20 3b fulldata" #t)) ;
11c00 3b 20 6d 61 72 6b 20 74 68 69 73 20 61 73 20 66 ; mark this as f
11c10 75 6c 6c 79 20 72 65 61 64 20 64 61 74 61 0a 09 ully read data..
11c20 09 28 69 66 20 74 63 66 67 20 28 68 61 73 68 2d .(if tcfg (hash-
11c30 74 61 62 6c 65 2d 73 65 74 21 20 2a 74 65 73 74 table-set! *test
11c40 63 6f 6e 66 69 67 73 2a 20 74 65 73 74 2d 66 75 configs* test-fu
11c50 6c 6c 2d 6e 61 6d 65 20 74 63 66 67 29 29 0a 09 ll-name tcfg))..
11c60 09 28 69 66 20 28 61 6e 64 20 74 65 73 74 65 78 .(if (and testex
11c70 69 73 74 73 0a 09 09 09 20 63 61 63 68 65 2d 66 ists.... cache-f
11c80 69 6c 65 0a 09 09 09 20 28 66 69 6c 65 2d 77 72 ile.... (file-wr
11c90 69 74 65 2d 61 63 63 65 73 73 3f 20 63 61 63 68 ite-access? cach
11ca0 65 2d 70 61 74 68 29 0a 09 09 09 20 61 6c 6c 6f e-path).... allo
11cb0 77 2d 77 72 69 74 65 2d 63 61 63 68 65 29 0a 09 w-write-cache)..
11cc0 09 20 20 20 20 28 6c 65 74 20 28 28 74 70 61 74 . (let ((tpat
11cd0 68 20 28 63 6f 6e 63 20 63 61 63 68 65 2d 70 61 h (conc cache-pa
11ce0 74 68 20 22 2f 2e 74 65 73 74 63 6f 6e 66 69 67 th "/.testconfig
11cf0 22 29 29 29 0a 09 09 20 20 20 20 20 20 28 64 65 ")))... (de
11d00 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 bug:print-info 1
11d10 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
11d20 72 74 2a 20 22 43 61 63 68 69 6e 67 20 74 65 73 rt* "Caching tes
11d30 74 63 6f 6e 66 69 67 20 66 6f 72 20 22 20 74 65 tconfig for " te
11d40 73 74 2d 6e 61 6d 65 20 22 20 69 6e 20 22 20 74 st-name " in " t
11d50 70 61 74 68 29 0a 20 20 20 20 20 20 20 20 20 20 path).
11d60 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
11d70 28 61 6e 64 20 74 63 66 67 20 28 6e 6f 74 20 28 (and tcfg (not (
11d80 63 6f 6d 6d 6f 6e 3a 69 6e 2d 72 75 6e 6e 69 6e common:in-runnin
11d90 67 2d 74 65 73 74 3f 29 29 29 0a 20 20 20 20 20 g-test?))).
11da0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11db0 20 20 20 20 20 28 63 6f 6e 66 69 67 66 3a 77 72 (configf:wr
11dc0 69 74 65 2d 61 6c 69 73 74 20 74 63 66 67 20 74 ite-alist tcfg t
11dd0 70 61 74 68 29 29 29 29 0a 09 09 74 63 66 67 29 path))))...tcfg)
11de0 29 29 29 29 29 0a 20 20 0a 3b 3b 20 73 6f 72 74 ))))). .;; sort
11df0 20 74 65 73 74 73 20 62 79 20 70 72 69 6f 72 69 tests by priori
11e00 74 79 20 61 6e 64 20 77 61 69 74 6f 6e 0a 3b 3b ty and waiton.;;
11e10 20 4d 6f 76 65 20 74 65 73 74 20 73 70 65 63 69 Move test speci
11e20 66 69 63 20 73 74 75 66 66 20 74 6f 20 61 20 74 fic stuff to a t
11e30 65 73 74 20 75 6e 69 74 20 46 49 58 4d 45 20 6f est unit FIXME o
11e40 6e 65 20 6f 66 20 74 68 65 73 65 20 64 61 79 73 ne of these days
11e50 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a .(define (tests:
11e60 73 6f 72 74 2d 62 79 2d 70 72 69 6f 72 69 74 79 sort-by-priority
11e70 2d 61 6e 64 2d 77 61 69 74 6f 6e 20 74 65 73 74 -and-waiton test
11e80 2d 72 65 63 6f 72 64 73 29 0a 20 20 28 69 66 20 -records). (if
11e90 28 65 71 3f 20 28 68 61 73 68 2d 74 61 62 6c 65 (eq? (hash-table
11ea0 2d 73 69 7a 65 20 74 65 73 74 2d 72 65 63 6f 72 -size test-recor
11eb0 64 73 29 20 30 29 0a 20 20 20 20 20 20 27 28 29 ds) 0). '()
11ec0 0a 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 6d . (let* ((m
11ed0 75 6e 67 65 70 72 69 6f 72 69 74 79 20 28 6c 61 ungepriority (la
11ee0 6d 62 64 61 20 28 70 72 69 6f 72 69 74 79 29 0a mbda (priority).
11ef0 09 09 09 20 20 20 20 20 20 28 69 66 20 70 72 69 ... (if pri
11f00 6f 72 69 74 79 0a 09 09 09 09 20 20 28 6c 65 74 ority..... (let
11f10 20 28 28 74 6d 70 20 28 61 6e 79 2d 3e 6e 75 6d ((tmp (any->num
11f20 62 65 72 20 70 72 69 6f 72 69 74 79 29 29 29 0a ber priority))).
11f30 09 09 09 09 20 20 20 20 28 69 66 20 74 6d 70 20 .... (if tmp
11f40 74 6d 70 20 28 62 65 67 69 6e 20 28 64 65 62 75 tmp (begin (debu
11f50 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 g:print-error 0
11f60 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
11f70 74 2a 20 22 62 61 64 20 70 72 69 6f 72 69 74 79 t* "bad priority
11f80 20 76 61 6c 75 65 20 22 20 70 72 69 6f 72 69 74 value " priorit
11f90 79 20 22 2c 20 75 73 69 6e 67 20 30 22 29 20 30 y ", using 0") 0
11fa0 29 29 29 0a 09 09 09 09 20 20 30 29 29 29 0a 09 )))..... 0)))..
11fb0 20 20 20 20 20 28 61 6c 6c 2d 74 65 73 74 73 20 (all-tests
11fc0 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
11fd0 2d 6b 65 79 73 20 74 65 73 74 2d 72 65 63 6f 72 -keys test-recor
11fe0 64 73 29 29 0a 09 20 20 20 20 20 28 61 6c 6c 2d ds)).. (all-
11ff0 77 61 69 74 65 64 2d 6f 6e 20 20 28 6c 65 74 20 waited-on (let
12000 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 61 72 20 loop ((hed (car
12010 61 6c 6c 2d 74 65 73 74 73 29 29 0a 09 09 09 09 all-tests)).....
12020 09 28 74 61 6c 20 28 63 64 72 20 61 6c 6c 2d 74 .(tal (cdr all-t
12030 65 73 74 73 29 29 0a 09 09 09 09 09 28 72 65 73 ests))......(res
12040 20 27 28 29 29 29 0a 09 09 09 20 20 20 20 20 20 '()))....
12050 20 28 6c 65 74 2a 20 28 28 74 72 65 63 20 20 20 (let* ((trec
12060 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
12070 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 68 65 test-records he
12080 64 29 29 0a 09 09 09 09 20 20 20 20 20 20 28 77 d))..... (w
12090 61 69 74 6f 6e 73 20 28 6f 72 20 28 74 65 73 74 aitons (or (test
120a0 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d s:testqueue-get-
120b0 77 61 69 74 6f 6e 73 20 74 72 65 63 29 20 27 28 waitons trec) '(
120c0 29 29 29 29 0a 09 09 09 09 20 28 69 66 20 28 6e ))))..... (if (n
120d0 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 09 09 20 20 ull? tal).....
120e0 20 20 20 28 61 70 70 65 6e 64 20 72 65 73 20 77 (append res w
120f0 61 69 74 6f 6e 73 29 0a 09 09 09 09 20 20 20 20 aitons).....
12100 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 (loop (car tal)
12110 28 63 64 72 20 74 61 6c 29 28 61 70 70 65 6e 64 (cdr tal)(append
12120 20 72 65 73 20 77 61 69 74 6f 6e 73 29 29 29 29 res waitons))))
12130 29 29 0a 09 20 20 20 20 20 28 73 6f 72 74 2d 66 )).. (sort-f
12140 6e 31 20 0a 09 20 20 20 20 20 20 28 6c 61 6d 62 n1 .. (lamb
12150 64 61 20 28 61 20 62 29 0a 09 09 28 6c 65 74 2a da (a b)...(let*
12160 20 28 28 61 2d 72 65 63 6f 72 64 20 20 20 28 68 ((a-record (h
12170 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 74 65 ash-table-ref te
12180 73 74 2d 72 65 63 6f 72 64 73 20 61 29 29 0a 09 st-records a))..
12190 09 20 20 20 20 20 20 20 28 62 2d 72 65 63 6f 72 . (b-recor
121a0 64 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d d (hash-table-
121b0 72 65 66 20 74 65 73 74 2d 72 65 63 6f 72 64 73 ref test-records
121c0 20 62 29 29 0a 09 09 20 20 20 20 20 20 20 28 61 b))... (a
121d0 2d 77 61 69 74 6f 6e 73 20 20 28 6f 72 20 28 74 -waitons (or (t
121e0 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 ests:testqueue-g
121f0 65 74 2d 77 61 69 74 6f 6e 73 20 61 2d 72 65 63 et-waitons a-rec
12200 6f 72 64 29 20 27 28 29 29 29 0a 09 09 20 20 20 ord) '()))...
12210 20 20 20 20 28 62 2d 77 61 69 74 6f 6e 73 20 20 (b-waitons
12220 28 6f 72 20 28 74 65 73 74 73 3a 74 65 73 74 71 (or (tests:testq
12230 75 65 75 65 2d 67 65 74 2d 77 61 69 74 6f 6e 73 ueue-get-waitons
12240 20 62 2d 72 65 63 6f 72 64 29 20 27 28 29 29 29 b-record) '()))
12250 0a 09 09 20 20 20 20 20 20 20 28 61 2d 63 6f 6e ... (a-con
12260 66 69 67 20 20 20 28 74 65 73 74 73 3a 74 65 73 fig (tests:tes
12270 74 71 75 65 75 65 2d 67 65 74 2d 74 65 73 74 63 tqueue-get-testc
12280 6f 6e 66 69 67 20 20 61 2d 72 65 63 6f 72 64 29 onfig a-record)
12290 29 0a 09 09 20 20 20 20 20 20 20 28 62 2d 63 6f )... (b-co
122a0 6e 66 69 67 20 20 20 28 74 65 73 74 73 3a 74 65 nfig (tests:te
122b0 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 73 74 stqueue-get-test
122c0 63 6f 6e 66 69 67 20 20 62 2d 72 65 63 6f 72 64 config b-record
122d0 29 29 0a 09 09 20 20 20 20 20 20 20 28 61 2d 72 ))... (a-r
122e0 61 77 2d 70 72 69 20 20 28 63 6f 6e 66 69 67 66 aw-pri (configf
122f0 3a 6c 6f 6f 6b 75 70 20 61 2d 63 6f 6e 66 69 67 :lookup a-config
12300 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 22 20 "requirements"
12310 22 70 72 69 6f 72 69 74 79 22 29 29 0a 09 09 20 "priority"))...
12320 20 20 20 20 20 20 28 62 2d 72 61 77 2d 70 72 69 (b-raw-pri
12330 20 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 (configf:looku
12340 70 20 62 2d 63 6f 6e 66 69 67 20 22 72 65 71 75 p b-config "requ
12350 69 72 65 6d 65 6e 74 73 22 20 22 70 72 69 6f 72 irements" "prior
12360 69 74 79 22 29 29 0a 09 09 20 20 20 20 20 20 20 ity"))...
12370 28 61 2d 70 72 69 6f 72 69 74 79 20 28 6d 75 6e (a-priority (mun
12380 67 65 70 72 69 6f 72 69 74 79 20 61 2d 72 61 77 gepriority a-raw
12390 2d 70 72 69 29 29 0a 09 09 20 20 20 20 20 20 20 -pri))...
123a0 28 62 2d 70 72 69 6f 72 69 74 79 20 28 6d 75 6e (b-priority (mun
123b0 67 65 70 72 69 6f 72 69 74 79 20 62 2d 72 61 77 gepriority b-raw
123c0 2d 70 72 69 29 29 29 0a 09 09 20 20 28 74 65 73 -pri)))... (tes
123d0 74 73 3a 74 65 73 74 71 75 65 75 65 2d 73 65 74 ts:testqueue-set
123e0 2d 70 72 69 6f 72 69 74 79 21 20 61 2d 72 65 63 -priority! a-rec
123f0 6f 72 64 20 61 2d 70 72 69 6f 72 69 74 79 29 0a ord a-priority).
12400 09 09 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 .. (tests:testq
12410 75 65 75 65 2d 73 65 74 2d 70 72 69 6f 72 69 74 ueue-set-priorit
12420 79 21 20 62 2d 72 65 63 6f 72 64 20 62 2d 70 72 y! b-record b-pr
12430 69 6f 72 69 74 79 29 0a 09 09 20 20 3b 3b 20 28 iority)... ;; (
12440 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
12450 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
12460 20 22 61 3d 22 20 61 20 22 2c 20 62 3d 22 20 62 "a=" a ", b=" b
12470 20 22 2c 20 61 2d 77 61 69 74 6f 6e 73 3d 22 20 ", a-waitons="
12480 61 2d 77 61 69 74 6f 6e 73 20 22 2c 20 62 2d 77 a-waitons ", b-w
12490 61 69 74 6f 6e 73 3d 22 20 62 2d 77 61 69 74 6f aitons=" b-waito
124a0 6e 73 29 0a 09 09 20 20 28 63 6f 6e 64 0a 09 09 ns)... (cond...
124b0 20 20 20 3b 3b 20 69 73 20 0a 09 09 20 20 20 28 ;; is ... (
124c0 28 6d 65 6d 62 65 72 20 61 20 62 2d 77 61 69 74 (member a b-wait
124d0 6f 6e 73 29 20 20 20 20 20 20 20 20 20 20 3b 3b ons) ;;
124e0 20 69 73 20 62 20 77 61 69 74 69 6e 67 20 6f 6e is b waiting on
124f0 20 61 3f 0a 09 09 20 20 20 20 3b 3b 20 28 64 65 a?... ;; (de
12500 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
12510 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
12520 63 61 73 65 31 22 29 0a 09 09 20 20 20 20 23 74 case1")... #t
12530 29 0a 09 09 20 20 20 28 28 6d 65 6d 62 65 72 20 )... ((member
12540 62 20 61 2d 77 61 69 74 6f 6e 73 29 20 20 20 20 b a-waitons)
12550 20 20 20 20 20 20 3b 3b 20 69 73 20 61 20 77 61 ;; is a wa
12560 69 74 69 6e 67 20 6f 6e 20 62 3f 0a 09 09 20 20 iting on b?...
12570 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e ;; (debug:prin
12580 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
12590 2d 70 6f 72 74 2a 20 22 63 61 73 65 32 22 29 0a -port* "case2").
125a0 09 09 20 20 20 20 23 66 29 0a 09 09 20 20 20 28 .. #f)... (
125b0 28 61 6e 64 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f (and (not (null?
125c0 20 61 2d 77 61 69 74 6f 6e 73 29 29 20 20 3b 3b a-waitons)) ;;
125d0 20 62 6f 74 68 20 68 61 76 65 20 77 61 69 74 6f both have waito
125e0 6e 73 20 2d 20 64 6f 20 6e 6f 74 20 64 69 73 74 ns - do not dist
125f0 75 72 62 0a 09 09 09 20 28 6e 6f 74 20 28 6e 75 urb.... (not (nu
12600 6c 6c 3f 20 62 2d 77 61 69 74 6f 6e 73 29 29 29 ll? b-waitons)))
12610 0a 09 09 20 20 20 20 3b 3b 20 28 64 65 62 75 67 ... ;; (debug
12620 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
12630 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 63 61 73 t-log-port* "cas
12640 65 32 2e 31 22 29 0a 09 09 20 20 20 20 23 74 29 e2.1")... #t)
12650 0a 09 09 20 20 20 28 28 61 6e 64 20 28 6e 75 6c ... ((and (nul
12660 6c 3f 20 61 2d 77 61 69 74 6f 6e 73 29 20 20 20 l? a-waitons)
12670 20 20 20 20 20 3b 3b 20 6e 6f 20 77 61 69 74 6f ;; no waito
12680 6e 73 20 66 6f 72 20 61 20 62 75 74 20 62 20 68 ns for a but b h
12690 61 73 20 77 61 69 74 6f 6e 73 0a 09 09 09 20 28 as waitons.... (
126a0 6e 6f 74 20 28 6e 75 6c 6c 3f 20 62 2d 77 61 69 not (null? b-wai
126b0 74 6f 6e 73 29 29 29 0a 09 09 20 20 20 20 3b 3b tons)))... ;;
126c0 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
126d0 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
126e0 74 2a 20 22 63 61 73 65 33 22 29 0a 09 09 20 20 t* "case3")...
126f0 20 20 23 66 29 0a 09 09 20 20 20 28 28 61 6e 64 #f)... ((and
12700 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 61 2d 77 (not (null? a-w
12710 61 69 74 6f 6e 73 29 29 20 20 3b 3b 20 61 20 68 aitons)) ;; a h
12720 61 73 20 77 61 69 74 6f 6e 73 20 62 75 74 20 62 as waitons but b
12730 20 64 6f 65 73 20 6e 6f 74 0a 09 09 09 20 28 6e does not.... (n
12740 75 6c 6c 3f 20 62 2d 77 61 69 74 6f 6e 73 29 29 ull? b-waitons))
12750 20 0a 09 09 20 20 20 20 3b 3b 20 28 64 65 62 75 ... ;; (debu
12760 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
12770 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 63 61 lt-log-port* "ca
12780 73 65 34 22 29 0a 09 09 20 20 20 20 23 74 29 0a se4")... #t).
12790 09 09 20 20 20 28 28 6e 6f 74 20 28 65 71 3f 20 .. ((not (eq?
127a0 61 2d 70 72 69 6f 72 69 74 79 20 62 2d 70 72 69 a-priority b-pri
127b0 6f 72 69 74 79 29 29 20 3b 3b 20 75 73 65 0a 09 ority)) ;; use..
127c0 09 20 20 20 20 28 3e 20 61 2d 70 72 69 6f 72 69 . (> a-priori
127d0 74 79 20 62 2d 70 72 69 6f 72 69 74 79 29 29 0a ty b-priority)).
127e0 09 09 20 20 20 28 65 6c 73 65 0a 09 09 20 20 20 .. (else...
127f0 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ;; (debug:print
12800 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
12810 70 6f 72 74 2a 20 22 63 61 73 65 35 22 29 0a 09 port* "case5")..
12820 09 20 20 20 20 28 73 74 72 69 6e 67 3e 3f 20 61 . (string>? a
12830 20 62 29 29 29 29 29 29 0a 09 20 20 20 20 20 0a b)))))).. .
12840 09 20 20 20 20 20 28 73 6f 72 74 2d 66 6e 32 0a . (sort-fn2.
12850 09 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 . (lambda (
12860 61 20 62 29 0a 09 09 28 3e 20 28 6d 75 6e 67 65 a b)...(> (munge
12870 70 72 69 6f 72 69 74 79 20 28 74 65 73 74 73 3a priority (tests:
12880 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 70 72 testqueue-get-pr
12890 69 6f 72 69 74 79 20 28 68 61 73 68 2d 74 61 62 iority (hash-tab
128a0 6c 65 2d 72 65 66 20 74 65 73 74 2d 72 65 63 6f le-ref test-reco
128b0 72 64 73 20 61 29 29 29 0a 09 09 20 20 20 28 6d rds a)))... (m
128c0 75 6e 67 65 70 72 69 6f 72 69 74 79 20 28 74 65 ungepriority (te
128d0 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 sts:testqueue-ge
128e0 74 2d 70 72 69 6f 72 69 74 79 20 28 68 61 73 68 t-priority (hash
128f0 2d 74 61 62 6c 65 2d 72 65 66 20 74 65 73 74 2d -table-ref test-
12900 72 65 63 6f 72 64 73 20 62 29 29 29 29 29 29 29 records b)))))))
12910 0a 09 3b 3b 20 28 6c 65 74 20 28 28 64 6f 74 2d ..;; (let ((dot-
12920 72 65 73 20 28 74 65 73 74 73 3a 72 75 6e 2d 64 res (tests:run-d
12930 6f 74 20 28 74 65 73 74 73 3a 74 65 73 74 73 2d ot (tests:tests-
12940 3e 64 6f 74 20 74 65 73 74 2d 72 65 63 6f 72 64 >dot test-record
12950 73 29 20 22 70 6c 61 69 6e 22 29 29 29 0a 09 3b s) "plain")))..;
12960 3b 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ; (debug:print
12970 20 22 64 6f 74 2d 72 65 73 3d 22 20 64 6f 74 2d "dot-res=" dot-
12980 72 65 73 29 29 0a 09 3b 3b 20 28 6c 65 74 20 28 res))..;; (let (
12990 28 64 61 74 61 20 28 6d 61 70 20 63 64 72 20 28 (data (map cdr (
129a0 66 69 6c 74 65 72 0a 09 3b 3b 20 20 20 20 20 09 filter..;; .
129b0 09 20 20 28 6c 61 6d 62 64 61 20 28 78 29 28 65 . (lambda (x)(e
129c0 71 75 61 6c 3f 20 22 6e 6f 64 65 22 20 28 63 61 qual? "node" (ca
129d0 72 20 78 29 29 29 0a 09 3b 3b 20 20 20 20 20 09 r x)))..;; .
129e0 09 20 20 28 6d 61 70 20 73 74 72 69 6e 67 2d 73 . (map string-s
129f0 70 6c 69 74 20 28 74 65 73 74 73 3a 65 61 73 79 plit (tests:easy
12a00 2d 64 6f 74 20 74 65 73 74 2d 72 65 63 6f 72 64 -dot test-record
12a10 73 20 22 70 6c 61 69 6e 22 29 29 29 29 29 29 0a s "plain")))))).
12a20 09 3b 3b 20 20 20 28 6d 61 70 20 63 61 72 20 28 .;; (map car (
12a30 73 6f 72 74 20 64 61 74 61 20 28 6c 61 6d 62 64 sort data (lambd
12a40 61 20 28 61 20 62 29 0a 09 3b 3b 20 20 20 20 20 a (a b)..;;
12a50 09 09 20 20 20 20 28 3e 20 28 73 74 72 69 6e 67 .. (> (string
12a60 2d 3e 6e 75 6d 62 65 72 20 28 63 61 64 64 72 20 ->number (caddr
12a70 61 29 29 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 a))(string->numb
12a80 65 72 20 28 63 61 64 64 72 20 62 29 29 29 29 29 er (caddr b)))))
12a90 29 29 0a 09 3b 3b 20 29 29 0a 09 28 73 6f 72 74 ))..;; ))..(sort
12aa0 20 61 6c 6c 2d 74 65 73 74 73 20 73 6f 72 74 2d all-tests sort-
12ab0 66 6e 31 29 29 29 29 20 3b 3b 20 61 76 6f 69 64 fn1)))) ;; avoid
12ac0 20 64 65 61 6c 69 6e 67 20 77 69 74 68 20 64 65 dealing with de
12ad0 6c 65 74 65 64 20 74 65 73 74 73 2c 20 6c 6f 6f leted tests, loo
12ae0 6b 20 61 74 20 74 68 65 20 68 61 73 68 20 74 61 k at the hash ta
12af0 62 6c 65 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 ble..(define (te
12b00 73 74 73 3a 65 61 73 79 2d 64 6f 74 20 74 65 73 sts:easy-dot tes
12b10 74 2d 72 65 63 6f 72 64 73 20 6f 75 74 74 79 70 t-records outtyp
12b20 65 29 0a 20 20 28 6c 65 74 2d 76 61 6c 75 65 73 e). (let-values
12b30 20 28 28 28 66 64 20 74 65 6d 70 2d 70 61 74 68 (((fd temp-path
12b40 29 20 28 66 69 6c 65 2d 6d 6b 73 74 65 6d 70 20 ) (file-mkstemp
12b50 28 63 6f 6e 63 20 22 2f 74 6d 70 2f 22 20 28 63 (conc "/tmp/" (c
12b60 75 72 72 65 6e 74 2d 75 73 65 72 2d 6e 61 6d 65 urrent-user-name
12b70 29 20 22 2e 58 58 58 58 58 58 22 29 29 29 29 0a ) ".XXXXXX")))).
12b80 20 20 20 20 28 6c 65 74 20 28 28 61 6c 6c 2d 74 (let ((all-t
12b90 65 73 74 6e 61 6d 65 73 20 28 68 61 73 68 2d 74 estnames (hash-t
12ba0 61 62 6c 65 2d 6b 65 79 73 20 74 65 73 74 2d 72 able-keys test-r
12bb0 65 63 6f 72 64 73 29 29 0a 09 20 20 28 74 65 6d ecords)).. (tem
12bc0 70 2d 70 6f 72 74 20 20 20 20 20 28 6f 70 65 6e p-port (open
12bd0 2d 6f 75 74 70 75 74 2d 66 69 6c 65 2a 20 66 64 -output-file* fd
12be0 29 29 29 0a 20 20 20 20 20 20 3b 3b 20 28 66 6f ))). ;; (fo
12bf0 72 6d 61 74 20 74 65 6d 70 2d 70 6f 72 74 20 22 rmat temp-port "
12c00 54 68 69 73 20 66 69 6c 65 20 69 73 20 7e 41 2e This file is ~A.
12c10 7e 25 22 20 74 65 6d 70 2d 70 61 74 68 29 0a 20 ~%" temp-path).
12c20 20 20 20 20 20 28 66 6f 72 6d 61 74 20 74 65 6d (format tem
12c30 70 2d 70 6f 72 74 20 22 64 69 67 72 61 70 68 20 p-port "digraph
12c40 74 65 73 74 73 20 7b 5c 6e 22 29 0a 20 20 20 20 tests {\n").
12c50 20 20 28 66 6f 72 6d 61 74 20 74 65 6d 70 2d 70 (format temp-p
12c60 6f 72 74 20 22 20 20 73 69 7a 65 3d 34 2c 38 5c ort " size=4,8\
12c70 6e 22 29 0a 20 20 20 20 20 20 3b 3b 20 28 66 6f n"). ;; (fo
12c80 72 6d 61 74 20 74 65 6d 70 2d 70 6f 72 74 20 22 rmat temp-port "
12c90 20 20 20 73 70 6c 69 6e 65 73 3d 6e 6f 6e 65 5c splines=none\
12ca0 6e 22 29 0a 20 20 20 20 20 20 28 66 6f 72 2d 65 n"). (for-e
12cb0 61 63 68 0a 20 20 20 20 20 20 20 28 6c 61 6d 62 ach. (lamb
12cc0 64 61 20 28 74 65 73 74 6e 61 6d 65 29 0a 09 20 da (testname)..
12cd0 28 6c 65 74 2a 20 28 28 74 65 73 74 72 65 63 20 (let* ((testrec
12ce0 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 (hash-table-ref
12cf0 74 65 73 74 2d 72 65 63 6f 72 64 73 20 74 65 73 test-records tes
12d00 74 6e 61 6d 65 29 29 0a 09 09 28 77 61 69 74 6f tname))...(waito
12d10 6e 73 20 28 6f 72 20 28 74 65 73 74 73 3a 74 65 ns (or (tests:te
12d20 73 74 71 75 65 75 65 2d 67 65 74 2d 77 61 69 74 stqueue-get-wait
12d30 6f 6e 73 20 74 65 73 74 72 65 63 29 20 27 28 29 ons testrec) '()
12d40 29 29 29 0a 09 20 20 20 28 66 6f 72 2d 65 61 63 ))).. (for-eac
12d50 68 0a 09 20 20 20 20 28 6c 61 6d 62 64 61 20 28 h.. (lambda (
12d60 77 61 69 74 6f 6e 29 0a 09 20 20 20 20 20 20 28 waiton).. (
12d70 66 6f 72 6d 61 74 20 74 65 6d 70 2d 70 6f 72 74 format temp-port
12d80 20 28 63 6f 6e 63 20 22 20 20 20 22 20 77 61 69 (conc " " wai
12d90 74 6f 6e 20 22 20 2d 3e 20 22 20 74 65 73 74 6e ton " -> " testn
12da0 61 6d 65 20 22 20 5b 73 70 6c 69 6e 65 73 3d 6f ame " [splines=o
12db0 72 74 68 6f 5d 5c 6e 22 29 29 29 0a 09 20 20 20 rtho]\n")))..
12dc0 20 77 61 69 74 6f 6e 73 29 29 29 0a 20 20 20 20 waitons))).
12dd0 20 20 20 61 6c 6c 2d 74 65 73 74 6e 61 6d 65 73 all-testnames
12de0 29 0a 20 20 20 20 20 20 28 66 6f 72 6d 61 74 20 ). (format
12df0 74 65 6d 70 2d 70 6f 72 74 20 22 7d 5c 6e 22 29 temp-port "}\n")
12e00 0a 20 20 20 20 20 20 28 63 6c 6f 73 65 2d 6f 75 . (close-ou
12e10 74 70 75 74 2d 70 6f 72 74 20 74 65 6d 70 2d 70 tput-port temp-p
12e20 6f 72 74 29 0a 20 20 20 20 20 20 28 77 69 74 68 ort). (with
12e30 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 -input-from-pipe
12e40 0a 20 20 20 20 20 20 20 28 63 6f 6e 63 20 22 65 . (conc "e
12e50 6e 76 20 2d 69 20 50 41 54 48 3d 24 50 41 54 48 nv -i PATH=$PATH
12e60 20 64 6f 74 20 2d 54 22 20 6f 75 74 74 79 70 65 dot -T" outtype
12e70 20 22 20 3c 20 22 20 74 65 6d 70 2d 70 61 74 68 " < " temp-path
12e80 29 0a 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 ). (lambda
12e90 20 28 29 0a 09 20 28 6c 65 74 20 28 28 72 65 73 ().. (let ((res
12ea0 20 28 72 65 61 64 2d 6c 69 6e 65 73 29 29 29 0a (read-lines))).
12eb0 09 20 20 20 3b 3b 20 28 64 65 6c 65 74 65 2d 66 . ;; (delete-f
12ec0 69 6c 65 20 74 65 6d 70 2d 70 61 74 68 29 0a 09 ile temp-path)..
12ed0 20 20 20 72 65 73 29 29 29 29 29 29 0a 0a 28 64 res))))))..(d
12ee0 65 66 69 6e 65 20 28 74 65 73 74 73 3a 77 72 69 efine (tests:wri
12ef0 74 65 2d 64 6f 74 2d 66 69 6c 65 20 74 65 73 74 te-dot-file test
12f00 2d 72 65 63 6f 72 64 73 20 66 6e 61 6d 65 20 73 -records fname s
12f10 69 7a 65 78 20 73 69 7a 65 79 29 0a 20 20 28 69 izex sizey). (i
12f20 66 20 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 f (file-write-ac
12f30 63 65 73 73 3f 20 28 70 61 74 68 6e 61 6d 65 2d cess? (pathname-
12f40 64 69 72 65 63 74 6f 72 79 20 66 6e 61 6d 65 29 directory fname)
12f50 29 0a 20 20 20 20 20 20 28 77 69 74 68 2d 6f 75 ). (with-ou
12f60 74 70 75 74 2d 74 6f 2d 66 69 6c 65 20 66 6e 61 tput-to-file fna
12f70 6d 65 0a 09 28 6c 61 6d 62 64 61 20 28 29 0a 09 me..(lambda ()..
12f80 20 20 28 6d 61 70 20 70 72 69 6e 74 20 28 74 65 (map print (te
12f90 73 74 73 3a 74 65 73 74 73 2d 3e 64 6f 74 20 74 sts:tests->dot t
12fa0 65 73 74 2d 72 65 63 6f 72 64 73 20 73 69 7a 65 est-records size
12fb0 78 20 73 69 7a 65 79 29 29 29 29 29 29 0a 0a 28 x sizey))))))..(
12fc0 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 74 65 define (tests:te
12fd0 73 74 73 2d 3e 64 6f 74 20 74 65 73 74 2d 72 65 sts->dot test-re
12fe0 63 6f 72 64 73 20 73 69 7a 65 78 20 73 69 7a 65 cords sizex size
12ff0 79 29 0a 20 20 28 6c 65 74 20 28 28 61 6c 6c 2d y). (let ((all-
13000 74 65 73 74 6e 61 6d 65 73 20 28 68 61 73 68 2d testnames (hash-
13010 74 61 62 6c 65 2d 6b 65 79 73 20 74 65 73 74 2d table-keys test-
13020 72 65 63 6f 72 64 73 29 29 29 0a 20 20 20 20 28 records))). (
13030 69 66 20 28 6e 75 6c 6c 3f 20 61 6c 6c 2d 74 65 if (null? all-te
13040 73 74 6e 61 6d 65 73 29 0a 09 27 28 29 0a 09 28 stnames)..'()..(
13050 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 let loop ((hed (
13060 63 61 72 20 61 6c 6c 2d 74 65 73 74 6e 61 6d 65 car all-testname
13070 73 29 29 0a 09 09 20 20 20 28 74 61 6c 20 28 63 s))... (tal (c
13080 64 72 20 61 6c 6c 2d 74 65 73 74 6e 61 6d 65 73 dr all-testnames
13090 29 29 0a 09 09 20 20 20 28 72 65 73 20 28 6c 69 ))... (res (li
130a0 73 74 20 22 64 69 67 72 61 70 68 20 74 65 73 74 st "digraph test
130b0 73 20 7b 22 0a 09 09 09 20 20 20 20 20 20 28 63 s {".... (c
130c0 6f 6e 63 20 22 20 73 69 7a 65 3d 5c 22 22 20 28 onc " size=\"" (
130d0 6f 72 20 73 69 7a 65 78 20 31 31 29 20 22 2c 22 or sizex 11) ","
130e0 20 28 6f 72 20 73 69 7a 65 79 20 31 31 29 20 22 (or sizey 11) "
130f0 5c 22 3b 22 29 0a 09 09 09 20 20 20 20 20 20 22 \";").... "
13100 20 72 61 74 69 6f 3d 30 2e 39 35 3b 22 0a 09 09 ratio=0.95;"...
13110 09 20 20 20 20 20 20 29 29 29 0a 09 20 20 28 6c . ))).. (l
13120 65 74 2a 20 28 28 74 65 73 74 72 65 63 20 28 68 et* ((testrec (h
13130 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 74 65 ash-table-ref te
13140 73 74 2d 72 65 63 6f 72 64 73 20 68 65 64 29 29 st-records hed))
13150 0a 09 09 20 28 77 61 69 74 6f 6e 73 20 28 6f 72 ... (waitons (or
13160 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 (tests:testqueu
13170 65 2d 67 65 74 2d 77 61 69 74 6f 6e 73 20 74 65 e-get-waitons te
13180 73 74 72 65 63 29 20 27 28 29 29 29 0a 09 09 20 strec) '()))...
13190 28 6e 65 77 72 65 73 20 20 28 61 70 70 65 6e 64 (newres (append
131a0 20 72 65 73 0a 09 09 09 09 20 20 28 69 66 20 28 res..... (if (
131b0 6e 75 6c 6c 3f 20 77 61 69 74 6f 6e 73 29 0a 09 null? waitons)..
131c0 09 09 09 20 20 20 20 20 20 28 6c 69 73 74 20 28 ... (list (
131d0 63 6f 6e 63 20 22 20 20 20 5c 22 22 20 68 65 64 conc " \"" hed
131e0 20 22 5c 22 20 5b 73 68 61 70 65 3d 62 6f 78 5d "\" [shape=box]
131f0 3b 22 29 29 0a 09 09 09 09 20 20 20 20 20 20 28 ;"))..... (
13200 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 77 61 69 map (lambda (wai
13210 74 6f 6e 29 0a 09 09 09 09 09 20 20 20 20 20 28 ton)...... (
13220 63 6f 6e 63 20 22 20 20 20 5c 22 22 20 77 61 69 conc " \"" wai
13230 74 6f 6e 20 22 5c 22 20 2d 3e 20 5c 22 22 20 68 ton "\" -> \"" h
13240 65 64 20 22 5c 22 20 5b 73 68 61 70 65 3d 62 6f ed "\" [shape=bo
13250 78 5d 3b 22 29 29 0a 09 09 09 09 09 20 20 20 77 x];"))...... w
13260 61 69 74 6f 6e 73 29 0a 09 09 09 09 20 20 20 20 aitons).....
13270 20 20 29 29 29 29 0a 09 20 20 20 20 28 69 66 20 )))).. (if
13280 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 28 61 (null? tal)...(a
13290 70 70 65 6e 64 20 6e 65 77 72 65 73 20 28 6c 69 ppend newres (li
132a0 73 74 20 22 7d 22 29 29 0a 09 09 28 6c 6f 6f 70 st "}"))...(loop
132b0 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 (car tal)(cdr t
132c0 61 6c 29 20 6e 65 77 72 65 73 29 0a 09 09 29 29 al) newres)...))
132d0 29 29 29 29 0a 0a 3b 3b 20 28 74 65 73 74 73 3a ))))..;; (tests:
132e0 72 75 6e 2d 64 6f 74 20 28 6c 69 73 74 20 22 64 run-dot (list "d
132f0 69 67 72 61 70 68 20 74 65 73 74 73 20 7b 22 20 igraph tests {"
13300 22 61 20 2d 3e 20 62 22 20 22 7d 22 29 20 22 70 "a -> b" "}") "p
13310 6c 61 69 6e 22 29 0a 0a 28 64 65 66 69 6e 65 20 lain")..(define
13320 28 74 65 73 74 73 3a 72 75 6e 2d 64 6f 74 20 69 (tests:run-dot i
13330 6e 64 61 74 20 6f 75 74 74 79 70 65 29 20 3b 3b ndat outtype) ;;
13340 20 6f 75 74 74 79 70 65 20 69 73 20 70 6c 61 69 outtype is plai
13350 6e 2c 20 66 69 67 2c 20 64 6f 74 2c 20 65 74 63 n, fig, dot, etc
13360 2e 20 68 74 74 70 3a 2f 2f 77 77 77 2e 67 72 61 . http://www.gra
13370 70 68 76 69 7a 2e 6f 72 67 2f 63 6f 6e 74 65 6e phviz.org/conten
13380 74 2f 6f 75 74 70 75 74 2d 66 6f 72 6d 61 74 73 t/output-formats
13390 0a 20 20 28 6c 65 74 2d 76 61 6c 75 65 73 20 28 . (let-values (
133a0 28 28 69 6e 70 20 6f 75 70 20 70 69 64 29 28 70 ((inp oup pid)(p
133b0 72 6f 63 65 73 73 20 22 65 6e 76 20 2d 69 20 50 rocess "env -i P
133c0 41 54 48 3d 5c 22 24 50 41 54 48 5c 22 20 64 6f ATH=\"$PATH\" do
133d0 74 22 20 28 6c 69 73 74 20 22 2d 54 22 20 6f 75 t" (list "-T" ou
133e0 74 74 79 70 65 29 29 29 29 0a 20 20 20 20 28 77 ttype)))). (w
133f0 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 70 6f ith-output-to-po
13400 72 74 20 6f 75 70 0a 20 20 20 20 20 20 28 6c 61 rt oup. (la
13410 6d 62 64 61 20 28 29 0a 09 28 6d 61 70 20 70 72 mbda ()..(map pr
13420 69 6e 74 20 69 6e 64 61 74 29 29 29 0a 20 20 20 int indat))).
13430 20 28 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d 70 (close-output-p
13440 6f 72 74 20 6f 75 70 29 0a 20 20 20 20 28 6c 65 ort oup). (le
13450 74 20 28 28 72 65 73 20 28 77 69 74 68 2d 69 6e t ((res (with-in
13460 70 75 74 2d 66 72 6f 6d 2d 70 6f 72 74 20 69 6e put-from-port in
13470 70 0a 09 09 20 28 6c 61 6d 62 64 61 20 28 29 0a p... (lambda ().
13480 09 09 20 20 20 28 72 65 61 64 2d 6c 69 6e 65 73 .. (read-lines
13490 29 29 29 29 29 0a 20 20 20 20 20 20 28 63 6c 6f ))))). (clo
134a0 73 65 2d 69 6e 70 75 74 2d 70 6f 72 74 20 69 6e se-input-port in
134b0 70 29 0a 20 20 20 20 20 20 72 65 73 29 29 29 0a p). res))).
134c0 0a 3b 3b 20 72 65 61 64 20 64 61 74 61 20 66 72 .;; read data fr
134d0 6f 6d 20 74 6d 70 20 66 69 6c 65 20 6f 72 20 63 om tmp file or c
134e0 72 65 61 74 65 20 69 66 20 6e 6f 74 20 65 78 69 reate if not exi
134f0 73 74 73 0a 3b 3b 20 69 66 20 65 78 69 73 74 73 sts.;; if exists
13500 20 72 65 67 65 6e 20 69 6e 20 62 61 63 6b 67 72 regen in backgr
13510 6f 75 6e 64 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 ound.;;.(define
13520 28 74 65 73 74 73 3a 6c 61 7a 79 2d 64 6f 74 20 (tests:lazy-dot
13530 74 65 73 74 72 65 63 6f 72 64 73 20 20 6f 75 74 testrecords out
13540 74 79 70 65 20 73 69 7a 65 78 20 73 69 7a 65 79 type sizex sizey
13550 29 0a 20 20 28 6c 65 74 20 28 28 64 66 69 6c 65 ). (let ((dfile
13560 20 28 63 6f 6e 63 20 22 2f 74 6d 70 2f 2e 22 20 (conc "/tmp/."
13570 28 63 75 72 72 65 6e 74 2d 75 73 65 72 2d 6e 61 (current-user-na
13580 6d 65 29 20 22 2d 22 20 28 73 65 72 76 65 72 3a me) "-" (server:
13590 6d 6b 2d 73 69 67 6e 61 74 75 72 65 29 20 22 2e mk-signature) ".
135a0 64 6f 74 22 29 29 0a 09 28 66 6e 61 6d 65 20 28 dot"))..(fname (
135b0 63 6f 6e 63 20 22 2f 74 6d 70 2f 2e 22 20 28 63 conc "/tmp/." (c
135c0 75 72 72 65 6e 74 2d 75 73 65 72 2d 6e 61 6d 65 urrent-user-name
135d0 29 20 22 2d 22 20 28 73 65 72 76 65 72 3a 6d 6b ) "-" (server:mk
135e0 2d 73 69 67 6e 61 74 75 72 65 29 20 22 2e 64 6f -signature) ".do
135f0 74 64 61 74 22 29 29 29 0a 20 20 20 20 28 74 65 tdat"))). (te
13600 73 74 73 3a 77 72 69 74 65 2d 64 6f 74 2d 66 69 sts:write-dot-fi
13610 6c 65 20 74 65 73 74 72 65 63 6f 72 64 73 20 64 le testrecords d
13620 66 69 6c 65 20 73 69 7a 65 78 20 73 69 7a 65 79 file sizex sizey
13630 29 0a 20 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f ). (if (commo
13640 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 66 n:file-exists? f
13650 6e 61 6d 65 29 0a 09 28 6c 65 74 20 28 28 72 65 name)..(let ((re
13660 73 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 s (with-input-fr
13670 6f 6d 2d 66 69 6c 65 20 66 6e 61 6d 65 0a 09 09 om-file fname...
13680 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a (lambda ().
13690 09 09 20 20 20 20 20 20 20 28 72 65 61 64 2d 6c .. (read-l
136a0 69 6e 65 73 29 29 29 29 29 0a 09 20 20 28 73 79 ines))))).. (sy
136b0 73 74 65 6d 20 28 63 6f 6e 63 20 22 65 6e 76 20 stem (conc "env
136c0 2d 69 20 50 41 54 48 3d 5c 22 24 50 41 54 48 5c -i PATH=\"$PATH\
136d0 22 20 64 6f 74 20 2d 54 20 22 20 6f 75 74 74 79 " dot -T " outty
136e0 70 65 20 22 20 3c 20 22 20 64 66 69 6c 65 20 22 pe " < " dfile "
136f0 20 3e 20 22 20 66 6e 61 6d 65 20 22 26 22 29 29 > " fname "&"))
13700 0a 09 20 20 72 65 73 29 0a 09 28 62 65 67 69 6e .. res)..(begin
13710 0a 09 20 20 28 73 79 73 74 65 6d 20 28 63 6f 6e .. (system (con
13720 63 20 22 65 6e 76 20 2d 69 20 50 41 54 48 3d 5c c "env -i PATH=\
13730 22 24 50 41 54 48 5c 22 20 64 6f 74 20 2d 54 20 "$PATH\" dot -T
13740 22 20 6f 75 74 74 79 70 65 20 22 20 3c 20 22 20 " outtype " < "
13750 64 66 69 6c 65 20 22 20 3e 20 22 20 66 6e 61 6d dfile " > " fnam
13760 65 29 29 0a 09 20 20 28 77 69 74 68 2d 69 6e 70 e)).. (with-inp
13770 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 20 66 6e 61 ut-from-file fna
13780 6d 65 0a 09 20 20 20 20 28 6c 61 6d 62 64 61 20 me.. (lambda
13790 28 29 0a 09 20 20 20 20 20 20 28 72 65 61 64 2d ().. (read-
137a0 6c 69 6e 65 73 29 29 29 29 29 29 29 0a 09 20 20 lines)))))))..
137b0 0a 0a 3b 3b 20 66 6f 72 20 65 61 63 68 20 74 65 ..;; for each te
137c0 73 74 3a 0a 3b 3b 20 20 20 0a 28 64 65 66 69 6e st:.;; .(defin
137d0 65 20 28 74 65 73 74 73 3a 66 69 6c 74 65 72 2d e (tests:filter-
137e0 6e 6f 6e 2d 72 75 6e 6e 61 62 6c 65 20 72 75 6e non-runnable run
137f0 2d 69 64 20 74 65 73 74 6b 65 79 6e 61 6d 65 73 -id testkeynames
13800 20 74 65 73 74 72 65 63 6f 72 64 73 68 61 73 68 testrecordshash
13810 29 0a 20 20 28 6c 65 74 20 28 28 72 75 6e 6e 61 ). (let ((runna
13820 62 6c 65 73 20 27 28 29 29 29 0a 20 20 20 20 28 bles '())). (
13830 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 6c for-each. (l
13840 61 6d 62 64 61 20 28 74 65 73 74 6b 65 79 6e 61 ambda (testkeyna
13850 6d 65 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a me). (let*
13860 20 28 28 74 65 73 74 2d 72 65 63 6f 72 64 20 28 ((test-record (
13870 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 74 hash-table-ref t
13880 65 73 74 72 65 63 6f 72 64 73 68 61 73 68 20 74 estrecordshash t
13890 65 73 74 6b 65 79 6e 61 6d 65 29 29 0a 09 20 20 estkeyname))..
138a0 20 20 20 20 28 74 65 73 74 2d 6e 61 6d 65 20 20 (test-name
138b0 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 (tests:testqueu
138c0 65 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 20 e-get-testname
138d0 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 test-record))..
138e0 20 20 20 20 20 28 69 74 65 6d 64 61 74 20 20 20 (itemdat
138f0 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 (tests:testque
13900 75 65 2d 67 65 74 2d 69 74 65 6d 64 61 74 20 20 ue-get-itemdat
13910 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 test-record))..
13920 20 20 20 20 20 20 28 69 74 65 6d 2d 70 61 74 68 (item-path
13930 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 (tests:testqu
13940 65 75 65 2d 67 65 74 2d 69 74 65 6d 5f 70 61 74 eue-get-item_pat
13950 68 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a h test-record)).
13960 09 20 20 20 20 20 20 28 77 61 69 74 6f 6e 73 20 . (waitons
13970 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 (tests:testq
13980 75 65 75 65 2d 67 65 74 2d 77 61 69 74 6f 6e 73 ueue-get-waitons
13990 20 20 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 test-record))
139a0 0a 09 20 20 20 20 20 20 28 6b 65 65 70 2d 74 65 .. (keep-te
139b0 73 74 20 20 20 23 74 29 0a 09 20 20 20 20 20 20 st #t)..
139c0 28 74 65 73 74 2d 69 64 20 20 20 20 20 28 72 6d (test-id (rm
139d0 74 3a 67 65 74 2d 74 65 73 74 2d 69 64 20 72 75 t:get-test-id ru
139e0 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 n-id test-name i
139f0 74 65 6d 2d 70 61 74 68 29 29 0a 09 20 20 20 20 tem-path))..
13a00 20 20 28 74 64 61 74 20 20 20 20 20 20 20 20 28 (tdat (
13a10 72 6d 74 3a 67 65 74 2d 74 65 73 74 69 6e 66 6f rmt:get-testinfo
13a20 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 72 75 -state-status ru
13a30 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 29 29 20 n-id test-id)))
13a40 3b 3b 20 28 63 64 62 3a 67 65 74 2d 74 65 73 74 ;; (cdb:get-test
13a50 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 2a 72 75 6e -info-by-id *run
13a60 72 65 6d 6f 74 65 2a 20 74 65 73 74 2d 69 64 29 remote* test-id)
13a70 29 29 0a 09 20 28 69 66 20 74 64 61 74 0a 09 20 )).. (if tdat..
13a80 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 (begin..
13a90 20 20 20 3b 3b 20 4c 6f 6f 6b 20 61 74 20 74 68 ;; Look at th
13aa0 65 20 74 65 73 74 20 73 74 61 74 65 20 61 6e 64 e test state and
13ab0 20 73 74 61 74 75 73 0a 09 20 20 20 20 20 20 20 status..
13ac0 28 69 66 20 28 6f 72 20 28 61 6e 64 20 28 6d 65 (if (or (and (me
13ad0 6d 62 65 72 20 28 64 62 3a 74 65 73 74 2d 67 65 mber (db:test-ge
13ae0 74 2d 73 74 61 74 75 73 20 74 64 61 74 29 20 0a t-status tdat) .
13af0 09 09 09 09 20 20 20 20 27 28 22 50 41 53 53 22 .... '("PASS"
13b00 20 22 57 41 52 4e 22 20 22 57 41 49 56 45 44 22 "WARN" "WAIVED"
13b10 20 22 43 48 45 43 4b 22 20 22 53 4b 49 50 22 29 "CHECK" "SKIP")
13b20 29 0a 09 09 09 20 20 20 20 28 65 71 75 61 6c 3f ).... (equal?
13b30 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 (db:test-get-st
13b40 61 74 65 20 74 64 61 74 29 20 22 43 4f 4d 50 4c ate tdat) "COMPL
13b50 45 54 45 44 22 29 29 0a 09 09 20 20 20 20 20 20 ETED"))...
13b60 20 28 6d 65 6d 62 65 72 20 28 64 62 3a 74 65 73 (member (db:tes
13b70 74 2d 67 65 74 2d 73 74 61 74 65 20 74 64 61 74 t-get-state tdat
13b80 29 0a 09 09 09 09 20 20 20 20 27 28 22 49 4e 43 )..... '("INC
13b90 4f 4d 50 4c 45 54 45 22 20 22 4b 49 4c 4c 45 44 OMPLETE" "KILLED
13ba0 22 29 29 29 0a 09 09 20 20 20 28 73 65 74 21 20 ")))... (set!
13bb0 6b 65 65 70 2d 74 65 73 74 20 23 66 29 29 0a 0a keep-test #f))..
13bc0 09 20 20 20 20 20 20 20 3b 3b 20 65 78 61 6d 69 . ;; exami
13bd0 6e 65 20 77 61 69 74 6f 6e 73 20 66 6f 72 20 61 ne waitons for a
13be0 6e 79 20 66 61 69 6c 73 2e 20 49 66 20 69 74 20 ny fails. If it
13bf0 69 73 20 46 41 49 4c 20 6f 72 20 49 4e 43 4f 4d is FAIL or INCOM
13c00 50 4c 45 54 45 20 74 68 65 6e 20 65 6c 69 6d 69 PLETE then elimi
13c10 6e 61 74 65 20 74 68 69 73 20 74 65 73 74 0a 09 nate this test..
13c20 20 20 20 20 20 20 20 3b 3b 20 66 72 6f 6d 20 74 ;; from t
13c30 68 65 20 72 75 6e 6e 61 62 6c 65 20 6c 69 73 74 he runnable list
13c40 0a 09 20 20 20 20 20 20 20 28 69 66 20 6b 65 65 .. (if kee
13c50 70 2d 74 65 73 74 0a 09 09 20 20 20 28 66 6f 72 p-test... (for
13c60 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 77 -each (lambda (w
13c70 61 69 74 6f 6e 29 0a 09 09 09 20 20 20 20 20 20 aiton)....
13c80 20 3b 3b 20 66 6f 72 20 6e 6f 77 20 77 65 20 61 ;; for now we a
13c90 72 65 20 77 61 69 74 69 6e 67 20 6f 6e 6c 79 20 re waiting only
13ca0 6f 6e 20 74 68 65 20 70 61 72 65 6e 74 20 74 65 on the parent te
13cb0 73 74 0a 09 09 09 20 20 20 20 20 20 20 28 6c 65 st.... (le
13cc0 74 2a 20 28 28 70 61 72 65 6e 74 2d 74 65 73 74 t* ((parent-test
13cd0 2d 69 64 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 -id (rmt:get-tes
13ce0 74 2d 69 64 20 72 75 6e 2d 69 64 20 77 61 69 74 t-id run-id wait
13cf0 6f 6e 20 22 22 29 29 0a 09 09 09 09 20 20 20 20 on "")).....
13d00 20 20 28 77 74 64 61 74 20 20 20 20 20 20 20 20 (wtdat
13d10 20 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 69 (rmt:get-testi
13d20 6e 66 6f 2d 73 74 61 74 65 2d 73 74 61 74 75 73 nfo-state-status
13d30 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 run-id test-id)
13d40 29 29 20 3b 3b 20 28 63 64 62 3a 67 65 74 2d 74 )) ;; (cdb:get-t
13d50 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 2a est-info-by-id *
13d60 72 75 6e 72 65 6d 6f 74 65 2a 20 74 65 73 74 2d runremote* test-
13d70 69 64 29 29 29 0a 09 09 09 09 20 28 69 66 20 28 id)))..... (if (
13d80 6f 72 20 28 61 6e 64 20 28 65 71 75 61 6c 3f 20 or (and (equal?
13d90 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 (db:test-get-sta
13da0 74 65 20 77 74 64 61 74 29 20 22 43 4f 4d 50 4c te wtdat) "COMPL
13db0 45 54 45 44 22 29 0a 09 09 09 09 09 20 20 20 20 ETED")......
13dc0 20 20 28 6d 65 6d 62 65 72 20 28 64 62 3a 74 65 (member (db:te
13dd0 73 74 2d 67 65 74 2d 73 74 61 74 75 73 20 77 74 st-get-status wt
13de0 64 61 74 29 20 27 28 22 46 41 49 4c 22 20 22 41 dat) '("FAIL" "A
13df0 42 4f 52 54 22 29 29 29 0a 09 09 09 09 09 20 28 BORT")))...... (
13e00 6d 65 6d 62 65 72 20 28 64 62 3a 74 65 73 74 2d member (db:test-
13e10 67 65 74 2d 73 74 61 74 75 73 20 77 74 64 61 74 get-status wtdat
13e20 29 20 20 27 28 22 4b 49 4c 4c 45 44 22 29 29 0a ) '("KILLED")).
13e30 09 09 09 09 09 20 28 6d 65 6d 62 65 72 20 28 64 ..... (member (d
13e40 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 b:test-get-state
13e50 20 77 74 64 61 74 29 20 20 20 27 28 22 49 4e 43 wtdat) '("INC
13e60 4f 4d 50 45 54 45 22 29 29 29 0a 09 09 09 09 20 OMPETE"))).....
13e70 3b 3b 20 28 69 66 20 28 6f 72 20 28 6d 65 6d 62 ;; (if (or (memb
13e80 65 72 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d er (db:test-get-
13e90 73 74 61 74 75 73 20 77 74 64 61 74 29 0a 09 09 status wtdat)...
13ea0 09 09 20 3b 3b 20 20 20 20 20 20 20 20 09 20 27 .. ;; . '
13eb0 28 22 46 41 49 4c 22 20 22 4b 49 4c 4c 45 44 22 ("FAIL" "KILLED"
13ec0 29 29 0a 09 09 09 09 20 3b 3b 20 20 20 20 20 20 ))..... ;;
13ed0 20 20 20 28 6d 65 6d 62 65 72 20 28 64 62 3a 74 (member (db:t
13ee0 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 77 74 est-get-state wt
13ef0 64 61 74 29 0a 09 09 09 09 20 3b 3b 20 20 20 20 dat)..... ;;
13f00 20 20 20 20 09 20 27 28 22 49 4e 43 4f 4d 50 45 . '("INCOMPE
13f10 54 45 22 29 29 29 0a 09 09 09 09 20 20 20 20 20 TE"))).....
13f20 28 73 65 74 21 20 6b 65 65 70 2d 74 65 73 74 20 (set! keep-test
13f30 23 66 29 29 29 29 20 3b 3b 20 6e 6f 20 70 6f 69 #f)))) ;; no poi
13f40 6e 74 20 69 6e 20 72 75 6e 6e 69 6e 67 20 74 68 nt in running th
13f50 69 73 20 6f 6e 65 20 61 67 61 69 6e 0a 09 09 09 is one again....
13f60 20 20 20 20 20 77 61 69 74 6f 6e 73 29 29 29 29 waitons))))
13f70 0a 09 20 28 69 66 20 6b 65 65 70 2d 74 65 73 74 .. (if keep-test
13f80 20 28 73 65 74 21 20 72 75 6e 6e 61 62 6c 65 73 (set! runnables
13f90 20 28 63 6f 6e 73 20 74 65 73 74 6b 65 79 6e 61 (cons testkeyna
13fa0 6d 65 20 72 75 6e 6e 61 62 6c 65 73 29 29 29 29 me runnables))))
13fb0 29 0a 20 20 20 20 20 74 65 73 74 6b 65 79 6e 61 ). testkeyna
13fc0 6d 65 73 29 0a 20 20 20 20 72 75 6e 6e 61 62 6c mes). runnabl
13fd0 65 73 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d es))..;;========
13fe0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13ff0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14000 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14010 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
14020 3b 20 72 65 66 61 63 74 6f 72 69 6e 67 20 74 68 ; refactoring th
14030 69 73 20 62 6c 6f 63 6b 20 69 6e 74 6f 20 74 65 is block into te
14040 73 74 73 3a 67 65 74 2d 66 75 6c 6c 2d 64 61 74 sts:get-full-dat
14050 61 20 66 72 6f 6d 20 6c 69 6e 65 20 32 36 33 20 a from line 263
14060 6f 66 20 72 75 6e 73 2e 73 63 6d 0a 3b 3b 3d 3d of runs.scm.;;==
14070 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14080 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14090 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
140a0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
140b0 3d 3d 3d 3d 0a 3b 3b 20 68 65 64 20 69 73 20 74 ====.;; hed is t
140c0 68 65 20 74 65 73 74 20 6e 61 6d 65 0a 3b 3b 20 he test name.;;
140d0 74 65 73 74 2d 72 65 63 6f 72 64 73 20 69 73 20 test-records is
140e0 61 20 68 61 73 68 20 6f 66 20 74 65 73 74 2d 6e a hash of test-n
140f0 61 6d 65 20 3d 3e 20 74 65 73 74 20 72 65 63 6f ame => test reco
14100 72 64 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 rd.(define (test
14110 73 3a 67 65 74 2d 66 75 6c 6c 2d 64 61 74 61 20 s:get-full-data
14120 74 65 73 74 2d 6e 61 6d 65 73 20 74 65 73 74 2d test-names test-
14130 72 65 63 6f 72 64 73 20 72 65 71 75 69 72 65 64 records required
14140 2d 74 65 73 74 73 20 61 6c 6c 2d 74 65 73 74 73 -tests all-tests
14150 2d 72 65 67 69 73 74 72 79 29 0a 20 20 28 6c 65 -registry). (le
14160 74 20 28 28 6d 69 73 73 69 6e 67 2d 77 61 69 74 t ((missing-wait
14170 6f 6e 73 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 ons (make-hash-t
14180 61 62 6c 65 29 29 29 0a 20 20 20 20 28 69 66 20 able))). (if
14190 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 65 73 74 (not (null? test
141a0 2d 6e 61 6d 65 73 29 29 0a 20 20 20 20 20 20 28 -names)). (
141b0 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 let loop ((hed (
141c0 63 61 72 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 car test-names))
141d0 0a 09 09 20 28 74 61 6c 20 28 63 64 72 20 74 65 ... (tal (cdr te
141e0 73 74 2d 6e 61 6d 65 73 29 29 29 20 20 20 20 20 st-names)))
141f0 20 20 20 20 3b 3b 20 27 72 65 74 75 72 6e 2d 70 ;; 'return-p
14200 72 6f 63 73 20 74 65 6c 6c 73 20 74 68 65 20 63 rocs tells the c
14210 6f 6e 66 69 67 20 72 65 61 64 65 72 20 74 6f 20 onfig reader to
14220 70 72 65 70 20 72 75 6e 6e 69 6e 67 20 73 79 73 prep running sys
14230 74 65 6d 20 62 75 74 20 72 65 74 75 72 6e 20 61 tem but return a
14240 20 70 72 6f 63 0a 09 28 64 65 62 75 67 3a 70 72 proc..(debug:pr
14250 69 6e 74 2d 69 6e 66 6f 20 34 20 2a 64 65 66 61 int-info 4 *defa
14260 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 68 ult-log-port* "h
14270 65 64 3d 22 20 68 65 64 20 22 20 61 74 20 74 6f ed=" hed " at to
14280 70 20 6f 66 20 6c 6f 6f 70 22 29 0a 20 20 20 20 p of loop").
14290 20 20 20 20 3b 3b 20 64 6f 6e 27 74 20 6b 6e 6f ;; don't kno
142a0 77 20 69 74 65 6d 2d 70 61 74 68 20 61 74 20 74 w item-path at t
142b0 68 69 73 20 74 69 6d 65 2c 20 6c 65 74 20 74 68 his time, let th
142c0 65 20 74 65 73 74 63 6f 6e 66 69 67 20 67 65 74 e testconfig get
142d0 20 74 68 65 20 74 6f 70 20 6c 65 76 65 6c 20 74 the top level t
142e0 65 73 74 63 6f 6e 66 69 67 0a 09 28 6c 65 74 2a estconfig..(let*
142f0 20 28 28 63 6f 6e 66 69 67 20 20 28 74 65 73 74 ((config (test
14300 73 3a 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 s:get-testconfig
14310 20 68 65 64 20 23 66 20 61 6c 6c 2d 74 65 73 74 hed #f all-test
14320 73 2d 72 65 67 69 73 74 72 79 20 27 72 65 74 75 s-registry 'retu
14330 72 6e 2d 70 72 6f 63 73 29 29 0a 09 20 20 20 20 rn-procs))..
14340 20 20 20 28 77 61 69 74 6f 6e 73 20 28 6c 65 74 (waitons (let
14350 20 28 28 69 6e 73 74 72 20 28 69 66 20 63 6f 6e ((instr (if con
14360 66 69 67 20 0a 09 09 09 09 09 20 28 63 6f 6e 66 fig ...... (conf
14370 69 67 66 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 igf:lookup confi
14380 67 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 22 g "requirements"
14390 20 22 77 61 69 74 6f 6e 22 29 0a 09 09 09 09 09 "waiton")......
143a0 20 28 62 65 67 69 6e 20 3b 3b 20 4e 6f 20 63 6f (begin ;; No co
143b0 6e 66 69 67 20 6d 65 61 6e 73 20 74 68 69 73 20 nfig means this
143c0 69 73 20 61 20 6e 6f 6e 2d 65 78 69 73 74 65 6e is a non-existen
143d0 74 20 74 65 73 74 0a 20 20 20 20 20 20 20 20 20 t test.
143e0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
143f0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14400 20 20 28 6c 65 74 20 28 28 77 61 69 74 65 72 73 (let ((waiters
14410 20 27 28 29 29 29 0a 20 20 20 20 20 20 20 20 20 '())).
14420 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14430 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14440 20 20 20 20 3b 3b 20 66 69 6e 64 20 74 68 65 20 ;; find the
14450 77 61 69 74 65 72 28 73 29 20 66 6f 72 20 74 68 waiter(s) for th
14460 69 73 20 77 61 69 74 6f 6e 2e 0a 20 20 20 20 20 is waiton..
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 66 6f 72 2d 65 61 63 (for-eac
144a0 68 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 h .
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 28 6c 61 6d 62 64 61 28 77 61 69 74 65 72 (lambda(waiter
144e0 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
144f0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14500 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14510 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 74 65 ;; (print "te
14520 73 74 2d 72 65 63 6f 72 64 20 3d 20 22 20 28 68 st-record = " (h
14530 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 74 65 ash-table-ref te
14540 73 74 2d 72 65 63 6f 72 64 73 20 77 61 69 74 65 st-records waite
14550 72 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 r)).
14560 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14570 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14580 20 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 ;; (print "
14590 77 61 69 74 6f 6e 73 20 3d 20 22 20 28 76 65 63 waitons = " (vec
145a0 74 6f 72 2d 72 65 66 20 28 68 61 73 68 2d 74 61 tor-ref (hash-ta
145b0 62 6c 65 2d 72 65 66 20 74 65 73 74 2d 72 65 63 ble-ref test-rec
145c0 6f 72 64 73 20 77 61 69 74 65 72 29 20 32 29 29 ords waiter) 2))
145d0 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
145e0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
145f0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14600 20 20 28 69 66 20 28 6d 65 6d 62 65 72 20 68 65 (if (member he
14610 64 20 28 76 65 63 74 6f 72 2d 72 65 66 20 28 68 d (vector-ref (h
14620 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 74 65 ash-table-ref te
14630 73 74 2d 72 65 63 6f 72 64 73 20 77 61 69 74 65 st-records waite
14640 72 29 20 32 29 29 0a 20 20 20 20 20 20 20 20 20 r) 2)).
14650 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14660 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14670 20 20 20 20 20 20 20 20 20 20 20 28 73 65 74 21 (set!
14680 20 77 61 69 74 65 72 73 20 28 63 6f 6e 73 20 77 waiters (cons w
14690 61 69 74 65 72 20 77 61 69 74 65 72 73 29 29 0a aiter waiters)).
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 20 20 20 20 20 20 20 20
146d0 20 29 0a 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 20 20 20 20 20 20 20 20 20
14700 20 20 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ).
14710 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14720 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14730 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 (hash-table-key
14740 73 20 74 65 73 74 2d 72 65 63 6f 72 64 73 29 29 s test-records))
14750 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
14760 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14770 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 68 (h
14780 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 6d ash-table-set! m
14790 69 73 73 69 6e 67 2d 77 61 69 74 6f 6e 73 20 68 issing-waitons h
147a0 65 64 20 77 61 69 74 65 72 73 29 0a 20 20 20 20 ed waiters).
147b0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
147c0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
147d0 20 20 20 20 20 20 20 29 0a 09 09 09 09 09 20 20 )......
147e0 20 22 22 29 29 29 29 0a 09 09 09 20 20 28 64 65 "")))).... (de
147f0 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 38 bug:print-info 8
14800 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
14810 72 74 2a 20 22 77 61 69 74 6f 6e 73 20 73 74 72 rt* "waitons str
14820 69 6e 67 20 69 73 20 22 20 69 6e 73 74 72 29 0a ing is " instr).
14830 09 09 09 20 20 28 73 74 72 69 6e 67 2d 73 70 6c ... (string-spl
14840 69 74 20 28 63 6f 6e 64 0a 09 09 09 09 09 20 28 it (cond...... (
14850 28 70 72 6f 63 65 64 75 72 65 3f 20 69 6e 73 74 (procedure? inst
14860 72 29 0a 09 09 09 09 09 20 20 28 6c 65 74 20 28 r)...... (let (
14870 28 72 65 73 20 28 69 6e 73 74 72 29 29 29 0a 09 (res (instr)))..
14880 09 09 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 .... (debug:p
14890 72 69 6e 74 2d 69 6e 66 6f 20 38 20 2a 64 65 66 rint-info 8 *def
148a0 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
148b0 77 61 69 74 6f 6e 20 70 72 6f 63 65 64 75 72 65 waiton procedure
148c0 20 72 65 73 75 6c 74 73 20 69 6e 20 73 74 72 69 results in stri
148d0 6e 67 20 22 20 72 65 73 20 22 20 66 6f 72 20 74 ng " res " for t
148e0 65 73 74 20 22 20 68 65 64 29 0a 09 09 09 09 09 est " hed)......
148f0 20 20 20 20 72 65 73 29 29 0a 09 09 09 09 09 20 res))......
14900 28 28 73 74 72 69 6e 67 3f 20 69 6e 73 74 72 29 ((string? instr)
14910 20 20 20 20 20 69 6e 73 74 72 29 0a 09 09 09 09 instr).....
14920 09 20 28 65 6c 73 65 20 0a 09 09 09 09 09 20 20 . (else ......
14930 3b 3b 20 4e 4f 54 45 3a 20 54 68 69 73 20 69 73 ;; NOTE: This is
14940 20 61 63 74 75 61 6c 6c 79 20 74 68 65 20 63 61 actually the ca
14950 73 65 20 6f 66 20 2a 6e 6f 2a 20 77 61 69 74 6f se of *no* waito
14960 6e 73 21 20 3b 3b 20 0a 09 09 09 09 09 20 20 22 ns! ;; ...... "
14970 22 29 29 29 29 29 29 0a 09 20 20 28 69 66 20 28 ")))))).. (if (
14980 6e 6f 74 20 63 6f 6e 66 69 67 29 20 3b 3b 20 74 not config) ;; t
14990 68 69 73 20 69 73 20 61 20 6e 6f 6e 2d 65 78 69 his is a non-exi
149a0 73 74 61 6e 74 20 74 65 73 74 20 63 61 6c 6c 65 stant test calle
149b0 64 20 69 6e 20 61 20 77 61 69 74 6f 6e 2e 20 0a d in a waiton. .
149c0 09 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c . (if (null
149d0 3f 20 74 61 6c 29 0a 09 09 20 20 74 65 73 74 2d ? tal)... test-
149e0 72 65 63 6f 72 64 73 0a 09 09 20 20 28 6c 6f 6f records... (loo
149f0 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 p (car tal)(cdr
14a00 74 61 6c 29 29 29 0a 09 20 20 20 20 20 20 28 62 tal))).. (b
14a10 65 67 69 6e 0a 09 09 28 64 65 62 75 67 3a 70 72 egin...(debug:pr
14a20 69 6e 74 2d 69 6e 66 6f 20 38 20 2a 64 65 66 61 int-info 8 *defa
14a30 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 77 ult-log-port* "w
14a40 61 69 74 6f 6e 73 3a 20 22 20 77 61 69 74 6f 6e aitons: " waiton
14a50 73 29 0a 09 09 3b 3b 20 63 68 65 63 6b 20 66 6f s)...;; check fo
14a60 72 20 68 65 64 20 69 6e 20 77 61 69 74 6f 6e 73 r hed in waitons
14a70 20 3d 3e 20 74 68 69 73 20 77 6f 75 6c 64 20 62 => this would b
14a80 65 20 63 69 72 63 75 6c 61 72 2c 20 72 65 6d 6f e circular, remo
14a90 76 65 20 69 74 20 61 6e 64 20 69 73 73 75 65 20 ve it and issue
14aa0 61 6e 0a 09 09 3b 3b 20 65 72 72 6f 72 0a 09 09 an...;; error...
14ab0 28 69 66 20 28 6d 65 6d 62 65 72 20 68 65 64 20 (if (member hed
14ac0 77 61 69 74 6f 6e 73 29 0a 09 09 20 20 20 20 28 waitons)... (
14ad0 62 65 67 69 6e 0a 09 09 20 20 20 20 20 20 28 64 begin... (d
14ae0 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 ebug:print-error
14af0 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
14b00 70 6f 72 74 2a 20 22 74 65 73 74 20 22 20 68 65 port* "test " he
14b10 64 20 22 20 68 61 73 20 6c 69 73 74 65 64 20 69 d " has listed i
14b20 74 73 65 6c 66 20 61 73 20 61 20 77 61 69 74 6f tself as a waito
14b30 6e 2c 20 70 6c 65 61 73 65 20 63 6f 72 72 65 63 n, please correc
14b40 74 20 74 68 69 73 21 22 29 0a 09 09 20 20 20 20 t this!")...
14b50 20 20 28 73 65 74 21 20 77 61 69 74 6f 6e 73 20 (set! waitons
14b60 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 (filter (lambda
14b70 28 78 29 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 (x)(not (equal?
14b80 78 20 68 65 64 29 29 29 20 77 61 69 74 6f 6e 73 x hed))) waitons
14b90 29 29 29 29 0a 09 09 0a 09 09 3b 3b 20 28 69 74 ))))......;; (it
14ba0 65 6d 73 20 20 20 28 69 74 65 6d 73 3a 67 65 74 ems (items:get
14bb0 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 -items-from-conf
14bc0 69 67 20 63 6f 6e 66 69 67 29 29 29 0a 09 09 28 ig config)))...(
14bd0 69 66 20 28 6e 6f 74 20 28 68 61 73 68 2d 74 61 if (not (hash-ta
14be0 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
14bf0 74 65 73 74 2d 72 65 63 6f 72 64 73 20 68 65 64 test-records hed
14c00 20 23 66 29 29 0a 09 09 20 20 20 20 28 68 61 73 #f))... (has
14c10 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 65 73 h-table-set! tes
14c20 74 2d 72 65 63 6f 72 64 73 0a 09 09 09 09 20 20 t-records.....
14c30 20 20 20 68 65 64 20 28 76 65 63 74 6f 72 20 68 hed (vector h
14c40 65 64 20 20 20 20 20 3b 3b 20 30 0a 09 09 09 09 ed ;; 0.....
14c50 09 09 20 63 6f 6e 66 69 67 20 20 3b 3b 20 31 0a .. config ;; 1.
14c60 09 09 09 09 09 09 20 77 61 69 74 6f 6e 73 20 3b ...... waitons ;
14c70 3b 20 32 0a 09 09 09 09 09 09 20 28 63 6f 6e 66 ; 2....... (conf
14c80 69 67 66 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 igf:lookup confi
14c90 67 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 22 g "requirements"
14ca0 20 22 70 72 69 6f 72 69 74 79 22 29 20 20 20 20 "priority")
14cb0 20 3b 3b 20 70 72 69 6f 72 69 74 79 20 33 0a 09 ;; priority 3..
14cc0 09 09 09 09 09 20 28 6c 65 74 20 28 28 69 74 65 ..... (let ((ite
14cd0 6d 73 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 ms (hash-ta
14ce0 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
14cf0 63 6f 6e 66 69 67 20 22 69 74 65 6d 73 22 20 23 config "items" #
14d00 66 29 29 20 3b 3b 20 69 74 65 6d 73 20 34 0a 09 f)) ;; items 4..
14d10 09 09 09 09 09 20 20 20 20 20 20 20 28 69 74 65 ..... (ite
14d20 6d 73 74 61 62 6c 65 20 28 68 61 73 68 2d 74 61 mstable (hash-ta
14d30 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
14d40 63 6f 6e 66 69 67 20 22 69 74 65 6d 73 74 61 62 config "itemstab
14d50 6c 65 22 20 23 66 29 29 29 20 0a 09 09 09 09 09 le" #f))) ......
14d60 09 20 20 20 3b 3b 20 69 66 20 65 69 74 68 65 72 . ;; if either
14d70 20 69 74 65 6d 73 20 6f 72 20 69 74 65 6d 73 20 items or items
14d80 74 61 62 6c 65 20 69 73 20 61 20 70 72 6f 63 20 table is a proc
14d90 72 65 74 75 72 6e 20 69 74 20 73 6f 20 74 65 73 return it so tes
14da0 74 20 72 75 6e 6e 69 6e 67 0a 09 09 09 09 09 09 t running.......
14db0 20 20 20 3b 3b 20 70 72 6f 63 65 73 73 20 63 61 ;; process ca
14dc0 6e 20 6b 6e 6f 77 20 74 6f 20 63 61 6c 6c 20 69 n know to call i
14dd0 74 65 6d 73 3a 67 65 74 2d 69 74 65 6d 73 2d 66 tems:get-items-f
14de0 72 6f 6d 2d 63 6f 6e 66 69 67 0a 09 09 09 09 09 rom-config......
14df0 09 20 20 20 3b 3b 20 69 66 20 65 69 74 68 65 72 . ;; if either
14e00 20 69 73 20 61 20 6c 69 73 74 20 61 6e 64 20 6e is a list and n
14e10 6f 6e 65 20 69 73 20 61 20 70 72 6f 63 20 67 6f one is a proc go
14e20 20 61 68 65 61 64 20 61 6e 64 20 63 61 6c 6c 20 ahead and call
14e30 67 65 74 2d 69 74 65 6d 73 0a 09 09 09 09 09 09 get-items.......
14e40 20 20 20 3b 3b 20 6f 74 68 65 72 77 69 73 65 20 ;; otherwise
14e50 72 65 74 75 72 6e 20 23 66 20 2d 20 74 68 69 73 return #f - this
14e60 20 69 73 20 6e 6f 74 20 61 6e 20 69 74 65 72 61 is not an itera
14e70 74 65 64 20 74 65 73 74 0a 09 09 09 09 09 09 20 ted test.......
14e80 20 20 28 63 6f 6e 64 0a 09 09 09 09 09 09 20 20 (cond.......
14e90 20 20 28 28 70 72 6f 63 65 64 75 72 65 3f 20 69 ((procedure? i
14ea0 74 65 6d 73 29 20 20 20 20 20 20 0a 09 09 09 09 tems) .....
14eb0 09 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 .. (debug:pr
14ec0 69 6e 74 2d 69 6e 66 6f 20 34 20 2a 64 65 66 61 int-info 4 *defa
14ed0 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 69 ult-log-port* "i
14ee0 74 65 6d 73 20 69 73 20 61 20 70 72 6f 63 65 64 tems is a proced
14ef0 75 72 65 2c 20 77 69 6c 6c 20 63 61 6c 63 20 6c ure, will calc l
14f00 61 74 65 72 22 29 0a 09 09 09 09 09 09 20 20 20 ater").......
14f10 20 20 69 74 65 6d 73 29 20 20 20 20 20 20 20 20 items)
14f20 20 20 20 20 3b 3b 20 63 61 6c 63 20 6c 61 74 65 ;; calc late
14f30 72 0a 09 09 09 09 09 09 20 20 20 20 28 28 70 72 r....... ((pr
14f40 6f 63 65 64 75 72 65 3f 20 69 74 65 6d 73 74 61 ocedure? itemsta
14f50 62 6c 65 29 0a 09 09 09 09 09 09 20 20 20 20 20 ble).......
14f60 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
14f70 6f 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 4 *default-log
14f80 2d 70 6f 72 74 2a 20 22 69 74 65 6d 73 74 61 62 -port* "itemstab
14f90 6c 65 20 69 73 20 61 20 70 72 6f 63 65 64 75 72 le is a procedur
14fa0 65 2c 20 77 69 6c 6c 20 63 61 6c 63 20 6c 61 74 e, will calc lat
14fb0 65 72 22 29 0a 09 09 09 09 09 09 20 20 20 20 20 er").......
14fc0 69 74 65 6d 73 74 61 62 6c 65 29 20 20 20 20 20 itemstable)
14fd0 20 20 3b 3b 20 63 61 6c 63 20 6c 61 74 65 72 0a ;; calc later.
14fe0 09 09 09 09 09 09 20 20 20 20 28 28 66 69 6c 74 ...... ((filt
14ff0 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 er (lambda (x)..
15000 09 09 09 09 09 09 20 20 20 20 20 20 20 28 6c 65 ...... (le
15010 74 20 28 28 76 61 6c 20 28 63 61 72 20 78 29 29 t ((val (car x))
15020 29 0a 09 09 09 09 09 09 09 09 20 28 69 66 20 28 )......... (if (
15030 70 72 6f 63 65 64 75 72 65 3f 20 76 61 6c 29 20 procedure? val)
15040 76 61 6c 20 23 66 29 29 29 0a 09 09 09 09 09 09 val #f))).......
15050 09 20 20 20 20 20 28 61 70 70 65 6e 64 20 28 69 . (append (i
15060 66 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 20 f (list? items)
15070 69 74 65 6d 73 20 27 28 29 29 0a 09 09 09 09 09 items '())......
15080 09 09 09 20 20 20 20 20 28 69 66 20 28 6c 69 73 ... (if (lis
15090 74 3f 20 69 74 65 6d 73 74 61 62 6c 65 29 20 69 t? itemstable) i
150a0 74 65 6d 73 74 61 62 6c 65 20 27 28 29 29 29 29 temstable '())))
150b0 0a 09 09 09 09 09 09 20 20 20 20 20 27 68 61 76 ....... 'hav
150c0 65 2d 70 72 6f 63 65 64 75 72 65 29 0a 09 09 09 e-procedure)....
150d0 09 09 09 20 20 20 20 28 28 6f 72 20 28 6c 69 73 ... ((or (lis
150e0 74 3f 20 69 74 65 6d 73 29 28 6c 69 73 74 3f 20 t? items)(list?
150f0 69 74 65 6d 73 74 61 62 6c 65 29 29 20 3b 3b 20 itemstable)) ;;
15100 63 61 6c 63 20 6e 6f 77 0a 09 09 09 09 09 09 20 calc now.......
15110 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
15120 2d 69 6e 66 6f 20 34 20 2a 64 65 66 61 75 6c 74 -info 4 *default
15130 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 69 74 65 6d -log-port* "item
15140 73 20 61 6e 64 20 69 74 65 6d 73 74 61 62 6c 65 s and itemstable
15150 20 61 72 65 20 6c 69 73 74 73 2c 20 63 61 6c 63 are lists, calc
15160 20 6e 6f 77 5c 6e 22 0a 09 09 09 09 09 09 09 09 now\n".........
15170 20 20 20 20 20 20 20 22 20 20 20 20 69 74 65 6d " item
15180 73 3a 20 22 20 69 74 65 6d 73 20 22 20 69 74 65 s: " items " ite
15190 6d 73 74 61 62 6c 65 3a 20 22 20 69 74 65 6d 73 mstable: " items
151a0 74 61 62 6c 65 29 0a 09 09 09 09 09 09 20 20 20 table).......
151b0 20 20 28 69 74 65 6d 73 3a 67 65 74 2d 69 74 65 (items:get-ite
151c0 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 20 63 ms-from-config c
151d0 6f 6e 66 69 67 29 29 0a 09 09 09 09 09 09 20 20 onfig)).......
151e0 20 20 28 65 6c 73 65 20 23 66 29 29 29 20 20 20 (else #f)))
151f0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
15200 20 20 20 20 20 20 20 20 3b 3b 20 6e 6f 74 20 69 ;; not i
15210 74 65 72 61 74 65 64 0a 09 09 09 09 09 09 20 23 terated....... #
15220 66 20 20 20 20 20 20 3b 3b 20 69 74 65 6d 73 64 f ;; itemsd
15230 61 74 20 35 0a 09 09 09 09 09 09 20 23 66 20 20 at 5....... #f
15240 20 20 20 20 3b 3b 20 73 70 61 72 65 20 2d 20 75 ;; spare - u
15250 73 65 64 20 66 6f 72 20 69 74 65 6d 2d 70 61 74 sed for item-pat
15260 68 0a 09 09 09 09 09 09 20 29 29 29 0a 20 20 20 h....... ))).
15270 20 20 20 20 20 20 20 20 20 20 20 20 20 28 66 6f (fo
15280 72 2d 65 61 63 68 20 0a 09 09 20 28 6c 61 6d 62 r-each ... (lamb
15290 64 61 20 28 77 61 69 74 6f 6e 29 0a 09 09 20 20 da (waiton)...
152a0 20 28 69 66 20 28 61 6e 64 20 77 61 69 74 6f 6e (if (and waiton
152b0 20 28 6e 6f 74 20 28 73 74 72 69 6e 67 3d 20 22 (not (string= "
152c0 23 66 22 20 77 61 69 74 6f 6e 29 29 20 28 6e 6f #f" waiton)) (no
152d0 74 20 28 6d 65 6d 62 65 72 20 77 61 69 74 6f 6e t (member waiton
152e0 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 29 0a 09 test-names)))..
152f0 09 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 . (begin..
15300 09 09 20 28 73 65 74 21 20 72 65 71 75 69 72 65 .. (set! require
15310 64 2d 74 65 73 74 73 20 28 63 6f 6e 73 20 77 61 d-tests (cons wa
15320 69 74 6f 6e 20 72 65 71 75 69 72 65 64 2d 74 65 iton required-te
15330 73 74 73 29 29 0a 09 09 09 20 28 73 65 74 21 20 sts)).... (set!
15340 74 65 73 74 2d 6e 61 6d 65 73 20 28 63 6f 6e 73 test-names (cons
15350 20 77 61 69 74 6f 6e 20 74 65 73 74 2d 6e 61 6d waiton test-nam
15360 65 73 29 29 29 29 29 20 3b 3b 20 77 61 73 20 61 es))))) ;; was a
15370 6e 20 61 70 70 65 6e 64 2c 20 6e 6f 77 20 61 20 n append, now a
15380 63 6f 6e 73 0a 09 09 20 77 61 69 74 6f 6e 73 29 cons... waitons)
15390 0a 09 09 28 6c 65 74 20 28 28 72 65 6d 74 65 73 ...(let ((remtes
153a0 74 73 20 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 ts (delete-dupli
153b0 63 61 74 65 73 20 28 61 70 70 65 6e 64 20 77 61 cates (append wa
153c0 69 74 6f 6e 73 20 74 61 6c 29 29 29 29 0a 09 09 itons tal))))...
153d0 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c (if (not (null
153e0 3f 20 72 65 6d 74 65 73 74 73 29 29 0a 09 09 20 ? remtests))...
153f0 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 (loop (car
15400 72 65 6d 74 65 73 74 73 29 28 63 64 72 20 72 65 remtests)(cdr re
15410 6d 74 65 73 74 73 29 29 0a 09 09 20 20 20 20 20 mtests))...
15420 20 74 65 73 74 2d 72 65 63 6f 72 64 73 29 29 29 test-records)))
15430 29 29 29 29 0a 20 20 20 20 20 20 28 66 6f 72 2d )))). (for-
15440 65 61 63 68 0a 20 20 20 20 20 20 20 20 20 28 6c each. (l
15450 61 6d 62 64 61 20 28 6d 69 73 73 69 6e 67 2d 77 ambda (missing-w
15460 61 69 74 6f 6e 29 0a 20 20 20 20 20 20 20 20 20 aiton).
15470 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
15480 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 error 0 *default
15490 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 6e 6f 6e 2d -log-port* "non-
154a0 65 78 69 73 74 65 6e 74 20 74 65 73 74 20 5c 22 existent test \"
154b0 22 20 6d 69 73 73 69 6e 67 2d 77 61 69 74 6f 6e " missing-waiton
154c0 20 22 5c 22 20 69 73 20 61 20 77 61 69 74 6f 6e "\" is a waiton
154d0 20 66 6f 72 20 74 65 73 74 73 20 22 20 28 68 61 for tests " (ha
154e0 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 6d 69 73 sh-table-ref mis
154f0 73 69 6e 67 2d 77 61 69 74 6f 6e 73 20 6d 69 73 sing-waitons mis
15500 73 69 6e 67 2d 77 61 69 74 6f 6e 29 29 0a 20 20 sing-waiton)).
15510 20 20 20 20 20 20 20 29 0a 20 20 20 20 20 20 20 ).
15520 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 (hash-table-ke
15530 79 73 20 6d 69 73 73 69 6e 67 2d 77 61 69 74 6f ys missing-waito
15540 6e 73 29 0a 20 20 20 20 20 20 29 0a 29 29 0a 0a ns). ).))..
15550 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
15560 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
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 0a 3b 3b 20 74 65 73 74 ========.;; test
155a0 20 73 74 65 70 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d steps.;;=======
155b0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
155c0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
155d0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
155e0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
155f0 0a 3b 3b 20 74 65 73 74 73 74 65 70 2d 73 65 74 .;; teststep-set
15600 2d 73 74 61 74 75 73 21 20 75 73 65 64 20 74 6f -status! used to
15610 20 62 65 20 68 65 72 65 0a 0a 28 64 65 66 69 6e be here..(defin
15620 65 20 28 74 65 73 74 2d 67 65 74 2d 6b 69 6c 6c e (test-get-kill
15630 2d 72 65 71 75 65 73 74 20 72 75 6e 2d 69 64 20 -request run-id
15640 74 65 73 74 2d 69 64 29 20 3b 3b 20 72 75 6e 2d test-id) ;; run-
15650 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 id test-name ite
15660 6d 64 61 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 mdat). (let* ((
15670 74 65 73 74 64 61 74 20 20 20 28 72 6d 74 3a 67 testdat (rmt:g
15680 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d et-test-info-by-
15690 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 id run-id test-i
156a0 64 29 29 29 0a 20 20 20 20 28 61 6e 64 20 74 65 d))). (and te
156b0 73 74 64 61 74 0a 09 20 28 65 71 75 61 6c 3f 20 stdat.. (equal?
156c0 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 (test:get-state
156d0 74 65 73 74 64 61 74 29 20 22 4b 49 4c 4c 52 45 testdat) "KILLRE
156e0 51 22 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 Q"))))..(define
156f0 28 74 65 73 74 3a 74 64 62 2d 67 65 74 2d 72 75 (test:tdb-get-ru
15700 6e 64 61 74 2d 63 6f 75 6e 74 20 74 64 62 29 0a ndat-count tdb).
15710 20 20 28 69 66 20 74 64 62 0a 20 20 20 20 20 20 (if tdb.
15720 28 6c 65 74 20 28 28 72 65 73 20 30 29 29 0a 09 (let ((res 0))..
15730 28 73 71 6c 69 74 65 33 3a 66 6f 72 2d 65 61 63 (sqlite3:for-eac
15740 68 2d 72 6f 77 0a 09 20 28 6c 61 6d 62 64 61 20 h-row.. (lambda
15750 28 63 6f 75 6e 74 29 0a 09 20 20 20 28 73 65 74 (count).. (set
15760 21 20 72 65 73 20 63 6f 75 6e 74 29 29 0a 09 20 ! res count))..
15770 74 64 62 0a 09 20 22 53 45 4c 45 43 54 20 63 6f tdb.. "SELECT co
15780 75 6e 74 28 69 64 29 20 46 52 4f 4d 20 74 65 73 unt(id) FROM tes
15790 74 5f 72 75 6e 64 61 74 3b 22 29 0a 09 72 65 73 t_rundat;")..res
157a0 29 29 0a 20 20 30 29 0a 0a 28 64 65 66 69 6e 65 )). 0)..(define
157b0 20 28 74 65 73 74 73 3a 75 70 64 61 74 65 2d 63 (tests:update-c
157c0 65 6e 74 72 61 6c 2d 6d 65 74 61 2d 69 6e 66 6f entral-meta-info
157d0 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 run-id test-id
157e0 63 70 75 6c 6f 61 64 20 64 69 73 6b 66 72 65 65 cpuload diskfree
157f0 20 6d 69 6e 75 74 65 73 20 75 6e 61 6d 65 20 68 minutes uname h
15800 6f 73 74 6e 61 6d 65 29 0a 20 20 28 72 6d 74 3a ostname). (rmt:
15810 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 75 70 general-call 'up
15820 64 61 74 65 2d 74 65 73 74 2d 72 75 6e 64 61 74 date-test-rundat
15830 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 run-id test-id
15840 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
15850 29 20 28 6f 72 20 63 70 75 6c 6f 61 64 20 2d 31 ) (or cpuload -1
15860 29 28 6f 72 20 64 69 73 6b 66 72 65 65 20 2d 31 )(or diskfree -1
15870 29 20 2d 31 20 28 6f 72 20 6d 69 6e 75 74 65 73 ) -1 (or minutes
15880 20 2d 31 29 29 0a 20 20 28 69 66 20 28 61 6e 64 -1)). (if (and
15890 20 63 70 75 6c 6f 61 64 20 64 69 73 6b 66 72 65 cpuload diskfre
158a0 65 29 0a 20 20 20 20 20 20 28 72 6d 74 3a 67 65 e). (rmt:ge
158b0 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 75 70 64 61 neral-call 'upda
158c0 74 65 2d 63 70 75 6c 6f 61 64 2d 64 69 73 6b 66 te-cpuload-diskf
158d0 72 65 65 20 72 75 6e 2d 69 64 20 63 70 75 6c 6f ree run-id cpulo
158e0 61 64 20 64 69 73 6b 66 72 65 65 20 74 65 73 74 ad diskfree test
158f0 2d 69 64 29 29 0a 20 20 28 69 66 20 6d 69 6e 75 -id)). (if minu
15900 74 65 73 20 0a 20 20 20 20 20 20 28 72 6d 74 3a tes . (rmt:
15910 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 75 70 general-call 'up
15920 64 61 74 65 2d 72 75 6e 2d 64 75 72 61 74 69 6f date-run-duratio
15930 6e 20 72 75 6e 2d 69 64 20 6d 69 6e 75 74 65 73 n run-id minutes
15940 20 74 65 73 74 2d 69 64 29 29 0a 20 20 28 69 66 test-id)). (if
15950 20 28 61 6e 64 20 75 6e 61 6d 65 20 68 6f 73 74 (and uname host
15960 6e 61 6d 65 29 0a 20 20 20 20 20 20 28 72 6d 74 name). (rmt
15970 3a 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 75 :general-call 'u
15980 70 64 61 74 65 2d 75 6e 61 6d 65 2d 68 6f 73 74 pdate-uname-host
15990 20 72 75 6e 2d 69 64 20 75 6e 61 6d 65 20 68 6f run-id uname ho
159a0 73 74 6e 61 6d 65 20 74 65 73 74 2d 69 64 29 29 stname test-id))
159b0 29 0a 20 20 0a 3b 3b 20 54 68 69 73 20 6f 6e 65 ). .;; This one
159c0 20 69 73 20 66 6f 72 20 72 75 6e 6e 69 6e 67 20 is for running
159d0 77 69 74 68 20 6e 6f 20 64 62 20 61 63 63 65 73 with no db acces
159e0 73 20 28 69 2e 65 2e 20 76 69 61 20 72 6d 74 3a s (i.e. via rmt:
159f0 20 69 6e 74 65 72 6e 61 6c 6c 79 29 0a 28 64 65 internally).(de
15a00 66 69 6e 65 20 28 74 65 73 74 73 3a 73 65 74 2d fine (tests:set-
15a10 66 75 6c 6c 2d 6d 65 74 61 2d 69 6e 66 6f 20 64 full-meta-info d
15a20 62 20 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 b test-id run-id
15a30 20 6d 69 6e 75 74 65 73 20 77 6f 72 6b 2d 61 72 minutes work-ar
15a40 65 61 20 72 65 6d 74 72 69 65 73 29 0a 3b 3b 20 ea remtries).;;
15a50 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 73 (define (tests:s
15a60 65 74 2d 66 75 6c 6c 2d 6d 65 74 61 2d 69 6e 66 et-full-meta-inf
15a70 6f 20 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 o test-id run-id
15a80 20 6d 69 6e 75 74 65 73 20 77 6f 72 6b 2d 61 72 minutes work-ar
15a90 65 61 29 0a 3b 3b 20 20 28 6c 65 74 20 28 28 72 ea).;; (let ((r
15aa0 65 6d 74 72 69 65 73 20 31 30 29 29 0a 20 20 28 emtries 10)). (
15ab0 6c 65 74 2a 20 28 28 63 70 75 6c 6f 61 64 20 20 let* ((cpuload
15ac0 28 67 65 74 2d 63 70 75 2d 6c 6f 61 64 29 29 0a (get-cpu-load)).
15ad0 09 20 28 64 69 73 6b 66 72 65 65 20 28 67 65 74 . (diskfree (get
15ae0 2d 64 66 20 28 63 75 72 72 65 6e 74 2d 64 69 72 -df (current-dir
15af0 65 63 74 6f 72 79 29 29 29 0a 09 20 28 75 6e 61 ectory))).. (una
15b00 6d 65 20 20 20 20 28 67 65 74 2d 75 6e 61 6d 65 me (get-uname
15b10 20 22 2d 73 72 76 70 69 6f 22 29 29 0a 09 20 28 "-srvpio")).. (
15b20 68 6f 73 74 6e 61 6d 65 20 28 67 65 74 2d 68 6f hostname (get-ho
15b30 73 74 2d 6e 61 6d 65 29 29 29 0a 20 20 20 20 28 st-name))). (
15b40 74 65 73 74 73 3a 75 70 64 61 74 65 2d 63 65 6e tests:update-cen
15b50 74 72 61 6c 2d 6d 65 74 61 2d 69 6e 66 6f 20 72 tral-meta-info r
15b60 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 63 70 un-id test-id cp
15b70 75 6c 6f 61 64 20 64 69 73 6b 66 72 65 65 20 6d uload diskfree m
15b80 69 6e 75 74 65 73 20 75 6e 61 6d 65 20 68 6f 73 inutes uname hos
15b90 74 6e 61 6d 65 29 29 29 0a 20 20 20 20 0a 3b 3b tname))). .;;
15ba0 20 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a (define (tests:
15bb0 73 65 74 2d 70 61 72 74 69 61 6c 2d 6d 65 74 61 set-partial-meta
15bc0 2d 69 6e 66 6f 20 74 65 73 74 2d 69 64 20 72 75 -info test-id ru
15bd0 6e 2d 69 64 20 6d 69 6e 75 74 65 73 20 77 6f 72 n-id minutes wor
15be0 6b 2d 61 72 65 61 29 0a 23 3b 28 64 65 66 69 6e k-area).#;(defin
15bf0 65 20 28 74 65 73 74 73 3a 73 65 74 2d 70 61 72 e (tests:set-par
15c00 74 69 61 6c 2d 6d 65 74 61 2d 69 6e 66 6f 20 74 tial-meta-info t
15c10 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 6d 69 est-id run-id mi
15c20 6e 75 74 65 73 20 77 6f 72 6b 2d 61 72 65 61 20 nutes work-area
15c30 72 65 6d 74 72 69 65 73 29 0a 20 20 28 6c 65 74 remtries). (let
15c40 2a 20 28 28 63 70 75 6c 6f 61 64 20 20 28 67 65 * ((cpuload (ge
15c50 74 2d 63 70 75 2d 6c 6f 61 64 29 29 0a 09 20 28 t-cpu-load)).. (
15c60 64 69 73 6b 66 72 65 65 20 28 67 65 74 2d 64 66 diskfree (get-df
15c70 20 28 63 75 72 72 65 6e 74 2d 64 69 72 65 63 74 (current-direct
15c80 6f 72 79 29 29 29 0a 09 20 28 72 65 6d 74 72 69 ory))).. (remtri
15c90 65 73 20 31 30 29 29 0a 20 20 20 20 28 68 61 6e es 10)). (han
15ca0 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 dle-exceptions.
15cb0 20 20 20 20 65 78 6e 0a 20 20 20 20 20 28 69 66 exn. (if
15cc0 20 28 3e 20 72 65 6d 74 72 69 65 73 20 30 29 0a (> remtries 0).
15cd0 09 20 28 62 65 67 69 6e 0a 09 20 20 20 28 70 72 . (begin.. (pr
15ce0 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 20 28 int-call-chain (
15cf0 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f current-error-po
15d00 72 74 29 29 0a 09 20 20 20 28 64 65 62 75 67 3a rt)).. (debug:
15d10 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 print-info 0 *de
15d20 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
15d30 22 57 41 52 4e 49 4e 47 3a 20 66 61 69 6c 65 64 "WARNING: failed
15d40 20 74 6f 20 73 65 74 20 6d 65 74 61 20 69 6e 66 to set meta inf
15d50 6f 2e 20 57 69 6c 6c 20 74 72 79 20 22 20 72 65 o. Will try " re
15d60 6d 74 72 69 65 73 20 22 20 6d 6f 72 65 20 74 69 mtries " more ti
15d70 6d 65 73 22 29 0a 09 20 20 20 28 73 65 74 21 20 mes").. (set!
15d80 72 65 6d 74 72 69 65 73 20 28 2d 20 72 65 6d 74 remtries (- remt
15d90 72 69 65 73 20 31 29 29 0a 09 20 20 20 28 74 68 ries 1)).. (th
15da0 72 65 61 64 2d 73 6c 65 65 70 21 20 31 30 29 0a read-sleep! 10).
15db0 09 20 20 20 28 74 65 73 74 73 3a 73 65 74 2d 66 . (tests:set-f
15dc0 75 6c 6c 2d 6d 65 74 61 2d 69 6e 66 6f 20 64 62 ull-meta-info db
15dd0 20 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 test-id run-id
15de0 6d 69 6e 75 74 65 73 20 77 6f 72 6b 2d 61 72 65 minutes work-are
15df0 61 20 28 2d 20 72 65 6d 74 72 69 65 73 20 31 29 a (- remtries 1)
15e00 29 29 0a 09 20 28 6c 65 74 20 28 28 65 72 72 2d )).. (let ((err-
15e10 73 74 61 74 75 73 20 28 28 63 6f 6e 64 69 74 69 status ((conditi
15e20 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 on-property-acce
15e30 73 73 6f 72 20 27 73 71 6c 69 74 65 33 20 27 73 ssor 'sqlite3 's
15e40 74 61 74 75 73 20 23 66 29 20 65 78 6e 29 29 29 tatus #f) exn)))
15e50 0a 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e .. (debug:prin
15e60 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 t-error 0 *defau
15e70 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 74 72 lt-log-port* "tr
15e80 69 65 64 20 66 6f 72 20 6f 76 65 72 20 61 20 6d ied for over a m
15e90 69 6e 75 74 65 20 74 6f 20 75 70 64 61 74 65 20 inute to update
15ea0 6d 65 74 61 20 69 6e 66 6f 20 61 6e 64 20 66 61 meta info and fa
15eb0 69 6c 65 64 2e 20 47 69 76 69 6e 67 20 75 70 22 iled. Giving up"
15ec0 29 0a 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 ).. (debug:pri
15ed0 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
15ee0 67 2d 70 6f 72 74 2a 20 22 45 58 43 45 50 54 49 g-port* "EXCEPTI
15ef0 4f 4e 3a 20 64 61 74 61 62 61 73 65 20 70 72 6f ON: database pro
15f00 62 61 62 6c 79 20 6f 76 65 72 6c 6f 61 64 65 64 bably overloaded
15f10 20 6f 72 20 75 6e 72 65 61 64 61 62 6c 65 2e 22 or unreadable."
15f20 29 0a 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 ).. (debug:pri
15f30 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
15f40 67 2d 70 6f 72 74 2a 20 22 20 6d 65 73 73 61 67 g-port* " messag
15f50 65 3a 20 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e e: " ((condition
15f60 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 -property-access
15f70 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 or 'exn 'message
15f80 29 20 65 78 6e 29 29 0a 09 20 20 20 28 64 65 62 ) exn)).. (deb
15f90 75 67 3a 70 72 69 6e 74 20 35 20 2a 64 65 66 61 ug:print 5 *defa
15fa0 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 65 ult-log-port* "e
15fb0 78 6e 3d 22 20 28 63 6f 6e 64 69 74 69 6f 6e 2d xn=" (condition-
15fc0 3e 6c 69 73 74 20 65 78 6e 29 29 0a 09 20 20 20 >list exn))..
15fd0 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
15fe0 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
15ff0 2a 20 22 20 73 74 61 74 75 73 3a 20 20 22 20 28 * " status: " (
16000 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 (condition-prope
16010 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 73 71 rty-accessor 'sq
16020 6c 69 74 65 33 20 27 73 74 61 74 75 73 29 20 65 lite3 'status) e
16030 78 6e 29 29 0a 09 20 20 20 28 70 72 69 6e 74 2d xn)).. (print-
16040 63 61 6c 6c 2d 63 68 61 69 6e 20 28 63 75 72 72 call-chain (curr
16050 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 ent-error-port))
16060 29 29 0a 20 20 20 20 20 28 74 65 73 74 73 3a 75 )). (tests:u
16070 70 64 61 74 65 2d 74 65 73 74 64 61 74 2d 6d 65 pdate-testdat-me
16080 74 61 2d 69 6e 66 6f 20 64 62 20 74 65 73 74 2d ta-info db test-
16090 69 64 20 77 6f 72 6b 2d 61 72 65 61 20 63 70 75 id work-area cpu
160a0 6c 6f 61 64 20 64 69 73 6b 66 72 65 65 20 6d 69 load diskfree mi
160b0 6e 75 74 65 73 29 0a 20 20 29 29 29 0a 09 20 0a nutes). ))).. .
160c0 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
160d0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
160e0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
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 0a 3b 3b 20 41 20 52 20 ========.;; A R
16110 43 20 48 20 49 20 56 20 49 20 4e 20 47 0a 3b 3b C H I V I N G.;;
16120 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
16130 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
16140 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
16150 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
16160 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 ======..(define
16170 28 74 65 73 74 3a 61 72 63 68 69 76 65 20 64 62 (test:archive db
16180 20 74 65 73 74 2d 69 64 29 0a 20 20 23 66 29 0a test-id). #f).
16190 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 3a 61 .(define (test:a
161a0 72 63 68 69 76 65 2d 74 65 73 74 73 20 64 62 20 rchive-tests db
161b0 6b 65 79 6e 61 6d 65 73 20 74 61 72 67 65 74 29 keynames target)
161c0 0a 20 20 23 66 29 0a 0a . #f)..