0000: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
0010: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0020: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0030: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0040: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 43 6f 70 79 ========.;; Copy
0050: 72 69 67 68 74 20 32 30 30 36 2d 32 30 31 33 2c right 2006-2013,
0060: 20 4d 61 74 74 68 65 77 20 57 65 6c 6c 61 6e 64 Matthew Welland
0070: 2e 0a 3b 3b 20 0a 3b 3b 20 54 68 69 73 20 66 69 ..;; .;; This fi
0080: 6c 65 20 69 73 20 70 61 72 74 20 6f 66 20 4d 65 le is part of Me
0090: 67 61 74 65 73 74 2e 0a 3b 3b 20 0a 3b 3b 20 20 gatest..;; .;;
00a0: 20 20 20 4d 65 67 61 74 65 73 74 20 69 73 20 66 Megatest is f
00b0: 72 65 65 20 73 6f 66 74 77 61 72 65 3a 20 79 6f ree software: yo
00c0: 75 20 63 61 6e 20 72 65 64 69 73 74 72 69 62 75 u can redistribu
00d0: 74 65 20 69 74 20 61 6e 64 2f 6f 72 20 6d 6f 64 te it and/or mod
00e0: 69 66 79 0a 3b 3b 20 20 20 20 20 69 74 20 75 6e ify.;; it un
00f0: 64 65 72 20 74 68 65 20 74 65 72 6d 73 20 6f 66 der the terms of
0100: 20 74 68 65 20 47 4e 55 20 47 65 6e 65 72 61 6c the GNU General
0110: 20 50 75 62 6c 69 63 20 4c 69 63 65 6e 73 65 20 Public License
0120: 61 73 20 70 75 62 6c 69 73 68 65 64 20 62 79 0a as published by.
0130: 3b 3b 20 20 20 20 20 74 68 65 20 46 72 65 65 20 ;; the Free
0140: 53 6f 66 74 77 61 72 65 20 46 6f 75 6e 64 61 74 Software Foundat
0150: 69 6f 6e 2c 20 65 69 74 68 65 72 20 76 65 72 73 ion, either vers
0160: 69 6f 6e 20 33 20 6f 66 20 74 68 65 20 4c 69 63 ion 3 of the Lic
0170: 65 6e 73 65 2c 20 6f 72 0a 3b 3b 20 20 20 20 20 ense, or.;;
0180: 28 61 74 20 79 6f 75 72 20 6f 70 74 69 6f 6e 29 (at your option)
0190: 20 61 6e 79 20 6c 61 74 65 72 20 76 65 72 73 69 any later versi
01a0: 6f 6e 2e 0a 3b 3b 20 0a 3b 3b 20 20 20 20 20 4d on..;; .;; M
01b0: 65 67 61 74 65 73 74 20 69 73 20 64 69 73 74 72 egatest is distr
01c0: 69 62 75 74 65 64 20 69 6e 20 74 68 65 20 68 6f ibuted in the ho
01d0: 70 65 20 74 68 61 74 20 69 74 20 77 69 6c 6c 20 pe that it will
01e0: 62 65 20 75 73 65 66 75 6c 2c 0a 3b 3b 20 20 20 be useful,.;;
01f0: 20 20 62 75 74 20 57 49 54 48 4f 55 54 20 41 4e but WITHOUT AN
0200: 59 20 57 41 52 52 41 4e 54 59 3b 20 77 69 74 68 Y WARRANTY; with
0210: 6f 75 74 20 65 76 65 6e 20 74 68 65 20 69 6d 70 out even the imp
0220: 6c 69 65 64 20 77 61 72 72 61 6e 74 79 20 6f 66 lied warranty of
0230: 0a 3b 3b 20 20 20 20 20 4d 45 52 43 48 41 4e 54 .;; MERCHANT
0240: 41 42 49 4c 49 54 59 20 6f 72 20 46 49 54 4e 45 ABILITY or FITNE
0250: 53 53 20 46 4f 52 20 41 20 50 41 52 54 49 43 55 SS FOR A PARTICU
0260: 4c 41 52 20 50 55 52 50 4f 53 45 2e 20 20 53 65 LAR PURPOSE. Se
0270: 65 20 74 68 65 0a 3b 3b 20 20 20 20 20 47 4e 55 e the.;; GNU
0280: 20 47 65 6e 65 72 61 6c 20 50 75 62 6c 69 63 20 General Public
0290: 4c 69 63 65 6e 73 65 20 66 6f 72 20 6d 6f 72 65 License for more
02a0: 20 64 65 74 61 69 6c 73 2e 0a 3b 3b 20 0a 3b 3b details..;; .;;
02b0: 20 20 20 20 20 59 6f 75 20 73 68 6f 75 6c 64 20 You should
02c0: 68 61 76 65 20 72 65 63 65 69 76 65 64 20 61 20 have received a
02d0: 63 6f 70 79 20 6f 66 20 74 68 65 20 47 4e 55 20 copy of the GNU
02e0: 47 65 6e 65 72 61 6c 20 50 75 62 6c 69 63 20 4c General Public L
02f0: 69 63 65 6e 73 65 0a 3b 3b 20 20 20 20 20 61 6c icense.;; al
0300: 6f 6e 67 20 77 69 74 68 20 4d 65 67 61 74 65 73 ong with Megates
0310: 74 2e 20 20 49 66 20 6e 6f 74 2c 20 73 65 65 20 t. If not, see
0320: 3c 68 74 74 70 3a 2f 2f 77 77 77 2e 67 6e 75 2e <http://www.gnu.
0330: 6f 72 67 2f 6c 69 63 65 6e 73 65 73 2f 3e 2e 0a org/licenses/>..
0340: 3b 3b 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;.;;===========
0350: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0360: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0370: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0380: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 3d ===========..;;=
0390: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
03a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
03b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
03c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
03d0: 3d 3d 3d 3d 3d 0a 3b 3b 20 54 65 73 74 73 0a 3b =====.;; Tests.;
03e0: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
03f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0400: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0410: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0420: 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 63 6c 61 72 =======..(declar
0430: 65 20 28 75 6e 69 74 20 74 65 73 74 73 29 29 0a e (unit tests)).
0440: 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 6c (declare (uses l
0450: 6f 63 6b 2d 71 75 65 75 65 29 29 0a 28 64 65 63 ock-queue)).(dec
0460: 6c 61 72 65 20 28 75 73 65 73 20 64 62 29 29 0a lare (uses db)).
0470: 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 74 (declare (uses t
0480: 64 62 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 db)).(declare (u
0490: 73 65 73 20 63 6f 6d 6d 6f 6e 29 29 0a 3b 3b 20 ses common)).;;
04a0: 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 64 (declare (uses d
04b0: 63 6f 6d 6d 6f 6e 29 29 20 3b 3b 20 6e 65 65 64 common)) ;; need
04c0: 65 64 20 66 6f 72 20 74 68 65 20 73 74 65 70 73 ed for the steps
04d0: 20 70 72 6f 63 65 73 73 69 6e 67 0a 28 64 65 63 processing.(dec
04e0: 6c 61 72 65 20 28 75 73 65 73 20 69 74 65 6d 73 lare (uses items
04f0: 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 )).(declare (use
0500: 73 20 72 75 6e 63 6f 6e 66 69 67 29 29 0a 3b 3b s runconfig)).;;
0510: 20 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 (declare (uses
0520: 73 64 62 29 29 0a 28 64 65 63 6c 61 72 65 20 28 sdb)).(declare (
0530: 75 73 65 73 20 73 65 72 76 65 72 29 29 0a 28 64 uses server)).(d
0540: 65 63 6c 61 72 65 20 28 75 73 65 73 20 73 74 6d eclare (uses stm
0550: 6c 32 29 29 0a 0a 28 75 73 65 20 73 71 6c 69 74 l2))..(use sqlit
0560: 65 33 20 73 72 66 69 2d 31 20 70 6f 73 69 78 20 e3 srfi-1 posix
0570: 72 65 67 65 78 20 72 65 67 65 78 2d 63 61 73 65 regex regex-case
0580: 20 73 72 66 69 2d 36 39 20 64 6f 74 2d 6c 6f 63 srfi-69 dot-loc
0590: 6b 69 6e 67 20 74 63 70 20 64 69 72 65 63 74 6f king tcp directo
05a0: 72 79 2d 75 74 69 6c 73 29 0a 28 69 6d 70 6f 72 ry-utils).(impor
05b0: 74 20 28 70 72 65 66 69 78 20 73 71 6c 69 74 65 t (prefix sqlite
05c0: 33 20 73 71 6c 69 74 65 33 3a 29 29 0a 28 72 65 3 sqlite3:)).(re
05d0: 71 75 69 72 65 2d 6c 69 62 72 61 72 79 20 73 74 quire-library st
05e0: 6d 6c 32 29 0a 0a 28 69 6e 63 6c 75 64 65 20 22 ml2)..(include "
05f0: 63 6f 6d 6d 6f 6e 5f 72 65 63 6f 72 64 73 2e 73 common_records.s
0600: 63 6d 22 29 0a 28 69 6e 63 6c 75 64 65 20 22 6b cm").(include "k
0610: 65 79 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 ey_records.scm")
0620: 0a 28 69 6e 63 6c 75 64 65 20 22 64 62 5f 72 65 .(include "db_re
0630: 63 6f 72 64 73 2e 73 63 6d 22 29 0a 28 69 6e 63 cords.scm").(inc
0640: 6c 75 64 65 20 22 72 75 6e 5f 72 65 63 6f 72 64 lude "run_record
0650: 73 2e 73 63 6d 22 29 0a 28 69 6e 63 6c 75 64 65 s.scm").(include
0660: 20 22 74 65 73 74 5f 72 65 63 6f 72 64 73 2e 73 "test_records.s
0670: 63 6d 22 29 0a 28 69 6e 63 6c 75 64 65 20 22 6a cm").(include "j
0680: 73 2d 70 61 74 68 2e 73 63 6d 22 29 0a 0a 28 64 s-path.scm")..(d
0690: 65 66 69 6e 65 20 28 69 6e 69 74 2d 6a 61 76 61 efine (init-java
06a0: 2d 73 63 72 69 70 74 2d 6c 69 62 29 0a 20 20 28 -script-lib). (
06b0: 73 65 74 21 20 2a 6a 61 76 61 2d 73 63 72 69 70 set! *java-scrip
06c0: 74 2d 6c 69 62 2a 20 28 63 6f 6e 63 20 20 28 63 t-lib* (conc (c
06d0: 6f 6d 6d 6f 6e 3a 67 65 74 2d 69 6e 73 74 61 6c ommon:get-instal
06e0: 6c 2d 61 72 65 61 29 20 22 2f 73 68 61 72 65 2f l-area) "/share/
06f0: 6a 73 2f 6a 71 75 65 72 79 2d 33 2e 31 2e 30 2e js/jquery-3.1.0.
0700: 73 6c 69 6d 2e 6d 69 6e 2e 6a 73 22 29 29 0a 20 slim.min.js")).
0710: 20 29 0a 0a 3b 3b 20 43 61 6c 6c 20 74 68 69 73 )..;; Call this
0720: 20 6f 6e 65 20 74 6f 20 64 6f 20 61 6c 6c 20 74 one to do all t
0730: 68 65 20 77 6f 72 6b 20 61 6e 64 20 67 65 74 20 he work and get
0740: 61 20 73 74 61 6e 64 61 72 64 69 7a 65 64 20 6c a standardized l
0750: 69 73 74 20 6f 66 20 74 65 73 74 73 0a 3b 3b 20 ist of tests.;;
0760: 20 20 67 65 74 73 20 70 61 74 68 73 20 66 72 6f gets paths fro
0770: 6d 20 63 6f 6e 66 69 67 73 20 61 6e 64 20 66 69 m configs and fi
0780: 6e 64 73 20 76 61 6c 69 64 20 74 65 73 74 73 20 nds valid tests
0790: 0a 3b 3b 20 20 20 72 65 74 75 72 6e 73 20 68 61 .;; returns ha
07a0: 73 68 20 6f 66 20 74 65 73 74 6e 61 6d 65 20 2d sh of testname -
07b0: 2d 3e 20 66 75 6c 6c 70 61 74 68 0a 3b 3b 0a 28 -> fullpath.;;.(
07c0: 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 67 65 define (tests:ge
07d0: 74 2d 61 6c 6c 29 0a 20 20 28 6c 65 74 2a 20 28 t-all). (let* (
07e0: 28 74 65 73 74 2d 73 65 61 72 63 68 2d 70 61 74 (test-search-pat
07f0: 68 20 20 20 28 74 65 73 74 73 3a 67 65 74 2d 74 h (tests:get-t
0800: 65 73 74 73 2d 73 65 61 72 63 68 2d 70 61 74 68 ests-search-path
0810: 20 2a 63 6f 6e 66 69 67 64 61 74 2a 29 29 29 0a *configdat*))).
0820: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
0830: 20 38 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 8 *default-log-
0840: 70 6f 72 74 2a 20 22 74 65 73 74 2d 73 65 61 72 port* "test-sear
0850: 63 68 2d 70 61 74 68 3a 20 22 20 74 65 73 74 2d ch-path: " test-
0860: 73 65 61 72 63 68 2d 70 61 74 68 29 0a 20 20 20 search-path).
0870: 20 28 74 65 73 74 73 3a 67 65 74 2d 76 61 6c 69 (tests:get-vali
0880: 64 2d 74 65 73 74 73 20 28 6d 61 6b 65 2d 68 61 d-tests (make-ha
0890: 73 68 2d 74 61 62 6c 65 29 20 74 65 73 74 2d 73 sh-table) test-s
08a0: 65 61 72 63 68 2d 70 61 74 68 29 29 29 0a 0a 28 earch-path)))..(
08b0: 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 67 65 define (tests:ge
08c0: 74 2d 74 65 73 74 73 2d 73 65 61 72 63 68 2d 70 t-tests-search-p
08d0: 61 74 68 20 63 66 67 64 61 74 29 0a 20 20 28 6c ath cfgdat). (l
08e0: 65 74 20 28 28 70 61 74 68 73 20 28 6c 65 74 20 et ((paths (let
08f0: 28 28 73 65 63 74 69 6f 6e 20 28 69 66 20 63 66 ((section (if cf
0900: 67 64 61 74 0a 09 09 09 09 20 20 28 63 6f 6e 66 gdat..... (conf
0910: 69 67 66 3a 67 65 74 2d 73 65 63 74 69 6f 6e 20 igf:get-section
0920: 63 66 67 64 61 74 20 22 74 65 73 74 73 2d 70 61 cfgdat "tests-pa
0930: 74 68 73 22 29 0a 09 09 09 09 20 20 23 66 29 29 ths")..... #f))
0940: 29 0a 09 09 20 28 69 66 20 73 65 63 74 69 6f 6e )... (if section
0950: 0a 09 09 20 20 20 20 20 28 6d 61 70 20 63 61 64 ... (map cad
0960: 72 20 73 65 63 74 69 6f 6e 29 0a 09 09 20 20 20 r section)...
0970: 20 20 27 28 29 29 29 29 29 0a 20 20 20 20 28 66 '())))). (f
0980: 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 64 ilter (lambda (d
0990: 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 64 69 ).. (if (di
09a0: 72 65 63 74 6f 72 79 2d 65 78 69 73 74 73 3f 20 rectory-exists?
09b0: 64 29 0a 09 09 20 20 64 0a 09 09 20 20 28 62 65 d)... d... (be
09c0: 67 69 6e 0a 09 09 20 20 20 20 3b 3b 20 28 69 66 gin... ;; (if
09d0: 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 (common:low-noi
09e0: 73 65 2d 70 72 69 6e 74 20 36 30 20 22 74 65 73 se-print 60 "tes
09f0: 74 73 3a 67 65 74 2d 74 65 73 74 73 2d 73 65 61 ts:get-tests-sea
0a00: 72 63 68 2d 70 61 74 68 22 20 64 29 0a 09 09 20 rch-path" d)...
0a10: 20 20 20 3b 3b 09 28 64 65 62 75 67 3a 70 72 69 ;;.(debug:pri
0a20: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
0a30: 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 g-port* "WARNING
0a40: 3a 20 70 72 6f 62 6c 65 6d 20 77 69 74 68 20 64 : problem with d
0a50: 69 72 65 63 74 6f 72 79 20 22 20 64 20 22 2c 20 irectory " d ",
0a60: 64 72 6f 70 70 69 6e 67 20 69 74 20 66 72 6f 6d dropping it from
0a70: 20 74 65 73 74 73 20 70 61 74 68 22 29 29 0a 09 tests path"))..
0a80: 09 20 20 20 20 23 66 29 29 29 0a 09 20 20 20 20 . #f)))..
0a90: 28 61 70 70 65 6e 64 20 70 61 74 68 73 20 28 6c (append paths (l
0aa0: 69 73 74 20 28 63 6f 6e 63 20 2a 74 6f 70 70 61 ist (conc *toppa
0ab0: 74 68 2a 20 22 2f 74 65 73 74 73 22 29 29 29 29 th* "/tests"))))
0ac0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 ))..(define (tes
0ad0: 74 73 3a 67 65 74 2d 76 61 6c 69 64 2d 74 65 73 ts:get-valid-tes
0ae0: 74 73 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 ts test-registry
0af0: 20 74 65 73 74 73 2d 70 61 74 68 73 29 0a 20 20 tests-paths).
0b00: 28 69 66 20 28 6e 75 6c 6c 3f 20 74 65 73 74 73 (if (null? tests
0b10: 2d 70 61 74 68 73 29 20 0a 20 20 20 20 20 20 74 -paths) . t
0b20: 65 73 74 2d 72 65 67 69 73 74 72 79 0a 20 20 20 est-registry.
0b30: 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 (let loop ((h
0b40: 65 64 20 28 63 61 72 20 74 65 73 74 73 2d 70 61 ed (car tests-pa
0b50: 74 68 73 29 29 0a 09 09 20 28 74 61 6c 20 28 63 ths))... (tal (c
0b60: 64 72 20 74 65 73 74 73 2d 70 61 74 68 73 29 29 dr tests-paths))
0b70: 29 0a 09 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 66 )..(if (common:f
0b80: 69 6c 65 2d 65 78 69 73 74 73 3f 20 68 65 64 29 ile-exists? hed)
0b90: 0a 09 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 .. (for-each
0ba0: 28 6c 61 6d 62 64 61 20 28 74 65 73 74 2d 70 61 (lambda (test-pa
0bb0: 74 68 29 0a 09 09 09 28 6c 65 74 2a 20 28 28 74 th)....(let* ((t
0bc0: 6e 61 6d 65 20 20 20 28 6c 61 73 74 20 28 73 74 name (last (st
0bd0: 72 69 6e 67 2d 73 70 6c 69 74 20 74 65 73 74 2d ring-split test-
0be0: 70 61 74 68 20 22 2f 22 29 29 29 0a 09 09 09 20 path "/")))....
0bf0: 20 20 20 20 20 20 28 74 63 6f 6e 66 69 67 20 28 (tconfig (
0c00: 63 6f 6e 63 20 74 65 73 74 2d 70 61 74 68 20 22 conc test-path "
0c10: 2f 74 65 73 74 63 6f 6e 66 69 67 22 29 29 29 0a /testconfig"))).
0c20: 09 09 09 20 20 28 69 66 20 28 61 6e 64 20 28 6e ... (if (and (n
0c30: 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 ot (hash-table-r
0c40: 65 66 2f 64 65 66 61 75 6c 74 20 74 65 73 74 2d ef/default test-
0c50: 72 65 67 69 73 74 72 79 20 74 6e 61 6d 65 20 23 registry tname #
0c60: 66 29 29 0a 09 09 09 09 20 20 20 28 63 6f 6d 6d f))..... (comm
0c70: 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 on:file-exists?
0c80: 74 63 6f 6e 66 69 67 29 29 0a 09 09 09 20 20 20 tconfig))....
0c90: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 (hash-table-s
0ca0: 65 74 21 20 74 65 73 74 2d 72 65 67 69 73 74 72 et! test-registr
0cb0: 79 20 74 6e 61 6d 65 20 74 65 73 74 2d 70 61 74 y tname test-pat
0cc0: 68 29 29 29 29 0a 09 09 20 20 20 20 20 20 28 67 h))))... (g
0cd0: 6c 6f 62 20 28 63 6f 6e 63 20 68 65 64 20 22 2f lob (conc hed "/
0ce0: 2a 22 29 29 29 29 0a 09 28 69 66 20 28 6e 75 6c *"))))..(if (nul
0cf0: 6c 3f 20 74 61 6c 29 0a 09 20 20 20 20 74 65 73 l? tal).. tes
0d00: 74 2d 72 65 67 69 73 74 72 79 0a 09 20 20 20 20 t-registry..
0d10: 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 (loop (car tal)(
0d20: 63 64 72 20 74 61 6c 29 29 29 29 29 29 0a 0a 28 cdr tal))))))..(
0d30: 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 66 69 define (tests:fi
0d40: 6c 74 65 72 2d 74 65 73 74 2d 6e 61 6d 65 73 2d lter-test-names-
0d50: 6e 6f 74 2d 6d 61 74 63 68 65 64 20 74 65 73 74 not-matched test
0d60: 2d 6e 61 6d 65 73 20 74 65 73 74 2d 70 61 74 74 -names test-patt
0d70: 73 29 0a 20 20 28 64 65 6c 65 74 65 2d 64 75 70 s). (delete-dup
0d80: 6c 69 63 61 74 65 73 0a 20 20 20 28 66 69 6c 74 licates. (filt
0d90: 65 72 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 er (lambda (test
0da0: 6e 61 6d 65 29 0a 09 20 20 20 20 20 28 6e 6f 74 name).. (not
0db0: 20 28 74 65 73 74 73 3a 6d 61 74 63 68 20 74 65 (tests:match te
0dc0: 73 74 2d 70 61 74 74 73 20 74 65 73 74 6e 61 6d st-patts testnam
0dd0: 65 20 23 66 29 29 29 0a 09 20 20 20 74 65 73 74 e #f))).. test
0de0: 2d 6e 61 6d 65 73 29 29 29 0a 0a 0a 28 64 65 66 -names)))...(def
0df0: 69 6e 65 20 28 74 65 73 74 73 3a 66 69 6c 74 65 ine (tests:filte
0e00: 72 2d 74 65 73 74 2d 6e 61 6d 65 73 20 74 65 73 r-test-names tes
0e10: 74 2d 6e 61 6d 65 73 20 74 65 73 74 2d 70 61 74 t-names test-pat
0e20: 74 73 29 0a 20 20 28 64 65 6c 65 74 65 2d 64 75 ts). (delete-du
0e30: 70 6c 69 63 61 74 65 73 0a 20 20 20 28 66 69 6c plicates. (fil
0e40: 74 65 72 20 28 6c 61 6d 62 64 61 20 28 74 65 73 ter (lambda (tes
0e50: 74 6e 61 6d 65 29 0a 09 20 20 20 20 20 28 74 65 tname).. (te
0e60: 73 74 73 3a 6d 61 74 63 68 20 74 65 73 74 2d 70 sts:match test-p
0e70: 61 74 74 73 20 74 65 73 74 6e 61 6d 65 20 23 66 atts testname #f
0e80: 29 29 0a 09 20 20 20 74 65 73 74 2d 6e 61 6d 65 )).. test-name
0e90: 73 29 29 29 0a 0a 3b 3b 20 69 74 65 6d 6d 61 70 s)))..;; itemmap
0ea0: 20 69 73 20 61 20 6c 69 73 74 20 6f 66 20 74 65 is a list of te
0eb0: 73 74 6e 61 6d 65 20 70 61 74 74 65 72 6e 73 20 stname patterns
0ec0: 74 6f 20 6d 61 70 73 0a 3b 3b 20 20 20 20 20 74 to maps.;; t
0ed0: 65 73 74 31 20 2e 2a 2f 62 61 72 2f 28 5c 64 2b est1 .*/bar/(\d+
0ee0: 29 20 66 6f 6f 2f 5c 31 0a 3b 3b 20 20 20 20 20 ) foo/\1.;;
0ef0: 25 20 20 20 20 20 66 6f 6f 2f 28 5b 5e 2f 5d 2b % foo/([^/]+
0f00: 29 20 20 5c 31 2f 62 61 72 0a 3b 3b 0a 3b 3b 20 ) \1/bar.;;.;;
0f10: 23 20 4e 4f 54 45 3a 20 74 68 65 20 6c 69 6e 65 # NOTE: the line
0f20: 20 77 69 74 68 20 74 68 65 20 73 69 6e 67 6c 65 with the single
0f30: 20 25 20 63 6f 75 6c 64 20 62 65 20 74 68 65 20 % could be the
0f40: 72 65 73 75 6c 74 20 6f 66 0a 3b 3b 20 23 20 20 result of.;; #
0f50: 20 20 20 20 20 69 74 65 6d 6d 61 70 20 65 6e 74 itemmap ent
0f60: 72 79 20 69 6e 20 72 65 71 75 69 72 65 6d 65 6e ry in requiremen
0f70: 74 73 20 28 6c 65 67 61 63 79 29 2e 20 54 68 65 ts (legacy). The
0f80: 20 69 74 65 6d 6d 61 70 0a 3b 3b 20 23 20 20 20 itemmap.;; #
0f90: 20 20 20 20 72 65 71 75 69 72 65 6d 65 6e 74 73 requirements
0fa0: 20 65 6e 74 72 79 20 69 73 20 64 65 70 72 65 63 entry is deprec
0fb0: 61 74 65 64 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 ated.;;.(define
0fc0: 28 74 65 73 74 73 3a 67 65 74 2d 69 74 65 6d 6d (tests:get-itemm
0fd0: 61 70 73 20 74 63 6f 6e 66 69 67 29 0a 20 20 28 aps tconfig). (
0fe0: 6c 65 74 20 28 28 62 61 73 65 2d 69 74 65 6d 6d let ((base-itemm
0ff0: 61 70 20 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f ap (configf:loo
1000: 6b 75 70 20 74 63 6f 6e 66 69 67 20 22 72 65 71 kup tconfig "req
1010: 75 69 72 65 6d 65 6e 74 73 22 20 22 69 74 65 6d uirements" "item
1020: 6d 61 70 22 29 29 0a 09 28 69 74 65 6d 6d 61 70 map"))..(itemmap
1030: 2d 74 61 62 6c 65 20 28 63 6f 6e 66 69 67 66 3a -table (configf:
1040: 67 65 74 2d 73 65 63 74 69 6f 6e 20 74 63 6f 6e get-section tcon
1050: 66 69 67 20 22 69 74 65 6d 6d 61 70 22 29 29 29 fig "itemmap")))
1060: 0a 20 20 20 20 28 61 70 70 65 6e 64 20 28 69 66 . (append (if
1070: 20 62 61 73 65 2d 69 74 65 6d 6d 61 70 0a 09 09 base-itemmap...
1080: 28 6c 69 73 74 20 28 6c 69 73 74 20 22 25 22 20 (list (list "%"
1090: 62 61 73 65 2d 69 74 65 6d 6d 61 70 29 29 0a 09 base-itemmap))..
10a0: 09 27 28 29 29 0a 09 20 20 20 20 28 69 66 20 69 .'()).. (if i
10b0: 74 65 6d 6d 61 70 2d 74 61 62 6c 65 0a 09 09 69 temmap-table...i
10c0: 74 65 6d 6d 61 70 2d 74 61 62 6c 65 0a 09 09 27 temmap-table...'
10d0: 28 29 29 29 29 29 0a 0a 3b 3b 20 67 69 76 65 6e ()))))..;; given
10e0: 20 61 20 6c 69 73 74 20 6f 66 20 69 74 65 6d 6d a list of itemm
10f0: 61 70 73 20 28 74 65 73 74 6e 61 6d 65 20 2e 20 aps (testname .
1100: 6d 61 70 29 2c 20 72 65 74 75 72 6e 20 74 68 65 map), return the
1110: 20 66 69 72 73 74 20 6d 61 74 63 68 0a 3b 3b 0a first match.;;.
1120: 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 6c (define (tests:l
1130: 6f 6f 6b 75 70 2d 69 74 65 6d 6d 61 70 20 69 74 ookup-itemmap it
1140: 65 6d 6d 61 70 73 20 74 65 73 74 6e 61 6d 65 29 emmaps testname)
1150: 0a 20 20 28 6c 65 74 20 28 28 62 65 73 74 2d 6d . (let ((best-m
1160: 61 74 63 68 65 73 20 28 66 69 6c 74 65 72 20 28 atches (filter (
1170: 6c 61 6d 62 64 61 20 28 69 74 65 6d 6d 61 70 29 lambda (itemmap)
1180: 0a 09 09 09 09 28 74 65 73 74 73 3a 6d 61 74 63 .....(tests:matc
1190: 68 20 28 63 61 72 20 69 74 65 6d 6d 61 70 29 20 h (car itemmap)
11a0: 74 65 73 74 6e 61 6d 65 20 23 66 29 29 0a 09 09 testname #f))...
11b0: 09 20 20 20 20 20 20 69 74 65 6d 6d 61 70 73 29 . itemmaps)
11c0: 29 29 0a 20 20 20 20 28 69 66 20 28 6e 75 6c 6c )). (if (null
11d0: 3f 20 62 65 73 74 2d 6d 61 74 63 68 65 73 29 0a ? best-matches).
11e0: 09 23 66 0a 09 28 6c 65 74 20 28 28 72 65 73 20 .#f..(let ((res
11f0: 28 63 61 72 20 62 65 73 74 2d 6d 61 74 63 68 65 (car best-matche
1200: 73 29 29 29 0a 09 20 20 3b 3b 20 28 64 65 62 75 s))).. ;; (debu
1210: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
1220: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 65 lt-log-port* "re
1230: 73 3d 22 20 72 65 73 29 0a 09 20 20 28 63 6f 6e s=" res).. (con
1240: 64 0a 09 20 20 20 28 28 73 74 72 69 6e 67 3f 20 d.. ((string?
1250: 72 65 73 29 20 72 65 73 29 20 3b 3b 3b 20 46 49 res) res) ;;; FI
1260: 58 20 54 48 45 20 52 4f 4f 54 20 43 41 55 53 45 X THE ROOT CAUSE
1270: 20 48 45 52 45 20 2e 2e 2e 2e 0a 09 20 20 20 28 HERE ...... (
1280: 28 6e 75 6c 6c 3f 20 72 65 73 29 20 20 20 23 66 (null? res) #f
1290: 29 0a 09 20 20 20 28 28 73 74 72 69 6e 67 3f 20 ).. ((string?
12a0: 28 63 64 72 20 72 65 73 29 29 20 28 63 64 72 20 (cdr res)) (cdr
12b0: 72 65 73 29 29 20 20 3b 3b 20 69 74 20 69 73 20 res)) ;; it is
12c0: 61 20 70 61 69 72 0a 09 20 20 20 28 28 73 74 72 a pair.. ((str
12d0: 69 6e 67 3f 20 28 63 61 64 72 20 72 65 73 29 29 ing? (cadr res))
12e0: 28 63 61 64 72 20 72 65 73 29 29 20 3b 3b 20 69 (cadr res)) ;; i
12f0: 74 20 69 73 20 61 20 6c 69 73 74 0a 09 20 20 20 t is a list..
1300: 28 65 6c 73 65 20 63 61 64 72 20 72 65 73 29 29 (else cadr res))
1310: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 ))))..(define (t
1320: 65 73 74 73 3a 67 65 74 2d 67 6c 6f 62 61 6c 2d ests:get-global-
1330: 77 61 69 74 6f 6e 73 20 72 63 6f 6e 66 69 67 29 waitons rconfig)
1340: 0a 20 20 28 6c 65 74 2a 20 28 28 67 6c 6f 62 61 . (let* ((globa
1350: 6c 2d 77 61 69 74 6f 6e 73 20 28 72 75 6e 63 6f l-waitons (runco
1360: 6e 66 69 67 73 2d 67 65 74 20 72 63 6f 6e 66 69 nfigs-get rconfi
1370: 67 20 22 21 47 4c 4f 42 41 4c 5f 57 41 49 54 4f g "!GLOBAL_WAITO
1380: 4e 53 22 29 29 29 0a 20 20 20 20 28 69 66 20 28 NS"))). (if (
1390: 73 74 72 69 6e 67 3f 20 67 6c 6f 62 61 6c 2d 77 string? global-w
13a0: 61 69 74 6f 6e 73 29 0a 09 28 73 74 72 69 6e 67 aitons)..(string
13b0: 2d 73 70 6c 69 74 20 67 6c 6f 62 61 6c 2d 77 61 -split global-wa
13c0: 69 74 6f 6e 73 29 0a 09 27 28 29 29 29 29 0a 0a itons)..'())))..
13d0: 3b 3b 20 72 65 74 75 72 6e 20 69 74 65 6d 73 20 ;; return items
13e0: 67 69 76 65 6e 20 63 6f 6e 66 69 67 0a 3b 3b 0a given config.;;.
13f0: 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 67 (define (tests:g
1400: 65 74 2d 69 74 65 6d 73 20 74 63 6f 6e 66 69 67 et-items tconfig
1410: 29 0a 20 20 28 6c 65 74 20 28 28 69 74 65 6d 73 ). (let ((items
1420: 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c (hash-tabl
1430: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 63 e-ref/default tc
1440: 6f 6e 66 69 67 20 22 69 74 65 6d 73 22 20 23 66 onfig "items" #f
1450: 29 29 20 3b 3b 20 69 74 65 6d 73 20 34 0a 09 28 )) ;; items 4..(
1460: 69 74 65 6d 73 74 61 62 6c 65 20 28 68 61 73 68 itemstable (hash
1470: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
1480: 6c 74 20 74 63 6f 6e 66 69 67 20 22 69 74 65 6d lt tconfig "item
1490: 73 74 61 62 6c 65 22 20 23 66 29 29 29 20 0a 20 stable" #f))) .
14a0: 20 20 20 3b 3b 20 69 66 20 65 69 74 68 65 72 20 ;; if either
14b0: 69 74 65 6d 73 20 6f 72 20 69 74 65 6d 73 20 74 items or items t
14c0: 61 62 6c 65 20 69 73 20 61 20 70 72 6f 63 20 72 able is a proc r
14d0: 65 74 75 72 6e 20 69 74 20 73 6f 20 74 65 73 74 eturn it so test
14e0: 20 72 75 6e 6e 69 6e 67 0a 20 20 20 20 3b 3b 20 running. ;;
14f0: 70 72 6f 63 65 73 73 20 63 61 6e 20 6b 6e 6f 77 process can know
1500: 20 74 6f 20 63 61 6c 6c 20 69 74 65 6d 73 3a 67 to call items:g
1510: 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f et-items-from-co
1520: 6e 66 69 67 0a 20 20 20 20 3b 3b 20 69 66 20 65 nfig. ;; if e
1530: 69 74 68 65 72 20 69 73 20 61 20 6c 69 73 74 20 ither is a list
1540: 61 6e 64 20 6e 6f 6e 65 20 69 73 20 61 20 70 72 and none is a pr
1550: 6f 63 20 67 6f 20 61 68 65 61 64 20 61 6e 64 20 oc go ahead and
1560: 63 61 6c 6c 20 67 65 74 2d 69 74 65 6d 73 0a 20 call get-items.
1570: 20 20 20 3b 3b 20 6f 74 68 65 72 77 69 73 65 20 ;; otherwise
1580: 72 65 74 75 72 6e 20 23 66 20 2d 20 74 68 69 73 return #f - this
1590: 20 69 73 20 6e 6f 74 20 61 6e 20 69 74 65 72 61 is not an itera
15a0: 74 65 64 20 74 65 73 74 0a 20 20 20 20 28 63 6f ted test. (co
15b0: 6e 64 0a 20 20 20 20 20 28 28 70 72 6f 63 65 64 nd. ((proced
15c0: 75 72 65 3f 20 69 74 65 6d 73 29 20 20 20 20 20 ure? items)
15d0: 20 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 . (debug:p
15e0: 72 69 6e 74 2d 69 6e 66 6f 20 34 20 2a 64 65 66 rint-info 4 *def
15f0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
1600: 69 74 65 6d 73 20 69 73 20 61 20 70 72 6f 63 65 items is a proce
1610: 64 75 72 65 2c 20 77 69 6c 6c 20 63 61 6c 63 20 dure, will calc
1620: 6c 61 74 65 72 22 29 0a 20 20 20 20 20 20 69 74 later"). it
1630: 65 6d 73 29 20 20 20 20 20 20 20 20 20 20 20 20 ems)
1640: 3b 3b 20 63 61 6c 63 20 6c 61 74 65 72 0a 20 20 ;; calc later.
1650: 20 20 20 28 28 70 72 6f 63 65 64 75 72 65 3f 20 ((procedure?
1660: 69 74 65 6d 73 74 61 62 6c 65 29 0a 20 20 20 20 itemstable).
1670: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
1680: 6e 66 6f 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 4 *default-l
1690: 6f 67 2d 70 6f 72 74 2a 20 22 69 74 65 6d 73 74 og-port* "itemst
16a0: 61 62 6c 65 20 69 73 20 61 20 70 72 6f 63 65 64 able is a proced
16b0: 75 72 65 2c 20 77 69 6c 6c 20 63 61 6c 63 20 6c ure, will calc l
16c0: 61 74 65 72 22 29 0a 20 20 20 20 20 20 69 74 65 ater"). ite
16d0: 6d 73 74 61 62 6c 65 29 20 20 20 20 20 20 20 3b mstable) ;
16e0: 3b 20 63 61 6c 63 20 6c 61 74 65 72 0a 20 20 20 ; calc later.
16f0: 20 20 28 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 ((filter (lamb
1700: 64 61 20 28 78 29 0a 09 09 28 6c 65 74 20 28 28 da (x)...(let ((
1710: 76 61 6c 20 28 63 61 72 20 78 29 29 29 0a 09 09 val (car x)))...
1720: 20 20 28 69 66 20 28 70 72 6f 63 65 64 75 72 65 (if (procedure
1730: 3f 20 76 61 6c 29 20 76 61 6c 20 23 66 29 29 29 ? val) val #f)))
1740: 0a 09 20 20 20 20 20 20 28 61 70 70 65 6e 64 20 .. (append
1750: 28 69 66 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 (if (list? items
1760: 29 20 69 74 65 6d 73 20 27 28 29 29 0a 09 09 20 ) items '())...
1770: 20 20 20 20 20 28 69 66 20 28 6c 69 73 74 3f 20 (if (list?
1780: 69 74 65 6d 73 74 61 62 6c 65 29 20 69 74 65 6d itemstable) item
1790: 73 74 61 62 6c 65 20 27 28 29 29 29 29 0a 20 20 stable '()))).
17a0: 20 20 20 20 27 68 61 76 65 2d 70 72 6f 63 65 64 'have-proced
17b0: 75 72 65 29 0a 20 20 20 20 20 28 28 6f 72 20 28 ure). ((or (
17c0: 6c 69 73 74 3f 20 69 74 65 6d 73 29 28 6c 69 73 list? items)(lis
17d0: 74 3f 20 69 74 65 6d 73 74 61 62 6c 65 29 29 20 t? itemstable))
17e0: 3b 3b 20 63 61 6c 63 20 6e 6f 77 0a 20 20 20 20 ;; calc now.
17f0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
1800: 6e 66 6f 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 4 *default-l
1810: 6f 67 2d 70 6f 72 74 2a 20 22 69 74 65 6d 73 20 og-port* "items
1820: 61 6e 64 20 69 74 65 6d 73 74 61 62 6c 65 20 61 and itemstable a
1830: 72 65 20 6c 69 73 74 73 2c 20 63 61 6c 63 20 6e re lists, calc n
1840: 6f 77 5c 6e 22 0a 09 09 09 22 20 20 20 20 69 74 ow\n"...." it
1850: 65 6d 73 3a 20 22 20 69 74 65 6d 73 20 22 20 69 ems: " items " i
1860: 74 65 6d 73 74 61 62 6c 65 3a 20 22 20 69 74 65 temstable: " ite
1870: 6d 73 74 61 62 6c 65 29 0a 20 20 20 20 20 20 28 mstable). (
1880: 69 74 65 6d 73 3a 67 65 74 2d 69 74 65 6d 73 2d items:get-items-
1890: 66 72 6f 6d 2d 63 6f 6e 66 69 67 20 74 63 6f 6e from-config tcon
18a0: 66 69 67 29 29 0a 20 20 20 20 20 28 65 6c 73 65 fig)). (else
18b0: 20 23 66 29 29 29 29 20 20 20 20 20 20 20 20 20 #f))))
18c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
18d0: 20 20 3b 3b 20 6e 6f 74 20 69 74 65 72 61 74 65 ;; not iterate
18e0: 64 0a 0a 0a 3b 3b 20 72 65 74 75 72 6e 73 20 77 d...;; returns w
18f0: 61 69 74 6f 6e 73 20 77 61 69 74 6f 72 73 20 74 aitons waitors t
1900: 63 6f 6e 66 69 67 64 61 74 0a 3b 3b 0a 28 64 65 configdat.;;.(de
1910: 66 69 6e 65 20 28 74 65 73 74 73 3a 67 65 74 2d fine (tests:get-
1920: 77 61 69 74 6f 6e 73 20 74 65 73 74 2d 6e 61 6d waitons test-nam
1930: 65 20 61 6c 6c 2d 74 65 73 74 73 2d 72 65 67 69 e all-tests-regi
1940: 73 74 72 79 20 67 6c 6f 62 61 6c 2d 77 61 69 74 stry global-wait
1950: 6f 6e 73 29 0a 20 20 20 28 6c 65 74 2a 20 28 28 ons). (let* ((
1960: 63 6f 6e 66 69 67 20 20 28 74 65 73 74 73 3a 67 config (tests:g
1970: 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 74 65 et-testconfig te
1980: 73 74 2d 6e 61 6d 65 20 23 66 20 61 6c 6c 2d 74 st-name #f all-t
1990: 65 73 74 73 2d 72 65 67 69 73 74 72 79 20 27 72 ests-registry 'r
19a0: 65 74 75 72 6e 2d 70 72 6f 63 73 29 29 29 20 3b eturn-procs))) ;
19b0: 3b 20 61 73 73 75 6d 69 6e 67 20 6e 6f 20 70 72 ; assuming no pr
19c0: 6f 62 6c 65 6d 73 20 77 69 74 68 20 69 6d 6d 65 oblems with imme
19d0: 64 69 61 74 65 20 65 76 61 6c 75 61 74 69 6f 6e diate evaluation
19e0: 2c 20 74 68 69 73 20 63 6f 75 6c 64 20 62 65 20 , this could be
19f0: 73 69 6d 70 6c 69 66 69 65 64 20 28 27 72 65 74 simplified ('ret
1a00: 75 72 6e 2d 70 72 6f 63 73 20 2d 3e 20 23 74 29 urn-procs -> #t)
1a10: 0a 20 20 20 20 20 28 6c 65 74 20 28 28 69 6e 73 . (let ((ins
1a20: 74 72 20 28 69 66 20 63 6f 6e 66 69 67 20 0a 09 tr (if config ..
1a30: 09 20 20 20 20 20 20 28 63 6f 6e 66 69 67 66 3a . (configf:
1a40: 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 20 22 72 lookup config "r
1a50: 65 71 75 69 72 65 6d 65 6e 74 73 22 20 22 77 61 equirements" "wa
1a60: 69 74 6f 6e 22 29 0a 09 09 20 20 20 20 20 20 28 iton")... (
1a70: 62 65 67 69 6e 20 3b 3b 20 4e 6f 20 63 6f 6e 66 begin ;; No conf
1a80: 69 67 20 6d 65 61 6e 73 20 74 68 69 73 20 69 73 ig means this is
1a90: 20 61 20 6e 6f 6e 2d 65 78 69 73 74 61 6e 74 20 a non-existant
1aa0: 74 65 73 74 0a 09 09 09 28 64 65 62 75 67 3a 70 test....(debug:p
1ab0: 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 rint-error 0 *de
1ac0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
1ad0: 22 6e 6f 6e 2d 65 78 69 73 74 65 6e 74 20 72 65 "non-existent re
1ae0: 71 75 69 72 65 64 20 74 65 73 74 20 5c 22 22 20 quired test \""
1af0: 74 65 73 74 2d 6e 61 6d 65 20 22 5c 22 22 29 0a test-name "\"").
1b00: 09 09 09 28 65 78 69 74 20 31 29 29 29 29 0a 09 ...(exit 1))))..
1b10: 20 20 20 28 69 6e 73 74 72 32 20 28 69 66 20 63 (instr2 (if c
1b20: 6f 6e 66 69 67 0a 09 09 20 20 20 20 20 20 20 28 onfig... (
1b30: 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 63 configf:lookup c
1b40: 6f 6e 66 69 67 20 22 72 65 71 75 69 72 65 6d 65 onfig "requireme
1b50: 6e 74 73 22 20 22 77 61 69 74 6f 72 22 29 0a 09 nts" "waitor")..
1b60: 09 20 20 20 20 20 20 20 22 22 29 29 29 0a 20 20 . ""))).
1b70: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
1b80: 74 2d 69 6e 66 6f 20 38 20 2a 64 65 66 61 75 6c t-info 8 *defaul
1b90: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 77 61 69 t-log-port* "wai
1ba0: 74 6f 6e 73 20 73 74 72 69 6e 67 20 69 73 20 22 tons string is "
1bb0: 20 69 6e 73 74 72 20 22 2c 20 77 61 69 74 6f 72 instr ", waitor
1bc0: 73 20 73 74 72 69 6e 67 20 69 73 20 22 20 69 6e s string is " in
1bd0: 73 74 72 32 29 0a 20 20 20 20 20 20 20 28 6c 65 str2). (le
1be0: 74 2a 20 28 28 6e 65 77 77 61 69 74 6f 6e 73 2d t* ((newwaitons-
1bf0: 74 6d 70 0a 09 20 20 20 20 20 20 28 73 74 72 69 tmp.. (stri
1c00: 6e 67 2d 73 70 6c 69 74 20 28 63 6f 6e 64 0a 09 ng-split (cond..
1c10: 09 09 20 20 20 20 20 28 28 70 72 6f 63 65 64 75 .. ((procedu
1c20: 72 65 3f 20 69 6e 73 74 72 29 20 3b 3b 20 68 65 re? instr) ;; he
1c30: 72 65 20 0a 09 09 09 20 20 20 20 20 20 28 6c 65 re .... (le
1c40: 74 20 28 28 72 65 73 20 28 69 6e 73 74 72 29 29 t ((res (instr))
1c50: 29 0a 09 09 09 09 28 64 65 62 75 67 3a 70 72 69 ).....(debug:pri
1c60: 6e 74 2d 69 6e 66 6f 20 38 20 2a 64 65 66 61 75 nt-info 8 *defau
1c70: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 77 61 lt-log-port* "wa
1c80: 69 74 6f 6e 20 70 72 6f 63 65 64 75 72 65 20 72 iton procedure r
1c90: 65 73 75 6c 74 73 20 69 6e 20 73 74 72 69 6e 67 esults in string
1ca0: 20 22 20 72 65 73 20 22 20 66 6f 72 20 74 65 73 " res " for tes
1cb0: 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 29 0a 09 t " test-name)..
1cc0: 09 09 09 72 65 73 29 29 0a 09 09 09 20 20 20 20 ...res))....
1cd0: 20 28 28 73 74 72 69 6e 67 3f 20 69 6e 73 74 72 ((string? instr
1ce0: 29 20 20 20 20 20 69 6e 73 74 72 29 0a 09 09 09 ) instr)....
1cf0: 20 20 20 20 20 28 65 6c 73 65 20 0a 09 09 09 20 (else ....
1d00: 20 20 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 54 68 ;; NOTE: Th
1d10: 69 73 20 69 73 20 61 63 74 75 61 6c 6c 79 20 74 is is actually t
1d20: 68 65 20 63 61 73 65 20 6f 66 20 2a 6e 6f 2a 20 he case of *no*
1d30: 77 61 69 74 6f 6e 73 21 20 3b 3b 20 28 64 65 62 waitons! ;; (deb
1d40: 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 ug:print-error 0
1d50: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
1d60: 72 74 2a 20 22 73 6f 6d 65 74 68 69 6e 67 20 77 rt* "something w
1d70: 65 6e 74 20 77 72 6f 6e 67 20 69 6e 20 70 72 6f ent wrong in pro
1d80: 63 65 73 73 69 6e 67 20 77 61 69 74 6f 6e 73 20 cessing waitons
1d90: 66 6f 72 20 74 65 73 74 20 22 20 74 65 73 74 2d for test " test-
1da0: 6e 61 6d 65 29 0a 09 09 09 20 20 20 20 20 20 22 name).... "
1db0: 22 29 29 29 29 0a 09 20 20 20 20 20 28 6e 65 77 ")))).. (new
1dc0: 77 61 69 74 6f 72 73 0a 09 20 20 20 20 20 20 28 waitors.. (
1dd0: 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 28 63 6f string-split (co
1de0: 6e 64 0a 09 09 09 20 20 20 20 20 28 28 70 72 6f nd.... ((pro
1df0: 63 65 64 75 72 65 3f 20 69 6e 73 74 72 32 29 0a cedure? instr2).
1e00: 09 09 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 ... (let ((
1e10: 72 65 73 20 28 69 6e 73 74 72 32 29 29 29 0a 09 res (instr2)))..
1e20: 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d ...(debug:print-
1e30: 69 6e 66 6f 20 38 20 2a 64 65 66 61 75 6c 74 2d info 8 *default-
1e40: 6c 6f 67 2d 70 6f 72 74 2a 20 22 77 61 69 74 6f log-port* "waito
1e50: 72 20 70 72 6f 63 65 64 75 72 65 20 72 65 73 75 r procedure resu
1e60: 6c 74 73 20 69 6e 20 73 74 72 69 6e 67 20 22 20 lts in string "
1e70: 72 65 73 20 22 20 66 6f 72 20 74 65 73 74 20 22 res " for test "
1e80: 20 74 65 73 74 2d 6e 61 6d 65 29 0a 09 09 09 09 test-name).....
1e90: 72 65 73 29 29 0a 09 09 09 20 20 20 20 20 28 28 res)).... ((
1ea0: 73 74 72 69 6e 67 3f 20 69 6e 73 74 72 32 29 20 string? instr2)
1eb0: 20 20 20 20 69 6e 73 74 72 32 29 0a 09 09 09 20 instr2)....
1ec0: 20 20 20 20 28 65 6c 73 65 20 0a 09 09 09 20 20 (else ....
1ed0: 20 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 54 68 69 ;; NOTE: Thi
1ee0: 73 20 69 73 20 61 63 74 75 61 6c 6c 79 20 74 68 s is actually th
1ef0: 65 20 63 61 73 65 20 6f 66 20 2a 6e 6f 2a 20 77 e case of *no* w
1f00: 61 69 74 6f 6e 73 21 20 3b 3b 20 28 64 65 62 75 aitons! ;; (debu
1f10: 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 g:print-error 0
1f20: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
1f30: 74 2a 20 22 73 6f 6d 65 74 68 69 6e 67 20 77 65 t* "something we
1f40: 6e 74 20 77 72 6f 6e 67 20 69 6e 20 70 72 6f 63 nt wrong in proc
1f50: 65 73 73 69 6e 67 20 77 61 69 74 6f 6e 73 20 66 essing waitons f
1f60: 6f 72 20 74 65 73 74 20 22 20 74 65 73 74 2d 6e or test " test-n
1f70: 61 6d 65 29 0a 09 09 09 20 20 20 20 20 20 22 22 ame).... ""
1f80: 29 29 29 29 0a 09 20 20 20 20 20 28 6e 65 77 77 )))).. (neww
1f90: 61 69 74 6f 6e 73 20 28 69 66 20 28 61 6e 64 20 aitons (if (and
1fa0: 28 6c 69 73 74 3f 20 67 6c 6f 62 61 6c 2d 77 61 (list? global-wa
1fb0: 69 74 6f 6e 73 29 0a 09 09 09 09 20 20 28 6e 6f itons)..... (no
1fc0: 74 20 28 6e 75 6c 6c 3f 20 67 6c 6f 62 61 6c 2d t (null? global-
1fd0: 77 61 69 74 6f 6e 73 29 29 29 0a 09 09 09 20 20 waitons)))....
1fe0: 20 20 20 28 62 65 67 69 6e 0a 09 09 09 20 20 20 (begin....
1ff0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
2000: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
2010: 70 6f 72 74 2a 20 22 41 64 64 69 6e 67 20 67 6c port* "Adding gl
2020: 6f 62 61 6c 20 77 61 69 74 6f 6e 73 20 22 20 67 obal waitons " g
2030: 6c 6f 62 61 6c 2d 77 61 69 74 6f 6e 73 29 0a 09 lobal-waitons)..
2040: 09 09 20 20 20 20 20 20 20 28 61 70 70 65 6e 64 .. (append
2050: 20 6e 65 77 77 61 69 74 6f 6e 73 2d 74 6d 70 20 newwaitons-tmp
2060: 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 (filter (lambda
2070: 20 28 78 29 20 3b 3b 20 72 65 6d 6f 76 65 20 73 (x) ;; remove s
2080: 65 6c 66 20 66 72 6f 6d 20 67 6c 6f 62 61 6c 20 elf from global
2090: 77 61 69 74 6f 6e 73 0a 09 09 09 09 09 09 09 09 waitons.........
20a0: 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 78 20 (not (equal? x
20b0: 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a 09 09 09 test-name)))....
20c0: 09 09 09 09 20 20 20 20 20 20 20 67 6c 6f 62 61 .... globa
20d0: 6c 2d 77 61 69 74 6f 6e 73 29 29 29 0a 09 09 09 l-waitons)))....
20e0: 20 20 20 20 20 6e 65 77 77 61 69 74 6f 6e 73 2d newwaitons-
20f0: 74 6d 70 29 29 29 0a 09 20 28 76 61 6c 75 65 73 tmp))).. (values
2100: 0a 09 20 20 3b 3b 20 74 68 65 20 77 61 69 74 6f .. ;; the waito
2110: 6e 73 0a 09 20 20 28 66 69 6c 74 65 72 20 28 6c ns.. (filter (l
2120: 61 6d 62 64 61 20 28 78 29 0a 09 09 20 20 20 20 ambda (x)...
2130: 28 69 66 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (if (hash-table-
2140: 72 65 66 2f 64 65 66 61 75 6c 74 20 61 6c 6c 2d ref/default all-
2150: 74 65 73 74 73 2d 72 65 67 69 73 74 72 79 20 78 tests-registry x
2160: 20 23 66 29 0a 09 09 09 23 74 0a 09 09 09 28 62 #f)....#t....(b
2170: 65 67 69 6e 0a 09 09 09 20 20 28 64 65 62 75 67 egin.... (debug
2180: 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a :print-error 0 *
2190: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
21a0: 2a 20 22 74 65 73 74 20 22 20 74 65 73 74 2d 6e * "test " test-n
21b0: 61 6d 65 20 22 20 68 61 73 20 75 6e 72 65 63 6f ame " has unreco
21c0: 67 6e 69 73 65 64 20 77 61 69 74 6f 6e 20 74 65 gnised waiton te
21d0: 73 74 6e 61 6d 65 20 22 20 78 29 0a 09 09 09 20 stname " x)....
21e0: 20 23 66 29 29 29 0a 09 09 20 20 6e 65 77 77 61 #f)))... newwa
21f0: 69 74 6f 6e 73 29 0a 09 20 20 28 66 69 6c 74 65 itons).. (filte
2200: 72 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 09 r (lambda (x)...
2210: 20 20 20 20 28 69 66 20 28 68 61 73 68 2d 74 61 (if (hash-ta
2220: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
2230: 61 6c 6c 2d 74 65 73 74 73 2d 72 65 67 69 73 74 all-tests-regist
2240: 72 79 20 78 20 23 66 29 0a 09 09 09 23 74 0a 09 ry x #f)....#t..
2250: 09 09 28 62 65 67 69 6e 0a 09 09 09 20 20 28 64 ..(begin.... (d
2260: 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 ebug:print-error
2270: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
2280: 70 6f 72 74 2a 20 22 74 65 73 74 20 22 20 74 65 port* "test " te
2290: 73 74 2d 6e 61 6d 65 20 22 20 68 61 73 20 75 6e st-name " has un
22a0: 72 65 63 6f 67 6e 69 73 65 64 20 77 61 69 74 6f recognised waito
22b0: 6e 20 74 65 73 74 6e 61 6d 65 20 22 20 78 29 0a n testname " x).
22c0: 09 09 09 20 20 23 66 29 29 29 0a 09 09 20 20 6e ... #f)))... n
22d0: 65 77 77 61 69 74 6f 72 73 29 0a 09 20 20 63 6f ewwaitors).. co
22e0: 6e 66 69 67 29 29 29 29 29 0a 09 09 09 09 09 20 nfig)))))......
22f0: 20 20 20 20 0a 3b 3b 20 67 69 76 65 6e 20 77 61 .;; given wa
2300: 69 74 69 6e 67 2d 74 65 73 74 20 74 68 61 74 20 iting-test that
2310: 69 73 20 77 61 69 74 69 6e 67 20 6f 6e 20 77 61 is waiting on wa
2320: 69 74 6f 6e 2d 74 65 73 74 20 65 78 74 65 6e 64 iton-test extend
2330: 20 74 65 73 74 2d 70 61 74 74 20 61 70 70 72 6f test-patt appro
2340: 70 72 69 61 74 65 6c 79 0a 3b 3b 0a 3b 3b 20 20 priately.;;.;;
2350: 67 65 6e 6c 69 62 2f 74 65 73 74 63 6f 6e 66 69 genlib/testconfi
2360: 67 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 g
2370: 73 69 6d 2f 74 65 73 74 63 6f 6e 66 69 67 0a 3b sim/testconfig.;
2380: 3b 20 20 67 65 6e 6c 69 62 2f 73 63 68 20 20 20 ; genlib/sch
2390: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
23a0: 20 20 20 73 69 6d 2f 73 63 68 2f 63 65 6c 6c 31 sim/sch/cell1
23b0: 0a 3b 3b 0a 3b 3b 20 20 5b 72 65 71 75 69 72 65 .;;.;; [require
23c0: 6d 65 6e 74 73 5d 20 20 20 20 20 20 20 20 20 20 ments]
23d0: 20 20 20 20 20 20 20 20 5b 72 65 71 75 69 72 65 [require
23e0: 6d 65 6e 74 73 5d 0a 3b 3b 20 20 20 20 20 20 20 ments].;;
23f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2400: 20 20 20 20 20 20 20 20 20 20 20 6d 6f 64 65 20 mode
2410: 69 74 65 6d 77 61 69 74 0a 3b 3b 20 20 20 20 20 itemwait.;;
2420: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2430: 20 20 20 20 20 20 20 20 20 20 20 20 20 23 20 74 # t
2440: 72 69 6d 20 6f 66 66 20 74 68 65 20 63 65 6c 6c rim off the cell
2450: 20 74 6f 20 64 65 74 65 72 6d 69 6e 65 20 77 68 to determine wh
2460: 61 74 20 74 6f 20 72 75 6e 20 66 6f 72 20 67 65 at to run for ge
2470: 6e 6c 69 62 0a 3b 3b 20 20 20 20 20 20 20 20 20 nlib.;;
2480: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2490: 20 20 20 20 20 20 20 20 20 69 74 65 6d 6d 61 70 itemmap
24a0: 20 2f 2e 2a 0a 3b 3b 0a 3b 3b 20 20 20 20 20 20 /.*.;;.;;
24b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
24c0: 20 20 20 20 20 20 20 20 20 20 20 20 77 61 69 74 wait
24d0: 69 6e 67 2d 74 65 73 74 20 69 73 20 77 61 69 74 ing-test is wait
24e0: 69 6e 67 20 6f 6e 20 77 61 69 74 6f 6e 2d 74 65 ing on waiton-te
24f0: 73 74 20 73 6f 20 77 65 20 6e 65 65 64 20 74 6f st so we need to
2500: 20 63 72 65 61 74 65 20 61 20 70 61 74 74 65 72 create a patter
2510: 6e 20 66 6f 72 20 77 61 69 74 6f 6e 2d 74 65 73 n for waiton-tes
2520: 74 20 67 69 76 65 6e 20 77 61 69 74 69 6e 67 2d t given waiting-
2530: 74 65 73 74 20 61 6e 64 20 69 74 65 6d 6d 61 70 test and itemmap
2540: 0a 3b 3b 20 42 42 3e 20 28 74 65 73 74 73 3a 65 .;; BB> (tests:e
2550: 78 74 65 6e 64 2d 74 65 73 74 2d 70 61 74 74 73 xtend-test-patts
2560: 20 22 6e 6f 72 6d 61 6c 2d 73 65 63 6f 6e 64 2f "normal-second/
2570: 32 22 20 22 6e 6f 72 6d 61 6c 2d 73 65 63 6f 6e 2" "normal-secon
2580: 64 22 20 22 6e 6f 72 6d 61 6c 2d 66 69 72 73 74 d" "normal-first
2590: 22 20 27 28 29 29 0a 3b 3b 20 6f 62 73 65 72 76 " '()).;; observ
25a0: 65 64 20 2d 3e 20 22 6e 6f 72 6d 61 6c 2d 66 69 ed -> "normal-fi
25b0: 72 73 74 2f 32 2c 6e 6f 72 6d 61 6c 2d 66 69 72 rst/2,normal-fir
25c0: 73 74 2f 2c 6e 6f 72 6d 61 6c 2d 73 65 63 6f 6e st/,normal-secon
25d0: 64 2f 32 2c 6e 6f 72 6d 61 6c 2d 73 65 63 6f 6e d/2,normal-secon
25e0: 64 2f 22 0a 3b 3b 20 65 78 70 65 63 74 65 64 20 d/".;; expected
25f0: 2d 3e 20 22 6e 6f 72 6d 61 6c 2d 66 69 72 73 74 -> "normal-first
2600: 2c 6e 6f 72 6d 61 6c 2d 73 65 63 6f 6e 64 2f 32 ,normal-second/2
2610: 2c 6e 6f 72 6d 61 6c 2d 73 65 63 6f 6e 64 2f 22 ,normal-second/"
2620: 0a 3b 3b 20 74 65 73 74 70 61 74 74 20 3d 20 6e .;; testpatt = n
2630: 6f 72 6d 61 6c 2d 73 65 63 6f 6e 64 2f 32 0a 3b ormal-second/2.;
2640: 3b 20 77 61 69 74 69 6e 67 2d 74 65 73 74 20 3d ; waiting-test =
2650: 20 6e 6f 72 6d 61 6c 2d 73 65 63 6f 6e 64 0a 3b normal-second.;
2660: 3b 20 77 61 69 74 6f 6e 2d 74 65 73 74 20 3d 20 ; waiton-test =
2670: 6e 6f 72 6d 61 6c 2d 66 69 72 73 74 0a 3b 3b 20 normal-first.;;
2680: 69 74 65 6d 6d 61 70 73 20 3d 20 28 29 0a 0a 28 itemmaps = ()..(
2690: 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 65 78 define (tests:ex
26a0: 74 65 6e 64 2d 74 65 73 74 2d 70 61 74 74 73 20 tend-test-patts
26b0: 74 65 73 74 2d 70 61 74 74 20 77 61 69 74 69 6e test-patt waitin
26c0: 67 2d 74 65 73 74 20 77 61 69 74 6f 6e 2d 74 65 g-test waiton-te
26d0: 73 74 20 69 74 65 6d 6d 61 70 73 20 69 74 65 6d st itemmaps item
26e0: 69 7a 65 64 2d 77 61 69 74 6f 6e 29 0a 20 20 28 ized-waiton). (
26f0: 63 6f 6e 64 0a 20 20 20 28 69 74 65 6d 69 7a 65 cond. (itemize
2700: 64 2d 77 61 69 74 6f 6e 0a 20 20 20 20 28 6c 65 d-waiton. (le
2710: 74 2a 20 28 28 69 74 65 6d 6d 61 70 20 20 20 20 t* ((itemmap
2720: 20 20 20 20 20 20 28 74 65 73 74 73 3a 6c 6f 6f (tests:loo
2730: 6b 75 70 2d 69 74 65 6d 6d 61 70 20 69 74 65 6d kup-itemmap item
2740: 6d 61 70 73 20 77 61 69 74 6f 6e 2d 74 65 73 74 maps waiton-test
2750: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 70 )). (p
2760: 61 74 74 73 20 20 20 20 20 20 20 20 20 20 20 20 atts
2770: 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 74 65 (string-split te
2780: 73 74 2d 70 61 74 74 20 22 2c 22 29 29 0a 20 20 st-patt ",")).
2790: 20 20 20 20 20 20 20 20 20 28 77 61 69 74 69 6e (waitin
27a0: 67 2d 74 65 73 74 2d 6c 65 6e 20 28 2b 20 28 73 g-test-len (+ (s
27b0: 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 77 61 69 tring-length wai
27c0: 74 69 6e 67 2d 74 65 73 74 29 20 31 29 29 0a 20 ting-test) 1)).
27d0: 20 20 20 20 20 20 20 20 20 20 28 70 61 74 74 73 (patts
27e0: 2d 77 61 69 74 6f 6e 20 20 20 20 20 28 6d 61 70 -waiton (map
27f0: 20 28 6c 61 6d 62 64 61 20 28 78 29 20 20 3b 3b (lambda (x) ;;
2800: 20 66 6f 72 20 65 61 63 68 20 69 6e 63 6f 6d 69 for each incomi
2810: 6e 67 20 70 61 74 74 20 74 68 61 74 20 6d 61 74 ng patt that mat
2820: 63 68 65 73 20 74 68 65 20 77 61 69 74 69 6e 67 ches the waiting
2830: 20 74 65 73 74 0a 20 20 20 20 20 20 20 20 20 20 test.
2840: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2850: 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 (let*
2860: 28 28 6d 6f 64 70 61 74 74 20 28 69 66 20 69 74 ((modpatt (if it
2870: 65 6d 6d 61 70 20 28 64 62 3a 63 6f 6e 76 65 72 emmap (db:conver
2880: 74 2d 74 65 73 74 2d 69 74 65 6d 70 61 74 68 20 t-test-itempath
2890: 78 20 69 74 65 6d 6d 61 70 29 20 78 29 29 20 0a x itemmap) x)) .
28a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
28b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
28c0: 20 20 20 20 20 20 20 20 20 20 20 28 6e 65 77 70 (newp
28d0: 61 74 74 20 28 63 6f 6e 63 20 77 61 69 74 6f 6e att (conc waiton
28e0: 2d 74 65 73 74 20 22 2f 22 20 28 73 75 62 73 74 -test "/" (subst
28f0: 72 69 6e 67 20 6d 6f 64 70 61 74 74 20 77 61 69 ring modpatt wai
2900: 74 69 6e 67 2d 74 65 73 74 2d 6c 65 6e 20 28 73 ting-test-len (s
2910: 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 6d 6f 64 tring-length mod
2920: 70 61 74 74 29 29 29 29 29 0a 20 20 20 20 20 20 patt))))).
2930: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2940: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2950: 3b 3b 20 28 63 6f 6e 63 20 77 61 69 74 69 6e 67 ;; (conc waiting
2960: 2d 74 65 73 74 20 22 2f 2c 22 20 77 61 69 74 69 -test "/," waiti
2970: 6e 67 2d 74 65 73 74 20 22 2f 22 20 28 73 75 62 ng-test "/" (sub
2980: 73 74 72 69 6e 67 20 6d 6f 64 70 61 74 74 20 77 string modpatt w
2990: 61 69 74 6f 6e 2d 74 65 73 74 2d 6c 65 6e 20 28 aiton-test-len (
29a0: 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 6d 6f string-length mo
29b0: 64 70 61 74 74 29 29 29 29 29 0a 20 20 20 20 20 dpatt))))).
29c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
29d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
29e0: 20 3b 3b 20 28 70 72 69 6e 74 20 22 69 6e 20 6d ;; (print "in m
29f0: 61 70 2c 20 78 3d 22 20 78 20 22 2c 20 6e 65 77 ap, x=" x ", new
2a00: 70 61 74 74 3d 22 20 6e 65 77 70 61 74 74 29 0a patt=" newpatt).
2a10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2a20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2a30: 20 20 20 20 20 20 6e 65 77 70 61 74 74 29 29 0a 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 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 (filter (lambd
2a70: 61 20 28 78 29 0a 20 20 20 20 20 20 20 20 20 20 a (x).
2a80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2a90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2aa0: 20 20 28 65 71 3f 20 28 73 75 62 73 74 72 69 6e (eq? (substrin
2ab0: 67 2d 69 6e 64 65 78 20 28 63 6f 6e 63 20 77 61 g-index (conc wa
2ac0: 69 74 69 6e 67 2d 74 65 73 74 20 22 2f 22 29 20 iting-test "/")
2ad0: 78 29 20 30 29 29 20 3b 3b 20 69 73 20 74 68 69 x) 0)) ;; is thi
2ae0: 73 20 70 61 74 74 20 70 65 72 74 69 6e 65 6e 74 s patt pertinent
2af0: 20 74 6f 20 74 68 65 20 77 61 69 74 69 6e 67 20 to the waiting
2b00: 74 65 73 74 0a 20 20 20 20 20 20 20 20 20 20 20 test.
2b10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2b20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 70 p
2b30: 61 74 74 73 29 29 29 0a 20 20 20 20 20 20 20 20 atts))).
2b40: 20 20 20 28 65 78 74 65 6e 64 65 64 2d 74 65 73 (extended-tes
2b50: 74 2d 70 61 74 74 20 20 20 28 61 70 70 65 6e 64 t-patt (append
2b60: 20 70 61 74 74 73 20 28 69 66 20 28 6e 75 6c 6c patts (if (null
2b70: 3f 20 70 61 74 74 73 2d 77 61 69 74 6f 6e 29 0a ? patts-waiton).
2b80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2b90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2ba0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2bb0: 20 20 20 28 6c 69 73 74 20 28 63 6f 6e 63 20 77 (list (conc w
2bc0: 61 69 74 6f 6e 2d 74 65 73 74 20 22 2f 25 22 29 aiton-test "/%")
2bd0: 29 20 3b 3b 20 72 65 61 6c 6c 79 20 73 68 6f 75 ) ;; really shou
2be0: 6c 64 6e 27 74 20 61 64 64 20 74 68 65 20 77 61 ldn't add the wa
2bf0: 69 74 6f 6e 20 66 6f 72 63 65 66 75 6c 6c 79 20 iton forcefully
2c00: 6c 69 6b 65 20 74 68 69 73 0a 20 20 20 20 20 20 like this.
2c10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2c20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2c30: 20 20 20 20 20 20 20 20 20 20 20 20 20 70 61 74 pat
2c40: 74 73 2d 77 61 69 74 6f 6e 29 29 29 0a 20 20 20 ts-waiton))).
2c50: 20 20 20 20 20 20 20 20 28 65 78 74 65 6e 64 65 (extende
2c60: 64 2d 74 65 73 74 2d 70 61 74 74 2d 77 69 74 68 d-test-patt-with
2c70: 2d 74 6f 70 6c 65 76 65 6c 73 0a 20 20 20 20 20 -toplevels.
2c80: 20 20 20 20 20 20 20 28 66 6f 6c 64 20 28 6c 61 (fold (la
2c90: 6d 62 64 61 20 28 74 65 73 74 70 61 74 74 2d 69 mbda (testpatt-i
2ca0: 74 65 6d 20 61 63 63 75 6d 20 29 0a 20 20 20 20 tem accum ).
2cb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2cc0: 28 6c 65 74 20 28 28 6d 79 2d 6d 61 74 63 68 20 (let ((my-match
2cd0: 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 22 5e (string-match "^
2ce0: 28 5b 5e 25 5c 5c 2f 5d 2b 29 5c 5c 2f 2e 2b 24 ([^%\\/]+)\\/.+$
2cf0: 22 20 74 65 73 74 70 61 74 74 2d 69 74 65 6d 29 " testpatt-item)
2d00: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
2d10: 20 20 20 20 20 20 20 20 20 28 63 6f 6e 73 20 74 (cons t
2d20: 65 73 74 70 61 74 74 2d 69 74 65 6d 0a 20 20 20 estpatt-item.
2d30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2d40: 20 20 20 20 20 20 20 20 20 28 69 66 20 6d 79 2d (if my-
2d50: 6d 61 74 63 68 0a 20 20 20 20 20 20 20 20 20 20 match.
2d60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2d70: 20 20 20 20 20 20 28 63 6f 6e 73 0a 20 20 20 20 (cons.
2d80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2d90: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f (co
2da0: 6e 63 20 28 63 61 64 72 20 6d 79 2d 6d 61 74 63 nc (cadr my-matc
2db0: 68 29 20 22 2f 22 29 0a 20 20 20 20 20 20 20 20 h) "/").
2dc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2dd0: 20 20 20 20 20 20 20 20 20 61 63 63 75 6d 29 0a accum).
2de0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2df0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2e00: 61 63 63 75 6d 29 29 29 29 0a 20 20 20 20 20 20 accum)))).
2e10: 20 20 20 20 20 20 20 20 20 20 20 20 27 28 29 0a '().
2e20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2e30: 20 20 65 78 74 65 6e 64 65 64 2d 74 65 73 74 2d extended-test-
2e40: 70 61 74 74 29 29 29 0a 20 20 20 20 20 20 28 73 patt))). (s
2e50: 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 tring-interspers
2e60: 65 20 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 e (delete-duplic
2e70: 61 74 65 73 20 65 78 74 65 6e 64 65 64 2d 74 65 ates extended-te
2e80: 73 74 2d 70 61 74 74 2d 77 69 74 68 2d 74 6f 70 st-patt-with-top
2e90: 6c 65 76 65 6c 73 29 20 22 2c 22 29 29 29 0a 20 levels) ","))).
2ea0: 20 20 28 65 6c 73 65 20 3b 3b 20 6e 6f 74 20 77 (else ;; not w
2eb0: 61 69 74 69 6e 67 20 6f 6e 20 69 74 65 6d 73 2c aiting on items,
2ec0: 20 77 61 69 74 69 6e 67 20 6f 6e 20 65 6e 74 69 waiting on enti
2ed0: 72 65 20 77 61 69 74 6f 6e 20 74 65 73 74 2e 0a re waiton test..
2ee0: 20 20 20 20 28 6c 65 74 2a 20 28 28 70 61 74 74 (let* ((patt
2ef0: 73 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 s (string-split
2f00: 74 65 73 74 2d 70 61 74 74 20 22 2c 22 29 29 0a test-patt ",")).
2f10: 20 20 20 20 20 20 20 20 20 20 20 28 6e 65 77 2d (new-
2f20: 70 61 74 74 73 20 28 69 66 20 28 6d 65 6d 62 65 patts (if (membe
2f30: 72 20 77 61 69 74 6f 6e 2d 74 65 73 74 20 70 61 r waiton-test pa
2f40: 74 74 73 29 0a 20 20 20 20 20 20 20 20 20 20 20 tts).
2f50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 70 p
2f60: 61 74 74 73 0a 20 20 20 20 20 20 20 20 20 20 20 atts.
2f70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
2f80: 63 6f 6e 73 20 77 61 69 74 6f 6e 2d 74 65 73 74 cons waiton-test
2f90: 20 70 61 74 74 73 29 29 29 29 0a 20 20 20 20 20 patts)))).
2fa0: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
2fb0: 65 72 73 65 20 28 64 65 6c 65 74 65 2d 64 75 70 erse (delete-dup
2fc0: 6c 69 63 61 74 65 73 20 6e 65 77 2d 70 61 74 74 licates new-patt
2fd0: 73 29 20 22 2c 22 29 29 29 29 29 0a 0a 28 64 65 s) ",")))))..(de
2fe0: 66 69 6e 65 20 2a 67 6c 6f 62 2d 6c 69 6b 65 2d fine *glob-like-
2ff0: 6d 61 74 63 68 2d 63 61 63 68 65 2a 20 28 6d 61 match-cache* (ma
3000: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
3010: 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 63 (define (tests:c
3020: 61 63 68 65 2d 72 65 67 65 78 70 20 73 74 72 2d ache-regexp str-
3030: 69 6e 20 66 6c 61 67 29 0a 20 20 28 6c 65 74 2a in flag). (let*
3040: 20 28 28 6b 65 79 20 28 63 6f 6e 63 20 73 74 72 ((key (conc str
3050: 2d 69 6e 20 66 6c 61 67 29 29 29 0a 20 20 20 20 -in flag))).
3060: 28 6f 72 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (or (hash-table-
3070: 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 67 6c 6f ref/default *glo
3080: 62 2d 6c 69 6b 65 2d 6d 61 74 63 68 2d 63 61 63 b-like-match-cac
3090: 68 65 2a 20 6b 65 79 20 23 66 29 0a 09 28 6c 65 he* key #f)..(le
30a0: 74 2a 20 28 28 6e 65 77 72 78 20 28 72 65 67 65 t* ((newrx (rege
30b0: 78 70 20 73 74 72 2d 69 6e 20 66 6c 61 67 29 29 xp str-in flag))
30c0: 29 0a 09 20 20 28 68 61 73 68 2d 74 61 62 6c 65 ).. (hash-table
30d0: 2d 73 65 74 21 20 2a 67 6c 6f 62 2d 6c 69 6b 65 -set! *glob-like
30e0: 2d 6d 61 74 63 68 2d 63 61 63 68 65 2a 20 6b 65 -match-cache* ke
30f0: 79 20 6e 65 77 72 78 29 0a 09 20 20 6e 65 77 72 y newrx).. newr
3100: 78 29 29 29 29 0a 0a 3b 3b 20 74 65 73 74 73 3a x))))..;; tests:
3110: 67 6c 6f 62 2d 6c 69 6b 65 2d 6d 61 74 63 68 20 glob-like-match
3120: 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a .(define (tests:
3130: 67 6c 6f 62 2d 6c 69 6b 65 2d 6d 61 74 63 68 20 glob-like-match
3140: 70 61 74 74 20 73 74 72 29 20 0a 20 20 28 6c 65 patt str) . (le
3150: 74 2a 20 28 28 6c 69 6b 65 20 20 20 20 20 28 73 t* ((like (s
3160: 75 62 73 74 72 69 6e 67 2d 69 6e 64 65 78 20 22 ubstring-index "
3170: 25 22 20 70 61 74 74 29 29 0a 09 20 28 6e 6f 74 %" patt)).. (not
3180: 70 61 74 74 20 20 28 65 71 75 61 6c 3f 20 28 73 patt (equal? (s
3190: 75 62 73 74 72 69 6e 67 2d 69 6e 64 65 78 20 22 ubstring-index "
31a0: 7e 22 20 70 61 74 74 29 20 30 29 29 0a 09 20 28 ~" patt) 0)).. (
31b0: 6e 65 77 70 61 74 74 20 20 28 69 66 20 6e 6f 74 newpatt (if not
31c0: 70 61 74 74 20 28 73 75 62 73 74 72 69 6e 67 20 patt (substring
31d0: 70 61 74 74 20 31 29 20 70 61 74 74 29 29 0a 09 patt 1) patt))..
31e0: 20 28 66 69 6e 70 61 74 74 20 20 28 69 66 20 6c (finpatt (if l
31f0: 69 6b 65 0a 09 09 20 20 20 20 20 20 20 28 73 74 ike... (st
3200: 72 69 6e 67 2d 73 75 62 73 74 69 74 75 74 65 20 ring-substitute
3210: 28 72 65 67 65 78 70 20 22 25 22 29 20 22 2e 2a (regexp "%") ".*
3220: 22 20 6e 65 77 70 61 74 74 20 23 66 29 0a 09 09 " newpatt #f)...
3230: 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 73 (string-s
3240: 75 62 73 74 69 74 75 74 65 20 28 72 65 67 65 78 ubstitute (regex
3250: 70 20 22 5c 5c 2a 22 29 20 22 2e 2a 22 20 6e 65 p "\\*") ".*" ne
3260: 77 70 61 74 74 20 23 66 29 29 29 0a 09 20 28 72 wpatt #f))).. (r
3270: 78 20 20 20 20 20 20 20 28 74 65 73 74 73 3a 63 x (tests:c
3280: 61 63 68 65 2d 72 65 67 65 78 70 20 66 69 6e 70 ache-regexp finp
3290: 61 74 74 20 28 69 66 20 6c 69 6b 65 20 23 74 20 att (if like #t
32a0: 23 66 29 29 29 0a 09 20 28 72 65 73 20 20 20 20 #f))).. (res
32b0: 20 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 (string-match
32c0: 72 78 20 73 74 72 29 29 29 0a 20 20 20 20 28 69 rx str))). (i
32d0: 66 20 6e 6f 74 70 61 74 74 20 28 6e 6f 74 20 72 f notpatt (not r
32e0: 65 73 29 20 72 65 73 29 29 29 0a 0a 3b 3b 20 69 es) res)))..;; i
32f0: 66 20 69 74 65 6d 70 61 74 68 20 69 73 20 23 66 f itempath is #f
3300: 20 74 68 65 6e 20 6c 6f 6f 6b 20 6f 6e 6c 79 20 then look only
3310: 61 74 20 74 68 65 20 74 65 73 74 6e 61 6d 65 20 at the testname
3320: 70 61 72 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 part.;;.(define
3330: 28 74 65 73 74 73 3a 6d 61 74 63 68 20 70 61 74 (tests:match pat
3340: 74 65 72 6e 73 20 74 65 73 74 6e 61 6d 65 20 69 terns testname i
3350: 74 65 6d 70 61 74 68 20 23 21 6b 65 79 20 28 72 tempath #!key (r
3360: 65 71 75 69 72 65 64 20 27 28 29 29 29 0a 20 20 equired '())).
3370: 28 69 66 20 28 73 74 72 69 6e 67 3f 20 70 61 74 (if (string? pat
3380: 74 65 72 6e 73 29 0a 20 20 20 20 20 20 28 6c 65 terns). (le
3390: 74 20 28 28 70 61 74 74 73 20 28 61 70 70 65 6e t ((patts (appen
33a0: 64 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 d (string-split
33b0: 70 61 74 74 65 72 6e 73 20 22 2c 22 29 20 72 65 patterns ",") re
33c0: 71 75 69 72 65 64 29 29 29 0a 09 28 69 66 20 28 quired)))..(if (
33d0: 6e 75 6c 6c 3f 20 70 61 74 74 73 29 20 3b 3b 3b null? patts) ;;;
33e0: 20 6e 6f 20 70 61 74 74 65 72 6e 28 73 29 20 6d no pattern(s) m
33f0: 65 61 6e 73 20 6e 6f 20 6d 61 74 63 68 0a 09 20 eans no match..
3400: 20 20 20 23 66 0a 09 20 20 20 20 28 6c 65 74 20 #f.. (let
3410: 6c 6f 6f 70 20 28 28 70 61 74 74 20 28 63 61 72 loop ((patt (car
3420: 20 70 61 74 74 73 29 29 0a 09 09 20 20 20 20 20 patts))...
3430: 20 20 28 74 61 6c 20 20 28 63 64 72 20 70 61 74 (tal (cdr pat
3440: 74 73 29 29 29 0a 09 20 20 20 20 20 20 3b 3b 20 ts))).. ;;
3450: 28 70 72 69 6e 74 20 22 6c 6f 6f 70 3a 20 70 61 (print "loop: pa
3460: 74 74 3a 20 22 20 70 61 74 74 20 22 2c 20 74 61 tt: " patt ", ta
3470: 6c 20 22 20 74 61 6c 29 0a 09 20 20 20 20 20 20 l " tal)..
3480: 28 69 66 20 28 73 74 72 69 6e 67 3d 3f 20 70 61 (if (string=? pa
3490: 74 74 20 22 22 29 0a 09 09 20 20 23 66 20 3b 3b tt "")... #f ;;
34a0: 20 6e 6f 74 68 69 6e 67 20 65 76 65 72 20 6d 61 nothing ever ma
34b0: 74 63 68 65 73 20 65 6d 70 74 79 20 73 74 72 69 tches empty stri
34c0: 6e 67 20 2d 20 70 6f 6c 69 63 79 0a 09 09 20 20 ng - policy...
34d0: 28 6c 65 74 2a 20 28 28 70 61 74 74 2d 70 61 72 (let* ((patt-par
34e0: 74 73 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 ts (string-match
34f0: 20 28 72 65 67 65 78 70 20 22 5e 28 5b 5e 5c 5c (regexp "^([^\\
3500: 2f 5d 2a 29 28 5c 5c 2f 28 2e 2a 29 7c 29 24 22 /]*)(\\/(.*)|)$"
3510: 29 20 70 61 74 74 29 29 0a 09 09 09 20 28 74 65 ) patt)).... (te
3520: 73 74 2d 70 61 74 74 20 20 28 63 61 64 72 20 70 st-patt (cadr p
3530: 61 74 74 2d 70 61 72 74 73 29 29 0a 09 09 09 20 att-parts))....
3540: 28 69 74 65 6d 2d 70 61 74 74 20 20 28 63 61 64 (item-patt (cad
3550: 64 64 72 20 70 61 74 74 2d 70 61 72 74 73 29 29 ddr patt-parts))
3560: 29 0a 09 09 20 20 20 20 3b 3b 20 73 70 65 63 69 )... ;; speci
3570: 61 6c 20 63 61 73 65 3a 20 74 65 73 74 20 76 73 al case: test vs
3580: 2e 20 74 65 73 74 2f 0a 09 09 20 20 20 20 3b 3b . test/... ;;
3590: 20 20 20 74 65 73 74 20 20 3d 3e 20 22 74 65 73 test => "tes
35a0: 74 22 20 22 25 22 0a 09 09 20 20 20 20 3b 3b 20 t" "%"... ;;
35b0: 20 20 74 65 73 74 2f 20 3d 3e 20 22 74 65 73 74 test/ => "test
35c0: 22 20 22 22 0a 09 09 20 20 20 20 28 69 66 20 28 " ""... (if (
35d0: 61 6e 64 20 28 6e 6f 74 20 28 73 75 62 73 74 72 and (not (substr
35e0: 69 6e 67 2d 69 6e 64 65 78 20 22 2f 22 20 70 61 ing-index "/" pa
35f0: 74 74 29 29 20 3b 3b 20 6e 6f 20 73 6c 61 73 68 tt)) ;; no slash
3600: 20 69 6e 20 74 68 65 20 6f 72 69 67 69 6e 61 6c in the original
3610: 0a 09 09 09 20 20 20 20 20 28 6f 72 20 28 6e 6f .... (or (no
3620: 74 20 69 74 65 6d 2d 70 61 74 74 29 0a 09 09 09 t item-patt)....
3630: 09 20 28 65 71 75 61 6c 3f 20 69 74 65 6d 2d 70 . (equal? item-p
3640: 61 74 74 20 22 22 29 29 29 20 20 20 20 20 20 3b att ""))) ;
3650: 3b 20 73 68 6f 75 6c 64 20 61 6c 77 61 79 73 20 ; should always
3660: 62 65 20 74 72 75 65 20 74 68 61 74 20 69 74 65 be true that ite
3670: 6d 2d 70 61 74 74 20 69 73 20 22 22 0a 09 09 09 m-patt is ""....
3680: 28 73 65 74 21 20 69 74 65 6d 2d 70 61 74 74 20 (set! item-patt
3690: 22 25 22 29 29 0a 09 09 20 20 20 20 3b 3b 20 28 "%"))... ;; (
36a0: 70 72 69 6e 74 20 22 74 65 73 74 73 3a 6d 61 74 print "tests:mat
36b0: 63 68 20 3d 3e 20 70 61 74 74 2d 70 61 72 74 73 ch => patt-parts
36c0: 3a 20 22 20 70 61 74 74 2d 70 61 72 74 73 20 22 : " patt-parts "
36d0: 2c 20 74 65 73 74 2d 70 61 74 74 3a 20 22 20 74 , test-patt: " t
36e0: 65 73 74 2d 70 61 74 74 20 22 2c 20 69 74 65 6d est-patt ", item
36f0: 2d 70 61 74 74 3a 20 22 20 69 74 65 6d 2d 70 61 -patt: " item-pa
3700: 74 74 29 0a 09 09 20 20 20 20 28 69 66 20 28 61 tt)... (if (a
3710: 6e 64 20 28 74 65 73 74 73 3a 67 6c 6f 62 2d 6c nd (tests:glob-l
3720: 69 6b 65 2d 6d 61 74 63 68 20 74 65 73 74 2d 70 ike-match test-p
3730: 61 74 74 20 74 65 73 74 6e 61 6d 65 29 0a 09 09 att testname)...
3740: 09 20 20 20 20 20 28 6f 72 20 28 6e 6f 74 20 69 . (or (not i
3750: 74 65 6d 70 61 74 68 29 0a 09 09 09 09 20 28 74 tempath)..... (t
3760: 65 73 74 73 3a 67 6c 6f 62 2d 6c 69 6b 65 2d 6d ests:glob-like-m
3770: 61 74 63 68 20 28 69 66 20 69 74 65 6d 2d 70 61 atch (if item-pa
3780: 74 74 20 69 74 65 6d 2d 70 61 74 74 20 22 22 29 tt item-patt "")
3790: 20 69 74 65 6d 70 61 74 68 29 29 29 0a 09 09 09 itempath)))....
37a0: 23 74 0a 09 09 09 28 69 66 20 28 6e 75 6c 6c 3f #t....(if (null?
37b0: 20 74 61 6c 29 0a 09 09 09 20 20 20 20 23 66 0a tal).... #f.
37c0: 09 09 09 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 ... (loop (ca
37d0: 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 29 r tal)(cdr tal))
37e0: 29 29 29 29 29 29 29 29 29 0a 0a 3b 3b 20 69 66 )))))))))..;; if
37f0: 20 69 74 65 6d 70 61 74 68 20 69 73 20 23 66 20 itempath is #f
3800: 74 68 65 6e 20 6c 6f 6f 6b 20 6f 6e 6c 79 20 61 then look only a
3810: 74 20 74 68 65 20 74 65 73 74 6e 61 6d 65 20 70 t the testname p
3820: 61 72 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 art.;;.(define (
3830: 74 65 73 74 73 3a 6d 61 74 63 68 2d 3e 73 71 6c tests:match->sql
3840: 71 72 79 20 70 61 74 74 65 72 6e 73 29 0a 20 20 qry patterns).
3850: 28 69 66 20 28 73 74 72 69 6e 67 3f 20 70 61 74 (if (string? pat
3860: 74 65 72 6e 73 29 0a 20 20 20 20 20 20 28 6c 65 terns). (le
3870: 74 20 28 28 70 61 74 74 73 20 28 73 74 72 69 6e t ((patts (strin
3880: 67 2d 73 70 6c 69 74 20 70 61 74 74 65 72 6e 73 g-split patterns
3890: 20 22 2c 22 29 29 29 0a 09 28 69 66 20 28 6e 75 ",")))..(if (nu
38a0: 6c 6c 3f 20 70 61 74 74 73 29 20 3b 3b 3b 20 6e ll? patts) ;;; n
38b0: 6f 20 70 61 74 74 65 72 6e 28 73 29 20 6d 65 61 o pattern(s) mea
38c0: 6e 73 20 6e 6f 20 6d 61 74 63 68 2c 20 77 65 20 ns no match, we
38d0: 77 69 6c 6c 20 64 6f 20 6e 6f 20 71 75 65 72 79 will do no query
38e0: 0a 09 20 20 20 20 23 66 0a 09 20 20 20 20 28 6c .. #f.. (l
38f0: 65 74 20 6c 6f 6f 70 20 28 28 70 61 74 74 20 28 et loop ((patt (
3900: 63 61 72 20 70 61 74 74 73 29 29 0a 09 09 20 20 car patts))...
3910: 20 20 20 20 20 28 74 61 6c 20 20 28 63 64 72 20 (tal (cdr
3920: 70 61 74 74 73 29 29 0a 09 09 20 20 20 20 20 20 patts))...
3930: 20 28 72 65 73 20 20 27 28 29 29 29 0a 09 20 20 (res '()))..
3940: 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 6c ;; (print "l
3950: 6f 6f 70 3a 20 70 61 74 74 3a 20 22 20 70 61 74 oop: patt: " pat
3960: 74 20 22 2c 20 74 61 6c 20 22 20 74 61 6c 29 0a t ", tal " tal).
3970: 09 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 70 . (let* ((p
3980: 61 74 74 2d 70 61 72 74 73 20 28 73 74 72 69 6e att-parts (strin
3990: 67 2d 6d 61 74 63 68 20 28 72 65 67 65 78 70 20 g-match (regexp
39a0: 22 5e 28 5b 5e 5c 5c 2f 5d 2a 29 28 5c 5c 2f 28 "^([^\\/]*)(\\/(
39b0: 2e 2a 29 7c 29 24 22 29 20 70 61 74 74 29 29 0a .*)|)$") patt)).
39c0: 09 09 20 20 20 20 20 28 74 65 73 74 2d 70 61 74 .. (test-pat
39d0: 74 20 20 28 63 61 64 72 20 70 61 74 74 2d 70 61 t (cadr patt-pa
39e0: 72 74 73 29 29 0a 09 09 20 20 20 20 20 28 69 74 rts))... (it
39f0: 65 6d 2d 70 61 74 74 20 20 28 63 61 64 64 64 72 em-patt (cadddr
3a00: 20 70 61 74 74 2d 70 61 72 74 73 29 29 0a 09 09 patt-parts))...
3a10: 20 20 20 20 20 28 74 65 73 74 2d 71 72 79 20 20 (test-qry
3a20: 20 28 64 62 3a 70 61 74 74 2d 3e 6c 69 6b 65 20 (db:patt->like
3a30: 22 74 65 73 74 6e 61 6d 65 22 20 74 65 73 74 2d "testname" test-
3a40: 70 61 74 74 29 29 0a 09 09 20 20 20 20 20 28 69 patt))... (i
3a50: 74 65 6d 2d 71 72 79 20 20 20 28 64 62 3a 70 61 tem-qry (db:pa
3a60: 74 74 2d 3e 6c 69 6b 65 20 22 69 74 65 6d 5f 70 tt->like "item_p
3a70: 61 74 68 22 20 69 74 65 6d 2d 70 61 74 74 29 29 ath" item-patt))
3a80: 0a 09 09 20 20 20 20 20 28 71 72 79 20 20 20 20 ... (qry
3a90: 20 20 20 20 28 63 6f 6e 63 20 22 28 22 20 74 65 (conc "(" te
3aa0: 73 74 2d 71 72 79 20 22 20 41 4e 44 20 22 20 69 st-qry " AND " i
3ab0: 74 65 6d 2d 71 72 79 20 22 29 22 29 29 29 0a 09 tem-qry ")")))..
3ac0: 09 3b 3b 20 28 70 72 69 6e 74 20 22 74 65 73 74 .;; (print "test
3ad0: 73 3a 6d 61 74 63 68 20 3d 3e 20 70 61 74 74 2d s:match => patt-
3ae0: 70 61 72 74 73 3a 20 22 20 70 61 74 74 2d 70 61 parts: " patt-pa
3af0: 72 74 73 20 22 2c 20 74 65 73 74 2d 70 61 74 74 rts ", test-patt
3b00: 3a 20 22 20 74 65 73 74 2d 70 61 74 74 20 22 2c : " test-patt ",
3b10: 20 69 74 65 6d 2d 70 61 74 74 3a 20 22 20 69 74 item-patt: " it
3b20: 65 6d 2d 70 61 74 74 29 0a 09 09 28 69 66 20 28 em-patt)...(if (
3b30: 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 20 20 20 null? tal)...
3b40: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
3b50: 65 72 73 65 20 28 61 70 70 65 6e 64 20 28 72 65 erse (append (re
3b60: 76 65 72 73 65 20 72 65 73 29 28 6c 69 73 74 20 verse res)(list
3b70: 71 72 79 29 29 20 22 20 4f 52 20 22 29 0a 09 09 qry)) " OR ")...
3b80: 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 (loop (car t
3b90: 61 6c 29 28 63 64 72 20 74 61 6c 29 28 63 6f 6e al)(cdr tal)(con
3ba0: 73 20 71 72 79 20 72 65 73 29 29 29 29 29 29 29 s qry res)))))))
3bb0: 0a 20 20 20 20 20 20 23 66 29 29 0a 0a 3b 3b 20 . #f))..;;
3bc0: 43 68 65 63 6b 20 66 6f 72 20 77 61 69 76 65 72 Check for waiver
3bd0: 20 65 6c 69 67 69 62 69 6c 69 74 79 0a 3b 3b 0a eligibility.;;.
3be0: 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 63 (define (tests:c
3bf0: 68 65 63 6b 2d 77 61 69 76 65 72 2d 65 6c 69 67 heck-waiver-elig
3c00: 69 62 69 6c 69 74 79 20 74 65 73 74 64 61 74 20 ibility testdat
3c10: 70 72 65 76 2d 74 65 73 74 64 61 74 29 0a 20 20 prev-testdat).
3c20: 28 6c 65 74 2a 20 28 28 74 65 73 74 2d 72 65 67 (let* ((test-reg
3c30: 69 73 74 72 79 20 28 6d 61 6b 65 2d 68 61 73 68 istry (make-hash
3c40: 2d 74 61 62 6c 65 29 29 0a 09 20 28 74 65 73 74 -table)).. (test
3c50: 63 6f 6e 66 69 67 20 20 28 74 65 73 74 73 3a 67 config (tests:g
3c60: 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 28 64 et-testconfig (d
3c70: 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e b:test-get-testn
3c80: 61 6d 65 20 74 65 73 74 64 61 74 29 20 28 64 62 ame testdat) (db
3c90: 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 :test-get-item-p
3ca0: 61 74 68 20 74 65 73 74 64 61 74 29 20 74 65 73 ath testdat) tes
3cb0: 74 2d 72 65 67 69 73 74 72 79 20 23 66 29 29 0a t-registry #f)).
3cc0: 09 20 28 74 65 73 74 2d 72 75 6e 64 69 72 20 3b . (test-rundir ;
3cd0: 3b 20 28 73 64 62 3a 71 72 79 20 27 70 61 73 73 ; (sdb:qry 'pass
3ce0: 73 74 72 20 0a 09 20 20 28 64 62 3a 74 65 73 74 str .. (db:test
3cf0: 2d 67 65 74 2d 72 75 6e 64 69 72 20 74 65 73 74 -get-rundir test
3d00: 64 61 74 29 29 20 3b 3b 20 29 0a 09 20 28 70 72 dat)) ;; ).. (pr
3d10: 65 76 2d 72 75 6e 64 69 72 20 3b 3b 20 28 73 64 ev-rundir ;; (sd
3d20: 62 3a 71 72 79 20 27 70 61 73 73 73 74 72 20 0a b:qry 'passstr .
3d30: 09 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d . (db:test-get-
3d40: 72 75 6e 64 69 72 20 70 72 65 76 2d 74 65 73 74 rundir prev-test
3d50: 64 61 74 29 29 20 3b 3b 20 29 0a 09 20 28 77 61 dat)) ;; ).. (wa
3d60: 69 76 65 72 73 20 20 20 20 20 28 69 66 20 74 65 ivers (if te
3d70: 73 74 63 6f 6e 66 69 67 20 28 63 6f 6e 66 69 67 stconfig (config
3d80: 66 3a 73 65 63 74 69 6f 6e 2d 76 61 72 73 20 74 f:section-vars t
3d90: 65 73 74 63 6f 6e 66 69 67 20 22 77 61 69 76 65 estconfig "waive
3da0: 72 73 22 29 20 27 28 29 29 29 0a 09 20 28 77 61 rs") '())).. (wa
3db0: 69 76 65 72 2d 72 78 20 20 20 28 72 65 67 65 78 iver-rx (regex
3dc0: 70 20 22 5e 28 5c 5c 53 2b 29 5c 5c 73 2b 28 2e p "^(\\S+)\\s+(.
3dd0: 2a 29 24 22 29 29 0a 09 20 28 64 69 66 66 2d 72 *)$")).. (diff-r
3de0: 75 6c 65 20 20 20 22 64 69 66 66 20 25 66 69 6c ule "diff %fil
3df0: 65 31 25 20 25 66 69 6c 65 32 25 22 29 0a 09 20 e1% %file2%")..
3e00: 28 6c 6f 67 70 72 6f 2d 72 75 6c 65 20 22 64 69 (logpro-rule "di
3e10: 66 66 20 25 66 69 6c 65 31 25 20 25 66 69 6c 65 ff %file1% %file
3e20: 32 25 20 7c 20 6c 6f 67 70 72 6f 20 25 77 61 69 2% | logpro %wai
3e30: 76 65 72 6e 61 6d 65 25 2e 6c 6f 67 70 72 6f 20 vername%.logpro
3e40: 25 77 61 69 76 65 72 6e 61 6d 65 25 2e 68 74 6d %waivername%.htm
3e50: 6c 22 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f l")). (if (no
3e60: 74 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 t (common:file-e
3e70: 78 69 73 74 73 3f 20 74 65 73 74 2d 72 75 6e 64 xists? test-rund
3e80: 69 72 29 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 ir))..(begin..
3e90: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 (debug:print-err
3ea0: 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f or 0 *default-lo
3eb0: 67 2d 70 6f 72 74 2a 20 22 74 65 73 74 20 72 75 g-port* "test ru
3ec0: 6e 20 64 69 72 65 63 74 6f 72 79 20 69 73 20 67 n directory is g
3ed0: 6f 6e 65 2c 20 63 61 6e 6e 6f 74 20 70 72 6f 70 one, cannot prop
3ee0: 61 67 61 74 65 20 77 61 69 76 65 72 22 29 0a 09 agate waiver")..
3ef0: 20 20 23 66 29 0a 09 28 62 65 67 69 6e 0a 09 20 #f)..(begin..
3f00: 20 28 70 75 73 68 2d 64 69 72 65 63 74 6f 72 79 (push-directory
3f10: 20 74 65 73 74 2d 72 75 6e 64 69 72 29 0a 09 20 test-rundir)..
3f20: 20 28 6c 65 74 20 28 28 72 65 73 75 6c 74 20 28 (let ((result (
3f30: 69 66 20 28 6e 75 6c 6c 3f 20 77 61 69 76 65 72 if (null? waiver
3f40: 73 29 0a 09 09 09 20 20 20 20 23 66 0a 09 09 09 s).... #f....
3f50: 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 (let loop ((
3f60: 68 65 64 20 28 63 61 72 20 77 61 69 76 65 72 73 hed (car waivers
3f70: 29 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 74 ))..... (t
3f80: 61 6c 20 28 63 64 72 20 77 61 69 76 65 72 73 29 al (cdr waivers)
3f90: 29 29 0a 09 09 09 20 20 20 20 20 20 28 64 65 62 )).... (deb
3fa0: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
3fb0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 ult-log-port* "I
3fc0: 4e 46 4f 3a 20 41 70 70 6c 79 69 6e 67 20 77 61 NFO: Applying wa
3fd0: 69 76 65 72 20 72 75 6c 65 20 5c 22 22 20 68 65 iver rule \"" he
3fe0: 64 20 22 5c 22 22 29 0a 09 09 09 20 20 20 20 20 d "\"")....
3ff0: 20 28 6c 65 74 2a 20 28 28 77 61 69 76 65 72 20 (let* ((waiver
4000: 20 20 20 20 20 28 63 6f 6e 66 69 67 66 3a 6c 6f (configf:lo
4010: 6f 6b 75 70 20 74 65 73 74 63 6f 6e 66 69 67 20 okup testconfig
4020: 22 77 61 69 76 65 72 73 22 20 68 65 64 29 29 0a "waivers" hed)).
4030: 09 09 09 09 20 20 20 20 20 28 77 70 61 72 74 73 .... (wparts
4040: 20 20 20 20 20 20 28 69 66 20 77 61 69 76 65 72 (if waiver
4050: 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 77 (string-match w
4060: 61 69 76 65 72 2d 72 78 20 77 61 69 76 65 72 29 aiver-rx waiver)
4070: 20 23 66 29 29 0a 09 09 09 09 20 20 20 20 20 28 #f))..... (
4080: 77 61 69 76 65 72 2d 72 75 6c 65 20 28 69 66 20 waiver-rule (if
4090: 77 70 61 72 74 73 20 28 63 61 64 72 20 77 70 61 wparts (cadr wpa
40a0: 72 74 73 29 20 20 23 66 29 29 0a 09 09 09 09 20 rts) #f)).....
40b0: 20 20 20 20 28 77 61 69 76 65 72 2d 67 6c 6f 62 (waiver-glob
40c0: 20 28 69 66 20 77 70 61 72 74 73 20 28 63 61 64 (if wparts (cad
40d0: 64 72 20 77 70 61 72 74 73 29 20 23 66 29 29 0a dr wparts) #f)).
40e0: 09 09 09 09 20 20 20 20 20 28 6c 6f 67 70 72 6f .... (logpro
40f0: 2d 66 69 6c 65 20 28 69 66 20 77 61 69 76 65 72 -file (if waiver
4100: 0a 09 09 09 09 09 09 20 20 20 20 20 20 28 6c 65 ....... (le
4110: 74 20 28 28 66 6e 61 6d 65 20 28 63 6f 6e 63 20 t ((fname (conc
4120: 68 65 64 20 22 2e 6c 6f 67 70 72 6f 22 29 29 29 hed ".logpro")))
4130: 0a 09 09 09 09 09 09 09 28 69 66 20 28 63 6f 6d ........(if (com
4140: 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f mon:file-exists?
4150: 20 66 6e 61 6d 65 29 0a 09 09 09 09 09 09 09 20 fname)........
4160: 20 20 20 66 6e 61 6d 65 20 0a 09 09 09 09 09 09 fname .......
4170: 09 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 09 . (begin.....
4180: 09 09 09 20 20 20 20 20 20 28 64 65 62 75 67 3a ... (debug:
4190: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
41a0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 4e 46 4f -log-port* "INFO
41b0: 3a 20 4e 6f 20 6c 6f 67 70 72 6f 20 66 69 6c 65 : No logpro file
41c0: 20 22 20 66 6e 61 6d 65 20 22 20 66 61 6c 6c 69 " fname " falli
41d0: 6e 67 20 62 61 63 6b 20 74 6f 20 64 69 66 66 22 ng back to diff"
41e0: 29 0a 09 09 09 09 09 09 09 20 20 20 20 20 20 23 )........ #
41f0: 66 29 29 29 0a 09 09 09 09 09 09 20 20 20 20 20 f))).......
4200: 20 23 66 29 29 0a 09 09 09 09 20 20 20 20 20 3b #f))..... ;
4210: 3b 20 69 66 20 72 75 6c 65 20 62 79 20 6e 61 6d ; if rule by nam
4220: 65 20 6f 66 20 77 61 69 76 65 72 2d 72 75 6c 65 e of waiver-rule
4230: 20 69 73 20 66 6f 75 6e 64 20 69 6e 20 74 65 73 is found in tes
4240: 74 63 6f 6e 66 69 67 20 2d 20 75 73 65 20 69 74 tconfig - use it
4250: 0a 09 09 09 09 20 20 20 20 20 3b 3b 20 65 6c 73 ..... ;; els
4260: 65 20 69 66 20 77 61 69 76 65 72 6e 61 6d 65 2e e if waivername.
4270: 6c 6f 67 70 72 6f 20 65 78 69 73 74 73 20 75 73 logpro exists us
4280: 65 20 6c 6f 67 70 72 6f 2d 72 75 6c 65 0a 09 09 e logpro-rule...
4290: 09 09 20 20 20 20 20 3b 3b 20 65 6c 73 65 20 64 .. ;; else d
42a0: 65 66 61 75 6c 74 20 74 6f 20 64 69 66 66 2d 72 efault to diff-r
42b0: 75 6c 65 0a 09 09 09 09 20 20 20 20 20 28 72 75 ule..... (ru
42c0: 6c 65 2d 73 74 72 69 6e 67 20 28 6c 65 74 20 28 le-string (let (
42d0: 28 72 75 6c 65 20 28 63 6f 6e 66 69 67 66 3a 6c (rule (configf:l
42e0: 6f 6f 6b 75 70 20 74 65 73 74 63 6f 6e 66 69 67 ookup testconfig
42f0: 20 22 77 61 69 76 65 72 5f 72 75 6c 65 73 22 20 "waiver_rules"
4300: 77 61 69 76 65 72 2d 72 75 6c 65 29 29 29 0a 09 waiver-rule)))..
4310: 09 09 09 09 09 20 20 20 20 28 69 66 20 72 75 6c ..... (if rul
4320: 65 0a 09 09 09 09 09 09 09 72 75 6c 65 0a 09 09 e........rule...
4330: 09 09 09 09 09 28 69 66 20 6c 6f 67 70 72 6f 2d .....(if logpro-
4340: 66 69 6c 65 0a 09 09 09 09 09 09 09 20 20 20 20 file........
4350: 6c 6f 67 70 72 6f 2d 72 75 6c 65 0a 09 09 09 09 logpro-rule.....
4360: 09 09 09 20 20 20 20 28 62 65 67 69 6e 0a 09 09 ... (begin...
4370: 09 09 09 09 09 20 20 20 20 20 20 28 64 65 62 75 ..... (debu
4380: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
4390: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 4e lt-log-port* "IN
43a0: 46 4f 3a 20 4e 6f 20 6c 6f 67 70 72 6f 20 66 69 FO: No logpro fi
43b0: 6c 65 20 22 20 6c 6f 67 70 72 6f 2d 66 69 6c 65 le " logpro-file
43c0: 20 22 20 66 6f 75 6e 64 2c 20 75 73 69 6e 67 20 " found, using
43d0: 64 69 66 66 20 72 75 6c 65 22 29 0a 09 09 09 09 diff rule").....
43e0: 09 09 09 20 20 20 20 20 20 64 69 66 66 2d 72 75 ... diff-ru
43f0: 6c 65 29 29 29 29 29 0a 09 09 09 09 20 20 20 20 le))))).....
4400: 20 3b 3b 20 28 73 74 72 69 6e 67 2d 73 75 62 73 ;; (string-subs
4410: 74 69 74 75 74 65 20 22 25 66 69 6c 65 31 25 22 titute "%file1%"
4420: 20 22 66 6f 6f 66 6f 6f 2e 74 78 74 22 20 22 54 "foofoo.txt" "T
4430: 68 69 73 20 69 73 20 25 66 69 6c 65 31 25 20 61 his is %file1% a
4440: 6e 64 20 73 6f 20 69 73 20 74 68 69 73 20 25 66 nd so is this %f
4450: 69 6c 65 31 25 2e 22 20 23 74 29 0a 09 09 09 09 ile1%." #t).....
4460: 20 20 20 20 20 28 70 72 6f 63 65 73 73 65 64 2d (processed-
4470: 63 6d 64 20 28 73 74 72 69 6e 67 2d 73 75 62 73 cmd (string-subs
4480: 74 69 74 75 74 65 20 0a 09 09 09 09 09 09 20 20 titute .......
4490: 20 20 20 22 25 66 69 6c 65 31 25 22 20 28 63 6f "%file1%" (co
44a0: 6e 63 20 74 65 73 74 2d 72 75 6e 64 69 72 20 22 nc test-rundir "
44b0: 2f 22 20 77 61 69 76 65 72 2d 67 6c 6f 62 29 0a /" waiver-glob).
44c0: 09 09 09 09 09 09 20 20 20 20 20 28 73 74 72 69 ...... (stri
44d0: 6e 67 2d 73 75 62 73 74 69 74 75 74 65 0a 09 09 ng-substitute...
44e0: 09 09 09 09 20 20 20 20 20 20 22 25 66 69 6c 65 .... "%file
44f0: 32 25 22 20 28 63 6f 6e 63 20 70 72 65 76 2d 72 2%" (conc prev-r
4500: 75 6e 64 69 72 20 22 2f 22 20 77 61 69 76 65 72 undir "/" waiver
4510: 2d 67 6c 6f 62 29 0a 09 09 09 09 09 09 20 20 20 -glob).......
4520: 20 20 20 28 73 74 72 69 6e 67 2d 73 75 62 73 74 (string-subst
4530: 69 74 75 74 65 0a 09 09 09 09 09 09 20 20 20 20 itute.......
4540: 20 20 20 22 25 77 61 69 76 65 72 6e 61 6d 65 25 "%waivername%
4550: 22 20 68 65 64 20 72 75 6c 65 2d 73 74 72 69 6e " hed rule-strin
4560: 67 20 23 74 29 20 23 74 29 20 23 74 29 29 0a 09 g #t) #t) #t))..
4570: 09 09 09 20 20 20 20 20 28 72 65 73 20 20 20 20 ... (res
4580: 20 20 20 20 20 20 20 20 23 66 29 29 0a 09 09 09 #f))....
4590: 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 .(debug:print 0
45a0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
45b0: 74 2a 20 22 49 4e 46 4f 3a 20 77 61 69 76 65 72 t* "INFO: waiver
45c0: 20 63 6f 6d 6d 61 6e 64 20 69 73 20 5c 22 22 20 command is \""
45d0: 70 72 6f 63 65 73 73 65 64 2d 63 6d 64 20 22 5c processed-cmd "\
45e0: 22 22 29 0a 09 09 09 09 28 69 66 20 28 65 71 3f "").....(if (eq?
45f0: 20 28 73 79 73 74 65 6d 20 70 72 6f 63 65 73 73 (system process
4600: 65 64 2d 63 6d 64 29 20 30 29 0a 09 09 09 09 20 ed-cmd) 0).....
4610: 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 (if (null? ta
4620: 6c 29 0a 09 09 09 09 09 23 74 0a 09 09 09 09 09 l)......#t......
4630: 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 (loop (car tal)(
4640: 63 64 72 20 74 61 6c 29 29 29 0a 09 09 09 09 20 cdr tal))).....
4650: 20 20 20 23 66 29 29 29 29 29 29 0a 09 20 20 20 #f))))))..
4660: 20 28 70 6f 70 2d 64 69 72 65 63 74 6f 72 79 29 (pop-directory)
4670: 0a 09 20 20 20 20 72 65 73 75 6c 74 29 29 29 29 .. result))))
4680: 29 0a 0a 3b 3b 20 44 6f 20 6e 6f 74 20 72 70 63 )..;; Do not rpc
4690: 20 74 68 69 73 20 6f 6e 65 2c 20 64 6f 20 74 68 this one, do th
46a0: 65 20 75 6e 64 65 72 6c 79 69 6e 67 20 63 61 6c e underlying cal
46b0: 6c 73 21 21 21 0a 28 64 65 66 69 6e 65 20 28 74 ls!!!.(define (t
46c0: 65 73 74 73 3a 74 65 73 74 2d 73 65 74 2d 73 74 ests:test-set-st
46d0: 61 74 75 73 21 20 72 75 6e 2d 69 64 20 74 65 73 atus! run-id tes
46e0: 74 2d 69 64 20 73 74 61 74 65 20 73 74 61 74 75 t-id state statu
46f0: 73 20 63 6f 6d 6d 65 6e 74 20 64 61 74 20 23 21 s comment dat #!
4700: 6b 65 79 20 28 77 6f 72 6b 2d 61 72 65 61 20 23 key (work-area #
4710: 66 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 72 65 f)). (let* ((re
4720: 61 6c 2d 73 74 61 74 75 73 20 73 74 61 74 75 73 al-status status
4730: 29 0a 09 20 28 6f 74 68 65 72 64 61 74 20 20 20 ).. (otherdat
4740: 20 28 69 66 20 64 61 74 20 64 61 74 20 28 6d 61 (if dat dat (ma
4750: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 ke-hash-table)))
4760: 0a 09 20 28 74 65 73 74 64 61 74 20 20 20 20 20 .. (testdat
4770: 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 6e (rmt:get-test-in
4780: 66 6f 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 fo-by-id run-id
4790: 74 65 73 74 2d 69 64 29 29 0a 09 20 28 74 65 73 test-id)).. (tes
47a0: 74 2d 6e 61 6d 65 20 20 20 28 64 62 3a 74 65 73 t-name (db:tes
47b0: 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 20 t-get-testname
47c0: 74 65 73 74 64 61 74 29 29 0a 09 20 28 69 74 65 testdat)).. (ite
47d0: 6d 2d 70 61 74 68 20 20 20 28 64 62 3a 74 65 73 m-path (db:tes
47e0: 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 t-get-item-path
47f0: 74 65 73 74 64 61 74 29 29 0a 09 20 3b 3b 20 62 testdat)).. ;; b
4800: 65 66 6f 72 65 20 70 72 6f 63 65 65 64 69 6e 67 efore proceeding
4810: 20 77 65 20 6d 75 73 74 20 66 69 6e 64 20 6f 75 we must find ou
4820: 74 20 69 66 20 74 68 65 20 70 72 65 76 69 6f 75 t if the previou
4830: 73 20 74 65 73 74 20 28 77 68 65 72 65 20 61 6c s test (where al
4840: 6c 20 6b 65 79 73 20 6d 61 74 63 68 65 64 20 65 l keys matched e
4850: 78 63 65 70 74 20 72 75 6e 6e 61 6d 65 29 0a 09 xcept runname)..
4860: 20 3b 3b 20 77 61 73 20 57 41 49 56 45 44 20 69 ;; was WAIVED i
4870: 66 20 74 68 69 73 20 74 65 73 74 20 69 73 20 46 f this test is F
4880: 41 49 4c 0a 0a 09 20 3b 3b 20 4e 4f 54 45 53 3a AIL... ;; NOTES:
4890: 0a 09 20 3b 3b 20 20 31 2e 20 49 73 20 74 68 65 .. ;; 1. Is the
48a0: 20 63 61 6c 6c 20 74 6f 20 74 65 73 74 3a 67 65 call to test:ge
48b0: 74 2d 70 72 65 76 69 6f 75 73 2d 72 75 6e 2d 72 t-previous-run-r
48c0: 65 63 6f 72 64 20 72 65 6d 6f 74 69 66 69 65 64 ecord remotified
48d0: 3f 0a 09 20 3b 3b 20 20 32 2e 20 41 64 64 20 74 ?.. ;; 2. Add t
48e0: 65 73 74 20 66 6f 72 20 74 65 73 74 63 6f 6e 66 est for testconf
48f0: 69 67 20 77 61 69 76 65 72 20 70 72 6f 70 61 67 ig waiver propag
4900: 61 74 69 6f 6e 20 63 6f 6e 74 72 6f 6c 20 68 65 ation control he
4910: 72 65 0a 09 20 3b 3b 0a 09 20 28 70 72 65 76 2d re.. ;;.. (prev-
4920: 74 65 73 74 20 20 20 28 69 66 20 28 65 71 75 61 test (if (equa
4930: 6c 3f 20 73 74 61 74 75 73 20 22 46 41 49 4c 22 l? status "FAIL"
4940: 29 0a 09 09 09 20 20 28 72 6d 74 3a 67 65 74 2d ).... (rmt:get-
4950: 70 72 65 76 69 6f 75 73 2d 74 65 73 74 2d 72 75 previous-test-ru
4960: 6e 2d 72 65 63 6f 72 64 20 72 75 6e 2d 69 64 20 n-record run-id
4970: 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 test-name item-p
4980: 61 74 68 29 0a 09 09 09 20 20 23 66 29 29 0a 09 ath).... #f))..
4990: 20 28 77 61 69 76 65 64 20 20 20 28 69 66 20 70 (waived (if p
49a0: 72 65 76 2d 74 65 73 74 0a 09 09 20 20 20 20 20 rev-test...
49b0: 20 20 28 69 66 20 70 72 65 76 2d 74 65 73 74 20 (if prev-test
49c0: 3b 3b 20 74 72 75 65 20 69 66 20 77 65 20 66 6f ;; true if we fo
49d0: 75 6e 64 20 61 20 70 72 65 76 69 6f 75 73 20 74 und a previous t
49e0: 65 73 74 20 69 6e 20 74 68 69 73 20 72 75 6e 20 est in this run
49f0: 73 65 72 69 65 73 0a 09 09 09 20 20 20 28 6c 65 series.... (le
4a00: 74 20 28 28 70 72 65 76 2d 73 74 61 74 75 73 20 t ((prev-status
4a10: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 (db:test-get-st
4a20: 61 74 75 73 20 20 70 72 65 76 2d 74 65 73 74 29 atus prev-test)
4a30: 29 0a 09 09 09 09 20 28 70 72 65 76 2d 73 74 61 )..... (prev-sta
4a40: 74 65 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 te (db:test-ge
4a50: 74 2d 73 74 61 74 65 20 20 20 70 72 65 76 2d 74 t-state prev-t
4a60: 65 73 74 29 29 0a 09 09 09 09 20 28 70 72 65 76 est))..... (prev
4a70: 2d 63 6f 6d 6d 65 6e 74 20 28 64 62 3a 74 65 73 -comment (db:tes
4a80: 74 2d 67 65 74 2d 63 6f 6d 6d 65 6e 74 20 70 72 t-get-comment pr
4a90: 65 76 2d 74 65 73 74 29 29 29 0a 09 09 09 20 20 ev-test)))....
4aa0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
4ab0: 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 4 *default-log-p
4ac0: 6f 72 74 2a 20 22 70 72 65 76 2d 73 74 61 74 75 ort* "prev-statu
4ad0: 73 20 22 20 70 72 65 76 2d 73 74 61 74 75 73 20 s " prev-status
4ae0: 22 2c 20 70 72 65 76 2d 73 74 61 74 65 20 22 20 ", prev-state "
4af0: 70 72 65 76 2d 73 74 61 74 65 20 22 2c 20 70 72 prev-state ", pr
4b00: 65 76 2d 63 6f 6d 6d 65 6e 74 20 22 20 70 72 65 ev-comment " pre
4b10: 76 2d 63 6f 6d 6d 65 6e 74 29 0a 09 09 09 20 20 v-comment)....
4b20: 20 20 20 28 69 66 20 28 61 6e 64 20 28 65 71 75 (if (and (equ
4b30: 61 6c 3f 20 70 72 65 76 2d 73 74 61 74 65 20 20 al? prev-state
4b40: 22 43 4f 4d 50 4c 45 54 45 44 22 29 0a 09 09 09 "COMPLETED")....
4b50: 09 20 20 20 20 20 20 28 65 71 75 61 6c 3f 20 70 . (equal? p
4b60: 72 65 76 2d 73 74 61 74 75 73 20 22 57 41 49 56 rev-status "WAIV
4b70: 45 44 22 29 29 0a 09 09 09 09 20 28 69 66 20 63 ED"))..... (if c
4b80: 6f 6d 6d 65 6e 74 0a 09 09 09 09 20 20 20 20 20 omment.....
4b90: 63 6f 6d 6d 65 6e 74 0a 09 09 09 09 20 20 20 20 comment.....
4ba0: 20 70 72 65 76 2d 63 6f 6d 6d 65 6e 74 29 20 3b prev-comment) ;
4bb0: 3b 20 77 61 69 76 65 64 20 69 73 20 65 69 74 68 ; waived is eith
4bc0: 65 72 20 74 68 65 20 63 6f 6d 6d 65 6e 74 20 6f er the comment o
4bd0: 72 20 23 66 0a 09 09 09 09 20 23 66 29 29 0a 09 r #f..... #f))..
4be0: 09 09 20 20 20 23 66 29 0a 09 09 20 20 20 20 20 .. #f)...
4bf0: 20 20 23 66 29 29 29 0a 20 20 20 20 28 69 66 20 #f))). (if
4c00: 28 61 6e 64 20 77 61 69 76 65 64 20 0a 09 20 20 (and waived ..
4c10: 20 20 20 28 74 65 73 74 73 3a 63 68 65 63 6b 2d (tests:check-
4c20: 77 61 69 76 65 72 2d 65 6c 69 67 69 62 69 6c 69 waiver-eligibili
4c30: 74 79 20 74 65 73 74 64 61 74 20 70 72 65 76 2d ty testdat prev-
4c40: 74 65 73 74 29 29 0a 09 28 73 65 74 21 20 72 65 test))..(set! re
4c50: 61 6c 2d 73 74 61 74 75 73 20 22 57 41 49 56 45 al-status "WAIVE
4c60: 44 22 29 29 0a 0a 20 20 20 20 28 64 65 62 75 67 D")).. (debug
4c70: 3a 70 72 69 6e 74 20 34 20 2a 64 65 66 61 75 6c :print 4 *defaul
4c80: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 65 61 t-log-port* "rea
4c90: 6c 2d 73 74 61 74 75 73 20 22 20 72 65 61 6c 2d l-status " real-
4ca0: 73 74 61 74 75 73 20 22 2c 20 77 61 69 76 65 64 status ", waived
4cb0: 20 22 20 77 61 69 76 65 64 20 22 2c 20 73 74 61 " waived ", sta
4cc0: 74 75 73 20 22 20 73 74 61 74 75 73 29 0a 0a 20 tus " status)..
4cd0: 20 20 20 3b 3b 20 75 70 64 61 74 65 20 74 68 65 ;; update the
4ce0: 20 70 72 69 6d 61 72 79 20 72 65 63 6f 72 64 20 primary record
4cf0: 49 46 20 73 74 61 74 65 20 41 4e 44 20 73 74 61 IF state AND sta
4d00: 74 75 73 20 61 72 65 20 64 65 66 69 6e 65 64 0a tus are defined.
4d10: 20 20 20 20 28 69 66 20 28 61 6e 64 20 73 74 61 (if (and sta
4d20: 74 65 20 73 74 61 74 75 73 29 0a 09 28 62 65 67 te status)..(beg
4d30: 69 6e 0a 09 20 20 28 72 6d 74 3a 73 65 74 2d 73 in.. (rmt:set-s
4d40: 74 61 74 65 2d 73 74 61 74 75 73 2d 61 6e 64 2d tate-status-and-
4d50: 72 6f 6c 6c 2d 75 70 2d 69 74 65 6d 73 20 72 75 roll-up-items ru
4d60: 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 69 74 65 n-id test-id ite
4d70: 6d 2d 70 61 74 68 20 73 74 61 74 65 20 72 65 61 m-path state rea
4d80: 6c 2d 73 74 61 74 75 73 20 28 69 66 20 77 61 69 l-status (if wai
4d90: 76 65 64 20 77 61 69 76 65 64 20 63 6f 6d 6d 65 ved waived comme
4da0: 6e 74 29 29 0a 09 20 20 3b 3b 20 28 6d 74 3a 70 nt)).. ;; (mt:p
4db0: 72 6f 63 65 73 73 2d 74 72 69 67 67 65 72 73 20 rocess-triggers
4dc0: 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 73 run-id test-id s
4dd0: 74 61 74 65 20 72 65 61 6c 2d 73 74 61 74 75 73 tate real-status
4de0: 29 20 3b 3b 20 74 72 69 67 67 65 72 73 20 61 72 ) ;; triggers ar
4df0: 65 20 63 61 6c 6c 65 64 20 69 6e 20 74 65 73 74 e called in test
4e00: 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 -set-state-statu
4e10: 73 0a 09 20 20 29 29 0a 20 20 20 20 0a 20 20 20 s.. )). .
4e20: 20 3b 3b 20 69 66 20 73 74 61 74 75 73 20 69 73 ;; if status is
4e30: 20 22 41 55 54 4f 22 20 74 68 65 6e 20 63 61 6c "AUTO" then cal
4e40: 6c 20 72 6f 6c 6c 75 70 20 28 6e 6f 74 65 2c 20 l rollup (note,
4e50: 74 68 69 73 20 6f 6e 65 20 6d 6f 64 69 66 69 65 this one modifie
4e60: 73 20 64 61 74 61 20 69 6e 20 74 65 73 74 0a 20 s data in test.
4e70: 20 20 20 3b 3b 20 72 75 6e 20 61 72 65 61 2c 20 ;; run area,
4e80: 69 74 20 64 6f 65 73 20 72 65 6d 6f 74 65 20 63 it does remote c
4e90: 61 6c 6c 73 20 75 6e 64 65 72 20 74 68 65 20 68 alls under the h
4ea0: 6f 6f 64 2e 0a 20 20 20 20 3b 3b 20 28 69 66 20 ood.. ;; (if
4eb0: 28 61 6e 64 20 74 65 73 74 2d 69 64 20 73 74 61 (and test-id sta
4ec0: 74 65 20 73 74 61 74 75 73 20 28 65 71 75 61 6c te status (equal
4ed0: 3f 20 73 74 61 74 75 73 20 22 41 55 54 4f 22 29 ? status "AUTO")
4ee0: 29 20 0a 20 20 20 20 3b 3b 20 09 28 72 6d 74 3a ) . ;; .(rmt:
4ef0: 74 65 73 74 2d 64 61 74 61 2d 72 6f 6c 6c 75 70 test-data-rollup
4f00: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 run-id test-id
4f10: 73 74 61 74 75 73 29 29 0a 0a 20 20 20 20 3b 3b status)).. ;;
4f20: 20 61 64 64 20 6d 65 74 61 64 61 74 61 20 28 6e add metadata (n
4f30: 65 65 64 20 74 6f 20 64 6f 20 74 68 69 73 20 77 eed to do this w
4f40: 61 79 20 74 6f 20 61 76 6f 69 64 20 53 51 4c 20 ay to avoid SQL
4f50: 69 6e 6a 65 63 74 69 6f 6e 20 69 73 73 75 65 73 injection issues
4f60: 29 0a 0a 20 20 20 20 3b 3b 20 3a 66 69 72 73 74 ).. ;; :first
4f70: 5f 65 72 72 0a 20 20 20 20 3b 3b 20 28 6c 65 74 _err. ;; (let
4f80: 20 28 28 76 61 6c 20 28 68 61 73 68 2d 74 61 62 ((val (hash-tab
4f90: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 6f le-ref/default o
4fa0: 74 68 65 72 64 61 74 20 22 3a 66 69 72 73 74 5f therdat ":first_
4fb0: 65 72 72 22 20 23 66 29 29 29 0a 20 20 20 20 3b err" #f))). ;
4fc0: 3b 20 20 20 28 69 66 20 76 61 6c 0a 20 20 20 20 ; (if val.
4fd0: 3b 3b 20 20 20 20 20 20 20 28 73 71 6c 69 74 65 ;; (sqlite
4fe0: 33 3a 65 78 65 63 75 74 65 20 64 62 20 22 55 50 3:execute db "UP
4ff0: 44 41 54 45 20 74 65 73 74 73 20 53 45 54 20 66 DATE tests SET f
5000: 69 72 73 74 5f 65 72 72 3d 3f 20 57 48 45 52 45 irst_err=? WHERE
5010: 20 72 75 6e 5f 69 64 3d 3f 20 41 4e 44 20 74 65 run_id=? AND te
5020: 73 74 6e 61 6d 65 3d 3f 20 41 4e 44 20 69 74 65 stname=? AND ite
5030: 6d 5f 70 61 74 68 3d 3f 3b 22 20 76 61 6c 20 72 m_path=?;" val r
5040: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 un-id test-name
5050: 69 74 65 6d 2d 70 61 74 68 29 29 29 0a 20 20 20 item-path))).
5060: 20 3b 3b 20 0a 20 20 20 20 3b 3b 20 3b 3b 20 3a ;; . ;; ;; :
5070: 66 69 72 73 74 5f 77 61 72 6e 0a 20 20 20 20 3b first_warn. ;
5080: 3b 20 28 6c 65 74 20 28 28 76 61 6c 20 28 68 61 ; (let ((val (ha
5090: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
50a0: 61 75 6c 74 20 6f 74 68 65 72 64 61 74 20 22 3a ault otherdat ":
50b0: 66 69 72 73 74 5f 77 61 72 6e 22 20 23 66 29 29 first_warn" #f))
50c0: 29 0a 20 20 20 20 3b 3b 20 20 20 28 69 66 20 76 ). ;; (if v
50d0: 61 6c 0a 20 20 20 20 3b 3b 20 20 20 20 20 20 20 al. ;;
50e0: 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 (sqlite3:execute
50f0: 20 64 62 20 22 55 50 44 41 54 45 20 74 65 73 74 db "UPDATE test
5100: 73 20 53 45 54 20 66 69 72 73 74 5f 77 61 72 6e s SET first_warn
5110: 3d 3f 20 57 48 45 52 45 20 72 75 6e 5f 69 64 3d =? WHERE run_id=
5120: 3f 20 41 4e 44 20 74 65 73 74 6e 61 6d 65 3d 3f ? AND testname=?
5130: 20 41 4e 44 20 69 74 65 6d 5f 70 61 74 68 3d 3f AND item_path=?
5140: 3b 22 20 76 61 6c 20 72 75 6e 2d 69 64 20 74 65 ;" val run-id te
5150: 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 st-name item-pat
5160: 68 29 29 29 0a 0a 20 20 20 20 28 6c 65 74 20 28 h))).. (let (
5170: 28 63 61 74 65 67 6f 72 79 20 28 68 61 73 68 2d (category (hash-
5180: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
5190: 74 20 6f 74 68 65 72 64 61 74 20 22 3a 63 61 74 t otherdat ":cat
51a0: 65 67 6f 72 79 22 20 22 22 29 29 0a 09 20 20 28 egory" "")).. (
51b0: 76 61 72 69 61 62 6c 65 20 28 68 61 73 68 2d 74 variable (hash-t
51c0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
51d0: 20 6f 74 68 65 72 64 61 74 20 22 3a 76 61 72 69 otherdat ":vari
51e0: 61 62 6c 65 22 20 22 22 29 29 0a 09 20 20 28 76 able" "")).. (v
51f0: 61 6c 75 65 20 20 20 20 28 68 61 73 68 2d 74 61 alue (hash-ta
5200: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
5210: 6f 74 68 65 72 64 61 74 20 22 3a 76 61 6c 75 65 otherdat ":value
5220: 22 20 20 20 20 23 66 29 29 0a 09 20 20 28 65 78 " #f)).. (ex
5230: 70 65 63 74 65 64 20 28 68 61 73 68 2d 74 61 62 pected (hash-tab
5240: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 6f le-ref/default o
5250: 74 68 65 72 64 61 74 20 22 3a 65 78 70 65 63 74 therdat ":expect
5260: 65 64 22 20 22 6e 2f 61 22 29 29 0a 09 20 20 28 ed" "n/a")).. (
5270: 74 6f 6c 20 20 20 20 20 20 28 68 61 73 68 2d 74 tol (hash-t
5280: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
5290: 20 6f 74 68 65 72 64 61 74 20 22 3a 74 6f 6c 22 otherdat ":tol"
52a0: 20 20 20 20 20 20 22 6e 2f 61 22 29 29 0a 09 20 "n/a"))..
52b0: 20 28 75 6e 69 74 73 20 20 20 20 28 68 61 73 68 (units (hash
52c0: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
52d0: 6c 74 20 6f 74 68 65 72 64 61 74 20 22 3a 75 6e lt otherdat ":un
52e0: 69 74 73 22 20 20 20 20 22 22 29 29 0a 09 20 20 its" ""))..
52f0: 28 74 79 70 65 20 20 20 20 20 28 68 61 73 68 2d (type (hash-
5300: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
5310: 74 20 6f 74 68 65 72 64 61 74 20 22 3a 74 79 70 t otherdat ":typ
5320: 65 22 20 20 20 20 20 22 22 29 29 0a 09 20 20 28 e" "")).. (
5330: 64 63 6f 6d 6d 65 6e 74 20 28 68 61 73 68 2d 74 dcomment (hash-t
5340: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
5350: 20 6f 74 68 65 72 64 61 74 20 22 3a 63 6f 6d 6d otherdat ":comm
5360: 65 6e 74 22 20 20 22 22 29 29 29 0a 20 20 20 20 ent" ""))).
5370: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 (debug:print 4
5380: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
5390: 72 74 2a 20 0a 09 09 20 20 20 22 63 61 74 65 67 rt* ... "categ
53a0: 6f 72 79 3a 20 22 20 63 61 74 65 67 6f 72 79 20 ory: " category
53b0: 22 2c 20 76 61 72 69 61 62 6c 65 3a 20 22 20 76 ", variable: " v
53c0: 61 72 69 61 62 6c 65 20 22 2c 20 76 61 6c 75 65 ariable ", value
53d0: 3a 20 22 20 76 61 6c 75 65 0a 09 09 20 20 20 22 : " value... "
53e0: 2c 20 65 78 70 65 63 74 65 64 3a 20 22 20 65 78 , expected: " ex
53f0: 70 65 63 74 65 64 20 22 2c 20 74 6f 6c 3a 20 22 pected ", tol: "
5400: 20 74 6f 6c 20 22 2c 20 75 6e 69 74 73 3a 20 22 tol ", units: "
5410: 20 75 6e 69 74 73 29 0a 20 20 20 20 20 20 28 69 units). (i
5420: 66 20 28 61 6e 64 20 76 61 6c 75 65 29 20 3b 3b f (and value) ;;
5430: 20 72 65 71 75 69 72 65 20 6f 6e 6c 79 20 76 61 require only va
5440: 6c 75 65 3b 20 42 42 20 77 61 73 2d 20 61 6c 6c lue; BB was- all
5450: 20 74 68 72 65 65 20 72 65 71 75 69 72 65 64 0a three required.
5460: 09 20 20 28 6c 65 74 20 28 28 64 61 74 20 28 63 . (let ((dat (c
5470: 6f 6e 63 20 63 61 74 65 67 6f 72 79 20 22 2c 22 onc category ","
5480: 0a 09 09 09 20 20 20 76 61 72 69 61 62 6c 65 20 .... variable
5490: 22 2c 22 0a 09 09 09 20 20 20 76 61 6c 75 65 20 ",".... value
54a0: 20 20 20 22 2c 22 0a 09 09 09 20 20 20 65 78 70 ",".... exp
54b0: 65 63 74 65 64 20 22 2c 22 0a 09 09 09 20 20 20 ected ","....
54c0: 74 6f 6c 20 20 20 20 20 20 22 2c 22 0a 09 09 09 tol ","....
54d0: 20 20 20 75 6e 69 74 73 20 20 20 20 22 2c 22 0a units ",".
54e0: 09 09 09 20 20 20 64 63 6f 6d 6d 65 6e 74 20 22 ... dcomment "
54f0: 2c 2c 22 20 3b 3b 20 65 78 74 72 61 20 63 6f 6d ,," ;; extra com
5500: 6d 61 20 66 6f 72 20 73 74 61 74 75 73 0a 09 09 ma for status...
5510: 09 20 20 20 74 79 70 65 20 20 20 20 20 29 29 29 . type )))
5520: 0a 09 20 20 20 20 3b 3b 20 54 68 69 73 20 77 61 .. ;; This wa
5530: 73 20 72 75 6e 20 72 65 6d 6f 74 65 2c 20 64 6f s run remote, do
5540: 6e 27 74 20 74 68 69 6e 6b 20 74 68 61 74 20 6d n't think that m
5550: 61 6b 65 73 20 73 65 6e 73 65 2e 20 50 65 72 68 akes sense. Perh
5560: 61 70 73 20 6e 6f 74 2c 20 62 75 74 20 74 68 61 aps not, but tha
5570: 74 20 69 73 20 74 68 65 20 65 61 73 69 65 73 74 t is the easiest
5580: 20 70 61 74 68 20 66 6f 72 20 74 68 65 20 6d 6f path for the mo
5590: 6d 65 6e 74 2e 0a 09 20 20 20 20 28 72 6d 74 3a ment... (rmt:
55a0: 63 73 76 2d 3e 74 65 73 74 2d 64 61 74 61 20 72 csv->test-data r
55b0: 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 0a 09 09 un-id test-id...
55c0: 09 09 64 61 74 29 0a 09 20 20 20 20 3b 3b 20 54 ..dat).. ;; T
55d0: 68 69 73 20 77 61 73 20 61 64 64 65 64 20 69 6e his was added in
55e0: 20 63 68 65 63 6b 2d 69 6e 20 61 35 61 64 66 61 check-in a5adfa
55f0: 33 66 39 61 2e 20 4d 65 73 73 61 67 65 20 77 61 3f9a. Message wa
5600: 73 3a 20 22 2e 2e 2e 61 64 64 65 64 20 64 65 6c s: "...added del
5610: 61 79 20 69 6e 20 73 65 74 2d 76 61 6c 75 65 73 ay in set-values
5620: 20 74 6f 20 61 6c 6c 6f 77 20 66 6f 72 20 64 65 to allow for de
5630: 6c 61 79 65 64 20 77 72 69 74 65 20 6f 6e 20 73 layed write on s
5640: 65 72 76 65 72 20 73 74 61 72 74 22 0a 09 20 20 erver start"..
5650: 20 20 3b 3b 20 49 27 6d 20 69 6e 73 65 72 74 69 ;; I'm inserti
5660: 6e 67 20 61 6e 20 61 72 62 69 74 72 61 72 79 20 ng an arbitrary
5670: 72 6d 74 3a 20 63 61 6c 6c 20 74 6f 20 66 6f 72 rmt: call to for
5680: 63 65 2f 65 6e 73 75 72 65 20 74 68 61 74 20 74 ce/ensure that t
5690: 68 65 20 73 65 72 76 65 72 20 69 73 20 61 76 61 he server is ava
56a0: 69 6c 61 62 6c 65 20 74 6f 20 28 68 6f 70 65 66 ilable to (hopef
56b0: 75 6c 6c 79 29 20 70 72 65 76 65 6e 74 20 61 20 ully) prevent a
56c0: 63 6f 6d 6d 75 6e 69 63 61 74 69 6f 6e 20 69 73 communication is
56d0: 73 75 65 2e 0a 09 20 20 20 20 28 72 6d 74 3a 67 sue... (rmt:g
56e0: 65 74 2d 76 61 72 20 22 4d 45 47 41 54 45 53 54 et-var "MEGATEST
56f0: 5f 56 45 52 53 49 4f 4e 22 29 20 3b 3b 20 74 68 _VERSION") ;; th
5700: 69 73 20 64 6f 65 73 20 4e 4f 54 48 49 4e 47 20 is does NOTHING
5710: 62 75 74 20 65 6e 73 75 72 65 20 74 68 65 20 73 but ensure the s
5720: 65 72 76 65 72 20 69 73 20 72 65 61 63 68 61 62 erver is reachab
5730: 6c 65 2e 20 54 68 69 73 20 69 73 20 61 6c 6d 6f le. This is almo
5740: 73 74 20 63 65 72 74 61 69 6e 6c 79 20 4e 4f 54 st certainly NOT
5750: 20 6e 65 65 64 65 64 20 3a 29 0a 20 20 20 20 20 needed :).
5760: 20 20 20 20 20 20 20 3b 3b 20 42 42 20 2d 20 63 ;; BB - c
5770: 6f 6d 6d 65 6e 74 69 6f 6e 67 20 6f 75 74 20 61 ommentiong out a
5780: 72 62 69 74 72 61 72 79 20 31 30 20 73 65 63 6f rbitrary 10 seco
5790: 6e 64 20 77 61 69 74 20 28 74 68 72 65 61 64 2d nd wait (thread-
57a0: 73 6c 65 65 70 21 20 31 30 29 20 3b 3b 20 61 64 sleep! 10) ;; ad
57b0: 64 20 31 30 20 73 65 63 6f 6e 64 20 64 65 6c 61 d 10 second dela
57c0: 79 20 62 65 66 6f 72 65 20 71 75 69 74 20 69 6e y before quit in
57d0: 63 61 73 65 20 72 6d 74 20 6e 65 65 64 73 20 74 case rmt needs t
57e0: 69 6d 65 20 74 6f 20 73 74 61 72 74 20 61 20 73 ime to start a s
57f0: 65 72 76 65 72 2e 0a 20 20 20 20 20 20 20 20 20 erver..
5800: 20 20 20 29 29 29 0a 20 20 20 20 20 20 0a 20 20 ))). .
5810: 20 20 3b 3b 20 6e 65 65 64 20 74 6f 20 75 70 64 ;; need to upd
5820: 61 74 65 20 74 68 65 20 74 6f 70 20 74 65 73 74 ate the top test
5830: 20 72 65 63 6f 72 64 20 69 66 20 50 41 53 53 20 record if PASS
5840: 6f 72 20 46 41 49 4c 20 61 6e 64 20 74 68 69 73 or FAIL and this
5850: 20 69 73 20 61 20 73 75 62 74 65 73 74 0a 20 20 is a subtest.
5860: 20 20 3b 3b 3b 3b 3b 3b 20 28 69 66 20 28 6e 6f ;;;;;; (if (no
5870: 74 20 28 65 71 75 61 6c 3f 20 69 74 65 6d 2d 70 t (equal? item-p
5880: 61 74 68 20 22 22 29 29 0a 20 20 20 20 3b 3b 3b ath "")). ;;;
5890: 3b 3b 3b 20 20 20 20 20 28 72 6d 74 3a 73 65 74 ;;; (rmt:set
58a0: 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d 61 6e -state-status-an
58b0: 64 2d 72 6f 6c 6c 2d 75 70 2d 69 74 65 6d 73 20 d-roll-up-items
58c0: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
58d0: 20 69 74 65 6d 2d 70 61 74 68 20 73 74 61 74 65 item-path state
58e0: 20 73 74 61 74 75 73 20 23 66 29 20 3b 3b 3b 3b status #f) ;;;;
58f0: 3b 29 0a 0a 20 20 20 20 28 69 66 20 28 6f 72 20 ;).. (if (or
5900: 28 61 6e 64 20 28 73 74 72 69 6e 67 3f 20 63 6f (and (string? co
5910: 6d 6d 65 6e 74 29 0a 09 09 20 28 73 74 72 69 6e mment)... (strin
5920: 67 2d 6d 61 74 63 68 20 28 72 65 67 65 78 70 20 g-match (regexp
5930: 22 5c 5c 53 2b 22 29 20 63 6f 6d 6d 65 6e 74 29 "\\S+") comment)
5940: 29 0a 09 20 20 20 20 77 61 69 76 65 64 29 0a 09 ).. waived)..
5950: 28 6c 65 74 20 28 28 63 6d 74 20 20 28 69 66 20 (let ((cmt (if
5960: 77 61 69 76 65 64 20 77 61 69 76 65 64 20 63 6f waived waived co
5970: 6d 6d 65 6e 74 29 29 29 0a 09 20 20 28 72 6d 74 mment))).. (rmt
5980: 3a 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 73 :general-call 's
5990: 65 74 2d 74 65 73 74 2d 63 6f 6d 6d 65 6e 74 20 et-test-comment
59a0: 72 75 6e 2d 69 64 20 63 6d 74 20 74 65 73 74 2d run-id cmt test-
59b0: 69 64 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 id)))))..(define
59c0: 20 28 74 65 73 74 73 3a 74 65 73 74 2d 73 65 74 (tests:test-set
59d0: 2d 74 6f 70 6c 6f 67 21 20 72 75 6e 2d 69 64 20 -toplog! run-id
59e0: 74 65 73 74 2d 6e 61 6d 65 20 6c 6f 67 66 29 20 test-name logf)
59f0: 0a 20 20 28 72 6d 74 3a 67 65 6e 65 72 61 6c 2d . (rmt:general-
5a00: 63 61 6c 6c 20 27 74 65 73 74 73 3a 74 65 73 74 call 'tests:test
5a10: 2d 73 65 74 2d 74 6f 70 6c 6f 67 20 72 75 6e 2d -set-toplog run-
5a20: 69 64 20 6c 6f 67 66 20 72 75 6e 2d 69 64 20 74 id logf run-id t
5a30: 65 73 74 2d 6e 61 6d 65 29 29 0a 0a 28 64 65 66 est-name))..(def
5a40: 69 6e 65 20 28 74 65 73 74 73 3a 73 75 6d 6d 61 ine (tests:summa
5a50: 72 69 7a 65 2d 69 74 65 6d 73 20 72 75 6e 2d 69 rize-items run-i
5a60: 64 20 74 65 73 74 2d 69 64 20 74 65 73 74 2d 6e d test-id test-n
5a70: 61 6d 65 20 66 6f 72 63 65 29 0a 20 20 3b 3b 20 ame force). ;;
5a80: 69 66 20 6e 6f 74 20 66 6f 72 63 65 20 74 68 65 if not force the
5a90: 6e 20 6f 6e 6c 79 20 75 70 64 61 74 65 20 74 68 n only update th
5aa0: 65 20 72 65 63 6f 72 64 20 69 66 20 6f 6e 65 20 e record if one
5ab0: 6f 66 20 74 68 65 73 65 20 69 73 20 74 72 75 65 of these is true
5ac0: 3a 0a 20 20 3b 3b 20 20 20 31 2e 20 6c 6f 67 66 :. ;; 1. logf
5ad0: 20 69 73 20 22 6c 6f 67 2f 66 69 6e 61 6c 2e 6c is "log/final.l
5ae0: 6f 67 0a 20 20 3b 3b 20 20 20 32 2e 20 6c 6f 67 og. ;; 2. log
5af0: 66 20 69 73 20 73 61 6d 65 20 61 73 20 6f 75 74 f is same as out
5b00: 70 75 74 66 69 6c 65 6e 61 6d 65 0a 20 20 28 6c putfilename. (l
5b10: 65 74 2a 20 28 28 6f 75 74 70 75 74 66 69 6c 65 et* ((outputfile
5b20: 6e 61 6d 65 20 28 63 6f 6e 63 20 22 6d 65 67 61 name (conc "mega
5b30: 74 65 73 74 2d 72 6f 6c 6c 75 70 2d 22 20 74 65 test-rollup-" te
5b40: 73 74 2d 6e 61 6d 65 20 22 2e 68 74 6d 6c 22 29 st-name ".html")
5b50: 29 0a 09 20 28 6f 72 69 67 2d 64 69 72 20 20 20 ).. (orig-dir
5b60: 20 20 20 20 28 63 75 72 72 65 6e 74 2d 64 69 72 (current-dir
5b70: 65 63 74 6f 72 79 29 29 0a 09 20 28 6c 6f 67 66 ectory)).. (logf
5b80: 2d 69 6e 66 6f 20 20 20 20 20 20 28 72 6d 74 3a -info (rmt:
5b90: 74 65 73 74 2d 67 65 74 2d 6c 6f 67 66 69 6c 65 test-get-logfile
5ba0: 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 20 74 65 73 -info run-id tes
5bb0: 74 2d 6e 61 6d 65 29 29 0a 09 20 28 6c 6f 67 66 t-name)).. (logf
5bc0: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 6c (if l
5bd0: 6f 67 66 2d 69 6e 66 6f 20 28 63 61 64 72 20 6c ogf-info (cadr l
5be0: 6f 67 66 2d 69 6e 66 6f 29 20 23 66 29 29 0a 09 ogf-info) #f))..
5bf0: 20 28 70 61 74 68 20 20 20 20 20 20 20 20 20 20 (path
5c00: 20 28 69 66 20 6c 6f 67 66 2d 69 6e 66 6f 20 28 (if logf-info (
5c10: 63 61 72 20 20 6c 6f 67 66 2d 69 6e 66 6f 29 20 car logf-info)
5c20: 23 66 29 29 29 0a 20 20 20 20 3b 3b 20 54 68 69 #f))). ;; Thi
5c30: 73 20 71 75 65 72 79 20 66 69 6e 64 73 20 74 68 s query finds th
5c40: 65 20 70 61 74 68 20 61 6e 64 20 63 68 61 6e 67 e path and chang
5c50: 65 73 20 74 68 65 20 64 69 72 65 63 74 6f 72 79 es the directory
5c60: 20 74 6f 20 69 74 20 66 6f 72 20 74 68 65 20 74 to it for the t
5c70: 65 73 74 0a 20 20 20 20 28 69 66 20 28 61 6e 64 est. (if (and
5c80: 20 28 73 74 72 69 6e 67 3f 20 70 61 74 68 29 0a (string? path).
5c90: 09 20 20 20 20 20 28 64 69 72 65 63 74 6f 72 79 . (directory
5ca0: 3f 20 70 61 74 68 29 29 20 3b 3b 20 63 61 6e 20 ? path)) ;; can
5cb0: 67 65 74 20 23 66 20 68 65 72 65 20 75 6e 64 65 get #f here unde
5cc0: 72 20 73 6f 6d 65 20 77 69 65 72 64 20 63 6f 6e r some wierd con
5cd0: 64 69 74 69 6f 6e 73 2e 20 77 68 79 2c 20 75 6e ditions. why, un
5ce0: 6b 6e 6f 77 6e 20 2e 2e 2e 0a 09 28 62 65 67 69 known .....(begi
5cf0: 6e 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e n.. (debug:prin
5d00: 74 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 4 *default-log
5d10: 2d 70 6f 72 74 2a 20 22 46 6f 75 6e 64 20 70 61 -port* "Found pa
5d20: 74 68 3a 20 22 20 70 61 74 68 29 0a 09 20 20 28 th: " path).. (
5d30: 63 68 61 6e 67 65 2d 64 69 72 65 63 74 6f 72 79 change-directory
5d40: 20 70 61 74 68 29 29 0a 09 3b 3b 20 28 73 65 74 path))..;; (set
5d50: 21 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 ! outputfilename
5d60: 20 28 63 6f 6e 63 20 70 61 74 68 20 22 2f 22 20 (conc path "/"
5d70: 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 29 29 outputfilename))
5d80: 29 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d )..(debug:print-
5d90: 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 error 0 *default
5da0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 75 6d 6d -log-port* "summ
5db0: 61 72 69 7a 65 2d 69 74 65 6d 73 20 66 6f 72 20 arize-items for
5dc0: 72 75 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 64 20 run-id=" run-id
5dd0: 22 2c 20 74 65 73 74 2d 6e 61 6d 65 3d 22 20 74 ", test-name=" t
5de0: 65 73 74 2d 6e 61 6d 65 20 22 2c 20 6e 6f 20 73 est-name ", no s
5df0: 75 63 68 20 70 61 74 68 3a 20 22 20 70 61 74 68 uch path: " path
5e00: 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 )). (debug:pr
5e10: 69 6e 74 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c int 4 *default-l
5e20: 6f 67 2d 70 6f 72 74 2a 20 22 73 75 6d 6d 61 72 og-port* "summar
5e30: 69 7a 65 2d 69 74 65 6d 73 20 77 69 74 68 20 6c ize-items with l
5e40: 6f 67 66 20 22 20 6c 6f 67 66 20 22 2c 20 6f 75 ogf " logf ", ou
5e50: 74 70 75 74 66 69 6c 65 6e 61 6d 65 20 22 20 6f tputfilename " o
5e60: 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 20 22 20 utputfilename "
5e70: 61 6e 64 20 66 6f 72 63 65 20 22 20 66 6f 72 63 and force " forc
5e80: 65 29 0a 20 20 20 20 28 69 66 20 28 6f 72 20 28 e). (if (or (
5e90: 65 71 75 61 6c 3f 20 6c 6f 67 66 20 22 6c 6f 67 equal? logf "log
5ea0: 73 2f 66 69 6e 61 6c 2e 6c 6f 67 22 29 0a 09 20 s/final.log")..
5eb0: 20 20 20 28 65 71 75 61 6c 3f 20 6c 6f 67 66 20 (equal? logf
5ec0: 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 29 0a outputfilename).
5ed0: 09 20 20 20 20 66 6f 72 63 65 29 0a 09 28 6c 65 . force)..(le
5ee0: 74 20 28 28 6d 79 2d 73 74 61 72 74 2d 74 69 6d t ((my-start-tim
5ef0: 65 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e e (current-secon
5f00: 64 73 29 29 0a 09 20 20 20 20 20 20 28 6c 6f 63 ds)).. (loc
5f10: 6b 66 20 20 20 20 20 20 20 20 20 28 63 6f 6e 63 kf (conc
5f20: 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 20 outputfilename
5f30: 22 2e 6c 6f 63 6b 22 29 29 29 0a 09 20 20 28 6c ".lock"))).. (l
5f40: 65 74 20 6c 6f 6f 70 20 28 28 68 61 76 65 2d 6c et loop ((have-l
5f50: 6f 63 6b 20 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d ock (common:sim
5f60: 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 20 6c 6f ple-file-lock lo
5f70: 63 6b 66 29 29 29 0a 09 20 20 20 20 28 69 66 20 ckf))).. (if
5f80: 68 61 76 65 2d 6c 6f 63 6b 0a 09 09 28 6c 65 74 have-lock...(let
5f90: 20 28 28 73 63 72 69 70 74 20 28 63 6f 6e 66 69 ((script (confi
5fa0: 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 gf:lookup *confi
5fb0: 67 64 61 74 2a 20 22 74 65 73 74 72 6f 6c 6c 75 gdat* "testrollu
5fc0: 70 22 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a p" test-name))).
5fd0: 09 09 20 20 28 70 72 69 6e 74 20 22 4f 62 74 61 .. (print "Obta
5fe0: 69 6e 65 64 20 6c 6f 63 6b 20 66 6f 72 20 22 20 ined lock for "
5ff0: 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 29 0a outputfilename).
6000: 09 09 20 20 28 72 6d 74 3a 73 65 74 2d 73 74 61 .. (rmt:set-sta
6010: 74 65 2d 73 74 61 74 75 73 2d 61 6e 64 2d 72 6f te-status-and-ro
6020: 6c 6c 2d 75 70 2d 69 74 65 6d 73 20 72 75 6e 2d ll-up-items run-
6030: 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 22 22 20 id test-name ""
6040: 23 66 20 23 66 20 23 66 29 0a 09 09 20 20 28 69 #f #f #f)... (i
6050: 66 20 73 63 72 69 70 74 0a 09 09 20 20 20 20 20 f script...
6060: 20 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 73 (system (conc s
6070: 63 72 69 70 74 20 22 20 3e 20 22 20 6f 75 74 70 cript " > " outp
6080: 75 74 66 69 6c 65 6e 61 6d 65 20 22 20 26 20 22 utfilename " & "
6090: 29 29 0a 09 09 20 20 20 20 20 20 28 74 65 73 74 ))... (test
60a0: 73 3a 67 65 6e 65 72 61 74 65 2d 68 74 6d 6c 2d s:generate-html-
60b0: 73 75 6d 6d 61 72 79 2d 66 6f 72 2d 69 74 65 72 summary-for-iter
60c0: 61 74 65 64 2d 74 65 73 74 20 72 75 6e 2d 69 64 ated-test run-id
60d0: 20 74 65 73 74 2d 69 64 20 74 65 73 74 2d 6e 61 test-id test-na
60e0: 6d 65 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d me outputfilenam
60f0: 65 29 29 0a 09 09 20 20 28 63 6f 6d 6d 6f 6e 3a e))... (common:
6100: 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 72 65 6c 65 simple-file-rele
6110: 61 73 65 2d 6c 6f 63 6b 20 6c 6f 63 6b 66 29 0a ase-lock lockf).
6120: 09 09 20 20 28 63 68 61 6e 67 65 2d 64 69 72 65 .. (change-dire
6130: 63 74 6f 72 79 20 6f 72 69 67 2d 64 69 72 29 0a ctory orig-dir).
6140: 09 09 20 20 3b 3b 20 4e 42 2f 2f 20 74 65 73 74 .. ;; NB// test
6150: 73 3a 74 65 73 74 2d 73 65 74 2d 74 6f 70 6c 6f s:test-set-toplo
6160: 67 21 20 69 73 20 72 65 6d 6f 74 65 20 69 6e 74 g! is remote int
6170: 65 72 6e 61 6c 2e 2e 2e 0a 09 09 20 20 28 74 65 ernal...... (te
6180: 73 74 73 3a 74 65 73 74 2d 73 65 74 2d 74 6f 70 sts:test-set-top
6190: 6c 6f 67 21 20 72 75 6e 2d 69 64 20 74 65 73 74 log! run-id test
61a0: 2d 6e 61 6d 65 20 6f 75 74 70 75 74 66 69 6c 65 -name outputfile
61b0: 6e 61 6d 65 29 29 0a 09 09 3b 3b 20 64 69 64 6e name))...;; didn
61c0: 27 74 20 67 65 74 20 74 68 65 20 6c 6f 63 6b 2c 't get the lock,
61d0: 20 63 68 65 63 6b 20 74 6f 20 73 65 65 20 69 66 check to see if
61e0: 20 63 75 72 72 65 6e 74 20 75 70 64 61 74 65 20 current update
61f0: 73 74 61 72 74 65 64 20 6c 61 74 65 72 20 74 68 started later th
6200: 61 6e 20 74 68 69 73 20 0a 09 09 3b 3b 20 75 70 an this ...;; up
6210: 64 61 74 65 2c 20 69 66 20 73 6f 20 77 65 20 63 date, if so we c
6220: 61 6e 20 65 78 69 74 20 77 69 74 68 6f 75 74 20 an exit without
6230: 64 6f 69 6e 67 20 61 6e 79 20 77 6f 72 6b 0a 09 doing any work..
6240: 09 28 69 66 20 28 3e 20 6d 79 2d 73 74 61 72 74 .(if (> my-start
6250: 2d 74 69 6d 65 20 28 68 61 6e 64 6c 65 2d 65 78 -time (handle-ex
6260: 63 65 70 74 69 6f 6e 73 0a 09 09 09 09 09 20 65 ceptions...... e
6270: 78 6e 0a 09 09 09 09 20 20 20 20 20 20 20 28 62 xn..... (b
6280: 65 67 69 6e 0a 09 09 09 09 09 20 28 70 72 69 6e egin...... (prin
6290: 74 20 22 66 61 69 6c 65 64 20 74 6f 20 67 65 74 t "failed to get
62a0: 20 6d 6f 64 20 74 69 6d 65 20 6f 6e 20 22 20 6c mod time on " l
62b0: 6f 63 6b 66 20 22 2c 20 65 78 6e 3d 22 20 65 78 ockf ", exn=" ex
62c0: 6e 29 0a 09 09 09 09 09 20 30 29 0a 09 09 09 09 n)...... 0).....
62d0: 20 20 20 20 20 20 20 28 66 69 6c 65 2d 6d 6f 64 (file-mod
62e0: 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 6c ification-time l
62f0: 6f 63 6b 66 29 29 29 0a 09 09 20 20 20 20 3b 3b ockf)))... ;;
6300: 20 77 65 20 73 74 61 72 74 65 64 20 73 69 6e 63 we started sinc
6310: 65 20 63 75 72 72 65 6e 74 20 72 65 2d 67 65 6e e current re-gen
6320: 20 69 6e 20 66 6c 69 67 68 74 2c 20 64 65 6c 61 in flight, dela
6330: 79 20 61 20 6c 69 74 74 6c 65 20 61 6e 64 20 74 y a little and t
6340: 72 79 20 61 67 61 69 6e 0a 09 09 20 20 20 20 28 ry again... (
6350: 62 65 67 69 6e 0a 09 09 20 20 20 20 20 20 28 64 begin... (d
6360: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
6370: 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 1 *default-log-p
6380: 6f 72 74 2a 20 22 57 61 69 74 69 6e 67 20 74 6f ort* "Waiting to
6390: 20 75 70 64 61 74 65 20 22 20 6f 75 74 70 75 74 update " output
63a0: 66 69 6c 65 6e 61 6d 65 20 22 2c 20 61 6e 6f 74 filename ", anot
63b0: 68 65 72 20 74 65 73 74 20 63 75 72 72 65 6e 74 her test current
63c0: 6c 79 20 75 70 64 61 74 69 6e 67 20 69 74 22 29 ly updating it")
63d0: 0a 09 09 20 20 20 20 20 20 28 74 68 72 65 61 64 ... (thread
63e0: 2d 73 6c 65 65 70 21 20 28 2b 20 35 20 28 72 61 -sleep! (+ 5 (ra
63f0: 6e 64 6f 6d 20 35 29 29 29 20 3b 3b 20 64 65 6c ndom 5))) ;; del
6400: 61 79 20 62 65 74 77 65 65 6e 20 35 20 61 6e 64 ay between 5 and
6410: 20 31 30 20 73 65 63 6f 6e 64 73 0a 09 09 20 20 10 seconds...
6420: 20 20 20 20 28 6c 6f 6f 70 20 28 63 6f 6d 6d 6f (loop (commo
6430: 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f n:simple-file-lo
6440: 63 6b 20 6c 6f 63 6b 66 29 29 29 29 29 29 29 29 ck lockf))))))))
6450: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 ))..(define (tes
6460: 74 73 3a 67 65 6e 65 72 61 74 65 2d 68 74 6d 6c ts:generate-html
6470: 2d 73 75 6d 6d 61 72 79 2d 66 6f 72 2d 69 74 65 -summary-for-ite
6480: 72 61 74 65 64 2d 74 65 73 74 20 72 75 6e 2d 69 rated-test run-i
6490: 64 20 74 65 73 74 2d 69 64 20 74 65 73 74 2d 6e d test-id test-n
64a0: 61 6d 65 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 ame outputfilena
64b0: 6d 65 29 0a 20 20 28 6c 65 74 20 28 28 63 6f 75 me). (let ((cou
64c0: 6e 74 73 20 20 20 20 20 20 20 20 20 20 20 20 20 nts
64d0: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
64e0: 65 29 29 0a 09 28 73 74 61 74 65 63 6f 75 6e 74 e))..(statecount
64f0: 73 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d s (make-
6500: 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 09 28 6f hash-table))..(o
6510: 75 74 74 78 74 20 20 20 20 20 20 20 20 20 20 20 uttxt
6520: 20 20 20 22 22 29 0a 09 28 74 6f 74 20 20 20 20 "")..(tot
6530: 20 20 20 20 20 20 20 20 20 20 20 20 20 30 29 0a 0).
6540: 09 28 74 65 73 74 64 61 74 20 20 20 20 20 20 20 .(testdat
6550: 20 20 20 20 20 20 28 72 6d 74 3a 74 65 73 74 2d (rmt:test-
6560: 67 65 74 2d 72 65 63 6f 72 64 73 2d 66 6f 72 2d get-records-for-
6570: 69 6e 64 65 78 2d 66 69 6c 65 20 72 75 6e 2d 69 index-file run-i
6580: 64 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a 20 d test-name))).
6590: 20 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d (with-output-
65a0: 74 6f 2d 66 69 6c 65 20 6f 75 74 70 75 74 66 69 to-file outputfi
65b0: 6c 65 6e 61 6d 65 0a 20 20 20 20 20 20 28 6c 61 lename. (la
65c0: 6d 62 64 61 20 28 29 0a 09 28 73 65 74 21 20 6f mbda ()..(set! o
65d0: 75 74 74 78 74 20 28 63 6f 6e 63 20 6f 75 74 74 uttxt (conc outt
65e0: 78 74 20 22 3c 68 74 6d 6c 3e 3c 74 69 74 6c 65 xt "<html><title
65f0: 3e 53 75 6d 6d 61 72 79 3a 20 22 20 74 65 73 74 >Summary: " test
6600: 2d 6e 61 6d 65 20 0a 09 09 09 20 20 20 22 3c 2f -name .... "</
6610: 74 69 74 6c 65 3e 3c 62 6f 64 79 3e 3c 68 32 3e title><body><h2>
6620: 53 75 6d 6d 61 72 79 20 66 6f 72 20 22 20 74 65 Summary for " te
6630: 73 74 2d 6e 61 6d 65 20 22 3c 2f 68 32 3e 22 29 st-name "</h2>")
6640: 29 0a 09 28 66 6f 72 2d 65 61 63 68 0a 09 20 28 )..(for-each.. (
6650: 6c 61 6d 62 64 61 20 28 74 65 73 74 72 65 63 6f lambda (testreco
6660: 72 64 29 0a 09 20 20 20 28 6c 65 74 20 28 28 69 rd).. (let ((i
6670: 64 20 20 20 20 20 20 20 20 20 20 20 20 20 28 76 d (v
6680: 65 63 74 6f 72 2d 72 65 66 20 74 65 73 74 72 65 ector-ref testre
6690: 63 6f 72 64 20 30 29 29 0a 09 09 20 28 69 74 65 cord 0))... (ite
66a0: 6d 70 61 74 68 20 20 20 20 20 20 20 28 76 65 63 mpath (vec
66b0: 74 6f 72 2d 72 65 66 20 74 65 73 74 72 65 63 6f tor-ref testreco
66c0: 72 64 20 31 29 29 0a 09 09 20 28 73 74 61 74 65 rd 1))... (state
66d0: 20 20 20 20 20 20 20 20 20 20 28 76 65 63 74 6f (vecto
66e0: 72 2d 72 65 66 20 74 65 73 74 72 65 63 6f 72 64 r-ref testrecord
66f0: 20 32 29 29 0a 09 09 20 28 73 74 61 74 75 73 20 2))... (status
6700: 20 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d (vector-
6710: 72 65 66 20 74 65 73 74 72 65 63 6f 72 64 20 33 ref testrecord 3
6720: 29 29 0a 09 09 20 28 72 75 6e 5f 64 75 72 61 74 ))... (run_durat
6730: 69 6f 6e 20 20 20 28 76 65 63 74 6f 72 2d 72 65 ion (vector-re
6740: 66 20 74 65 73 74 72 65 63 6f 72 64 20 34 29 29 f testrecord 4))
6750: 0a 09 09 20 28 6c 6f 67 66 20 20 20 20 20 20 20 ... (logf
6760: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
6770: 74 65 73 74 72 65 63 6f 72 64 20 35 29 29 0a 09 testrecord 5))..
6780: 09 20 28 63 6f 6d 6d 65 6e 74 20 20 20 20 20 20 . (comment
6790: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 65 (vector-ref te
67a0: 73 74 72 65 63 6f 72 64 20 36 29 29 29 0a 09 20 strecord 6)))..
67b0: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
67c0: 73 65 74 21 20 63 6f 75 6e 74 73 20 73 74 61 74 set! counts stat
67d0: 75 73 20 28 2b 20 31 20 28 68 61 73 68 2d 74 61 us (+ 1 (hash-ta
67e0: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
67f0: 63 6f 75 6e 74 73 20 73 74 61 74 75 73 20 30 29 counts status 0)
6800: 29 29 0a 09 20 20 20 20 20 28 68 61 73 68 2d 74 )).. (hash-t
6810: 61 62 6c 65 2d 73 65 74 21 20 73 74 61 74 65 63 able-set! statec
6820: 6f 75 6e 74 73 20 73 74 61 74 65 20 28 2b 20 31 ounts state (+ 1
6830: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
6840: 2f 64 65 66 61 75 6c 74 20 73 74 61 74 65 63 6f /default stateco
6850: 75 6e 74 73 20 73 74 61 74 65 20 30 29 29 29 0a unts state 0))).
6860: 09 20 20 20 20 20 28 73 65 74 21 20 6f 75 74 74 . (set! outt
6870: 78 74 20 28 63 6f 6e 63 20 6f 75 74 74 78 74 20 xt (conc outtxt
6880: 22 3c 74 72 3e 22 0a 09 09 09 09 3b 3b 20 22 3c "<tr>".....;; "<
6890: 74 64 3e 3c 61 20 68 72 65 66 3d 5c 22 22 20 69 td><a href=\"" i
68a0: 74 65 6d 70 61 74 68 20 22 2f 22 20 6c 6f 67 66 tempath "/" logf
68b0: 20 22 5c 22 3e 20 22 20 69 74 65 6d 70 61 74 68 "\"> " itempath
68c0: 20 22 3c 2f 61 3e 3c 2f 74 64 3e 22 20 0a 09 09 "</a></td>" ...
68d0: 09 09 22 3c 74 64 3e 3c 61 20 68 72 65 66 3d 5c .."<td><a href=\
68e0: 22 22 20 69 74 65 6d 70 61 74 68 20 22 2f 74 65 "" itempath "/te
68f0: 73 74 2d 73 75 6d 6d 61 72 79 2e 68 74 6d 6c 5c st-summary.html\
6900: 22 3e 20 22 20 69 74 65 6d 70 61 74 68 20 22 3c "> " itempath "<
6910: 2f 61 3e 3c 2f 74 64 3e 22 20 0a 09 09 09 09 22 /a></td>" ....."
6920: 3c 74 64 3e 22 20 73 74 61 74 65 20 20 20 20 22 <td>" state "
6930: 3c 2f 74 64 3e 22 20 0a 09 09 09 09 22 3c 74 64 </td>" ....."<td
6940: 3e 3c 66 6f 6e 74 20 63 6f 6c 6f 72 3d 22 20 28 ><font color=" (
6950: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 6f 6c 6f 72 common:get-color
6960: 2d 66 72 6f 6d 2d 73 74 61 74 75 73 20 73 74 61 -from-status sta
6970: 74 75 73 29 0a 09 09 09 09 22 3e 22 20 20 20 73 tus).....">" s
6980: 74 61 74 75 73 20 20 20 22 3c 2f 66 6f 6e 74 3e tatus "</font>
6990: 3c 2f 74 64 3e 22 0a 09 09 09 09 22 3c 74 64 3e </td>"....."<td>
69a0: 22 20 28 69 66 20 28 65 71 75 61 6c 3f 20 63 6f " (if (equal? co
69b0: 6d 6d 65 6e 74 20 22 22 29 0a 09 09 09 09 09 20 mment "")......
69c0: 20 20 22 26 6e 62 73 70 3b 22 0a 09 09 09 09 09 " "......
69d0: 20 20 20 63 6f 6d 6d 65 6e 74 29 20 22 3c 2f 74 comment) "</t
69e0: 64 3e 22 0a 09 09 09 09 09 20 20 20 22 3c 2f 74 d>"...... "</t
69f0: 72 3e 22 29 29 29 29 0a 09 20 28 69 66 20 28 6c r>")))).. (if (l
6a00: 69 73 74 3f 20 74 65 73 74 64 61 74 29 0a 09 20 ist? testdat)..
6a10: 20 20 20 20 74 65 73 74 64 61 74 0a 09 20 20 20 testdat..
6a20: 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 (begin..
6a30: 20 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 (print "ERROR:
6a40: 66 61 69 6c 65 64 20 74 6f 20 67 65 74 20 72 65 failed to get re
6a50: 63 6f 72 64 73 20 77 69 74 68 20 72 6d 74 3a 74 cords with rmt:t
6a60: 65 73 74 2d 67 65 74 2d 72 65 63 6f 72 64 73 2d est-get-records-
6a70: 66 6f 72 2d 69 6e 64 65 78 2d 66 69 6c 65 20 72 for-index-file r
6a80: 75 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 64 20 22 un-id=" run-id "
6a90: 74 65 73 74 2d 6e 61 6d 65 3d 22 20 74 65 73 74 test-name=" test
6aa0: 2d 6e 61 6d 65 29 0a 09 20 20 20 20 20 20 20 27 -name).. '
6ab0: 28 29 29 29 29 0a 09 0a 09 28 70 72 69 6e 74 20 ())))....(print
6ac0: 22 3c 74 61 62 6c 65 3e 3c 74 72 3e 3c 74 64 20 "<table><tr><td
6ad0: 76 61 6c 69 67 6e 3d 5c 22 74 6f 70 5c 22 3e 22 valign=\"top\">"
6ae0: 29 0a 09 3b 3b 20 50 72 69 6e 74 20 6f 75 74 20 )..;; Print out
6af0: 73 74 61 74 73 20 66 6f 72 20 73 74 61 74 75 73 stats for status
6b00: 0a 09 28 73 65 74 21 20 74 6f 74 20 30 29 0a 09 ..(set! tot 0)..
6b10: 28 70 72 69 6e 74 20 22 3c 74 61 62 6c 65 20 63 (print "<table c
6b20: 65 6c 6c 73 70 61 63 69 6e 67 3d 5c 22 30 5c 22 ellspacing=\"0\"
6b30: 20 62 6f 72 64 65 72 3d 5c 22 31 5c 22 3e 3c 74 border=\"1\"><t
6b40: 72 3e 3c 74 64 20 63 6f 6c 73 70 61 6e 3d 5c 22 r><td colspan=\"
6b50: 32 5c 22 3e 3c 68 32 3e 53 74 61 74 65 20 73 74 2\"><h2>State st
6b60: 61 74 73 3c 2f 68 32 3e 3c 2f 74 64 3e 3c 2f 74 ats</h2></td></t
6b70: 72 3e 22 29 0a 09 28 66 6f 72 2d 65 61 63 68 20 r>")..(for-each
6b80: 28 6c 61 6d 62 64 61 20 28 73 74 61 74 65 29 0a (lambda (state).
6b90: 09 09 20 20 20 20 28 73 65 74 21 20 74 6f 74 20 .. (set! tot
6ba0: 28 2b 20 74 6f 74 20 28 68 61 73 68 2d 74 61 62 (+ tot (hash-tab
6bb0: 6c 65 2d 72 65 66 20 73 74 61 74 65 63 6f 75 6e le-ref statecoun
6bc0: 74 73 20 73 74 61 74 65 29 29 29 0a 09 09 20 20 ts state)))...
6bd0: 20 20 28 70 72 69 6e 74 20 22 3c 74 72 3e 3c 74 (print "<tr><t
6be0: 64 3e 22 20 73 74 61 74 65 20 22 3c 2f 74 64 3e d>" state "</td>
6bf0: 3c 74 64 3e 22 20 28 68 61 73 68 2d 74 61 62 6c <td>" (hash-tabl
6c00: 65 2d 72 65 66 20 73 74 61 74 65 63 6f 75 6e 74 e-ref statecount
6c10: 73 20 73 74 61 74 65 29 20 22 3c 2f 74 64 3e 3c s state) "</td><
6c20: 2f 74 72 3e 22 29 29 0a 09 09 20 20 28 68 61 73 /tr>"))... (has
6c30: 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 73 74 61 h-table-keys sta
6c40: 74 65 63 6f 75 6e 74 73 29 29 0a 09 28 70 72 69 tecounts))..(pri
6c50: 6e 74 20 22 3c 74 72 3e 3c 74 64 3e 54 6f 74 61 nt "<tr><td>Tota
6c60: 6c 3c 2f 74 64 3e 3c 74 64 3e 22 20 74 6f 74 20 l</td><td>" tot
6c70: 22 3c 2f 74 64 3e 3c 2f 74 72 3e 3c 2f 74 61 62 "</td></tr></tab
6c80: 6c 65 3e 22 29 0a 09 28 70 72 69 6e 74 20 22 3c le>")..(print "<
6c90: 2f 74 64 3e 3c 74 64 20 76 61 6c 69 67 6e 3d 5c /td><td valign=\
6ca0: 22 74 6f 70 5c 22 3e 22 29 0a 09 3b 3b 20 50 72 "top\">")..;; Pr
6cb0: 69 6e 74 20 6f 75 74 20 73 74 61 74 73 20 66 6f int out stats fo
6cc0: 72 20 73 74 61 74 65 0a 09 28 73 65 74 21 20 74 r state..(set! t
6cd0: 6f 74 20 30 29 0a 09 28 70 72 69 6e 74 20 22 3c ot 0)..(print "<
6ce0: 74 61 62 6c 65 20 63 65 6c 6c 73 70 61 63 69 6e table cellspacin
6cf0: 67 3d 5c 22 30 5c 22 20 62 6f 72 64 65 72 3d 5c g=\"0\" border=\
6d00: 22 31 5c 22 3e 3c 74 72 3e 3c 74 64 20 63 6f 6c "1\"><tr><td col
6d10: 73 70 61 6e 3d 5c 22 32 5c 22 3e 3c 68 32 3e 53 span=\"2\"><h2>S
6d20: 74 61 74 75 73 20 73 74 61 74 73 3c 2f 68 32 3e tatus stats</h2>
6d30: 3c 2f 74 64 3e 3c 2f 74 72 3e 22 29 0a 09 28 66 </td></tr>")..(f
6d40: 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 or-each (lambda
6d50: 28 73 74 61 74 75 73 29 0a 09 09 20 20 20 20 28 (status)... (
6d60: 73 65 74 21 20 74 6f 74 20 28 2b 20 74 6f 74 20 set! tot (+ tot
6d70: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 (hash-table-ref
6d80: 63 6f 75 6e 74 73 20 73 74 61 74 75 73 29 29 29 counts status)))
6d90: 0a 09 09 20 20 20 20 28 70 72 69 6e 74 20 22 3c ... (print "<
6da0: 74 72 3e 3c 74 64 3e 3c 66 6f 6e 74 20 63 6f 6c tr><td><font col
6db0: 6f 72 3d 5c 22 22 20 28 63 6f 6d 6d 6f 6e 3a 67 or=\"" (common:g
6dc0: 65 74 2d 63 6f 6c 6f 72 2d 66 72 6f 6d 2d 73 74 et-color-from-st
6dd0: 61 74 75 73 20 73 74 61 74 75 73 29 20 22 5c 22 atus status) "\"
6de0: 3e 22 20 73 74 61 74 75 73 0a 09 09 09 20 20 20 >" status....
6df0: 22 3c 2f 66 6f 6e 74 3e 3c 2f 74 64 3e 3c 74 64 "</font></td><td
6e00: 3e 22 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 >" (hash-table-r
6e10: 65 66 20 63 6f 75 6e 74 73 20 73 74 61 74 75 73 ef counts status
6e20: 29 20 22 3c 2f 74 64 3e 3c 2f 74 72 3e 22 29 29 ) "</td></tr>"))
6e30: 0a 09 09 20 20 28 68 61 73 68 2d 74 61 62 6c 65 ... (hash-table
6e40: 2d 6b 65 79 73 20 63 6f 75 6e 74 73 29 29 0a 09 -keys counts))..
6e50: 28 70 72 69 6e 74 20 22 3c 74 72 3e 3c 74 64 3e (print "<tr><td>
6e60: 54 6f 74 61 6c 3c 2f 74 64 3e 3c 74 64 3e 22 20 Total</td><td>"
6e70: 74 6f 74 20 22 3c 2f 74 64 3e 3c 2f 74 72 3e 3c tot "</td></tr><
6e80: 2f 74 61 62 6c 65 3e 22 29 0a 09 28 70 72 69 6e /table>")..(prin
6e90: 74 20 22 3c 2f 74 64 3e 3c 2f 74 64 3e 3c 2f 74 t "</td></td></t
6ea0: 72 3e 3c 2f 74 61 62 6c 65 3e 22 29 0a 09 0a 09 r></table>")....
6eb0: 28 70 72 69 6e 74 20 22 3c 74 61 62 6c 65 20 63 (print "<table c
6ec0: 65 6c 6c 73 70 61 63 69 6e 67 3d 5c 22 30 5c 22 ellspacing=\"0\"
6ed0: 20 62 6f 72 64 65 72 3d 5c 22 31 5c 22 3e 22 20 border=\"1\">"
6ee0: 0a 09 20 20 20 20 20 20 20 22 3c 74 72 3e 3c 74 .. "<tr><t
6ef0: 64 3e 49 74 65 6d 3c 2f 74 64 3e 3c 74 64 3e 53 d>Item</td><td>S
6f00: 74 61 74 65 3c 2f 74 64 3e 3c 74 64 3e 53 74 61 tate</td><td>Sta
6f10: 74 75 73 3c 2f 74 64 3e 3c 74 64 3e 43 6f 6d 6d tus</td><td>Comm
6f20: 65 6e 74 3c 2f 74 64 3e 22 0a 09 20 20 20 20 20 ent</td>"..
6f30: 20 20 6f 75 74 74 78 74 20 22 3c 2f 74 61 62 6c outtxt "</tabl
6f40: 65 3e 3c 2f 62 6f 64 79 3e 3c 2f 68 74 6d 6c 3e e></body></html>
6f50: 22 29 0a 09 3b 3b 20 28 72 65 6c 65 61 73 65 2d ")..;; (release-
6f60: 64 6f 74 2d 6c 6f 63 6b 20 6f 75 74 70 75 74 66 dot-lock outputf
6f70: 69 6c 65 6e 61 6d 65 29 0a 09 3b 3b 28 72 6d 74 ilename)..;;(rmt
6f80: 3a 75 70 64 61 74 65 2d 72 75 6e 2d 73 74 61 74 :update-run-stat
6f90: 73 20 0a 09 3b 3b 20 72 75 6e 2d 69 64 0a 09 3b s ..;; run-id..;
6fa0: 3b 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6d 61 ; (hash-table-ma
6fb0: 70 0a 09 3b 3b 20 20 73 74 61 74 65 2d 73 74 61 p..;; state-sta
6fc0: 74 75 73 2d 63 6f 75 6e 74 73 0a 09 3b 3b 20 20 tus-counts..;;
6fd0: 28 6c 61 6d 62 64 61 20 28 6b 65 79 20 76 61 6c (lambda (key val
6fe0: 29 0a 09 3b 3b 09 28 61 70 70 65 6e 64 20 6b 65 )..;;.(append ke
6ff0: 79 20 28 6c 69 73 74 20 76 61 6c 29 29 29 29 29 y (list val)))))
7000: 0a 09 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ..))))..(define
7010: 74 65 73 74 73 3a 63 73 73 2d 6a 73 63 72 69 70 tests:css-jscrip
7020: 74 2d 62 6c 6f 63 6b 0a 23 3c 3c 45 4f 46 0a 3c t-block.#<<EOF.<
7030: 73 74 79 6c 65 20 74 79 70 65 3d 22 74 65 78 74 style type="text
7040: 2f 63 73 73 22 3e 0a 75 6c 2e 4c 69 6e 6b 65 64 /css">.ul.Linked
7050: 4c 69 73 74 20 7b 20 64 69 73 70 6c 61 79 3a 20 List { display:
7060: 62 6c 6f 63 6b 3b 20 7d 0a 2f 2a 20 75 6c 2e 4c block; }./* ul.L
7070: 69 6e 6b 65 64 4c 69 73 74 20 75 6c 20 7b 20 64 inkedList ul { d
7080: 69 73 70 6c 61 79 3a 20 6e 6f 6e 65 3b 20 7d 20 isplay: none; }
7090: 2a 2f 0a 2e 48 61 6e 64 43 75 72 73 6f 72 53 74 */..HandCursorSt
70a0: 79 6c 65 20 7b 20 63 75 72 73 6f 72 3a 20 70 6f yle { cursor: po
70b0: 69 6e 74 65 72 3b 20 63 75 72 73 6f 72 3a 20 68 inter; cursor: h
70c0: 61 6e 64 3b 20 7d 20 20 2f 2a 20 46 6f 72 20 49 and; } /* For I
70d0: 45 20 2a 2f 0a 74 68 20 7b 62 61 63 6b 67 72 6f E */.th {backgro
70e0: 75 6e 64 2d 63 6f 6c 6f 72 3a 20 23 38 63 38 63 und-color: #8c8c
70f0: 38 63 3b 7d 0a 74 64 2e 74 65 73 74 20 7b 62 61 8c;}.td.test {ba
7100: 63 6b 67 72 6f 75 6e 64 2d 63 6f 6c 6f 72 3a 20 ckground-color:
7110: 23 64 39 64 62 64 64 3b 7d 0a 74 64 2e 50 41 53 #d9dbdd;}.td.PAS
7120: 53 20 7b 62 61 63 6b 67 72 6f 75 6e 64 2d 63 6f S {background-co
7130: 6c 6f 72 3a 20 23 33 34 37 35 33 33 3b 7d 0a 74 lor: #347533;}.t
7140: 64 2e 46 41 49 4c 20 7b 62 61 63 6b 67 72 6f 75 d.FAIL {backgrou
7150: 6e 64 2d 63 6f 6c 6f 72 3a 20 23 63 63 32 38 31 nd-color: #cc281
7160: 32 3b 7d 0a 74 64 2e 53 4b 49 50 7b 62 61 63 6b 2;}.td.SKIP{back
7170: 67 72 6f 75 6e 64 2d 63 6f 6c 6f 72 3a 20 23 46 ground-color: #F
7180: 46 44 37 33 33 3b 7d 0a 74 64 2e 57 41 52 4e 20 FD733;}.td.WARN
7190: 7b 62 61 63 6b 67 72 6f 75 6e 64 2d 63 6f 6c 6f {background-colo
71a0: 72 3a 20 23 45 41 38 37 32 34 3b 7d 0a 74 64 2e r: #EA8724;}.td.
71b0: 57 41 49 56 45 44 20 7b 62 61 63 6b 67 72 6f 75 WAIVED {backgrou
71c0: 6e 64 2d 63 6f 6c 6f 72 3a 20 23 38 33 38 41 31 nd-color: #838A1
71d0: 32 3b 7d 0a 74 64 2e 41 42 4f 52 54 7b 62 61 63 2;}.td.ABORT{bac
71e0: 6b 67 72 6f 75 6e 64 2d 63 6f 6c 6f 72 3a 20 23 kground-color: #
71f0: 45 41 32 34 42 37 3b 7d 0a 2e 50 41 53 53 20 2e EA24B7;}..PASS .
7200: 6c 69 6e 6b 2c 20 2e 53 4b 49 50 20 2e 6c 69 6e link, .SKIP .lin
7210: 6b 2c 20 2e 57 41 52 4e 20 2e 6c 69 6e 6b 2c 2e k, .WARN .link,.
7220: 57 41 49 56 45 44 20 2e 6c 69 6e 6b 2c 2e 41 42 WAIVED .link,.AB
7230: 4f 52 54 20 2e 6c 69 6e 6b 2c 20 2e 46 41 49 4c ORT .link, .FAIL
7240: 20 2e 6c 69 6e 6b 7b 63 6f 6c 6f 72 3a 20 23 46 .link{color: #F
7250: 46 46 46 46 46 3b 7d 0a 0a 0a 3c 2f 73 74 79 6c FFFFF;}...</styl
7260: 65 3e 0a 0a 0a 20 20 3c 73 63 72 69 70 74 20 74 e>... <script t
7270: 79 70 65 3d 22 74 65 78 74 2f 4a 61 76 61 53 63 ype="text/JavaSc
7280: 72 69 70 74 22 3e 0a 0a 20 20 20 20 66 75 6e 63 ript">.. func
7290: 74 69 6f 6e 20 66 69 6c 74 65 72 73 6f 6d 65 28 tion filtersome(
72a0: 29 20 7b 0a 20 20 24 28 22 74 72 22 29 2e 73 68 ) {. $("tr").sh
72b0: 6f 77 28 29 3b 0a 20 20 24 28 22 2e 74 65 73 74 ow();. $(".test
72c0: 22 29 2e 66 69 6c 74 65 72 28 0a 20 20 20 20 66 ").filter(. f
72d0: 75 6e 63 74 69 6f 6e 28 29 20 7b 0a 20 20 20 20 unction() {.
72e0: 20 20 76 61 72 20 6e 61 6d 65 73 20 3d 20 24 28 var names = $(
72f0: 27 23 74 65 73 74 6e 61 6d 65 27 29 2e 76 61 6c '#testname').val
7300: 28 29 2e 73 70 6c 69 74 28 27 2c 27 29 3b 0a 20 ().split(',');.
7310: 20 20 20 20 20 76 61 72 20 67 6f 6f 64 3d 31 3b var good=1;
7320: 0a 20 20 20 20 20 20 66 6f 72 20 28 76 61 72 20 . for (var
7330: 69 3d 30 2c 20 6c 65 6e 3d 6e 61 6d 65 73 2e 6c i=0, len=names.l
7340: 65 6e 67 74 68 3b 20 69 3c 6c 65 6e 3b 20 69 2b ength; i<len; i+
7350: 2b 29 20 7b 0a 20 20 20 20 20 20 20 20 76 61 72 +) {. var
7360: 20 75 6e 61 6d 65 3d 6e 61 6d 65 73 5b 69 5d 3b uname=names[i];
7370: 0a 20 20 20 20 20 20 20 20 63 6f 6e 73 6f 6c 65 . console
7380: 2e 6c 6f 67 28 22 54 72 79 69 6e 67 20 74 6f 20 .log("Trying to
7390: 63 68 65 63 6b 20 66 6f 72 20 22 20 2b 20 75 6e check for " + un
73a0: 61 6d 65 29 3b 20 0a 20 20 20 20 20 20 20 20 69 ame); . i
73b0: 66 28 24 28 74 68 69 73 29 2e 74 65 78 74 28 29 f($(this).text()
73c0: 2e 69 6e 64 65 78 4f 66 28 75 6e 61 6d 65 29 20 .indexOf(uname)
73d0: 21 3d 20 2d 31 29 20 7b 0a 20 20 20 20 20 20 20 != -1) {.
73e0: 20 20 20 67 6f 6f 64 3d 20 30 3b 0a 20 20 20 20 good= 0;.
73f0: 20 20 20 20 20 20 63 6f 6e 73 6f 6c 65 2e 6c 6f console.lo
7400: 67 28 22 46 6f 75 6e 64 20 22 2b 75 6e 61 6d 65 g("Found "+uname
7410: 29 3b 0a 20 20 20 20 20 20 20 20 7d 0a 20 20 20 );. }.
7420: 20 20 20 7d 0a 20 20 20 20 20 20 72 65 74 75 72 }. retur
7430: 6e 20 67 6f 6f 64 3b 20 0a 20 20 20 20 7d 0a 20 n good; . }.
7440: 20 29 2e 70 61 72 65 6e 74 28 29 2e 68 69 64 65 ).parent().hide
7450: 28 29 3b 0a 2f 2f 20 20 24 28 22 2e 73 75 6d 22 ();.// $(".sum"
7460: 29 2e 73 68 6f 77 28 29 3b 0a 7d 0a 20 20 0a 20 ).show();.}. .
7470: 20 20 20 2f 2f 20 41 64 64 20 74 68 69 73 20 74 // Add this t
7480: 6f 20 74 68 65 20 6f 6e 6c 6f 61 64 20 65 76 65 o the onload eve
7490: 6e 74 20 6f 66 20 74 68 65 20 42 4f 44 59 20 65 nt of the BODY e
74a0: 6c 65 6d 65 6e 74 0a 20 20 20 20 66 75 6e 63 74 lement. funct
74b0: 69 6f 6e 20 61 64 64 45 76 65 6e 74 73 28 29 20 ion addEvents()
74c0: 7b 0a 20 20 20 20 20 20 61 63 74 69 76 61 74 65 {. activate
74d0: 54 72 65 65 28 64 6f 63 75 6d 65 6e 74 2e 67 65 Tree(document.ge
74e0: 74 45 6c 65 6d 65 6e 74 42 79 49 64 28 22 4c 69 tElementById("Li
74f0: 6e 6b 65 64 4c 69 73 74 31 22 29 29 3b 0a 20 20 nkedList1"));.
7500: 20 20 7d 0a 0a 20 20 20 20 2f 2f 20 54 68 69 73 }.. // This
7510: 20 66 75 6e 63 74 69 6f 6e 20 74 72 61 76 65 72 function traver
7520: 73 65 73 20 74 68 65 20 6c 69 73 74 20 61 6e 64 ses the list and
7530: 20 61 64 64 20 6c 69 6e 6b 73 20 0a 20 20 20 20 add links .
7540: 2f 2f 20 74 6f 20 6e 65 73 74 65 64 20 6c 69 73 // to nested lis
7550: 74 20 69 74 65 6d 73 0a 20 20 20 20 66 75 6e 63 t items. func
7560: 74 69 6f 6e 20 61 63 74 69 76 61 74 65 54 72 65 tion activateTre
7570: 65 28 6f 4c 69 73 74 29 20 7b 0a 20 20 20 20 20 e(oList) {.
7580: 20 2f 2f 20 43 6f 6c 6c 61 70 73 65 20 74 68 65 // Collapse the
7590: 20 74 72 65 65 0a 20 20 20 20 20 20 66 6f 72 20 tree. for
75a0: 28 76 61 72 20 69 3d 30 3b 20 69 20 3c 20 6f 4c (var i=0; i < oL
75b0: 69 73 74 2e 67 65 74 45 6c 65 6d 65 6e 74 73 42 ist.getElementsB
75c0: 79 54 61 67 4e 61 6d 65 28 22 75 6c 22 29 2e 6c yTagName("ul").l
75d0: 65 6e 67 74 68 3b 20 69 2b 2b 29 20 7b 0a 20 20 ength; i++) {.
75e0: 20 20 20 20 20 20 6f 4c 69 73 74 2e 67 65 74 45 oList.getE
75f0: 6c 65 6d 65 6e 74 73 42 79 54 61 67 4e 61 6d 65 lementsByTagName
7600: 28 22 75 6c 22 29 5b 69 5d 2e 73 74 79 6c 65 2e ("ul")[i].style.
7610: 64 69 73 70 6c 61 79 3d 22 6e 6f 6e 65 22 3b 20 display="none";
7620: 20 20 20 20 20 20 20 20 20 20 20 0a 20 20 20 20 .
7630: 20 20 7d 20 20 20 20 20 20 20 20 20 20 20 20 20 }
7640: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7650: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7660: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7670: 20 20 20 20 20 0a 20 20 20 20 20 20 2f 2f 20 41 . // A
7680: 64 64 20 74 68 65 20 63 6c 69 63 6b 2d 65 76 65 dd the click-eve
7690: 6e 74 20 68 61 6e 64 6c 65 72 20 74 6f 20 74 68 nt handler to th
76a0: 65 20 6c 69 73 74 20 69 74 65 6d 73 0a 20 20 20 e list items.
76b0: 20 20 20 69 66 20 28 6f 4c 69 73 74 2e 61 64 64 if (oList.add
76c0: 45 76 65 6e 74 4c 69 73 74 65 6e 65 72 29 20 7b EventListener) {
76d0: 0a 20 20 20 20 20 20 20 20 6f 4c 69 73 74 2e 61 . oList.a
76e0: 64 64 45 76 65 6e 74 4c 69 73 74 65 6e 65 72 28 ddEventListener(
76f0: 22 63 6c 69 63 6b 22 2c 20 74 6f 67 67 6c 65 42 "click", toggleB
7700: 72 61 6e 63 68 2c 20 66 61 6c 73 65 29 3b 0a 20 ranch, false);.
7710: 20 20 20 20 20 7d 20 65 6c 73 65 20 69 66 20 28 } else if (
7720: 6f 4c 69 73 74 2e 61 74 74 61 63 68 45 76 65 6e oList.attachEven
7730: 74 29 20 7b 20 2f 2f 20 46 6f 72 20 49 45 0a 20 t) { // For IE.
7740: 20 20 20 20 20 20 20 6f 4c 69 73 74 2e 61 74 74 oList.att
7750: 61 63 68 45 76 65 6e 74 28 22 6f 6e 63 6c 69 63 achEvent("onclic
7760: 6b 22 2c 20 74 6f 67 67 6c 65 42 72 61 6e 63 68 k", toggleBranch
7770: 29 3b 0a 20 20 20 20 20 20 7d 0a 20 20 20 20 20 );. }.
7780: 20 2f 2f 20 4d 61 6b 65 20 74 68 65 20 6e 65 73 // Make the nes
7790: 74 65 64 20 69 74 65 6d 73 20 6c 6f 6f 6b 20 6c ted items look l
77a0: 69 6b 65 20 6c 69 6e 6b 73 0a 20 20 20 20 20 20 ike links.
77b0: 61 64 64 4c 69 6e 6b 73 54 6f 42 72 61 6e 63 68 addLinksToBranch
77c0: 65 73 28 6f 4c 69 73 74 29 3b 0a 20 20 20 20 7d es(oList);. }
77d0: 0a 0a 20 20 20 20 2f 2f 20 54 68 69 73 20 69 73 .. // This is
77e0: 20 74 68 65 20 63 6c 69 63 6b 2d 65 76 65 6e 74 the click-event
77f0: 20 68 61 6e 64 6c 65 72 0a 20 20 20 20 66 75 6e handler. fun
7800: 63 74 69 6f 6e 20 74 6f 67 67 6c 65 42 72 61 6e ction toggleBran
7810: 63 68 28 65 76 65 6e 74 29 20 7b 0a 20 20 20 20 ch(event) {.
7820: 20 20 76 61 72 20 6f 42 72 61 6e 63 68 2c 20 63 var oBranch, c
7830: 53 75 62 42 72 61 6e 63 68 65 73 3b 0a 20 20 20 SubBranches;.
7840: 20 20 20 69 66 20 28 65 76 65 6e 74 2e 74 61 72 if (event.tar
7850: 67 65 74 29 20 7b 0a 20 20 20 20 20 20 20 20 6f get) {. o
7860: 42 72 61 6e 63 68 20 3d 20 65 76 65 6e 74 2e 74 Branch = event.t
7870: 61 72 67 65 74 3b 0a 20 20 20 20 20 20 7d 20 65 arget;. } e
7880: 6c 73 65 20 69 66 20 28 65 76 65 6e 74 2e 73 72 lse if (event.sr
7890: 63 45 6c 65 6d 65 6e 74 29 20 7b 20 2f 2f 20 46 cElement) { // F
78a0: 6f 72 20 49 45 0a 20 20 20 20 20 20 20 20 6f 42 or IE. oB
78b0: 72 61 6e 63 68 20 3d 20 65 76 65 6e 74 2e 73 72 ranch = event.sr
78c0: 63 45 6c 65 6d 65 6e 74 3b 0a 20 20 20 20 20 20 cElement;.
78d0: 7d 0a 20 20 20 20 20 20 63 53 75 62 42 72 61 6e }. cSubBran
78e0: 63 68 65 73 20 3d 20 6f 42 72 61 6e 63 68 2e 67 ches = oBranch.g
78f0: 65 74 45 6c 65 6d 65 6e 74 73 42 79 54 61 67 4e etElementsByTagN
7900: 61 6d 65 28 22 75 6c 22 29 3b 0a 20 20 20 20 20 ame("ul");.
7910: 20 69 66 20 28 63 53 75 62 42 72 61 6e 63 68 65 if (cSubBranche
7920: 73 2e 6c 65 6e 67 74 68 20 3e 20 30 29 20 7b 0a s.length > 0) {.
7930: 20 20 20 20 20 20 20 20 69 66 20 28 63 53 75 62 if (cSub
7940: 42 72 61 6e 63 68 65 73 5b 30 5d 2e 73 74 79 6c Branches[0].styl
7950: 65 2e 64 69 73 70 6c 61 79 20 3d 3d 20 22 62 6c e.display == "bl
7960: 6f 63 6b 22 29 20 7b 0a 20 20 20 20 20 20 20 20 ock") {.
7970: 20 20 63 53 75 62 42 72 61 6e 63 68 65 73 5b 30 cSubBranches[0
7980: 5d 2e 73 74 79 6c 65 2e 64 69 73 70 6c 61 79 20 ].style.display
7990: 3d 20 22 6e 6f 6e 65 22 3b 0a 20 20 20 20 20 20 = "none";.
79a0: 20 20 7d 20 65 6c 73 65 20 7b 0a 20 20 20 20 20 } else {.
79b0: 20 20 20 20 20 63 53 75 62 42 72 61 6e 63 68 65 cSubBranche
79c0: 73 5b 30 5d 2e 73 74 79 6c 65 2e 64 69 73 70 6c s[0].style.displ
79d0: 61 79 20 3d 20 22 62 6c 6f 63 6b 22 3b 0a 20 20 ay = "block";.
79e0: 20 20 20 20 20 20 7d 0a 20 20 20 20 20 20 7d 0a }. }.
79f0: 20 20 20 20 7d 0a 0a 20 20 20 20 2f 2f 20 54 68 }.. // Th
7a00: 69 73 20 66 75 6e 63 74 69 6f 6e 20 6d 61 6b 65 is function make
7a10: 73 20 6e 65 73 74 65 64 20 6c 69 73 74 20 69 74 s nested list it
7a20: 65 6d 73 20 6c 6f 6f 6b 20 6c 69 6b 65 20 6c 69 ems look like li
7a30: 6e 6b 73 0a 20 20 20 20 66 75 6e 63 74 69 6f 6e nks. function
7a40: 20 61 64 64 4c 69 6e 6b 73 54 6f 42 72 61 6e 63 addLinksToBranc
7a50: 68 65 73 28 6f 4c 69 73 74 29 20 7b 0a 20 20 20 hes(oList) {.
7a60: 20 20 20 76 61 72 20 63 42 72 61 6e 63 68 65 73 var cBranches
7a70: 20 3d 20 6f 4c 69 73 74 2e 67 65 74 45 6c 65 6d = oList.getElem
7a80: 65 6e 74 73 42 79 54 61 67 4e 61 6d 65 28 22 6c entsByTagName("l
7a90: 69 22 29 3b 0a 20 20 20 20 20 20 76 61 72 20 69 i");. var i
7aa0: 2c 20 6e 2c 20 63 53 75 62 42 72 61 6e 63 68 65 , n, cSubBranche
7ab0: 73 3b 0a 20 20 20 20 20 20 69 66 20 28 63 42 72 s;. if (cBr
7ac0: 61 6e 63 68 65 73 2e 6c 65 6e 67 74 68 20 3e 20 anches.length >
7ad0: 30 29 20 7b 0a 20 20 20 20 20 20 20 20 66 6f 72 0) {. for
7ae0: 20 28 69 3d 30 2c 20 6e 20 3d 20 63 42 72 61 6e (i=0, n = cBran
7af0: 63 68 65 73 2e 6c 65 6e 67 74 68 3b 20 69 20 3c ches.length; i <
7b00: 20 6e 3b 20 69 2b 2b 29 20 7b 0a 20 20 20 20 20 n; i++) {.
7b10: 20 20 20 20 20 63 53 75 62 42 72 61 6e 63 68 65 cSubBranche
7b20: 73 20 3d 20 63 42 72 61 6e 63 68 65 73 5b 69 5d s = cBranches[i]
7b30: 2e 67 65 74 45 6c 65 6d 65 6e 74 73 42 79 54 61 .getElementsByTa
7b40: 67 4e 61 6d 65 28 22 75 6c 22 29 3b 0a 20 20 20 gName("ul");.
7b50: 20 20 20 20 20 20 20 69 66 20 28 63 53 75 62 42 if (cSubB
7b60: 72 61 6e 63 68 65 73 2e 6c 65 6e 67 74 68 20 3e ranches.length >
7b70: 20 30 29 20 7b 0a 20 20 20 20 20 20 20 20 20 20 0) {.
7b80: 20 20 61 64 64 4c 69 6e 6b 73 54 6f 42 72 61 6e addLinksToBran
7b90: 63 68 65 73 28 63 53 75 62 42 72 61 6e 63 68 65 ches(cSubBranche
7ba0: 73 5b 30 5d 29 3b 0a 20 20 20 20 20 20 20 20 20 s[0]);.
7bb0: 20 20 20 63 42 72 61 6e 63 68 65 73 5b 69 5d 2e cBranches[i].
7bc0: 63 6c 61 73 73 4e 61 6d 65 20 3d 20 22 48 61 6e className = "Han
7bd0: 64 43 75 72 73 6f 72 53 74 79 6c 65 22 3b 0a 20 dCursorStyle";.
7be0: 20 20 20 20 20 20 20 20 20 20 20 63 42 72 61 6e cBran
7bf0: 63 68 65 73 5b 69 5d 2e 73 74 79 6c 65 2e 63 6f ches[i].style.co
7c00: 6c 6f 72 20 3d 20 22 62 6c 75 65 22 3b 0a 20 20 lor = "blue";.
7c10: 20 20 20 20 20 20 20 20 20 20 63 53 75 62 42 72 cSubBr
7c20: 61 6e 63 68 65 73 5b 30 5d 2e 73 74 79 6c 65 2e anches[0].style.
7c30: 63 6f 6c 6f 72 20 3d 20 22 62 6c 61 63 6b 22 3b color = "black";
7c40: 0a 20 20 20 20 20 20 20 20 20 20 20 20 63 53 75 . cSu
7c50: 62 42 72 61 6e 63 68 65 73 5b 30 5d 2e 73 74 79 bBranches[0].sty
7c60: 6c 65 2e 63 75 72 73 6f 72 20 3d 20 22 61 75 74 le.cursor = "aut
7c70: 6f 22 3b 0a 20 20 20 20 20 20 20 20 20 20 7d 0a o";. }.
7c80: 20 20 20 20 20 20 20 20 7d 0a 20 20 20 20 20 20 }.
7c90: 7d 0a 20 20 20 20 7d 0a 20 20 3c 2f 73 63 72 69 }. }. </scri
7ca0: 70 74 3e 0a 45 4f 46 0a 29 0a 0a 28 64 65 66 69 pt>.EOF.)..(defi
7cb0: 6e 65 20 74 65 73 74 73 3a 63 73 73 2d 6a 73 63 ne tests:css-jsc
7cc0: 72 69 70 74 2d 62 6c 6f 63 6b 2d 64 79 6e 61 6d ript-block-dynam
7cd0: 69 63 20 0a 23 3c 3c 45 4f 46 0a 20 20 20 20 20 ic .#<<EOF.
7ce0: 20 20 20 20 20 20 3c 73 63 72 69 70 74 20 73 72 <script sr
7cf0: 63 3d 20 2e 2f 6a 71 75 65 72 79 33 2e 31 2e 30 c= ./jquery3.1.0
7d00: 2e 6a 73 3e 3c 2f 73 63 72 69 70 74 3e 20 0a 45 .js></script> .E
7d10: 4f 46 0a 29 0a 0a 28 64 65 66 69 6e 65 20 20 28 OF.)..(define (
7d20: 74 65 73 74 3a 6a 73 2d 62 6c 6f 63 6b 20 6a 61 test:js-block ja
7d30: 76 61 73 63 72 69 70 74 2d 6c 69 62 29 0a 20 20 vascript-lib).
7d40: 20 28 63 6f 6e 63 20 20 22 3c 73 63 72 69 70 74 (conc "<script
7d50: 20 73 72 63 3d 22 20 6a 61 76 61 73 63 72 69 70 src=" javascrip
7d60: 74 2d 6c 69 62 20 22 3e 3c 2f 73 63 72 69 70 74 t-lib "></script
7d70: 3e 22 20 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 >" ))...(define
7d80: 74 65 73 74 73 3a 63 73 73 2d 6a 73 63 72 69 70 tests:css-jscrip
7d90: 74 2d 62 6c 6f 63 6b 2d 73 74 61 74 69 63 20 28 t-block-static (
7da0: 74 65 73 74 3a 6a 73 2d 62 6c 6f 63 6b 20 2a 6a test:js-block *j
7db0: 61 76 61 2d 73 63 72 69 70 74 2d 6c 69 62 2a 29 ava-script-lib*)
7dc0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 )..(define (test
7dd0: 73 3a 63 73 73 2d 6a 73 63 72 69 70 74 2d 62 6c s:css-jscript-bl
7de0: 6f 63 6b 2d 63 6f 6e 64 20 64 79 6e 61 6d 69 63 ock-cond dynamic
7df0: 29 20 0a 20 20 20 20 20 20 28 69 66 20 28 65 71 ) . (if (eq
7e00: 75 61 6c 3f 20 64 79 6e 61 6d 69 63 20 20 23 74 ual? dynamic #t
7e10: 29 0a 20 20 20 20 20 20 20 74 65 73 74 73 3a 63 ). tests:c
7e20: 73 73 2d 6a 73 63 72 69 70 74 2d 62 6c 6f 63 6b ss-jscript-block
7e30: 2d 64 79 6e 61 6d 69 63 0a 20 20 20 20 20 20 20 -dynamic.
7e40: 74 65 73 74 73 3a 63 73 73 2d 6a 73 63 72 69 70 tests:css-jscrip
7e50: 74 2d 62 6c 6f 63 6b 2d 73 74 61 74 69 63 29 29 t-block-static))
7e60: 0a 0a 20 20 20 20 20 20 20 0a 28 64 65 66 69 6e .. .(defin
7e70: 65 20 28 74 65 73 74 73 3a 72 75 6e 2d 72 65 63 e (tests:run-rec
7e80: 6f 72 64 2d 3e 74 65 73 74 2d 70 61 74 68 20 72 ord->test-path r
7e90: 75 6e 20 6e 75 6d 6b 65 79 73 29 0a 20 20 20 28 un numkeys). (
7ea0: 61 70 70 65 6e 64 20 28 74 61 6b 65 20 28 76 65 append (take (ve
7eb0: 63 74 6f 72 2d 3e 6c 69 73 74 20 72 75 6e 29 20 ctor->list run)
7ec0: 6e 75 6d 6b 65 79 73 29 0a 09 20 20 20 28 6c 69 numkeys).. (li
7ed0: 73 74 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 st (vector-ref r
7ee0: 75 6e 20 28 2b 20 31 20 6e 75 6d 6b 65 79 73 29 un (+ 1 numkeys)
7ef0: 29 29 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 ))))...(define (
7f00: 74 65 73 74 73 3a 67 65 74 2d 72 65 73 74 2d 64 tests:get-rest-d
7f10: 61 74 61 20 72 75 6e 73 20 68 65 61 64 65 72 20 ata runs header
7f20: 6e 75 6d 6b 65 79 73 29 0a 20 20 20 28 6c 65 74 numkeys). (let
7f30: 20 28 28 72 65 73 68 20 28 6d 61 6b 65 2d 68 61 ((resh (make-ha
7f40: 73 68 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 28 sh-table))). (
7f50: 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 6c for-each. (l
7f60: 61 6d 62 64 61 20 28 72 75 6e 29 0a 20 20 20 20 ambda (run).
7f70: 20 20 20 20 28 6c 65 74 2a 20 28 28 72 75 6e 2d (let* ((run-
7f80: 69 64 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 id (db:get-value
7f90: 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 -by-header run h
7fa0: 65 61 64 65 72 20 22 69 64 22 29 29 0a 20 20 20 eader "id")).
7fb0: 20 20 20 20 20 20 20 20 20 20 20 20 28 72 75 6e (run
7fc0: 2d 64 69 72 20 20 20 20 20 20 28 74 65 73 74 73 -dir (tests
7fd0: 3a 72 75 6e 2d 72 65 63 6f 72 64 2d 3e 74 65 73 :run-record->tes
7fe0: 74 2d 70 61 74 68 20 72 75 6e 20 6e 75 6d 6b 65 t-path run numke
7ff0: 79 73 29 29 0a 09 20 20 20 20 20 20 20 28 74 65 ys)).. (te
8000: 73 74 2d 64 61 74 61 20 20 20 20 28 72 6d 74 3a st-data (rmt:
8010: 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 get-tests-for-ru
8020: 6e 0a 09 09 09 09 20 20 20 72 75 6e 2d 69 64 0a n..... run-id.
8030: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8040: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8050: 20 20 20 22 25 22 20 20 20 20 20 20 20 3b 3b 20 "%" ;;
8060: 74 65 73 74 6e 61 6d 65 70 61 74 74 0a 09 09 09 testnamepatt....
8070: 09 20 20 20 27 28 29 20 20 20 20 20 20 20 20 3b . '() ;
8080: 3b 20 73 74 61 74 65 73 0a 09 09 09 09 20 20 20 ; states.....
8090: 27 28 29 20 20 20 20 20 20 20 20 3b 3b 20 73 74 '() ;; st
80a0: 61 74 75 73 65 73 0a 09 09 09 09 20 20 20 23 66 atuses..... #f
80b0: 20 20 20 20 20 20 20 20 20 3b 3b 20 6f 66 66 73 ;; offs
80c0: 65 74 0a 09 09 09 09 20 20 20 23 66 20 20 20 20 et..... #f
80d0: 20 20 20 20 20 3b 3b 20 6e 75 6d 2d 74 6f 2d 67 ;; num-to-g
80e0: 65 74 0a 09 09 09 09 20 20 20 23 66 20 20 20 20 et..... #f
80f0: 20 20 20 20 20 3b 3b 20 68 69 64 65 2f 6e 6f 74 ;; hide/not
8100: 2d 68 69 64 65 0a 09 09 09 09 20 20 20 23 66 20 -hide..... #f
8110: 20 20 20 20 20 20 20 20 3b 3b 20 73 6f 72 74 2d ;; sort-
8120: 62 79 0a 09 09 09 09 20 20 20 23 66 20 20 20 20 by..... #f
8130: 20 20 20 20 20 3b 3b 20 73 6f 72 74 2d 6f 72 64 ;; sort-ord
8140: 65 72 0a 09 09 09 09 20 20 20 23 66 20 20 20 20 er..... #f
8150: 20 20 20 20 20 3b 3b 20 27 73 68 6f 72 74 6c 69 ;; 'shortli
8160: 73 74 20 20 20 20 20 20 20 20 20 20 20 20 20 20 st
8170: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ;;
8180: 71 72 79 74 79 70 65 0a 20 20 20 20 20 20 20 20 qrytype.
8190: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
81a0: 20 20 20 20 20 20 20 20 20 20 20 30 20 20 20 20 0
81b0: 20 20 20 20 20 3b 3b 20 6c 61 73 74 20 75 70 64 ;; last upd
81c0: 61 74 65 0a 09 09 09 09 20 20 20 23 66 29 29 29 ate..... #f)))
81d0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 0a 20 20 . .
81e0: 20 20 20 20 20 20 20 20 20 20 28 6d 61 70 20 28 (map (
81f0: 6c 61 6d 62 64 61 20 28 74 65 73 74 29 0a 20 20 lambda (test).
8200: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
8210: 6c 65 74 2a 20 28 28 74 65 73 74 2d 6e 61 6d 65 let* ((test-name
8220: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 65 73 (vector-ref tes
8230: 74 20 32 29 29 0a 20 20 20 20 20 20 20 20 20 20 t 2)).
8240: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 74 (t
8250: 65 73 74 2d 68 74 6d 6c 2d 70 61 74 68 20 28 63 est-html-path (c
8260: 6f 6e 63 20 28 76 65 63 74 6f 72 2d 72 65 66 20 onc (vector-ref
8270: 74 65 73 74 20 31 30 29 20 22 2f 22 20 28 76 65 test 10) "/" (ve
8280: 63 74 6f 72 2d 72 65 66 20 74 65 73 74 20 31 33 ctor-ref test 13
8290: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
82a0: 20 20 20 20 20 20 20 20 20 20 20 20 28 74 65 73 (tes
82b0: 74 2d 69 74 65 6d 20 28 63 6f 6e 63 20 74 65 73 t-item (conc tes
82c0: 74 2d 6e 61 6d 65 20 22 3a 22 20 28 76 65 63 74 t-name ":" (vect
82d0: 6f 72 2d 72 65 66 20 74 65 73 74 20 31 31 29 29 or-ref test 11))
82e0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
82f0: 20 20 20 20 20 20 20 20 20 20 28 74 65 73 74 2d (test-
8300: 73 74 61 74 75 73 20 28 76 65 63 74 6f 72 2d 72 status (vector-r
8310: 65 66 20 74 65 73 74 20 34 29 29 29 0a 20 20 20 ef test 4))).
8320: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8330: 20 20 20 20 20 20 0a 20 20 20 20 20 20 20 20 20 .
8340: 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 (if (not
8350: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
8360: 64 65 66 61 75 6c 74 20 72 65 73 68 20 74 65 73 default resh tes
8370: 74 2d 6e 61 6d 65 20 20 23 66 29 29 0a 20 20 20 t-name #f)).
8380: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8390: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 (hash-table-s
83a0: 65 74 21 20 72 65 73 68 20 74 65 73 74 2d 6e 61 et! resh test-na
83b0: 6d 65 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d me (make-hash-
83c0: 74 61 62 6c 65 29 29 29 0a 20 20 20 20 20 20 20 table))).
83d0: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f (if (no
83e0: 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 t (hash-table-re
83f0: 66 2f 64 65 66 61 75 6c 74 20 28 68 61 73 68 2d f/default (hash-
8400: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
8410: 74 20 72 65 73 68 20 74 65 73 74 2d 6e 61 6d 65 t resh test-name
8420: 20 20 23 66 29 20 20 74 65 73 74 2d 69 74 65 6d #f) test-item
8430: 20 20 23 66 29 29 0a 20 20 20 20 20 20 20 20 20 #f)).
8440: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 68 (h
8450: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 28 ash-table-set! (
8460: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
8470: 65 66 61 75 6c 74 20 72 65 73 68 20 74 65 73 74 efault resh test
8480: 2d 6e 61 6d 65 20 20 23 66 29 20 74 65 73 74 2d -name #f) test-
8490: 69 74 65 6d 20 20 20 28 6d 61 6b 65 2d 68 61 73 item (make-has
84a0: 68 2d 74 61 62 6c 65 29 29 29 20 0a 20 20 20 20 h-table))) .
84b0: 20 20 20 20 20 20 20 20 20 20 20 28 68 61 73 68 (hash
84c0: 2d 74 61 62 6c 65 2d 73 65 74 21 20 20 28 68 61 -table-set! (ha
84d0: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
84e0: 61 75 6c 74 20 28 68 61 73 68 2d 74 61 62 6c 65 ault (hash-table
84f0: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 72 65 73 -ref/default res
8500: 68 20 74 65 73 74 2d 6e 61 6d 65 20 20 23 66 29 h test-name #f)
8510: 20 74 65 73 74 2d 69 74 65 6d 20 23 66 29 20 72 test-item #f) r
8520: 75 6e 2d 69 64 20 28 6c 69 73 74 20 74 65 73 74 un-id (list test
8530: 2d 73 74 61 74 75 73 20 74 65 73 74 2d 68 74 6d -status test-htm
8540: 6c 2d 70 61 74 68 29 29 29 29 20 0a 20 20 20 20 l-path)))) .
8550: 20 20 20 20 74 65 73 74 2d 64 61 74 61 29 29 29 test-data)))
8560: 0a 20 20 20 20 20 20 72 75 6e 73 29 0a 20 20 20 . runs).
8570: 72 65 73 68 29 29 0a 0a 0a 3b 3b 20 74 65 73 74 resh))...;; test
8580: 73 3a 67 65 6e 72 61 74 65 20 64 61 73 68 62 6f s:genrate dashbo
8590: 61 72 64 20 62 6f 64 79 20 0a 3b 3b 0a 0a 28 64 ard body .;;..(d
85a0: 65 66 69 6e 65 20 28 74 65 73 74 73 3a 64 61 73 efine (tests:das
85b0: 68 62 6f 61 72 64 2d 62 6f 64 79 20 70 61 67 65 hboard-body page
85c0: 20 70 67 2d 73 69 7a 65 20 6b 65 79 73 20 6e 75 pg-size keys nu
85d0: 6d 6b 65 79 73 20 20 74 6f 74 61 6c 2d 72 75 6e mkeys total-run
85e0: 73 20 6c 69 6e 6b 74 72 65 65 20 61 72 65 61 2d s linktree area-
85f0: 6e 61 6d 65 20 67 65 74 2d 70 72 65 76 2d 6c 69 name get-prev-li
8600: 6e 6b 73 20 67 65 74 2d 6e 65 78 74 2d 6c 69 6e nks get-next-lin
8610: 6b 73 20 66 6c 61 67 20 72 75 6e 2d 70 61 74 74 ks flag run-patt
8620: 20 74 61 72 67 65 74 2d 70 61 74 74 29 0a 20 20 target-patt).
8630: 28 6c 65 74 2a 20 28 28 73 74 61 72 74 20 28 2a (let* ((start (*
8640: 20 70 61 67 65 20 70 67 2d 73 69 7a 65 29 29 20 page pg-size))
8650: 0a 09 09 09 09 09 3b 28 72 75 6e 73 64 61 74 20 ......;(runsdat
8660: 20 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e 73 20 (rmt:get-runs
8670: 22 25 22 20 70 67 2d 73 69 7a 65 20 73 74 61 72 "%" pg-size star
8680: 74 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 t (map (lambda (
8690: 78 29 28 6c 69 73 74 20 78 20 22 25 22 29 29 20 x)(list x "%"))
86a0: 6b 65 79 73 29 29 29 0a 20 20 20 20 20 20 20 20 keys))).
86b0: 20 28 72 75 6e 73 64 61 74 20 20 20 28 72 6d 74 (runsdat (rmt
86c0: 3a 67 65 74 2d 72 75 6e 73 2d 62 79 2d 70 61 74 :get-runs-by-pat
86d0: 74 20 20 6b 65 79 73 20 72 75 6e 2d 70 61 74 74 t keys run-patt
86e0: 20 74 61 72 67 65 74 2d 70 61 74 74 20 73 74 61 target-patt sta
86f0: 72 74 20 70 67 2d 73 69 7a 65 20 23 66 20 30 20 rt pg-size #f 0
8700: 73 6f 72 74 2d 6f 72 64 65 72 3a 20 22 64 65 73 sort-order: "des
8710: 63 22 29 29 0a 09 09 09 09 09 3b 20 64 62 3a 67 c"))......; db:g
8720: 65 74 2d 72 75 6e 73 2d 62 79 2d 70 61 74 74 20 et-runs-by-patt
8730: 20 20 6b 65 79 73 20 72 75 6e 6e 61 6d 65 70 61 keys runnamepa
8740: 74 74 20 74 61 72 67 70 61 74 74 20 6f 66 66 73 tt targpatt offs
8750: 65 74 20 6c 69 6d 69 74 20 66 69 65 6c 64 73 20 et limit fields
8760: 6c 61 73 74 2d 75 70 64 61 74 65 20 20 20 0a 09 last-update ..
8770: 20 28 68 65 61 64 65 72 20 20 20 20 28 76 65 63 (header (vec
8780: 74 6f 72 2d 72 65 66 20 72 75 6e 73 64 61 74 20 tor-ref runsdat
8790: 30 29 29 0a 09 20 28 72 75 6e 73 20 20 20 20 20 0)).. (runs
87a0: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e (vector-ref run
87b0: 73 64 61 74 20 31 29 29 0a 20 20 20 20 20 20 20 sdat 1)).
87c0: 20 20 28 63 74 72 20 30 29 0a 20 20 20 20 20 20 (ctr 0).
87d0: 20 20 20 28 74 65 73 74 2d 72 75 6e 73 2d 68 61 (test-runs-ha
87e0: 73 68 20 28 74 65 73 74 73 3a 67 65 74 2d 72 65 sh (tests:get-re
87f0: 73 74 2d 64 61 74 61 20 72 75 6e 73 20 68 65 61 st-data runs hea
8800: 64 65 72 20 6e 75 6d 6b 65 79 73 29 29 0a 20 20 der numkeys)).
8810: 20 20 20 20 20 20 20 28 74 65 73 74 2d 6c 69 73 (test-lis
8820: 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 t (hash-table-ke
8830: 79 73 20 74 65 73 74 2d 72 75 6e 73 2d 68 61 73 ys test-runs-has
8840: 68 29 29 29 20 0a 20 20 20 20 0a 20 20 20 20 28 h))) . . (
8850: 73 3a 68 74 6d 6c 20 74 65 73 74 73 3a 63 73 73 s:html tests:css
8860: 2d 6a 73 63 72 69 70 74 2d 62 6c 6f 63 6b 20 28 -jscript-block (
8870: 74 65 73 74 73 3a 63 73 73 2d 6a 73 63 72 69 70 tests:css-jscrip
8880: 74 2d 62 6c 6f 63 6b 2d 63 6f 6e 64 20 66 6c 61 t-block-cond fla
8890: 67 29 0a 09 20 20 20 20 28 73 3a 74 69 74 6c 65 g).. (s:title
88a0: 20 22 53 75 6d 6d 61 72 79 20 66 6f 72 20 22 20 "Summary for "
88b0: 61 72 65 61 2d 6e 61 6d 65 29 0a 09 20 20 20 20 area-name)..
88c0: 28 73 3a 62 6f 64 79 20 27 6f 6e 6c 6f 61 64 20 (s:body 'onload
88d0: 22 61 64 64 45 76 65 6e 74 73 28 29 3b 22 0a 09 "addEvents();"..
88e0: 09 20 20 20 20 28 67 65 74 2d 70 72 65 76 2d 6c . (get-prev-l
88f0: 69 6e 6b 73 20 70 61 67 65 20 6c 69 6e 6b 74 72 inks page linktr
8900: 65 65 29 0a 09 09 20 20 20 20 28 67 65 74 2d 6e ee)... (get-n
8910: 65 78 74 2d 6c 69 6e 6b 73 20 70 61 67 65 20 6c ext-links page l
8920: 69 6e 6b 74 72 65 65 20 74 6f 74 61 6c 2d 72 75 inktree total-ru
8930: 6e 73 29 0a 09 09 20 20 20 20 0a 09 09 20 20 20 ns)... ...
8940: 20 28 73 3a 68 31 20 22 53 75 6d 6d 61 72 79 20 (s:h1 "Summary
8950: 66 6f 72 20 22 20 61 72 65 61 2d 6e 61 6d 65 29 for " area-name)
8960: 0a 09 09 20 20 20 20 28 73 3a 68 33 20 22 46 69 ... (s:h3 "Fi
8970: 6c 74 65 72 22 20 29 0a 09 09 20 20 20 20 28 73 lter" )... (s
8980: 3a 69 6e 70 75 74 20 27 74 79 70 65 20 22 74 65 :input 'type "te
8990: 78 74 22 20 20 27 6e 61 6d 65 20 22 74 65 73 74 xt" 'name "test
89a0: 6e 61 6d 65 22 20 27 69 64 20 22 74 65 73 74 6e name" 'id "testn
89b0: 61 6d 65 22 20 27 6c 65 6e 67 74 68 20 22 33 30 ame" 'length "30
89c0: 22 20 27 6f 6e 6b 65 79 75 70 20 22 66 69 6c 74 " 'onkeyup "filt
89d0: 65 72 73 6f 6d 65 28 29 22 29 0a 09 09 20 20 20 ersome()")...
89e0: 20 3b 3b 20 74 6f 70 20 6c 69 73 74 0a 09 09 20 ;; top list...
89f0: 20 20 20 0a 09 09 20 20 20 20 28 73 3a 74 61 62 ... (s:tab
8a00: 6c 65 20 27 69 64 20 22 4c 69 6e 6b 65 64 4c 69 le 'id "LinkedLi
8a10: 73 74 31 22 20 27 62 6f 72 64 65 72 20 22 31 22 st1" 'border "1"
8a20: 20 27 63 65 6c 6c 73 70 61 63 69 6e 67 20 30 0a 'cellspacing 0.
8a30: 09 09 09 20 20 20 20 20 28 6d 61 70 20 28 6c 61 ... (map (la
8a40: 6d 62 64 61 20 28 6b 65 79 29 0a 09 09 09 09 20 mbda (key).....
8a50: 20 20 20 28 6c 65 74 2a 20 28 28 72 65 73 20 28 (let* ((res (
8a60: 73 3a 74 72 20 27 63 6c 61 73 73 20 22 73 6f 6d s:tr 'class "som
8a70: 65 74 68 69 6e 67 22 20 0a 09 09 09 09 09 09 20 ething" .......
8a80: 20 20 20 20 20 28 73 3a 74 68 20 6b 65 79 20 29 (s:th key )
8a90: 0a 09 09 09 09 09 09 20 20 20 20 20 20 28 6d 61 ....... (ma
8aa0: 70 20 28 6c 61 6d 62 64 61 20 28 72 75 6e 29 0a p (lambda (run).
8ab0: 09 09 09 09 09 09 09 20 20 20 20 20 28 73 3a 74 ....... (s:t
8ac0: 68 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 h (vector-ref r
8ad0: 75 6e 20 63 74 72 29 29 29 0a 09 09 09 09 09 09 un ctr))).......
8ae0: 09 20 20 20 72 75 6e 73 29 29 29 29 0a 09 09 09 . runs))))....
8af0: 09 20 20 20 20 20 20 28 73 65 74 21 20 63 74 72 . (set! ctr
8b00: 20 28 2b 20 63 74 72 20 31 29 29 0a 09 09 09 09 (+ ctr 1)).....
8b10: 20 20 20 20 20 20 72 65 73 29 29 0a 09 09 09 09 res)).....
8b20: 20 20 6b 65 79 73 29 0a 09 09 09 20 20 20 20 20 keys)....
8b30: 28 73 3a 74 72 0a 09 09 09 20 20 20 20 20 20 28 (s:tr.... (
8b40: 73 3a 74 68 20 22 52 75 6e 20 4e 61 6d 65 22 29 s:th "Run Name")
8b50: 0a 09 09 09 20 20 20 20 20 20 28 6d 61 70 20 28 .... (map (
8b60: 6c 61 6d 62 64 61 20 28 72 75 6e 29 0a 09 09 09 lambda (run)....
8b70: 09 20 20 20 20 20 28 73 3a 74 68 20 28 64 62 3a . (s:th (db:
8b80: 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 get-value-by-hea
8b90: 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 der run header "
8ba0: 72 75 6e 6e 61 6d 65 22 29 29 29 0a 09 09 09 09 runname"))).....
8bb0: 20 20 20 72 75 6e 73 29 29 0a 09 09 09 20 20 20 runs))....
8bc0: 20 20 0a 09 09 09 20 20 20 20 20 28 6d 61 70 20 .... (map
8bd0: 28 6c 61 6d 62 64 61 20 28 74 65 73 74 2d 6e 61 (lambda (test-na
8be0: 6d 65 29 0a 09 09 09 09 20 20 20 20 28 6c 65 74 me)..... (let
8bf0: 2a 20 28 28 69 74 65 6d 2d 68 61 73 68 20 28 68 * ((item-hash (h
8c00: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
8c10: 66 61 75 6c 74 20 74 65 73 74 2d 72 75 6e 73 2d fault test-runs-
8c20: 68 61 73 68 20 74 65 73 74 2d 6e 61 6d 65 20 20 hash test-name
8c30: 23 66 29 29 0a 09 09 09 09 09 20 20 20 28 69 74 #f))...... (it
8c40: 65 6d 2d 6b 65 79 73 20 28 73 6f 72 74 20 28 68 em-keys (sort (h
8c50: 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 69 ash-table-keys i
8c60: 74 65 6d 2d 68 61 73 68 29 20 73 74 72 69 6e 67 tem-hash) string
8c70: 3c 3d 3f 29 29 29 20 0a 09 09 09 09 20 20 20 20 <=?))) .....
8c80: 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 (map (lambda (
8c90: 69 74 65 6d 2d 6e 61 6d 65 29 20 20 0a 20 20 09 item-name) . .
8ca0: 09 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
8cb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l
8cc0: 65 74 2a 20 28 28 72 65 73 20 28 73 3a 74 72 20 et* ((res (s:tr
8cd0: 20 27 63 6c 61 73 73 20 69 74 65 6d 2d 6e 61 6d 'class item-nam
8ce0: 65 0a 09 09 09 09 09 09 09 09 28 73 3a 74 64 20 e.........(s:td
8cf0: 20 69 74 65 6d 2d 6e 61 6d 65 20 27 63 6c 61 73 item-name 'clas
8d00: 73 20 22 74 65 73 74 22 20 29 0a 09 09 09 09 09 s "test" )......
8d10: 09 09 09 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 ...(map (lambda
8d20: 28 72 75 6e 29 0a 09 09 09 09 09 09 09 09 20 20 (run).........
8d30: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 72 75 6e (let* ((run
8d40: 2d 74 65 73 74 20 28 68 61 73 68 2d 74 61 62 6c -test (hash-tabl
8d50: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 69 74 e-ref/default it
8d60: 65 6d 2d 68 61 73 68 20 69 74 65 6d 2d 6e 61 6d em-hash item-nam
8d70: 65 20 20 23 66 29 29 0a 09 09 09 09 09 09 09 09 e #f)).........
8d80: 09 20 20 20 20 20 20 28 72 75 6e 2d 69 64 20 28 . (run-id (
8d90: 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d db:get-value-by-
8da0: 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 header run heade
8db0: 72 20 22 69 64 22 29 29 0a 09 09 09 09 09 09 09 r "id"))........
8dc0: 09 09 20 20 20 20 20 20 28 72 65 73 75 6c 74 20 .. (result
8dd0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
8de0: 64 65 66 61 75 6c 74 20 72 75 6e 2d 74 65 73 74 default run-test
8df0: 20 72 75 6e 2d 69 64 20 22 6e 2f 61 22 29 29 0a run-id "n/a")).
8e00: 09 09 09 09 09 3b 28 72 65 6c 61 74 69 76 65 2d .....;(relative-
8e10: 70 61 74 68 20 28 67 65 74 2d 72 65 6c 61 74 69 path (get-relati
8e20: 76 65 2d 70 61 74 68 29 29 20 0a 09 09 09 09 09 ve-path)) ......
8e30: 09 09 09 09 20 20 20 20 20 20 28 73 74 61 74 75 .... (statu
8e40: 73 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 72 s (if (string? r
8e50: 65 73 75 6c 74 29 0a 09 09 09 09 09 09 09 09 09 esult)..........
8e60: 09 09 20 20 72 65 73 75 6c 74 0a 09 09 09 09 09 .. result......
8e70: 09 09 09 09 09 09 20 20 28 63 61 72 20 72 65 73 ...... (car res
8e80: 75 6c 74 29 29 29 0a 09 09 09 09 09 09 09 09 09 ult)))..........
8e90: 20 20 20 20 20 20 28 6c 69 6e 6b 20 28 69 66 20 (link (if
8ea0: 28 73 74 72 69 6e 67 3f 20 72 65 73 75 6c 74 29 (string? result)
8eb0: 0a 09 09 09 09 09 09 09 09 09 09 09 72 65 73 75 ............resu
8ec0: 6c 74 0a 09 09 09 09 09 09 09 09 09 09 09 28 69 lt............(i
8ed0: 66 20 28 65 71 75 61 6c 3f 20 66 6c 61 67 20 23 f (equal? flag #
8ee0: 74 29 20 0a 09 09 09 09 09 09 09 09 09 09 09 20 t) ............
8ef0: 20 20 20 28 73 3a 61 20 28 63 61 72 20 72 65 73 (s:a (car res
8f00: 75 6c 74 29 20 27 68 72 65 66 20 28 63 6f 6e 63 ult) 'href (conc
8f10: 20 22 2e 2f 74 65 73 74 5f 6c 6f 67 3f 72 75 6e "./test_log?run
8f20: 69 64 3d 22 20 72 75 6e 2d 69 64 20 22 26 74 65 id=" run-id "&te
8f30: 73 74 6e 61 6d 65 3d 22 20 20 69 74 65 6d 2d 6e stname=" item-n
8f40: 61 6d 65 20 29 29 0a 09 09 09 09 09 09 09 09 09 ame ))..........
8f50: 09 09 20 20 20 20 28 73 3a 61 20 28 63 61 72 20 .. (s:a (car
8f60: 72 65 73 75 6c 74 29 20 27 68 72 65 66 20 28 73 result) 'href (s
8f70: 74 72 69 6e 67 2d 73 75 62 73 74 69 74 75 74 65 tring-substitute
8f80: 20 20 28 63 6f 6e 63 20 6c 69 6e 6b 74 72 65 65 (conc linktree
8f90: 20 22 2f 22 29 20 20 22 22 20 28 63 61 64 72 20 "/") "" (cadr
8fa0: 72 65 73 75 6c 74 29 20 20 22 2d 22 29 29 29 29 result) "-"))))
8fb0: 29 29 0a 09 09 09 09 09 09 09 09 09 20 28 73 3a )).......... (s:
8fc0: 74 64 20 20 6c 69 6e 6b 20 27 63 6c 61 73 73 20 td link 'class
8fd0: 73 74 61 74 75 73 29 29 29 0a 09 09 09 09 09 09 status))).......
8fe0: 09 09 20 20 20 20 20 72 75 6e 73 29 29 29 29 0a .. runs)))).
8ff0: 09 09 09 09 09 20 20 20 20 20 20 20 72 65 73 29 ..... res)
9000: 29 0a 09 09 09 09 09 20 20 20 69 74 65 6d 2d 6b )...... item-k
9010: 65 79 73 29 29 29 0a 09 09 09 09 20 20 74 65 73 eys)))..... tes
9020: 74 2d 6c 69 73 74 29 29 29 29 29 29 20 0a 0a 3b t-list)))))) ..;
9030: 3b 20 28 74 65 73 74 73 3a 63 72 65 61 74 65 2d ; (tests:create-
9040: 68 74 6d 6c 2d 74 72 65 65 20 22 74 65 73 74 2d html-tree "test-
9050: 69 6e 64 65 78 2e 68 74 6d 6c 22 29 0a 3b 3b 0a index.html").;;.
9060: 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 63 (define (tests:c
9070: 72 65 61 74 65 2d 68 74 6d 6c 2d 74 72 65 65 20 reate-html-tree
9080: 6f 75 74 66 29 0a 20 20 28 6c 65 74 2a 20 28 28 outf). (let* ((
9090: 6c 6f 63 6b 66 69 6c 65 20 20 28 63 6f 6e 63 20 lockfile (conc
90a0: 6f 75 74 66 20 22 2e 6c 6f 63 6b 22 29 29 0a 09 outf ".lock"))..
90b0: 20 28 72 75 6e 73 2d 74 6f 2d 70 72 6f 63 65 73 (runs-to-proces
90c0: 73 20 27 28 29 29 0a 20 20 20 20 20 20 20 20 20 s '()).
90d0: 28 6c 69 6e 6b 74 72 65 65 20 20 28 63 6f 6d 6d (linktree (comm
90e0: 6f 6e 3a 67 65 74 2d 6c 69 6e 6b 74 72 65 65 29 on:get-linktree)
90f0: 29 0a 20 20 20 20 20 20 20 20 20 28 61 72 65 61 ). (area
9100: 2d 6e 61 6d 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 -name (common:ge
9110: 74 2d 74 65 73 74 73 75 69 74 65 2d 6e 61 6d 65 t-testsuite-name
9120: 29 29 0a 09 20 28 6b 65 79 73 20 20 20 20 20 20 )).. (keys
9130: 28 72 6d 74 3a 67 65 74 2d 6b 65 79 73 29 29 0a (rmt:get-keys)).
9140: 09 20 28 6e 75 6d 6b 65 79 73 20 20 20 28 6c 65 . (numkeys (le
9150: 6e 67 74 68 20 6b 65 79 73 29 29 0a 20 20 20 20 ngth keys)).
9160: 20 20 20 20 20 28 72 75 6e 2d 70 61 74 74 20 28 (run-patt (
9170: 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 or (args:get-arg
9180: 20 22 2d 72 75 6e 2d 70 61 74 74 22 29 0a 09 09 "-run-patt")...
9190: 20 20 20 20 20 20 20 28 61 72 67 73 3a 67 65 74 (args:get
91a0: 2d 61 72 67 20 22 2d 72 75 6e 6e 61 6d 65 22 29 -arg "-runname")
91b0: 0a 09 09 20 20 20 20 20 20 20 22 25 22 29 29 0a ... "%")).
91c0: 20 20 20 20 20 20 20 20 20 28 74 61 72 67 65 74 (target
91d0: 20 28 6f 72 20 20 28 61 72 67 73 3a 67 65 74 2d (or (args:get-
91e0: 61 72 67 20 22 2d 74 61 72 67 65 74 2d 70 61 74 arg "-target-pat
91f0: 74 22 29 20 0a 09 09 20 20 20 20 20 20 28 61 72 t") ... (ar
9200: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 72 gs:get-arg "-tar
9210: 67 65 74 22 29 0a 20 20 20 20 20 20 20 20 20 20 get").
9220: 20 20 20 20 20 20 20 20 20 20 20 20 22 25 22 29 "%")
9230: 29 0a 20 20 20 20 20 20 20 20 20 28 74 61 72 67 ). (targ
9240: 6c 69 73 74 20 28 73 74 72 69 6e 67 2d 73 70 6c list (string-spl
9250: 69 74 20 74 61 72 67 65 74 20 22 2f 22 29 29 0a it target "/")).
9260: 20 20 20 20 20 20 20 20 20 28 6e 75 6d 74 61 72 (numtar
9270: 67 20 20 28 6c 65 6e 67 74 68 20 74 61 72 67 6c g (length targl
9280: 69 73 74 29 29 20 20 0a 20 20 20 20 20 20 20 20 ist)) .
9290: 20 28 74 61 72 67 74 77 65 61 6b 65 64 20 28 69 (targtweaked (i
92a0: 66 20 28 3e 20 6e 75 6d 6b 65 79 73 20 6e 75 6d f (> numkeys num
92b0: 74 61 72 67 29 0a 09 09 09 20 20 28 61 70 70 65 targ).... (appe
92c0: 6e 64 20 74 61 72 67 6c 69 73 74 20 28 6d 61 6b nd targlist (mak
92d0: 65 2d 6c 69 73 74 20 28 2d 20 6e 75 6d 6b 65 79 e-list (- numkey
92e0: 73 20 6e 75 6d 74 61 72 67 29 20 22 25 22 29 29 s numtarg) "%"))
92f0: 0a 09 09 09 20 20 74 61 72 67 6c 69 73 74 29 29 .... targlist))
9300: 0a 20 20 20 20 20 20 20 20 20 28 74 61 72 67 65 . (targe
9310: 74 2d 70 61 74 74 20 28 73 74 72 69 6e 67 2d 6a t-patt (string-j
9320: 6f 69 6e 20 74 61 72 67 74 77 65 61 6b 65 64 20 oin targtweaked
9330: 22 2f 22 29 29 0a 09 09 09 09 09 3b 28 74 6f 74 "/"))......;(tot
9340: 61 6c 2d 72 75 6e 73 20 20 28 72 6d 74 3a 67 65 al-runs (rmt:ge
9350: 74 2d 6e 75 6d 2d 72 75 6e 73 20 22 25 22 29 29 t-num-runs "%"))
9360: 20 3b 3b 74 68 69 73 20 6e 65 65 64 73 20 74 6f ;;this needs to
9370: 20 62 65 20 63 68 61 6e 67 65 64 20 74 6f 20 66 be changed to f
9380: 69 6c 74 65 72 20 62 79 20 74 61 72 67 65 74 0a ilter by target.
9390: 09 20 28 74 6f 74 61 6c 2d 72 75 6e 73 20 28 72 . (total-runs (r
93a0: 6d 74 3a 67 65 74 2d 72 75 6e 73 2d 63 6e 74 2d mt:get-runs-cnt-
93b0: 62 79 2d 70 61 74 74 20 72 75 6e 2d 70 61 74 74 by-patt run-patt
93c0: 20 74 61 72 67 65 74 2d 70 61 74 74 20 6b 65 79 target-patt key
93d0: 73 20 29 29 20 0a 20 20 20 20 20 20 20 20 20 28 s )) . (
93e0: 70 67 2d 73 69 7a 65 20 31 30 29 29 0a 20 20 20 pg-size 10)).
93f0: 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d (if (common:sim
9400: 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 20 6c 6f ple-file-lock lo
9410: 63 6b 66 69 6c 65 29 0a 20 20 20 20 20 20 20 20 ckfile).
9420: 28 62 65 67 69 6e 0a 09 09 09 09 09 3b 28 70 72 (begin......;(pr
9430: 69 6e 74 20 74 6f 74 61 6c 2d 72 75 6e 73 29 20 int total-runs)
9440: 20 20 20 0a 09 20 20 28 6c 65 74 20 6c 6f 6f 70 .. (let loop
9450: 20 28 28 70 61 67 65 20 30 29 29 0a 09 20 20 20 ((page 0))..
9460: 20 28 6c 65 74 2a 20 28 28 6f 75 70 20 20 20 20 (let* ((oup
9470: 20 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 6f 75 (open-ou
9480: 74 70 75 74 2d 66 69 6c 65 20 28 6f 72 20 6f 75 tput-file (or ou
9490: 74 66 20 28 63 6f 6e 63 20 6c 69 6e 6b 74 72 65 tf (conc linktre
94a0: 65 20 22 2f 70 61 67 65 22 20 70 61 67 65 20 22 e "/page" page "
94b0: 2e 68 74 6d 6c 22 29 29 29 29 0a 09 09 20 20 20 .html"))))...
94c0: 28 67 65 74 2d 70 72 65 76 2d 6c 69 6e 6b 73 20 (get-prev-links
94d0: 28 6c 61 6d 62 64 61 20 28 70 61 67 65 20 6c 69 (lambda (page li
94e0: 6e 6b 74 72 65 65 20 29 20 20 20 0a 09 09 09 09 nktree ) .....
94f0: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 6c 69 6e (let* ((lin
9500: 6b 20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 3f k (if (not (eq?
9510: 20 70 61 67 65 20 30 29 29 0a 09 09 09 09 09 09 page 0)).......
9520: 20 20 20 20 20 20 20 28 73 3a 61 20 22 26 6c 74 (s:a "<
9530: 3b 26 6c 74 3b 70 72 65 76 22 20 27 68 72 65 66 ;<prev" 'href
9540: 20 28 63 6f 6e 63 20 20 22 70 61 67 65 22 20 28 (conc "page" (
9550: 2d 20 70 61 67 65 20 31 29 20 22 2e 68 74 6d 6c - page 1) ".html
9560: 22 29 29 0a 09 09 09 09 09 09 20 20 20 20 20 20 ")).......
9570: 20 28 73 3a 61 20 22 22 20 27 68 72 65 66 20 28 (s:a "" 'href (
9580: 63 6f 6e 63 20 20 20 22 70 61 67 65 22 20 20 70 conc "page" p
9590: 61 67 65 20 22 2e 68 74 6d 6c 22 29 29 29 29 29 age ".html")))))
95a0: 0a 09 09 09 09 20 20 20 20 20 20 20 6c 69 6e 6b ..... link
95b0: 29 29 29 0a 09 09 20 20 20 28 67 65 74 2d 6e 65 )))... (get-ne
95c0: 78 74 2d 6c 69 6e 6b 73 20 28 6c 61 6d 62 64 61 xt-links (lambda
95d0: 20 28 70 61 67 65 20 6c 69 6e 6b 74 72 65 65 20 (page linktree
95e0: 74 6f 74 61 6c 2d 72 75 6e 73 29 20 20 20 0a 09 total-runs) ..
95f0: 09 09 09 20 20 20 20 20 28 6c 65 74 2a 20 28 28 ... (let* ((
9600: 6c 69 6e 6b 20 20 28 69 66 20 28 3e 20 74 6f 74 link (if (> tot
9610: 61 6c 2d 72 75 6e 73 20 28 2b 20 31 30 20 28 2a al-runs (+ 10 (*
9620: 20 70 61 67 65 20 70 67 2d 73 69 7a 65 29 29 29 page pg-size)))
9630: 0a 09 09 09 09 09 09 20 20 20 20 20 20 20 28 73 ....... (s
9640: 3a 61 20 22 6e 65 78 74 26 67 74 3b 26 67 74 3b :a "next>>
9650: 22 20 27 68 72 65 66 20 28 63 6f 6e 63 20 20 22 " 'href (conc "
9660: 70 61 67 65 22 20 20 28 2b 20 70 61 67 65 20 31 page" (+ page 1
9670: 29 20 22 2e 68 74 6d 6c 22 29 29 0a 09 09 09 09 ) ".html")).....
9680: 09 09 20 20 20 20 20 20 20 28 73 3a 61 20 22 22 .. (s:a ""
9690: 20 27 68 72 65 66 20 28 63 6f 6e 63 20 20 20 22 'href (conc "
96a0: 70 61 67 65 22 20 70 61 67 65 20 20 22 2e 68 74 page" page ".ht
96b0: 6d 6c 22 29 29 29 29 29 0a 09 09 09 09 20 20 20 ml"))))).....
96c0: 20 20 20 20 6c 69 6e 6b 29 29 29 20 29 0a 09 20 link))) )..
96d0: 20 20 20 20 20 28 70 72 69 6e 74 20 22 74 6f 74 (print "tot
96e0: 61 6c 20 72 75 6e 73 3a 20 22 20 74 6f 74 61 6c al runs: " total
96f0: 2d 72 75 6e 73 29 20 0a 09 20 20 20 20 20 20 28 -runs) .. (
9700: 73 3a 6f 75 74 70 75 74 2d 6e 65 77 0a 09 20 20 s:output-new..
9710: 20 20 20 20 20 6f 75 70 0a 09 20 20 20 20 20 20 oup..
9720: 20 28 74 65 73 74 73 3a 64 61 73 68 62 6f 61 72 (tests:dashboar
9730: 64 2d 62 6f 64 79 20 70 61 67 65 20 70 67 2d 73 d-body page pg-s
9740: 69 7a 65 20 6b 65 79 73 20 6e 75 6d 6b 65 79 73 ize keys numkeys
9750: 20 74 6f 74 61 6c 2d 72 75 6e 73 20 6c 69 6e 6b total-runs link
9760: 74 72 65 65 20 61 72 65 61 2d 6e 61 6d 65 20 67 tree area-name g
9770: 65 74 2d 70 72 65 76 2d 6c 69 6e 6b 73 20 67 65 et-prev-links ge
9780: 74 2d 6e 65 78 74 2d 6c 69 6e 6b 73 20 23 66 20 t-next-links #f
9790: 72 75 6e 2d 70 61 74 74 20 74 61 72 67 65 74 2d run-patt target-
97a0: 70 61 74 74 29 29 20 3b 3b 20 75 70 64 61 74 65 patt)) ;; update
97b0: 20 74 68 69 73 20 66 75 6e 63 74 69 6f 6e 0a 09 this function..
97c0: 20 20 20 20 20 20 28 63 6c 6f 73 65 2d 6f 75 74 (close-out
97d0: 70 75 74 2d 70 6f 72 74 20 6f 75 70 29 0a 09 09 put-port oup)...
97e0: 09 09 09 3b 20 28 73 65 74 21 20 70 61 67 65 20 ...; (set! page
97f0: 28 2b 20 31 20 70 61 67 65 29 29 0a 09 20 20 20 (+ 1 page))..
9800: 20 20 20 28 69 66 20 28 3e 20 74 6f 74 61 6c 2d (if (> total-
9810: 72 75 6e 73 20 28 2a 20 28 2b 20 31 20 70 61 67 runs (* (+ 1 pag
9820: 65 29 20 70 67 2d 73 69 7a 65 29 29 0a 09 09 20 e) pg-size))...
9830: 20 28 6c 6f 6f 70 20 28 2b 20 31 20 20 70 61 67 (loop (+ 1 pag
9840: 65 29 29 29 29 29 0a 09 20 20 28 63 6f 6d 6d 6f e))))).. (commo
9850: 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 72 65 n:simple-file-re
9860: 6c 65 61 73 65 2d 6c 6f 63 6b 20 6c 6f 63 6b 66 lease-lock lockf
9870: 69 6c 65 29 29 0a 09 28 62 65 67 69 6e 0a 09 20 ile))..(begin..
9880: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
9890: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
98a0: 74 2a 20 22 46 61 69 6c 65 64 20 74 6f 20 67 65 t* "Failed to ge
98b0: 74 20 6c 6f 63 6b 20 6f 6e 20 66 69 6c 65 20 6f t lock on file o
98c0: 75 74 66 2c 20 6c 6f 63 6b 66 69 6c 65 3a 20 22 utf, lockfile: "
98d0: 20 6c 6f 63 6b 66 69 6c 65 29 20 23 66 29 29 29 lockfile) #f)))
98e0: 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 )...(define (tes
98f0: 74 73 3a 72 65 61 64 6c 69 6e 65 73 20 66 69 6c ts:readlines fil
9900: 65 6e 61 6d 65 29 0a 20 20 28 63 61 6c 6c 2d 77 ename). (call-w
9910: 69 74 68 2d 69 6e 70 75 74 2d 66 69 6c 65 20 66 ith-input-file f
9920: 69 6c 65 6e 61 6d 65 0a 20 20 20 20 28 6c 61 6d ilename. (lam
9930: 62 64 61 20 28 70 29 0a 20 20 20 20 20 20 28 6c bda (p). (l
9940: 65 74 20 6c 6f 6f 70 20 28 28 6c 69 6e 65 20 28 et loop ((line (
9950: 72 65 61 64 2d 6c 69 6e 65 20 70 29 29 0a 20 20 read-line p)).
9960: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
9970: 72 65 73 75 6c 74 20 27 28 29 29 29 0a 20 20 20 result '())).
9980: 20 20 20 20 20 28 69 66 20 28 65 6f 66 2d 6f 62 (if (eof-ob
9990: 6a 65 63 74 3f 20 6c 69 6e 65 29 0a 20 20 20 20 ject? line).
99a0: 20 20 20 20 20 20 20 20 28 72 65 76 65 72 73 65 (reverse
99b0: 20 72 65 73 75 6c 74 29 0a 20 20 20 20 20 20 20 result).
99c0: 20 20 20 20 20 28 6c 6f 6f 70 20 28 72 65 61 64 (loop (read
99d0: 2d 6c 69 6e 65 20 70 29 20 28 63 6f 6e 73 20 6c -line p) (cons l
99e0: 69 6e 65 20 72 65 73 75 6c 74 29 29 29 29 29 29 ine result))))))
99f0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 )..(define (test
9a00: 73 3a 67 65 74 2d 74 65 73 74 2d 6c 6f 67 20 72 s:get-test-log r
9a10: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 un-id test-name
9a20: 69 74 65 6d 2d 6e 61 6d 65 29 0a 20 20 28 6c 65 item-name). (le
9a30: 74 2a 20 28 28 74 65 73 74 2d 64 61 74 61 20 20 t* ((test-data
9a40: 20 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 73 (rmt:get-tests
9a50: 2d 66 6f 72 2d 72 75 6e 0a 09 09 09 09 20 20 20 -for-run.....
9a60: 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 (string->number
9a70: 72 75 6e 2d 69 64 29 0a 20 20 20 20 20 20 20 20 run-id).
9a80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9a90: 20 20 20 20 20 20 20 20 20 20 20 20 74 65 73 74 test
9aa0: 2d 6e 61 6d 65 20 20 20 20 20 20 3b 3b 20 74 65 -name ;; te
9ab0: 73 74 6e 61 6d 65 70 61 74 74 0a 09 09 09 09 20 stnamepatt.....
9ac0: 20 20 27 28 29 20 20 20 20 20 20 20 20 3b 3b 20 '() ;;
9ad0: 73 74 61 74 65 73 0a 09 09 09 09 20 20 20 27 28 states..... '(
9ae0: 29 20 20 20 20 20 20 20 20 3b 3b 20 73 74 61 74 ) ;; stat
9af0: 75 73 65 73 0a 09 09 09 09 20 20 20 23 66 20 20 uses..... #f
9b00: 20 20 20 20 20 20 20 3b 3b 20 6f 66 66 73 65 74 ;; offset
9b10: 0a 09 09 09 09 20 20 20 23 66 20 20 20 20 20 20 ..... #f
9b20: 20 20 20 3b 3b 20 6e 75 6d 2d 74 6f 2d 67 65 74 ;; num-to-get
9b30: 0a 09 09 09 09 20 20 20 23 66 20 20 20 20 20 20 ..... #f
9b40: 20 20 20 3b 3b 20 68 69 64 65 2f 6e 6f 74 2d 68 ;; hide/not-h
9b50: 69 64 65 0a 09 09 09 09 20 20 20 23 66 20 20 20 ide..... #f
9b60: 20 20 20 20 20 20 3b 3b 20 73 6f 72 74 2d 62 79 ;; sort-by
9b70: 0a 09 09 09 09 20 20 20 23 66 20 20 20 20 20 20 ..... #f
9b80: 20 20 20 3b 3b 20 73 6f 72 74 2d 6f 72 64 65 72 ;; sort-order
9b90: 0a 09 09 09 09 20 20 20 23 66 20 20 20 20 20 20 ..... #f
9ba0: 20 20 20 3b 3b 20 27 73 68 6f 72 74 6c 69 73 74 ;; 'shortlist
9bb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9bc0: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 71 72 ;; qr
9bd0: 79 74 79 70 65 0a 20 20 20 20 20 20 20 20 20 20 ytype.
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 30 20 20 20 20 20 20 0
9c00: 20 20 20 3b 3b 20 6c 61 73 74 20 75 70 64 61 74 ;; last updat
9c10: 65 0a 09 09 09 09 20 20 20 23 66 29 29 0a 20 20 e..... #f)).
9c20: 20 20 20 20 20 20 20 28 70 61 74 68 20 22 22 29 (path "")
9c30: 0a 20 20 20 20 20 20 20 20 20 28 66 6f 75 6e 64 . (found
9c40: 20 30 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a 0)). (debug:
9c50: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 print-info 0 *de
9c60: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
9c70: 22 66 6f 75 6e 64 3a 20 22 20 66 6f 75 6e 64 20 "found: " found
9c80: 29 0a 0a 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 ).. (let loop
9c90: 28 28 68 65 64 20 28 63 61 72 20 74 65 73 74 2d ((hed (car test-
9ca0: 64 61 74 61 29 29 0a 09 09 20 28 74 61 6c 20 28 data))... (tal (
9cb0: 63 64 72 20 74 65 73 74 2d 64 61 74 61 29 29 29 cdr test-data)))
9cc0: 0a 20 20 20 20 20 20 20 20 20 20 28 64 65 62 75 . (debu
9cd0: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a g:print-info 0 *
9ce0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
9cf0: 2a 20 22 69 74 65 6d 3a 20 22 20 28 76 65 63 74 * "item: " (vect
9d00: 6f 72 2d 72 65 66 20 68 65 64 20 31 31 29 20 28 or-ref hed 11) (
9d10: 76 65 63 74 6f 72 2d 72 65 66 20 68 65 64 20 31 vector-ref hed 1
9d20: 30 29 20 22 2f 22 20 28 76 65 63 74 6f 72 2d 72 0) "/" (vector-r
9d30: 65 66 20 68 65 64 20 31 33 29 29 0a 0a 09 28 69 ef hed 13))...(i
9d40: 66 20 28 65 71 75 61 6c 3f 20 28 76 65 63 74 6f f (equal? (vecto
9d50: 72 2d 72 65 66 20 68 65 64 20 31 31 29 20 69 74 r-ref hed 11) it
9d60: 65 6d 2d 6e 61 6d 65 29 0a 20 20 20 20 20 20 20 em-name).
9d70: 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 (begin.
9d80: 20 20 20 20 20 20 20 20 20 20 28 73 65 74 21 20 (set!
9d90: 66 6f 75 6e 64 20 31 29 20 0a 09 20 20 20 20 20 found 1) ..
9da0: 20 28 73 65 74 21 20 70 61 74 68 20 28 63 6f 6e (set! path (con
9db0: 63 20 28 76 65 63 74 6f 72 2d 72 65 66 20 68 65 c (vector-ref he
9dc0: 64 20 31 30 29 20 22 2f 22 20 28 76 65 63 74 6f d 10) "/" (vecto
9dd0: 72 2d 72 65 66 20 68 65 64 20 31 33 29 29 29 29 r-ref hed 13))))
9de0: 29 0a 09 20 20 20 20 28 69 66 20 28 61 6e 64 20 ).. (if (and
9df0: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 (not (null? tal)
9e00: 29 20 28 65 71 75 61 6c 3f 20 66 6f 75 6e 64 20 ) (equal? found
9e10: 30 29 29 0a 09 09 28 6c 6f 6f 70 20 28 63 61 72 0))...(loop (car
9e20: 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 29 29 tal)(cdr tal)))
9e30: 29 0a 20 20 20 28 69 66 20 28 65 71 75 61 6c 3f ). (if (equal?
9e40: 20 70 61 74 68 20 22 22 29 0a 20 20 20 20 20 22 path ""). "
9e50: 3c 48 32 3e 44 61 74 61 20 6e 6f 74 20 66 6f 75 <H2>Data not fou
9e60: 6e 64 3c 2f 48 32 3e 22 0a 20 20 20 20 20 28 73 nd</H2>". (s
9e70: 74 72 69 6e 67 2d 6a 6f 69 6e 20 28 74 65 73 74 tring-join (test
9e80: 73 3a 72 65 61 64 6c 69 6e 65 73 20 70 61 74 68 s:readlines path
9e90: 29 20 22 5c 6e 22 29 29 29 29 0a 0a 0a 28 64 65 ) "\n"))))...(de
9ea0: 66 69 6e 65 20 28 74 65 73 74 73 3a 64 79 6e 61 fine (tests:dyna
9eb0: 6d 69 63 2d 64 62 6f 61 72 64 20 70 61 67 65 29 mic-dboard page)
9ec0: 0a 3b 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 .;(define (tests
9ed0: 3a 63 72 65 61 74 65 2d 68 74 6d 6c 2d 74 72 65 :create-html-tre
9ee0: 65 20 6f 29 0a 20 28 6c 65 74 2a 20 28 0a 3b 28 e o). (let* (.;(
9ef0: 70 61 67 65 20 22 31 22 29 0a 20 20 20 20 20 20 page "1").
9f00: 20 20 20 20 28 6c 69 6e 6b 74 72 65 65 20 20 28 (linktree (
9f10: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 69 6e 6b 74 common:get-linkt
9f20: 72 65 65 29 29 0a 20 20 20 20 20 20 20 20 20 28 ree)). (
9f30: 61 72 65 61 2d 6e 61 6d 65 20 28 63 6f 6d 6d 6f area-name (commo
9f40: 6e 3a 67 65 74 2d 74 65 73 74 73 75 69 74 65 2d n:get-testsuite-
9f50: 6e 61 6d 65 29 29 0a 09 20 20 20 20 20 20 20 28 name)).. (
9f60: 6b 65 79 73 20 20 20 20 20 20 28 72 6d 74 3a 67 keys (rmt:g
9f70: 65 74 2d 6b 65 79 73 29 29 0a 09 20 20 20 20 20 et-keys))..
9f80: 20 20 28 6e 75 6d 6b 65 79 73 20 20 20 28 6c 65 (numkeys (le
9f90: 6e 67 74 68 20 6b 65 79 73 29 29 0a 20 20 20 20 ngth keys)).
9fa0: 20 20 20 20 20 28 74 61 72 67 74 77 65 61 6b 65 (targtweake
9fb0: 64 20 28 6d 61 6b 65 2d 6c 69 73 74 20 6e 75 6d d (make-list num
9fc0: 6b 65 79 73 20 22 25 22 29 29 0a 20 20 20 20 20 keys "%")).
9fd0: 20 20 20 20 28 74 61 72 67 65 74 2d 70 61 74 74 (target-patt
9fe0: 20 28 73 74 72 69 6e 67 2d 6a 6f 69 6e 20 74 61 (string-join ta
9ff0: 72 67 74 77 65 61 6b 65 64 20 22 2f 22 29 29 0a rgtweaked "/")).
a000: 20 20 20 20 20 20 20 20 20 28 74 6f 74 61 6c 2d (total-
a010: 72 75 6e 73 20 20 28 72 6d 74 3a 67 65 74 2d 6e runs (rmt:get-n
a020: 75 6d 2d 72 75 6e 73 20 22 25 22 29 29 0a 20 20 um-runs "%")).
a030: 20 20 20 20 20 20 20 28 70 67 2d 73 69 7a 65 20 (pg-size
a040: 31 30 29 0a 20 20 20 20 20 20 20 20 20 28 70 67 10). (pg
a050: 20 28 69 66 20 28 65 71 75 61 6c 3f 20 70 61 67 (if (equal? pag
a060: 65 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 e #f).
a070: 20 20 20 20 20 20 20 30 0a 20 20 20 20 20 20 20 0.
a080: 20 20 20 20 20 20 20 20 20 20 28 2d 20 28 73 74 (- (st
a090: 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 70 61 67 ring->number pag
a0a0: 65 29 20 31 29 29 29 0a 20 20 20 20 20 20 20 20 e) 1))).
a0b0: 20 20 28 67 65 74 2d 70 72 65 76 2d 6c 69 6e 6b (get-prev-link
a0c0: 73 20 20 28 6c 61 6d 62 64 61 20 28 70 67 20 6c s (lambda (pg l
a0d0: 69 6e 6b 74 72 65 65 29 0a 20 20 20 20 20 20 20 inktree).
a0e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a0f0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
a100: 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 -info 0 *default
a110: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 76 61 6c 3a -log-port* "val:
a120: 20 22 20 28 2d 20 31 20 70 67 29 29 0a 20 20 20 " (- 1 pg)).
a130: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a140: 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 6c (let* ((l
a150: 69 6e 6b 20 20 28 69 66 20 28 6e 6f 74 20 28 65 ink (if (not (e
a160: 71 3f 20 70 67 20 30 29 29 0a 20 20 20 20 20 20 q? pg 0)).
a170: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a180: 20 20 20 20 20 20 20 20 20 28 73 3a 61 20 20 22 (s:a "
a190: 26 6c 74 3b 26 6c 74 3b 70 72 65 76 20 22 20 27 <<prev " '
a1a0: 68 72 65 66 20 28 63 6f 6e 63 20 20 22 64 61 73 href (conc "das
a1b0: 68 62 6f 61 72 64 3f 70 61 67 65 3d 22 20 20 70 hboard?page=" p
a1c0: 67 20 20 29 29 0a 20 20 20 20 20 20 20 20 20 20 g )).
a1d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a1e0: 20 20 20 20 20 28 73 3a 61 20 22 22 20 27 68 72 (s:a "" 'hr
a1f0: 65 66 20 28 63 6f 6e 63 20 20 22 64 61 73 68 62 ef (conc "dashb
a200: 6f 61 72 64 3f 70 61 67 65 3d 22 20 70 67 29 29 oard?page=" pg))
a210: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
a220: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a230: 20 20 20 6c 69 6e 6b 29 29 29 0a 20 20 20 20 20 link))).
a240: 20 20 20 20 20 28 67 65 74 2d 6e 65 78 74 2d 6c (get-next-l
a250: 69 6e 6b 73 20 20 20 28 6c 61 6d 62 64 61 20 28 inks (lambda (
a260: 70 67 20 6c 69 6e 6b 74 72 65 65 20 74 6f 74 61 pg linktree tota
a270: 6c 2d 72 75 6e 73 29 20 20 0a 20 20 20 20 20 20 l-runs) .
a280: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a290: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
a2a0: 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 nt-info 0 *defau
a2b0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 76 61 lt-log-port* "va
a2c0: 6c 3a 20 22 20 70 67 29 0a 20 20 20 20 20 20 20 l: " pg).
a2d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a2e0: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
a2f0: 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 nt-info 0 *defau
a300: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 76 61 lt-log-port* "va
a310: 6c 3a 20 22 20 74 6f 74 61 6c 2d 72 75 6e 73 20 l: " total-runs
a320: 22 20 73 69 7a 65 22 20 70 67 2d 73 69 7a 65 29 " size" pg-size)
a330: 0a 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 . .
a340: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
a350: 6c 65 74 2a 20 28 28 6c 69 6e 6b 20 20 28 69 66 let* ((link (if
a360: 20 28 3e 20 74 6f 74 61 6c 2d 72 75 6e 73 20 28 (> total-runs (
a370: 2b 20 31 30 20 28 2a 20 70 67 20 70 67 2d 73 69 + 10 (* pg pg-si
a380: 7a 65 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 ze))).
a390: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a3a0: 20 20 20 20 28 73 3a 61 20 20 22 6e 65 78 74 26 (s:a "next&
a3b0: 67 74 3b 26 67 74 3b 20 22 20 20 27 68 72 65 66 gt;> " 'href
a3c0: 20 28 63 6f 6e 63 20 20 22 64 61 73 68 62 6f 61 (conc "dashboa
a3d0: 72 64 3f 70 61 67 65 3d 22 20 20 28 2b 20 70 67 rd?page=" (+ pg
a3e0: 20 32 29 20 20 29 29 0a 20 20 20 20 20 20 20 20 2) )).
a3f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a400: 20 20 20 20 20 28 73 3a 61 20 22 22 20 27 68 72 (s:a "" 'hr
a410: 65 66 20 28 63 6f 6e 63 20 20 22 64 61 73 68 62 ef (conc "dashb
a420: 6f 61 72 64 3f 70 61 67 65 3d 22 20 70 67 20 20 oard?page=" pg
a430: 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 ))))).
a440: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a450: 20 20 20 6c 69 6e 6b 29 29 29 0a 20 20 20 20 20 link))).
a460: 20 20 20 20 28 68 74 6d 6c 2d 62 6f 64 79 20 28 (html-body (
a470: 74 65 73 74 73 3a 64 61 73 68 62 6f 61 72 64 2d tests:dashboard-
a480: 62 6f 64 79 20 70 67 20 70 67 2d 73 69 7a 65 20 body pg pg-size
a490: 6b 65 79 73 20 6e 75 6d 6b 65 79 73 20 74 6f 74 keys numkeys tot
a4a0: 61 6c 2d 72 75 6e 73 20 6c 69 6e 6b 74 72 65 65 al-runs linktree
a4b0: 20 61 72 65 61 2d 6e 61 6d 65 20 67 65 74 2d 70 area-name get-p
a4c0: 72 65 76 2d 6c 69 6e 6b 73 20 67 65 74 2d 6e 65 rev-links get-ne
a4d0: 78 74 2d 6c 69 6e 6b 73 20 23 74 20 22 25 22 20 xt-links #t "%"
a4e0: 74 61 72 67 65 74 2d 70 61 74 74 29 29 29 20 3b target-patt))) ;
a4f0: 3b 20 75 70 64 61 74 65 20 74 69 73 20 66 75 6e ; update tis fun
a500: 63 74 69 6f 6e 0a 20 20 20 20 20 20 20 20 68 74 ction. ht
a510: 6d 6c 2d 62 6f 64 79 29 29 0a 0a 28 64 65 66 69 ml-body))..(defi
a520: 6e 65 20 28 74 65 73 74 73 3a 63 72 65 61 74 65 ne (tests:create
a530: 2d 68 74 6d 6c 2d 73 75 6d 6d 61 72 79 20 6f 75 -html-summary ou
a540: 74 66 29 0a 20 28 6c 65 74 2a 20 28 28 6c 6f 63 tf). (let* ((loc
a550: 6b 66 69 6c 65 20 20 28 63 6f 6e 63 20 6f 75 74 kfile (conc out
a560: 66 20 22 2e 6c 6f 63 6b 22 29 29 0a 20 20 20 20 f ".lock")).
a570: 20 20 20 20 28 6c 69 6e 6b 74 72 65 65 20 20 28 (linktree (
a580: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 69 6e 6b 74 common:get-linkt
a590: 72 65 65 29 29 0a 09 09 09 09 28 6b 65 79 73 20 ree)).....(keys
a5a0: 20 20 20 20 20 28 72 6d 74 3a 67 65 74 2d 6b 65 (rmt:get-ke
a5b0: 79 73 29 29 0a 20 20 20 20 20 20 20 20 28 61 72 ys)). (ar
a5c0: 65 61 2d 6e 61 6d 65 20 28 63 6f 6d 6d 6f 6e 3a ea-name (common:
a5d0: 67 65 74 2d 74 65 73 74 73 75 69 74 65 2d 6e 61 get-testsuite-na
a5e0: 6d 65 29 29 0a 20 20 20 20 20 20 20 20 28 72 75 me)). (ru
a5f0: 6e 2d 70 61 74 74 20 28 6f 72 20 28 61 72 67 73 n-patt (or (args
a600: 3a 67 65 74 2d 61 72 67 20 22 2d 72 75 6e 2d 70 :get-arg "-run-p
a610: 61 74 74 22 29 0a 20 20 20 20 20 20 20 20 20 20 att").
a620: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 61 (a
a630: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 75 rgs:get-arg "-ru
a640: 6e 6e 61 6d 65 22 29 0a 20 20 20 20 20 20 20 20 nname").
a650: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a660: 22 25 22 29 29 0a 20 20 20 20 20 20 20 20 28 74 "%")). (t
a670: 61 72 67 65 74 20 28 6f 72 20 28 61 72 67 73 3a arget (or (args:
a680: 67 65 74 2d 61 72 67 20 22 2d 74 61 72 67 65 74 get-arg "-target
a690: 2d 70 61 74 74 22 29 0a 20 20 20 20 20 20 20 20 -patt").
a6a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a6b0: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
a6c0: 74 61 72 67 65 74 22 29 0a 20 20 20 20 20 20 20 target").
a6d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a6e0: 20 22 25 22 29 29 0a 20 20 20 20 20 20 20 20 20 "%")).
a6f0: 28 74 61 72 67 6c 69 73 74 20 28 73 74 72 69 6e (targlist (strin
a700: 67 2d 73 70 6c 69 74 20 74 61 72 67 65 74 20 22 g-split target "
a710: 2f 22 29 29 0a 20 20 20 20 20 20 20 20 20 28 6e /")). (n
a720: 75 6d 6b 65 79 73 20 20 28 6c 65 6e 67 74 68 20 umkeys (length
a730: 6b 65 79 73 29 29 0a 09 20 20 20 20 20 20 20 28 keys)).. (
a740: 6e 75 6d 74 61 72 67 20 20 28 6c 65 6e 67 74 68 numtarg (length
a750: 20 74 61 72 67 6c 69 73 74 29 29 20 20 0a 20 20 targlist)) .
a760: 20 20 20 20 20 20 20 28 74 61 72 67 74 77 65 61 (targtwea
a770: 6b 65 64 20 28 69 66 20 28 3e 20 6e 75 6d 6b 65 ked (if (> numke
a780: 79 73 20 6e 75 6d 74 61 72 67 29 0a 09 09 09 20 ys numtarg)....
a790: 20 20 09 09 09 09 09 09 09 09 28 61 70 70 65 6e ........(appen
a7a0: 64 20 74 61 72 67 6c 69 73 74 20 28 6d 61 6b 65 d targlist (make
a7b0: 2d 6c 69 73 74 20 28 2d 20 6e 75 6d 6b 65 79 73 -list (- numkeys
a7c0: 20 6e 75 6d 74 61 72 67 29 20 22 25 22 29 29 0a numtarg) "%")).
a7d0: 09 09 09 20 20 09 09 09 09 09 09 09 09 74 61 72 ... ........tar
a7e0: 67 6c 69 73 74 29 29 0a 20 20 20 20 20 20 20 20 glist)).
a7f0: 28 74 61 72 67 65 74 2d 70 61 74 74 20 28 73 74 (target-patt (st
a800: 72 69 6e 67 2d 6a 6f 69 6e 20 74 61 72 67 74 77 ring-join targtw
a810: 65 61 6b 65 64 20 22 2f 22 29 29 29 0a 20 20 20 eaked "/"))).
a820: 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d (if (common:sim
a830: 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 20 6c 6f ple-file-lock lo
a840: 63 6b 66 69 6c 65 29 0a 20 20 20 20 20 20 20 20 ckfile).
a850: 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 (begin.
a860: 20 28 6c 65 74 2a 20 28 3b 28 72 75 6e 73 64 61 (let* (;(runsda
a870: 74 31 20 20 20 28 72 6d 74 3a 67 65 74 2d 72 75 t1 (rmt:get-ru
a880: 6e 73 20 72 75 6e 2d 70 61 74 74 20 23 66 20 23 ns run-patt #f #
a890: 66 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 f (map (lambda (
a8a0: 78 29 28 6c 69 73 74 20 78 20 22 25 22 29 29 20 x)(list x "%"))
a8b0: 6b 65 79 73 29 29 29 0a 20 20 20 20 20 20 20 20 keys))).
a8c0: 20 20 20 20 20 20 20 20 20 28 72 75 6e 73 64 61 (runsda
a8d0: 74 20 20 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e t (rmt:get-run
a8e0: 73 2d 62 79 2d 70 61 74 74 20 20 6b 65 79 73 20 s-by-patt keys
a8f0: 72 75 6e 2d 70 61 74 74 20 74 61 72 67 65 74 2d run-patt target-
a900: 70 61 74 74 20 23 66 20 23 66 20 23 66 20 30 29 patt #f #f #f 0)
a910: 29 0a 09 09 09 09 09 20 20 20 20 20 20 20 28 72 )...... (r
a920: 75 6e 73 20 20 20 20 20 20 28 76 65 63 74 6f 72 uns (vector
a930: 2d 72 65 66 20 72 75 6e 73 64 61 74 20 31 29 29 -ref runsdat 1))
a940: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
a950: 20 20 28 68 65 61 64 65 72 20 20 20 20 20 20 28 (header (
a960: 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 73 64 vector-ref runsd
a970: 61 74 20 30 29 29 0a 20 20 20 20 20 20 20 20 09 at 0)). .
a980: 20 20 20 20 20 20 20 28 6f 75 70 20 20 20 20 20 (oup
a990: 20 20 28 6f 70 65 6e 2d 6f 75 74 70 75 74 2d 66 (open-output-f
a9a0: 69 6c 65 20 28 6f 72 20 6f 75 74 66 20 28 63 6f ile (or outf (co
a9b0: 6e 63 20 6c 69 6e 6b 74 72 65 65 20 22 2f 74 61 nc linktree "/ta
a9c0: 72 67 65 74 73 2e 68 74 6d 6c 22 29 29 29 29 0a rgets.html")))).
a9d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a9e0: 20 28 74 61 72 67 65 74 2d 68 61 73 68 20 28 74 (target-hash (t
a9f0: 65 73 74 3a 63 72 65 61 74 65 2d 74 61 72 67 65 est:create-targe
aa00: 74 2d 68 61 73 68 20 72 75 6e 73 20 68 65 61 64 t-hash runs head
aa10: 65 72 20 28 6c 65 6e 67 74 68 20 6b 65 79 73 29 er (length keys)
aa20: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 ))). (
aa30: 74 65 73 74 3a 63 72 65 61 74 65 2d 74 61 72 67 test:create-targ
aa40: 65 74 2d 68 74 6d 6c 20 74 61 72 67 65 74 2d 68 et-html target-h
aa50: 61 73 68 20 6f 75 70 20 61 72 65 61 2d 6e 61 6d ash oup area-nam
aa60: 65 20 6c 69 6e 6b 74 72 65 65 29 0a 20 20 20 20 e linktree).
aa70: 20 20 20 20 20 20 28 74 65 73 74 3a 63 72 65 61 (test:crea
aa80: 74 65 2d 72 75 6e 2d 68 74 6d 6c 20 20 72 75 6e te-run-html run
aa90: 73 20 61 72 65 61 2d 6e 61 6d 65 20 6c 69 6e 6b s area-name link
aaa0: 74 72 65 65 20 28 6c 65 6e 67 74 68 20 6b 65 79 tree (length key
aab0: 73 29 20 68 65 61 64 65 72 29 29 0a 09 20 20 28 s) header)).. (
aac0: 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 common:simple-fi
aad0: 6c 65 2d 72 65 6c 65 61 73 65 2d 6c 6f 63 6b 20 le-release-lock
aae0: 6c 6f 63 6b 66 69 6c 65 29 29 0a 09 23 66 29 29 lockfile))..#f))
aaf0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 )..(define (test
ab00: 3a 67 65 74 2d 74 65 73 74 2d 68 61 73 68 20 74 :get-test-hash t
ab10: 65 73 74 2d 64 61 74 61 29 0a 09 28 6c 65 74 20 est-data)..(let
ab20: 28 28 72 65 73 68 20 28 6d 61 6b 65 2d 68 61 73 ((resh (make-has
ab30: 68 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 20 09 h-table))). .
ab40: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 74 65 (map (lambda (te
ab50: 73 74 29 0a 20 20 20 20 20 20 20 20 28 6c 65 74 st). (let
ab60: 2a 20 28 28 74 65 73 74 2d 6e 61 6d 65 20 28 76 * ((test-name (v
ab70: 65 63 74 6f 72 2d 72 65 66 20 74 65 73 74 20 32 ector-ref test 2
ab80: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
ab90: 20 20 28 74 65 73 74 2d 68 74 6d 6c 2d 70 61 74 (test-html-pat
aba0: 68 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 h (if (file-exis
abb0: 74 73 3f 20 28 63 6f 6e 63 20 28 76 65 63 74 6f ts? (conc (vecto
abc0: 72 2d 72 65 66 20 74 65 73 74 20 31 30 29 20 22 r-ref test 10) "
abd0: 2f 74 65 73 74 2d 73 75 6d 6d 61 72 79 2e 68 74 /test-summary.ht
abe0: 6d 6c 22 29 29 0a 09 09 09 09 09 09 09 09 09 09 ml"))...........
abf0: 09 09 09 09 09 09 20 28 63 6f 6e 63 20 28 76 65 ...... (conc (ve
ac00: 63 74 6f 72 2d 72 65 66 20 74 65 73 74 20 31 30 ctor-ref test 10
ac10: 29 20 22 2f 74 65 73 74 2d 73 75 6d 6d 61 72 79 ) "/test-summary
ac20: 2e 68 74 6d 6c 22 20 29 0a 09 09 09 09 09 09 09 .html" )........
ac30: 20 09 09 09 09 09 09 09 09 09 20 28 63 6f 6e 63 ......... (conc
ac40: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 65 73 (vector-ref tes
ac50: 74 20 31 30 29 20 22 2f 22 20 28 76 65 63 74 6f t 10) "/" (vecto
ac60: 72 2d 72 65 66 20 74 65 73 74 20 31 33 29 29 29 r-ref test 13)))
ac70: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
ac80: 20 28 74 65 73 74 2d 69 74 65 6d 20 20 28 76 65 (test-item (ve
ac90: 63 74 6f 72 2d 72 65 66 20 74 65 73 74 20 31 31 ctor-ref test 11
aca0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
acb0: 20 20 28 74 65 73 74 2d 73 74 61 74 75 73 20 28 (test-status (
acc0: 76 65 63 74 6f 72 2d 72 65 66 20 74 65 73 74 20 vector-ref test
acd0: 34 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 4))).
ace0: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 68 61 (if (not (ha
acf0: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
ad00: 61 75 6c 74 20 72 65 73 68 20 74 65 73 74 2d 69 ault resh test-i
ad10: 74 65 6d 20 20 23 66 29 29 0a 20 20 20 20 20 20 tem #f)).
ad20: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 68 61 (ha
ad30: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 72 65 sh-table-set! re
ad40: 73 68 20 74 65 73 74 2d 69 74 65 6d 20 20 20 28 sh test-item (
ad50: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
ad60: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
ad70: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
ad80: 74 21 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 t! (hash-table-r
ad90: 65 66 2f 64 65 66 61 75 6c 74 20 72 65 73 68 20 ef/default resh
ada0: 74 65 73 74 2d 69 74 65 6d 20 20 23 66 29 20 74 test-item #f) t
adb0: 65 73 74 2d 6e 61 6d 65 20 28 6c 69 73 74 20 74 est-name (list t
adc0: 65 73 74 2d 73 74 61 74 75 73 20 74 65 73 74 2d est-status test-
add0: 68 74 6d 6c 2d 70 61 74 68 29 29 29 29 20 0a 20 html-path)))) .
ade0: 20 20 20 20 20 20 20 74 65 73 74 2d 64 61 74 61 test-data
adf0: 29 0a 72 65 73 68 29 29 0a 0a 28 64 65 66 69 6e ).resh))..(defin
ae00: 65 20 28 74 65 73 74 3a 67 65 74 2d 64 61 74 61 e (test:get-data
ae10: 2d 3e 62 2d 6b 65 79 73 20 6f 72 64 65 72 65 64 ->b-keys ordered
ae20: 2d 64 61 74 61 20 61 2d 6b 65 79 73 29 0a 20 20 -data a-keys).
ae30: 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 74 (delete-duplicat
ae40: 65 73 0a 20 20 20 28 73 6f 72 74 20 28 61 70 70 es. (sort (app
ae50: 6c 79 0a 09 20 20 61 70 70 65 6e 64 0a 09 20 20 ly.. append..
ae60: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 73 75 (map (lambda (su
ae70: 62 2d 6b 65 79 29 0a 09 09 20 28 6c 65 74 20 28 b-key)... (let (
ae80: 28 73 75 62 64 61 74 20 28 68 61 73 68 2d 74 61 (subdat (hash-ta
ae90: 62 6c 65 2d 72 65 66 20 6f 72 64 65 72 65 64 2d ble-ref ordered-
aea0: 64 61 74 61 20 73 75 62 2d 6b 65 79 29 29 29 0a data sub-key))).
aeb0: 09 09 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 .. (hash-table
aec0: 2d 6b 65 79 73 20 73 75 62 64 61 74 29 29 29 0a -keys subdat))).
aed0: 09 20 20 20 20 20 20 20 61 2d 6b 65 79 73 29 29 . a-keys))
aee0: 0a 09 20 73 74 72 69 6e 67 3e 3d 3f 29 29 29 0a .. string>=?))).
aef0: 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 3a ..(define (test:
af00: 63 72 65 61 74 65 2d 72 75 6e 2d 68 74 6d 6c 20 create-run-html
af10: 72 75 6e 73 20 61 72 65 61 2d 6e 61 6d 65 20 6c runs area-name l
af20: 69 6e 6b 74 72 65 65 20 6e 75 6d 6b 65 79 73 20 inktree numkeys
af30: 68 65 61 64 65 72 29 0a 20 20 28 6d 61 70 20 28 header). (map (
af40: 6c 61 6d 62 64 61 20 28 72 75 6e 29 0a 09 09 20 lambda (run)...
af50: 28 6c 65 74 2a 20 28 28 74 61 72 67 65 74 20 28 (let* ((target (
af60: 73 74 72 69 6e 67 2d 6a 6f 69 6e 20 28 74 61 6b string-join (tak
af70: 65 20 28 76 65 63 74 6f 72 2d 3e 6c 69 73 74 20 e (vector->list
af80: 72 75 6e 29 20 6e 75 6d 6b 65 79 73 29 20 22 2f run) numkeys) "/
af90: 22 29 29 0a 09 09 09 09 09 09 28 72 75 6e 2d 6e ")).......(run-n
afa0: 61 6d 65 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 ame (db:get-valu
afb0: 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 e-by-header run
afc0: 68 65 61 64 65 72 20 22 72 75 6e 6e 61 6d 65 22 header "runname"
afd0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 )). (
afe0: 72 75 6e 2d 74 69 6d 65 20 28 73 65 63 6f 6e 64 run-time (second
aff0: 73 2d 3e 77 6f 72 6b 2d 77 65 65 6b 2f 64 61 79 s->work-week/day
b000: 2d 74 69 6d 65 20 28 64 62 3a 67 65 74 2d 76 61 -time (db:get-va
b010: 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 lue-by-header ru
b020: 6e 20 68 65 61 64 65 72 20 22 65 76 65 6e 74 5f n header "event_
b030: 74 69 6d 65 22 29 29 29 0a 09 09 09 09 09 09 28 time"))).......(
b040: 6f 75 70 20 28 69 66 20 28 66 69 6c 65 2d 65 78 oup (if (file-ex
b050: 69 73 74 73 3f 20 28 63 6f 6e 63 20 6c 69 6e 6b ists? (conc link
b060: 74 72 65 65 20 22 2f 22 20 74 61 72 67 65 74 20 tree "/" target
b070: 22 2f 22 20 72 75 6e 2d 6e 61 6d 65 29 29 0a 20 "/" run-name)).
b080: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b090: 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 6f 75 74 (open-out
b0a0: 70 75 74 2d 66 69 6c 65 20 28 63 6f 6e 63 20 6c put-file (conc l
b0b0: 69 6e 6b 74 72 65 65 20 22 2f 22 20 74 61 72 67 inktree "/" targ
b0c0: 65 74 20 22 2f 22 20 72 75 6e 2d 6e 61 6d 65 20 et "/" run-name
b0d0: 22 2f 72 75 6e 2e 68 74 6d 6c 22 29 29 0a 20 20 "/run.html")).
b0e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b0f0: 20 20 20 20 20 20 20 23 66 29 29 0a 20 20 20 20 #f)).
b100: 20 20 20 20 20 20 20 20 28 72 75 6e 2d 69 64 20 (run-id
b110: 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 (db:get-value-by
b120: 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 -header run head
b130: 65 72 20 22 69 64 22 29 29 0a 20 20 20 20 20 20 er "id")).
b140: 20 20 20 20 20 20 28 74 65 73 74 2d 64 61 74 61 (test-data
b150: 20 20 20 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 (rmt:get-tes
b160: 74 73 2d 66 6f 72 2d 72 75 6e 0a 09 09 09 09 20 ts-for-run.....
b170: 20 09 09 09 09 09 09 09 09 20 72 75 6e 2d 69 64 ........ run-id
b180: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
b190: 20 20 20 20 20 20 20 20 20 20 20 20 22 25 22 20 "%"
b1a0: 20 20 20 20 20 20 3b 3b 20 74 65 73 74 6e 61 6d ;; testnam
b1b0: 65 70 61 74 74 0a 09 09 09 09 20 20 09 09 09 09 epatt..... ....
b1c0: 09 09 09 09 20 27 28 29 20 20 20 20 20 20 20 20 .... '()
b1d0: 3b 3b 20 73 74 61 74 65 73 0a 09 09 09 09 20 20 ;; states.....
b1e0: 20 09 09 09 09 09 09 09 09 20 27 28 29 20 20 20 ........ '()
b1f0: 20 20 20 20 20 3b 3b 20 73 74 61 74 75 73 65 73 ;; statuses
b200: 0a 09 09 09 09 20 20 09 09 09 09 09 09 09 09 20 ..... ........
b210: 09 23 66 20 20 20 20 20 20 20 20 20 3b 3b 20 6f .#f ;; o
b220: 66 66 73 65 74 0a 09 09 09 09 20 20 09 09 09 09 ffset..... ....
b230: 09 09 20 09 09 09 23 66 20 20 20 20 20 20 20 20 .. ...#f
b240: 20 3b 3b 20 6e 75 6d 2d 74 6f 2d 67 65 74 0a 09 ;; num-to-get..
b250: 09 09 09 20 20 20 09 09 09 09 09 09 09 09 09 23 ... .........#
b260: 66 20 20 20 20 20 20 20 20 20 3b 3b 20 68 69 64 f ;; hid
b270: 65 2f 6e 6f 74 2d 68 69 64 65 0a 09 09 09 09 20 e/not-hide.....
b280: 20 09 09 09 09 09 09 09 09 20 20 23 66 20 20 20 ........ #f
b290: 20 20 20 20 20 20 3b 3b 20 73 6f 72 74 2d 62 79 ;; sort-by
b2a0: 0a 09 09 09 09 20 20 20 09 09 09 09 09 09 09 09 ..... ........
b2b0: 09 23 66 20 20 20 20 20 20 20 20 20 3b 3b 20 73 .#f ;; s
b2c0: 6f 72 74 2d 6f 72 64 65 72 0a 09 09 09 09 20 20 ort-order.....
b2d0: 20 09 09 09 09 09 09 09 09 09 23 66 20 20 20 20 .........#f
b2e0: 20 20 20 20 20 3b 3b 20 27 73 68 6f 72 74 6c 69 ;; 'shortli
b2f0: 73 74 20 20 20 20 20 20 20 20 20 20 20 20 20 20 st
b300: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ;;
b310: 71 72 79 74 79 70 65 0a 20 20 20 20 20 20 20 20 qrytype.
b320: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b330: 20 20 20 20 30 20 20 20 20 20 20 20 20 20 3b 3b 0 ;;
b340: 20 6c 61 73 74 20 75 70 64 61 74 65 0a 09 09 09 last update....
b350: 09 20 20 09 09 09 09 09 09 09 09 09 23 66 29 29 . .........#f))
b360: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 69 74 . (it
b370: 65 6d 2d 74 65 73 74 2d 68 61 73 68 20 28 74 65 em-test-hash (te
b380: 73 74 3a 67 65 74 2d 74 65 73 74 2d 68 61 73 68 st:get-test-hash
b390: 20 74 65 73 74 2d 64 61 74 61 29 29 0a 20 20 20 test-data)).
b3a0: 20 20 20 20 20 20 20 20 20 28 69 74 65 6d 73 20 (items
b3b0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 (hash-table-key
b3c0: 73 20 69 74 65 6d 2d 74 65 73 74 2d 68 61 73 68 s item-test-hash
b3d0: 29 29 0a 20 09 09 09 09 09 09 28 74 65 73 74 2d )). ......(test-
b3e0: 6e 61 6d 65 73 20 28 74 65 73 74 3a 67 65 74 2d names (test:get-
b3f0: 64 61 74 61 2d 3e 62 2d 6b 65 79 73 20 69 74 65 data->b-keys ite
b400: 6d 2d 74 65 73 74 2d 68 61 73 68 20 69 74 65 6d m-test-hash item
b410: 73 29 29 29 0a 20 20 20 20 28 69 66 20 6f 75 70 s))). (if oup
b420: 0a 20 20 20 20 20 20 28 62 65 67 69 6e 20 0a 20 . (begin .
b430: 20 20 20 20 28 73 3a 6f 75 74 70 75 74 2d 6e 65 (s:output-ne
b440: 77 0a 09 20 20 20 6f 75 70 0a 09 20 20 20 28 73 w.. oup.. (s
b450: 3a 68 74 6d 6c 20 74 65 73 74 73 3a 63 73 73 2d :html tests:css-
b460: 6a 73 63 72 69 70 74 2d 62 6c 6f 63 6b 20 28 74 jscript-block (t
b470: 65 73 74 73 3a 63 73 73 2d 6a 73 63 72 69 70 74 ests:css-jscript
b480: 2d 62 6c 6f 63 6b 2d 63 6f 6e 64 20 23 66 29 0a -block-cond #f).
b490: 09 09 20 20 20 28 73 3a 74 69 74 6c 65 20 22 52 .. (s:title "R
b4a0: 75 6e 73 20 56 69 65 77 20 22 20 72 75 6e 2d 6e uns View " run-n
b4b0: 61 6d 65 29 0a 09 09 20 20 20 28 73 3a 62 6f 64 ame)... (s:bod
b4c0: 79 0a 09 09 20 20 20 20 20 28 73 3a 68 31 20 22 y... (s:h1 "
b4d0: 52 75 6e 73 20 56 69 65 77 20 22 20 29 0a 20 20 Runs View " ).
b4e0: 20 20 20 20 20 20 20 28 73 3a 68 33 20 22 54 61 (s:h3 "Ta
b4f0: 72 67 65 74 22 20 74 61 72 67 65 74 29 0a 09 09 rget" target)...
b500: 09 09 20 28 73 3a 70 20 0a 09 09 09 09 09 28 73 .. (s:p ......(s
b510: 3a 62 20 22 52 75 6e 20 6e 61 6d 65 22 20 29 20 :b "Run name" )
b520: 72 75 6e 2d 6e 61 6d 65 29 0a 20 20 20 20 20 20 run-name).
b530: 20 20 20 28 73 3a 70 20 0a 09 09 09 09 09 28 73 (s:p ......(s
b540: 3a 62 20 22 52 75 6e 20 44 61 74 65 22 20 29 20 :b "Run Date" )
b550: 72 75 6e 2d 74 69 6d 65 29 0a 20 20 20 20 20 20 run-time).
b560: 20 20 20 28 73 3a 74 61 62 6c 65 20 27 62 6f 72 (s:table 'bor
b570: 64 65 72 20 31 20 27 63 65 6c 6c 73 70 61 63 69 der 1 'cellspaci
b580: 6e 67 20 30 0a 20 20 20 20 20 20 20 20 20 20 20 ng 0.
b590: 28 73 3a 74 72 0a 20 20 20 20 20 20 20 20 20 20 (s:tr.
b5a0: 20 28 73 3a 74 68 20 22 49 74 65 6d 73 22 29 0a (s:th "Items").
b5b0: 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 70 20 (map
b5c0: 28 6c 61 6d 62 64 61 20 28 74 65 73 74 29 0a 20 (lambda (test).
b5d0: 20 20 20 20 20 20 20 20 20 20 20 28 73 3a 74 68 (s:th
b5e0: 20 74 65 73 74 29 29 0a 20 20 20 20 20 20 20 20 test)).
b5f0: 20 20 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 20 test-names))
b600: 20 0a 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 . (ma
b610: 70 20 28 6c 61 6d 62 64 61 20 28 69 74 65 6d 29 p (lambda (item)
b620: 20 0a 09 09 09 09 09 20 20 28 6c 65 74 2a 20 28 ...... (let* (
b630: 28 74 65 73 74 2d 68 61 73 68 20 28 68 61 73 68 (test-hash (hash
b640: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
b650: 6c 74 20 69 74 65 6d 2d 74 65 73 74 2d 68 61 73 lt item-test-has
b660: 68 20 69 74 65 6d 20 20 23 66 29 29 29 0a 09 09 h item #f)))...
b670: 09 09 09 09 09 09 20 28 69 66 20 74 65 73 74 2d ...... (if test-
b680: 68 61 73 68 0a 20 20 20 20 20 20 20 20 20 20 20 hash.
b690: 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 (begin...
b6a0: 09 09 09 09 09 09 09 28 73 3a 74 72 0a 09 09 09 .......(s:tr....
b6b0: 09 09 20 20 09 09 09 28 73 3a 74 64 20 27 63 6c .. ...(s:td 'cl
b6c0: 61 73 73 20 22 74 65 73 74 22 20 69 74 65 6d 29 ass "test" item)
b6d0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 09 09 09 . ...
b6e0: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 74 65 (map (lambda (te
b6f0: 73 74 29 0a 09 09 09 09 09 09 20 20 09 09 28 6c st)....... ..(l
b700: 65 74 2a 20 28 28 74 65 73 74 2d 64 65 74 61 69 et* ((test-detai
b710: 6c 73 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 ls (hash-table-r
b720: 65 66 2f 64 65 66 61 75 6c 74 20 74 65 73 74 2d ef/default test-
b730: 68 61 73 68 20 74 65 73 74 20 20 23 66 29 29 0a hash test #f)).
b740: 09 09 09 09 09 09 09 09 09 09 09 09 28 73 74 61 ............(sta
b750: 74 75 73 20 28 69 66 20 74 65 73 74 2d 64 65 74 tus (if test-det
b760: 61 69 6c 73 0a 09 09 09 09 09 09 09 09 09 09 09 ails............
b770: 09 09 09 09 09 28 63 61 72 20 74 65 73 74 2d 64 .....(car test-d
b780: 65 74 61 69 6c 73 29 29 29 0a 20 20 20 20 20 20 etails))).
b790: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b7a0: 20 20 28 6c 69 6e 6b 20 28 69 66 20 74 65 73 74 (link (if test
b7b0: 2d 64 65 74 61 69 6c 73 20 0a 09 09 09 09 09 09 -details .......
b7c0: 09 09 09 09 09 09 09 09 28 73 74 72 69 6e 67 2d ........(string-
b7d0: 73 75 62 73 74 69 74 75 74 65 20 20 28 63 6f 6e substitute (con
b7e0: 63 20 6c 69 6e 6b 74 72 65 65 20 22 2f 22 20 74 c linktree "/" t
b7f0: 61 72 67 65 74 20 22 2f 22 20 72 75 6e 2d 6e 61 arget "/" run-na
b800: 6d 65 20 22 2f 22 29 20 20 22 22 20 28 63 61 64 me "/") "" (cad
b810: 72 20 74 65 73 74 2d 64 65 74 61 69 6c 73 29 20 r test-details)
b820: 22 2d 22 29 29 29 29 0a 20 20 20 20 20 20 20 20 "-")))).
b830: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 74 (if t
b840: 65 73 74 2d 64 65 74 61 69 6c 73 0a 09 09 09 09 est-details.....
b850: 09 09 09 09 09 09 09 28 73 3a 74 64 20 27 63 6c .......(s:td 'cl
b860: 61 73 73 20 73 74 61 74 75 73 0a 09 09 09 09 09 ass status......
b870: 09 09 09 09 09 09 09 28 73 3a 61 20 27 63 6c 61 .......(s:a 'cla
b880: 73 73 20 22 6c 69 6e 6b 22 20 27 68 72 65 66 20 ss "link" 'href
b890: 6c 69 6e 6b 20 73 74 61 74 75 73 20 29 29 0a 20 link status )).
b8a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b8b0: 20 20 20 20 20 28 73 3a 74 64 20 22 22 29 29 29 (s:td "")))
b8c0: 29 20 09 09 09 0a 09 09 09 09 09 09 09 09 09 74 ) .............t
b8d0: 65 73 74 2d 6e 61 6d 65 73 29 29 29 29 29 29 0a est-names)))))).
b8e0: 09 09 09 09 20 20 28 73 6f 72 74 20 69 74 65 6d .... (sort item
b8f0: 73 20 73 74 72 69 6e 67 3c 3d 3f 29 29 29 29 29 s string<=?)))))
b900: 29 0a 09 09 28 63 6c 6f 73 65 2d 6f 75 74 70 75 )...(close-outpu
b910: 74 2d 70 6f 72 74 20 6f 75 70 29 29 0a 20 20 20 t-port oup)).
b920: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
b930: 66 6f 20 30 20 22 53 6b 69 70 3a 20 44 69 72 63 fo 0 "Skip: Dirc
b940: 74 6f 72 79 20 73 74 72 75 63 74 75 72 65 20 22 tory structure "
b950: 20 6c 69 6e 6b 74 72 65 65 20 22 2f 22 20 74 61 linktree "/" ta
b960: 72 67 65 74 20 22 2f 22 20 72 75 6e 2d 6e 61 6d rget "/" run-nam
b970: 65 20 22 20 64 6f 65 73 20 6e 6f 74 20 65 78 69 e " does not exi
b980: 73 74 2e 20 4d 65 67 61 74 65 73 74 20 77 69 6c st. Megatest wil
b990: 6c 20 6e 6f 74 20 63 72 65 61 74 65 20 72 75 6e l not create run
b9a0: 2e 68 74 6d 6c 22 29 29 29 29 0a 72 75 6e 73 29 .html")))).runs)
b9b0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 )..(define (test
b9c0: 3a 63 72 65 61 74 65 2d 74 61 72 67 65 74 2d 68 :create-target-h
b9d0: 61 73 68 20 72 75 6e 73 20 68 65 61 64 65 72 20 ash runs header
b9e0: 6e 75 6d 6b 65 79 73 29 0a 20 20 28 6c 65 74 20 numkeys). (let
b9f0: 28 28 72 65 73 68 20 28 6d 61 6b 65 2d 68 61 73 ((resh (make-has
ba00: 68 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 28 66 h-table))). (f
ba10: 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 6c 61 or-each. (la
ba20: 6d 62 64 61 20 28 72 75 6e 29 0a 20 20 20 20 20 mbda (run).
ba30: 20 20 20 28 6c 65 74 2a 20 28 28 72 75 6e 2d 6e (let* ((run-n
ba40: 61 6d 65 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 ame (db:get-valu
ba50: 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 e-by-header run
ba60: 68 65 61 64 65 72 20 22 72 75 6e 6e 61 6d 65 22 header "runname"
ba70: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
ba80: 20 20 28 74 61 72 67 65 74 20 20 20 28 73 74 72 (target (str
ba90: 69 6e 67 2d 6a 6f 69 6e 20 28 74 61 6b 65 20 28 ing-join (take (
baa0: 76 65 63 74 6f 72 2d 3e 6c 69 73 74 20 72 75 6e vector->list run
bab0: 29 20 6e 75 6d 6b 65 79 73 29 20 22 2f 22 29 29 ) numkeys) "/"))
bac0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
bad0: 28 72 75 6e 2d 6c 69 73 74 20 28 68 61 73 68 2d (run-list (hash-
bae0: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
baf0: 74 20 72 65 73 68 20 74 61 72 67 65 74 20 20 23 t resh target #
bb00: 66 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 f))).
bb10: 20 20 20 20 0a 20 20 20 20 20 20 20 20 20 20 20 .
bb20: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 72 75 6e (if (not run
bb30: 2d 6c 69 73 74 29 0a 20 20 20 20 20 20 20 20 20 -list).
bb40: 20 20 20 20 20 20 20 20 20 20 28 68 61 73 68 2d (hash-
bb50: 74 61 62 6c 65 2d 73 65 74 21 20 72 65 73 68 20 table-set! resh
bb60: 74 61 72 67 65 74 20 20 20 28 6c 69 73 74 20 72 target (list r
bb70: 75 6e 2d 6e 61 6d 65 29 29 0a 20 20 20 20 20 20 un-name)).
bb80: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 68 61 (ha
bb90: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 72 65 sh-table-set! re
bba0: 73 68 20 74 61 72 67 65 74 20 20 20 28 63 6f 6e sh target (con
bbb0: 73 20 72 75 6e 2d 6e 61 6d 65 20 72 75 6e 2d 6c s run-name run-l
bbc0: 69 73 74 29 29 29 29 29 0a 20 20 20 20 20 20 72 ist))))). r
bbd0: 75 6e 73 29 0a 20 20 20 72 65 73 68 29 29 0a 0a uns). resh))..
bbe0: 28 64 65 66 69 6e 65 20 28 74 65 73 74 3a 67 65 (define (test:ge
bbf0: 74 2d 6d 61 78 2d 72 75 6e 2d 63 6e 74 20 74 61 t-max-run-cnt ta
bc00: 72 67 65 74 2d 68 61 73 68 20 74 61 72 67 65 74 rget-hash target
bc10: 73 29 0a 20 20 20 28 6c 65 74 2a 20 28 28 63 6e s). (let* ((cn
bc20: 74 20 30 20 29 29 0a 20 20 20 28 6d 61 70 20 28 t 0 )). (map (
bc30: 6c 61 6d 62 64 61 20 28 74 61 72 67 65 74 29 0a lambda (target).
bc40: 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 (let* ((
bc50: 72 75 6e 73 20 20 28 68 61 73 68 2d 74 61 62 6c runs (hash-tabl
bc60: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 61 e-ref/default ta
bc70: 72 67 65 74 2d 68 61 73 68 20 74 61 72 67 65 74 rget-hash target
bc80: 20 20 23 66 29 29 0a 20 20 20 20 20 20 20 20 20 #f)).
bc90: 20 20 20 20 20 20 28 72 75 6e 2d 6c 65 6e 67 74 (run-lengt
bca0: 68 20 28 69 66 20 72 75 6e 73 0a 09 09 09 09 09 h (if runs......
bcb0: 09 09 09 09 09 09 09 09 09 09 09 28 6c 65 6e 67 ...........(leng
bcc0: 74 68 20 72 75 6e 73 29 0a 20 20 20 20 20 20 20 th runs).
bcd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bce0: 20 20 20 20 20 20 20 20 20 20 30 29 29 29 0a 20 0))).
bcf0: 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
bd00: 28 69 66 20 28 3c 20 63 6e 74 20 72 75 6e 2d 6c (if (< cnt run-l
bd10: 65 6e 67 74 68 29 0a 20 20 20 20 20 20 20 20 20 ength).
bd20: 20 20 20 20 20 20 28 73 65 74 21 20 63 6e 74 20 (set! cnt
bd30: 20 72 75 6e 2d 6c 65 6e 67 74 68 29 29 29 29 20 run-length))))
bd40: 0a 09 09 74 61 72 67 65 74 73 29 20 0a 63 6e 74 ...targets) .cnt
bd50: 29 29 0a 20 0a 28 64 65 66 69 6e 65 20 28 74 65 )). .(define (te
bd60: 73 74 3a 70 61 64 2d 72 75 6e 73 20 74 61 72 67 st:pad-runs targ
bd70: 65 74 2d 68 61 73 68 20 74 61 72 67 65 74 73 20 et-hash targets
bd80: 6d 61 78 2d 72 6f 77 2d 6c 65 6e 67 74 68 29 0a max-row-length).
bd90: 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 74 (map (lambda (t
bda0: 61 72 67 65 74 29 0a 20 20 20 20 20 20 20 20 28 arget). (
bdb0: 6c 65 74 20 6c 6f 6f 70 20 28 28 72 75 6e 2d 6c let loop ((run-l
bdc0: 69 73 74 20 20 28 68 61 73 68 2d 74 61 62 6c 65 ist (hash-table
bdd0: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 61 72 -ref/default tar
bde0: 67 65 74 2d 68 61 73 68 20 74 61 72 67 65 74 20 get-hash target
bdf0: 20 23 66 29 29 29 0a 20 20 20 20 20 20 20 20 20 #f))).
be00: 20 20 20 20 20 20 28 69 66 20 28 3c 20 28 6c 65 (if (< (le
be10: 6e 67 74 68 20 72 75 6e 2d 6c 69 73 74 29 20 6d ngth run-list) m
be20: 61 78 2d 72 6f 77 2d 6c 65 6e 67 74 68 29 0a 20 ax-row-length).
be30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
be40: 28 62 65 67 69 6e 20 20 0a 20 20 20 20 20 20 20 (begin .
be50: 20 20 20 20 20 20 20 20 09 09 20 28 68 61 73 68 .. (hash
be60: 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 61 72 67 -table-set! targ
be70: 65 74 2d 68 61 73 68 20 74 61 72 67 65 74 20 20 et-hash target
be80: 20 28 63 6f 6e 73 20 22 22 20 72 75 6e 2d 6c 69 (cons "" run-li
be90: 73 74 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 st)).
bea0: 20 20 20 20 09 09 20 28 6c 6f 6f 70 20 28 68 61 .. (loop (ha
beb0: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
bec0: 61 75 6c 74 20 74 61 72 67 65 74 2d 68 61 73 68 ault target-hash
bed0: 20 74 61 72 67 65 74 20 20 23 66 29 20 29 29 29 target #f) )))
bee0: 29 29 20 0a 09 09 74 61 72 67 65 74 73 29 0a 20 )) ...targets).
bef0: 20 20 74 61 72 67 65 74 2d 68 61 73 68 29 0a 0a target-hash)..
bf00: 28 64 65 66 69 6e 65 20 28 74 65 73 74 3a 63 72 (define (test:cr
bf10: 65 61 74 65 2d 74 61 72 67 65 74 2d 68 74 6d 6c eate-target-html
bf20: 20 74 61 72 67 65 74 2d 68 61 73 68 20 6f 75 70 target-hash oup
bf30: 20 61 72 65 61 2d 6e 61 6d 65 20 6c 69 6e 6b 74 area-name linkt
bf40: 72 65 65 29 0a 20 20 28 6c 65 74 2a 20 28 28 74 ree). (let* ((t
bf50: 61 72 67 65 74 73 20 28 68 61 73 68 2d 74 61 62 argets (hash-tab
bf60: 6c 65 2d 6b 65 79 73 20 74 61 72 67 65 74 2d 68 le-keys target-h
bf70: 61 73 68 29 29 0a 20 20 20 20 20 20 20 20 20 28 ash)). (
bf80: 6d 61 78 2d 72 6f 77 2d 6c 65 6e 67 74 68 20 28 max-row-length (
bf90: 74 65 73 74 3a 67 65 74 2d 6d 61 78 2d 72 75 6e test:get-max-run
bfa0: 2d 63 6e 74 20 74 61 72 67 65 74 2d 68 61 73 68 -cnt target-hash
bfb0: 20 74 61 72 67 65 74 73 29 29 0a 20 20 20 20 20 targets)).
bfc0: 20 20 20 20 28 70 61 64 2d 72 75 6e 73 2d 68 61 (pad-runs-ha
bfd0: 73 68 20 28 74 65 73 74 3a 70 61 64 2d 72 75 6e sh (test:pad-run
bfe0: 73 20 74 61 72 67 65 74 2d 68 61 73 68 20 74 61 s target-hash ta
bff0: 72 67 65 74 73 20 6d 61 78 2d 72 6f 77 2d 6c 65 rgets max-row-le
c000: 6e 67 74 68 29 29 29 0a 20 20 20 28 73 3a 6f 75 ngth))). (s:ou
c010: 74 70 75 74 2d 6e 65 77 0a 09 20 20 20 6f 75 70 tput-new.. oup
c020: 0a 09 20 20 20 28 73 3a 68 74 6d 6c 20 74 65 73 .. (s:html tes
c030: 74 73 3a 63 73 73 2d 6a 73 63 72 69 70 74 2d 62 ts:css-jscript-b
c040: 6c 6f 63 6b 20 28 74 65 73 74 73 3a 63 73 73 2d lock (tests:css-
c050: 6a 73 63 72 69 70 74 2d 62 6c 6f 63 6b 2d 63 6f jscript-block-co
c060: 6e 64 20 23 66 29 0a 0a 09 09 20 20 20 28 73 3a nd #f).... (s:
c070: 74 69 74 6c 65 20 22 54 61 72 67 65 74 20 56 69 title "Target Vi
c080: 65 77 20 22 20 61 72 65 61 2d 6e 61 6d 65 29 0a ew " area-name).
c090: 09 09 20 20 20 28 73 3a 62 6f 64 79 0a 09 09 20 .. (s:body...
c0a0: 20 20 28 73 3a 68 31 20 22 54 61 72 67 65 74 20 (s:h1 "Target
c0b0: 56 69 65 77 20 22 20 61 72 65 61 2d 6e 61 6d 65 View " area-name
c0c0: 29 0a 09 09 09 09 09 28 73 3a 74 61 62 6c 65 20 )......(s:table
c0d0: 27 69 64 20 22 4c 69 6e 6b 65 64 4c 69 73 74 31 'id "LinkedList1
c0e0: 22 20 27 62 6f 72 64 65 72 20 22 31 22 20 27 63 " 'border "1" 'c
c0f0: 65 6c 6c 73 70 61 63 69 6e 67 20 30 0a 20 20 20 ellspacing 0.
c100: 20 20 20 20 20 20 20 20 20 20 28 73 3a 74 72 20 (s:tr
c110: 27 63 6c 61 73 73 20 22 73 6f 6d 65 74 68 69 6e 'class "somethin
c120: 67 22 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 g" .
c130: 20 20 20 28 73 3a 74 68 20 22 54 61 72 67 65 74 (s:th "Target
c140: 22 29 0a 09 09 09 09 09 09 09 09 28 73 3a 74 68 ").........(s:th
c150: 20 27 63 6f 6c 73 70 61 6e 20 6d 61 78 2d 72 6f 'colspan max-ro
c160: 77 2d 6c 65 6e 67 74 68 20 22 52 75 6e 73 22 29 w-length "Runs")
c170: 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 )
c180: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c190: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0a .
c1a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c1b0: 28 6c 65 74 2a 20 28 28 74 62 6c 20 28 6d 61 70 (let* ((tbl (map
c1c0: 20 28 6c 61 6d 62 64 61 20 28 74 61 72 67 65 74 (lambda (target
c1d0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
c1e0: 20 20 20 20 20 20 20 20 28 73 3a 74 72 0a 20 20 (s:tr.
c1f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c200: 20 20 20 20 28 73 3a 74 64 20 27 63 6c 61 73 73 (s:td 'class
c210: 20 22 74 65 73 74 22 20 74 61 72 67 65 74 29 0a "test" target).
c220: 09 09 09 09 09 09 09 09 09 09 20 20 28 6c 65 74 .......... (let
c230: 2a 20 28 28 72 75 6e 73 20 20 28 68 61 73 68 2d * ((runs (hash-
c240: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
c250: 74 20 74 61 72 67 65 74 2d 68 61 73 68 20 74 61 t target-hash ta
c260: 72 67 65 74 20 20 23 66 29 29 0a 09 09 09 09 09 rget #f))......
c270: 09 09 09 09 09 09 09 09 09 20 28 72 65 73 74 2d ......... (rest-
c280: 72 6f 77 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 row (map (lambda
c290: 20 28 72 75 6e 29 0a 09 09 09 09 09 09 09 09 09 (run)..........
c2a0: 09 09 09 09 09 09 09 09 09 09 09 28 69 66 20 28 ...........(if (
c2b0: 65 71 75 61 6c 3f 20 72 75 6e 20 22 22 29 0a 09 equal? run "")..
c2c0: 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 ................
c2d0: 09 09 09 09 09 28 73 3a 74 64 20 72 75 6e 29 0a .....(s:td run).
c2e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c2f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c300: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
c310: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 28 63 6f (file-exists?(co
c320: 6e 63 20 6c 69 6e 6b 74 72 65 65 20 22 2f 22 20 nc linktree "/"
c330: 74 61 72 67 65 74 20 22 2f 22 20 72 75 6e 20 29 target "/" run )
c340: 29 0a 09 09 09 09 09 09 09 09 09 09 09 09 09 09 )...............
c350: 09 09 09 09 09 09 09 09 28 62 65 67 69 6e 20 0a ........(begin .
c360: 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 ................
c370: 09 09 09 09 09 09 09 28 73 3a 74 64 20 0a 09 09 .......(s:td ...
c380: 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 ................
c390: 09 09 09 09 09 28 73 3a 61 20 27 68 72 65 66 20 .....(s:a 'href
c3a0: 28 63 6f 6e 63 20 20 74 61 72 67 65 74 20 22 2f (conc target "/
c3b0: 22 20 72 75 6e 20 22 2f 72 75 6e 2e 68 74 6d 6c " run "/run.html
c3c0: 22 29 20 72 75 6e 29 29 29 29 29 29 0a 09 09 09 ") run))))))....
c3d0: 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 ................
c3e0: 09 28 72 65 76 65 72 73 65 20 72 75 6e 73 29 29 .(reverse runs))
c3f0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
c400: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c410: 20 72 65 73 74 2d 72 6f 77 29 29 29 0a 20 20 20 rest-row))).
c420: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c430: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c440: 74 61 72 67 65 74 73 29 29 29 0a 20 20 20 20 20 targets))).
c450: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c460: 20 20 20 20 20 20 74 62 6c 29 29 29 29 29 0a 20 tbl))))).
c470: 20 20 20 20 20 20 20 20 20 28 63 6c 6f 73 65 2d (close-
c480: 6f 75 74 70 75 74 2d 70 6f 72 74 20 6f 75 70 29 output-port oup)
c490: 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 ))...(define (te
c4a0: 73 74 73 3a 63 72 65 61 74 65 2d 68 74 6d 6c 2d sts:create-html-
c4b0: 74 72 65 65 2d 6f 6c 64 20 6f 75 74 66 29 0a 20 tree-old outf).
c4c0: 20 20 28 6c 65 74 2a 20 28 28 6c 6f 63 6b 66 69 (let* ((lockfi
c4d0: 6c 65 20 20 28 63 6f 6e 63 20 6f 75 74 66 20 22 le (conc outf "
c4e0: 2e 6c 6f 63 6b 22 29 29 0a 09 20 28 72 75 6e 73 .lock")).. (runs
c4f0: 2d 74 6f 2d 70 72 6f 63 65 73 73 20 27 28 29 29 -to-process '())
c500: 29 0a 20 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f ). (if (commo
c510: 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f n:simple-file-lo
c520: 63 6b 20 6c 6f 63 6b 66 69 6c 65 29 0a 09 28 6c ck lockfile)..(l
c530: 65 74 2a 20 28 28 6c 69 6e 6b 74 72 65 65 20 20 et* ((linktree
c540: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 69 6e 6b (common:get-link
c550: 74 72 65 65 29 29 0a 09 20 20 20 20 20 20 20 28 tree)).. (
c560: 6f 75 70 20 20 20 20 20 20 20 28 6f 70 65 6e 2d oup (open-
c570: 6f 75 74 70 75 74 2d 66 69 6c 65 20 28 6f 72 20 output-file (or
c580: 6f 75 74 66 20 28 63 6f 6e 63 20 6c 69 6e 6b 74 outf (conc linkt
c590: 72 65 65 20 22 2f 72 75 6e 73 2d 69 6e 64 65 78 ree "/runs-index
c5a0: 2e 68 74 6d 6c 22 29 29 29 29 0a 09 20 20 20 20 .html"))))..
c5b0: 20 20 20 28 61 72 65 61 2d 6e 61 6d 65 20 28 63 (area-name (c
c5c0: 6f 6d 6d 6f 6e 3a 67 65 74 2d 74 65 73 74 73 75 ommon:get-testsu
c5d0: 69 74 65 2d 6e 61 6d 65 29 29 0a 09 20 20 20 20 ite-name))..
c5e0: 20 20 20 28 6b 65 79 73 20 20 20 20 20 20 28 72 (keys (r
c5f0: 6d 74 3a 67 65 74 2d 6b 65 79 73 29 29 0a 09 20 mt:get-keys))..
c600: 20 20 20 20 20 20 28 6e 75 6d 6b 65 79 73 20 20 (numkeys
c610: 20 28 6c 65 6e 67 74 68 20 6b 65 79 73 29 29 0a (length keys)).
c620: 09 20 20 20 20 20 20 20 28 72 75 6e 73 64 61 74 . (runsdat
c630: 20 20 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e 73 (rmt:get-runs
c640: 20 22 25 22 20 23 66 20 23 66 20 28 6d 61 70 20 "%" #f #f (map
c650: 28 6c 61 6d 62 64 61 20 28 78 29 28 6c 69 73 74 (lambda (x)(list
c660: 20 78 20 22 25 22 29 29 20 6b 65 79 73 29 29 29 x "%")) keys)))
c670: 0a 09 20 20 20 20 20 20 20 28 68 65 61 64 65 72 .. (header
c680: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
c690: 72 75 6e 73 64 61 74 20 30 29 29 0a 09 20 20 20 runsdat 0))..
c6a0: 20 20 20 20 28 72 75 6e 73 20 20 20 20 20 20 28 (runs (
c6b0: 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 73 64 vector-ref runsd
c6c0: 61 74 20 31 29 29 0a 09 20 20 20 20 20 20 20 28 at 1)).. (
c6d0: 72 75 6e 74 72 65 65 64 61 74 20 28 6d 61 70 20 runtreedat (map
c6e0: 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 09 09 09 (lambda (x).....
c6f0: 20 20 28 74 65 73 74 73 3a 72 75 6e 2d 72 65 63 (tests:run-rec
c700: 6f 72 64 2d 3e 74 65 73 74 2d 70 61 74 68 20 78 ord->test-path x
c710: 20 6e 75 6d 6b 65 79 73 29 29 0a 09 09 09 09 72 numkeys)).....r
c720: 75 6e 73 29 29 0a 09 20 20 20 20 20 20 20 28 72 uns)).. (r
c730: 75 6e 73 2d 68 74 72 65 65 20 28 63 6f 6d 6d 6f uns-htree (commo
c740: 6e 3a 6c 69 73 74 2d 3e 68 74 72 65 65 20 72 75 n:list->htree ru
c750: 6e 74 72 65 65 64 61 74 29 29 29 0a 09 20 20 28 ntreedat))).. (
c760: 73 65 74 21 20 72 75 6e 73 2d 74 6f 2d 70 72 6f set! runs-to-pro
c770: 63 65 73 73 20 72 75 6e 73 29 0a 09 20 20 28 73 cess runs).. (s
c780: 3a 6f 75 74 70 75 74 2d 6e 65 77 0a 09 20 20 20 :output-new..
c790: 6f 75 70 0a 09 20 20 20 28 73 3a 68 74 6d 6c 20 oup.. (s:html
c7a0: 74 65 73 74 73 3a 63 73 73 2d 6a 73 63 72 69 70 tests:css-jscrip
c7b0: 74 2d 62 6c 6f 63 6b 0a 09 09 20 20 20 28 73 3a t-block... (s:
c7c0: 74 69 74 6c 65 20 22 53 75 6d 6d 61 72 79 20 66 title "Summary f
c7d0: 6f 72 20 22 20 61 72 65 61 2d 6e 61 6d 65 29 0a or " area-name).
c7e0: 09 09 20 20 20 28 73 3a 62 6f 64 79 20 27 6f 6e .. (s:body 'on
c7f0: 6c 6f 61 64 20 22 61 64 64 45 76 65 6e 74 73 28 load "addEvents(
c800: 29 3b 22 0a 09 09 09 20 20 20 28 73 3a 68 31 20 );".... (s:h1
c810: 22 53 75 6d 6d 61 72 79 20 66 6f 72 20 22 20 61 "Summary for " a
c820: 72 65 61 2d 6e 61 6d 65 29 0a 09 09 09 20 20 20 rea-name)....
c830: 3b 3b 20 74 6f 70 20 6c 69 73 74 0a 09 09 09 20 ;; top list....
c840: 20 20 28 73 3a 75 6c 20 27 69 64 20 22 4c 69 6e (s:ul 'id "Lin
c850: 6b 65 64 4c 69 73 74 31 22 20 27 63 6c 61 73 73 kedList1" 'class
c860: 20 22 4c 69 6e 6b 65 64 4c 69 73 74 22 0a 09 09 "LinkedList"...
c870: 09 09 20 28 73 3a 6c 69 0a 09 09 09 09 20 20 22 .. (s:li..... "
c880: 52 75 6e 73 22 0a 09 09 09 09 20 20 28 63 6f 6d Runs"..... (com
c890: 6d 6f 6e 3a 68 74 72 65 65 2d 3e 68 74 6d 6c 20 mon:htree->html
c8a0: 72 75 6e 73 2d 68 74 72 65 65 0a 09 09 09 09 09 runs-htree......
c8b0: 09 20 20 20 20 20 20 27 28 29 0a 09 09 09 09 09 . '()......
c8c0: 09 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 . (lambda (
c8d0: 78 20 70 29 0a 09 09 09 09 09 09 09 28 6c 65 74 x p)........(let
c8e0: 2a 20 28 28 74 61 72 67 2d 70 61 74 68 20 28 73 * ((targ-path (s
c8f0: 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 tring-interspers
c900: 65 20 70 20 22 2f 22 29 29 0a 20 20 20 20 20 20 e p "/")).
c910: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c920: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c930: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c940: 20 20 20 20 20 20 20 20 20 28 66 75 6c 6c 2d 70 (full-p
c950: 61 74 68 20 28 63 6f 6e 63 20 6c 69 6e 6b 74 72 ath (conc linktr
c960: 65 65 20 22 2f 22 20 74 61 72 67 2d 70 61 74 68 ee "/" targ-path
c970: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
c980: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c990: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c9a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c9b0: 20 20 28 72 75 6e 2d 6e 61 6d 65 20 20 28 63 61 (run-name (ca
c9c0: 72 20 28 72 65 76 65 72 73 65 20 70 29 29 29 29 r (reverse p))))
c9d0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
c9e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c9f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ca00: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 (if (
ca10: 61 6e 64 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 and (common:file
ca20: 2d 65 78 69 73 74 73 3f 20 66 75 6c 6c 2d 70 61 -exists? full-pa
ca30: 74 68 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 th).
ca40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ca50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ca60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ca70: 20 20 20 20 20 20 20 28 64 69 72 65 63 74 6f 72 (director
ca80: 79 3f 20 20 20 66 75 6c 6c 2d 70 61 74 68 29 0a y? full-path).
ca90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
caa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cab0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cac0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cad0: 20 20 20 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 (file-write-a
cae0: 63 63 65 73 73 3f 20 66 75 6c 6c 2d 70 61 74 68 ccess? full-path
caf0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
cb00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cb10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cb20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cb30: 20 28 73 3a 61 20 72 75 6e 2d 6e 61 6d 65 20 27 (s:a run-name '
cb40: 68 72 65 66 20 28 63 6f 6e 63 20 74 61 72 67 2d href (conc targ-
cb50: 70 61 74 68 20 22 2f 72 75 6e 2d 73 75 6d 6d 61 path "/run-summa
cb60: 72 79 2e 68 74 6d 6c 22 29 29 0a 20 20 20 20 20 ry.html")).
cb70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cb80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cb90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cba0: 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a (begin.
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 20 20 20 20 20 20 20 20
cbe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cbf0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
cc00: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
cc10: 2a 20 22 49 4e 46 4f 3a 20 43 61 6e 27 74 20 63 * "INFO: Can't c
cc20: 72 65 61 74 65 20 22 20 74 61 72 67 2d 70 61 74 reate " targ-pat
cc30: 68 20 22 2f 72 75 6e 2d 73 75 6d 6d 61 72 79 2e h "/run-summary.
cc40: 68 74 6d 6c 22 29 0a 20 20 20 20 20 20 20 20 20 html").
cc50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cc60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cc70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cc80: 20 20 20 20 20 20 20 28 63 6f 6e 63 20 72 75 6e (conc run
cc90: 2d 6e 61 6d 65 20 22 20 28 4e 6f 74 20 61 62 6c -name " (Not abl
cca0: 65 20 74 6f 20 63 72 65 61 74 65 20 73 75 6d 6d e to create summ
ccb0: 61 72 79 20 61 74 20 22 20 74 61 72 67 2d 70 61 ary at " targ-pa
ccc0: 74 68 20 22 29 22 29 29 29 29 29 29 29 29 29 29 th ")"))))))))))
ccd0: 29 0a 20 20 20 20 20 20 20 20 20 20 28 63 6c 6f ). (clo
cce0: 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 6f se-output-port o
ccf0: 75 70 29 0a 09 20 20 28 63 6f 6d 6d 6f 6e 3a 73 up).. (common:s
cd00: 69 6d 70 6c 65 2d 66 69 6c 65 2d 72 65 6c 65 61 imple-file-relea
cd10: 73 65 2d 6c 6f 63 6b 20 6c 6f 63 6b 66 69 6c 65 se-lock lockfile
cd20: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
cd30: 20 0a 09 20 20 28 66 6f 72 2d 65 61 63 68 0a 09 .. (for-each..
cd40: 20 20 20 28 6c 61 6d 62 64 61 20 28 72 75 6e 29 (lambda (run)
cd50: 0a 09 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 .. (let* ((t
cd60: 65 73 74 2d 73 75 62 70 61 74 68 20 28 74 65 73 est-subpath (tes
cd70: 74 73 3a 72 75 6e 2d 72 65 63 6f 72 64 2d 3e 74 ts:run-record->t
cd80: 65 73 74 2d 70 61 74 68 20 72 75 6e 20 6e 75 6d est-path run num
cd90: 6b 65 79 73 29 29 0a 09 09 20 20 20 20 28 72 75 keys))... (ru
cda0: 6e 2d 69 64 20 20 20 20 20 20 20 28 64 62 3a 67 n-id (db:g
cdb0: 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 et-value-by-head
cdc0: 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 69 er run header "i
cdd0: 64 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 d")).
cde0: 20 20 20 20 20 20 20 20 20 28 72 75 6e 2d 64 69 (run-di
cdf0: 72 20 20 20 20 20 20 28 74 65 73 74 73 3a 72 75 r (tests:ru
ce00: 6e 2d 72 65 63 6f 72 64 2d 3e 74 65 73 74 2d 70 n-record->test-p
ce10: 61 74 68 20 72 75 6e 20 6e 75 6d 6b 65 79 73 29 ath run numkeys)
ce20: 29 0a 09 09 20 20 20 20 28 74 65 73 74 2d 64 61 )... (test-da
ce30: 74 73 20 20 20 20 28 72 6d 74 3a 67 65 74 2d 74 ts (rmt:get-t
ce40: 65 73 74 73 2d 66 6f 72 2d 72 75 6e 0a 09 09 09 ests-for-run....
ce50: 09 20 20 20 72 75 6e 2d 69 64 0a 20 20 20 20 20 . run-id.
ce60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ce70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 22 25 "%
ce80: 2f 22 20 20 20 20 20 20 20 3b 3b 20 74 65 73 74 /" ;; test
ce90: 6e 61 6d 65 70 61 74 74 0a 09 09 09 09 20 20 20 namepatt.....
cea0: 27 28 29 20 20 20 20 20 20 20 20 3b 3b 20 73 74 '() ;; st
ceb0: 61 74 65 73 0a 09 09 09 09 20 20 20 27 28 29 20 ates..... '()
cec0: 20 20 20 20 20 20 20 3b 3b 20 73 74 61 74 75 73 ;; status
ced0: 65 73 0a 09 09 09 09 20 20 20 23 66 20 20 20 20 es..... #f
cee0: 20 20 20 20 20 3b 3b 20 6f 66 66 73 65 74 0a 09 ;; offset..
cef0: 09 09 09 20 20 20 23 66 20 20 20 20 20 20 20 20 ... #f
cf00: 20 3b 3b 20 6e 75 6d 2d 74 6f 2d 67 65 74 0a 09 ;; num-to-get..
cf10: 09 09 09 20 20 20 23 66 20 20 20 20 20 20 20 20 ... #f
cf20: 20 3b 3b 20 68 69 64 65 2f 6e 6f 74 2d 68 69 64 ;; hide/not-hid
cf30: 65 0a 09 09 09 09 20 20 20 23 66 20 20 20 20 20 e..... #f
cf40: 20 20 20 20 3b 3b 20 73 6f 72 74 2d 62 79 0a 09 ;; sort-by..
cf50: 09 09 09 20 20 20 23 66 20 20 20 20 20 20 20 20 ... #f
cf60: 20 3b 3b 20 73 6f 72 74 2d 6f 72 64 65 72 0a 09 ;; sort-order..
cf70: 09 09 09 20 20 20 23 66 20 20 20 20 20 20 20 20 ... #f
cf80: 20 3b 3b 20 27 73 68 6f 72 74 6c 69 73 74 20 20 ;; 'shortlist
cf90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cfa0: 20 20 20 20 20 20 20 20 20 3b 3b 20 71 72 79 74 ;; qryt
cfb0: 79 70 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 ype.
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 30 20 20 20 20 20 20 20 20 0
cfe0: 20 3b 3b 20 6c 61 73 74 20 75 70 64 61 74 65 0a ;; last update.
cff0: 09 09 09 09 20 20 20 23 66 29 29 0a 20 20 20 20 .... #f)).
d000: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d010: 28 74 65 73 74 73 2d 74 72 65 65 2d 64 61 74 20 (tests-tree-dat
d020: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 74 65 (map (lambda (te
d030: 73 74 2d 64 61 74 29 0a 20 20 20 20 20 20 20 20 st-dat).
d040: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d050: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d060: 20 3b 3b 20 28 74 65 73 74 73 3a 72 75 6e 2d 72 ;; (tests:run-r
d070: 65 63 6f 72 64 2d 3e 74 65 73 74 2d 70 61 74 68 ecord->test-path
d080: 20 78 20 6e 75 6d 6b 65 79 73 29 29 0a 20 20 20 x numkeys)).
d090: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d0a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d0b0: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 65 (let* ((te
d0c0: 73 74 2d 6e 61 6d 65 20 20 28 64 62 3a 74 65 73 st-name (db:tes
d0d0: 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 t-get-testname t
d0e0: 65 73 74 2d 64 61 74 29 29 0a 20 20 20 20 20 20 est-dat)).
d0f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d100: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d110: 20 20 20 20 20 20 20 20 20 20 28 69 74 65 6d 2d (item-
d120: 70 61 74 68 20 20 28 64 62 3a 74 65 73 74 2d 67 path (db:test-g
d130: 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 65 73 et-item-path tes
d140: 74 2d 64 61 74 29 29 0a 20 20 20 20 20 20 20 20 t-dat)).
d150: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d160: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d170: 20 20 20 20 20 20 20 20 28 66 75 6c 6c 2d 6e 61 (full-na
d180: 6d 65 20 20 28 64 62 3a 74 65 73 74 2d 6d 61 6b me (db:test-mak
d190: 65 2d 66 75 6c 6c 2d 6e 61 6d 65 20 74 65 73 74 e-full-name test
d1a0: 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 -name item-path)
d1b0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
d1c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d1d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d1e0: 20 20 28 70 61 74 68 2d 70 61 72 74 73 20 28 73 (path-parts (s
d1f0: 74 72 69 6e 67 2d 73 70 6c 69 74 20 66 75 6c 6c tring-split full
d200: 2d 6e 61 6d 65 29 29 29 0a 20 20 20 20 20 20 20 -name))).
d210: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d220: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d230: 20 20 20 20 70 61 74 68 2d 70 61 72 74 73 29 29 path-parts))
d240: 0a 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 20 20 20 20 20 74 65 73 74 2d 64 61 74 test-dat
d270: 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 s)).
d280: 20 20 20 20 20 20 20 20 28 74 65 73 74 73 2d 68 (tests-h
d290: 74 72 65 65 20 28 63 6f 6d 6d 6f 6e 3a 6c 69 73 tree (common:lis
d2a0: 74 2d 3e 68 74 72 65 65 20 74 65 73 74 73 2d 74 t->htree tests-t
d2b0: 72 65 65 2d 64 61 74 29 29 0a 20 20 20 20 20 20 ree-dat)).
d2c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 68 (h
d2d0: 74 6d 6c 2d 64 69 72 20 20 20 20 28 63 6f 6e 63 tml-dir (conc
d2e0: 20 6c 69 6e 6b 74 72 65 65 20 22 2f 22 20 28 73 linktree "/" (s
d2f0: 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 tring-interspers
d300: 65 20 72 75 6e 2d 64 69 72 20 22 2f 22 29 29 29 e run-dir "/")))
d310: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
d320: 20 20 20 20 20 28 68 74 6d 6c 2d 70 61 74 68 20 (html-path
d330: 20 20 28 63 6f 6e 63 20 68 74 6d 6c 2d 64 69 72 (conc html-dir
d340: 20 22 2f 72 75 6e 2d 73 75 6d 6d 61 72 79 2e 68 "/run-summary.h
d350: 74 6d 6c 22 29 29 0a 20 20 20 20 20 20 20 20 20 tml")).
d360: 20 20 20 20 20 20 20 20 20 20 20 28 6f 75 70 20 (oup
d370: 20 20 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 (if (and
d380: 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 (common:file-ex
d390: 69 73 74 73 3f 20 68 74 6d 6c 2d 64 69 72 29 0a ists? html-dir).
d3a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d3b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d3c0: 20 20 20 20 20 20 20 20 20 20 28 64 69 72 65 63 (direc
d3d0: 74 6f 72 79 3f 20 20 20 68 74 6d 6c 2d 64 69 72 tory? html-dir
d3e0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
d3f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d400: 20 20 20 20 20 20 20 20 20 20 20 20 28 66 69 6c (fil
d410: 65 2d 77 72 69 74 65 2d 61 63 63 65 73 73 3f 20 e-write-access?
d420: 68 74 6d 6c 2d 64 69 72 29 29 0a 20 20 20 20 20 html-dir)).
d430: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d440: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d450: 28 6f 70 65 6e 2d 6f 75 74 70 75 74 2d 66 69 6c (open-output-fil
d460: 65 20 20 68 74 6d 6c 2d 70 61 74 68 29 0a 20 20 e html-path).
d470: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d480: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d490: 20 20 20 23 66 29 29 29 0a 20 20 20 20 20 20 20 #f))).
d4a0: 20 20 20 20 20 20 20 20 3b 3b 20 28 70 72 69 6e ;; (prin
d4b0: 74 20 22 72 75 6e 2d 64 69 72 3a 20 22 20 72 75 t "run-dir: " ru
d4c0: 6e 2d 64 69 72 20 22 2c 20 74 65 73 74 73 2d 74 n-dir ", tests-t
d4d0: 72 65 65 2d 64 61 74 3a 20 22 20 74 65 73 74 73 ree-dat: " tests
d4e0: 2d 74 72 65 65 2d 64 61 74 29 0a 20 20 20 20 20 -tree-dat).
d4f0: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 6f 75 (if ou
d500: 70 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 p.
d510: 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 (begin.
d520: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d530: 20 28 73 3a 6f 75 74 70 75 74 2d 6e 65 77 0a 20 (s:output-new.
d540: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d550: 20 20 20 20 20 6f 75 70 0a 20 20 20 20 20 20 20 oup.
d560: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
d570: 73 3a 68 74 6d 6c 20 74 65 73 74 73 3a 63 73 73 s:html tests:css
d580: 2d 6a 73 63 72 69 70 74 2d 62 6c 6f 63 6b 0a 20 -jscript-block.
d590: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d5a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 3a (s:
d5b0: 74 69 74 6c 65 20 22 53 75 6d 6d 61 72 79 20 66 title "Summary f
d5c0: 6f 72 20 22 20 61 72 65 61 2d 6e 61 6d 65 29 0a or " area-name).
d5d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d5e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s
d5f0: 3a 62 6f 64 79 20 27 6f 6e 6c 6f 61 64 20 22 61 :body 'onload "a
d600: 64 64 45 76 65 6e 74 73 28 29 3b 22 0a 20 20 20 ddEvents();".
d610: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d620: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d630: 20 20 20 28 73 3a 68 31 20 22 53 75 6d 6d 61 72 (s:h1 "Summar
d640: 79 20 66 6f 72 20 22 20 28 73 74 72 69 6e 67 2d y for " (string-
d650: 69 6e 74 65 72 73 70 65 72 73 65 20 72 75 6e 2d intersperse run-
d660: 64 69 72 20 22 2f 22 29 29 0a 20 20 20 20 20 20 dir "/")).
d670: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d680: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d690: 3b 3b 20 74 6f 70 20 6c 69 73 74 0a 20 20 20 20 ;; top list.
d6a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d6b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d6c0: 20 20 28 73 3a 75 6c 20 27 69 64 20 22 4c 69 6e (s:ul 'id "Lin
d6d0: 6b 65 64 4c 69 73 74 31 22 20 27 63 6c 61 73 73 kedList1" 'class
d6e0: 20 22 4c 69 6e 6b 65 64 4c 69 73 74 22 0a 20 20 "LinkedList".
d6f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d700: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d710: 20 20 20 20 20 20 20 20 20 20 28 73 3a 6c 69 0a (s:li.
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 20 20 20 20 22 54 65 "Te
d750: 73 74 73 22 0a 20 20 20 20 20 20 20 20 20 20 20 sts".
d760: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d770: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d780: 20 20 28 63 6f 6d 6d 6f 6e 3a 68 74 72 65 65 2d (common:htree-
d790: 3e 68 74 6d 6c 20 74 65 73 74 73 2d 68 74 72 65 >html tests-htre
d7a0: 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 e.
d7b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d7c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d7d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d7e0: 20 20 20 27 28 29 0a 20 20 20 20 20 20 20 20 20 '().
d7f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d800: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d810: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d820: 20 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 (lambda
d830: 28 78 20 70 29 0a 20 20 20 20 20 20 20 20 20 20 (x p).
d840: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d850: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d860: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d870: 20 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 (let* (
d880: 28 74 61 72 67 2d 70 61 74 68 20 28 73 74 72 69 (targ-path (stri
d890: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 70 ng-intersperse p
d8a0: 20 22 2f 22 29 29 0a 20 20 20 20 20 20 20 20 20 "/")).
d8b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d8c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d8d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d8e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d8f0: 20 28 74 65 73 74 2d 6e 61 6d 65 20 28 63 61 72 (test-name (car
d900: 20 70 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 p)).
d910: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d920: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d930: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d940: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
d950: 69 74 65 6d 2d 70 61 74 68 20 3b 3b 20 28 69 66 item-path ;; (if
d960: 20 28 3e 20 28 6c 65 6e 67 74 68 20 70 29 20 32 (> (length p) 2
d970: 29 20 3b 3b 20 74 65 73 74 2d 6e 61 6d 65 20 2b ) ;; test-name +
d980: 20 72 75 6e 2d 6e 61 6d 65 0a 20 20 20 20 20 20 run-name.
d990: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d9a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d9b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d9c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d9d0: 20 20 20 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 (string-int
d9e0: 65 72 73 70 65 72 73 65 20 70 20 22 2f 22 29 29 ersperse p "/"))
d9f0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
da00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
da10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
da20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
da30: 20 20 20 20 20 20 20 20 20 20 20 28 66 75 6c 6c (full
da40: 2d 74 61 72 67 20 28 63 6f 6e 63 20 68 74 6d 6c -targ (conc html
da50: 2d 64 69 72 20 22 2f 22 20 74 61 72 67 2d 70 61 -dir "/" targ-pa
da60: 74 68 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 th)).
da70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
da80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
da90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
daa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
dab0: 73 74 64 2d 66 69 6c 65 20 20 28 63 6f 6e 63 20 std-file (conc
dac0: 66 75 6c 6c 2d 74 61 72 67 20 22 2f 74 65 73 74 full-targ "/test
dad0: 2d 73 75 6d 6d 61 72 79 2e 68 74 6d 6c 22 29 29 -summary.html"))
dae0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
daf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
db00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
db10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
db20: 20 20 20 20 20 20 20 20 20 20 20 28 61 6c 74 2d (alt-
db30: 66 69 6c 65 20 20 28 63 6f 6e 63 20 66 75 6c 6c file (conc full
db40: 2d 74 61 72 67 20 22 2f 6d 65 67 61 74 65 73 74 -targ "/megatest
db50: 2d 72 6f 6c 6c 75 70 2d 22 20 74 65 73 74 2d 6e -rollup-" test-n
db60: 61 6d 65 20 22 2e 68 74 6d 6c 22 29 29 0a 20 20 ame ".html")).
db70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
db80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
db90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dba0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dbb0: 20 20 20 20 20 20 20 20 28 68 74 6d 6c 2d 66 69 (html-fi
dbc0: 6c 65 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 66 le (if (common:f
dbd0: 69 6c 65 2d 65 78 69 73 74 73 3f 20 61 6c 74 2d ile-exists? alt-
dbe0: 66 69 6c 65 29 0a 20 20 20 20 20 20 20 20 20 20 file).
dbf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dc00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dc10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dc20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dc30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 61 a
dc40: 6c 74 2d 66 69 6c 65 0a 20 20 20 20 20 20 20 20 lt-file.
dc50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dc60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dc70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dc80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dc90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dca0: 20 73 74 64 2d 66 69 6c 65 29 29 0a 20 20 20 20 std-file)).
dcb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dcc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dcd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dce0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dcf0: 20 20 20 20 20 20 28 72 75 6e 2d 6e 61 6d 65 20 (run-name
dd00: 20 28 63 61 72 20 28 72 65 76 65 72 73 65 20 70 (car (reverse p
dd10: 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 )))).
dd20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dd30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dd40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dd50: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 61 (if (a
dd60: 6e 64 20 28 6e 6f 74 20 28 63 6f 6d 6d 6f 6e 3a nd (not (common:
dd70: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 66 75 6c file-exists? ful
dd80: 6c 2d 74 61 72 67 29 29 0a 20 20 20 20 20 20 20 l-targ)).
dd90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dda0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ddb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ddc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ddd0: 20 20 20 20 20 20 20 28 64 69 72 65 63 74 6f 72 (director
dde0: 79 3f 20 66 75 6c 6c 2d 74 61 72 67 29 0a 20 20 y? full-targ).
ddf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
de00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
de10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
de20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
de30: 20 20 20 20 20 20 20 20 20 20 20 20 28 66 69 6c (fil
de40: 65 2d 77 72 69 74 65 2d 61 63 63 65 73 73 3f 20 e-write-access?
de50: 66 75 6c 6c 2d 74 61 72 67 29 29 0a 20 20 20 20 full-targ)).
de60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
de70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
de80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
de90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dea0: 20 20 20 20 20 28 74 65 73 74 73 3a 73 75 6d 6d (tests:summ
deb0: 61 72 69 7a 65 2d 74 65 73 74 20 0a 20 20 20 20 arize-test .
dec0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ded0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dee0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
def0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
df00: 20 20 20 20 20 20 72 75 6e 2d 69 64 20 0a 20 20 run-id .
df10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
df20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
df30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
df40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
df50: 20 20 20 20 20 20 20 20 28 72 6d 74 3a 67 65 74 (rmt:get
df60: 2d 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 -test-id run-id
df70: 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 test-name item-p
df80: 61 74 68 29 29 29 0a 20 20 20 20 20 20 20 20 20 ath))).
df90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dfa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dfb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dfc0: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
dfd0: 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 (common:file-exi
dfe0: 73 74 73 3f 20 66 75 6c 6c 2d 74 61 72 67 29 0a sts? full-targ).
dff0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e000: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e010: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e020: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e030: 20 20 20 20 20 20 20 20 20 28 73 3a 61 20 72 75 (s:a ru
e040: 6e 2d 6e 61 6d 65 20 27 68 72 65 66 20 68 74 6d n-name 'href htm
e050: 6c 2d 66 69 6c 65 29 0a 20 20 20 20 20 20 20 20 l-file).
e060: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e070: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e080: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e090: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e0a0: 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 (begin.
e0b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e0c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e0d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e0e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e0f0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
e100: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
e110: 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 63 61 6e ort* "ERROR: can
e120: 27 74 20 61 63 63 65 73 73 20 22 20 66 75 6c 6c 't access " full
e130: 2d 74 61 72 67 29 0a 20 20 20 20 20 20 20 20 20 -targ).
e140: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e150: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e160: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e170: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e180: 20 20 28 63 6f 6e 63 20 22 4e 6f 20 73 75 6d 6d (conc "No summ
e190: 61 72 79 20 66 6f 72 20 22 20 72 75 6e 2d 6e 61 ary for " run-na
e1a0: 6d 65 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 me))))).
e1b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e1c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e1d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e1e0: 20 20 20 20 20 20 20 20 20 29 29 29 29 29 29 0a )))))).
e1f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e200: 20 20 20 20 20 28 63 6c 6f 73 65 2d 6f 75 74 70 (close-outp
e210: 75 74 2d 70 6f 72 74 20 6f 75 70 29 29 29 29 29 ut-port oup)))))
e220: 0a 20 20 20 20 20 20 20 20 20 20 20 72 75 6e 73 . runs
e230: 29 0a 20 20 20 20 20 20 20 20 20 20 23 74 29 0a ). #t).
e240: 09 23 66 29 29 29 0a 0a 0a 0a 0a 0a 0a 0a 3b 3b .#f)))........;;
e250: 20 43 48 45 43 4b 20 2d 20 57 41 53 20 54 48 49 CHECK - WAS THI
e260: 53 20 41 44 44 45 44 20 4f 52 20 52 45 4d 4f 56 S ADDED OR REMOV
e270: 45 44 3f 20 4d 41 4e 55 41 4c 20 4d 45 52 47 45 ED? MANUAL MERGE
e280: 20 57 49 54 48 20 41 50 49 20 53 54 55 46 46 21 WITH API STUFF!
e290: 21 21 0a 3b 3b 0a 3b 3b 20 67 65 74 20 61 20 70 !!.;;.;; get a p
e2a0: 72 65 74 74 79 20 74 61 62 6c 65 20 74 6f 20 73 retty table to s
e2b0: 75 6d 6d 61 72 69 7a 65 20 73 74 65 70 73 0a 3b ummarize steps.;
e2c0: 3b 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 64 63 ;.;; (define (dc
e2d0: 6f 6d 6d 6f 6e 3a 70 72 6f 63 65 73 73 2d 73 74 ommon:process-st
e2e0: 65 70 73 2d 74 61 62 6c 65 20 73 74 65 70 73 29 eps-table steps)
e2f0: 3b 3b 20 64 62 20 74 65 73 74 2d 69 64 20 23 21 ;; db test-id #!
e300: 6b 65 79 20 28 77 6f 72 6b 2d 61 72 65 61 20 23 key (work-area #
e310: 66 29 29 0a 28 64 65 66 69 6e 65 20 28 74 65 73 f)).(define (tes
e320: 74 73 3a 70 72 6f 63 65 73 73 2d 73 74 65 70 73 ts:process-steps
e330: 2d 74 61 62 6c 65 20 73 74 65 70 73 29 3b 3b 20 -table steps);;
e340: 64 62 20 74 65 73 74 2d 69 64 20 23 21 6b 65 79 db test-id #!key
e350: 20 28 77 6f 72 6b 2d 61 72 65 61 20 23 66 29 29 (work-area #f))
e360: 0a 3b 3b 20 20 28 6c 65 74 20 28 28 73 74 65 70 .;; (let ((step
e370: 73 20 20 20 28 64 62 3a 67 65 74 2d 73 74 65 70 s (db:get-step
e380: 73 2d 66 6f 72 2d 74 65 73 74 20 64 62 20 74 65 s-for-test db te
e390: 73 74 2d 69 64 20 77 6f 72 6b 2d 61 72 65 61 3a st-id work-area:
e3a0: 20 77 6f 72 6b 2d 61 72 65 61 29 29 29 0a 20 20 work-area))).
e3b0: 20 20 3b 3b 20 6f 72 67 61 6e 69 73 65 20 74 68 ;; organise th
e3c0: 65 20 73 74 65 70 73 20 66 6f 72 20 62 65 74 74 e steps for bett
e3d0: 65 72 20 72 65 61 64 61 62 69 6c 69 74 79 0a 20 er readability.
e3e0: 20 20 20 28 6c 65 74 20 28 28 72 65 73 20 28 6d (let ((res (m
e3f0: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
e400: 29 0a 20 20 20 20 20 20 28 66 6f 72 2d 65 61 63 ). (for-eac
e410: 68 20 0a 20 20 20 20 20 20 20 28 6c 61 6d 62 64 h . (lambd
e420: 61 20 28 73 74 65 70 29 0a 09 20 28 64 65 62 75 a (step).. (debu
e430: 67 3a 70 72 69 6e 74 20 36 20 2a 64 65 66 61 75 g:print 6 *defau
e440: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 74 lt-log-port* "st
e450: 65 70 3d 22 20 73 74 65 70 29 0a 09 20 28 6c 65 ep=" step).. (le
e460: 74 20 28 28 72 65 63 6f 72 64 20 28 68 61 73 68 t ((record (hash
e470: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
e480: 6c 74 20 0a 09 09 09 72 65 73 20 0a 09 09 09 28 lt ....res ....(
e490: 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 65 tdb:step-get-ste
e4a0: 70 6e 61 6d 65 20 73 74 65 70 29 0a 09 09 09 3b pname step)....;
e4b0: 3b 20 20 20 20 20 20 20 20 20 20 20 30 20 20 20 ; 0
e4c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e4d0: 20 20 20 31 20 20 20 20 32 20 20 20 20 33 20 20 1 2 3
e4e0: 20 20 20 20 20 34 20 20 20 20 20 20 20 20 20 35 4 5
e4f0: 20 20 20 20 20 20 20 36 20 20 20 20 20 20 20 37 6 7
e500: 0a 09 09 09 3b 3b 20 20 20 20 20 20 20 20 73 74 ....;; st
e510: 65 70 6e 61 6d 65 20 20 20 20 20 20 20 20 20 20 epname
e520: 20 20 20 20 20 20 73 74 61 72 74 20 65 6e 64 20 start end
e530: 73 74 61 74 75 73 20 44 75 72 61 74 69 6f 6e 20 status Duration
e540: 20 4c 6f 67 66 69 6c 65 20 43 6f 6d 6d 65 6e 74 Logfile Comment
e550: 20 20 66 69 72 73 74 2d 69 64 0a 09 09 09 28 76 first-id....(v
e560: 65 63 74 6f 72 20 28 74 64 62 3a 73 74 65 70 2d ector (tdb:step-
e570: 67 65 74 2d 73 74 65 70 6e 61 6d 65 20 73 74 65 get-stepname ste
e580: 70 29 20 22 22 20 20 20 22 22 20 22 22 20 20 20 p) "" "" ""
e590: 20 20 22 22 20 20 20 20 20 20 20 20 22 22 20 20 "" ""
e5a0: 20 20 20 22 22 20 20 20 20 20 20 20 23 66 29 29 "" #f))
e5b0: 29 29 0a 09 20 20 20 28 64 65 62 75 67 3a 70 72 )).. (debug:pr
e5c0: 69 6e 74 20 36 20 2a 64 65 66 61 75 6c 74 2d 6c int 6 *default-l
e5d0: 6f 67 2d 70 6f 72 74 2a 20 22 72 65 63 6f 72 64 og-port* "record
e5e0: 28 62 65 66 6f 72 65 29 20 3d 20 22 20 72 65 63 (before) = " rec
e5f0: 6f 72 64 20 0a 09 09 09 22 5c 6e 69 64 3a 20 20 ord ...."\nid:
e600: 20 20 20 20 20 22 20 28 74 64 62 3a 73 74 65 70 " (tdb:step
e610: 2d 67 65 74 2d 69 64 20 73 74 65 70 29 0a 09 09 -get-id step)...
e620: 09 22 5c 6e 73 74 65 70 6e 61 6d 65 3a 20 22 20 ."\nstepname: "
e630: 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 (tdb:step-get-st
e640: 65 70 6e 61 6d 65 20 73 74 65 70 29 0a 09 09 09 epname step)....
e650: 22 5c 6e 73 74 61 74 65 3a 20 20 20 20 22 20 28 "\nstate: " (
e660: 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 61 tdb:step-get-sta
e670: 74 65 20 73 74 65 70 29 0a 09 09 09 22 5c 6e 73 te step)...."\ns
e680: 74 61 74 75 73 3a 20 20 20 22 20 28 74 64 62 3a tatus: " (tdb:
e690: 73 74 65 70 2d 67 65 74 2d 73 74 61 74 75 73 20 step-get-status
e6a0: 73 74 65 70 29 0a 09 09 09 22 5c 6e 74 69 6d 65 step)...."\ntime
e6b0: 3a 20 20 20 20 20 22 20 28 74 64 62 3a 73 74 65 : " (tdb:ste
e6c0: 70 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 p-get-event_time
e6d0: 20 73 74 65 70 29 29 0a 09 20 20 20 28 69 66 20 step)).. (if
e6e0: 28 6e 6f 74 20 28 76 65 63 74 6f 72 2d 72 65 66 (not (vector-ref
e6f0: 20 72 65 63 6f 72 64 20 37 29 29 28 76 65 63 74 record 7))(vect
e700: 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 64 20 37 or-set! record 7
e710: 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 69 (tdb:step-get-i
e720: 64 20 73 74 65 70 29 29 29 20 3b 3b 20 64 6f 20 d step))) ;; do
e730: 6e 6f 74 20 63 6c 6f 62 62 65 72 20 74 68 65 20 not clobber the
e740: 69 64 20 69 66 20 70 72 65 76 69 6f 75 73 6c 79 id if previously
e750: 20 73 65 74 0a 09 20 20 20 28 63 61 73 65 20 28 set.. (case (
e760: 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 string->symbol (
e770: 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 61 tdb:step-get-sta
e780: 74 65 20 73 74 65 70 29 29 0a 09 20 20 20 20 20 te step))..
e790: 28 28 73 74 61 72 74 29 28 76 65 63 74 6f 72 2d ((start)(vector-
e7a0: 73 65 74 21 20 72 65 63 6f 72 64 20 31 20 28 74 set! record 1 (t
e7b0: 64 62 3a 73 74 65 70 2d 67 65 74 2d 65 76 65 6e db:step-get-even
e7c0: 74 5f 74 69 6d 65 20 73 74 65 70 29 29 0a 09 20 t_time step))..
e7d0: 20 20 20 20 20 28 76 65 63 74 6f 72 2d 73 65 74 (vector-set
e7e0: 21 20 72 65 63 6f 72 64 20 33 20 28 69 66 20 28 ! record 3 (if (
e7f0: 65 71 75 61 6c 3f 20 28 76 65 63 74 6f 72 2d 72 equal? (vector-r
e800: 65 66 20 72 65 63 6f 72 64 20 33 29 20 22 22 29 ef record 3) "")
e810: 0a 09 09 09 09 09 28 74 64 62 3a 73 74 65 70 2d ......(tdb:step-
e820: 67 65 74 2d 73 74 61 74 75 73 20 73 74 65 70 29 get-status step)
e830: 29 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 3e )).. (if (>
e840: 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 (string-length
e850: 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 6c 6f (tdb:step-get-lo
e860: 67 66 69 6c 65 20 73 74 65 70 29 29 0a 09 09 20 gfile step))...
e870: 20 20 20 20 30 29 0a 09 09 20 20 28 76 65 63 74 0)... (vect
e880: 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 64 20 35 or-set! record 5
e890: 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 6c (tdb:step-get-l
e8a0: 6f 67 66 69 6c 65 20 73 74 65 70 29 29 29 29 0a ogfile step)))).
e8b0: 09 20 20 20 20 20 28 28 65 6e 64 29 20 20 0a 09 . ((end) ..
e8c0: 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 73 65 (vector-se
e8d0: 74 21 20 72 65 63 6f 72 64 20 32 20 28 61 6e 79 t! record 2 (any
e8e0: 2d 3e 6e 75 6d 62 65 72 20 28 74 64 62 3a 73 74 ->number (tdb:st
e8f0: 65 70 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 6d ep-get-event_tim
e900: 65 20 73 74 65 70 29 29 29 0a 09 20 20 20 20 20 e step)))..
e910: 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 72 65 (vector-set! re
e920: 63 6f 72 64 20 33 20 28 74 64 62 3a 73 74 65 70 cord 3 (tdb:step
e930: 2d 67 65 74 2d 73 74 61 74 75 73 20 73 74 65 70 -get-status step
e940: 29 29 0a 09 20 20 20 20 20 20 28 76 65 63 74 6f )).. (vecto
e950: 72 2d 73 65 74 21 20 72 65 63 6f 72 64 20 34 20 r-set! record 4
e960: 28 6c 65 74 20 28 28 73 74 61 72 74 74 20 28 61 (let ((startt (a
e970: 6e 79 2d 3e 6e 75 6d 62 65 72 20 28 76 65 63 74 ny->number (vect
e980: 6f 72 2d 72 65 66 20 72 65 63 6f 72 64 20 31 29 or-ref record 1)
e990: 29 29 0a 09 09 09 09 09 20 20 28 65 6e 64 74 20 ))...... (endt
e9a0: 20 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 20 28 (any->number (
e9b0: 76 65 63 74 6f 72 2d 72 65 66 20 72 65 63 6f 72 vector-ref recor
e9c0: 64 20 32 29 29 29 29 0a 09 09 09 09 20 20 20 20 d 2)))).....
e9d0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 (debug:print 4
e9e0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
e9f0: 72 74 2a 20 22 72 65 63 6f 72 64 5b 31 5d 3d 22 rt* "record[1]="
ea00: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 65 63 (vector-ref rec
ea10: 6f 72 64 20 31 29 20 0a 09 09 09 09 09 09 20 20 ord 1) .......
ea20: 20 22 2c 20 73 74 61 72 74 74 3d 22 20 73 74 61 ", startt=" sta
ea30: 72 74 74 20 22 2c 20 65 6e 64 74 3d 22 20 65 6e rtt ", endt=" en
ea40: 64 74 0a 09 09 09 09 09 09 20 20 20 22 2c 20 67 dt....... ", g
ea50: 65 74 2d 73 74 61 74 75 73 3a 20 22 20 28 74 64 et-status: " (td
ea60: 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 61 74 75 b:step-get-statu
ea70: 73 20 73 74 65 70 29 29 0a 09 09 09 09 20 20 20 s step)).....
ea80: 20 20 20 28 69 66 20 28 61 6e 64 20 28 6e 75 6d (if (and (num
ea90: 62 65 72 3f 20 73 74 61 72 74 74 29 28 6e 75 6d ber? startt)(num
eaa0: 62 65 72 3f 20 65 6e 64 74 29 29 0a 09 09 09 09 ber? endt)).....
eab0: 09 20 20 28 73 65 63 6f 6e 64 73 2d 3e 68 72 2d . (seconds->hr-
eac0: 6d 69 6e 2d 73 65 63 20 28 2d 20 65 6e 64 74 20 min-sec (- endt
ead0: 73 74 61 72 74 74 29 29 20 22 2d 31 22 29 29 29 startt)) "-1")))
eae0: 0a 09 20 20 20 20 20 20 28 69 66 20 28 3e 20 28 .. (if (> (
eaf0: 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 28 74 string-length (t
eb00: 64 62 3a 73 74 65 70 2d 67 65 74 2d 6c 6f 67 66 db:step-get-logf
eb10: 69 6c 65 20 73 74 65 70 29 29 0a 09 09 20 20 20 ile step))...
eb20: 20 20 30 29 0a 09 09 20 20 28 76 65 63 74 6f 72 0)... (vector
eb30: 2d 73 65 74 21 20 72 65 63 6f 72 64 20 35 20 28 -set! record 5 (
eb40: 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 6c 6f 67 tdb:step-get-log
eb50: 66 69 6c 65 20 73 74 65 70 29 29 29 0a 09 20 20 file step)))..
eb60: 20 20 20 20 28 69 66 20 28 3e 20 28 73 74 72 69 (if (> (stri
eb70: 6e 67 2d 6c 65 6e 67 74 68 20 28 74 64 62 3a 73 ng-length (tdb:s
eb80: 74 65 70 2d 67 65 74 2d 63 6f 6d 6d 65 6e 74 20 tep-get-comment
eb90: 73 74 65 70 29 29 0a 09 09 20 20 20 20 20 30 29 step))... 0)
eba0: 0a 09 09 20 20 28 76 65 63 74 6f 72 2d 73 65 74 ... (vector-set
ebb0: 21 20 72 65 63 6f 72 64 20 36 20 28 74 64 62 3a ! record 6 (tdb:
ebc0: 73 74 65 70 2d 67 65 74 2d 63 6f 6d 6d 65 6e 74 step-get-comment
ebd0: 20 73 74 65 70 29 29 29 29 0a 09 20 20 20 20 20 step))))..
ebe0: 28 65 6c 73 65 0a 09 20 20 20 20 20 20 28 76 65 (else.. (ve
ebf0: 63 74 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 64 ctor-set! record
ec00: 20 32 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2 (tdb:step-get
ec10: 2d 73 74 61 74 65 20 73 74 65 70 29 29 0a 09 20 -state step))..
ec20: 20 20 20 20 20 28 76 65 63 74 6f 72 2d 73 65 74 (vector-set
ec30: 21 20 72 65 63 6f 72 64 20 33 20 28 74 64 62 3a ! record 3 (tdb:
ec40: 73 74 65 70 2d 67 65 74 2d 73 74 61 74 75 73 20 step-get-status
ec50: 73 74 65 70 29 29 0a 09 20 20 20 20 20 20 28 76 step)).. (v
ec60: 65 63 74 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 ector-set! recor
ec70: 64 20 34 20 28 74 64 62 3a 73 74 65 70 2d 67 65 d 4 (tdb:step-ge
ec80: 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 73 74 65 t-event_time ste
ec90: 70 29 29 0a 09 20 20 20 20 20 20 28 76 65 63 74 p)).. (vect
eca0: 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 64 20 36 or-set! record 6
ecb0: 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 63 (tdb:step-get-c
ecc0: 6f 6d 6d 65 6e 74 20 73 74 65 70 29 29 29 29 0a omment step)))).
ecd0: 09 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d . (hash-table-
ece0: 73 65 74 21 20 72 65 73 20 28 74 64 62 3a 73 74 set! res (tdb:st
ecf0: 65 70 2d 67 65 74 2d 73 74 65 70 6e 61 6d 65 20 ep-get-stepname
ed00: 73 74 65 70 29 20 72 65 63 6f 72 64 29 0a 09 20 step) record)..
ed10: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 36 (debug:print 6
ed20: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
ed30: 72 74 2a 20 22 72 65 63 6f 72 64 28 61 66 74 65 rt* "record(afte
ed40: 72 29 20 20 3d 20 22 20 72 65 63 6f 72 64 20 0a r) = " record .
ed50: 09 09 09 22 5c 6e 69 64 3a 20 20 20 20 20 20 20 ..."\nid:
ed60: 22 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d " (tdb:step-get-
ed70: 69 64 20 73 74 65 70 29 0a 09 09 09 22 5c 6e 73 id step)...."\ns
ed80: 74 65 70 6e 61 6d 65 3a 20 22 20 28 74 64 62 3a tepname: " (tdb:
ed90: 73 74 65 70 2d 67 65 74 2d 73 74 65 70 6e 61 6d step-get-stepnam
eda0: 65 20 73 74 65 70 29 0a 09 09 09 22 5c 6e 73 74 e step)...."\nst
edb0: 61 74 65 3a 20 20 20 20 22 20 28 74 64 62 3a 73 ate: " (tdb:s
edc0: 74 65 70 2d 67 65 74 2d 73 74 61 74 65 20 73 74 tep-get-state st
edd0: 65 70 29 0a 09 09 09 22 5c 6e 73 74 61 74 75 73 ep)...."\nstatus
ede0: 3a 20 20 20 22 20 28 74 64 62 3a 73 74 65 70 2d : " (tdb:step-
edf0: 67 65 74 2d 73 74 61 74 75 73 20 73 74 65 70 29 get-status step)
ee00: 0a 09 09 09 22 5c 6e 74 69 6d 65 3a 20 20 20 20 ...."\ntime:
ee10: 20 22 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 " (tdb:step-get
ee20: 2d 65 76 65 6e 74 5f 74 69 6d 65 20 73 74 65 70 -event_time step
ee30: 29 29 29 29 0a 20 20 20 20 20 20 20 3b 3b 20 28 )))). ;; (
ee40: 65 6c 73 65 20 20 20 28 76 65 63 74 6f 72 2d 73 else (vector-s
ee50: 65 74 21 20 72 65 63 6f 72 64 20 31 20 28 74 64 et! record 1 (td
ee60: 62 3a 73 74 65 70 2d 67 65 74 2d 65 76 65 6e 74 b:step-get-event
ee70: 5f 74 69 6d 65 20 73 74 65 70 29 29 29 0a 20 20 _time step))).
ee80: 20 20 20 20 20 28 73 6f 72 74 20 73 74 65 70 73 (sort steps
ee90: 20 28 6c 61 6d 62 64 61 20 28 61 20 62 29 0a 09 (lambda (a b)..
eea0: 09 20 20 20 20 20 28 63 6f 6e 64 0a 09 09 20 20 . (cond...
eeb0: 20 20 20 20 28 28 3c 20 20 20 28 74 64 62 3a 73 ((< (tdb:s
eec0: 74 65 70 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 tep-get-event_ti
eed0: 6d 65 20 61 29 28 74 64 62 3a 73 74 65 70 2d 67 me a)(tdb:step-g
eee0: 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 62 29 et-event_time b)
eef0: 29 20 23 74 29 0a 09 09 20 20 20 20 20 20 28 28 ) #t)... ((
ef00: 65 71 3f 20 28 74 64 62 3a 73 74 65 70 2d 67 65 eq? (tdb:step-ge
ef10: 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 61 29 28 t-event_time a)(
ef20: 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 65 76 65 tdb:step-get-eve
ef30: 6e 74 5f 74 69 6d 65 20 62 29 29 20 0a 09 09 20 nt_time b)) ...
ef40: 20 20 20 20 20 20 28 3c 20 20 20 28 74 64 62 3a (< (tdb:
ef50: 73 74 65 70 2d 67 65 74 2d 69 64 20 61 29 20 20 step-get-id a)
ef60: 20 20 20 20 20 20 28 74 64 62 3a 73 74 65 70 2d (tdb:step-
ef70: 67 65 74 2d 69 64 20 62 29 29 29 0a 09 09 20 20 get-id b)))...
ef80: 20 20 20 20 28 65 6c 73 65 20 23 66 29 29 29 29 (else #f))))
ef90: 29 0a 20 20 20 20 20 20 72 65 73 29 29 0a 0a 3b ). res))..;
efa0: 3b 20 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 ; .;;.(define (t
efb0: 65 73 74 73 3a 67 65 74 2d 63 6f 6d 70 72 65 73 ests:get-compres
efc0: 73 65 64 2d 73 74 65 70 73 20 72 75 6e 2d 69 64 sed-steps run-id
efd0: 20 74 65 73 74 2d 69 64 29 0a 20 20 28 6c 65 74 test-id). (let
efe0: 2a 20 28 28 73 74 65 70 73 2d 64 61 74 61 20 20 * ((steps-data
eff0: 28 72 6d 74 3a 67 65 74 2d 73 74 65 70 73 2d 66 (rmt:get-steps-f
f000: 6f 72 2d 74 65 73 74 20 72 75 6e 2d 69 64 20 74 or-test run-id t
f010: 65 73 74 2d 69 64 29 29 20 3b 3b 20 20 20 20 20 est-id)) ;;
f020: 20 30 20 20 20 20 20 20 20 31 20 20 20 20 32 20 0 1 2
f030: 20 20 20 33 20 20 20 20 20 20 20 34 20 20 20 20 3 4
f040: 20 20 20 35 20 20 20 20 20 20 20 36 20 20 20 20 5 6
f050: 20 20 37 20 20 20 20 20 20 20 0a 09 20 28 63 6f 7 .. (co
f060: 6d 70 72 73 74 65 70 73 20 20 28 74 65 73 74 73 mprsteps (tests
f070: 3a 70 72 6f 63 65 73 73 2d 73 74 65 70 73 2d 74 :process-steps-t
f080: 61 62 6c 65 20 73 74 65 70 73 2d 64 61 74 61 29 able steps-data)
f090: 29 29 20 3b 3b 20 23 3c 73 74 65 70 6e 61 6d 65 )) ;; #<stepname
f0a0: 20 73 74 61 72 74 20 65 6e 64 20 73 74 61 74 75 start end statu
f0b0: 73 20 44 75 72 61 74 69 6f 6e 20 4c 6f 67 66 69 s Duration Logfi
f0c0: 6c 65 20 43 6f 6d 6d 65 6e 74 20 69 64 3e 0a 20 le Comment id>.
f0d0: 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 (map (lambda
f0e0: 28 78 29 0a 09 20 20 20 3b 3b 20 74 61 6b 65 20 (x).. ;; take
f0f0: 61 64 76 61 6e 74 61 67 65 20 6f 66 20 74 68 65 advantage of the
f100: 20 5c 6e 20 6f 6e 20 74 69 6d 65 2d 3e 73 74 72 \n on time->str
f110: 69 6e 67 0a 09 20 20 20 28 76 65 63 74 6f 72 20 ing.. (vector
f120: 20 20 20 3b 3b 20 77 65 20 61 72 65 20 63 6f 6e ;; we are con
f130: 73 74 72 75 63 74 69 6e 67 20 62 61 73 69 63 61 structing basica
f140: 6c 6c 79 20 74 68 65 20 6f 72 69 67 69 6e 61 6c lly the original
f150: 20 76 65 63 74 6f 72 20 62 75 74 20 63 6f 6c 6c vector but coll
f160: 61 70 73 69 6e 67 20 73 74 61 72 74 20 65 6e 64 apsing start end
f170: 20 72 65 63 6f 72 64 73 0a 09 20 20 20 20 28 76 records.. (v
f180: 65 63 74 6f 72 2d 72 65 66 20 78 20 30 29 20 20 ector-ref x 0)
f190: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
f1a0: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 69 ;; i
f1b0: 64 20 20 20 20 20 20 20 20 30 0a 09 20 20 20 20 d 0..
f1c0: 28 6c 65 74 20 28 28 73 20 28 76 65 63 74 6f 72 (let ((s (vector
f1d0: 2d 72 65 66 20 78 20 31 29 29 29 0a 09 20 20 20 -ref x 1)))..
f1e0: 20 20 20 28 69 66 20 28 6e 75 6d 62 65 72 3f 20 (if (number?
f1f0: 73 29 28 73 65 63 6f 6e 64 73 2d 3e 74 69 6d 65 s)(seconds->time
f200: 2d 73 74 72 69 6e 67 20 73 29 20 73 29 29 20 3b -string s) s)) ;
f210: 3b 20 73 74 61 72 74 74 69 6d 65 20 31 0a 09 20 ; starttime 1..
f220: 20 20 20 28 6c 65 74 20 28 28 73 20 28 76 65 63 (let ((s (vec
f230: 74 6f 72 2d 72 65 66 20 78 20 32 29 29 29 0a 09 tor-ref x 2)))..
f240: 20 20 20 20 20 20 28 69 66 20 28 6e 75 6d 62 65 (if (numbe
f250: 72 3f 20 73 29 28 73 65 63 6f 6e 64 73 2d 3e 74 r? s)(seconds->t
f260: 69 6d 65 2d 73 74 72 69 6e 67 20 73 29 20 73 29 ime-string s) s)
f270: 29 20 3b 3b 20 65 6e 64 74 69 6d 65 20 20 20 32 ) ;; endtime 2
f280: 0a 09 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 .. (vector-re
f290: 66 20 78 20 33 29 20 20 20 20 20 20 20 20 20 20 f x 3)
f2a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
f2b0: 20 20 20 20 3b 3b 20 73 74 61 74 75 73 20 20 20 ;; status
f2c0: 20 33 20 20 20 20 0a 09 20 20 20 20 28 76 65 63 3 .. (vec
f2d0: 74 6f 72 2d 72 65 66 20 78 20 34 29 20 20 20 20 tor-ref x 4)
f2e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
f2f0: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 64 75 72 ;; dur
f300: 61 74 69 6f 6e 20 20 34 0a 09 20 20 20 20 28 76 ation 4.. (v
f310: 65 63 74 6f 72 2d 72 65 66 20 78 20 35 29 20 20 ector-ref x 5)
f320: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
f330: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 6c ;; l
f340: 6f 67 66 69 6c 65 20 20 20 35 0a 09 20 20 20 20 ogfile 5..
f350: 28 76 65 63 74 6f 72 2d 72 65 66 20 78 20 36 29 (vector-ref x 6)
f360: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
f370: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b ;;
f380: 20 63 6f 6d 6d 65 6e 74 20 20 20 36 0a 09 20 20 comment 6..
f390: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 78 20 (vector-ref x
f3a0: 37 29 29 29 20 20 20 20 20 20 20 20 20 20 20 20 7)))
f3b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
f3c0: 3b 3b 20 69 64 20 20 20 20 20 20 20 20 37 0a 09 ;; id 7..
f3d0: 20 28 73 6f 72 74 20 28 68 61 73 68 2d 74 61 62 (sort (hash-tab
f3e0: 6c 65 2d 76 61 6c 75 65 73 20 63 6f 6d 70 72 73 le-values comprs
f3f0: 74 65 70 73 29 0a 09 20 20 20 20 20 20 20 28 6c teps).. (l
f400: 61 6d 62 64 61 20 28 61 20 62 29 0a 09 09 20 28 ambda (a b)... (
f410: 6c 65 74 20 28 28 74 69 6d 65 2d 61 20 28 76 65 let ((time-a (ve
f420: 63 74 6f 72 2d 72 65 66 20 61 20 31 29 29 0a 09 ctor-ref a 1))..
f430: 09 20 20 20 20 20 20 20 28 74 69 6d 65 2d 62 20 . (time-b
f440: 28 76 65 63 74 6f 72 2d 72 65 66 20 62 20 31 29 (vector-ref b 1)
f450: 29 0a 09 09 20 20 20 20 20 20 20 28 69 64 2d 61 )... (id-a
f460: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 61 (vector-ref a
f470: 20 37 29 29 0a 09 09 20 20 20 20 20 20 20 28 69 7))... (i
f480: 64 2d 62 20 20 20 28 76 65 63 74 6f 72 2d 72 65 d-b (vector-re
f490: 66 20 62 20 37 29 29 29 0a 09 09 20 20 20 28 69 f b 7)))... (i
f4a0: 66 20 28 61 6e 64 20 28 6e 75 6d 62 65 72 3f 20 f (and (number?
f4b0: 74 69 6d 65 2d 61 29 28 6e 75 6d 62 65 72 3f 20 time-a)(number?
f4c0: 74 69 6d 65 2d 62 29 29 0a 09 09 20 20 20 20 20 time-b))...
f4d0: 20 20 28 69 66 20 28 3c 20 74 69 6d 65 2d 61 20 (if (< time-a
f4e0: 74 69 6d 65 2d 62 29 0a 09 09 09 20 20 20 23 74 time-b).... #t
f4f0: 0a 09 09 09 20 20 20 28 69 66 20 28 65 71 3f 20 .... (if (eq?
f500: 74 69 6d 65 2d 61 20 74 69 6d 65 2d 62 29 0a 09 time-a time-b)..
f510: 09 09 20 20 20 20 20 20 20 28 3c 20 69 64 2d 61 .. (< id-a
f520: 20 69 64 2d 62 29 0a 09 09 09 20 20 20 20 20 20 id-b)....
f530: 20 3b 3b 20 28 73 74 72 69 6e 67 3c 3f 20 28 63 ;; (string<? (c
f540: 6f 6e 63 20 28 76 65 63 74 6f 72 2d 72 65 66 20 onc (vector-ref
f550: 61 20 32 29 29 0a 09 09 09 20 20 20 20 20 20 20 a 2))....
f560: 3b 3b 09 20 20 20 20 28 63 6f 6e 63 20 28 76 65 ;;. (conc (ve
f570: 63 74 6f 72 2d 72 65 66 20 62 20 32 29 29 29 0a ctor-ref b 2))).
f580: 09 09 09 20 20 20 20 20 20 20 23 66 29 29 0a 09 ... #f))..
f590: 09 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 3c . (string<
f5a0: 3f 20 28 63 6f 6e 63 20 74 69 6d 65 2d 61 29 28 ? (conc time-a)(
f5b0: 63 6f 6e 63 20 74 69 6d 65 2d 62 29 29 29 29 29 conc time-b)))))
f5c0: 29 29 29 29 0a 0a 0a 3b 3b 20 53 61 76 65 20 74 ))))...;; Save t
f5d0: 65 73 74 20 73 74 61 74 65 20 61 6e 64 20 73 74 est state and st
f5e0: 61 74 75 73 20 69 6e 20 74 6f 20 61 20 66 69 6c atus in to a fil
f5f0: 65 20 2e 66 69 6e 61 6c 2d 73 74 61 74 75 73 20 e .final-status
f600: 69 6e 20 74 68 65 20 74 65 73 74 20 64 69 72 65 in the test dire
f610: 63 74 6f 72 79 0a 3b 3b 0a 28 64 65 66 69 6e 65 ctory.;;.(define
f620: 20 28 74 65 73 74 73 3a 73 61 76 65 2d 66 69 6e (tests:save-fin
f630: 61 6c 2d 73 74 61 74 75 73 20 72 75 6e 2d 69 64 al-status run-id
f640: 20 74 65 73 74 2d 69 64 29 0a 20 20 28 6c 65 74 test-id). (let
f650: 2a 20 28 28 74 65 73 74 2d 64 61 74 20 20 28 72 * ((test-dat (r
f660: 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f mt:get-test-info
f670: 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 -by-id run-id te
f680: 73 74 2d 69 64 29 29 0a 09 20 28 6f 75 74 2d 64 st-id)).. (out-d
f690: 69 72 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 ir (db:test-ge
f6a0: 74 2d 72 75 6e 64 69 72 20 74 65 73 74 2d 64 61 t-rundir test-da
f6b0: 74 29 29 0a 09 20 28 73 74 61 74 75 73 2d 66 69 t)).. (status-fi
f6c0: 6c 65 20 20 28 63 6f 6e 63 20 6f 75 74 2d 64 69 le (conc out-di
f6d0: 72 20 22 2f 2e 66 69 6e 61 6c 2d 73 74 61 74 75 r "/.final-statu
f6e0: 73 22 29 29 0a 20 20 20 29 0a 20 20 20 20 3b 3b s")). ). ;;
f6f0: 20 66 69 72 73 74 20 76 65 72 69 66 79 20 77 65 first verify we
f700: 20 61 72 65 20 61 62 6c 65 20 74 6f 20 77 72 69 are able to wri
f710: 74 65 20 74 68 65 20 6f 75 74 70 75 74 20 66 69 te the output fi
f720: 6c 65 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 le. (if (not
f730: 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 (file-write-acce
f740: 73 73 3f 20 6f 75 74 2d 64 69 72 29 29 0a 09 20 ss? out-dir))..
f750: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
f760: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
f770: 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 63 61 6e ort* "ERROR: can
f780: 6e 6f 74 20 77 72 69 74 65 20 2e 66 69 6e 61 6c not write .final
f790: 2d 73 74 61 74 75 73 20 74 6f 20 22 20 6f 75 74 -status to " out
f7a0: 2d 64 69 72 29 0a 09 20 20 20 20 28 6c 65 74 2a -dir).. (let*
f7b0: 20 0a 20 20 20 20 20 20 20 20 20 28 28 6f 75 74 . ((out
f7c0: 70 20 20 20 20 20 20 28 6f 70 65 6e 2d 6f 75 74 p (open-out
f7d0: 70 75 74 2d 66 69 6c 65 20 73 74 61 74 75 73 2d put-file status-
f7e0: 66 69 6c 65 29 29 0a 09 20 20 20 20 20 20 20 28 file)).. (
f7f0: 73 74 61 74 75 73 20 20 20 20 28 64 62 3a 74 65 status (db:te
f800: 73 74 2d 67 65 74 2d 73 74 61 74 75 73 20 20 20 st-get-status
f810: 74 65 73 74 2d 64 61 74 29 29 0a 20 20 20 20 20 test-dat)).
f820: 20 20 20 20 28 73 74 61 74 65 20 20 20 20 20 28 (state (
f830: 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 db:test-get-stat
f840: 65 20 20 20 20 74 65 73 74 2d 64 61 74 29 29 29 e test-dat)))
f850: 0a 20 20 20 20 20 20 20 20 28 66 70 72 69 6e 74 . (fprint
f860: 66 20 6f 75 74 70 20 22 7e 53 5c 6e 22 20 73 74 f outp "~S\n" st
f870: 61 74 65 29 20 0a 20 20 20 20 20 20 20 20 28 66 ate) . (f
f880: 70 72 69 6e 74 66 20 6f 75 74 70 20 22 7e 53 5c printf outp "~S\
f890: 6e 22 20 73 74 61 74 75 73 29 20 0a 20 20 20 20 n" status) .
f8a0: 20 20 20 20 28 63 6c 6f 73 65 2d 6f 75 74 70 75 (close-outpu
f8b0: 74 2d 70 6f 72 74 20 6f 75 74 70 29 29 29 29 29 t-port outp)))))
f8c0: 0a 0a 0a 3b 3b 20 73 75 6d 6d 61 72 69 7a 65 20 ...;; summarize
f8d0: 74 65 73 74 20 69 6e 20 74 6f 20 61 20 66 69 6c test in to a fil
f8e0: 65 20 74 65 73 74 2d 73 75 6d 6d 61 72 79 2e 68 e test-summary.h
f8f0: 74 6d 6c 20 69 6e 20 74 68 65 20 74 65 73 74 20 tml in the test
f900: 64 69 72 65 63 74 6f 72 79 0a 3b 3b 0a 28 64 65 directory.;;.(de
f910: 66 69 6e 65 20 28 74 65 73 74 73 3a 73 75 6d 6d fine (tests:summ
f920: 61 72 69 7a 65 2d 74 65 73 74 20 72 75 6e 2d 69 arize-test run-i
f930: 64 20 74 65 73 74 2d 69 64 29 0a 20 20 28 6c 65 d test-id). (le
f940: 74 2a 20 28 28 74 65 73 74 2d 64 61 74 20 20 28 t* ((test-dat (
f950: 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 rmt:get-test-inf
f960: 6f 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 74 o-by-id run-id t
f970: 65 73 74 2d 69 64 29 29 0a 09 20 28 6f 75 74 2d est-id)).. (out-
f980: 64 69 72 20 20 20 28 64 62 3a 74 65 73 74 2d 67 dir (db:test-g
f990: 65 74 2d 72 75 6e 64 69 72 20 74 65 73 74 2d 64 et-rundir test-d
f9a0: 61 74 29 29 0a 09 20 28 6f 75 74 2d 66 69 6c 65 at)).. (out-file
f9b0: 20 20 28 63 6f 6e 63 20 6f 75 74 2d 64 69 72 20 (conc out-dir
f9c0: 22 2f 74 65 73 74 2d 73 75 6d 6d 61 72 79 2e 68 "/test-summary.h
f9d0: 74 6d 6c 22 29 29 29 0a 20 20 20 20 3b 3b 20 66 tml"))). ;; f
f9e0: 69 72 73 74 20 76 65 72 69 66 79 20 77 65 20 61 irst verify we a
f9f0: 72 65 20 61 62 6c 65 20 74 6f 20 77 72 69 74 65 re able to write
fa00: 20 74 68 65 20 6f 75 74 70 75 74 20 66 69 6c 65 the output file
fa10: 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 66 . (if (not (f
fa20: 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 73 73 ile-write-access
fa30: 3f 20 6f 75 74 2d 64 69 72 29 29 0a 09 28 64 65 ? out-dir))..(de
fa40: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
fa50: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
fa60: 45 52 52 4f 52 3a 20 63 61 6e 6e 6f 74 20 77 72 ERROR: cannot wr
fa70: 69 74 65 20 74 65 73 74 2d 73 75 6d 6d 61 72 79 ite test-summary
fa80: 2e 68 74 6d 6c 20 74 6f 20 22 20 6f 75 74 2d 64 .html to " out-d
fa90: 69 72 29 0a 09 28 6c 65 74 2a 20 28 3b 3b 20 28 ir)..(let* (;; (
faa0: 73 74 65 70 73 2d 64 61 74 20 28 72 6d 74 3a 67 steps-dat (rmt:g
fab0: 65 74 2d 73 74 65 70 73 2d 66 6f 72 2d 74 65 73 et-steps-for-tes
fac0: 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 t run-id test-id
fad0: 29 29 0a 09 20 20 20 20 20 20 20 28 74 65 73 74 )).. (test
fae0: 2d 6e 61 6d 65 20 28 64 62 3a 74 65 73 74 2d 67 -name (db:test-g
faf0: 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 et-testname test
fb00: 2d 64 61 74 29 29 0a 09 20 20 20 20 20 20 20 28 -dat)).. (
fb10: 69 74 65 6d 2d 70 61 74 68 20 28 64 62 3a 74 65 item-path (db:te
fb20: 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 st-get-item-path
fb30: 20 74 65 73 74 2d 64 61 74 29 29 0a 09 20 20 20 test-dat))..
fb40: 20 20 20 20 28 66 75 6c 6c 2d 6e 61 6d 65 20 28 (full-name (
fb50: 64 62 3a 74 65 73 74 2d 6d 61 6b 65 2d 66 75 6c db:test-make-ful
fb60: 6c 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 l-name test-name
fb70: 20 69 74 65 6d 2d 70 61 74 68 29 29 0a 09 20 20 item-path))..
fb80: 20 20 20 20 20 28 6f 75 70 20 20 20 20 20 20 20 (oup
fb90: 28 6f 70 65 6e 2d 6f 75 74 70 75 74 2d 66 69 6c (open-output-fil
fba0: 65 20 6f 75 74 2d 66 69 6c 65 29 29 0a 09 20 20 e out-file))..
fbb0: 20 20 20 20 20 28 73 74 61 74 75 73 20 20 20 20 (status
fbc0: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 (db:test-get-sta
fbd0: 74 75 73 20 20 20 74 65 73 74 2d 64 61 74 29 29 tus test-dat))
fbe0: 0a 09 20 20 20 20 20 20 20 28 63 6f 6c 6f 72 20 .. (color
fbf0: 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d (common:get-
fc00: 63 6f 6c 6f 72 2d 66 72 6f 6d 2d 73 74 61 74 75 color-from-statu
fc10: 73 20 73 74 61 74 75 73 29 29 0a 09 20 20 20 20 s status))..
fc20: 20 20 20 28 6c 6f 67 66 20 20 20 20 20 20 28 64 (logf (d
fc30: 62 3a 74 65 73 74 2d 67 65 74 2d 66 69 6e 61 6c b:test-get-final
fc40: 5f 6c 6f 67 66 20 74 65 73 74 2d 64 61 74 29 29 _logf test-dat))
fc50: 0a 09 20 20 20 20 20 20 20 28 73 74 65 70 73 2d .. (steps-
fc60: 64 61 74 20 28 74 65 73 74 73 3a 67 65 74 2d 63 dat (tests:get-c
fc70: 6f 6d 70 72 65 73 73 65 64 2d 73 74 65 70 73 20 ompressed-steps
fc80: 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 29 run-id test-id))
fc90: 29 0a 09 20 20 3b 3b 20 28 64 63 6f 6d 6d 6f 6e ).. ;; (dcommon
fca0: 3a 67 65 74 2d 63 6f 6d 70 72 65 73 73 65 64 2d :get-compressed-
fcb0: 73 74 65 70 73 20 23 66 20 31 20 33 30 30 34 35 steps #f 1 30045
fcc0: 29 0a 09 20 20 3b 3b 20 28 23 28 22 77 61 73 74 ).. ;; (#("wast
fcd0: 69 6e 67 5f 74 69 6d 65 22 20 22 32 33 3a 33 36 ing_time" "23:36
fce0: 3a 31 33 22 20 22 32 33 3a 33 36 3a 32 31 22 20 :13" "23:36:21"
fcf0: 22 30 22 20 22 38 2e 30 73 22 20 22 77 61 73 74 "0" "8.0s" "wast
fd00: 69 6e 67 5f 74 69 6d 65 2e 6c 6f 67 22 29 29 0a ing_time.log")).
fd10: 09 0a 09 20 20 28 73 3a 6f 75 74 70 75 74 2d 6e ... (s:output-n
fd20: 65 77 0a 09 20 20 20 6f 75 70 0a 09 20 20 20 28 ew.. oup.. (
fd30: 73 3a 68 74 6d 6c 0a 09 20 20 20 20 28 73 3a 74 s:html.. (s:t
fd40: 69 74 6c 65 20 22 53 75 6d 6d 61 72 79 20 66 6f itle "Summary fo
fd50: 72 20 22 20 66 75 6c 6c 2d 6e 61 6d 65 29 0a 09 r " full-name)..
fd60: 20 20 20 20 28 73 3a 62 6f 64 79 20 0a 09 20 20 (s:body ..
fd70: 20 20 20 28 73 3a 68 32 20 22 53 75 6d 6d 61 72 (s:h2 "Summar
fd80: 79 20 66 6f 72 20 22 20 66 75 6c 6c 2d 6e 61 6d y for " full-nam
fd90: 65 29 0a 09 20 20 20 20 20 28 73 3a 74 61 62 6c e).. (s:tabl
fda0: 65 20 27 63 65 6c 6c 73 70 61 63 69 6e 67 20 22 e 'cellspacing "
fdb0: 30 22 20 27 62 6f 72 64 65 72 20 22 31 22 0a 09 0" 'border "1"..
fdc0: 09 20 20 20 20 20 20 28 73 3a 74 72 20 28 73 3a . (s:tr (s:
fdd0: 74 64 20 22 72 75 6e 20 69 64 22 29 20 20 20 28 td "run id") (
fde0: 73 3a 74 64 20 28 64 62 3a 74 65 73 74 2d 67 65 s:td (db:test-ge
fdf0: 74 2d 72 75 6e 5f 69 64 20 20 20 74 65 73 74 2d t-run_id test-
fe00: 64 61 74 29 29 0a 09 09 09 20 20 20 20 28 73 3a dat)).... (s:
fe10: 74 64 20 22 74 65 73 74 20 69 64 22 29 20 20 28 td "test id") (
fe20: 73 3a 74 64 20 28 64 62 3a 74 65 73 74 2d 67 65 s:td (db:test-ge
fe30: 74 2d 69 64 20 20 20 20 20 20 20 74 65 73 74 2d t-id test-
fe40: 64 61 74 29 29 29 0a 09 09 20 20 20 20 20 20 28 dat)))... (
fe50: 73 3a 74 72 20 28 73 3a 74 64 20 22 74 65 73 74 s:tr (s:td "test
fe60: 6e 61 6d 65 22 29 20 28 73 3a 74 64 20 74 65 73 name") (s:td tes
fe70: 74 2d 6e 61 6d 65 29 0a 09 09 09 20 20 20 20 28 t-name).... (
fe80: 73 3a 74 64 20 22 69 74 65 6d 70 61 74 68 22 29 s:td "itempath")
fe90: 20 28 73 3a 74 64 20 69 74 65 6d 2d 70 61 74 68 (s:td item-path
fea0: 29 29 0a 09 09 20 20 20 20 20 20 28 73 3a 74 72 ))... (s:tr
feb0: 20 28 73 3a 74 64 20 22 73 74 61 74 65 22 29 20 (s:td "state")
fec0: 20 20 20 28 73 3a 74 64 20 28 64 62 3a 74 65 73 (s:td (db:tes
fed0: 74 2d 67 65 74 2d 73 74 61 74 65 20 20 20 20 74 t-get-state t
fee0: 65 73 74 2d 64 61 74 29 29 0a 09 09 09 20 20 20 est-dat))....
fef0: 20 28 73 3a 74 64 20 22 73 74 61 74 75 73 22 29 (s:td "status")
ff00: 20 20 20 28 73 3a 74 64 20 28 73 3a 61 20 27 68 (s:td (s:a 'h
ff10: 72 65 66 20 6c 6f 67 66 20 28 73 3a 66 6f 6e 74 ref logf (s:font
ff20: 20 27 63 6f 6c 6f 72 20 63 6f 6c 6f 72 20 73 74 'color color st
ff30: 61 74 75 73 29 29 29 29 0a 09 09 20 20 20 20 20 atus))))...
ff40: 20 28 73 3a 74 72 20 28 73 3a 74 64 20 22 54 65 (s:tr (s:td "Te
ff50: 73 74 44 61 74 65 22 29 20 28 73 3a 74 64 20 28 stDate") (s:td (
ff60: 73 65 63 6f 6e 64 73 2d 3e 77 6f 72 6b 2d 77 65 seconds->work-we
ff70: 65 6b 2f 64 61 79 2d 74 69 6d 65 20 0a 09 09 09 ek/day-time ....
ff80: 09 09 09 20 20 20 20 20 28 64 62 3a 74 65 73 74 ... (db:test
ff90: 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 -get-event_time
ffa0: 74 65 73 74 2d 64 61 74 29 29 29 0a 09 09 09 20 test-dat)))....
ffb0: 20 20 20 28 73 3a 74 64 20 22 44 75 72 61 74 69 (s:td "Durati
ffc0: 6f 6e 22 29 20 28 73 3a 74 64 20 28 73 65 63 6f on") (s:td (seco
ffd0: 6e 64 73 2d 3e 68 72 2d 6d 69 6e 2d 73 65 63 20 nds->hr-min-sec
ffe0: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e (db:test-get-run
fff0: 5f 64 75 72 61 74 69 6f 6e 20 74 65 73 74 2d 64 _duration test-d
10000 61 74 29 29 29 29 29 0a 09 20 20 20 20 20 28 73 at))))).. (s
10010 3a 68 33 20 22 4c 6f 67 20 66 69 6c 65 73 22 29 :h3 "Log files")
10020 0a 09 20 20 20 20 20 28 73 3a 74 61 62 6c 65 20 .. (s:table
10030 0a 09 20 20 20 20 20 20 27 63 65 6c 6c 73 70 61 .. 'cellspa
10040 63 69 6e 67 20 22 30 22 20 27 62 6f 72 64 65 72 cing "0" 'border
10050 20 22 31 22 0a 09 20 20 20 20 20 20 28 73 3a 74 "1".. (s:t
10060 72 20 28 73 3a 74 64 20 22 46 69 6e 61 6c 20 6c r (s:td "Final l
10070 6f 67 22 29 28 73 3a 74 64 20 28 73 3a 61 20 27 og")(s:td (s:a '
10080 68 72 65 66 20 6c 6f 67 66 20 6c 6f 67 66 29 29 href logf logf))
10090 29 29 0a 09 20 20 20 20 20 28 73 3a 74 61 62 6c )).. (s:tabl
100a0 65 0a 09 20 20 20 20 20 20 27 63 65 6c 6c 73 70 e.. 'cellsp
100b0 61 63 69 6e 67 20 22 30 22 20 27 62 6f 72 64 65 acing "0" 'borde
100c0 72 20 22 31 22 0a 09 20 20 20 20 20 20 28 73 3a r "1".. (s:
100d0 74 72 20 28 73 3a 74 64 20 22 53 74 65 70 20 4e tr (s:td "Step N
100e0 61 6d 65 22 29 28 73 3a 74 64 20 22 53 74 61 72 ame")(s:td "Star
100f0 74 22 29 28 73 3a 74 64 20 22 45 6e 64 22 29 28 t")(s:td "End")(
10100 73 3a 74 64 20 22 53 74 61 74 75 73 22 29 28 73 s:td "Status")(s
10110 3a 74 64 20 22 44 75 72 61 74 69 6f 6e 22 29 28 :td "Duration")(
10120 73 3a 74 64 20 22 4c 6f 67 20 46 69 6c 65 22 29 s:td "Log File")
10130 29 0a 09 20 20 20 20 20 20 28 6d 61 70 20 28 6c ).. (map (l
10140 61 6d 62 64 61 20 28 73 74 65 70 2d 64 61 74 29 ambda (step-dat)
10150 0a 09 09 20 20 20 20 20 28 73 3a 74 72 20 28 73 ... (s:tr (s
10160 3a 74 64 20 28 74 64 62 3a 73 74 65 70 73 2d 74 :td (tdb:steps-t
10170 61 62 6c 65 2d 67 65 74 2d 73 74 65 70 6e 61 6d able-get-stepnam
10180 65 20 73 74 65 70 2d 64 61 74 29 29 0a 09 09 09 e step-dat))....
10190 20 20 20 28 73 3a 74 64 20 28 74 64 62 3a 73 74 (s:td (tdb:st
101a0 65 70 73 2d 74 61 62 6c 65 2d 67 65 74 2d 73 74 eps-table-get-st
101b0 61 72 74 20 20 20 20 73 74 65 70 2d 64 61 74 29 art step-dat)
101c0 29 0a 09 09 09 20 20 20 28 73 3a 74 64 20 28 74 ).... (s:td (t
101d0 64 62 3a 73 74 65 70 73 2d 74 61 62 6c 65 2d 67 db:steps-table-g
101e0 65 74 2d 65 6e 64 20 20 20 20 20 20 73 74 65 70 et-end step
101f0 2d 64 61 74 29 29 0a 09 09 09 20 20 20 28 73 3a -dat)).... (s:
10200 74 64 20 28 74 64 62 3a 73 74 65 70 73 2d 74 61 td (tdb:steps-ta
10210 62 6c 65 2d 67 65 74 2d 73 74 61 74 75 73 20 20 ble-get-status
10220 20 73 74 65 70 2d 64 61 74 29 29 0a 09 09 09 20 step-dat))....
10230 20 20 28 73 3a 74 64 20 28 74 64 62 3a 73 74 65 (s:td (tdb:ste
10240 70 73 2d 74 61 62 6c 65 2d 67 65 74 2d 72 75 6e ps-table-get-run
10250 74 69 6d 65 20 20 73 74 65 70 2d 64 61 74 29 29 time step-dat))
10260 0a 09 09 09 20 20 20 28 73 3a 74 64 20 28 6c 65 .... (s:td (le
10270 74 20 28 28 73 74 65 70 2d 6c 6f 67 20 28 74 64 t ((step-log (td
10280 62 3a 73 74 65 70 73 2d 74 61 62 6c 65 2d 67 65 b:steps-table-ge
10290 74 2d 6c 6f 67 2d 66 69 6c 65 20 73 74 65 70 2d t-log-file step-
102a0 64 61 74 29 29 29 0a 09 09 09 09 20 20 20 28 73 dat)))..... (s
102b0 3a 61 20 27 68 72 65 66 20 73 74 65 70 2d 6c 6f :a 'href step-lo
102c0 67 20 73 74 65 70 2d 6c 6f 67 29 29 29 29 29 0a g step-log))))).
102d0 09 09 20 20 20 73 74 65 70 73 2d 64 61 74 29 29 .. steps-dat))
102e0 0a 09 20 20 20 20 20 29 29 29 0a 09 20 20 28 63 .. ))).. (c
102f0 6c 6f 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 lose-output-port
10300 20 6f 75 70 29 29 29 29 29 0a 09 20 20 0a 09 20 oup))))).. ..
10310 20 0a 3b 3b 20 4d 55 53 54 20 42 45 20 43 41 4c .;; MUST BE CAL
10320 4c 45 44 20 6c 6f 63 61 6c 21 0a 3b 3b 0a 28 64 LED local!.;;.(d
10330 65 66 69 6e 65 20 28 74 65 73 74 73 3a 74 65 73 efine (tests:tes
10340 74 2d 67 65 74 2d 70 61 74 68 73 2d 6d 61 74 63 t-get-paths-matc
10350 68 69 6e 67 20 6b 65 79 6e 61 6d 65 73 20 74 61 hing keynames ta
10360 72 67 65 74 20 66 6e 61 6d 65 70 61 74 74 20 23 rget fnamepatt #
10370 21 6b 65 79 20 28 72 65 73 20 27 28 29 29 29 0a !key (res '())).
10380 20 20 3b 3b 20 42 55 47 3a 20 4d 6f 76 65 20 74 ;; BUG: Move t
10390 68 65 20 76 61 6c 75 65 73 20 64 65 72 69 76 65 he values derive
103a0 64 20 66 72 6f 6d 20 61 72 67 73 20 74 6f 20 70 d from args to p
103b0 61 72 61 6d 65 74 65 72 73 20 61 6e 64 20 70 75 arameters and pu
103c0 73 68 20 74 6f 20 6d 65 67 61 74 65 73 74 2e 73 sh to megatest.s
103d0 63 6d 0a 20 20 28 6c 65 74 2a 20 28 28 74 65 73 cm. (let* ((tes
103e0 74 70 61 74 74 20 20 20 28 6f 72 20 28 61 72 67 tpatt (or (arg
103f0 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 65 73 74 s:get-arg "-test
10400 70 61 74 74 22 29 28 61 72 67 73 3a 67 65 74 2d patt")(args:get-
10410 61 72 67 20 22 2d 74 65 73 74 70 61 74 74 22 29 arg "-testpatt")
10420 20 22 25 22 29 29 0a 09 20 28 73 74 61 74 65 70 "%")).. (statep
10430 61 74 74 20 20 28 6f 72 20 28 61 72 67 73 3a 67 att (or (args:g
10440 65 74 2d 61 72 67 20 22 2d 73 74 61 74 65 22 29 et-arg "-state")
10450 20 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 (args:get-arg
10460 20 22 3a 73 74 61 74 65 22 29 20 20 20 20 22 25 ":state") "%
10470 22 29 29 0a 09 20 28 73 74 61 74 75 73 70 61 74 ")).. (statuspat
10480 74 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d t (or (args:get-
10490 61 72 67 20 22 2d 73 74 61 74 75 73 22 29 20 20 arg "-status")
104a0 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 3a (args:get-arg ":
104b0 73 74 61 74 75 73 22 29 20 20 20 22 25 22 29 29 status") "%"))
104c0 0a 09 20 28 72 75 6e 6e 61 6d 65 20 20 20 20 28 .. (runname (
104d0 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 or (args:get-arg
104e0 20 22 2d 72 75 6e 6e 61 6d 65 22 29 20 28 61 72 "-runname") (ar
104f0 67 73 3a 67 65 74 2d 61 72 67 20 22 3a 72 75 6e gs:get-arg ":run
10500 6e 61 6d 65 22 29 20 20 22 25 22 29 29 0a 09 20 name") "%"))..
10510 28 70 61 74 68 73 2d 66 72 6f 6d 2d 64 62 20 28 (paths-from-db (
10520 72 6d 74 3a 74 65 73 74 2d 67 65 74 2d 70 61 74 rmt:test-get-pat
10530 68 73 2d 6d 61 74 63 68 69 6e 67 2d 6b 65 79 6e hs-matching-keyn
10540 61 6d 65 73 2d 74 61 72 67 65 74 2d 6e 65 77 20 ames-target-new
10550 6b 65 79 6e 61 6d 65 73 20 74 61 72 67 65 74 20 keynames target
10560 72 65 73 0a 09 09 09 09 09 74 65 73 74 70 61 74 res......testpat
10570 74 0a 09 09 09 09 09 73 74 61 74 65 70 61 74 74 t......statepatt
10580 0a 09 09 09 09 09 73 74 61 74 75 73 70 61 74 74 ......statuspatt
10590 0a 09 09 09 09 09 72 75 6e 6e 61 6d 65 29 29 29 ......runname)))
105a0 0a 20 20 20 20 28 69 66 20 66 6e 61 6d 65 70 61 . (if fnamepa
105b0 74 74 0a 09 28 61 70 70 6c 79 20 61 70 70 65 6e tt..(apply appen
105c0 64 20 0a 09 20 20 20 20 20 20 20 28 6d 61 70 20 d .. (map
105d0 28 6c 61 6d 62 64 61 20 28 70 29 0a 09 09 20 20 (lambda (p)...
105e0 20 20 20 20 28 69 66 20 28 64 69 72 65 63 74 6f (if (directo
105f0 72 79 2d 65 78 69 73 74 73 3f 20 70 29 0a 09 09 ry-exists? p)...
10600 09 20 20 28 6c 65 74 20 28 28 67 6c 6f 62 2d 71 . (let ((glob-q
10610 75 65 72 79 20 28 63 6f 6e 63 20 70 20 22 2f 22 uery (conc p "/"
10620 20 66 6e 61 6d 65 70 61 74 74 29 29 29 0a 09 09 fnamepatt)))...
10630 09 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 . (handle-exc
10640 65 70 74 69 6f 6e 73 0a 09 09 09 09 65 78 6e 0a eptions.....exn.
10650 09 09 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a ... (begin.
10660 09 09 09 09 28 70 72 69 6e 74 20 22 62 75 69 6c ....(print "buil
10670 74 2d 69 6e 20 67 6c 6f 62 20 6f 6e 20 22 20 67 t-in glob on " g
10680 6c 6f 62 2d 71 75 65 72 79 20 22 2c 20 66 61 69 lob-query ", fai
10690 6c 65 64 2c 20 74 72 79 20 75 73 69 6e 67 20 74 led, try using t
106a0 68 65 20 73 68 65 6c 6c 2e 20 65 78 6e 3d 22 20 he shell. exn="
106b0 65 78 6e 29 0a 09 09 09 09 28 77 69 74 68 2d 69 exn).....(with-i
106c0 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 0a 09 nput-from-pipe..
106d0 09 09 09 20 28 63 6f 6e 63 20 22 65 63 68 6f 20 ... (conc "echo
106e0 22 20 67 6c 6f 62 2d 71 75 65 72 79 29 0a 09 09 " glob-query)...
106f0 09 09 20 72 65 61 64 2d 6c 69 6e 65 73 29 29 20 .. read-lines))
10700 20 3b 3b 20 77 65 20 61 72 65 6e 27 74 20 67 6f ;; we aren't go
10710 69 6e 67 20 74 6f 20 74 72 79 20 74 6f 6f 20 68 ing to try too h
10720 61 72 64 2e 20 49 66 20 67 6c 6f 62 20 62 72 65 ard. If glob bre
10730 61 6b 73 20 69 74 20 69 73 20 6c 69 6b 65 6c 79 aks it is likely
10740 20 62 65 63 61 75 73 65 20 73 6f 6d 65 6f 6e 65 because someone
10750 20 74 72 69 65 64 20 74 6f 20 64 6f 20 2a 2f 2a tried to do */*
10760 2f 2a 2e 6c 6f 67 20 6f 72 20 73 69 6d 69 6c 61 /*.log or simila
10770 72 0a 09 09 09 20 20 20 20 20 20 28 67 6c 6f 62 r.... (glob
10780 20 67 6c 6f 62 2d 71 75 65 72 79 29 29 29 0a 09 glob-query)))..
10790 09 09 20 20 27 28 29 29 29 0a 09 09 20 20 20 20 .. '()))...
107a0 70 61 74 68 73 2d 66 72 6f 6d 2d 64 62 29 29 0a paths-from-db)).
107b0 09 70 61 74 68 73 2d 66 72 6f 6d 2d 64 62 29 29 .paths-from-db))
107c0 29 0a 0a 09 09 09 20 20 20 20 20 20 0a 3b 3b 3d )..... .;;=
107d0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
107e0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
107f0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10800 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10810 3d 3d 3d 3d 3d 0a 3b 3b 20 47 61 74 68 65 72 20 =====.;; Gather
10820 64 61 74 61 20 66 72 6f 6d 20 74 65 73 74 2f 74 data from test/t
10830 61 73 6b 20 73 70 65 63 69 66 69 63 61 74 69 6f ask specificatio
10840 6e 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ns.;;===========
10850 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10860 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10870 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10880 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 ===========..;;
10890 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 67 (define (tests:g
108a0 65 74 2d 76 61 6c 69 64 2d 74 65 73 74 73 20 74 et-valid-tests t
108b0 65 73 74 73 64 69 72 20 74 65 73 74 2d 70 61 74 estsdir test-pat
108c0 74 73 29 20 3b 3b 20 20 23 21 6b 65 79 20 28 74 ts) ;; #!key (t
108d0 65 73 74 2d 6e 61 6d 65 73 20 27 28 29 29 29 0a est-names '())).
108e0 3b 3b 20 20 20 28 6c 65 74 20 28 28 74 65 73 74 ;; (let ((test
108f0 73 20 28 67 6c 6f 62 20 28 63 6f 6e 63 20 74 65 s (glob (conc te
10900 73 74 73 64 69 72 20 22 2f 74 65 73 74 73 2f 2a stsdir "/tests/*
10910 22 29 29 29 29 20 3b 3b 20 22 20 28 73 74 72 69 ")))) ;; " (stri
10920 6e 67 2d 74 72 61 6e 73 6c 61 74 65 20 70 61 74 ng-translate pat
10930 74 20 22 25 22 20 22 2a 22 29 29 29 29 29 0a 3b t "%" "*"))))).;
10940 3b 20 20 20 20 20 28 73 65 74 21 20 74 65 73 74 ; (set! test
10950 73 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 s (filter (lambd
10960 61 20 28 74 65 73 74 29 28 63 6f 6d 6d 6f 6e 3a a (test)(common:
10970 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 28 63 6f file-exists? (co
10980 6e 63 20 74 65 73 74 20 22 2f 74 65 73 74 63 6f nc test "/testco
10990 6e 66 69 67 22 29 29 29 20 74 65 73 74 73 29 29 nfig"))) tests))
109a0 0a 3b 3b 20 20 20 20 20 28 64 65 6c 65 74 65 2d .;; (delete-
109b0 64 75 70 6c 69 63 61 74 65 73 0a 3b 3b 20 20 20 duplicates.;;
109c0 20 20 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 (filter (lamb
109d0 64 61 20 28 74 65 73 74 6e 61 6d 65 29 0a 3b 3b da (testname).;;
109e0 20 09 20 20 20 20 20 20 20 28 74 65 73 74 73 3a . (tests:
109f0 6d 61 74 63 68 20 74 65 73 74 2d 70 61 74 74 73 match test-patts
10a00 20 74 65 73 74 6e 61 6d 65 20 23 66 29 29 0a 3b testname #f)).;
10a10 3b 20 09 20 20 20 20 20 28 6d 61 70 20 28 6c 61 ; . (map (la
10a20 6d 62 64 61 20 28 74 65 73 74 70 29 0a 3b 3b 20 mbda (testp).;;
10a30 09 09 20 20 20 20 28 6c 61 73 74 20 28 73 74 72 .. (last (str
10a40 69 6e 67 2d 73 70 6c 69 74 20 74 65 73 74 70 20 ing-split testp
10a50 22 2f 22 29 29 29 0a 3b 3b 20 09 09 20 20 74 65 "/"))).;; .. te
10a60 73 74 73 29 29 29 29 29 0a 0a 28 64 65 66 69 6e sts)))))..(defin
10a70 65 20 28 74 65 73 74 73 3a 67 65 74 2d 74 65 73 e (tests:get-tes
10a80 74 2d 70 61 74 68 2d 66 72 6f 6d 2d 65 6e 76 69 t-path-from-envi
10a90 72 6f 6e 6d 65 6e 74 29 0a 20 20 28 69 66 20 28 ronment). (if (
10aa0 61 6e 64 20 28 67 65 74 65 6e 76 20 22 4d 54 5f and (getenv "MT_
10ab0 4c 49 4e 4b 54 52 45 45 22 29 0a 09 20 20 20 28 LINKTREE").. (
10ac0 67 65 74 65 6e 76 20 22 4d 54 5f 54 41 52 47 45 getenv "MT_TARGE
10ad0 54 22 29 0a 09 20 20 20 28 67 65 74 65 6e 76 20 T").. (getenv
10ae0 22 4d 54 5f 52 55 4e 4e 41 4d 45 22 29 0a 09 20 "MT_RUNNAME")..
10af0 20 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 54 45 (getenv "MT_TE
10b00 53 54 5f 4e 41 4d 45 22 29 0a 09 20 20 20 28 67 ST_NAME").. (g
10b10 65 74 65 6e 76 20 22 4d 54 5f 49 54 45 4d 50 41 etenv "MT_ITEMPA
10b20 54 48 22 29 29 0a 20 20 20 20 20 20 28 63 6f 6e TH")). (con
10b30 63 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 4c 49 c (getenv "MT_LI
10b40 4e 4b 54 52 45 45 22 29 20 20 22 2f 22 0a 09 20 NKTREE") "/"..
10b50 20 20 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 54 (getenv "MT_T
10b60 41 52 47 45 54 22 29 20 20 20 20 22 2f 22 0a 09 ARGET") "/"..
10b70 20 20 20 20 28 67 65 74 65 6e 76 20 22 4d 54 5f (getenv "MT_
10b80 52 55 4e 4e 41 4d 45 22 29 20 20 20 22 2f 22 0a RUNNAME") "/".
10b90 09 20 20 20 20 28 67 65 74 65 6e 76 20 22 4d 54 . (getenv "MT
10ba0 5f 54 45 53 54 5f 4e 41 4d 45 22 29 0a 09 20 20 _TEST_NAME")..
10bb0 20 20 28 69 66 20 28 61 6e 64 20 28 67 65 74 65 (if (and (gete
10bc0 6e 76 20 22 4d 54 5f 49 54 45 4d 50 41 54 48 22 nv "MT_ITEMPATH"
10bd0 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
10be0 20 20 20 20 20 20 20 28 6e 6f 74 20 28 73 74 72 (not (str
10bf0 69 6e 67 3d 3f 20 22 22 20 28 67 65 74 65 6e 76 ing=? "" (getenv
10c00 20 22 4d 54 5f 49 54 45 4d 50 41 54 48 22 29 29 "MT_ITEMPATH"))
10c10 29 29 0a 09 09 28 63 6f 6e 63 20 22 2f 22 20 28 ))...(conc "/" (
10c20 67 65 74 65 6e 76 20 22 4d 54 5f 49 54 45 4d 50 getenv "MT_ITEMP
10c30 41 54 48 22 29 29 0a 20 20 20 20 20 20 20 20 20 ATH")).
10c40 20 20 20 20 20 20 20 22 22 29 29 0a 20 20 20 20 "")).
10c50 20 20 23 66 29 29 0a 0a 3b 3b 20 69 66 20 2e 74 #f))..;; if .t
10c60 65 73 74 63 6f 6e 66 69 67 20 65 78 69 73 74 73 estconfig exists
10c70 20 69 6e 20 74 65 73 74 20 64 69 72 65 63 74 6f in test directo
10c80 72 79 20 72 65 61 64 20 61 6e 64 20 72 65 74 75 ry read and retu
10c90 72 6e 20 69 74 0a 3b 3b 20 65 6c 73 65 20 69 66 rn it.;; else if
10ca0 20 68 61 76 65 20 63 61 63 68 65 64 20 63 6f 70 have cached cop
10cb0 79 20 69 6e 20 2a 74 65 73 74 63 6f 6e 66 69 67 y in *testconfig
10cc0 73 2a 20 72 65 74 75 72 6e 20 69 74 20 49 46 46 s* return it IFF
10cd0 20 74 68 65 72 65 20 69 73 20 61 20 73 65 63 74 there is a sect
10ce0 69 6f 6e 20 22 68 61 76 65 20 66 75 6c 6c 64 61 ion "have fullda
10cf0 74 61 22 0a 3b 3b 20 65 6c 73 65 20 72 65 61 64 ta".;; else read
10d00 20 74 68 65 20 74 65 73 74 63 6f 6e 66 69 67 20 the testconfig
10d10 66 69 6c 65 0a 3b 3b 20 20 20 69 66 20 68 61 76 file.;; if hav
10d20 65 20 70 61 74 68 20 74 6f 20 74 65 73 74 20 64 e path to test d
10d30 69 72 65 63 74 6f 72 79 20 73 61 76 65 20 74 68 irectory save th
10d40 65 20 63 6f 6e 66 69 67 20 61 73 20 2e 74 65 73 e config as .tes
10d50 74 63 6f 6e 66 69 67 20 61 6e 64 20 72 65 74 75 tconfig and retu
10d60 72 6e 20 69 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 rn it.;;.(define
10d70 20 28 74 65 73 74 73 3a 67 65 74 2d 74 65 73 74 (tests:get-test
10d80 63 6f 6e 66 69 67 20 74 65 73 74 2d 6e 61 6d 65 config test-name
10d90 20 69 74 65 6d 2d 70 61 74 68 20 74 65 73 74 2d item-path test-
10da0 72 65 67 69 73 74 72 79 20 73 79 73 74 65 6d 2d registry system-
10db0 61 6c 6c 6f 77 65 64 20 23 21 6b 65 79 20 28 66 allowed #!key (f
10dc0 6f 72 63 65 2d 63 72 65 61 74 65 20 23 66 29 28 orce-create #f)(
10dd0 61 6c 6c 6f 77 2d 77 72 69 74 65 2d 63 61 63 68 allow-write-cach
10de0 65 20 23 74 29 28 77 61 69 74 2d 61 2d 6d 69 6e e #t)(wait-a-min
10df0 75 74 65 20 23 66 29 29 0a 20 20 28 6c 65 74 2a ute #f)). (let*
10e00 20 28 28 75 73 65 2d 63 61 63 68 65 20 20 20 20 ((use-cache
10e10 28 63 6f 6d 6d 6f 6e 3a 75 73 65 2d 63 61 63 68 (common:use-cach
10e20 65 3f 29 29 0a 09 20 28 63 61 63 68 65 2d 70 61 e?)).. (cache-pa
10e30 74 68 20 20 20 28 74 65 73 74 73 3a 67 65 74 2d th (tests:get-
10e40 74 65 73 74 2d 70 61 74 68 2d 66 72 6f 6d 2d 65 test-path-from-e
10e50 6e 76 69 72 6f 6e 6d 65 6e 74 29 29 0a 09 20 28 nvironment)).. (
10e60 63 61 63 68 65 2d 66 69 6c 65 20 20 20 28 61 6e cache-file (an
10e70 64 20 63 61 63 68 65 2d 70 61 74 68 20 28 63 6f d cache-path (co
10e80 6e 63 20 63 61 63 68 65 2d 70 61 74 68 20 22 2f nc cache-path "/
10e90 2e 74 65 73 74 63 6f 6e 66 69 67 22 29 29 29 0a .testconfig"))).
10ea0 09 20 28 63 61 63 68 65 2d 65 78 69 73 74 73 20 . (cache-exists
10eb0 28 61 6e 64 20 63 61 63 68 65 2d 66 69 6c 65 0a (and cache-file.
10ec0 09 09 09 20 20 20 20 28 6e 6f 74 20 66 6f 72 63 ... (not forc
10ed0 65 2d 63 72 65 61 74 65 29 20 20 3b 3b 20 69 66 e-create) ;; if
10ee0 20 66 6f 72 63 65 2d 63 72 65 61 74 65 20 74 68 force-create th
10ef0 65 6e 20 70 72 65 74 65 6e 64 20 74 68 65 72 65 en pretend there
10f00 20 69 73 20 6e 6f 20 63 61 63 68 65 20 74 6f 20 is no cache to
10f10 72 65 61 64 0a 09 09 09 20 20 20 20 28 63 6f 6d read.... (com
10f20 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f mon:file-exists?
10f30 20 63 61 63 68 65 2d 66 69 6c 65 29 29 29 0a 09 cache-file)))..
10f40 20 28 63 61 63 68 65 64 2d 64 61 74 20 20 20 28 (cached-dat (
10f50 69 66 20 28 61 6e 64 20 28 6e 6f 74 20 66 6f 72 if (and (not for
10f60 63 65 2d 63 72 65 61 74 65 29 0a 09 09 09 09 63 ce-create).....c
10f70 61 63 68 65 2d 65 78 69 73 74 73 0a 09 09 09 09 ache-exists.....
10f80 75 73 65 2d 63 61 63 68 65 29 0a 09 09 09 20 20 use-cache)....
10f90 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 (handle-excepti
10fa0 6f 6e 73 0a 09 09 09 20 20 20 20 20 20 20 65 78 ons.... ex
10fb0 6e 0a 09 09 09 20 20 20 20 20 28 62 65 67 69 6e n.... (begin
10fc0 0a 09 09 09 20 20 20 20 20 20 20 28 64 65 62 75 .... (debu
10fd0 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
10fe0 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 66 61 lt-log-port* "fa
10ff0 69 6c 65 64 20 74 6f 20 72 65 61 64 20 22 20 63 iled to read " c
11000 61 63 68 65 2d 66 69 6c 65 20 22 2c 20 65 78 6e ache-file ", exn
11010 3d 22 20 65 78 6e 29 0a 09 09 09 20 20 20 20 20 =" exn)....
11020 20 20 23 66 29 20 3b 3b 20 61 6e 79 20 69 73 73 #f) ;; any iss
11030 75 65 73 2c 20 6a 75 73 74 20 67 69 76 65 20 75 ues, just give u
11040 70 20 77 69 74 68 20 74 68 65 20 63 61 63 68 65 p with the cache
11050 64 20 76 65 72 73 69 6f 6e 20 61 6e 64 20 72 65 d version and re
11060 2d 72 65 61 64 0a 09 09 09 20 20 20 20 20 28 63 -read.... (c
11070 6f 6e 66 69 67 66 3a 72 65 61 64 2d 61 6c 69 73 onfigf:read-alis
11080 74 20 63 61 63 68 65 2d 66 69 6c 65 29 29 0a 09 t cache-file))..
11090 09 09 20 20 20 23 66 29 29 0a 20 20 20 20 20 20 .. #f)).
110a0 20 20 20 28 74 65 73 74 2d 66 75 6c 6c 2d 6e 61 (test-full-na
110b0 6d 65 20 28 69 66 20 28 61 6e 64 20 69 74 65 6d me (if (and item
110c0 2d 70 61 74 68 20 28 6e 6f 74 20 28 73 74 72 69 -path (not (stri
110d0 6e 67 2d 6e 75 6c 6c 3f 20 69 74 65 6d 2d 70 61 ng-null? item-pa
110e0 74 68 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 th))).
110f0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11100 20 20 20 28 63 6f 6e 63 20 74 65 73 74 2d 6e 61 (conc test-na
11110 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 me "/" item-path
11120 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
11130 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 74 t
11140 65 73 74 2d 6e 61 6d 65 29 29 29 0a 20 20 20 20 est-name))).
11150 28 69 66 20 63 61 63 68 65 64 2d 64 61 74 0a 09 (if cached-dat..
11160 63 61 63 68 65 64 2d 64 61 74 0a 09 28 6c 65 74 cached-dat..(let
11170 20 28 28 64 61 74 20 28 68 61 73 68 2d 74 61 62 ((dat (hash-tab
11180 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a le-ref/default *
11190 74 65 73 74 63 6f 6e 66 69 67 73 2a 20 74 65 73 testconfigs* tes
111a0 74 2d 66 75 6c 6c 2d 6e 61 6d 65 20 23 66 29 29 t-full-name #f))
111b0 29 0a 09 20 20 28 69 66 20 28 61 6e 64 20 20 64 ).. (if (and d
111c0 61 74 20 3b 3b 20 68 61 76 65 20 61 20 6c 6f 63 at ;; have a loc
111d0 61 6c 6c 79 20 63 61 63 68 65 64 20 76 65 72 73 ally cached vers
111e0 69 6f 6e 0a 09 09 20 20 20 20 28 68 61 73 68 2d ion... (hash-
111f0 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
11200 74 20 64 61 74 20 22 68 61 76 65 20 66 75 6c 6c t dat "have full
11210 64 61 74 61 22 20 23 66 29 29 20 3b 3b 20 6d 61 data" #f)) ;; ma
11220 72 6b 65 64 20 61 73 20 67 6f 6f 64 20 64 61 74 rked as good dat
11230 61 3f 0a 09 20 20 20 20 20 20 64 61 74 0a 09 20 a?.. dat..
11240 20 20 20 20 20 3b 3b 20 6e 6f 20 63 61 63 68 65 ;; no cache
11250 64 20 64 61 74 61 20 61 76 61 69 6c 61 62 6c 65 d data available
11260 0a 09 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 .. (let* ((
11270 74 72 65 67 20 20 20 20 20 20 20 20 20 28 6f 72 treg (or
11280 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 0a 09 test-registry..
11290 09 09 09 20 20 20 20 20 20 20 28 74 65 73 74 73 ... (tests
112a0 3a 67 65 74 2d 61 6c 6c 29 29 29 0a 09 09 20 20 :get-all)))...
112b0 20 20 20 28 74 65 73 74 2d 70 61 74 68 20 20 20 (test-path
112c0 20 28 6f 72 20 28 68 61 73 68 2d 74 61 62 6c 65 (or (hash-table
112d0 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 72 65 -ref/default tre
112e0 67 20 74 65 73 74 2d 6e 61 6d 65 20 23 66 29 0a g test-name #f).
112f0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11300 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11310 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 6c (let* ((l
11320 6f 63 61 6c 2d 74 63 64 69 72 20 28 63 6f 6e 63 ocal-tcdir (conc
11330 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 4c 49 4e (getenv "MT_LIN
11340 4b 54 52 45 45 22 29 20 22 2f 22 0a 20 20 20 20 KTREE") "/".
11350 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11360 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11370 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11380 20 20 20 20 20 20 20 20 20 20 20 20 20 28 67 65 (ge
11390 74 65 6e 76 20 22 4d 54 5f 54 41 52 47 45 54 22 tenv "MT_TARGET"
113a0 29 20 22 2f 22 0a 20 20 20 20 20 20 20 20 20 20 ) "/".
113b0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
113c0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
113d0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
113e0 20 20 20 20 20 20 20 28 67 65 74 65 6e 76 20 22 (getenv "
113f0 4d 54 5f 52 55 4e 4e 41 4d 45 22 29 20 22 2f 22 MT_RUNNAME") "/"
11400 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
11410 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11420 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11430 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11440 20 20 74 65 73 74 2d 6e 61 6d 65 20 22 2f 22 20 test-name "/"
11450 69 74 65 6d 2d 70 61 74 68 29 29 0a 20 20 20 20 item-path)).
11460 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11470 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11480 20 20 20 20 20 20 20 20 20 20 28 6c 6f 63 61 6c (local
11490 2d 74 63 66 67 20 28 63 6f 6e 63 20 6c 6f 63 61 -tcfg (conc loca
114a0 6c 2d 74 63 64 69 72 20 22 2f 74 65 73 74 63 6f l-tcdir "/testco
114b0 6e 66 69 67 22 29 29 29 0a 20 20 20 20 20 20 20 nfig"))).
114c0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
114d0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
114e0 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 66 69 (if (common:fi
114f0 6c 65 2d 65 78 69 73 74 73 3f 20 6c 6f 63 61 6c le-exists? local
11500 2d 74 63 66 67 29 0a 20 20 20 20 20 20 20 20 20 -tcfg).
11510 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11520 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11530 20 20 20 20 6c 6f 63 61 6c 2d 74 63 64 69 72 0a local-tcdir.
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 20 20 20 20 20 20 20 20 20 20 23 66 29 #f)
11570 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 63 6f )..... (co
11580 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 74 nc *toppath* "/t
11590 65 73 74 73 2f 22 20 74 65 73 74 2d 6e 61 6d 65 ests/" test-name
115a0 29 29 29 0a 09 09 20 20 20 20 20 28 74 65 73 74 )))... (test
115b0 2d 63 6f 6e 66 69 67 66 20 28 63 6f 6e 63 20 74 -configf (conc t
115c0 65 73 74 2d 70 61 74 68 20 22 2f 74 65 73 74 63 est-path "/testc
115d0 6f 6e 66 69 67 22 29 29 0a 09 09 20 20 20 20 20 onfig"))...
115e0 28 74 65 73 74 65 78 69 73 74 73 20 20 20 28 6c (testexists (l
115f0 65 74 20 6c 6f 6f 70 61 20 28 28 74 72 69 65 73 et loopa ((tries
11600 2d 6c 65 66 74 20 33 30 29 29 0a 20 20 20 20 20 -left 30)).
11610 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11620 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11630 28 63 6f 6e 64 0a 20 20 20 20 20 20 20 20 20 20 (cond.
11640 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11650 20 20 20 20 20 20 20 20 20 20 20 20 28 0a 20 20 (.
11660 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11670 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11680 20 20 20 20 20 28 61 6e 64 20 28 63 6f 6d 6d 6f (and (commo
11690 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 74 n:file-exists? t
116a0 65 73 74 2d 63 6f 6e 66 69 67 66 29 28 66 69 6c est-configf)(fil
116b0 65 2d 72 65 61 64 2d 61 63 63 65 73 73 3f 20 74 e-read-access? t
116c0 65 73 74 2d 63 6f 6e 66 69 67 66 29 29 0a 20 20 est-configf)).
116d0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
116e0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
116f0 20 20 20 20 20 23 74 29 0a 20 20 20 20 20 20 20 #t).
11700 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11710 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
11720 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
11730 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11740 20 20 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a (common:
11750 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 74 65 73 file-exists? tes
11760 74 2d 63 6f 6e 66 69 67 66 29 0a 20 20 20 20 20 t-configf).
11770 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11780 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11790 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
117a0 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
117b0 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 43 61 rt* "WARNING: Ca
117c0 6e 6e 6f 74 20 72 65 61 64 20 74 65 73 74 63 6f nnot read testco
117d0 6e 66 69 67 20 66 69 6c 65 3a 20 22 74 65 73 74 nfig file: "test
117e0 2d 63 6f 6e 66 69 67 66 29 0a 20 20 20 20 20 20 -configf).
117f0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11800 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11810 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 20 #f).
11820 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11830 20 20 20 20 20 20 20 20 20 20 20 28 0a 20 20 20 (.
11840 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11850 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11860 20 20 20 20 28 61 6e 64 20 77 61 69 74 2d 61 2d (and wait-a-
11870 6d 69 6e 75 74 65 20 28 3e 20 74 72 69 65 73 2d minute (> tries-
11880 6c 65 66 74 20 30 29 29 0a 20 20 20 20 20 20 20 left 0)).
11890 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
118a0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
118b0 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 (thread-sleep! 1
118c0 30 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 0).
118d0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
118e0 20 20 20 20 20 20 20 20 20 20 28 64 65 62 75 67 (debug
118f0 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
11900 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 t-log-port* "WAR
11910 4e 49 4e 47 3a 20 74 65 73 74 63 6f 6e 66 69 67 NING: testconfig
11920 20 66 69 6c 65 20 64 6f 65 73 20 6e 6f 74 20 65 file does not e
11930 78 69 73 74 3a 20 22 74 65 73 74 2d 63 6f 6e 66 xist: "test-conf
11940 69 67 66 22 20 77 69 6c 6c 20 72 65 74 72 79 20 igf" will retry
11950 69 6e 20 31 30 20 73 65 63 6f 6e 64 73 2e 20 20 in 10 seconds.
11960 54 72 69 65 73 20 6c 65 66 74 3a 20 22 74 72 69 Tries left: "tri
11970 65 73 2d 6c 65 66 74 29 20 3b 3b 20 42 42 3a 20 es-left) ;; BB:
11980 74 68 69 73 20 66 69 72 65 73 0a 20 20 20 20 20 this fires.
11990 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
119a0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
119b0 20 20 28 6c 6f 6f 70 61 20 28 73 75 62 31 20 74 (loopa (sub1 t
119c0 72 69 65 73 2d 6c 65 66 74 29 29 29 0a 20 20 20 ries-left))).
119d0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
119e0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
119f0 20 20 20 28 65 6c 73 65 0a 20 20 20 20 20 20 20 (else.
11a00 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11a10 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11a20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 2a (debug:print 2 *
11a30 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
11a40 2a 20 22 57 41 52 4e 49 4e 47 3a 20 74 65 73 74 * "WARNING: test
11a50 63 6f 6e 66 69 67 20 66 69 6c 65 20 64 6f 65 73 config file does
11a60 20 6e 6f 74 20 65 78 69 73 74 3a 20 22 74 65 73 not exist: "tes
11a70 74 2d 63 6f 6e 66 69 67 66 29 20 3b 3b 20 42 42 t-configf) ;; BB
11a80 3a 20 74 68 69 73 20 66 69 72 65 73 0a 20 20 20 : this fires.
11a90 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11aa0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11ab0 20 20 20 20 23 66 29 29 29 29 0a 09 09 20 20 20 #f))))...
11ac0 20 20 28 74 63 66 67 20 20 20 20 20 20 20 20 20 (tcfg
11ad0 28 69 66 20 74 65 73 74 65 78 69 73 74 73 0a 09 (if testexists..
11ae0 09 09 09 20 20 20 20 20 20 20 28 72 65 61 64 2d ... (read-
11af0 63 6f 6e 66 69 67 20 74 65 73 74 2d 63 6f 6e 66 config test-conf
11b00 69 67 66 20 23 66 20 73 79 73 74 65 6d 2d 61 6c igf #f system-al
11b10 6c 6f 77 65 64 0a 09 09 09 09 09 09 20 20 20 20 lowed.......
11b20 65 6e 76 69 72 6f 6e 2d 70 61 74 74 3a 20 28 69 environ-patt: (i
11b30 66 20 73 79 73 74 65 6d 2d 61 6c 6c 6f 77 65 64 f system-allowed
11b40 0a 09 09 09 09 09 09 09 09 20 20 20 20 20 20 22 ......... "
11b50 70 72 65 2d 6c 61 75 6e 63 68 2d 65 6e 76 2d 76 pre-launch-env-v
11b60 61 72 73 22 0a 09 09 09 09 09 09 09 09 20 20 20 ars".........
11b70 20 20 20 23 66 29 29 0a 09 09 09 09 20 20 20 20 #f)).....
11b80 20 20 20 23 66 29 29 29 0a 09 09 28 69 66 20 28 #f)))...(if (
11b90 61 6e 64 20 74 63 66 67 20 63 61 63 68 65 2d 66 and tcfg cache-f
11ba0 69 6c 65 29 20 28 68 61 73 68 2d 74 61 62 6c 65 ile) (hash-table
11bb0 2d 73 65 74 21 20 74 63 66 67 20 22 68 61 76 65 -set! tcfg "have
11bc0 20 66 75 6c 6c 64 61 74 61 22 20 23 74 29 29 20 fulldata" #t))
11bd0 3b 3b 20 6d 61 72 6b 20 74 68 69 73 20 61 73 20 ;; mark this as
11be0 66 75 6c 6c 79 20 72 65 61 64 20 64 61 74 61 0a fully read data.
11bf0 09 09 28 69 66 20 74 63 66 67 20 28 68 61 73 68 ..(if tcfg (hash
11c00 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a 74 65 73 -table-set! *tes
11c10 74 63 6f 6e 66 69 67 73 2a 20 74 65 73 74 2d 66 tconfigs* test-f
11c20 75 6c 6c 2d 6e 61 6d 65 20 74 63 66 67 29 29 0a ull-name tcfg)).
11c30 09 09 28 69 66 20 28 61 6e 64 20 74 65 73 74 65 ..(if (and teste
11c40 78 69 73 74 73 0a 09 09 09 20 63 61 63 68 65 2d xists.... cache-
11c50 66 69 6c 65 0a 09 09 09 20 28 66 69 6c 65 2d 77 file.... (file-w
11c60 72 69 74 65 2d 61 63 63 65 73 73 3f 20 63 61 63 rite-access? cac
11c70 68 65 2d 70 61 74 68 29 0a 09 09 09 20 61 6c 6c he-path).... all
11c80 6f 77 2d 77 72 69 74 65 2d 63 61 63 68 65 29 0a ow-write-cache).
11c90 09 09 20 20 20 20 28 6c 65 74 20 28 28 74 70 61 .. (let ((tpa
11ca0 74 68 20 28 63 6f 6e 63 20 63 61 63 68 65 2d 70 th (conc cache-p
11cb0 61 74 68 20 22 2f 2e 74 65 73 74 63 6f 6e 66 69 ath "/.testconfi
11cc0 67 22 29 29 29 0a 09 09 20 20 20 20 20 20 28 64 g")))... (d
11cd0 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
11ce0 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 1 *default-log-p
11cf0 6f 72 74 2a 20 22 43 61 63 68 69 6e 67 20 74 65 ort* "Caching te
11d00 73 74 63 6f 6e 66 69 67 20 66 6f 72 20 22 20 74 stconfig for " t
11d10 65 73 74 2d 6e 61 6d 65 20 22 20 69 6e 20 22 20 est-name " in "
11d20 74 70 61 74 68 29 0a 20 20 20 20 20 20 20 20 20 tpath).
11d30 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
11d40 20 28 61 6e 64 20 74 63 66 67 20 28 6e 6f 74 20 (and tcfg (not
11d50 28 63 6f 6d 6d 6f 6e 3a 69 6e 2d 72 75 6e 6e 69 (common:in-runni
11d60 6e 67 2d 74 65 73 74 3f 29 29 29 0a 20 20 20 20 ng-test?))).
11d70 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11d80 20 20 20 20 20 20 28 63 6f 6e 66 69 67 66 3a 77 (configf:w
11d90 72 69 74 65 2d 61 6c 69 73 74 20 74 63 66 67 20 rite-alist tcfg
11da0 74 70 61 74 68 29 29 29 29 0a 09 09 74 63 66 67 tpath))))...tcfg
11db0 29 29 29 29 29 29 0a 20 20 0a 3b 3b 20 73 6f 72 )))))). .;; sor
11dc0 74 20 74 65 73 74 73 20 62 79 20 70 72 69 6f 72 t tests by prior
11dd0 69 74 79 20 61 6e 64 20 77 61 69 74 6f 6e 0a 3b ity and waiton.;
11de0 3b 20 4d 6f 76 65 20 74 65 73 74 20 73 70 65 63 ; Move test spec
11df0 69 66 69 63 20 73 74 75 66 66 20 74 6f 20 61 20 ific stuff to a
11e00 74 65 73 74 20 75 6e 69 74 20 46 49 58 4d 45 20 test unit FIXME
11e10 6f 6e 65 20 6f 66 20 74 68 65 73 65 20 64 61 79 one of these day
11e20 73 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 s.(define (tests
11e30 3a 73 6f 72 74 2d 62 79 2d 70 72 69 6f 72 69 74 :sort-by-priorit
11e40 79 2d 61 6e 64 2d 77 61 69 74 6f 6e 20 74 65 73 y-and-waiton tes
11e50 74 2d 72 65 63 6f 72 64 73 29 0a 20 20 28 69 66 t-records). (if
11e60 20 28 65 71 3f 20 28 68 61 73 68 2d 74 61 62 6c (eq? (hash-tabl
11e70 65 2d 73 69 7a 65 20 74 65 73 74 2d 72 65 63 6f e-size test-reco
11e80 72 64 73 29 20 30 29 0a 20 20 20 20 20 20 27 28 rds) 0). '(
11e90 29 0a 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 ). (let* ((
11ea0 6d 75 6e 67 65 70 72 69 6f 72 69 74 79 20 28 6c mungepriority (l
11eb0 61 6d 62 64 61 20 28 70 72 69 6f 72 69 74 79 29 ambda (priority)
11ec0 0a 09 09 09 20 20 20 20 20 20 28 69 66 20 70 72 .... (if pr
11ed0 69 6f 72 69 74 79 0a 09 09 09 09 20 20 28 6c 65 iority..... (le
11ee0 74 20 28 28 74 6d 70 20 28 61 6e 79 2d 3e 6e 75 t ((tmp (any->nu
11ef0 6d 62 65 72 20 70 72 69 6f 72 69 74 79 29 29 29 mber priority)))
11f00 0a 09 09 09 09 20 20 20 20 28 69 66 20 74 6d 70 ..... (if tmp
11f10 20 74 6d 70 20 28 62 65 67 69 6e 20 28 64 65 62 tmp (begin (deb
11f20 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 ug:print-error 0
11f30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
11f40 72 74 2a 20 22 62 61 64 20 70 72 69 6f 72 69 74 rt* "bad priorit
11f50 79 20 76 61 6c 75 65 20 22 20 70 72 69 6f 72 69 y value " priori
11f60 74 79 20 22 2c 20 75 73 69 6e 67 20 30 22 29 20 ty ", using 0")
11f70 30 29 29 29 0a 09 09 09 09 20 20 30 29 29 29 0a 0)))..... 0))).
11f80 09 20 20 20 20 20 28 61 6c 6c 2d 74 65 73 74 73 . (all-tests
11f90 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c (hash-tabl
11fa0 65 2d 6b 65 79 73 20 74 65 73 74 2d 72 65 63 6f e-keys test-reco
11fb0 72 64 73 29 29 0a 09 20 20 20 20 20 28 61 6c 6c rds)).. (all
11fc0 2d 77 61 69 74 65 64 2d 6f 6e 20 20 28 6c 65 74 -waited-on (let
11fd0 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 61 72 loop ((hed (car
11fe0 20 61 6c 6c 2d 74 65 73 74 73 29 29 0a 09 09 09 all-tests))....
11ff0 09 09 28 74 61 6c 20 28 63 64 72 20 61 6c 6c 2d ..(tal (cdr all-
12000 74 65 73 74 73 29 29 0a 09 09 09 09 09 28 72 65 tests))......(re
12010 73 20 27 28 29 29 29 0a 09 09 09 20 20 20 20 20 s '()))....
12020 20 20 28 6c 65 74 2a 20 28 28 74 72 65 63 20 20 (let* ((trec
12030 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 (hash-table-re
12040 66 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 68 f test-records h
12050 65 64 29 29 0a 09 09 09 09 20 20 20 20 20 20 28 ed))..... (
12060 77 61 69 74 6f 6e 73 20 28 6f 72 20 28 74 65 73 waitons (or (tes
12070 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 ts:testqueue-get
12080 2d 77 61 69 74 6f 6e 73 20 74 72 65 63 29 20 27 -waitons trec) '
12090 28 29 29 29 29 0a 09 09 09 09 20 28 69 66 20 28 ())))..... (if (
120a0 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 09 09 20 null? tal).....
120b0 20 20 20 20 28 61 70 70 65 6e 64 20 72 65 73 20 (append res
120c0 77 61 69 74 6f 6e 73 29 0a 09 09 09 09 20 20 20 waitons).....
120d0 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c (loop (car tal
120e0 29 28 63 64 72 20 74 61 6c 29 28 61 70 70 65 6e )(cdr tal)(appen
120f0 64 20 72 65 73 20 77 61 69 74 6f 6e 73 29 29 29 d res waitons)))
12100 29 29 29 0a 09 20 20 20 20 20 28 73 6f 72 74 2d ))).. (sort-
12110 66 6e 31 20 0a 09 20 20 20 20 20 20 28 6c 61 6d fn1 .. (lam
12120 62 64 61 20 28 61 20 62 29 0a 09 09 28 6c 65 74 bda (a b)...(let
12130 2a 20 28 28 61 2d 72 65 63 6f 72 64 20 20 20 28 * ((a-record (
12140 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 74 hash-table-ref t
12150 65 73 74 2d 72 65 63 6f 72 64 73 20 61 29 29 0a est-records a)).
12160 09 09 20 20 20 20 20 20 20 28 62 2d 72 65 63 6f .. (b-reco
12170 72 64 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 rd (hash-table
12180 2d 72 65 66 20 74 65 73 74 2d 72 65 63 6f 72 64 -ref test-record
12190 73 20 62 29 29 0a 09 09 20 20 20 20 20 20 20 28 s b))... (
121a0 61 2d 77 61 69 74 6f 6e 73 20 20 28 6f 72 20 28 a-waitons (or (
121b0 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d tests:testqueue-
121c0 67 65 74 2d 77 61 69 74 6f 6e 73 20 61 2d 72 65 get-waitons a-re
121d0 63 6f 72 64 29 20 27 28 29 29 29 0a 09 09 20 20 cord) '()))...
121e0 20 20 20 20 20 28 62 2d 77 61 69 74 6f 6e 73 20 (b-waitons
121f0 20 28 6f 72 20 28 74 65 73 74 73 3a 74 65 73 74 (or (tests:test
12200 71 75 65 75 65 2d 67 65 74 2d 77 61 69 74 6f 6e queue-get-waiton
12210 73 20 62 2d 72 65 63 6f 72 64 29 20 27 28 29 29 s b-record) '())
12220 29 0a 09 09 20 20 20 20 20 20 20 28 61 2d 63 6f )... (a-co
12230 6e 66 69 67 20 20 20 28 74 65 73 74 73 3a 74 65 nfig (tests:te
12240 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 73 74 stqueue-get-test
12250 63 6f 6e 66 69 67 20 20 61 2d 72 65 63 6f 72 64 config a-record
12260 29 29 0a 09 09 20 20 20 20 20 20 20 28 62 2d 63 ))... (b-c
12270 6f 6e 66 69 67 20 20 20 28 74 65 73 74 73 3a 74 onfig (tests:t
12280 65 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 73 estqueue-get-tes
12290 74 63 6f 6e 66 69 67 20 20 62 2d 72 65 63 6f 72 tconfig b-recor
122a0 64 29 29 0a 09 09 20 20 20 20 20 20 20 28 61 2d d))... (a-
122b0 72 61 77 2d 70 72 69 20 20 28 63 6f 6e 66 69 67 raw-pri (config
122c0 66 3a 6c 6f 6f 6b 75 70 20 61 2d 63 6f 6e 66 69 f:lookup a-confi
122d0 67 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 22 g "requirements"
122e0 20 22 70 72 69 6f 72 69 74 79 22 29 29 0a 09 09 "priority"))...
122f0 20 20 20 20 20 20 20 28 62 2d 72 61 77 2d 70 72 (b-raw-pr
12300 69 20 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b i (configf:look
12310 75 70 20 62 2d 63 6f 6e 66 69 67 20 22 72 65 71 up b-config "req
12320 75 69 72 65 6d 65 6e 74 73 22 20 22 70 72 69 6f uirements" "prio
12330 72 69 74 79 22 29 29 0a 09 09 20 20 20 20 20 20 rity"))...
12340 20 28 61 2d 70 72 69 6f 72 69 74 79 20 28 6d 75 (a-priority (mu
12350 6e 67 65 70 72 69 6f 72 69 74 79 20 61 2d 72 61 ngepriority a-ra
12360 77 2d 70 72 69 29 29 0a 09 09 20 20 20 20 20 20 w-pri))...
12370 20 28 62 2d 70 72 69 6f 72 69 74 79 20 28 6d 75 (b-priority (mu
12380 6e 67 65 70 72 69 6f 72 69 74 79 20 62 2d 72 61 ngepriority b-ra
12390 77 2d 70 72 69 29 29 29 0a 09 09 20 20 28 74 65 w-pri)))... (te
123a0 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 73 65 sts:testqueue-se
123b0 74 2d 70 72 69 6f 72 69 74 79 21 20 61 2d 72 65 t-priority! a-re
123c0 63 6f 72 64 20 61 2d 70 72 69 6f 72 69 74 79 29 cord a-priority)
123d0 0a 09 09 20 20 28 74 65 73 74 73 3a 74 65 73 74 ... (tests:test
123e0 71 75 65 75 65 2d 73 65 74 2d 70 72 69 6f 72 69 queue-set-priori
123f0 74 79 21 20 62 2d 72 65 63 6f 72 64 20 62 2d 70 ty! b-record b-p
12400 72 69 6f 72 69 74 79 29 0a 09 09 20 20 3b 3b 20 riority)... ;;
12410 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
12420 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
12430 2a 20 22 61 3d 22 20 61 20 22 2c 20 62 3d 22 20 * "a=" a ", b="
12440 62 20 22 2c 20 61 2d 77 61 69 74 6f 6e 73 3d 22 b ", a-waitons="
12450 20 61 2d 77 61 69 74 6f 6e 73 20 22 2c 20 62 2d a-waitons ", b-
12460 77 61 69 74 6f 6e 73 3d 22 20 62 2d 77 61 69 74 waitons=" b-wait
12470 6f 6e 73 29 0a 09 09 20 20 28 63 6f 6e 64 0a 09 ons)... (cond..
12480 09 20 20 20 3b 3b 20 69 73 20 0a 09 09 20 20 20 . ;; is ...
12490 28 28 6d 65 6d 62 65 72 20 61 20 62 2d 77 61 69 ((member a b-wai
124a0 74 6f 6e 73 29 20 20 20 20 20 20 20 20 20 20 3b tons) ;
124b0 3b 20 69 73 20 62 20 77 61 69 74 69 6e 67 20 6f ; is b waiting o
124c0 6e 20 61 3f 0a 09 09 20 20 20 20 3b 3b 20 28 64 n a?... ;; (d
124d0 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
124e0 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
124f0 22 63 61 73 65 31 22 29 0a 09 09 20 20 20 20 23 "case1")... #
12500 74 29 0a 09 09 20 20 20 28 28 6d 65 6d 62 65 72 t)... ((member
12510 20 62 20 61 2d 77 61 69 74 6f 6e 73 29 20 20 20 b a-waitons)
12520 20 20 20 20 20 20 20 3b 3b 20 69 73 20 61 20 77 ;; is a w
12530 61 69 74 69 6e 67 20 6f 6e 20 62 3f 0a 09 09 20 aiting on b?...
12540 20 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 ;; (debug:pri
12550 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
12560 67 2d 70 6f 72 74 2a 20 22 63 61 73 65 32 22 29 g-port* "case2")
12570 0a 09 09 20 20 20 20 23 66 29 0a 09 09 20 20 20 ... #f)...
12580 28 28 61 6e 64 20 28 6e 6f 74 20 28 6e 75 6c 6c ((and (not (null
12590 3f 20 61 2d 77 61 69 74 6f 6e 73 29 29 20 20 3b ? a-waitons)) ;
125a0 3b 20 62 6f 74 68 20 68 61 76 65 20 77 61 69 74 ; both have wait
125b0 6f 6e 73 20 2d 20 64 6f 20 6e 6f 74 20 64 69 73 ons - do not dis
125c0 74 75 72 62 0a 09 09 09 20 28 6e 6f 74 20 28 6e turb.... (not (n
125d0 75 6c 6c 3f 20 62 2d 77 61 69 74 6f 6e 73 29 29 ull? b-waitons))
125e0 29 0a 09 09 20 20 20 20 3b 3b 20 28 64 65 62 75 )... ;; (debu
125f0 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
12600 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 63 61 lt-log-port* "ca
12610 73 65 32 2e 31 22 29 0a 09 09 20 20 20 20 23 74 se2.1")... #t
12620 29 0a 09 09 20 20 20 28 28 61 6e 64 20 28 6e 75 )... ((and (nu
12630 6c 6c 3f 20 61 2d 77 61 69 74 6f 6e 73 29 20 20 ll? a-waitons)
12640 20 20 20 20 20 20 3b 3b 20 6e 6f 20 77 61 69 74 ;; no wait
12650 6f 6e 73 20 66 6f 72 20 61 20 62 75 74 20 62 20 ons for a but b
12660 68 61 73 20 77 61 69 74 6f 6e 73 0a 09 09 09 20 has waitons....
12670 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 62 2d 77 61 (not (null? b-wa
12680 69 74 6f 6e 73 29 29 29 0a 09 09 20 20 20 20 3b itons)))... ;
12690 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 ; (debug:print 0
126a0 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
126b0 72 74 2a 20 22 63 61 73 65 33 22 29 0a 09 09 20 rt* "case3")...
126c0 20 20 20 23 66 29 0a 09 09 20 20 20 28 28 61 6e #f)... ((an
126d0 64 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 61 2d d (not (null? a-
126e0 77 61 69 74 6f 6e 73 29 29 20 20 3b 3b 20 61 20 waitons)) ;; a
126f0 68 61 73 20 77 61 69 74 6f 6e 73 20 62 75 74 20 has waitons but
12700 62 20 64 6f 65 73 20 6e 6f 74 0a 09 09 09 20 28 b does not.... (
12710 6e 75 6c 6c 3f 20 62 2d 77 61 69 74 6f 6e 73 29 null? b-waitons)
12720 29 20 0a 09 09 20 20 20 20 3b 3b 20 28 64 65 62 ) ... ;; (deb
12730 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
12740 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 63 ult-log-port* "c
12750 61 73 65 34 22 29 0a 09 09 20 20 20 20 23 74 29 ase4")... #t)
12760 0a 09 09 20 20 20 28 28 6e 6f 74 20 28 65 71 3f ... ((not (eq?
12770 20 61 2d 70 72 69 6f 72 69 74 79 20 62 2d 70 72 a-priority b-pr
12780 69 6f 72 69 74 79 29 29 20 3b 3b 20 75 73 65 0a iority)) ;; use.
12790 09 09 20 20 20 20 28 3e 20 61 2d 70 72 69 6f 72 .. (> a-prior
127a0 69 74 79 20 62 2d 70 72 69 6f 72 69 74 79 29 29 ity b-priority))
127b0 0a 09 09 20 20 20 28 65 6c 73 65 0a 09 09 20 20 ... (else...
127c0 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e ;; (debug:prin
127d0 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
127e0 2d 70 6f 72 74 2a 20 22 63 61 73 65 35 22 29 0a -port* "case5").
127f0 09 09 20 20 20 20 28 73 74 72 69 6e 67 3e 3f 20 .. (string>?
12800 61 20 62 29 29 29 29 29 29 0a 09 20 20 20 20 20 a b))))))..
12810 0a 09 20 20 20 20 20 28 73 6f 72 74 2d 66 6e 32 .. (sort-fn2
12820 0a 09 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 .. (lambda
12830 28 61 20 62 29 0a 09 09 28 3e 20 28 6d 75 6e 67 (a b)...(> (mung
12840 65 70 72 69 6f 72 69 74 79 20 28 74 65 73 74 73 epriority (tests
12850 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 70 :testqueue-get-p
12860 72 69 6f 72 69 74 79 20 28 68 61 73 68 2d 74 61 riority (hash-ta
12870 62 6c 65 2d 72 65 66 20 74 65 73 74 2d 72 65 63 ble-ref test-rec
12880 6f 72 64 73 20 61 29 29 29 0a 09 09 20 20 20 28 ords a)))... (
12890 6d 75 6e 67 65 70 72 69 6f 72 69 74 79 20 28 74 mungepriority (t
128a0 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 ests:testqueue-g
128b0 65 74 2d 70 72 69 6f 72 69 74 79 20 28 68 61 73 et-priority (has
128c0 68 2d 74 61 62 6c 65 2d 72 65 66 20 74 65 73 74 h-table-ref test
128d0 2d 72 65 63 6f 72 64 73 20 62 29 29 29 29 29 29 -records b))))))
128e0 29 0a 09 3b 3b 20 28 6c 65 74 20 28 28 64 6f 74 )..;; (let ((dot
128f0 2d 72 65 73 20 28 74 65 73 74 73 3a 72 75 6e 2d -res (tests:run-
12900 64 6f 74 20 28 74 65 73 74 73 3a 74 65 73 74 73 dot (tests:tests
12910 2d 3e 64 6f 74 20 74 65 73 74 2d 72 65 63 6f 72 ->dot test-recor
12920 64 73 29 20 22 70 6c 61 69 6e 22 29 29 29 0a 09 ds) "plain")))..
12930 3b 3b 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e ;; (debug:prin
12940 74 20 22 64 6f 74 2d 72 65 73 3d 22 20 64 6f 74 t "dot-res=" dot
12950 2d 72 65 73 29 29 0a 09 3b 3b 20 28 6c 65 74 20 -res))..;; (let
12960 28 28 64 61 74 61 20 28 6d 61 70 20 63 64 72 20 ((data (map cdr
12970 28 66 69 6c 74 65 72 0a 09 3b 3b 20 20 20 20 20 (filter..;;
12980 09 09 20 20 28 6c 61 6d 62 64 61 20 28 78 29 28 .. (lambda (x)(
12990 65 71 75 61 6c 3f 20 22 6e 6f 64 65 22 20 28 63 equal? "node" (c
129a0 61 72 20 78 29 29 29 0a 09 3b 3b 20 20 20 20 20 ar x)))..;;
129b0 09 09 20 20 28 6d 61 70 20 73 74 72 69 6e 67 2d .. (map string-
129c0 73 70 6c 69 74 20 28 74 65 73 74 73 3a 65 61 73 split (tests:eas
129d0 79 2d 64 6f 74 20 74 65 73 74 2d 72 65 63 6f 72 y-dot test-recor
129e0 64 73 20 22 70 6c 61 69 6e 22 29 29 29 29 29 29 ds "plain"))))))
129f0 0a 09 3b 3b 20 20 20 28 6d 61 70 20 63 61 72 20 ..;; (map car
12a00 28 73 6f 72 74 20 64 61 74 61 20 28 6c 61 6d 62 (sort data (lamb
12a10 64 61 20 28 61 20 62 29 0a 09 3b 3b 20 20 20 20 da (a b)..;;
12a20 20 09 09 20 20 20 20 28 3e 20 28 73 74 72 69 6e .. (> (strin
12a30 67 2d 3e 6e 75 6d 62 65 72 20 28 63 61 64 64 72 g->number (caddr
12a40 20 61 29 29 28 73 74 72 69 6e 67 2d 3e 6e 75 6d a))(string->num
12a50 62 65 72 20 28 63 61 64 64 72 20 62 29 29 29 29 ber (caddr b))))
12a60 29 29 29 0a 09 3b 3b 20 29 29 0a 09 28 73 6f 72 )))..;; ))..(sor
12a70 74 20 61 6c 6c 2d 74 65 73 74 73 20 73 6f 72 74 t all-tests sort
12a80 2d 66 6e 31 29 29 29 29 20 3b 3b 20 61 76 6f 69 -fn1)))) ;; avoi
12a90 64 20 64 65 61 6c 69 6e 67 20 77 69 74 68 20 64 d dealing with d
12aa0 65 6c 65 74 65 64 20 74 65 73 74 73 2c 20 6c 6f eleted tests, lo
12ab0 6f 6b 20 61 74 20 74 68 65 20 68 61 73 68 20 74 ok at the hash t
12ac0 61 62 6c 65 0a 0a 28 64 65 66 69 6e 65 20 28 74 able..(define (t
12ad0 65 73 74 73 3a 65 61 73 79 2d 64 6f 74 20 74 65 ests:easy-dot te
12ae0 73 74 2d 72 65 63 6f 72 64 73 20 6f 75 74 74 79 st-records outty
12af0 70 65 29 0a 20 20 28 6c 65 74 2d 76 61 6c 75 65 pe). (let-value
12b00 73 20 28 28 28 66 64 20 74 65 6d 70 2d 70 61 74 s (((fd temp-pat
12b10 68 29 20 28 66 69 6c 65 2d 6d 6b 73 74 65 6d 70 h) (file-mkstemp
12b20 20 28 63 6f 6e 63 20 22 2f 74 6d 70 2f 22 20 28 (conc "/tmp/" (
12b30 63 75 72 72 65 6e 74 2d 75 73 65 72 2d 6e 61 6d current-user-nam
12b40 65 29 20 22 2e 58 58 58 58 58 58 22 29 29 29 29 e) ".XXXXXX"))))
12b50 0a 20 20 20 20 28 6c 65 74 20 28 28 61 6c 6c 2d . (let ((all-
12b60 74 65 73 74 6e 61 6d 65 73 20 28 68 61 73 68 2d testnames (hash-
12b70 74 61 62 6c 65 2d 6b 65 79 73 20 74 65 73 74 2d table-keys test-
12b80 72 65 63 6f 72 64 73 29 29 0a 09 20 20 28 74 65 records)).. (te
12b90 6d 70 2d 70 6f 72 74 20 20 20 20 20 28 6f 70 65 mp-port (ope
12ba0 6e 2d 6f 75 74 70 75 74 2d 66 69 6c 65 2a 20 66 n-output-file* f
12bb0 64 29 29 29 0a 20 20 20 20 20 20 3b 3b 20 28 66 d))). ;; (f
12bc0 6f 72 6d 61 74 20 74 65 6d 70 2d 70 6f 72 74 20 ormat temp-port
12bd0 22 54 68 69 73 20 66 69 6c 65 20 69 73 20 7e 41 "This file is ~A
12be0 2e 7e 25 22 20 74 65 6d 70 2d 70 61 74 68 29 0a .~%" temp-path).
12bf0 20 20 20 20 20 20 28 66 6f 72 6d 61 74 20 74 65 (format te
12c00 6d 70 2d 70 6f 72 74 20 22 64 69 67 72 61 70 68 mp-port "digraph
12c10 20 74 65 73 74 73 20 7b 5c 6e 22 29 0a 20 20 20 tests {\n").
12c20 20 20 20 28 66 6f 72 6d 61 74 20 74 65 6d 70 2d (format temp-
12c30 70 6f 72 74 20 22 20 20 73 69 7a 65 3d 34 2c 38 port " size=4,8
12c40 5c 6e 22 29 0a 20 20 20 20 20 20 3b 3b 20 28 66 \n"). ;; (f
12c50 6f 72 6d 61 74 20 74 65 6d 70 2d 70 6f 72 74 20 ormat temp-port
12c60 22 20 20 20 73 70 6c 69 6e 65 73 3d 6e 6f 6e 65 " splines=none
12c70 5c 6e 22 29 0a 20 20 20 20 20 20 28 66 6f 72 2d \n"). (for-
12c80 65 61 63 68 0a 20 20 20 20 20 20 20 28 6c 61 6d each. (lam
12c90 62 64 61 20 28 74 65 73 74 6e 61 6d 65 29 0a 09 bda (testname)..
12ca0 20 28 6c 65 74 2a 20 28 28 74 65 73 74 72 65 63 (let* ((testrec
12cb0 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
12cc0 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 74 65 test-records te
12cd0 73 74 6e 61 6d 65 29 29 0a 09 09 28 77 61 69 74 stname))...(wait
12ce0 6f 6e 73 20 28 6f 72 20 28 74 65 73 74 73 3a 74 ons (or (tests:t
12cf0 65 73 74 71 75 65 75 65 2d 67 65 74 2d 77 61 69 estqueue-get-wai
12d00 74 6f 6e 73 20 74 65 73 74 72 65 63 29 20 27 28 tons testrec) '(
12d10 29 29 29 29 0a 09 20 20 20 28 66 6f 72 2d 65 61 )))).. (for-ea
12d20 63 68 0a 09 20 20 20 20 28 6c 61 6d 62 64 61 20 ch.. (lambda
12d30 28 77 61 69 74 6f 6e 29 0a 09 20 20 20 20 20 20 (waiton)..
12d40 28 66 6f 72 6d 61 74 20 74 65 6d 70 2d 70 6f 72 (format temp-por
12d50 74 20 28 63 6f 6e 63 20 22 20 20 20 22 20 77 61 t (conc " " wa
12d60 69 74 6f 6e 20 22 20 2d 3e 20 22 20 74 65 73 74 iton " -> " test
12d70 6e 61 6d 65 20 22 20 5b 73 70 6c 69 6e 65 73 3d name " [splines=
12d80 6f 72 74 68 6f 5d 5c 6e 22 29 29 29 0a 09 20 20 ortho]\n")))..
12d90 20 20 77 61 69 74 6f 6e 73 29 29 29 0a 20 20 20 waitons))).
12da0 20 20 20 20 61 6c 6c 2d 74 65 73 74 6e 61 6d 65 all-testname
12db0 73 29 0a 20 20 20 20 20 20 28 66 6f 72 6d 61 74 s). (format
12dc0 20 74 65 6d 70 2d 70 6f 72 74 20 22 7d 5c 6e 22 temp-port "}\n"
12dd0 29 0a 20 20 20 20 20 20 28 63 6c 6f 73 65 2d 6f ). (close-o
12de0 75 74 70 75 74 2d 70 6f 72 74 20 74 65 6d 70 2d utput-port temp-
12df0 70 6f 72 74 29 0a 20 20 20 20 20 20 28 77 69 74 port). (wit
12e00 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 h-input-from-pip
12e10 65 0a 20 20 20 20 20 20 20 28 63 6f 6e 63 20 22 e. (conc "
12e20 65 6e 76 20 2d 69 20 50 41 54 48 3d 24 50 41 54 env -i PATH=$PAT
12e30 48 20 64 6f 74 20 2d 54 22 20 6f 75 74 74 79 70 H dot -T" outtyp
12e40 65 20 22 20 3c 20 22 20 74 65 6d 70 2d 70 61 74 e " < " temp-pat
12e50 68 29 0a 20 20 20 20 20 20 20 28 6c 61 6d 62 64 h). (lambd
12e60 61 20 28 29 0a 09 20 28 6c 65 74 20 28 28 72 65 a ().. (let ((re
12e70 73 20 28 72 65 61 64 2d 6c 69 6e 65 73 29 29 29 s (read-lines)))
12e80 0a 09 20 20 20 3b 3b 20 28 64 65 6c 65 74 65 2d .. ;; (delete-
12e90 66 69 6c 65 20 74 65 6d 70 2d 70 61 74 68 29 0a file temp-path).
12ea0 09 20 20 20 72 65 73 29 29 29 29 29 29 0a 0a 28 . res))))))..(
12eb0 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 77 72 define (tests:wr
12ec0 69 74 65 2d 64 6f 74 2d 66 69 6c 65 20 74 65 73 ite-dot-file tes
12ed0 74 2d 72 65 63 6f 72 64 73 20 66 6e 61 6d 65 20 t-records fname
12ee0 73 69 7a 65 78 20 73 69 7a 65 79 29 0a 20 20 28 sizex sizey). (
12ef0 69 66 20 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 if (file-write-a
12f00 63 63 65 73 73 3f 20 28 70 61 74 68 6e 61 6d 65 ccess? (pathname
12f10 2d 64 69 72 65 63 74 6f 72 79 20 66 6e 61 6d 65 -directory fname
12f20 29 29 0a 20 20 20 20 20 20 28 77 69 74 68 2d 6f )). (with-o
12f30 75 74 70 75 74 2d 74 6f 2d 66 69 6c 65 20 66 6e utput-to-file fn
12f40 61 6d 65 0a 09 28 6c 61 6d 62 64 61 20 28 29 0a ame..(lambda ().
12f50 09 20 20 28 6d 61 70 20 70 72 69 6e 74 20 28 74 . (map print (t
12f60 65 73 74 73 3a 74 65 73 74 73 2d 3e 64 6f 74 20 ests:tests->dot
12f70 74 65 73 74 2d 72 65 63 6f 72 64 73 20 73 69 7a test-records siz
12f80 65 78 20 73 69 7a 65 79 29 29 29 29 29 29 0a 0a ex sizey))))))..
12f90 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 74 (define (tests:t
12fa0 65 73 74 73 2d 3e 64 6f 74 20 74 65 73 74 2d 72 ests->dot test-r
12fb0 65 63 6f 72 64 73 20 73 69 7a 65 78 20 73 69 7a ecords sizex siz
12fc0 65 79 29 0a 20 20 28 6c 65 74 20 28 28 61 6c 6c ey). (let ((all
12fd0 2d 74 65 73 74 6e 61 6d 65 73 20 28 68 61 73 68 -testnames (hash
12fe0 2d 74 61 62 6c 65 2d 6b 65 79 73 20 74 65 73 74 -table-keys test
12ff0 2d 72 65 63 6f 72 64 73 29 29 29 0a 20 20 20 20 -records))).
13000 28 69 66 20 28 6e 75 6c 6c 3f 20 61 6c 6c 2d 74 (if (null? all-t
13010 65 73 74 6e 61 6d 65 73 29 0a 09 27 28 29 0a 09 estnames)..'()..
13020 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 (let loop ((hed
13030 28 63 61 72 20 61 6c 6c 2d 74 65 73 74 6e 61 6d (car all-testnam
13040 65 73 29 29 0a 09 09 20 20 20 28 74 61 6c 20 28 es))... (tal (
13050 63 64 72 20 61 6c 6c 2d 74 65 73 74 6e 61 6d 65 cdr all-testname
13060 73 29 29 0a 09 09 20 20 20 28 72 65 73 20 28 6c s))... (res (l
13070 69 73 74 20 22 64 69 67 72 61 70 68 20 74 65 73 ist "digraph tes
13080 74 73 20 7b 22 0a 09 09 09 20 20 20 20 20 20 28 ts {".... (
13090 63 6f 6e 63 20 22 20 73 69 7a 65 3d 5c 22 22 20 conc " size=\""
130a0 28 6f 72 20 73 69 7a 65 78 20 31 31 29 20 22 2c (or sizex 11) ",
130b0 22 20 28 6f 72 20 73 69 7a 65 79 20 31 31 29 20 " (or sizey 11)
130c0 22 5c 22 3b 22 29 0a 09 09 09 20 20 20 20 20 20 "\";")....
130d0 22 20 72 61 74 69 6f 3d 30 2e 39 35 3b 22 0a 09 " ratio=0.95;"..
130e0 09 09 20 20 20 20 20 20 29 29 29 0a 09 20 20 28 .. ))).. (
130f0 6c 65 74 2a 20 28 28 74 65 73 74 72 65 63 20 28 let* ((testrec (
13100 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 74 hash-table-ref t
13110 65 73 74 2d 72 65 63 6f 72 64 73 20 68 65 64 29 est-records hed)
13120 29 0a 09 09 20 28 77 61 69 74 6f 6e 73 20 28 6f )... (waitons (o
13130 72 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 r (tests:testque
13140 75 65 2d 67 65 74 2d 77 61 69 74 6f 6e 73 20 74 ue-get-waitons t
13150 65 73 74 72 65 63 29 20 27 28 29 29 29 0a 09 09 estrec) '()))...
13160 20 28 6e 65 77 72 65 73 20 20 28 61 70 70 65 6e (newres (appen
13170 64 20 72 65 73 0a 09 09 09 09 20 20 28 69 66 20 d res..... (if
13180 28 6e 75 6c 6c 3f 20 77 61 69 74 6f 6e 73 29 0a (null? waitons).
13190 09 09 09 09 20 20 20 20 20 20 28 6c 69 73 74 20 .... (list
131a0 28 63 6f 6e 63 20 22 20 20 20 5c 22 22 20 68 65 (conc " \"" he
131b0 64 20 22 5c 22 20 5b 73 68 61 70 65 3d 62 6f 78 d "\" [shape=box
131c0 5d 3b 22 29 29 0a 09 09 09 09 20 20 20 20 20 20 ];")).....
131d0 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 77 61 (map (lambda (wa
131e0 69 74 6f 6e 29 0a 09 09 09 09 09 20 20 20 20 20 iton)......
131f0 28 63 6f 6e 63 20 22 20 20 20 5c 22 22 20 77 61 (conc " \"" wa
13200 69 74 6f 6e 20 22 5c 22 20 2d 3e 20 5c 22 22 20 iton "\" -> \""
13210 68 65 64 20 22 5c 22 20 5b 73 68 61 70 65 3d 62 hed "\" [shape=b
13220 6f 78 5d 3b 22 29 29 0a 09 09 09 09 09 20 20 20 ox];"))......
13230 77 61 69 74 6f 6e 73 29 0a 09 09 09 09 20 20 20 waitons).....
13240 20 20 20 29 29 29 29 0a 09 20 20 20 20 28 69 66 )))).. (if
13250 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 28 (null? tal)...(
13260 61 70 70 65 6e 64 20 6e 65 77 72 65 73 20 28 6c append newres (l
13270 69 73 74 20 22 7d 22 29 29 0a 09 09 28 6c 6f 6f ist "}"))...(loo
13280 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 p (car tal)(cdr
13290 74 61 6c 29 20 6e 65 77 72 65 73 29 0a 09 09 29 tal) newres)...)
132a0 29 29 29 29 29 0a 0a 3b 3b 20 28 74 65 73 74 73 )))))..;; (tests
132b0 3a 72 75 6e 2d 64 6f 74 20 28 6c 69 73 74 20 22 :run-dot (list "
132c0 64 69 67 72 61 70 68 20 74 65 73 74 73 20 7b 22 digraph tests {"
132d0 20 22 61 20 2d 3e 20 62 22 20 22 7d 22 29 20 22 "a -> b" "}") "
132e0 70 6c 61 69 6e 22 29 0a 0a 28 64 65 66 69 6e 65 plain")..(define
132f0 20 28 74 65 73 74 73 3a 72 75 6e 2d 64 6f 74 20 (tests:run-dot
13300 69 6e 64 61 74 20 6f 75 74 74 79 70 65 29 20 3b indat outtype) ;
13310 3b 20 6f 75 74 74 79 70 65 20 69 73 20 70 6c 61 ; outtype is pla
13320 69 6e 2c 20 66 69 67 2c 20 64 6f 74 2c 20 65 74 in, fig, dot, et
13330 63 2e 20 68 74 74 70 3a 2f 2f 77 77 77 2e 67 72 c. http://www.gr
13340 61 70 68 76 69 7a 2e 6f 72 67 2f 63 6f 6e 74 65 aphviz.org/conte
13350 6e 74 2f 6f 75 74 70 75 74 2d 66 6f 72 6d 61 74 nt/output-format
13360 73 0a 20 20 28 6c 65 74 2d 76 61 6c 75 65 73 20 s. (let-values
13370 28 28 28 69 6e 70 20 6f 75 70 20 70 69 64 29 28 (((inp oup pid)(
13380 70 72 6f 63 65 73 73 20 22 65 6e 76 20 2d 69 20 process "env -i
13390 50 41 54 48 3d 24 50 41 54 48 20 64 6f 74 22 20 PATH=$PATH dot"
133a0 28 6c 69 73 74 20 22 2d 54 22 20 6f 75 74 74 79 (list "-T" outty
133b0 70 65 29 29 29 29 0a 20 20 20 20 28 77 69 74 68 pe)))). (with
133c0 2d 6f 75 74 70 75 74 2d 74 6f 2d 70 6f 72 74 20 -output-to-port
133d0 6f 75 70 0a 20 20 20 20 20 20 28 6c 61 6d 62 64 oup. (lambd
133e0 61 20 28 29 0a 09 28 6d 61 70 20 70 72 69 6e 74 a ()..(map print
133f0 20 69 6e 64 61 74 29 29 29 0a 20 20 20 20 28 63 indat))). (c
13400 6c 6f 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 lose-output-port
13410 20 6f 75 70 29 0a 20 20 20 20 28 6c 65 74 20 28 oup). (let (
13420 28 72 65 73 20 28 77 69 74 68 2d 69 6e 70 75 74 (res (with-input
13430 2d 66 72 6f 6d 2d 70 6f 72 74 20 69 6e 70 0a 09 -from-port inp..
13440 09 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 20 . (lambda ()...
13450 20 20 28 72 65 61 64 2d 6c 69 6e 65 73 29 29 29 (read-lines)))
13460 29 29 0a 20 20 20 20 20 20 28 63 6c 6f 73 65 2d )). (close-
13470 69 6e 70 75 74 2d 70 6f 72 74 20 69 6e 70 29 0a input-port inp).
13480 20 20 20 20 20 20 72 65 73 29 29 29 0a 0a 3b 3b res)))..;;
13490 20 72 65 61 64 20 64 61 74 61 20 66 72 6f 6d 20 read data from
134a0 74 6d 70 20 66 69 6c 65 20 6f 72 20 63 72 65 61 tmp file or crea
134b0 74 65 20 69 66 20 6e 6f 74 20 65 78 69 73 74 73 te if not exists
134c0 0a 3b 3b 20 69 66 20 65 78 69 73 74 73 20 72 65 .;; if exists re
134d0 67 65 6e 20 69 6e 20 62 61 63 6b 67 72 6f 75 6e gen in backgroun
134e0 64 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 65 d.;;.(define (te
134f0 73 74 73 3a 6c 61 7a 79 2d 64 6f 74 20 74 65 73 sts:lazy-dot tes
13500 74 72 65 63 6f 72 64 73 20 20 6f 75 74 74 79 70 trecords outtyp
13510 65 20 73 69 7a 65 78 20 73 69 7a 65 79 29 0a 20 e sizex sizey).
13520 20 28 6c 65 74 20 28 28 64 66 69 6c 65 20 28 63 (let ((dfile (c
13530 6f 6e 63 20 22 2f 74 6d 70 2f 2e 22 20 28 63 75 onc "/tmp/." (cu
13540 72 72 65 6e 74 2d 75 73 65 72 2d 6e 61 6d 65 29 rrent-user-name)
13550 20 22 2d 22 20 28 73 65 72 76 65 72 3a 6d 6b 2d "-" (server:mk-
13560 73 69 67 6e 61 74 75 72 65 29 20 22 2e 64 6f 74 signature) ".dot
13570 22 29 29 0a 09 28 66 6e 61 6d 65 20 28 63 6f 6e "))..(fname (con
13580 63 20 22 2f 74 6d 70 2f 2e 22 20 28 63 75 72 72 c "/tmp/." (curr
13590 65 6e 74 2d 75 73 65 72 2d 6e 61 6d 65 29 20 22 ent-user-name) "
135a0 2d 22 20 28 73 65 72 76 65 72 3a 6d 6b 2d 73 69 -" (server:mk-si
135b0 67 6e 61 74 75 72 65 29 20 22 2e 64 6f 74 64 61 gnature) ".dotda
135c0 74 22 29 29 29 0a 20 20 20 20 28 74 65 73 74 73 t"))). (tests
135d0 3a 77 72 69 74 65 2d 64 6f 74 2d 66 69 6c 65 20 :write-dot-file
135e0 74 65 73 74 72 65 63 6f 72 64 73 20 64 66 69 6c testrecords dfil
135f0 65 20 73 69 7a 65 78 20 73 69 7a 65 79 29 0a 20 e sizex sizey).
13600 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 66 (if (common:f
13610 69 6c 65 2d 65 78 69 73 74 73 3f 20 66 6e 61 6d ile-exists? fnam
13620 65 29 0a 09 28 6c 65 74 20 28 28 72 65 73 20 28 e)..(let ((res (
13630 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d with-input-from-
13640 66 69 6c 65 20 66 6e 61 6d 65 0a 09 09 20 20 20 file fname...
13650 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 20 (lambda ()...
13660 20 20 20 20 20 20 28 72 65 61 64 2d 6c 69 6e 65 (read-line
13670 73 29 29 29 29 29 0a 09 20 20 28 73 79 73 74 65 s))))).. (syste
13680 6d 20 28 63 6f 6e 63 20 22 65 6e 76 20 2d 69 20 m (conc "env -i
13690 50 41 54 48 3d 24 50 41 54 48 20 64 6f 74 20 2d PATH=$PATH dot -
136a0 54 20 22 20 6f 75 74 74 79 70 65 20 22 20 3c 20 T " outtype " <
136b0 22 20 64 66 69 6c 65 20 22 20 3e 20 22 20 66 6e " dfile " > " fn
136c0 61 6d 65 20 22 26 22 29 29 0a 09 20 20 72 65 73 ame "&")).. res
136d0 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 73 79 )..(begin.. (sy
136e0 73 74 65 6d 20 28 63 6f 6e 63 20 22 65 6e 76 20 stem (conc "env
136f0 2d 69 20 50 41 54 48 3d 24 50 41 54 48 20 64 6f -i PATH=$PATH do
13700 74 20 2d 54 20 22 20 6f 75 74 74 79 70 65 20 22 t -T " outtype "
13710 20 3c 20 22 20 64 66 69 6c 65 20 22 20 3e 20 22 < " dfile " > "
13720 20 66 6e 61 6d 65 29 29 0a 09 20 20 28 77 69 74 fname)).. (wit
13730 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 66 69 6c h-input-from-fil
13740 65 20 66 6e 61 6d 65 0a 09 20 20 20 20 28 6c 61 e fname.. (la
13750 6d 62 64 61 20 28 29 0a 09 20 20 20 20 20 20 28 mbda ().. (
13760 72 65 61 64 2d 6c 69 6e 65 73 29 29 29 29 29 29 read-lines))))))
13770 29 0a 09 20 20 0a 0a 3b 3b 20 66 6f 72 20 65 61 ).. ..;; for ea
13780 63 68 20 74 65 73 74 3a 0a 3b 3b 20 20 20 0a 28 ch test:.;; .(
13790 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 66 69 define (tests:fi
137a0 6c 74 65 72 2d 6e 6f 6e 2d 72 75 6e 6e 61 62 6c lter-non-runnabl
137b0 65 20 72 75 6e 2d 69 64 20 74 65 73 74 6b 65 79 e run-id testkey
137c0 6e 61 6d 65 73 20 74 65 73 74 72 65 63 6f 72 64 names testrecord
137d0 73 68 61 73 68 29 0a 20 20 28 6c 65 74 20 28 28 shash). (let ((
137e0 72 75 6e 6e 61 62 6c 65 73 20 27 28 29 29 29 0a runnables '())).
137f0 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 (for-each.
13800 20 20 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 (lambda (test
13810 6b 65 79 6e 61 6d 65 29 0a 20 20 20 20 20 20 20 keyname).
13820 28 6c 65 74 2a 20 28 28 74 65 73 74 2d 72 65 63 (let* ((test-rec
13830 6f 72 64 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ord (hash-table-
13840 72 65 66 20 74 65 73 74 72 65 63 6f 72 64 73 68 ref testrecordsh
13850 61 73 68 20 74 65 73 74 6b 65 79 6e 61 6d 65 29 ash testkeyname)
13860 29 0a 09 20 20 20 20 20 20 28 74 65 73 74 2d 6e ).. (test-n
13870 61 6d 65 20 20 20 28 74 65 73 74 73 3a 74 65 73 ame (tests:tes
13880 74 71 75 65 75 65 2d 67 65 74 2d 74 65 73 74 6e tqueue-get-testn
13890 61 6d 65 20 20 74 65 73 74 2d 72 65 63 6f 72 64 ame test-record
138a0 29 29 0a 09 20 20 20 20 20 20 28 69 74 65 6d 64 )).. (itemd
138b0 61 74 20 20 20 20 20 28 74 65 73 74 73 3a 74 65 at (tests:te
138c0 73 74 71 75 65 75 65 2d 67 65 74 2d 69 74 65 6d stqueue-get-item
138d0 64 61 74 20 20 20 74 65 73 74 2d 72 65 63 6f 72 dat test-recor
138e0 64 29 29 0a 09 20 20 20 20 20 20 28 69 74 65 6d d)).. (item
138f0 2d 70 61 74 68 20 20 20 28 74 65 73 74 73 3a 74 -path (tests:t
13900 65 73 74 71 75 65 75 65 2d 67 65 74 2d 69 74 65 estqueue-get-ite
13910 6d 5f 70 61 74 68 20 74 65 73 74 2d 72 65 63 6f m_path test-reco
13920 72 64 29 29 0a 09 20 20 20 20 20 20 28 77 61 69 rd)).. (wai
13930 74 6f 6e 73 20 20 20 20 20 28 74 65 73 74 73 3a tons (tests:
13940 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 77 61 testqueue-get-wa
13950 69 74 6f 6e 73 20 20 20 74 65 73 74 2d 72 65 63 itons test-rec
13960 6f 72 64 29 29 0a 09 20 20 20 20 20 20 28 6b 65 ord)).. (ke
13970 65 70 2d 74 65 73 74 20 20 20 23 74 29 0a 09 20 ep-test #t)..
13980 20 20 20 20 20 28 74 65 73 74 2d 69 64 20 20 20 (test-id
13990 20 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d (rmt:get-test-
139a0 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e id run-id test-n
139b0 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 0a ame item-path)).
139c0 09 20 20 20 20 20 20 28 74 64 61 74 20 20 20 20 . (tdat
139d0 20 20 20 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 (rmt:get-tes
139e0 74 69 6e 66 6f 2d 73 74 61 74 65 2d 73 74 61 74 tinfo-state-stat
139f0 75 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 us run-id test-i
13a00 64 29 29 29 20 3b 3b 20 28 63 64 62 3a 67 65 74 d))) ;; (cdb:get
13a10 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 -test-info-by-id
13a20 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 74 65 73 *runremote* tes
13a30 74 2d 69 64 29 29 29 0a 09 20 28 69 66 20 74 64 t-id))).. (if td
13a40 61 74 0a 09 20 20 20 20 20 28 62 65 67 69 6e 0a at.. (begin.
13a50 09 20 20 20 20 20 20 20 3b 3b 20 4c 6f 6f 6b 20 . ;; Look
13a60 61 74 20 74 68 65 20 74 65 73 74 20 73 74 61 74 at the test stat
13a70 65 20 61 6e 64 20 73 74 61 74 75 73 0a 09 20 20 e and status..
13a80 20 20 20 20 20 28 69 66 20 28 6f 72 20 28 61 6e (if (or (an
13a90 64 20 28 6d 65 6d 62 65 72 20 28 64 62 3a 74 65 d (member (db:te
13aa0 73 74 2d 67 65 74 2d 73 74 61 74 75 73 20 74 64 st-get-status td
13ab0 61 74 29 20 0a 09 09 09 09 20 20 20 20 27 28 22 at) ..... '("
13ac0 50 41 53 53 22 20 22 57 41 52 4e 22 20 22 57 41 PASS" "WARN" "WA
13ad0 49 56 45 44 22 20 22 43 48 45 43 4b 22 20 22 53 IVED" "CHECK" "S
13ae0 4b 49 50 22 29 29 0a 09 09 09 20 20 20 20 28 65 KIP")).... (e
13af0 71 75 61 6c 3f 20 28 64 62 3a 74 65 73 74 2d 67 qual? (db:test-g
13b00 65 74 2d 73 74 61 74 65 20 74 64 61 74 29 20 22 et-state tdat) "
13b10 43 4f 4d 50 4c 45 54 45 44 22 29 29 0a 09 09 20 COMPLETED"))...
13b20 20 20 20 20 20 20 28 6d 65 6d 62 65 72 20 28 64 (member (d
13b30 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 b:test-get-state
13b40 20 74 64 61 74 29 0a 09 09 09 09 20 20 20 20 27 tdat)..... '
13b50 28 22 49 4e 43 4f 4d 50 4c 45 54 45 22 20 22 4b ("INCOMPLETE" "K
13b60 49 4c 4c 45 44 22 29 29 29 0a 09 09 20 20 20 28 ILLED")))... (
13b70 73 65 74 21 20 6b 65 65 70 2d 74 65 73 74 20 23 set! keep-test #
13b80 66 29 29 0a 0a 09 20 20 20 20 20 20 20 3b 3b 20 f))... ;;
13b90 65 78 61 6d 69 6e 65 20 77 61 69 74 6f 6e 73 20 examine waitons
13ba0 66 6f 72 20 61 6e 79 20 66 61 69 6c 73 2e 20 49 for any fails. I
13bb0 66 20 69 74 20 69 73 20 46 41 49 4c 20 6f 72 20 f it is FAIL or
13bc0 49 4e 43 4f 4d 50 4c 45 54 45 20 74 68 65 6e 20 INCOMPLETE then
13bd0 65 6c 69 6d 69 6e 61 74 65 20 74 68 69 73 20 74 eliminate this t
13be0 65 73 74 0a 09 20 20 20 20 20 20 20 3b 3b 20 66 est.. ;; f
13bf0 72 6f 6d 20 74 68 65 20 72 75 6e 6e 61 62 6c 65 rom the runnable
13c00 20 6c 69 73 74 0a 09 20 20 20 20 20 20 20 28 69 list.. (i
13c10 66 20 6b 65 65 70 2d 74 65 73 74 0a 09 09 20 20 f keep-test...
13c20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 (for-each (lamb
13c30 64 61 20 28 77 61 69 74 6f 6e 29 0a 09 09 09 20 da (waiton)....
13c40 20 20 20 20 20 20 3b 3b 20 66 6f 72 20 6e 6f 77 ;; for now
13c50 20 77 65 20 61 72 65 20 77 61 69 74 69 6e 67 20 we are waiting
13c60 6f 6e 6c 79 20 6f 6e 20 74 68 65 20 70 61 72 65 only on the pare
13c70 6e 74 20 74 65 73 74 0a 09 09 09 20 20 20 20 20 nt test....
13c80 20 20 28 6c 65 74 2a 20 28 28 70 61 72 65 6e 74 (let* ((parent
13c90 2d 74 65 73 74 2d 69 64 20 28 72 6d 74 3a 67 65 -test-id (rmt:ge
13ca0 74 2d 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 t-test-id run-id
13cb0 20 77 61 69 74 6f 6e 20 22 22 29 29 0a 09 09 09 waiton ""))....
13cc0 09 20 20 20 20 20 20 28 77 74 64 61 74 20 20 20 . (wtdat
13cd0 20 20 20 20 20 20 20 28 72 6d 74 3a 67 65 74 2d (rmt:get-
13ce0 74 65 73 74 69 6e 66 6f 2d 73 74 61 74 65 2d 73 testinfo-state-s
13cf0 74 61 74 75 73 20 72 75 6e 2d 69 64 20 74 65 73 tatus run-id tes
13d00 74 2d 69 64 29 29 29 20 3b 3b 20 28 63 64 62 3a t-id))) ;; (cdb:
13d10 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 get-test-info-by
13d20 2d 69 64 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 -id *runremote*
13d30 74 65 73 74 2d 69 64 29 29 29 0a 09 09 09 09 20 test-id))).....
13d40 28 69 66 20 28 6f 72 20 28 61 6e 64 20 28 65 71 (if (or (and (eq
13d50 75 61 6c 3f 20 28 64 62 3a 74 65 73 74 2d 67 65 ual? (db:test-ge
13d60 74 2d 73 74 61 74 65 20 77 74 64 61 74 29 20 22 t-state wtdat) "
13d70 43 4f 4d 50 4c 45 54 45 44 22 29 0a 09 09 09 09 COMPLETED").....
13d80 09 20 20 20 20 20 20 28 6d 65 6d 62 65 72 20 28 . (member (
13d90 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 db:test-get-stat
13da0 75 73 20 77 74 64 61 74 29 20 27 28 22 46 41 49 us wtdat) '("FAI
13db0 4c 22 20 22 41 42 4f 52 54 22 29 29 29 0a 09 09 L" "ABORT")))...
13dc0 09 09 09 20 28 6d 65 6d 62 65 72 20 28 64 62 3a ... (member (db:
13dd0 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 73 20 test-get-status
13de0 77 74 64 61 74 29 20 20 27 28 22 4b 49 4c 4c 45 wtdat) '("KILLE
13df0 44 22 29 29 0a 09 09 09 09 09 20 28 6d 65 6d 62 D"))...... (memb
13e00 65 72 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d er (db:test-get-
13e10 73 74 61 74 65 20 77 74 64 61 74 29 20 20 20 27 state wtdat) '
13e20 28 22 49 4e 43 4f 4d 50 45 54 45 22 29 29 29 0a ("INCOMPETE"))).
13e30 09 09 09 09 20 3b 3b 20 28 69 66 20 28 6f 72 20 .... ;; (if (or
13e40 28 6d 65 6d 62 65 72 20 28 64 62 3a 74 65 73 74 (member (db:test
13e50 2d 67 65 74 2d 73 74 61 74 75 73 20 77 74 64 61 -get-status wtda
13e60 74 29 0a 09 09 09 09 20 3b 3b 20 20 20 20 20 20 t)..... ;;
13e70 20 20 09 20 27 28 22 46 41 49 4c 22 20 22 4b 49 . '("FAIL" "KI
13e80 4c 4c 45 44 22 29 29 0a 09 09 09 09 20 3b 3b 20 LLED"))..... ;;
13e90 20 20 20 20 20 20 20 20 28 6d 65 6d 62 65 72 20 (member
13ea0 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 (db:test-get-sta
13eb0 74 65 20 77 74 64 61 74 29 0a 09 09 09 09 20 3b te wtdat)..... ;
13ec0 3b 20 20 20 20 20 20 20 20 09 20 27 28 22 49 4e ; . '("IN
13ed0 43 4f 4d 50 45 54 45 22 29 29 29 0a 09 09 09 09 COMPETE"))).....
13ee0 20 20 20 20 20 28 73 65 74 21 20 6b 65 65 70 2d (set! keep-
13ef0 74 65 73 74 20 23 66 29 29 29 29 20 3b 3b 20 6e test #f)))) ;; n
13f00 6f 20 70 6f 69 6e 74 20 69 6e 20 72 75 6e 6e 69 o point in runni
13f10 6e 67 20 74 68 69 73 20 6f 6e 65 20 61 67 61 69 ng this one agai
13f20 6e 0a 09 09 09 20 20 20 20 20 77 61 69 74 6f 6e n.... waiton
13f30 73 29 29 29 29 0a 09 20 28 69 66 20 6b 65 65 70 s)))).. (if keep
13f40 2d 74 65 73 74 20 28 73 65 74 21 20 72 75 6e 6e -test (set! runn
13f50 61 62 6c 65 73 20 28 63 6f 6e 73 20 74 65 73 74 ables (cons test
13f60 6b 65 79 6e 61 6d 65 20 72 75 6e 6e 61 62 6c 65 keyname runnable
13f70 73 29 29 29 29 29 0a 20 20 20 20 20 74 65 73 74 s))))). test
13f80 6b 65 79 6e 61 6d 65 73 29 0a 20 20 20 20 72 75 keynames). ru
13f90 6e 6e 61 62 6c 65 73 29 29 0a 0a 3b 3b 3d 3d 3d nnables))..;;===
13fa0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13fb0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13fc0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13fd0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13fe0 3d 3d 3d 0a 3b 3b 20 72 65 66 61 63 74 6f 72 69 ===.;; refactori
13ff0 6e 67 20 74 68 69 73 20 62 6c 6f 63 6b 20 69 6e ng this block in
14000 74 6f 20 74 65 73 74 73 3a 67 65 74 2d 66 75 6c to tests:get-ful
14010 6c 2d 64 61 74 61 20 66 72 6f 6d 20 6c 69 6e 65 l-data from line
14020 20 32 36 33 20 6f 66 20 72 75 6e 73 2e 73 63 6d 263 of runs.scm
14030 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
14040 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14050 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14060 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14070 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 68 65 64 =========.;; hed
14080 20 69 73 20 74 68 65 20 74 65 73 74 20 6e 61 6d is the test nam
14090 65 0a 3b 3b 20 74 65 73 74 2d 72 65 63 6f 72 64 e.;; test-record
140a0 73 20 69 73 20 61 20 68 61 73 68 20 6f 66 20 74 s is a hash of t
140b0 65 73 74 2d 6e 61 6d 65 20 3d 3e 20 74 65 73 74 est-name => test
140c0 20 72 65 63 6f 72 64 0a 28 64 65 66 69 6e 65 20 record.(define
140d0 28 74 65 73 74 73 3a 67 65 74 2d 66 75 6c 6c 2d (tests:get-full-
140e0 64 61 74 61 20 74 65 73 74 2d 6e 61 6d 65 73 20 data test-names
140f0 74 65 73 74 2d 72 65 63 6f 72 64 73 20 72 65 71 test-records req
14100 75 69 72 65 64 2d 74 65 73 74 73 20 61 6c 6c 2d uired-tests all-
14110 74 65 73 74 73 2d 72 65 67 69 73 74 72 79 29 0a tests-registry).
14120 20 20 28 6c 65 74 20 28 28 6d 69 73 73 69 6e 67 (let ((missing
14130 2d 77 61 69 74 6f 6e 73 20 28 6d 61 6b 65 2d 68 -waitons (make-h
14140 61 73 68 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 ash-table))).
14150 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f (if (not (null?
14160 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 0a 20 20 test-names)).
14170 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 (let loop ((
14180 68 65 64 20 28 63 61 72 20 74 65 73 74 2d 6e 61 hed (car test-na
14190 6d 65 73 29 29 0a 09 09 20 28 74 61 6c 20 28 63 mes))... (tal (c
141a0 64 72 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 29 dr test-names)))
141b0 20 20 20 20 20 20 20 20 20 3b 3b 20 27 72 65 74 ;; 'ret
141c0 75 72 6e 2d 70 72 6f 63 73 20 74 65 6c 6c 73 20 urn-procs tells
141d0 74 68 65 20 63 6f 6e 66 69 67 20 72 65 61 64 65 the config reade
141e0 72 20 74 6f 20 70 72 65 70 20 72 75 6e 6e 69 6e r to prep runnin
141f0 67 20 73 79 73 74 65 6d 20 62 75 74 20 72 65 74 g system but ret
14200 75 72 6e 20 61 20 70 72 6f 63 0a 09 28 64 65 62 urn a proc..(deb
14210 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 ug:print-info 4
14220 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
14230 74 2a 20 22 68 65 64 3d 22 20 68 65 64 20 22 20 t* "hed=" hed "
14240 61 74 20 74 6f 70 20 6f 66 20 6c 6f 6f 70 22 29 at top of loop")
14250 0a 20 20 20 20 20 20 20 20 3b 3b 20 64 6f 6e 27 . ;; don'
14260 74 20 6b 6e 6f 77 20 69 74 65 6d 2d 70 61 74 68 t know item-path
14270 20 61 74 20 74 68 69 73 20 74 69 6d 65 2c 20 6c at this time, l
14280 65 74 20 74 68 65 20 74 65 73 74 63 6f 6e 66 69 et the testconfi
14290 67 20 67 65 74 20 74 68 65 20 74 6f 70 20 6c 65 g get the top le
142a0 76 65 6c 20 74 65 73 74 63 6f 6e 66 69 67 0a 09 vel testconfig..
142b0 28 6c 65 74 2a 20 28 28 63 6f 6e 66 69 67 20 20 (let* ((config
142c0 28 74 65 73 74 73 3a 67 65 74 2d 74 65 73 74 63 (tests:get-testc
142d0 6f 6e 66 69 67 20 68 65 64 20 23 66 20 61 6c 6c onfig hed #f all
142e0 2d 74 65 73 74 73 2d 72 65 67 69 73 74 72 79 20 -tests-registry
142f0 27 72 65 74 75 72 6e 2d 70 72 6f 63 73 29 29 0a 'return-procs)).
14300 09 20 20 20 20 20 20 20 28 77 61 69 74 6f 6e 73 . (waitons
14310 20 28 6c 65 74 20 28 28 69 6e 73 74 72 20 28 69 (let ((instr (i
14320 66 20 63 6f 6e 66 69 67 20 0a 09 09 09 09 09 20 f config ......
14330 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 (configf:lookup
14340 63 6f 6e 66 69 67 20 22 72 65 71 75 69 72 65 6d config "requirem
14350 65 6e 74 73 22 20 22 77 61 69 74 6f 6e 22 29 0a ents" "waiton").
14360 09 09 09 09 09 20 28 62 65 67 69 6e 20 3b 3b 20 ..... (begin ;;
14370 4e 6f 20 63 6f 6e 66 69 67 20 6d 65 61 6e 73 20 No config means
14380 74 68 69 73 20 69 73 20 61 20 6e 6f 6e 2d 65 78 this is a non-ex
14390 69 73 74 65 6e 74 20 74 65 73 74 0a 20 20 20 20 istent test.
143a0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
143b0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
143c0 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 77 61 (let ((wa
143d0 69 74 65 72 73 20 27 28 29 29 29 0a 20 20 20 20 iters '())).
143e0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
143f0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14400 20 20 20 20 20 20 20 20 20 3b 3b 20 66 69 6e 64 ;; find
14410 20 74 68 65 20 77 61 69 74 65 72 28 73 29 20 66 the waiter(s) f
14420 6f 72 20 74 68 69 73 20 77 61 69 74 6f 6e 2e 0a or this waiton..
14430 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14440 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14450 20 20 20 20 20 20 20 20 20 20 20 20 20 28 66 6f (fo
14460 72 2d 65 61 63 68 20 0a 20 20 20 20 20 20 20 20 r-each .
14470 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14480 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14490 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 28 77 (lambda(w
144a0 61 69 74 65 72 29 0a 20 20 20 20 20 20 20 20 20 aiter).
144b0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
144c0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
144d0 20 20 20 20 20 20 20 20 3b 3b 20 28 70 72 69 6e ;; (prin
144e0 74 20 22 74 65 73 74 2d 72 65 63 6f 72 64 20 3d t "test-record =
144f0 20 22 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 " (hash-table-r
14500 65 66 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 ef test-records
14510 77 61 69 74 65 72 29 29 0a 20 20 20 20 20 20 20 waiter)).
14520 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14530 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14540 20 20 20 20 20 20 20 20 20 20 3b 3b 20 28 70 72 ;; (pr
14550 69 6e 74 20 22 77 61 69 74 6f 6e 73 20 3d 20 22 int "waitons = "
14560 20 28 76 65 63 74 6f 72 2d 72 65 66 20 28 68 61 (vector-ref (ha
14570 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 74 65 73 sh-table-ref tes
14580 74 2d 72 65 63 6f 72 64 73 20 77 61 69 74 65 72 t-records waiter
14590 29 20 32 29 29 0a 20 20 20 20 20 20 20 20 20 20 ) 2)).
145a0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
145b0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
145c0 20 20 20 20 20 20 20 28 69 66 20 28 6d 65 6d 62 (if (memb
145d0 65 72 20 68 65 64 20 28 76 65 63 74 6f 72 2d 72 er hed (vector-r
145e0 65 66 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 ef (hash-table-r
145f0 65 66 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 ef test-records
14600 77 61 69 74 65 72 29 20 32 29 29 0a 20 20 20 20 waiter) 2)).
14610 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14620 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14630 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14640 28 73 65 74 21 20 77 61 69 74 65 72 73 20 28 63 (set! waiters (c
14650 6f 6e 73 20 77 61 69 74 65 72 20 77 61 69 74 65 ons waiter waite
14660 72 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 rs)).
14670 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14680 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14690 20 20 20 20 20 20 29 0a 20 20 20 20 20 20 20 20 ).
146a0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
146b0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
146c0 20 20 20 20 20 20 20 29 0a 20 20 20 20 20 20 20 ).
146d0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
146e0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
146f0 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c (hash-tabl
14700 65 2d 6b 65 79 73 20 74 65 73 74 2d 72 65 63 6f e-keys test-reco
14710 72 64 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 rds)).
14720 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14730 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14740 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 (hash-table-s
14750 65 74 21 20 6d 69 73 73 69 6e 67 2d 77 61 69 74 et! missing-wait
14760 6f 6e 73 20 68 65 64 20 77 61 69 74 65 72 73 29 ons hed waiters)
14770 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
14780 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14790 20 20 20 20 20 20 20 20 20 20 20 20 29 0a 09 09 )...
147a0 09 09 09 20 20 20 22 22 29 29 29 29 0a 09 09 09 ... ""))))....
147b0 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
147c0 6e 66 6f 20 38 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 8 *default-l
147d0 6f 67 2d 70 6f 72 74 2a 20 22 77 61 69 74 6f 6e og-port* "waiton
147e0 73 20 73 74 72 69 6e 67 20 69 73 20 22 20 69 6e s string is " in
147f0 73 74 72 29 0a 09 09 09 20 20 28 73 74 72 69 6e str).... (strin
14800 67 2d 73 70 6c 69 74 20 28 63 6f 6e 64 0a 09 09 g-split (cond...
14810 09 09 09 20 28 28 70 72 6f 63 65 64 75 72 65 3f ... ((procedure?
14820 20 69 6e 73 74 72 29 0a 09 09 09 09 09 20 20 28 instr)...... (
14830 6c 65 74 20 28 28 72 65 73 20 28 69 6e 73 74 72 let ((res (instr
14840 29 29 29 0a 09 09 09 09 09 20 20 20 20 28 64 65 )))...... (de
14850 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 38 bug:print-info 8
14860 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
14870 72 74 2a 20 22 77 61 69 74 6f 6e 20 70 72 6f 63 rt* "waiton proc
14880 65 64 75 72 65 20 72 65 73 75 6c 74 73 20 69 6e edure results in
14890 20 73 74 72 69 6e 67 20 22 20 72 65 73 20 22 20 string " res "
148a0 66 6f 72 20 74 65 73 74 20 22 20 68 65 64 29 0a for test " hed).
148b0 09 09 09 09 09 20 20 20 20 72 65 73 29 29 0a 09 ..... res))..
148c0 09 09 09 09 20 28 28 73 74 72 69 6e 67 3f 20 69 .... ((string? i
148d0 6e 73 74 72 29 20 20 20 20 20 69 6e 73 74 72 29 nstr) instr)
148e0 0a 09 09 09 09 09 20 28 65 6c 73 65 20 0a 09 09 ...... (else ...
148f0 09 09 09 20 20 3b 3b 20 4e 4f 54 45 3a 20 54 68 ... ;; NOTE: Th
14900 69 73 20 69 73 20 61 63 74 75 61 6c 6c 79 20 74 is is actually t
14910 68 65 20 63 61 73 65 20 6f 66 20 2a 6e 6f 2a 20 he case of *no*
14920 77 61 69 74 6f 6e 73 21 20 3b 3b 20 0a 09 09 09 waitons! ;; ....
14930 09 09 20 20 22 22 29 29 29 29 29 29 0a 09 20 20 .. ""))))))..
14940 28 69 66 20 28 6e 6f 74 20 63 6f 6e 66 69 67 29 (if (not config)
14950 20 3b 3b 20 74 68 69 73 20 69 73 20 61 20 6e 6f ;; this is a no
14960 6e 2d 65 78 69 73 74 61 6e 74 20 74 65 73 74 20 n-existant test
14970 63 61 6c 6c 65 64 20 69 6e 20 61 20 77 61 69 74 called in a wait
14980 6f 6e 2e 20 0a 09 20 20 20 20 20 20 28 69 66 20 on. .. (if
14990 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 20 20 (null? tal)...
149a0 74 65 73 74 2d 72 65 63 6f 72 64 73 0a 09 09 20 test-records...
149b0 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 (loop (car tal)
149c0 28 63 64 72 20 74 61 6c 29 29 29 0a 09 20 20 20 (cdr tal)))..
149d0 20 20 20 28 62 65 67 69 6e 0a 09 09 28 64 65 62 (begin...(deb
149e0 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 38 20 ug:print-info 8
149f0 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
14a00 74 2a 20 22 77 61 69 74 6f 6e 73 3a 20 22 20 77 t* "waitons: " w
14a10 61 69 74 6f 6e 73 29 0a 09 09 3b 3b 20 63 68 65 aitons)...;; che
14a20 63 6b 20 66 6f 72 20 68 65 64 20 69 6e 20 77 61 ck for hed in wa
14a30 69 74 6f 6e 73 20 3d 3e 20 74 68 69 73 20 77 6f itons => this wo
14a40 75 6c 64 20 62 65 20 63 69 72 63 75 6c 61 72 2c uld be circular,
14a50 20 72 65 6d 6f 76 65 20 69 74 20 61 6e 64 20 69 remove it and i
14a60 73 73 75 65 20 61 6e 0a 09 09 3b 3b 20 65 72 72 ssue an...;; err
14a70 6f 72 0a 09 09 28 69 66 20 28 6d 65 6d 62 65 72 or...(if (member
14a80 20 68 65 64 20 77 61 69 74 6f 6e 73 29 0a 09 09 hed waitons)...
14a90 20 20 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 (begin...
14aa0 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
14ab0 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 error 0 *default
14ac0 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 74 65 73 74 -log-port* "test
14ad0 20 22 20 68 65 64 20 22 20 68 61 73 20 6c 69 73 " hed " has lis
14ae0 74 65 64 20 69 74 73 65 6c 66 20 61 73 20 61 20 ted itself as a
14af0 77 61 69 74 6f 6e 2c 20 70 6c 65 61 73 65 20 63 waiton, please c
14b00 6f 72 72 65 63 74 20 74 68 69 73 21 22 29 0a 09 orrect this!")..
14b10 09 20 20 20 20 20 20 28 73 65 74 21 20 77 61 69 . (set! wai
14b20 74 6f 6e 73 20 28 66 69 6c 74 65 72 20 28 6c 61 tons (filter (la
14b30 6d 62 64 61 20 28 78 29 28 6e 6f 74 20 28 65 71 mbda (x)(not (eq
14b40 75 61 6c 3f 20 78 20 68 65 64 29 29 29 20 77 61 ual? x hed))) wa
14b50 69 74 6f 6e 73 29 29 29 29 0a 09 09 0a 09 09 3b itons))))......;
14b60 3b 20 28 69 74 65 6d 73 20 20 20 28 69 74 65 6d ; (items (item
14b70 73 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d s:get-items-from
14b80 2d 63 6f 6e 66 69 67 20 63 6f 6e 66 69 67 29 29 -config config))
14b90 29 0a 09 09 28 69 66 20 28 6e 6f 74 20 28 68 61 )...(if (not (ha
14ba0 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
14bb0 61 75 6c 74 20 74 65 73 74 2d 72 65 63 6f 72 64 ault test-record
14bc0 73 20 68 65 64 20 23 66 29 29 0a 09 09 20 20 20 s hed #f))...
14bd0 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
14be0 21 20 74 65 73 74 2d 72 65 63 6f 72 64 73 0a 09 ! test-records..
14bf0 09 09 09 20 20 20 20 20 68 65 64 20 28 76 65 63 ... hed (vec
14c00 74 6f 72 20 68 65 64 20 20 20 20 20 3b 3b 20 30 tor hed ;; 0
14c10 0a 09 09 09 09 09 09 20 63 6f 6e 66 69 67 20 20 ....... config
14c20 3b 3b 20 31 0a 09 09 09 09 09 09 20 77 61 69 74 ;; 1....... wait
14c30 6f 6e 73 20 3b 3b 20 32 0a 09 09 09 09 09 09 20 ons ;; 2.......
14c40 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 (configf:lookup
14c50 63 6f 6e 66 69 67 20 22 72 65 71 75 69 72 65 6d config "requirem
14c60 65 6e 74 73 22 20 22 70 72 69 6f 72 69 74 79 22 ents" "priority"
14c70 29 20 20 20 20 20 3b 3b 20 70 72 69 6f 72 69 74 ) ;; priorit
14c80 79 20 33 0a 09 09 09 09 09 09 20 28 6c 65 74 20 y 3....... (let
14c90 28 28 69 74 65 6d 73 20 20 20 20 20 20 28 68 61 ((items (ha
14ca0 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
14cb0 61 75 6c 74 20 63 6f 6e 66 69 67 20 22 69 74 65 ault config "ite
14cc0 6d 73 22 20 23 66 29 29 20 3b 3b 20 69 74 65 6d ms" #f)) ;; item
14cd0 73 20 34 0a 09 09 09 09 09 09 20 20 20 20 20 20 s 4.......
14ce0 20 28 69 74 65 6d 73 74 61 62 6c 65 20 28 68 61 (itemstable (ha
14cf0 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
14d00 61 75 6c 74 20 63 6f 6e 66 69 67 20 22 69 74 65 ault config "ite
14d10 6d 73 74 61 62 6c 65 22 20 23 66 29 29 29 20 0a mstable" #f))) .
14d20 09 09 09 09 09 09 20 20 20 3b 3b 20 69 66 20 65 ...... ;; if e
14d30 69 74 68 65 72 20 69 74 65 6d 73 20 6f 72 20 69 ither items or i
14d40 74 65 6d 73 20 74 61 62 6c 65 20 69 73 20 61 20 tems table is a
14d50 70 72 6f 63 20 72 65 74 75 72 6e 20 69 74 20 73 proc return it s
14d60 6f 20 74 65 73 74 20 72 75 6e 6e 69 6e 67 0a 09 o test running..
14d70 09 09 09 09 09 20 20 20 3b 3b 20 70 72 6f 63 65 ..... ;; proce
14d80 73 73 20 63 61 6e 20 6b 6e 6f 77 20 74 6f 20 63 ss can know to c
14d90 61 6c 6c 20 69 74 65 6d 73 3a 67 65 74 2d 69 74 all items:get-it
14da0 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 0a ems-from-config.
14db0 09 09 09 09 09 09 20 20 20 3b 3b 20 69 66 20 65 ...... ;; if e
14dc0 69 74 68 65 72 20 69 73 20 61 20 6c 69 73 74 20 ither is a list
14dd0 61 6e 64 20 6e 6f 6e 65 20 69 73 20 61 20 70 72 and none is a pr
14de0 6f 63 20 67 6f 20 61 68 65 61 64 20 61 6e 64 20 oc go ahead and
14df0 63 61 6c 6c 20 67 65 74 2d 69 74 65 6d 73 0a 09 call get-items..
14e00 09 09 09 09 09 20 20 20 3b 3b 20 6f 74 68 65 72 ..... ;; other
14e10 77 69 73 65 20 72 65 74 75 72 6e 20 23 66 20 2d wise return #f -
14e20 20 74 68 69 73 20 69 73 20 6e 6f 74 20 61 6e 20 this is not an
14e30 69 74 65 72 61 74 65 64 20 74 65 73 74 0a 09 09 iterated test...
14e40 09 09 09 09 20 20 20 28 63 6f 6e 64 0a 09 09 09 .... (cond....
14e50 09 09 09 20 20 20 20 28 28 70 72 6f 63 65 64 75 ... ((procedu
14e60 72 65 3f 20 69 74 65 6d 73 29 20 20 20 20 20 20 re? items)
14e70 0a 09 09 09 09 09 09 20 20 20 20 20 28 64 65 62 ....... (deb
14e80 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 ug:print-info 4
14e90 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
14ea0 74 2a 20 22 69 74 65 6d 73 20 69 73 20 61 20 70 t* "items is a p
14eb0 72 6f 63 65 64 75 72 65 2c 20 77 69 6c 6c 20 63 rocedure, will c
14ec0 61 6c 63 20 6c 61 74 65 72 22 29 0a 09 09 09 09 alc later").....
14ed0 09 09 20 20 20 20 20 69 74 65 6d 73 29 20 20 20 .. items)
14ee0 20 20 20 20 20 20 20 20 20 3b 3b 20 63 61 6c 63 ;; calc
14ef0 20 6c 61 74 65 72 0a 09 09 09 09 09 09 20 20 20 later.......
14f00 20 28 28 70 72 6f 63 65 64 75 72 65 3f 20 69 74 ((procedure? it
14f10 65 6d 73 74 61 62 6c 65 29 0a 09 09 09 09 09 09 emstable).......
14f20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
14f30 74 2d 69 6e 66 6f 20 34 20 2a 64 65 66 61 75 6c t-info 4 *defaul
14f40 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 69 74 65 t-log-port* "ite
14f50 6d 73 74 61 62 6c 65 20 69 73 20 61 20 70 72 6f mstable is a pro
14f60 63 65 64 75 72 65 2c 20 77 69 6c 6c 20 63 61 6c cedure, will cal
14f70 63 20 6c 61 74 65 72 22 29 0a 09 09 09 09 09 09 c later").......
14f80 20 20 20 20 20 69 74 65 6d 73 74 61 62 6c 65 29 itemstable)
14f90 20 20 20 20 20 20 20 3b 3b 20 63 61 6c 63 20 6c ;; calc l
14fa0 61 74 65 72 0a 09 09 09 09 09 09 20 20 20 20 28 ater....... (
14fb0 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 (filter (lambda
14fc0 28 78 29 0a 09 09 09 09 09 09 09 20 20 20 20 20 (x)........
14fd0 20 20 28 6c 65 74 20 28 28 76 61 6c 20 28 63 61 (let ((val (ca
14fe0 72 20 78 29 29 29 0a 09 09 09 09 09 09 09 09 20 r x))).........
14ff0 28 69 66 20 28 70 72 6f 63 65 64 75 72 65 3f 20 (if (procedure?
15000 76 61 6c 29 20 76 61 6c 20 23 66 29 29 29 0a 09 val) val #f)))..
15010 09 09 09 09 09 09 20 20 20 20 20 28 61 70 70 65 ...... (appe
15020 6e 64 20 28 69 66 20 28 6c 69 73 74 3f 20 69 74 nd (if (list? it
15030 65 6d 73 29 20 69 74 65 6d 73 20 27 28 29 29 0a ems) items '()).
15040 09 09 09 09 09 09 09 09 20 20 20 20 20 28 69 66 ........ (if
15050 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 74 61 62 (list? itemstab
15060 6c 65 29 20 69 74 65 6d 73 74 61 62 6c 65 20 27 le) itemstable '
15070 28 29 29 29 29 0a 09 09 09 09 09 09 20 20 20 20 ()))).......
15080 20 27 68 61 76 65 2d 70 72 6f 63 65 64 75 72 65 'have-procedure
15090 29 0a 09 09 09 09 09 09 20 20 20 20 28 28 6f 72 )....... ((or
150a0 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 28 6c (list? items)(l
150b0 69 73 74 3f 20 69 74 65 6d 73 74 61 62 6c 65 29 ist? itemstable)
150c0 29 20 3b 3b 20 63 61 6c 63 20 6e 6f 77 0a 09 09 ) ;; calc now...
150d0 09 09 09 09 20 20 20 20 20 28 64 65 62 75 67 3a .... (debug:
150e0 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 2a 64 65 print-info 4 *de
150f0 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
15100 22 69 74 65 6d 73 20 61 6e 64 20 69 74 65 6d 73 "items and items
15110 74 61 62 6c 65 20 61 72 65 20 6c 69 73 74 73 2c table are lists,
15120 20 63 61 6c 63 20 6e 6f 77 5c 6e 22 0a 09 09 09 calc now\n"....
15130 09 09 09 09 09 20 20 20 20 20 20 20 22 20 20 20 ..... "
15140 20 69 74 65 6d 73 3a 20 22 20 69 74 65 6d 73 20 items: " items
15150 22 20 69 74 65 6d 73 74 61 62 6c 65 3a 20 22 20 " itemstable: "
15160 69 74 65 6d 73 74 61 62 6c 65 29 0a 09 09 09 09 itemstable).....
15170 09 09 20 20 20 20 20 28 69 74 65 6d 73 3a 67 65 .. (items:ge
15180 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e t-items-from-con
15190 66 69 67 20 63 6f 6e 66 69 67 29 29 0a 09 09 09 fig config))....
151a0 09 09 09 20 20 20 20 28 65 6c 73 65 20 23 66 29 ... (else #f)
151b0 29 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ))
151c0 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ;;
151d0 6e 6f 74 20 69 74 65 72 61 74 65 64 0a 09 09 09 not iterated....
151e0 09 09 09 20 23 66 20 20 20 20 20 20 3b 3b 20 69 ... #f ;; i
151f0 74 65 6d 73 64 61 74 20 35 0a 09 09 09 09 09 09 temsdat 5.......
15200 20 23 66 20 20 20 20 20 20 3b 3b 20 73 70 61 72 #f ;; spar
15210 65 20 2d 20 75 73 65 64 20 66 6f 72 20 69 74 65 e - used for ite
15220 6d 2d 70 61 74 68 0a 09 09 09 09 09 09 20 29 29 m-path....... ))
15230 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
15240 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 09 09 20 (for-each ...
15250 28 6c 61 6d 62 64 61 20 28 77 61 69 74 6f 6e 29 (lambda (waiton)
15260 0a 09 09 20 20 20 28 69 66 20 28 61 6e 64 20 77 ... (if (and w
15270 61 69 74 6f 6e 20 28 6e 6f 74 20 28 73 74 72 69 aiton (not (stri
15280 6e 67 3d 20 22 23 66 22 20 77 61 69 74 6f 6e 29 ng= "#f" waiton)
15290 29 20 28 6e 6f 74 20 28 6d 65 6d 62 65 72 20 77 ) (not (member w
152a0 61 69 74 6f 6e 20 74 65 73 74 2d 6e 61 6d 65 73 aiton test-names
152b0 29 29 29 0a 09 09 20 20 20 20 20 20 20 28 62 65 )))... (be
152c0 67 69 6e 0a 09 09 09 20 28 73 65 74 21 20 72 65 gin.... (set! re
152d0 71 75 69 72 65 64 2d 74 65 73 74 73 20 28 63 6f quired-tests (co
152e0 6e 73 20 77 61 69 74 6f 6e 20 72 65 71 75 69 72 ns waiton requir
152f0 65 64 2d 74 65 73 74 73 29 29 0a 09 09 09 20 28 ed-tests)).... (
15300 73 65 74 21 20 74 65 73 74 2d 6e 61 6d 65 73 20 set! test-names
15310 28 63 6f 6e 73 20 77 61 69 74 6f 6e 20 74 65 73 (cons waiton tes
15320 74 2d 6e 61 6d 65 73 29 29 29 29 29 20 3b 3b 20 t-names))))) ;;
15330 77 61 73 20 61 6e 20 61 70 70 65 6e 64 2c 20 6e was an append, n
15340 6f 77 20 61 20 63 6f 6e 73 0a 09 09 20 77 61 69 ow a cons... wai
15350 74 6f 6e 73 29 0a 09 09 28 6c 65 74 20 28 28 72 tons)...(let ((r
15360 65 6d 74 65 73 74 73 20 28 64 65 6c 65 74 65 2d emtests (delete-
15370 64 75 70 6c 69 63 61 74 65 73 20 28 61 70 70 65 duplicates (appe
15380 6e 64 20 77 61 69 74 6f 6e 73 20 74 61 6c 29 29 nd waitons tal))
15390 29 29 0a 09 09 20 20 28 69 66 20 28 6e 6f 74 20 ))... (if (not
153a0 28 6e 75 6c 6c 3f 20 72 65 6d 74 65 73 74 73 29 (null? remtests)
153b0 29 0a 09 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 )... (loop
153c0 28 63 61 72 20 72 65 6d 74 65 73 74 73 29 28 63 (car remtests)(c
153d0 64 72 20 72 65 6d 74 65 73 74 73 29 29 0a 09 09 dr remtests))...
153e0 20 20 20 20 20 20 74 65 73 74 2d 72 65 63 6f 72 test-recor
153f0 64 73 29 29 29 29 29 29 29 0a 20 20 20 20 20 20 ds))))))).
15400 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 20 (for-each.
15410 20 20 20 28 6c 61 6d 62 64 61 20 28 6d 69 73 73 (lambda (miss
15420 69 6e 67 2d 77 61 69 74 6f 6e 29 0a 20 20 20 20 ing-waiton).
15430 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 (debug:p
15440 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 rint-error 0 *de
15450 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
15460 22 6e 6f 6e 2d 65 78 69 73 74 65 6e 74 20 74 65 "non-existent te
15470 73 74 20 5c 22 22 20 6d 69 73 73 69 6e 67 2d 77 st \"" missing-w
15480 61 69 74 6f 6e 20 22 5c 22 20 69 73 20 61 20 77 aiton "\" is a w
15490 61 69 74 6f 6e 20 66 6f 72 20 74 65 73 74 73 20 aiton for tests
154a0 22 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 " (hash-table-re
154b0 66 20 6d 69 73 73 69 6e 67 2d 77 61 69 74 6f 6e f missing-waiton
154c0 73 20 6d 69 73 73 69 6e 67 2d 77 61 69 74 6f 6e s missing-waiton
154d0 29 29 0a 20 20 20 20 20 20 20 20 20 29 0a 20 20 )). ).
154e0 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 (hash-tab
154f0 6c 65 2d 6b 65 79 73 20 6d 69 73 73 69 6e 67 2d le-keys missing-
15500 77 61 69 74 6f 6e 73 29 0a 20 20 20 20 20 20 29 waitons). )
15510 0a 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d .))..;;=========
15520 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15530 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15540 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15550 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
15560 20 74 65 73 74 20 73 74 65 70 73 0a 3b 3b 3d 3d test steps.;;==
15570 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15580 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15590 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
155a0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
155b0 3d 3d 3d 3d 0a 0a 3b 3b 20 74 65 73 74 73 74 65 ====..;; testste
155c0 70 2d 73 65 74 2d 73 74 61 74 75 73 21 20 75 73 p-set-status! us
155d0 65 64 20 74 6f 20 62 65 20 68 65 72 65 0a 0a 28 ed to be here..(
155e0 64 65 66 69 6e 65 20 28 74 65 73 74 2d 67 65 74 define (test-get
155f0 2d 6b 69 6c 6c 2d 72 65 71 75 65 73 74 20 72 75 -kill-request ru
15600 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 20 3b 3b n-id test-id) ;;
15610 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
15620 65 20 69 74 65 6d 64 61 74 29 0a 20 20 28 6c 65 e itemdat). (le
15630 74 2a 20 28 28 74 65 73 74 64 61 74 20 20 20 28 t* ((testdat (
15640 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 rmt:get-test-inf
15650 6f 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 74 o-by-id run-id t
15660 65 73 74 2d 69 64 29 29 29 0a 20 20 20 20 28 61 est-id))). (a
15670 6e 64 20 74 65 73 74 64 61 74 0a 09 20 28 65 71 nd testdat.. (eq
15680 75 61 6c 3f 20 28 74 65 73 74 3a 67 65 74 2d 73 ual? (test:get-s
15690 74 61 74 65 20 74 65 73 74 64 61 74 29 20 22 4b tate testdat) "K
156a0 49 4c 4c 52 45 51 22 29 29 29 29 0a 0a 28 64 65 ILLREQ"))))..(de
156b0 66 69 6e 65 20 28 74 65 73 74 3a 74 64 62 2d 67 fine (test:tdb-g
156c0 65 74 2d 72 75 6e 64 61 74 2d 63 6f 75 6e 74 20 et-rundat-count
156d0 74 64 62 29 0a 20 20 28 69 66 20 74 64 62 0a 20 tdb). (if tdb.
156e0 20 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 20 (let ((res
156f0 30 29 29 0a 09 28 73 71 6c 69 74 65 33 3a 66 6f 0))..(sqlite3:fo
15700 72 2d 65 61 63 68 2d 72 6f 77 0a 09 20 28 6c 61 r-each-row.. (la
15710 6d 62 64 61 20 28 63 6f 75 6e 74 29 0a 09 20 20 mbda (count)..
15720 20 28 73 65 74 21 20 72 65 73 20 63 6f 75 6e 74 (set! res count
15730 29 29 0a 09 20 74 64 62 0a 09 20 22 53 45 4c 45 )).. tdb.. "SELE
15740 43 54 20 63 6f 75 6e 74 28 69 64 29 20 46 52 4f CT count(id) FRO
15750 4d 20 74 65 73 74 5f 72 75 6e 64 61 74 3b 22 29 M test_rundat;")
15760 0a 09 72 65 73 29 29 0a 20 20 30 29 0a 0a 28 64 ..res)). 0)..(d
15770 65 66 69 6e 65 20 28 74 65 73 74 73 3a 75 70 64 efine (tests:upd
15780 61 74 65 2d 63 65 6e 74 72 61 6c 2d 6d 65 74 61 ate-central-meta
15790 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 20 74 65 73 -info run-id tes
157a0 74 2d 69 64 20 63 70 75 6c 6f 61 64 20 64 69 73 t-id cpuload dis
157b0 6b 66 72 65 65 20 6d 69 6e 75 74 65 73 20 75 6e kfree minutes un
157c0 61 6d 65 20 68 6f 73 74 6e 61 6d 65 29 0a 20 20 ame hostname).
157d0 28 72 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 61 6c (rmt:general-cal
157e0 6c 20 27 75 70 64 61 74 65 2d 74 65 73 74 2d 72 l 'update-test-r
157f0 75 6e 64 61 74 20 72 75 6e 2d 69 64 20 74 65 73 undat run-id tes
15800 74 2d 69 64 20 28 63 75 72 72 65 6e 74 2d 73 65 t-id (current-se
15810 63 6f 6e 64 73 29 20 28 6f 72 20 63 70 75 6c 6f conds) (or cpulo
15820 61 64 20 2d 31 29 28 6f 72 20 64 69 73 6b 66 72 ad -1)(or diskfr
15830 65 65 20 2d 31 29 20 2d 31 20 28 6f 72 20 6d 69 ee -1) -1 (or mi
15840 6e 75 74 65 73 20 2d 31 29 29 0a 20 20 28 69 66 nutes -1)). (if
15850 20 28 61 6e 64 20 63 70 75 6c 6f 61 64 20 64 69 (and cpuload di
15860 73 6b 66 72 65 65 29 0a 20 20 20 20 20 20 28 72 skfree). (r
15870 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 mt:general-call
15880 27 75 70 64 61 74 65 2d 63 70 75 6c 6f 61 64 2d 'update-cpuload-
15890 64 69 73 6b 66 72 65 65 20 72 75 6e 2d 69 64 20 diskfree run-id
158a0 63 70 75 6c 6f 61 64 20 64 69 73 6b 66 72 65 65 cpuload diskfree
158b0 20 74 65 73 74 2d 69 64 29 29 0a 20 20 28 69 66 test-id)). (if
158c0 20 6d 69 6e 75 74 65 73 20 0a 20 20 20 20 20 20 minutes .
158d0 28 72 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 61 6c (rmt:general-cal
158e0 6c 20 27 75 70 64 61 74 65 2d 72 75 6e 2d 64 75 l 'update-run-du
158f0 72 61 74 69 6f 6e 20 72 75 6e 2d 69 64 20 6d 69 ration run-id mi
15900 6e 75 74 65 73 20 74 65 73 74 2d 69 64 29 29 0a nutes test-id)).
15910 20 20 28 69 66 20 28 61 6e 64 20 75 6e 61 6d 65 (if (and uname
15920 20 68 6f 73 74 6e 61 6d 65 29 0a 20 20 20 20 20 hostname).
15930 20 28 72 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 61 (rmt:general-ca
15940 6c 6c 20 27 75 70 64 61 74 65 2d 75 6e 61 6d 65 ll 'update-uname
15950 2d 68 6f 73 74 20 72 75 6e 2d 69 64 20 75 6e 61 -host run-id una
15960 6d 65 20 68 6f 73 74 6e 61 6d 65 20 74 65 73 74 me hostname test
15970 2d 69 64 29 29 29 0a 20 20 0a 3b 3b 20 54 68 69 -id))). .;; Thi
15980 73 20 6f 6e 65 20 69 73 20 66 6f 72 20 72 75 6e s one is for run
15990 6e 69 6e 67 20 77 69 74 68 20 6e 6f 20 64 62 20 ning with no db
159a0 61 63 63 65 73 73 20 28 69 2e 65 2e 20 76 69 61 access (i.e. via
159b0 20 72 6d 74 3a 20 69 6e 74 65 72 6e 61 6c 6c 79 rmt: internally
159c0 29 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 ).(define (tests
159d0 3a 73 65 74 2d 66 75 6c 6c 2d 6d 65 74 61 2d 69 :set-full-meta-i
159e0 6e 66 6f 20 64 62 20 74 65 73 74 2d 69 64 20 72 nfo db test-id r
159f0 75 6e 2d 69 64 20 6d 69 6e 75 74 65 73 20 77 6f un-id minutes wo
15a00 72 6b 2d 61 72 65 61 20 72 65 6d 74 72 69 65 73 rk-area remtries
15a10 29 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 74 65 ).;; (define (te
15a20 73 74 73 3a 73 65 74 2d 66 75 6c 6c 2d 6d 65 74 sts:set-full-met
15a30 61 2d 69 6e 66 6f 20 74 65 73 74 2d 69 64 20 72 a-info test-id r
15a40 75 6e 2d 69 64 20 6d 69 6e 75 74 65 73 20 77 6f un-id minutes wo
15a50 72 6b 2d 61 72 65 61 29 0a 3b 3b 20 20 28 6c 65 rk-area).;; (le
15a60 74 20 28 28 72 65 6d 74 72 69 65 73 20 31 30 29 t ((remtries 10)
15a70 29 0a 20 20 28 6c 65 74 2a 20 28 28 63 70 75 6c ). (let* ((cpul
15a80 6f 61 64 20 20 28 67 65 74 2d 63 70 75 2d 6c 6f oad (get-cpu-lo
15a90 61 64 29 29 0a 09 20 28 64 69 73 6b 66 72 65 65 ad)).. (diskfree
15aa0 20 28 67 65 74 2d 64 66 20 28 63 75 72 72 65 6e (get-df (curren
15ab0 74 2d 64 69 72 65 63 74 6f 72 79 29 29 29 0a 09 t-directory)))..
15ac0 20 28 75 6e 61 6d 65 20 20 20 20 28 67 65 74 2d (uname (get-
15ad0 75 6e 61 6d 65 20 22 2d 73 72 76 70 69 6f 22 29 uname "-srvpio")
15ae0 29 0a 09 20 28 68 6f 73 74 6e 61 6d 65 20 28 67 ).. (hostname (g
15af0 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 29 0a et-host-name))).
15b00 20 20 20 20 28 74 65 73 74 73 3a 75 70 64 61 74 (tests:updat
15b10 65 2d 63 65 6e 74 72 61 6c 2d 6d 65 74 61 2d 69 e-central-meta-i
15b20 6e 66 6f 20 72 75 6e 2d 69 64 20 74 65 73 74 2d nfo run-id test-
15b30 69 64 20 63 70 75 6c 6f 61 64 20 64 69 73 6b 66 id cpuload diskf
15b40 72 65 65 20 6d 69 6e 75 74 65 73 20 75 6e 61 6d ree minutes unam
15b50 65 20 68 6f 73 74 6e 61 6d 65 29 29 29 0a 20 20 e hostname))).
15b60 20 20 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 74 .;; (define (t
15b70 65 73 74 73 3a 73 65 74 2d 70 61 72 74 69 61 6c ests:set-partial
15b80 2d 6d 65 74 61 2d 69 6e 66 6f 20 74 65 73 74 2d -meta-info test-
15b90 69 64 20 72 75 6e 2d 69 64 20 6d 69 6e 75 74 65 id run-id minute
15ba0 73 20 77 6f 72 6b 2d 61 72 65 61 29 0a 23 3b 28 s work-area).#;(
15bb0 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 73 65 define (tests:se
15bc0 74 2d 70 61 72 74 69 61 6c 2d 6d 65 74 61 2d 69 t-partial-meta-i
15bd0 6e 66 6f 20 74 65 73 74 2d 69 64 20 72 75 6e 2d nfo test-id run-
15be0 69 64 20 6d 69 6e 75 74 65 73 20 77 6f 72 6b 2d id minutes work-
15bf0 61 72 65 61 20 72 65 6d 74 72 69 65 73 29 0a 20 area remtries).
15c00 20 28 6c 65 74 2a 20 28 28 63 70 75 6c 6f 61 64 (let* ((cpuload
15c10 20 20 28 67 65 74 2d 63 70 75 2d 6c 6f 61 64 29 (get-cpu-load)
15c20 29 0a 09 20 28 64 69 73 6b 66 72 65 65 20 28 67 ).. (diskfree (g
15c30 65 74 2d 64 66 20 28 63 75 72 72 65 6e 74 2d 64 et-df (current-d
15c40 69 72 65 63 74 6f 72 79 29 29 29 0a 09 20 28 72 irectory))).. (r
15c50 65 6d 74 72 69 65 73 20 31 30 29 29 0a 20 20 20 emtries 10)).
15c60 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 (handle-excepti
15c70 6f 6e 73 0a 20 20 20 20 20 65 78 6e 0a 20 20 20 ons. exn.
15c80 20 20 28 69 66 20 28 3e 20 72 65 6d 74 72 69 65 (if (> remtrie
15c90 73 20 30 29 0a 09 20 28 62 65 67 69 6e 0a 09 20 s 0).. (begin..
15ca0 20 20 28 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 (print-call-ch
15cb0 61 69 6e 20 28 63 75 72 72 65 6e 74 2d 65 72 72 ain (current-err
15cc0 6f 72 2d 70 6f 72 74 29 29 0a 09 20 20 20 28 64 or-port)).. (d
15cd0 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
15ce0 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
15cf0 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 66 ort* "WARNING: f
15d00 61 69 6c 65 64 20 74 6f 20 73 65 74 20 6d 65 74 ailed to set met
15d10 61 20 69 6e 66 6f 2e 20 57 69 6c 6c 20 74 72 79 a info. Will try
15d20 20 22 20 72 65 6d 74 72 69 65 73 20 22 20 6d 6f " remtries " mo
15d30 72 65 20 74 69 6d 65 73 22 29 0a 09 20 20 20 28 re times").. (
15d40 73 65 74 21 20 72 65 6d 74 72 69 65 73 20 28 2d set! remtries (-
15d50 20 72 65 6d 74 72 69 65 73 20 31 29 29 0a 09 20 remtries 1))..
15d60 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
15d70 20 31 30 29 0a 09 20 20 20 28 74 65 73 74 73 3a 10).. (tests:
15d80 73 65 74 2d 66 75 6c 6c 2d 6d 65 74 61 2d 69 6e set-full-meta-in
15d90 66 6f 20 64 62 20 74 65 73 74 2d 69 64 20 72 75 fo db test-id ru
15da0 6e 2d 69 64 20 6d 69 6e 75 74 65 73 20 77 6f 72 n-id minutes wor
15db0 6b 2d 61 72 65 61 20 28 2d 20 72 65 6d 74 72 69 k-area (- remtri
15dc0 65 73 20 31 29 29 29 0a 09 20 28 6c 65 74 20 28 es 1))).. (let (
15dd0 28 65 72 72 2d 73 74 61 74 75 73 20 28 28 63 6f (err-status ((co
15de0 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 ndition-property
15df0 2d 61 63 63 65 73 73 6f 72 20 27 73 71 6c 69 74 -accessor 'sqlit
15e00 65 33 20 27 73 74 61 74 75 73 20 23 66 29 20 65 e3 'status #f) e
15e10 78 6e 29 29 29 0a 09 20 20 20 28 64 65 62 75 67 xn))).. (debug
15e20 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a :print-error 0 *
15e30 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
15e40 2a 20 22 74 72 69 65 64 20 66 6f 72 20 6f 76 65 * "tried for ove
15e50 72 20 61 20 6d 69 6e 75 74 65 20 74 6f 20 75 70 r a minute to up
15e60 64 61 74 65 20 6d 65 74 61 20 69 6e 66 6f 20 61 date meta info a
15e70 6e 64 20 66 61 69 6c 65 64 2e 20 47 69 76 69 6e nd failed. Givin
15e80 67 20 75 70 22 29 0a 09 20 20 20 28 64 65 62 75 g up").. (debu
15e90 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
15ea0 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 58 lt-log-port* "EX
15eb0 43 45 50 54 49 4f 4e 3a 20 64 61 74 61 62 61 73 CEPTION: databas
15ec0 65 20 70 72 6f 62 61 62 6c 79 20 6f 76 65 72 6c e probably overl
15ed0 6f 61 64 65 64 20 6f 72 20 75 6e 72 65 61 64 61 oaded or unreada
15ee0 62 6c 65 2e 22 29 0a 09 20 20 20 28 64 65 62 75 ble.").. (debu
15ef0 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
15f00 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 6d lt-log-port* " m
15f10 65 73 73 61 67 65 3a 20 22 20 28 28 63 6f 6e 64 essage: " ((cond
15f20 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 ition-property-a
15f30 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 ccessor 'exn 'me
15f40 73 73 61 67 65 29 20 65 78 6e 29 29 0a 09 20 20 ssage) exn))..
15f50 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 35 20 (debug:print 5
15f60 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
15f70 74 2a 20 22 65 78 6e 3d 22 20 28 63 6f 6e 64 69 t* "exn=" (condi
15f80 74 69 6f 6e 2d 3e 6c 69 73 74 20 65 78 6e 29 29 tion->list exn))
15f90 0a 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e .. (debug:prin
15fa0 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
15fb0 2d 70 6f 72 74 2a 20 22 20 73 74 61 74 75 73 3a -port* " status:
15fc0 20 20 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d " ((condition-
15fd0 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f property-accesso
15fe0 72 20 27 73 71 6c 69 74 65 33 20 27 73 74 61 74 r 'sqlite3 'stat
15ff0 75 73 29 20 65 78 6e 29 29 0a 09 20 20 20 28 70 us) exn)).. (p
16000 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 20 rint-call-chain
16010 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 (current-error-p
16020 6f 72 74 29 29 29 29 0a 20 20 20 20 20 28 74 65 ort)))). (te
16030 73 74 73 3a 75 70 64 61 74 65 2d 74 65 73 74 64 sts:update-testd
16040 61 74 2d 6d 65 74 61 2d 69 6e 66 6f 20 64 62 20 at-meta-info db
16050 74 65 73 74 2d 69 64 20 77 6f 72 6b 2d 61 72 65 test-id work-are
16060 61 20 63 70 75 6c 6f 61 64 20 64 69 73 6b 66 72 a cpuload diskfr
16070 65 65 20 6d 69 6e 75 74 65 73 29 0a 20 20 29 29 ee minutes). ))
16080 29 0a 09 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d ).. .;;=========
16090 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
160a0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
160b0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
160c0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
160d0 20 41 20 52 20 43 20 48 20 49 20 56 20 49 20 4e A R C H I V I N
160e0 20 47 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d G.;;===========
160f0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
16100 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
16110 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
16120 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 ===========..(de
16130 66 69 6e 65 20 28 74 65 73 74 3a 61 72 63 68 69 fine (test:archi
16140 76 65 20 64 62 20 74 65 73 74 2d 69 64 29 0a 20 ve db test-id).
16150 20 23 66 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 #f)..(define (t
16160 65 73 74 3a 61 72 63 68 69 76 65 2d 74 65 73 74 est:archive-test
16170 73 20 64 62 20 6b 65 79 6e 61 6d 65 73 20 74 61 s db keynames ta
16180 72 67 65 74 29 0a 20 20 23 66 29 0a 0a rget). #f)..