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 20 54 68 69 73 20 70 ..;; .;; This p
0080: 72 6f 67 72 61 6d 20 69 73 20 6d 61 64 65 20 61 rogram is made a
0090: 76 61 69 6c 61 62 6c 65 20 75 6e 64 65 72 20 74 vailable under t
00a0: 68 65 20 47 4e 55 20 47 50 4c 20 76 65 72 73 69 he GNU GPL versi
00b0: 6f 6e 20 32 2e 30 20 6f 72 0a 3b 3b 20 20 67 72 on 2.0 or.;; gr
00c0: 65 61 74 65 72 2e 20 53 65 65 20 74 68 65 20 61 eater. See the a
00d0: 63 63 6f 6d 70 61 6e 79 69 6e 67 20 66 69 6c 65 ccompanying file
00e0: 20 43 4f 50 59 49 4e 47 20 66 6f 72 20 64 65 74 COPYING for det
00f0: 61 69 6c 73 2e 0a 3b 3b 20 0a 3b 3b 20 20 54 68 ails..;; .;; Th
0100: 69 73 20 70 72 6f 67 72 61 6d 20 69 73 20 64 69 is program is di
0110: 73 74 72 69 62 75 74 65 64 20 57 49 54 48 4f 55 stributed WITHOU
0120: 54 20 41 4e 59 20 57 41 52 52 41 4e 54 59 3b 20 T ANY WARRANTY;
0130: 77 69 74 68 6f 75 74 20 65 76 65 6e 20 74 68 65 without even the
0140: 0a 3b 3b 20 20 69 6d 70 6c 69 65 64 20 77 61 72 .;; implied war
0150: 72 61 6e 74 79 20 6f 66 20 4d 45 52 43 48 41 4e ranty of MERCHAN
0160: 54 41 42 49 4c 49 54 59 20 6f 72 20 46 49 54 4e TABILITY or FITN
0170: 45 53 53 20 46 4f 52 20 41 20 50 41 52 54 49 43 ESS FOR A PARTIC
0180: 55 4c 41 52 0a 3b 3b 20 20 50 55 52 50 4f 53 45 ULAR.;; PURPOSE
0190: 2e 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
01a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 3d 3d ==========..;;==
01e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0200: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0210: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0220: 3d 3d 3d 3d 0a 3b 3b 20 54 65 73 74 73 0a 3b 3b ====.;; Tests.;;
0230: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0240: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0250: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0260: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0270: 3d 3d 3d 3d 3d 3d 0a 0a 28 75 73 65 20 73 71 6c ======..(use sql
0280: 69 74 65 33 20 73 72 66 69 2d 31 20 70 6f 73 69 ite3 srfi-1 posi
0290: 78 20 72 65 67 65 78 20 72 65 67 65 78 2d 63 61 x regex regex-ca
02a0: 73 65 20 73 72 66 69 2d 36 39 20 64 6f 74 2d 6c se srfi-69 dot-l
02b0: 6f 63 6b 69 6e 67 20 74 63 70 20 64 69 72 65 63 ocking tcp direc
02c0: 74 6f 72 79 2d 75 74 69 6c 73 29 0a 28 69 6d 70 tory-utils).(imp
02d0: 6f 72 74 20 28 70 72 65 66 69 78 20 73 71 6c 69 ort (prefix sqli
02e0: 74 65 33 20 73 71 6c 69 74 65 33 3a 29 29 0a 28 te3 sqlite3:)).(
02f0: 72 65 71 75 69 72 65 2d 6c 69 62 72 61 72 79 20 require-library
0300: 73 74 6d 6c 29 0a 0a 28 64 65 63 6c 61 72 65 20 stml)..(declare
0310: 28 75 6e 69 74 20 74 65 73 74 73 29 29 0a 28 64 (unit tests)).(d
0320: 65 63 6c 61 72 65 20 28 75 73 65 73 20 6c 6f 63 eclare (uses loc
0330: 6b 2d 71 75 65 75 65 29 29 0a 28 64 65 63 6c 61 k-queue)).(decla
0340: 72 65 20 28 75 73 65 73 20 64 62 29 29 0a 28 64 re (uses db)).(d
0350: 65 63 6c 61 72 65 20 28 75 73 65 73 20 74 64 62 eclare (uses tdb
0360: 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 )).(declare (use
0370: 73 20 63 6f 6d 6d 6f 6e 29 29 0a 3b 3b 20 28 64 s common)).;; (d
0380: 65 63 6c 61 72 65 20 28 75 73 65 73 20 64 63 6f eclare (uses dco
0390: 6d 6d 6f 6e 29 29 20 3b 3b 20 6e 65 65 64 65 64 mmon)) ;; needed
03a0: 20 66 6f 72 20 74 68 65 20 73 74 65 70 73 20 70 for the steps p
03b0: 72 6f 63 65 73 73 69 6e 67 0a 28 64 65 63 6c 61 rocessing.(decla
03c0: 72 65 20 28 75 73 65 73 20 69 74 65 6d 73 29 29 re (uses items))
03d0: 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 .(declare (uses
03e0: 72 75 6e 63 6f 6e 66 69 67 29 29 0a 3b 3b 20 28 runconfig)).;; (
03f0: 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 73 64 declare (uses sd
0400: 62 29 29 0a 0a 28 69 6e 63 6c 75 64 65 20 22 63 b))..(include "c
0410: 6f 6d 6d 6f 6e 5f 72 65 63 6f 72 64 73 2e 73 63 ommon_records.sc
0420: 6d 22 29 0a 28 69 6e 63 6c 75 64 65 20 22 6b 65 m").(include "ke
0430: 79 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a y_records.scm").
0440: 28 69 6e 63 6c 75 64 65 20 22 64 62 5f 72 65 63 (include "db_rec
0450: 6f 72 64 73 2e 73 63 6d 22 29 0a 28 69 6e 63 6c ords.scm").(incl
0460: 75 64 65 20 22 72 75 6e 5f 72 65 63 6f 72 64 73 ude "run_records
0470: 2e 73 63 6d 22 29 0a 28 69 6e 63 6c 75 64 65 20 .scm").(include
0480: 22 74 65 73 74 5f 72 65 63 6f 72 64 73 2e 73 63 "test_records.sc
0490: 6d 22 29 0a 0a 3b 3b 20 43 61 6c 6c 20 74 68 69 m")..;; Call thi
04a0: 73 20 6f 6e 65 20 74 6f 20 64 6f 20 61 6c 6c 20 s one to do all
04b0: 74 68 65 20 77 6f 72 6b 20 61 6e 64 20 67 65 74 the work and get
04c0: 20 61 20 73 74 61 6e 64 61 72 64 69 7a 65 64 20 a standardized
04d0: 6c 69 73 74 20 6f 66 20 74 65 73 74 73 0a 3b 3b list of tests.;;
04e0: 20 20 20 67 65 74 73 20 70 61 74 68 73 20 66 72 gets paths fr
04f0: 6f 6d 20 63 6f 6e 66 69 67 73 20 61 6e 64 20 66 om configs and f
0500: 69 6e 64 73 20 76 61 6c 69 64 20 74 65 73 74 73 inds valid tests
0510: 20 0a 3b 3b 20 20 20 72 65 74 75 72 6e 73 20 68 .;; returns h
0520: 61 73 68 20 6f 66 20 74 65 73 74 6e 61 6d 65 20 ash of testname
0530: 2d 2d 3e 20 66 75 6c 6c 70 61 74 68 0a 3b 3b 0a --> fullpath.;;.
0540: 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 67 (define (tests:g
0550: 65 74 2d 61 6c 6c 29 0a 20 20 28 6c 65 74 2a 20 et-all). (let*
0560: 28 28 74 65 73 74 2d 73 65 61 72 63 68 2d 70 61 ((test-search-pa
0570: 74 68 20 20 20 28 74 65 73 74 73 3a 67 65 74 2d th (tests:get-
0580: 74 65 73 74 73 2d 73 65 61 72 63 68 2d 70 61 74 tests-search-pat
0590: 68 20 2a 63 6f 6e 66 69 67 64 61 74 2a 29 29 29 h *configdat*)))
05a0: 0a 20 20 20 20 28 74 65 73 74 73 3a 67 65 74 2d . (tests:get-
05b0: 76 61 6c 69 64 2d 74 65 73 74 73 20 28 6d 61 6b valid-tests (mak
05c0: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 20 74 65 e-hash-table) te
05d0: 73 74 2d 73 65 61 72 63 68 2d 70 61 74 68 29 29 st-search-path))
05e0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 )..(define (test
05f0: 73 3a 67 65 74 2d 74 65 73 74 73 2d 73 65 61 72 s:get-tests-sear
0600: 63 68 2d 70 61 74 68 20 63 66 67 64 61 74 29 0a ch-path cfgdat).
0610: 20 20 28 6c 65 74 20 28 28 70 61 74 68 73 20 28 (let ((paths (
0620: 6d 61 70 20 63 61 64 72 20 28 63 6f 6e 66 69 67 map cadr (config
0630: 66 3a 67 65 74 2d 73 65 63 74 69 6f 6e 20 63 66 f:get-section cf
0640: 67 64 61 74 20 22 74 65 73 74 73 2d 70 61 74 68 gdat "tests-path
0650: 73 22 29 29 29 29 0a 20 20 20 20 28 66 69 6c 74 s")))). (filt
0660: 65 72 20 28 6c 61 6d 62 64 61 20 28 64 29 0a 09 er (lambda (d)..
0670: 20 20 20 20 20 20 28 69 66 20 28 64 69 72 65 63 (if (direc
0680: 74 6f 72 79 2d 65 78 69 73 74 73 3f 20 64 29 0a tory-exists? d).
0690: 09 09 20 20 64 0a 09 09 20 20 28 62 65 67 69 6e .. d... (begin
06a0: 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 ... (debug:pr
06b0: 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 int 0 "WARNING:
06c0: 70 72 6f 62 6c 65 6d 20 77 69 74 68 20 64 69 72 problem with dir
06d0: 65 63 74 6f 72 79 20 22 20 64 20 22 2c 20 64 72 ectory " d ", dr
06e0: 6f 70 70 69 6e 67 20 69 74 20 66 72 6f 6d 20 74 opping it from t
06f0: 65 73 74 73 20 70 61 74 68 22 29 0a 09 09 20 20 ests path")...
0700: 20 20 23 66 29 29 29 0a 09 20 20 20 20 28 61 70 #f))).. (ap
0710: 70 65 6e 64 20 70 61 74 68 73 20 28 6c 69 73 74 pend paths (list
0720: 20 28 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a (conc *toppath*
0730: 20 22 2f 74 65 73 74 73 22 29 29 29 29 29 29 0a "/tests")))))).
0740: 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a .(define (tests:
0750: 67 65 74 2d 76 61 6c 69 64 2d 74 65 73 74 73 20 get-valid-tests
0760: 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 74 65 test-registry te
0770: 73 74 73 2d 70 61 74 68 73 29 0a 20 20 28 69 66 sts-paths). (if
0780: 20 28 6e 75 6c 6c 3f 20 74 65 73 74 73 2d 70 61 (null? tests-pa
0790: 74 68 73 29 20 0a 20 20 20 20 20 20 74 65 73 74 ths) . test
07a0: 2d 72 65 67 69 73 74 72 79 0a 20 20 20 20 20 20 -registry.
07b0: 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 (let loop ((hed
07c0: 28 63 61 72 20 74 65 73 74 73 2d 70 61 74 68 73 (car tests-paths
07d0: 29 29 0a 09 09 20 28 74 61 6c 20 28 63 64 72 20 ))... (tal (cdr
07e0: 74 65 73 74 73 2d 70 61 74 68 73 29 29 29 0a 09 tests-paths)))..
07f0: 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 (if (file-exists
0800: 3f 20 68 65 64 29 0a 09 20 20 20 20 28 66 6f 72 ? hed).. (for
0810: 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 74 -each (lambda (t
0820: 65 73 74 2d 70 61 74 68 29 0a 09 09 09 28 6c 65 est-path)....(le
0830: 74 2a 20 28 28 74 6e 61 6d 65 20 20 20 28 6c 61 t* ((tname (la
0840: 73 74 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 st (string-split
0850: 20 74 65 73 74 2d 70 61 74 68 20 22 2f 22 29 29 test-path "/"))
0860: 29 0a 09 09 09 20 20 20 20 20 20 20 28 74 63 6f ).... (tco
0870: 6e 66 69 67 20 28 63 6f 6e 63 20 74 65 73 74 2d nfig (conc test-
0880: 70 61 74 68 20 22 2f 74 65 73 74 63 6f 6e 66 69 path "/testconfi
0890: 67 22 29 29 29 0a 09 09 09 20 20 28 69 66 20 28 g"))).... (if (
08a0: 61 6e 64 20 28 6e 6f 74 20 28 68 61 73 68 2d 74 and (not (hash-t
08b0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
08c0: 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 74 test-registry t
08d0: 6e 61 6d 65 20 23 66 29 29 0a 09 09 09 09 20 20 name #f)).....
08e0: 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 74 (file-exists? t
08f0: 63 6f 6e 66 69 67 29 29 0a 09 09 09 20 20 20 20 config))....
0900: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
0910: 74 21 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 t! test-registry
0920: 20 74 6e 61 6d 65 20 74 65 73 74 2d 70 61 74 68 tname test-path
0930: 29 29 29 29 0a 09 09 20 20 20 20 20 20 28 67 6c ))))... (gl
0940: 6f 62 20 28 63 6f 6e 63 20 68 65 64 20 22 2f 2a ob (conc hed "/*
0950: 22 29 29 29 29 0a 09 28 69 66 20 28 6e 75 6c 6c "))))..(if (null
0960: 3f 20 74 61 6c 29 0a 09 20 20 20 20 74 65 73 74 ? tal).. test
0970: 2d 72 65 67 69 73 74 72 79 0a 09 20 20 20 20 28 -registry.. (
0980: 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 loop (car tal)(c
0990: 64 72 20 74 61 6c 29 29 29 29 29 29 0a 0a 28 64 dr tal))))))..(d
09a0: 65 66 69 6e 65 20 28 74 65 73 74 73 3a 66 69 6c efine (tests:fil
09b0: 74 65 72 2d 74 65 73 74 2d 6e 61 6d 65 73 20 74 ter-test-names t
09c0: 65 73 74 2d 6e 61 6d 65 73 20 74 65 73 74 2d 70 est-names test-p
09d0: 61 74 74 73 29 0a 20 20 28 64 65 6c 65 74 65 2d atts). (delete-
09e0: 64 75 70 6c 69 63 61 74 65 73 0a 20 20 20 28 66 duplicates. (f
09f0: 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 74 ilter (lambda (t
0a00: 65 73 74 6e 61 6d 65 29 0a 09 20 20 20 20 20 28 estname).. (
0a10: 74 65 73 74 73 3a 6d 61 74 63 68 20 74 65 73 74 tests:match test
0a20: 2d 70 61 74 74 73 20 74 65 73 74 6e 61 6d 65 20 -patts testname
0a30: 23 66 29 29 0a 09 20 20 20 74 65 73 74 2d 6e 61 #f)).. test-na
0a40: 6d 65 73 29 29 29 0a 0a 3b 3b 20 67 69 76 65 6e mes)))..;; given
0a50: 20 74 65 73 74 2d 62 20 74 68 61 74 20 69 73 20 test-b that is
0a60: 77 61 69 74 69 6e 67 20 6f 6e 20 74 65 73 74 2d waiting on test-
0a70: 61 20 65 78 74 65 6e 64 20 74 65 73 74 2d 70 61 a extend test-pa
0a80: 74 74 20 61 70 70 72 6f 70 72 69 61 74 65 6c 79 tt appropriately
0a90: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 65 73 .;;.(define (tes
0aa0: 74 73 3a 65 78 74 65 6e 64 2d 74 65 73 74 2d 70 ts:extend-test-p
0ab0: 61 74 74 73 20 74 65 73 74 2d 70 61 74 74 20 74 atts test-patt t
0ac0: 65 73 74 2d 62 20 74 65 73 74 2d 61 20 69 74 65 est-b test-a ite
0ad0: 6d 6d 61 70 29 0a 20 20 28 6c 65 74 2a 20 28 28 mmap). (let* ((
0ae0: 70 61 74 74 73 20 20 20 20 20 20 28 73 74 72 69 patts (stri
0af0: 6e 67 2d 73 70 6c 69 74 20 74 65 73 74 2d 70 61 ng-split test-pa
0b00: 74 74 20 22 2c 22 29 29 0a 09 20 28 74 65 73 74 tt ",")).. (test
0b10: 2d 62 2d 6c 65 6e 20 28 2b 20 28 73 74 72 69 6e -b-len (+ (strin
0b20: 67 2d 6c 65 6e 67 74 68 20 74 65 73 74 2d 62 29 g-length test-b)
0b30: 20 31 29 29 0a 09 20 28 70 61 74 74 73 2d 62 20 1)).. (patts-b
0b40: 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 (map (lambda
0b50: 28 78 29 0a 09 09 09 20 20 20 20 28 6c 65 74 20 (x).... (let
0b60: 28 28 6e 65 77 70 61 74 74 20 28 63 6f 6e 63 20 ((newpatt (conc
0b70: 74 65 73 74 2d 61 20 22 2f 22 20 28 73 75 62 73 test-a "/" (subs
0b80: 74 72 69 6e 67 20 78 20 74 65 73 74 2d 62 2d 6c tring x test-b-l
0b90: 65 6e 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 en (string-lengt
0ba0: 68 20 78 29 29 29 29 29 0a 09 09 09 20 20 20 20 h x)))))....
0bb0: 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 69 6e 20 ;; (print "in
0bc0: 6d 61 70 2c 20 78 3d 22 20 78 20 22 2c 20 6e 65 map, x=" x ", ne
0bd0: 77 70 61 74 74 3d 22 20 6e 65 77 70 61 74 74 29 wpatt=" newpatt)
0be0: 0a 09 09 09 20 20 20 20 20 20 6e 65 77 70 61 74 .... newpat
0bf0: 74 29 29 0a 09 09 09 20 20 28 66 69 6c 74 65 72 t)).... (filter
0c00: 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 09 09 (lambda (x)....
0c10: 09 20 20 20 20 28 65 71 3f 20 28 73 75 62 73 74 . (eq? (subst
0c20: 72 69 6e 67 2d 69 6e 64 65 78 20 28 63 6f 6e 63 ring-index (conc
0c30: 20 74 65 73 74 2d 62 20 22 2f 22 29 20 78 29 20 test-b "/") x)
0c40: 30 29 29 0a 09 09 09 09 20 20 70 61 74 74 73 29 0))..... patts)
0c50: 29 29 29 0a 20 20 20 20 28 73 74 72 69 6e 67 2d ))). (string-
0c60: 69 6e 74 65 72 73 70 65 72 73 65 20 28 64 65 6c intersperse (del
0c70: 65 74 65 2d 64 75 70 6c 69 63 61 74 65 73 20 28 ete-duplicates (
0c80: 61 70 70 65 6e 64 20 70 61 74 74 73 20 28 69 66 append patts (if
0c90: 20 28 6e 75 6c 6c 3f 20 70 61 74 74 73 2d 62 29 (null? patts-b)
0ca0: 0a 09 09 09 09 09 09 09 20 20 20 20 20 28 6c 69 ........ (li
0cb0: 73 74 20 28 63 6f 6e 63 20 74 65 73 74 2d 61 20 st (conc test-a
0cc0: 22 2f 25 22 29 29 0a 09 09 09 09 09 09 09 20 20 "/%"))........
0cd0: 20 20 20 70 61 74 74 73 2d 62 29 29 29 0a 09 09 patts-b)))...
0ce0: 09 22 2c 22 29 29 29 0a 20 20 0a 3b 3b 20 74 65 .","))). .;; te
0cf0: 73 74 73 3a 67 6c 6f 62 2d 6c 69 6b 65 2d 6d 61 sts:glob-like-ma
0d00: 74 63 68 20 0a 28 64 65 66 69 6e 65 20 28 74 65 tch .(define (te
0d10: 73 74 73 3a 67 6c 6f 62 2d 6c 69 6b 65 2d 6d 61 sts:glob-like-ma
0d20: 74 63 68 20 70 61 74 74 20 73 74 72 29 20 0a 20 tch patt str) .
0d30: 20 28 6c 65 74 20 28 28 6c 69 6b 65 20 28 73 75 (let ((like (su
0d40: 62 73 74 72 69 6e 67 2d 69 6e 64 65 78 20 22 25 bstring-index "%
0d50: 22 20 70 61 74 74 29 29 29 0a 20 20 20 20 28 6c " patt))). (l
0d60: 65 74 2a 20 28 28 6e 6f 74 70 61 74 74 20 20 28 et* ((notpatt (
0d70: 65 71 75 61 6c 3f 20 28 73 75 62 73 74 72 69 6e equal? (substrin
0d80: 67 2d 69 6e 64 65 78 20 22 7e 22 20 70 61 74 74 g-index "~" patt
0d90: 29 20 30 29 29 0a 09 20 20 20 28 6e 65 77 70 61 ) 0)).. (newpa
0da0: 74 74 20 20 28 69 66 20 6e 6f 74 70 61 74 74 20 tt (if notpatt
0db0: 28 73 75 62 73 74 72 69 6e 67 20 70 61 74 74 20 (substring patt
0dc0: 31 29 20 70 61 74 74 29 29 0a 09 20 20 20 28 66 1) patt)).. (f
0dd0: 69 6e 70 61 74 74 20 20 28 69 66 20 6c 69 6b 65 inpatt (if like
0de0: 0a 09 09 09 28 73 74 72 69 6e 67 2d 73 75 62 73 ....(string-subs
0df0: 74 69 74 75 74 65 20 28 72 65 67 65 78 70 20 22 titute (regexp "
0e00: 25 22 29 20 22 2e 2a 22 20 6e 65 77 70 61 74 74 %") ".*" newpatt
0e10: 20 23 66 29 0a 09 09 09 28 73 74 72 69 6e 67 2d #f)....(string-
0e20: 73 75 62 73 74 69 74 75 74 65 20 28 72 65 67 65 substitute (rege
0e30: 78 70 20 22 5c 5c 2a 22 29 20 22 2e 2a 22 20 6e xp "\\*") ".*" n
0e40: 65 77 70 61 74 74 20 23 66 29 29 29 0a 09 20 20 ewpatt #f)))..
0e50: 20 28 72 65 73 20 20 20 20 20 20 23 66 29 29 0a (res #f)).
0e60: 20 20 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 ;; (print
0e70: 22 74 65 73 74 73 3a 67 6c 6f 62 2d 6c 69 6b 65 "tests:glob-like
0e80: 2d 6d 61 74 63 68 20 3d 3e 20 6e 6f 74 70 61 74 -match => notpat
0e90: 74 3a 20 22 20 6e 6f 74 70 61 74 74 20 22 2c 20 t: " notpatt ",
0ea0: 6e 65 77 70 61 74 74 3a 20 22 20 6e 65 77 70 61 newpatt: " newpa
0eb0: 74 74 20 22 2c 20 66 69 6e 70 61 74 74 3a 20 22 tt ", finpatt: "
0ec0: 20 66 69 6e 70 61 74 74 29 0a 20 20 20 20 20 20 finpatt).
0ed0: 28 73 65 74 21 20 72 65 73 20 28 73 74 72 69 6e (set! res (strin
0ee0: 67 2d 6d 61 74 63 68 20 28 72 65 67 65 78 70 20 g-match (regexp
0ef0: 66 69 6e 70 61 74 74 20 28 69 66 20 6c 69 6b 65 finpatt (if like
0f00: 20 23 74 20 23 66 29 29 20 73 74 72 29 29 0a 20 #t #f)) str)).
0f10: 20 20 20 20 20 28 69 66 20 6e 6f 74 70 61 74 74 (if notpatt
0f20: 20 28 6e 6f 74 20 72 65 73 29 20 72 65 73 29 29 (not res) res))
0f30: 29 29 0a 0a 3b 3b 20 69 66 20 69 74 65 6d 70 61 ))..;; if itempa
0f40: 74 68 20 69 73 20 23 66 20 74 68 65 6e 20 6c 6f th is #f then lo
0f50: 6f 6b 20 6f 6e 6c 79 20 61 74 20 74 68 65 20 74 ok only at the t
0f60: 65 73 74 6e 61 6d 65 20 70 61 72 74 0a 3b 3b 0a estname part.;;.
0f70: 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 6d (define (tests:m
0f80: 61 74 63 68 20 70 61 74 74 65 72 6e 73 20 74 65 atch patterns te
0f90: 73 74 6e 61 6d 65 20 69 74 65 6d 70 61 74 68 20 stname itempath
0fa0: 23 21 6b 65 79 20 28 72 65 71 75 69 72 65 64 20 #!key (required
0fb0: 27 28 29 29 29 0a 20 20 28 69 66 20 28 73 74 72 '())). (if (str
0fc0: 69 6e 67 3f 20 70 61 74 74 65 72 6e 73 29 0a 20 ing? patterns).
0fd0: 20 20 20 20 20 28 6c 65 74 20 28 28 70 61 74 74 (let ((patt
0fe0: 73 20 28 61 70 70 65 6e 64 20 28 73 74 72 69 6e s (append (strin
0ff0: 67 2d 73 70 6c 69 74 20 70 61 74 74 65 72 6e 73 g-split patterns
1000: 20 22 2c 22 29 20 72 65 71 75 69 72 65 64 29 29 ",") required))
1010: 29 0a 09 28 69 66 20 28 6e 75 6c 6c 3f 20 70 61 )..(if (null? pa
1020: 74 74 73 29 20 3b 3b 3b 20 6e 6f 20 70 61 74 74 tts) ;;; no patt
1030: 65 72 6e 28 73 29 20 6d 65 61 6e 73 20 6e 6f 20 ern(s) means no
1040: 6d 61 74 63 68 0a 09 20 20 20 20 23 66 0a 09 20 match.. #f..
1050: 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 70 (let loop ((p
1060: 61 74 74 20 28 63 61 72 20 70 61 74 74 73 29 29 att (car patts))
1070: 0a 09 09 20 20 20 20 20 20 20 28 74 61 6c 20 20 ... (tal
1080: 28 63 64 72 20 70 61 74 74 73 29 29 29 0a 09 20 (cdr patts)))..
1090: 20 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 ;; (print "
10a0: 6c 6f 6f 70 3a 20 70 61 74 74 3a 20 22 20 70 61 loop: patt: " pa
10b0: 74 74 20 22 2c 20 74 61 6c 20 22 20 74 61 6c 29 tt ", tal " tal)
10c0: 0a 09 20 20 20 20 20 20 28 69 66 20 28 73 74 72 .. (if (str
10d0: 69 6e 67 3d 3f 20 70 61 74 74 20 22 22 29 0a 09 ing=? patt "")..
10e0: 09 20 20 23 66 20 3b 3b 20 6e 6f 74 68 69 6e 67 . #f ;; nothing
10f0: 20 65 76 65 72 20 6d 61 74 63 68 65 73 20 65 6d ever matches em
1100: 70 74 79 20 73 74 72 69 6e 67 20 2d 20 70 6f 6c pty string - pol
1110: 69 63 79 0a 09 09 20 20 28 6c 65 74 2a 20 28 28 icy... (let* ((
1120: 70 61 74 74 2d 70 61 72 74 73 20 28 73 74 72 69 patt-parts (stri
1130: 6e 67 2d 6d 61 74 63 68 20 28 72 65 67 65 78 70 ng-match (regexp
1140: 20 22 5e 28 5b 5e 5c 5c 2f 5d 2a 29 28 5c 5c 2f "^([^\\/]*)(\\/
1150: 28 2e 2a 29 7c 29 24 22 29 20 70 61 74 74 29 29 (.*)|)$") patt))
1160: 0a 09 09 09 20 28 74 65 73 74 2d 70 61 74 74 20 .... (test-patt
1170: 20 28 63 61 64 72 20 70 61 74 74 2d 70 61 72 74 (cadr patt-part
1180: 73 29 29 0a 09 09 09 20 28 69 74 65 6d 2d 70 61 s)).... (item-pa
1190: 74 74 20 20 28 63 61 64 64 64 72 20 70 61 74 74 tt (cadddr patt
11a0: 2d 70 61 72 74 73 29 29 29 0a 09 09 20 20 20 20 -parts)))...
11b0: 3b 3b 20 73 70 65 63 69 61 6c 20 63 61 73 65 3a ;; special case:
11c0: 20 74 65 73 74 20 76 73 2e 20 74 65 73 74 2f 0a test vs. test/.
11d0: 09 09 20 20 20 20 3b 3b 20 20 20 74 65 73 74 20 .. ;; test
11e0: 20 3d 3e 20 22 74 65 73 74 22 20 22 25 22 0a 09 => "test" "%"..
11f0: 09 20 20 20 20 3b 3b 20 20 20 74 65 73 74 2f 20 . ;; test/
1200: 3d 3e 20 22 74 65 73 74 22 20 22 22 0a 09 09 20 => "test" ""...
1210: 20 20 20 28 69 66 20 28 61 6e 64 20 28 6e 6f 74 (if (and (not
1220: 20 28 73 75 62 73 74 72 69 6e 67 2d 69 6e 64 65 (substring-inde
1230: 78 20 22 2f 22 20 70 61 74 74 29 29 20 3b 3b 20 x "/" patt)) ;;
1240: 6e 6f 20 73 6c 61 73 68 20 69 6e 20 74 68 65 20 no slash in the
1250: 6f 72 69 67 69 6e 61 6c 0a 09 09 09 20 20 20 20 original....
1260: 20 28 6f 72 20 28 6e 6f 74 20 69 74 65 6d 2d 70 (or (not item-p
1270: 61 74 74 29 0a 09 09 09 09 20 28 65 71 75 61 6c att)..... (equal
1280: 3f 20 69 74 65 6d 2d 70 61 74 74 20 22 22 29 29 ? item-patt ""))
1290: 29 20 20 20 20 20 20 3b 3b 20 73 68 6f 75 6c 64 ) ;; should
12a0: 20 61 6c 77 61 79 73 20 62 65 20 74 72 75 65 20 always be true
12b0: 74 68 61 74 20 69 74 65 6d 2d 70 61 74 74 20 69 that item-patt i
12c0: 73 20 22 22 0a 09 09 09 28 73 65 74 21 20 69 74 s ""....(set! it
12d0: 65 6d 2d 70 61 74 74 20 22 25 22 29 29 0a 09 09 em-patt "%"))...
12e0: 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 74 ;; (print "t
12f0: 65 73 74 73 3a 6d 61 74 63 68 20 3d 3e 20 70 61 ests:match => pa
1300: 74 74 2d 70 61 72 74 73 3a 20 22 20 70 61 74 74 tt-parts: " patt
1310: 2d 70 61 72 74 73 20 22 2c 20 74 65 73 74 2d 70 -parts ", test-p
1320: 61 74 74 3a 20 22 20 74 65 73 74 2d 70 61 74 74 att: " test-patt
1330: 20 22 2c 20 69 74 65 6d 2d 70 61 74 74 3a 20 22 ", item-patt: "
1340: 20 69 74 65 6d 2d 70 61 74 74 29 0a 09 09 20 20 item-patt)...
1350: 20 20 28 69 66 20 28 61 6e 64 20 28 74 65 73 74 (if (and (test
1360: 73 3a 67 6c 6f 62 2d 6c 69 6b 65 2d 6d 61 74 63 s:glob-like-matc
1370: 68 20 74 65 73 74 2d 70 61 74 74 20 74 65 73 74 h test-patt test
1380: 6e 61 6d 65 29 0a 09 09 09 20 20 20 20 20 28 6f name).... (o
1390: 72 20 28 6e 6f 74 20 69 74 65 6d 70 61 74 68 29 r (not itempath)
13a0: 0a 09 09 09 09 20 28 74 65 73 74 73 3a 67 6c 6f ..... (tests:glo
13b0: 62 2d 6c 69 6b 65 2d 6d 61 74 63 68 20 28 69 66 b-like-match (if
13c0: 20 69 74 65 6d 2d 70 61 74 74 20 69 74 65 6d 2d item-patt item-
13d0: 70 61 74 74 20 22 22 29 20 69 74 65 6d 70 61 74 patt "") itempat
13e0: 68 29 29 29 0a 09 09 09 23 74 0a 09 09 09 28 69 h)))....#t....(i
13f0: 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 f (null? tal)...
1400: 09 20 20 20 20 23 66 0a 09 09 09 20 20 20 20 28 . #f.... (
1410: 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 loop (car tal)(c
1420: 64 72 20 74 61 6c 29 29 29 29 29 29 29 29 29 29 dr tal))))))))))
1430: 29 0a 0a 3b 3b 20 69 66 20 69 74 65 6d 70 61 74 )..;; if itempat
1440: 68 20 69 73 20 23 66 20 74 68 65 6e 20 6c 6f 6f h is #f then loo
1450: 6b 20 6f 6e 6c 79 20 61 74 20 74 68 65 20 74 65 k only at the te
1460: 73 74 6e 61 6d 65 20 70 61 72 74 0a 3b 3b 0a 28 stname part.;;.(
1470: 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 6d 61 define (tests:ma
1480: 74 63 68 2d 3e 73 71 6c 71 72 79 20 70 61 74 74 tch->sqlqry patt
1490: 65 72 6e 73 29 0a 20 20 28 69 66 20 28 73 74 72 erns). (if (str
14a0: 69 6e 67 3f 20 70 61 74 74 65 72 6e 73 29 0a 20 ing? patterns).
14b0: 20 20 20 20 20 28 6c 65 74 20 28 28 70 61 74 74 (let ((patt
14c0: 73 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 s (string-split
14d0: 70 61 74 74 65 72 6e 73 20 22 2c 22 29 29 29 0a patterns ","))).
14e0: 09 28 69 66 20 28 6e 75 6c 6c 3f 20 70 61 74 74 .(if (null? patt
14f0: 73 29 20 3b 3b 3b 20 6e 6f 20 70 61 74 74 65 72 s) ;;; no patter
1500: 6e 28 73 29 20 6d 65 61 6e 73 20 6e 6f 20 6d 61 n(s) means no ma
1510: 74 63 68 2c 20 77 65 20 77 69 6c 6c 20 64 6f 20 tch, we will do
1520: 6e 6f 20 71 75 65 72 79 0a 09 20 20 20 20 23 66 no query.. #f
1530: 0a 09 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 .. (let loop
1540: 28 28 70 61 74 74 20 28 63 61 72 20 70 61 74 74 ((patt (car patt
1550: 73 29 29 0a 09 09 20 20 20 20 20 20 20 28 74 61 s))... (ta
1560: 6c 20 20 28 63 64 72 20 70 61 74 74 73 29 29 0a l (cdr patts)).
1570: 09 09 20 20 20 20 20 20 20 28 72 65 73 20 20 27 .. (res '
1580: 28 29 29 29 0a 09 20 20 20 20 20 20 3b 3b 20 28 ())).. ;; (
1590: 70 72 69 6e 74 20 22 6c 6f 6f 70 3a 20 70 61 74 print "loop: pat
15a0: 74 3a 20 22 20 70 61 74 74 20 22 2c 20 74 61 6c t: " patt ", tal
15b0: 20 22 20 74 61 6c 29 0a 09 20 20 20 20 20 20 28 " tal).. (
15c0: 6c 65 74 2a 20 28 28 70 61 74 74 2d 70 61 72 74 let* ((patt-part
15d0: 73 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 s (string-match
15e0: 28 72 65 67 65 78 70 20 22 5e 28 5b 5e 5c 5c 2f (regexp "^([^\\/
15f0: 5d 2a 29 28 5c 5c 2f 28 2e 2a 29 7c 29 24 22 29 ]*)(\\/(.*)|)$")
1600: 20 70 61 74 74 29 29 0a 09 09 20 20 20 20 20 28 patt))... (
1610: 74 65 73 74 2d 70 61 74 74 20 20 28 63 61 64 72 test-patt (cadr
1620: 20 70 61 74 74 2d 70 61 72 74 73 29 29 0a 09 09 patt-parts))...
1630: 20 20 20 20 20 28 69 74 65 6d 2d 70 61 74 74 20 (item-patt
1640: 20 28 63 61 64 64 64 72 20 70 61 74 74 2d 70 61 (cadddr patt-pa
1650: 72 74 73 29 29 0a 09 09 20 20 20 20 20 28 74 65 rts))... (te
1660: 73 74 2d 71 72 79 20 20 20 28 64 62 3a 70 61 74 st-qry (db:pat
1670: 74 2d 3e 6c 69 6b 65 20 22 74 65 73 74 6e 61 6d t->like "testnam
1680: 65 22 20 74 65 73 74 2d 70 61 74 74 29 29 0a 09 e" test-patt))..
1690: 09 20 20 20 20 20 28 69 74 65 6d 2d 71 72 79 20 . (item-qry
16a0: 20 20 28 64 62 3a 70 61 74 74 2d 3e 6c 69 6b 65 (db:patt->like
16b0: 20 22 69 74 65 6d 5f 70 61 74 68 22 20 69 74 65 "item_path" ite
16c0: 6d 2d 70 61 74 74 29 29 0a 09 09 20 20 20 20 20 m-patt))...
16d0: 28 71 72 79 20 20 20 20 20 20 20 20 28 63 6f 6e (qry (con
16e0: 63 20 22 28 22 20 74 65 73 74 2d 71 72 79 20 22 c "(" test-qry "
16f0: 20 41 4e 44 20 22 20 69 74 65 6d 2d 71 72 79 20 AND " item-qry
1700: 22 29 22 29 29 29 0a 09 09 3b 3b 20 28 70 72 69 ")")))...;; (pri
1710: 6e 74 20 22 74 65 73 74 73 3a 6d 61 74 63 68 20 nt "tests:match
1720: 3d 3e 20 70 61 74 74 2d 70 61 72 74 73 3a 20 22 => patt-parts: "
1730: 20 70 61 74 74 2d 70 61 72 74 73 20 22 2c 20 74 patt-parts ", t
1740: 65 73 74 2d 70 61 74 74 3a 20 22 20 74 65 73 74 est-patt: " test
1750: 2d 70 61 74 74 20 22 2c 20 69 74 65 6d 2d 70 61 -patt ", item-pa
1760: 74 74 3a 20 22 20 69 74 65 6d 2d 70 61 74 74 29 tt: " item-patt)
1770: 0a 09 09 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 ...(if (null? ta
1780: 6c 29 0a 09 09 20 20 20 20 28 73 74 72 69 6e 67 l)... (string
1790: 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 61 70 -intersperse (ap
17a0: 70 65 6e 64 20 28 72 65 76 65 72 73 65 20 72 65 pend (reverse re
17b0: 73 29 28 6c 69 73 74 20 71 72 79 29 29 20 22 20 s)(list qry)) "
17c0: 4f 52 20 22 29 0a 09 09 20 20 20 20 28 6c 6f 6f OR ")... (loo
17d0: 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 p (car tal)(cdr
17e0: 74 61 6c 29 28 63 6f 6e 73 20 71 72 79 20 72 65 tal)(cons qry re
17f0: 73 29 29 29 29 29 29 29 0a 20 20 20 20 20 20 23 s))))))). #
1800: 66 29 29 0a 0a 3b 3b 20 43 68 65 63 6b 20 66 6f f))..;; Check fo
1810: 72 20 77 61 69 76 65 72 20 65 6c 69 67 69 62 69 r waiver eligibi
1820: 6c 69 74 79 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 lity.;;.(define
1830: 28 74 65 73 74 73 3a 63 68 65 63 6b 2d 77 61 69 (tests:check-wai
1840: 76 65 72 2d 65 6c 69 67 69 62 69 6c 69 74 79 20 ver-eligibility
1850: 74 65 73 74 64 61 74 20 70 72 65 76 2d 74 65 73 testdat prev-tes
1860: 74 64 61 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 tdat). (let* ((
1870: 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 28 6d test-registry (m
1880: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
1890: 0a 09 20 28 74 65 73 74 63 6f 6e 66 69 67 20 20 .. (testconfig
18a0: 28 74 65 73 74 73 3a 67 65 74 2d 74 65 73 74 63 (tests:get-testc
18b0: 6f 6e 66 69 67 20 28 64 62 3a 74 65 73 74 2d 67 onfig (db:test-g
18c0: 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 et-testname test
18d0: 64 61 74 29 20 74 65 73 74 2d 72 65 67 69 73 74 dat) test-regist
18e0: 72 79 20 23 66 29 29 0a 09 20 28 74 65 73 74 2d ry #f)).. (test-
18f0: 72 75 6e 64 69 72 20 3b 3b 20 28 73 64 62 3a 71 rundir ;; (sdb:q
1900: 72 79 20 27 70 61 73 73 73 74 72 20 0a 09 20 20 ry 'passstr ..
1910: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e (db:test-get-run
1920: 64 69 72 20 74 65 73 74 64 61 74 29 29 20 3b 3b dir testdat)) ;;
1930: 20 29 0a 09 20 28 70 72 65 76 2d 72 75 6e 64 69 ).. (prev-rundi
1940: 72 20 3b 3b 20 28 73 64 62 3a 71 72 79 20 27 70 r ;; (sdb:qry 'p
1950: 61 73 73 73 74 72 20 0a 09 20 20 28 64 62 3a 74 assstr .. (db:t
1960: 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 20 70 est-get-rundir p
1970: 72 65 76 2d 74 65 73 74 64 61 74 29 29 20 3b 3b rev-testdat)) ;;
1980: 20 29 0a 09 20 28 77 61 69 76 65 72 73 20 20 20 ).. (waivers
1990: 20 20 28 69 66 20 74 65 73 74 63 6f 6e 66 69 67 (if testconfig
19a0: 20 28 63 6f 6e 66 69 67 66 3a 73 65 63 74 69 6f (configf:sectio
19b0: 6e 2d 76 61 72 73 20 74 65 73 74 63 6f 6e 66 69 n-vars testconfi
19c0: 67 20 22 77 61 69 76 65 72 73 22 29 20 27 28 29 g "waivers") '()
19d0: 29 29 0a 09 20 28 77 61 69 76 65 72 2d 72 78 20 )).. (waiver-rx
19e0: 20 20 28 72 65 67 65 78 70 20 22 5e 28 5c 5c 53 (regexp "^(\\S
19f0: 2b 29 5c 5c 73 2b 28 2e 2a 29 24 22 29 29 0a 09 +)\\s+(.*)$"))..
1a00: 20 28 64 69 66 66 2d 72 75 6c 65 20 20 20 22 64 (diff-rule "d
1a10: 69 66 66 20 25 66 69 6c 65 31 25 20 25 66 69 6c iff %file1% %fil
1a20: 65 32 25 22 29 0a 09 20 28 6c 6f 67 70 72 6f 2d e2%").. (logpro-
1a30: 72 75 6c 65 20 22 64 69 66 66 20 25 66 69 6c 65 rule "diff %file
1a40: 31 25 20 25 66 69 6c 65 32 25 20 7c 20 6c 6f 67 1% %file2% | log
1a50: 70 72 6f 20 25 77 61 69 76 65 72 6e 61 6d 65 25 pro %waivername%
1a60: 2e 6c 6f 67 70 72 6f 20 25 77 61 69 76 65 72 6e .logpro %waivern
1a70: 61 6d 65 25 2e 68 74 6d 6c 22 29 29 0a 20 20 20 ame%.html")).
1a80: 20 28 69 66 20 28 6e 6f 74 20 28 66 69 6c 65 2d (if (not (file-
1a90: 65 78 69 73 74 73 3f 20 74 65 73 74 2d 72 75 6e exists? test-run
1aa0: 64 69 72 29 29 0a 09 28 62 65 67 69 6e 0a 09 20 dir))..(begin..
1ab0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
1ac0: 22 45 52 52 4f 52 3a 20 74 65 73 74 20 72 75 6e "ERROR: test run
1ad0: 20 64 69 72 65 63 74 6f 72 79 20 69 73 20 67 6f directory is go
1ae0: 6e 65 2c 20 63 61 6e 6e 6f 74 20 70 72 6f 70 61 ne, cannot propa
1af0: 67 61 74 65 20 77 61 69 76 65 72 22 29 0a 09 20 gate waiver")..
1b00: 20 23 66 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 #f)..(begin..
1b10: 28 70 75 73 68 2d 64 69 72 65 63 74 6f 72 79 20 (push-directory
1b20: 74 65 73 74 2d 72 75 6e 64 69 72 29 0a 09 20 20 test-rundir)..
1b30: 28 6c 65 74 20 28 28 72 65 73 75 6c 74 20 28 69 (let ((result (i
1b40: 66 20 28 6e 75 6c 6c 3f 20 77 61 69 76 65 72 73 f (null? waivers
1b50: 29 0a 09 09 09 20 20 20 20 23 66 0a 09 09 09 20 ).... #f....
1b60: 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 (let loop ((h
1b70: 65 64 20 28 63 61 72 20 77 61 69 76 65 72 73 29 ed (car waivers)
1b80: 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 74 61 )..... (ta
1b90: 6c 20 28 63 64 72 20 77 61 69 76 65 72 73 29 29 l (cdr waivers))
1ba0: 29 0a 09 09 09 20 20 20 20 20 20 28 64 65 62 75 ).... (debu
1bb0: 67 3a 70 72 69 6e 74 20 30 20 22 49 4e 46 4f 3a g:print 0 "INFO:
1bc0: 20 41 70 70 6c 79 69 6e 67 20 77 61 69 76 65 72 Applying waiver
1bd0: 20 72 75 6c 65 20 5c 22 22 20 68 65 64 20 22 5c rule \"" hed "\
1be0: 22 22 29 0a 09 09 09 20 20 20 20 20 20 28 6c 65 "").... (le
1bf0: 74 2a 20 28 28 77 61 69 76 65 72 20 20 20 20 20 t* ((waiver
1c00: 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 (configf:lookup
1c10: 20 74 65 73 74 63 6f 6e 66 69 67 20 22 77 61 69 testconfig "wai
1c20: 76 65 72 73 22 20 68 65 64 29 29 0a 09 09 09 09 vers" hed)).....
1c30: 20 20 20 20 20 28 77 70 61 72 74 73 20 20 20 20 (wparts
1c40: 20 20 28 69 66 20 77 61 69 76 65 72 20 28 73 74 (if waiver (st
1c50: 72 69 6e 67 2d 6d 61 74 63 68 20 77 61 69 76 65 ring-match waive
1c60: 72 2d 72 78 20 77 61 69 76 65 72 29 20 23 66 29 r-rx waiver) #f)
1c70: 29 0a 09 09 09 09 20 20 20 20 20 28 77 61 69 76 )..... (waiv
1c80: 65 72 2d 72 75 6c 65 20 28 69 66 20 77 70 61 72 er-rule (if wpar
1c90: 74 73 20 28 63 61 64 72 20 77 70 61 72 74 73 29 ts (cadr wparts)
1ca0: 20 20 23 66 29 29 0a 09 09 09 09 20 20 20 20 20 #f)).....
1cb0: 28 77 61 69 76 65 72 2d 67 6c 6f 62 20 28 69 66 (waiver-glob (if
1cc0: 20 77 70 61 72 74 73 20 28 63 61 64 64 72 20 77 wparts (caddr w
1cd0: 70 61 72 74 73 29 20 23 66 29 29 0a 09 09 09 09 parts) #f)).....
1ce0: 20 20 20 20 20 28 6c 6f 67 70 72 6f 2d 66 69 6c (logpro-fil
1cf0: 65 20 28 69 66 20 77 61 69 76 65 72 0a 09 09 09 e (if waiver....
1d00: 09 09 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 ... (let ((
1d10: 66 6e 61 6d 65 20 28 63 6f 6e 63 20 68 65 64 20 fname (conc hed
1d20: 22 2e 6c 6f 67 70 72 6f 22 29 29 29 0a 09 09 09 ".logpro")))....
1d30: 09 09 09 09 28 69 66 20 28 66 69 6c 65 2d 65 78 ....(if (file-ex
1d40: 69 73 74 73 3f 20 66 6e 61 6d 65 29 0a 09 09 09 ists? fname)....
1d50: 09 09 09 09 20 20 20 20 66 6e 61 6d 65 20 0a 09 .... fname ..
1d60: 09 09 09 09 09 09 20 20 20 20 28 62 65 67 69 6e ...... (begin
1d70: 0a 09 09 09 09 09 09 09 20 20 20 20 20 20 28 64 ........ (d
1d80: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 49 4e ebug:print 0 "IN
1d90: 46 4f 3a 20 4e 6f 20 6c 6f 67 70 72 6f 20 66 69 FO: No logpro fi
1da0: 6c 65 20 22 20 66 6e 61 6d 65 20 22 20 66 61 6c le " fname " fal
1db0: 6c 69 6e 67 20 62 61 63 6b 20 74 6f 20 64 69 66 ling back to dif
1dc0: 66 22 29 0a 09 09 09 09 09 09 09 20 20 20 20 20 f")........
1dd0: 20 23 66 29 29 29 0a 09 09 09 09 09 09 20 20 20 #f))).......
1de0: 20 20 20 23 66 29 29 0a 09 09 09 09 20 20 20 20 #f)).....
1df0: 20 3b 3b 20 69 66 20 72 75 6c 65 20 62 79 20 6e ;; if rule by n
1e00: 61 6d 65 20 6f 66 20 77 61 69 76 65 72 2d 72 75 ame of waiver-ru
1e10: 6c 65 20 69 73 20 66 6f 75 6e 64 20 69 6e 20 74 le is found in t
1e20: 65 73 74 63 6f 6e 66 69 67 20 2d 20 75 73 65 20 estconfig - use
1e30: 69 74 0a 09 09 09 09 20 20 20 20 20 3b 3b 20 65 it..... ;; e
1e40: 6c 73 65 20 69 66 20 77 61 69 76 65 72 6e 61 6d lse if waivernam
1e50: 65 2e 6c 6f 67 70 72 6f 20 65 78 69 73 74 73 20 e.logpro exists
1e60: 75 73 65 20 6c 6f 67 70 72 6f 2d 72 75 6c 65 0a use logpro-rule.
1e70: 09 09 09 09 20 20 20 20 20 3b 3b 20 65 6c 73 65 .... ;; else
1e80: 20 64 65 66 61 75 6c 74 20 74 6f 20 64 69 66 66 default to diff
1e90: 2d 72 75 6c 65 0a 09 09 09 09 20 20 20 20 20 28 -rule..... (
1ea0: 72 75 6c 65 2d 73 74 72 69 6e 67 20 28 6c 65 74 rule-string (let
1eb0: 20 28 28 72 75 6c 65 20 28 63 6f 6e 66 69 67 66 ((rule (configf
1ec0: 3a 6c 6f 6f 6b 75 70 20 74 65 73 74 63 6f 6e 66 :lookup testconf
1ed0: 69 67 20 22 77 61 69 76 65 72 5f 72 75 6c 65 73 ig "waiver_rules
1ee0: 22 20 77 61 69 76 65 72 2d 72 75 6c 65 29 29 29 " waiver-rule)))
1ef0: 0a 09 09 09 09 09 09 20 20 20 20 28 69 66 20 72 ....... (if r
1f00: 75 6c 65 0a 09 09 09 09 09 09 09 72 75 6c 65 0a ule........rule.
1f10: 09 09 09 09 09 09 09 28 69 66 20 6c 6f 67 70 72 .......(if logpr
1f20: 6f 2d 66 69 6c 65 0a 09 09 09 09 09 09 09 20 20 o-file........
1f30: 20 20 6c 6f 67 70 72 6f 2d 72 75 6c 65 0a 09 09 logpro-rule...
1f40: 09 09 09 09 09 20 20 20 20 28 62 65 67 69 6e 0a ..... (begin.
1f50: 09 09 09 09 09 09 09 20 20 20 20 20 20 28 64 65 ....... (de
1f60: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 49 4e 46 bug:print 0 "INF
1f70: 4f 3a 20 4e 6f 20 6c 6f 67 70 72 6f 20 66 69 6c O: No logpro fil
1f80: 65 20 22 20 6c 6f 67 70 72 6f 2d 66 69 6c 65 20 e " logpro-file
1f90: 22 20 66 6f 75 6e 64 2c 20 75 73 69 6e 67 20 64 " found, using d
1fa0: 69 66 66 20 72 75 6c 65 22 29 0a 09 09 09 09 09 iff rule")......
1fb0: 09 09 20 20 20 20 20 20 64 69 66 66 2d 72 75 6c .. diff-rul
1fc0: 65 29 29 29 29 29 0a 09 09 09 09 20 20 20 20 20 e))))).....
1fd0: 3b 3b 20 28 73 74 72 69 6e 67 2d 73 75 62 73 74 ;; (string-subst
1fe0: 69 74 75 74 65 20 22 25 66 69 6c 65 31 25 22 20 itute "%file1%"
1ff0: 22 66 6f 6f 66 6f 6f 2e 74 78 74 22 20 22 54 68 "foofoo.txt" "Th
2000: 69 73 20 69 73 20 25 66 69 6c 65 31 25 20 61 6e is is %file1% an
2010: 64 20 73 6f 20 69 73 20 74 68 69 73 20 25 66 69 d so is this %fi
2020: 6c 65 31 25 2e 22 20 23 74 29 0a 09 09 09 09 20 le1%." #t).....
2030: 20 20 20 20 28 70 72 6f 63 65 73 73 65 64 2d 63 (processed-c
2040: 6d 64 20 28 73 74 72 69 6e 67 2d 73 75 62 73 74 md (string-subst
2050: 69 74 75 74 65 20 0a 09 09 09 09 09 09 20 20 20 itute .......
2060: 20 20 22 25 66 69 6c 65 31 25 22 20 28 63 6f 6e "%file1%" (con
2070: 63 20 74 65 73 74 2d 72 75 6e 64 69 72 20 22 2f c test-rundir "/
2080: 22 20 77 61 69 76 65 72 2d 67 6c 6f 62 29 0a 09 " waiver-glob)..
2090: 09 09 09 09 09 20 20 20 20 20 28 73 74 72 69 6e ..... (strin
20a0: 67 2d 73 75 62 73 74 69 74 75 74 65 0a 09 09 09 g-substitute....
20b0: 09 09 09 20 20 20 20 20 20 22 25 66 69 6c 65 32 ... "%file2
20c0: 25 22 20 28 63 6f 6e 63 20 70 72 65 76 2d 72 75 %" (conc prev-ru
20d0: 6e 64 69 72 20 22 2f 22 20 77 61 69 76 65 72 2d ndir "/" waiver-
20e0: 67 6c 6f 62 29 0a 09 09 09 09 09 09 20 20 20 20 glob).......
20f0: 20 20 28 73 74 72 69 6e 67 2d 73 75 62 73 74 69 (string-substi
2100: 74 75 74 65 0a 09 09 09 09 09 09 20 20 20 20 20 tute.......
2110: 20 20 22 25 77 61 69 76 65 72 6e 61 6d 65 25 22 "%waivername%"
2120: 20 68 65 64 20 72 75 6c 65 2d 73 74 72 69 6e 67 hed rule-string
2130: 20 23 74 29 20 23 74 29 20 23 74 29 29 0a 09 09 #t) #t) #t))...
2140: 09 09 20 20 20 20 20 28 72 65 73 20 20 20 20 20 .. (res
2150: 20 20 20 20 20 20 20 23 66 29 29 0a 09 09 09 09 #f)).....
2160: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
2170: 49 4e 46 4f 3a 20 77 61 69 76 65 72 20 63 6f 6d INFO: waiver com
2180: 6d 61 6e 64 20 69 73 20 5c 22 22 20 70 72 6f 63 mand is \"" proc
2190: 65 73 73 65 64 2d 63 6d 64 20 22 5c 22 22 29 0a essed-cmd "\"").
21a0: 09 09 09 09 28 69 66 20 28 65 71 3f 20 28 73 79 ....(if (eq? (sy
21b0: 73 74 65 6d 20 70 72 6f 63 65 73 73 65 64 2d 63 stem processed-c
21c0: 6d 64 29 20 30 29 0a 09 09 09 09 20 20 20 20 28 md) 0)..... (
21d0: 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 if (null? tal)..
21e0: 09 09 09 09 23 74 0a 09 09 09 09 09 28 6c 6f 6f ....#t......(loo
21f0: 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 p (car tal)(cdr
2200: 74 61 6c 29 29 29 0a 09 09 09 09 20 20 20 20 23 tal)))..... #
2210: 66 29 29 29 29 29 29 0a 09 20 20 20 20 28 70 6f f)))))).. (po
2220: 70 2d 64 69 72 65 63 74 6f 72 79 29 0a 09 20 20 p-directory)..
2230: 20 20 72 65 73 75 6c 74 29 29 29 29 29 0a 0a 28 result)))))..(
2240: 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 74 65 define (tests:te
2250: 73 74 2d 66 6f 72 63 65 2d 73 74 61 74 65 2d 73 st-force-state-s
2260: 74 61 74 75 73 21 20 72 75 6e 2d 69 64 20 74 65 tatus! run-id te
2270: 73 74 2d 69 64 20 73 74 61 74 65 20 73 74 61 74 st-id state stat
2280: 75 73 29 0a 20 20 28 72 6d 74 3a 74 65 73 74 2d us). (rmt:test-
2290: 73 65 74 2d 73 74 61 74 75 73 2d 73 74 61 74 65 set-status-state
22a0: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 run-id test-id
22b0: 73 74 61 74 75 73 20 73 74 61 74 65 20 23 66 29 status state #f)
22c0: 0a 20 20 28 6d 74 3a 70 72 6f 63 65 73 73 2d 74 . (mt:process-t
22d0: 72 69 67 67 65 72 73 20 72 75 6e 2d 69 64 20 74 riggers run-id t
22e0: 65 73 74 2d 69 64 20 73 74 61 74 65 20 73 74 61 est-id state sta
22f0: 74 75 73 29 29 0a 0a 3b 3b 20 44 6f 20 6e 6f 74 tus))..;; Do not
2300: 20 72 70 63 20 74 68 69 73 20 6f 6e 65 2c 20 64 rpc this one, d
2310: 6f 20 74 68 65 20 75 6e 64 65 72 6c 79 69 6e 67 o the underlying
2320: 20 63 61 6c 6c 73 21 21 21 0a 28 64 65 66 69 6e calls!!!.(defin
2330: 65 20 28 74 65 73 74 73 3a 74 65 73 74 2d 73 65 e (tests:test-se
2340: 74 2d 73 74 61 74 75 73 21 20 72 75 6e 2d 69 64 t-status! run-id
2350: 20 74 65 73 74 2d 69 64 20 73 74 61 74 65 20 73 test-id state s
2360: 74 61 74 75 73 20 63 6f 6d 6d 65 6e 74 20 64 61 tatus comment da
2370: 74 20 23 21 6b 65 79 20 28 77 6f 72 6b 2d 61 72 t #!key (work-ar
2380: 65 61 20 23 66 29 29 0a 20 20 28 6c 65 74 2a 20 ea #f)). (let*
2390: 28 28 72 65 61 6c 2d 73 74 61 74 75 73 20 73 74 ((real-status st
23a0: 61 74 75 73 29 0a 09 20 28 6f 74 68 65 72 64 61 atus).. (otherda
23b0: 74 20 20 20 20 28 69 66 20 64 61 74 20 64 61 74 t (if dat dat
23c0: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
23d0: 65 29 29 29 0a 09 20 28 74 65 73 74 64 61 74 20 e))).. (testdat
23e0: 20 20 20 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 (rmt:get-tes
23f0: 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 72 75 6e t-info-by-id run
2400: 2d 69 64 20 74 65 73 74 2d 69 64 29 29 0a 09 20 -id test-id))..
2410: 28 74 65 73 74 2d 6e 61 6d 65 20 20 20 28 64 62 (test-name (db
2420: 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 :test-get-testna
2430: 6d 65 20 20 74 65 73 74 64 61 74 29 29 0a 09 20 me testdat))..
2440: 28 69 74 65 6d 2d 70 61 74 68 20 20 20 28 64 62 (item-path (db
2450: 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 :test-get-item-p
2460: 61 74 68 20 74 65 73 74 64 61 74 29 29 0a 09 20 ath testdat))..
2470: 3b 3b 20 62 65 66 6f 72 65 20 70 72 6f 63 65 65 ;; before procee
2480: 64 69 6e 67 20 77 65 20 6d 75 73 74 20 66 69 6e ding we must fin
2490: 64 20 6f 75 74 20 69 66 20 74 68 65 20 70 72 65 d out if the pre
24a0: 76 69 6f 75 73 20 74 65 73 74 20 28 77 68 65 72 vious test (wher
24b0: 65 20 61 6c 6c 20 6b 65 79 73 20 6d 61 74 63 68 e all keys match
24c0: 65 64 20 65 78 63 65 70 74 20 72 75 6e 6e 61 6d ed except runnam
24d0: 65 29 0a 09 20 3b 3b 20 77 61 73 20 57 41 49 56 e).. ;; was WAIV
24e0: 45 44 20 69 66 20 74 68 69 73 20 74 65 73 74 20 ED if this test
24f0: 69 73 20 46 41 49 4c 0a 0a 09 20 3b 3b 20 4e 4f is FAIL... ;; NO
2500: 54 45 53 3a 0a 09 20 3b 3b 20 20 31 2e 20 49 73 TES:.. ;; 1. Is
2510: 20 74 68 65 20 63 61 6c 6c 20 74 6f 20 74 65 73 the call to tes
2520: 74 3a 67 65 74 2d 70 72 65 76 69 6f 75 73 2d 72 t:get-previous-r
2530: 75 6e 2d 72 65 63 6f 72 64 20 72 65 6d 6f 74 69 un-record remoti
2540: 66 69 65 64 3f 0a 09 20 3b 3b 20 20 32 2e 20 41 fied?.. ;; 2. A
2550: 64 64 20 74 65 73 74 20 66 6f 72 20 74 65 73 74 dd test for test
2560: 63 6f 6e 66 69 67 20 77 61 69 76 65 72 20 70 72 config waiver pr
2570: 6f 70 61 67 61 74 69 6f 6e 20 63 6f 6e 74 72 6f opagation contro
2580: 6c 20 68 65 72 65 0a 09 20 3b 3b 0a 09 20 28 70 l here.. ;;.. (p
2590: 72 65 76 2d 74 65 73 74 20 20 20 28 69 66 20 28 rev-test (if (
25a0: 65 71 75 61 6c 3f 20 73 74 61 74 75 73 20 22 46 equal? status "F
25b0: 41 49 4c 22 29 0a 09 09 09 20 20 28 72 6d 74 3a AIL").... (rmt:
25c0: 67 65 74 2d 70 72 65 76 69 6f 75 73 2d 74 65 73 get-previous-tes
25d0: 74 2d 72 75 6e 2d 72 65 63 6f 72 64 20 72 75 6e t-run-record run
25e0: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 -id test-name it
25f0: 65 6d 2d 70 61 74 68 29 0a 09 09 09 20 20 23 66 em-path).... #f
2600: 29 29 0a 09 20 28 77 61 69 76 65 64 20 20 20 28 )).. (waived (
2610: 69 66 20 70 72 65 76 2d 74 65 73 74 0a 09 09 20 if prev-test...
2620: 20 20 20 20 20 20 28 69 66 20 70 72 65 76 2d 74 (if prev-t
2630: 65 73 74 20 3b 3b 20 74 72 75 65 20 69 66 20 77 est ;; true if w
2640: 65 20 66 6f 75 6e 64 20 61 20 70 72 65 76 69 6f e found a previo
2650: 75 73 20 74 65 73 74 20 69 6e 20 74 68 69 73 20 us test in this
2660: 72 75 6e 20 73 65 72 69 65 73 0a 09 09 09 20 20 run series....
2670: 20 28 6c 65 74 20 28 28 70 72 65 76 2d 73 74 61 (let ((prev-sta
2680: 74 75 73 20 20 28 64 62 3a 74 65 73 74 2d 67 65 tus (db:test-ge
2690: 74 2d 73 74 61 74 75 73 20 20 70 72 65 76 2d 74 t-status prev-t
26a0: 65 73 74 29 29 0a 09 09 09 09 20 28 70 72 65 76 est))..... (prev
26b0: 2d 73 74 61 74 65 20 20 20 28 64 62 3a 74 65 73 -state (db:tes
26c0: 74 2d 67 65 74 2d 73 74 61 74 65 20 20 20 70 72 t-get-state pr
26d0: 65 76 2d 74 65 73 74 29 29 0a 09 09 09 09 20 28 ev-test))..... (
26e0: 70 72 65 76 2d 63 6f 6d 6d 65 6e 74 20 28 64 62 prev-comment (db
26f0: 3a 74 65 73 74 2d 67 65 74 2d 63 6f 6d 6d 65 6e :test-get-commen
2700: 74 20 70 72 65 76 2d 74 65 73 74 29 29 29 0a 09 t prev-test)))..
2710: 09 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 .. (debug:pr
2720: 69 6e 74 20 34 20 22 70 72 65 76 2d 73 74 61 74 int 4 "prev-stat
2730: 75 73 20 22 20 70 72 65 76 2d 73 74 61 74 75 73 us " prev-status
2740: 20 22 2c 20 70 72 65 76 2d 73 74 61 74 65 20 22 ", prev-state "
2750: 20 70 72 65 76 2d 73 74 61 74 65 20 22 2c 20 70 prev-state ", p
2760: 72 65 76 2d 63 6f 6d 6d 65 6e 74 20 22 20 70 72 rev-comment " pr
2770: 65 76 2d 63 6f 6d 6d 65 6e 74 29 0a 09 09 09 20 ev-comment)....
2780: 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 65 71 (if (and (eq
2790: 75 61 6c 3f 20 70 72 65 76 2d 73 74 61 74 65 20 ual? prev-state
27a0: 20 22 43 4f 4d 50 4c 45 54 45 44 22 29 0a 09 09 "COMPLETED")...
27b0: 09 09 20 20 20 20 20 20 28 65 71 75 61 6c 3f 20 .. (equal?
27c0: 70 72 65 76 2d 73 74 61 74 75 73 20 22 57 41 49 prev-status "WAI
27d0: 56 45 44 22 29 29 0a 09 09 09 09 20 28 69 66 20 VED"))..... (if
27e0: 63 6f 6d 6d 65 6e 74 0a 09 09 09 09 20 20 20 20 comment.....
27f0: 20 63 6f 6d 6d 65 6e 74 0a 09 09 09 09 20 20 20 comment.....
2800: 20 20 70 72 65 76 2d 63 6f 6d 6d 65 6e 74 29 20 prev-comment)
2810: 3b 3b 20 77 61 69 76 65 64 20 69 73 20 65 69 74 ;; waived is eit
2820: 68 65 72 20 74 68 65 20 63 6f 6d 6d 65 6e 74 20 her the comment
2830: 6f 72 20 23 66 0a 09 09 09 09 20 23 66 29 29 0a or #f..... #f)).
2840: 09 09 09 20 20 20 23 66 29 0a 09 09 20 20 20 20 ... #f)...
2850: 20 20 20 23 66 29 29 29 0a 20 20 20 20 28 69 66 #f))). (if
2860: 20 28 61 6e 64 20 77 61 69 76 65 64 20 0a 09 20 (and waived ..
2870: 20 20 20 20 28 74 65 73 74 73 3a 63 68 65 63 6b (tests:check
2880: 2d 77 61 69 76 65 72 2d 65 6c 69 67 69 62 69 6c -waiver-eligibil
2890: 69 74 79 20 74 65 73 74 64 61 74 20 70 72 65 76 ity testdat prev
28a0: 2d 74 65 73 74 29 29 0a 09 28 73 65 74 21 20 72 -test))..(set! r
28b0: 65 61 6c 2d 73 74 61 74 75 73 20 22 57 41 49 56 eal-status "WAIV
28c0: 45 44 22 29 29 0a 0a 20 20 20 20 28 64 65 62 75 ED")).. (debu
28d0: 67 3a 70 72 69 6e 74 20 34 20 22 72 65 61 6c 2d g:print 4 "real-
28e0: 73 74 61 74 75 73 20 22 20 72 65 61 6c 2d 73 74 status " real-st
28f0: 61 74 75 73 20 22 2c 20 77 61 69 76 65 64 20 22 atus ", waived "
2900: 20 77 61 69 76 65 64 20 22 2c 20 73 74 61 74 75 waived ", statu
2910: 73 20 22 20 73 74 61 74 75 73 29 0a 0a 20 20 20 s " status)..
2920: 20 3b 3b 20 75 70 64 61 74 65 20 74 68 65 20 70 ;; update the p
2930: 72 69 6d 61 72 79 20 72 65 63 6f 72 64 20 49 46 rimary record IF
2940: 20 73 74 61 74 65 20 41 4e 44 20 73 74 61 74 75 state AND statu
2950: 73 20 61 72 65 20 64 65 66 69 6e 65 64 0a 20 20 s are defined.
2960: 20 20 28 69 66 20 28 61 6e 64 20 73 74 61 74 65 (if (and state
2970: 20 73 74 61 74 75 73 29 0a 09 28 62 65 67 69 6e status)..(begin
2980: 0a 09 20 20 28 72 6d 74 3a 74 65 73 74 2d 73 65 .. (rmt:test-se
2990: 74 2d 73 74 61 74 75 73 2d 73 74 61 74 65 20 72 t-status-state r
29a0: 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 72 65 un-id test-id re
29b0: 61 6c 2d 73 74 61 74 75 73 20 73 74 61 74 65 20 al-status state
29c0: 28 69 66 20 77 61 69 76 65 64 20 77 61 69 76 65 (if waived waive
29d0: 64 20 63 6f 6d 6d 65 6e 74 29 29 0a 09 20 20 28 d comment)).. (
29e0: 6d 74 3a 70 72 6f 63 65 73 73 2d 74 72 69 67 67 mt:process-trigg
29f0: 65 72 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d ers run-id test-
2a00: 69 64 20 73 74 61 74 65 20 72 65 61 6c 2d 73 74 id state real-st
2a10: 61 74 75 73 29 29 29 0a 20 20 20 20 0a 20 20 20 atus))). .
2a20: 20 3b 3b 20 69 66 20 73 74 61 74 75 73 20 69 73 ;; if status is
2a30: 20 22 41 55 54 4f 22 20 74 68 65 6e 20 63 61 6c "AUTO" then cal
2a40: 6c 20 72 6f 6c 6c 75 70 20 28 6e 6f 74 65 2c 20 l rollup (note,
2a50: 74 68 69 73 20 6f 6e 65 20 6d 6f 64 69 66 69 65 this one modifie
2a60: 73 20 64 61 74 61 20 69 6e 20 74 65 73 74 0a 20 s data in test.
2a70: 20 20 20 3b 3b 20 72 75 6e 20 61 72 65 61 2c 20 ;; run area,
2a80: 69 74 20 64 6f 65 73 20 72 65 6d 6f 74 65 20 63 it does remote c
2a90: 61 6c 6c 73 20 75 6e 64 65 72 20 74 68 65 20 68 alls under the h
2aa0: 6f 6f 64 2e 0a 20 20 20 20 28 69 66 20 28 61 6e ood.. (if (an
2ab0: 64 20 74 65 73 74 2d 69 64 20 73 74 61 74 65 20 d test-id state
2ac0: 73 74 61 74 75 73 20 28 65 71 75 61 6c 3f 20 73 status (equal? s
2ad0: 74 61 74 75 73 20 22 41 55 54 4f 22 29 29 20 0a tatus "AUTO")) .
2ae0: 09 28 72 6d 74 3a 74 65 73 74 2d 64 61 74 61 2d .(rmt:test-data-
2af0: 72 6f 6c 6c 75 70 20 72 75 6e 2d 69 64 20 74 65 rollup run-id te
2b00: 73 74 2d 69 64 20 73 74 61 74 75 73 29 29 0a 0a st-id status))..
2b10: 20 20 20 20 3b 3b 20 61 64 64 20 6d 65 74 61 64 ;; add metad
2b20: 61 74 61 20 28 6e 65 65 64 20 74 6f 20 64 6f 20 ata (need to do
2b30: 74 68 69 73 20 77 61 79 20 74 6f 20 61 76 6f 69 this way to avoi
2b40: 64 20 53 51 4c 20 69 6e 6a 65 63 74 69 6f 6e 20 d SQL injection
2b50: 69 73 73 75 65 73 29 0a 0a 20 20 20 20 3b 3b 20 issues).. ;;
2b60: 3a 66 69 72 73 74 5f 65 72 72 0a 20 20 20 20 3b :first_err. ;
2b70: 3b 20 28 6c 65 74 20 28 28 76 61 6c 20 28 68 61 ; (let ((val (ha
2b80: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
2b90: 61 75 6c 74 20 6f 74 68 65 72 64 61 74 20 22 3a ault otherdat ":
2ba0: 66 69 72 73 74 5f 65 72 72 22 20 23 66 29 29 29 first_err" #f)))
2bb0: 0a 20 20 20 20 3b 3b 20 20 20 28 69 66 20 76 61 . ;; (if va
2bc0: 6c 0a 20 20 20 20 3b 3b 20 20 20 20 20 20 20 28 l. ;; (
2bd0: 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 sqlite3:execute
2be0: 64 62 20 22 55 50 44 41 54 45 20 74 65 73 74 73 db "UPDATE tests
2bf0: 20 53 45 54 20 66 69 72 73 74 5f 65 72 72 3d 3f SET first_err=?
2c00: 20 57 48 45 52 45 20 72 75 6e 5f 69 64 3d 3f 20 WHERE run_id=?
2c10: 41 4e 44 20 74 65 73 74 6e 61 6d 65 3d 3f 20 41 AND testname=? A
2c20: 4e 44 20 69 74 65 6d 5f 70 61 74 68 3d 3f 3b 22 ND item_path=?;"
2c30: 20 76 61 6c 20 72 75 6e 2d 69 64 20 74 65 73 74 val run-id test
2c40: 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 -name item-path)
2c50: 29 29 0a 20 20 20 20 3b 3b 20 0a 20 20 20 20 3b )). ;; . ;
2c60: 3b 20 3b 3b 20 3a 66 69 72 73 74 5f 77 61 72 6e ; ;; :first_warn
2c70: 0a 20 20 20 20 3b 3b 20 28 6c 65 74 20 28 28 76 . ;; (let ((v
2c80: 61 6c 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 al (hash-table-r
2c90: 65 66 2f 64 65 66 61 75 6c 74 20 6f 74 68 65 72 ef/default other
2ca0: 64 61 74 20 22 3a 66 69 72 73 74 5f 77 61 72 6e dat ":first_warn
2cb0: 22 20 23 66 29 29 29 0a 20 20 20 20 3b 3b 20 20 " #f))). ;;
2cc0: 20 28 69 66 20 76 61 6c 0a 20 20 20 20 3b 3b 20 (if val. ;;
2cd0: 20 20 20 20 20 20 28 73 71 6c 69 74 65 33 3a 65 (sqlite3:e
2ce0: 78 65 63 75 74 65 20 64 62 20 22 55 50 44 41 54 xecute db "UPDAT
2cf0: 45 20 74 65 73 74 73 20 53 45 54 20 66 69 72 73 E tests SET firs
2d00: 74 5f 77 61 72 6e 3d 3f 20 57 48 45 52 45 20 72 t_warn=? WHERE r
2d10: 75 6e 5f 69 64 3d 3f 20 41 4e 44 20 74 65 73 74 un_id=? AND test
2d20: 6e 61 6d 65 3d 3f 20 41 4e 44 20 69 74 65 6d 5f name=? AND item_
2d30: 70 61 74 68 3d 3f 3b 22 20 76 61 6c 20 72 75 6e path=?;" val run
2d40: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 -id test-name it
2d50: 65 6d 2d 70 61 74 68 29 29 29 0a 0a 20 20 20 20 em-path)))..
2d60: 28 6c 65 74 20 28 28 63 61 74 65 67 6f 72 79 20 (let ((category
2d70: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
2d80: 64 65 66 61 75 6c 74 20 6f 74 68 65 72 64 61 74 default otherdat
2d90: 20 22 3a 63 61 74 65 67 6f 72 79 22 20 22 22 29 ":category" "")
2da0: 29 0a 09 20 20 28 76 61 72 69 61 62 6c 65 20 28 ).. (variable (
2db0: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
2dc0: 65 66 61 75 6c 74 20 6f 74 68 65 72 64 61 74 20 efault otherdat
2dd0: 22 3a 76 61 72 69 61 62 6c 65 22 20 22 22 29 29 ":variable" ""))
2de0: 0a 09 20 20 28 76 61 6c 75 65 20 20 20 20 28 68 .. (value (h
2df0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
2e00: 66 61 75 6c 74 20 6f 74 68 65 72 64 61 74 20 22 fault otherdat "
2e10: 3a 76 61 6c 75 65 22 20 20 20 20 23 66 29 29 0a :value" #f)).
2e20: 09 20 20 28 65 78 70 65 63 74 65 64 20 28 68 61 . (expected (ha
2e30: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
2e40: 61 75 6c 74 20 6f 74 68 65 72 64 61 74 20 22 3a ault otherdat ":
2e50: 65 78 70 65 63 74 65 64 22 20 23 66 29 29 0a 09 expected" #f))..
2e60: 20 20 28 74 6f 6c 20 20 20 20 20 20 28 68 61 73 (tol (has
2e70: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
2e80: 75 6c 74 20 6f 74 68 65 72 64 61 74 20 22 3a 74 ult otherdat ":t
2e90: 6f 6c 22 20 20 20 20 20 20 23 66 29 29 0a 09 20 ol" #f))..
2ea0: 20 28 75 6e 69 74 73 20 20 20 20 28 68 61 73 68 (units (hash
2eb0: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
2ec0: 6c 74 20 6f 74 68 65 72 64 61 74 20 22 3a 75 6e lt otherdat ":un
2ed0: 69 74 73 22 20 20 20 20 22 22 29 29 0a 09 20 20 its" ""))..
2ee0: 28 74 79 70 65 20 20 20 20 20 28 68 61 73 68 2d (type (hash-
2ef0: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
2f00: 74 20 6f 74 68 65 72 64 61 74 20 22 3a 74 79 70 t otherdat ":typ
2f10: 65 22 20 20 20 20 20 22 22 29 29 0a 09 20 20 28 e" "")).. (
2f20: 64 63 6f 6d 6d 65 6e 74 20 28 68 61 73 68 2d 74 dcomment (hash-t
2f30: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
2f40: 20 6f 74 68 65 72 64 61 74 20 22 3a 63 6f 6d 6d otherdat ":comm
2f50: 65 6e 74 22 20 20 22 22 29 29 29 0a 20 20 20 20 ent" ""))).
2f60: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 (debug:print 4
2f70: 20 0a 09 09 20 20 20 22 63 61 74 65 67 6f 72 79 ... "category
2f80: 3a 20 22 20 63 61 74 65 67 6f 72 79 20 22 2c 20 : " category ",
2f90: 76 61 72 69 61 62 6c 65 3a 20 22 20 76 61 72 69 variable: " vari
2fa0: 61 62 6c 65 20 22 2c 20 76 61 6c 75 65 3a 20 22 able ", value: "
2fb0: 20 76 61 6c 75 65 0a 09 09 20 20 20 22 2c 20 65 value... ", e
2fc0: 78 70 65 63 74 65 64 3a 20 22 20 65 78 70 65 63 xpected: " expec
2fd0: 74 65 64 20 22 2c 20 74 6f 6c 3a 20 22 20 74 6f ted ", tol: " to
2fe0: 6c 20 22 2c 20 75 6e 69 74 73 3a 20 22 20 75 6e l ", units: " un
2ff0: 69 74 73 29 0a 20 20 20 20 20 20 28 69 66 20 28 its). (if (
3000: 61 6e 64 20 76 61 6c 75 65 20 65 78 70 65 63 74 and value expect
3010: 65 64 20 74 6f 6c 29 20 3b 3b 20 61 6c 6c 20 74 ed tol) ;; all t
3020: 68 72 65 65 20 72 65 71 75 69 72 65 64 0a 09 20 hree required..
3030: 20 28 6c 65 74 20 28 28 64 61 74 20 28 63 6f 6e (let ((dat (con
3040: 63 20 63 61 74 65 67 6f 72 79 20 22 2c 22 0a 09 c category ","..
3050: 09 09 20 20 20 76 61 72 69 61 62 6c 65 20 22 2c .. variable ",
3060: 22 0a 09 09 09 20 20 20 76 61 6c 75 65 20 20 20 ".... value
3070: 20 22 2c 22 0a 09 09 09 20 20 20 65 78 70 65 63 ",".... expec
3080: 74 65 64 20 22 2c 22 0a 09 09 09 20 20 20 74 6f ted ",".... to
3090: 6c 20 20 20 20 20 20 22 2c 22 0a 09 09 09 20 20 l ","....
30a0: 20 75 6e 69 74 73 20 20 20 20 22 2c 22 0a 09 09 units ","...
30b0: 09 20 20 20 64 63 6f 6d 6d 65 6e 74 20 22 2c 2c . dcomment ",,
30c0: 22 20 3b 3b 20 65 78 74 72 61 20 63 6f 6d 6d 61 " ;; extra comma
30d0: 20 66 6f 72 20 73 74 61 74 75 73 0a 09 09 09 20 for status....
30e0: 20 20 74 79 70 65 20 20 20 20 20 29 29 29 0a 09 type )))..
30f0: 20 20 20 20 3b 3b 20 54 68 69 73 20 77 61 73 20 ;; This was
3100: 72 75 6e 20 72 65 6d 6f 74 65 2c 20 64 6f 6e 27 run remote, don'
3110: 74 20 74 68 69 6e 6b 20 74 68 61 74 20 6d 61 6b t think that mak
3120: 65 73 20 73 65 6e 73 65 2e 20 50 65 72 68 61 70 es sense. Perhap
3130: 73 20 6e 6f 74 2c 20 62 75 74 20 74 68 61 74 20 s not, but that
3140: 69 73 20 74 68 65 20 65 61 73 69 65 73 74 20 70 is the easiest p
3150: 61 74 68 20 66 6f 72 20 74 68 65 20 6d 6f 6d 65 ath for the mome
3160: 6e 74 2e 0a 09 20 20 20 20 28 72 6d 74 3a 63 73 nt... (rmt:cs
3170: 76 2d 3e 74 65 73 74 2d 64 61 74 61 20 72 75 6e v->test-data run
3180: 2d 69 64 20 74 65 73 74 2d 69 64 0a 09 09 09 09 -id test-id.....
3190: 64 61 74 29 29 29 29 0a 20 20 20 20 20 20 0a 20 dat)))). .
31a0: 20 20 20 3b 3b 20 6e 65 65 64 20 74 6f 20 75 70 ;; need to up
31b0: 64 61 74 65 20 74 68 65 20 74 6f 70 20 74 65 73 date the top tes
31c0: 74 20 72 65 63 6f 72 64 20 69 66 20 50 41 53 53 t record if PASS
31d0: 20 6f 72 20 46 41 49 4c 20 61 6e 64 20 74 68 69 or FAIL and thi
31e0: 73 20 69 73 20 61 20 73 75 62 74 65 73 74 0a 20 s is a subtest.
31f0: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 75 (if (not (equ
3200: 61 6c 3f 20 69 74 65 6d 2d 70 61 74 68 20 22 22 al? item-path ""
3210: 29 29 0a 09 28 72 6d 74 3a 72 6f 6c 6c 2d 75 70 ))..(rmt:roll-up
3220: 2d 70 61 73 73 2d 66 61 69 6c 2d 63 6f 75 6e 74 -pass-fail-count
3230: 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 s run-id test-na
3240: 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 73 74 61 me item-path sta
3250: 74 65 20 73 74 61 74 75 73 29 29 0a 0a 20 20 20 te status))..
3260: 20 28 69 66 20 28 6f 72 20 28 61 6e 64 20 28 73 (if (or (and (s
3270: 74 72 69 6e 67 3f 20 63 6f 6d 6d 65 6e 74 29 0a tring? comment).
3280: 09 09 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 .. (string-match
3290: 20 28 72 65 67 65 78 70 20 22 5c 5c 53 2b 22 29 (regexp "\\S+")
32a0: 20 63 6f 6d 6d 65 6e 74 29 29 0a 09 20 20 20 20 comment))..
32b0: 77 61 69 76 65 64 29 0a 09 28 6c 65 74 20 28 28 waived)..(let ((
32c0: 63 6d 74 20 20 28 69 66 20 77 61 69 76 65 64 20 cmt (if waived
32d0: 77 61 69 76 65 64 20 63 6f 6d 6d 65 6e 74 29 29 waived comment))
32e0: 29 0a 09 20 20 28 72 6d 74 3a 67 65 6e 65 72 61 ).. (rmt:genera
32f0: 6c 2d 63 61 6c 6c 20 27 73 65 74 2d 74 65 73 74 l-call 'set-test
3300: 2d 63 6f 6d 6d 65 6e 74 20 72 75 6e 2d 69 64 20 -comment run-id
3310: 63 6d 74 20 74 65 73 74 2d 69 64 29 29 29 29 29 cmt test-id)))))
3320: 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 ..(define (tests
3330: 3a 74 65 73 74 2d 73 65 74 2d 74 6f 70 6c 6f 67 :test-set-toplog
3340: 21 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 ! run-id test-na
3350: 6d 65 20 6c 6f 67 66 29 20 0a 20 20 28 72 6d 74 me logf) . (rmt
3360: 3a 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 74 :general-call 't
3370: 65 73 74 73 3a 74 65 73 74 2d 73 65 74 2d 74 6f ests:test-set-to
3380: 70 6c 6f 67 20 72 75 6e 2d 69 64 20 6c 6f 67 66 plog run-id logf
3390: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
33a0: 65 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 e))..(define (te
33b0: 73 74 73 3a 73 75 6d 6d 61 72 69 7a 65 2d 69 74 sts:summarize-it
33c0: 65 6d 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d ems run-id test-
33d0: 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 66 6f 72 id test-name for
33e0: 63 65 29 0a 20 20 3b 3b 20 69 66 20 6e 6f 74 20 ce). ;; if not
33f0: 66 6f 72 63 65 20 74 68 65 6e 20 6f 6e 6c 79 20 force then only
3400: 75 70 64 61 74 65 20 74 68 65 20 72 65 63 6f 72 update the recor
3410: 64 20 69 66 20 6f 6e 65 20 6f 66 20 74 68 65 73 d if one of thes
3420: 65 20 69 73 20 74 72 75 65 3a 0a 20 20 3b 3b 20 e is true:. ;;
3430: 20 20 31 2e 20 6c 6f 67 66 20 69 73 20 22 6c 6f 1. logf is "lo
3440: 67 2f 66 69 6e 61 6c 2e 6c 6f 67 0a 20 20 3b 3b g/final.log. ;;
3450: 20 20 20 32 2e 20 6c 6f 67 66 20 69 73 20 73 61 2. logf is sa
3460: 6d 65 20 61 73 20 6f 75 74 70 75 74 66 69 6c 65 me as outputfile
3470: 6e 61 6d 65 0a 20 20 28 6c 65 74 2a 20 28 28 6f name. (let* ((o
3480: 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 20 28 63 utputfilename (c
3490: 6f 6e 63 20 22 6d 65 67 61 74 65 73 74 2d 72 6f onc "megatest-ro
34a0: 6c 6c 75 70 2d 22 20 74 65 73 74 2d 6e 61 6d 65 llup-" test-name
34b0: 20 22 2e 68 74 6d 6c 22 29 29 0a 09 20 28 6f 72 ".html")).. (or
34c0: 69 67 2d 64 69 72 20 20 20 20 20 20 20 28 63 75 ig-dir (cu
34d0: 72 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 79 29 rrent-directory)
34e0: 29 0a 09 20 28 6c 6f 67 66 2d 69 6e 66 6f 20 20 ).. (logf-info
34f0: 20 20 20 20 28 72 6d 74 3a 74 65 73 74 2d 67 65 (rmt:test-ge
3500: 74 2d 6c 6f 67 66 69 6c 65 2d 69 6e 66 6f 20 72 t-logfile-info r
3510: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 29 un-id test-name)
3520: 29 0a 09 20 28 6c 6f 67 66 20 20 20 20 20 20 20 ).. (logf
3530: 20 20 20 20 28 69 66 20 6c 6f 67 66 2d 69 6e 66 (if logf-inf
3540: 6f 20 28 63 61 64 72 20 6c 6f 67 66 2d 69 6e 66 o (cadr logf-inf
3550: 6f 29 20 23 66 29 29 0a 09 20 28 70 61 74 68 20 o) #f)).. (path
3560: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 6c 6f (if lo
3570: 67 66 2d 69 6e 66 6f 20 28 63 61 72 20 20 6c 6f gf-info (car lo
3580: 67 66 2d 69 6e 66 6f 29 20 23 66 29 29 29 0a 20 gf-info) #f))).
3590: 20 20 20 3b 3b 20 54 68 69 73 20 71 75 65 72 79 ;; This query
35a0: 20 66 69 6e 64 73 20 74 68 65 20 70 61 74 68 20 finds the path
35b0: 61 6e 64 20 63 68 61 6e 67 65 73 20 74 68 65 20 and changes the
35c0: 64 69 72 65 63 74 6f 72 79 20 74 6f 20 69 74 20 directory to it
35d0: 66 6f 72 20 74 68 65 20 74 65 73 74 0a 20 20 20 for the test.
35e0: 20 28 69 66 20 28 61 6e 64 20 28 73 74 72 69 6e (if (and (strin
35f0: 67 3f 20 70 61 74 68 29 0a 09 20 20 20 20 20 28 g? path).. (
3600: 64 69 72 65 63 74 6f 72 79 3f 20 70 61 74 68 29 directory? path)
3610: 29 20 3b 3b 20 63 61 6e 20 67 65 74 20 23 66 20 ) ;; can get #f
3620: 68 65 72 65 20 75 6e 64 65 72 20 73 6f 6d 65 20 here under some
3630: 77 69 65 72 64 20 63 6f 6e 64 69 74 69 6f 6e 73 wierd conditions
3640: 2e 20 77 68 79 2c 20 75 6e 6b 6e 6f 77 6e 20 2e . why, unknown .
3650: 2e 2e 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 64 ....(begin.. (d
3660: 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 46 6f ebug:print 4 "Fo
3670: 75 6e 64 20 70 61 74 68 3a 20 22 20 70 61 74 68 und path: " path
3680: 29 0a 09 20 20 28 63 68 61 6e 67 65 2d 64 69 72 ).. (change-dir
3690: 65 63 74 6f 72 79 20 70 61 74 68 29 29 0a 09 3b ectory path))..;
36a0: 3b 20 28 73 65 74 21 20 6f 75 74 70 75 74 66 69 ; (set! outputfi
36b0: 6c 65 6e 61 6d 65 20 28 63 6f 6e 63 20 70 61 74 lename (conc pat
36c0: 68 20 22 2f 22 20 6f 75 74 70 75 74 66 69 6c 65 h "/" outputfile
36d0: 6e 61 6d 65 29 29 29 0a 09 28 64 65 62 75 67 3a name)))..(debug:
36e0: 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 print 0 "ERROR:
36f0: 73 75 6d 6d 61 72 69 7a 65 2d 69 74 65 6d 73 20 summarize-items
3700: 66 6f 72 20 72 75 6e 2d 69 64 3d 22 20 72 75 6e for run-id=" run
3710: 2d 69 64 20 22 2c 20 74 65 73 74 2d 6e 61 6d 65 -id ", test-name
3720: 3d 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 2c 20 =" test-name ",
3730: 6e 6f 20 73 75 63 68 20 70 61 74 68 3a 20 22 20 no such path: "
3740: 70 61 74 68 29 29 0a 20 20 20 20 28 64 65 62 75 path)). (debu
3750: 67 3a 70 72 69 6e 74 20 34 20 22 73 75 6d 6d 61 g:print 4 "summa
3760: 72 69 7a 65 2d 69 74 65 6d 73 20 77 69 74 68 20 rize-items with
3770: 6c 6f 67 66 20 22 20 6c 6f 67 66 20 22 2c 20 6f logf " logf ", o
3780: 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 20 22 20 utputfilename "
3790: 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 20 22 outputfilename "
37a0: 20 61 6e 64 20 66 6f 72 63 65 20 22 20 66 6f 72 and force " for
37b0: 63 65 29 0a 20 20 20 20 28 69 66 20 28 6f 72 20 ce). (if (or
37c0: 28 65 71 75 61 6c 3f 20 6c 6f 67 66 20 22 6c 6f (equal? logf "lo
37d0: 67 73 2f 66 69 6e 61 6c 2e 6c 6f 67 22 29 0a 09 gs/final.log")..
37e0: 20 20 20 20 28 65 71 75 61 6c 3f 20 6c 6f 67 66 (equal? logf
37f0: 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 29 outputfilename)
3800: 0a 09 20 20 20 20 66 6f 72 63 65 29 0a 09 28 6c .. force)..(l
3810: 65 74 20 28 28 6d 79 2d 73 74 61 72 74 2d 74 69 et ((my-start-ti
3820: 6d 65 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f me (current-seco
3830: 6e 64 73 29 29 0a 09 20 20 20 20 20 20 28 6c 6f nds)).. (lo
3840: 63 6b 66 20 20 20 20 20 20 20 20 20 28 63 6f 6e ckf (con
3850: 63 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 c outputfilename
3860: 20 22 2e 6c 6f 63 6b 22 29 29 29 0a 09 20 20 28 ".lock"))).. (
3870: 6c 65 74 20 6c 6f 6f 70 20 28 28 68 61 76 65 2d let loop ((have-
3880: 6c 6f 63 6b 20 20 28 63 6f 6d 6d 6f 6e 3a 73 69 lock (common:si
3890: 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 20 6c mple-file-lock l
38a0: 6f 63 6b 66 29 29 29 0a 09 20 20 20 20 28 69 66 ockf))).. (if
38b0: 20 68 61 76 65 2d 6c 6f 63 6b 0a 09 09 28 6c 65 have-lock...(le
38c0: 74 20 28 28 73 63 72 69 70 74 20 28 63 6f 6e 66 t ((script (conf
38d0: 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 igf:lookup *conf
38e0: 69 67 64 61 74 2a 20 22 74 65 73 74 72 6f 6c 6c igdat* "testroll
38f0: 75 70 22 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 up" test-name)))
3900: 0a 09 09 20 20 28 70 72 69 6e 74 20 22 4f 62 74 ... (print "Obt
3910: 61 69 6e 65 64 20 6c 6f 63 6b 20 66 6f 72 20 22 ained lock for "
3920: 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 29 outputfilename)
3930: 0a 09 09 20 20 3b 3b 20 28 72 6d 74 3a 74 6f 70 ... ;; (rmt:top
3940: 2d 74 65 73 74 2d 73 65 74 2d 70 65 72 2d 70 66 -test-set-per-pf
3950: 2d 63 6f 75 6e 74 73 20 72 75 6e 2d 69 64 20 74 -counts run-id t
3960: 65 73 74 2d 6e 61 6d 65 29 0a 09 09 20 20 28 72 est-name)... (r
3970: 6d 74 3a 72 6f 6c 6c 2d 75 70 2d 70 61 73 73 2d mt:roll-up-pass-
3980: 66 61 69 6c 2d 63 6f 75 6e 74 73 20 72 75 6e 2d fail-counts run-
3990: 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 22 22 20 id test-name ""
39a0: 23 66 20 23 66 29 0a 09 09 20 20 28 69 66 20 73 #f #f)... (if s
39b0: 63 72 69 70 74 0a 09 09 20 20 20 20 20 20 28 73 cript... (s
39c0: 79 73 74 65 6d 20 28 63 6f 6e 63 20 73 63 72 69 ystem (conc scri
39d0: 70 74 20 22 20 3e 20 22 20 6f 75 74 70 75 74 66 pt " > " outputf
39e0: 69 6c 65 6e 61 6d 65 20 22 20 26 20 22 29 29 0a ilename " & ")).
39f0: 09 09 20 20 20 20 20 20 28 74 65 73 74 73 3a 67 .. (tests:g
3a00: 65 6e 65 72 61 74 65 2d 68 74 6d 6c 2d 73 75 6d enerate-html-sum
3a10: 6d 61 72 79 2d 66 6f 72 2d 69 74 65 72 61 74 65 mary-for-iterate
3a20: 64 2d 74 65 73 74 20 72 75 6e 2d 69 64 20 74 65 d-test run-id te
3a30: 73 74 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 st-id test-name
3a40: 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 29 29 outputfilename))
3a50: 0a 09 09 20 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d ... (common:sim
3a60: 70 6c 65 2d 66 69 6c 65 2d 72 65 6c 65 61 73 65 ple-file-release
3a70: 2d 6c 6f 63 6b 20 6c 6f 63 6b 66 29 0a 09 09 20 -lock lockf)...
3a80: 20 28 63 68 61 6e 67 65 2d 64 69 72 65 63 74 6f (change-directo
3a90: 72 79 20 6f 72 69 67 2d 64 69 72 29 0a 09 09 20 ry orig-dir)...
3aa0: 20 3b 3b 20 4e 42 2f 2f 20 74 65 73 74 73 3a 74 ;; NB// tests:t
3ab0: 65 73 74 2d 73 65 74 2d 74 6f 70 6c 6f 67 21 20 est-set-toplog!
3ac0: 69 73 20 72 65 6d 6f 74 65 20 69 6e 74 65 72 6e is remote intern
3ad0: 61 6c 2e 2e 2e 0a 09 09 20 20 28 74 65 73 74 73 al...... (tests
3ae0: 3a 74 65 73 74 2d 73 65 74 2d 74 6f 70 6c 6f 67 :test-set-toplog
3af0: 21 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 ! run-id test-na
3b00: 6d 65 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d me outputfilenam
3b10: 65 29 29 0a 09 09 3b 3b 20 64 69 64 6e 27 74 20 e))...;; didn't
3b20: 67 65 74 20 74 68 65 20 6c 6f 63 6b 2c 20 63 68 get the lock, ch
3b30: 65 63 6b 20 74 6f 20 73 65 65 20 69 66 20 63 75 eck to see if cu
3b40: 72 72 65 6e 74 20 75 70 64 61 74 65 20 73 74 61 rrent update sta
3b50: 72 74 65 64 20 6c 61 74 65 72 20 74 68 61 6e 20 rted later than
3b60: 74 68 69 73 20 0a 09 09 3b 3b 20 75 70 64 61 74 this ...;; updat
3b70: 65 2c 20 69 66 20 73 6f 20 77 65 20 63 61 6e 20 e, if so we can
3b80: 65 78 69 74 20 77 69 74 68 6f 75 74 20 64 6f 69 exit without doi
3b90: 6e 67 20 61 6e 79 20 77 6f 72 6b 0a 09 09 28 69 ng any work...(i
3ba0: 66 20 28 3e 20 6d 79 2d 73 74 61 72 74 2d 74 69 f (> my-start-ti
3bb0: 6d 65 20 28 66 69 6c 65 2d 6d 6f 64 69 66 69 63 me (file-modific
3bc0: 61 74 69 6f 6e 2d 74 69 6d 65 20 6c 6f 63 6b 66 ation-time lockf
3bd0: 29 29 0a 09 09 20 20 20 20 3b 3b 20 77 65 20 73 ))... ;; we s
3be0: 74 61 72 74 65 64 20 73 69 6e 63 65 20 63 75 72 tarted since cur
3bf0: 72 65 6e 74 20 72 65 2d 67 65 6e 20 69 6e 20 66 rent re-gen in f
3c00: 6c 69 67 68 74 2c 20 64 65 6c 61 79 20 61 20 6c light, delay a l
3c10: 69 74 74 6c 65 20 61 6e 64 20 74 72 79 20 61 67 ittle and try ag
3c20: 61 69 6e 0a 09 09 20 20 20 20 28 62 65 67 69 6e ain... (begin
3c30: 0a 09 09 20 20 20 20 20 20 28 64 65 62 75 67 3a ... (debug:
3c40: 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 22 57 61 print-info 1 "Wa
3c50: 69 74 69 6e 67 20 74 6f 20 75 70 64 61 74 65 20 iting to update
3c60: 22 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 " outputfilename
3c70: 20 22 2c 20 61 6e 6f 74 68 65 72 20 74 65 73 74 ", another test
3c80: 20 63 75 72 72 65 6e 74 6c 79 20 75 70 64 61 74 currently updat
3c90: 69 6e 67 20 69 74 22 29 0a 09 09 20 20 20 20 20 ing it")...
3ca0: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
3cb0: 28 2b 20 35 20 28 72 61 6e 64 6f 6d 20 35 29 29 (+ 5 (random 5))
3cc0: 29 20 3b 3b 20 64 65 6c 61 79 20 62 65 74 77 65 ) ;; delay betwe
3cd0: 65 6e 20 35 20 61 6e 64 20 31 30 20 73 65 63 6f en 5 and 10 seco
3ce0: 6e 64 73 0a 09 09 20 20 20 20 20 20 28 6c 6f 6f nds... (loo
3cf0: 70 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 p (common:simple
3d00: 2d 66 69 6c 65 2d 6c 6f 63 6b 20 6c 6f 63 6b 66 -file-lock lockf
3d10: 29 29 29 29 29 29 29 29 29 29 0a 0a 28 64 65 66 ))))))))))..(def
3d20: 69 6e 65 20 28 74 65 73 74 73 3a 67 65 6e 65 72 ine (tests:gener
3d30: 61 74 65 2d 68 74 6d 6c 2d 73 75 6d 6d 61 72 79 ate-html-summary
3d40: 2d 66 6f 72 2d 69 74 65 72 61 74 65 64 2d 74 65 -for-iterated-te
3d50: 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 st run-id test-i
3d60: 64 20 74 65 73 74 2d 6e 61 6d 65 20 6f 75 74 70 d test-name outp
3d70: 75 74 66 69 6c 65 6e 61 6d 65 29 0a 20 20 28 6c utfilename). (l
3d80: 65 74 20 28 28 63 6f 75 6e 74 73 20 28 6d 61 6b et ((counts (mak
3d90: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 09 e-hash-table))..
3da0: 28 73 74 61 74 65 63 6f 75 6e 74 73 20 28 6d 61 (statecounts (ma
3db0: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
3dc0: 09 28 6f 75 74 74 78 74 20 22 22 29 0a 09 28 74 .(outtxt "")..(t
3dd0: 6f 74 20 20 20 20 30 29 0a 09 28 74 65 73 74 64 ot 0)..(testd
3de0: 61 74 20 28 72 6d 74 3a 74 65 73 74 2d 67 65 74 at (rmt:test-get
3df0: 2d 72 65 63 6f 72 64 73 2d 66 6f 72 2d 69 6e 64 -records-for-ind
3e00: 65 78 2d 66 69 6c 65 20 72 75 6e 2d 69 64 20 74 ex-file run-id t
3e10: 65 73 74 2d 6e 61 6d 65 29 29 29 0a 20 20 20 20 est-name))).
3e20: 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d (with-output-to-
3e30: 66 69 6c 65 20 6f 75 74 70 75 74 66 69 6c 65 6e file outputfilen
3e40: 61 6d 65 0a 20 20 20 20 20 20 28 6c 61 6d 62 64 ame. (lambd
3e50: 61 20 28 29 0a 09 28 73 65 74 21 20 6f 75 74 74 a ()..(set! outt
3e60: 78 74 20 28 63 6f 6e 63 20 6f 75 74 74 78 74 20 xt (conc outtxt
3e70: 22 3c 68 74 6d 6c 3e 3c 74 69 74 6c 65 3e 53 75 "<html><title>Su
3e80: 6d 6d 61 72 79 3a 20 22 20 74 65 73 74 2d 6e 61 mmary: " test-na
3e90: 6d 65 20 0a 09 09 09 20 20 20 22 3c 2f 74 69 74 me .... "</tit
3ea0: 6c 65 3e 3c 62 6f 64 79 3e 3c 68 32 3e 53 75 6d le><body><h2>Sum
3eb0: 6d 61 72 79 20 66 6f 72 20 22 20 74 65 73 74 2d mary for " test-
3ec0: 6e 61 6d 65 20 22 3c 2f 68 32 3e 22 29 29 0a 09 name "</h2>"))..
3ed0: 28 66 6f 72 2d 65 61 63 68 0a 09 20 28 6c 61 6d (for-each.. (lam
3ee0: 62 64 61 20 28 74 65 73 74 72 65 63 6f 72 64 29 bda (testrecord)
3ef0: 0a 09 20 20 20 28 6c 65 74 20 28 28 69 64 20 20 .. (let ((id
3f00: 20 20 20 20 20 20 20 20 20 20 20 28 76 65 63 74 (vect
3f10: 6f 72 2d 72 65 66 20 74 65 73 74 72 65 63 6f 72 or-ref testrecor
3f20: 64 20 30 29 29 0a 09 09 20 28 69 74 65 6d 70 61 d 0))... (itempa
3f30: 74 68 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 th (vector
3f40: 2d 72 65 66 20 74 65 73 74 72 65 63 6f 72 64 20 -ref testrecord
3f50: 31 29 29 0a 09 09 20 28 73 74 61 74 65 20 20 20 1))... (state
3f60: 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 (vector-r
3f70: 65 66 20 74 65 73 74 72 65 63 6f 72 64 20 32 29 ef testrecord 2)
3f80: 29 0a 09 09 20 28 73 74 61 74 75 73 20 20 20 20 )... (status
3f90: 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 (vector-ref
3fa0: 20 74 65 73 74 72 65 63 6f 72 64 20 33 29 29 0a testrecord 3)).
3fb0: 09 09 20 28 72 75 6e 5f 64 75 72 61 74 69 6f 6e .. (run_duration
3fc0: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 (vector-ref t
3fd0: 65 73 74 72 65 63 6f 72 64 20 34 29 29 0a 09 09 estrecord 4))...
3fe0: 20 28 6c 6f 67 66 20 20 20 20 20 20 20 20 20 20 (logf
3ff0: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 65 73 (vector-ref tes
4000: 74 72 65 63 6f 72 64 20 35 29 29 0a 09 09 20 28 trecord 5))... (
4010: 63 6f 6d 6d 65 6e 74 20 20 20 20 20 20 20 20 28 comment (
4020: 76 65 63 74 6f 72 2d 72 65 66 20 74 65 73 74 72 vector-ref testr
4030: 65 63 6f 72 64 20 36 29 29 29 0a 09 20 20 20 20 ecord 6)))..
4040: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
4050: 21 20 63 6f 75 6e 74 73 20 73 74 61 74 75 73 20 ! counts status
4060: 28 2b 20 31 20 28 68 61 73 68 2d 74 61 62 6c 65 (+ 1 (hash-table
4070: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 63 6f 75 -ref/default cou
4080: 6e 74 73 20 73 74 61 74 75 73 20 30 29 29 29 0a nts status 0))).
4090: 09 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c . (hash-tabl
40a0: 65 2d 73 65 74 21 20 73 74 61 74 65 63 6f 75 6e e-set! statecoun
40b0: 74 73 20 73 74 61 74 65 20 28 2b 20 31 20 28 68 ts state (+ 1 (h
40c0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
40d0: 66 61 75 6c 74 20 73 74 61 74 65 63 6f 75 6e 74 fault statecount
40e0: 73 20 73 74 61 74 65 20 30 29 29 29 0a 09 20 20 s state 0)))..
40f0: 20 20 20 28 73 65 74 21 20 6f 75 74 74 78 74 20 (set! outtxt
4100: 28 63 6f 6e 63 20 6f 75 74 74 78 74 20 22 3c 74 (conc outtxt "<t
4110: 72 3e 22 0a 09 09 09 09 3b 3b 20 22 3c 74 64 3e r>".....;; "<td>
4120: 3c 61 20 68 72 65 66 3d 5c 22 22 20 69 74 65 6d <a href=\"" item
4130: 70 61 74 68 20 22 2f 22 20 6c 6f 67 66 20 22 5c path "/" logf "\
4140: 22 3e 20 22 20 69 74 65 6d 70 61 74 68 20 22 3c "> " itempath "<
4150: 2f 61 3e 3c 2f 74 64 3e 22 20 0a 09 09 09 09 22 /a></td>" ....."
4160: 3c 74 64 3e 3c 61 20 68 72 65 66 3d 5c 22 22 20 <td><a href=\""
4170: 69 74 65 6d 70 61 74 68 20 22 2f 74 65 73 74 2d itempath "/test-
4180: 73 75 6d 6d 61 72 79 2e 68 74 6d 6c 5c 22 3e 20 summary.html\">
4190: 22 20 69 74 65 6d 70 61 74 68 20 22 3c 2f 61 3e " itempath "</a>
41a0: 3c 2f 74 64 3e 22 20 0a 09 09 09 09 22 3c 74 64 </td>" ....."<td
41b0: 3e 22 20 73 74 61 74 65 20 20 20 20 22 3c 2f 74 >" state "</t
41c0: 64 3e 22 20 0a 09 09 09 09 22 3c 74 64 3e 3c 66 d>" ....."<td><f
41d0: 6f 6e 74 20 63 6f 6c 6f 72 3d 22 20 28 63 6f 6d ont color=" (com
41e0: 6d 6f 6e 3a 67 65 74 2d 63 6f 6c 6f 72 2d 66 72 mon:get-color-fr
41f0: 6f 6d 2d 73 74 61 74 75 73 20 73 74 61 74 75 73 om-status status
4200: 29 0a 09 09 09 09 22 3e 22 20 20 20 73 74 61 74 ).....">" stat
4210: 75 73 20 20 20 22 3c 2f 66 6f 6e 74 3e 3c 2f 74 us "</font></t
4220: 64 3e 22 0a 09 09 09 09 22 3c 74 64 3e 22 20 28 d>"....."<td>" (
4230: 69 66 20 28 65 71 75 61 6c 3f 20 63 6f 6d 6d 65 if (equal? comme
4240: 6e 74 20 22 22 29 0a 09 09 09 09 09 20 20 20 22 nt "")...... "
4250: 26 6e 62 73 70 3b 22 0a 09 09 09 09 09 20 20 20 "......
4260: 63 6f 6d 6d 65 6e 74 29 20 22 3c 2f 74 64 3e 22 comment) "</td>"
4270: 0a 09 09 09 09 09 20 20 20 22 3c 2f 74 72 3e 22 ...... "</tr>"
4280: 29 29 29 29 0a 09 20 28 69 66 20 28 6c 69 73 74 )))).. (if (list
4290: 3f 20 74 65 73 74 64 61 74 29 0a 09 20 20 20 20 ? testdat)..
42a0: 20 74 65 73 74 64 61 74 0a 09 20 20 20 20 20 28 testdat.. (
42b0: 62 65 67 69 6e 0a 09 20 20 20 20 20 20 20 28 70 begin.. (p
42c0: 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 66 61 69 rint "ERROR: fai
42d0: 6c 65 64 20 74 6f 20 67 65 74 20 72 65 63 6f 72 led to get recor
42e0: 64 73 20 77 69 74 68 20 72 6d 74 3a 74 65 73 74 ds with rmt:test
42f0: 2d 67 65 74 2d 72 65 63 6f 72 64 73 2d 66 6f 72 -get-records-for
4300: 2d 69 6e 64 65 78 2d 66 69 6c 65 20 72 75 6e 2d -index-file run-
4310: 69 64 3d 22 20 72 75 6e 2d 69 64 20 22 74 65 73 id=" run-id "tes
4320: 74 2d 6e 61 6d 65 3d 22 20 74 65 73 74 2d 6e 61 t-name=" test-na
4330: 6d 65 29 0a 09 20 20 20 20 20 20 20 27 28 29 29 me).. '())
4340: 29 29 0a 09 0a 09 28 70 72 69 6e 74 20 22 3c 74 ))....(print "<t
4350: 61 62 6c 65 3e 3c 74 72 3e 3c 74 64 20 76 61 6c able><tr><td val
4360: 69 67 6e 3d 5c 22 74 6f 70 5c 22 3e 22 29 0a 09 ign=\"top\">")..
4370: 3b 3b 20 50 72 69 6e 74 20 6f 75 74 20 73 74 61 ;; Print out sta
4380: 74 73 20 66 6f 72 20 73 74 61 74 75 73 0a 09 28 ts for status..(
4390: 73 65 74 21 20 74 6f 74 20 30 29 0a 09 28 70 72 set! tot 0)..(pr
43a0: 69 6e 74 20 22 3c 74 61 62 6c 65 20 63 65 6c 6c int "<table cell
43b0: 73 70 61 63 69 6e 67 3d 5c 22 30 5c 22 20 62 6f spacing=\"0\" bo
43c0: 72 64 65 72 3d 5c 22 31 5c 22 3e 3c 74 72 3e 3c rder=\"1\"><tr><
43d0: 74 64 20 63 6f 6c 73 70 61 6e 3d 5c 22 32 5c 22 td colspan=\"2\"
43e0: 3e 3c 68 32 3e 53 74 61 74 65 20 73 74 61 74 73 ><h2>State stats
43f0: 3c 2f 68 32 3e 3c 2f 74 64 3e 3c 2f 74 72 3e 22 </h2></td></tr>"
4400: 29 0a 09 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 )..(for-each (la
4410: 6d 62 64 61 20 28 73 74 61 74 65 29 0a 09 09 20 mbda (state)...
4420: 20 20 20 28 73 65 74 21 20 74 6f 74 20 28 2b 20 (set! tot (+
4430: 74 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d tot (hash-table-
4440: 72 65 66 20 73 74 61 74 65 63 6f 75 6e 74 73 20 ref statecounts
4450: 73 74 61 74 65 29 29 29 0a 09 09 20 20 20 20 28 state)))... (
4460: 70 72 69 6e 74 20 22 3c 74 72 3e 3c 74 64 3e 22 print "<tr><td>"
4470: 20 73 74 61 74 65 20 22 3c 2f 74 64 3e 3c 74 64 state "</td><td
4480: 3e 22 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 >" (hash-table-r
4490: 65 66 20 73 74 61 74 65 63 6f 75 6e 74 73 20 73 ef statecounts s
44a0: 74 61 74 65 29 20 22 3c 2f 74 64 3e 3c 2f 74 72 tate) "</td></tr
44b0: 3e 22 29 29 0a 09 09 20 20 28 68 61 73 68 2d 74 >"))... (hash-t
44c0: 61 62 6c 65 2d 6b 65 79 73 20 73 74 61 74 65 63 able-keys statec
44d0: 6f 75 6e 74 73 29 29 0a 09 28 70 72 69 6e 74 20 ounts))..(print
44e0: 22 3c 74 72 3e 3c 74 64 3e 54 6f 74 61 6c 3c 2f "<tr><td>Total</
44f0: 74 64 3e 3c 74 64 3e 22 20 74 6f 74 20 22 3c 2f td><td>" tot "</
4500: 74 64 3e 3c 2f 74 72 3e 3c 2f 74 61 62 6c 65 3e td></tr></table>
4510: 22 29 0a 09 28 70 72 69 6e 74 20 22 3c 2f 74 64 ")..(print "</td
4520: 3e 3c 74 64 20 76 61 6c 69 67 6e 3d 5c 22 74 6f ><td valign=\"to
4530: 70 5c 22 3e 22 29 0a 09 3b 3b 20 50 72 69 6e 74 p\">")..;; Print
4540: 20 6f 75 74 20 73 74 61 74 73 20 66 6f 72 20 73 out stats for s
4550: 74 61 74 65 0a 09 28 73 65 74 21 20 74 6f 74 20 tate..(set! tot
4560: 30 29 0a 09 28 70 72 69 6e 74 20 22 3c 74 61 62 0)..(print "<tab
4570: 6c 65 20 63 65 6c 6c 73 70 61 63 69 6e 67 3d 5c le cellspacing=\
4580: 22 30 5c 22 20 62 6f 72 64 65 72 3d 5c 22 31 5c "0\" border=\"1\
4590: 22 3e 3c 74 72 3e 3c 74 64 20 63 6f 6c 73 70 61 "><tr><td colspa
45a0: 6e 3d 5c 22 32 5c 22 3e 3c 68 32 3e 53 74 61 74 n=\"2\"><h2>Stat
45b0: 75 73 20 73 74 61 74 73 3c 2f 68 32 3e 3c 2f 74 us stats</h2></t
45c0: 64 3e 3c 2f 74 72 3e 22 29 0a 09 28 66 6f 72 2d d></tr>")..(for-
45d0: 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 73 74 each (lambda (st
45e0: 61 74 75 73 29 0a 09 09 20 20 20 20 28 73 65 74 atus)... (set
45f0: 21 20 74 6f 74 20 28 2b 20 74 6f 74 20 28 68 61 ! tot (+ tot (ha
4600: 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 63 6f 75 sh-table-ref cou
4610: 6e 74 73 20 73 74 61 74 75 73 29 29 29 0a 09 09 nts status)))...
4620: 20 20 20 20 28 70 72 69 6e 74 20 22 3c 74 72 3e (print "<tr>
4630: 3c 74 64 3e 3c 66 6f 6e 74 20 63 6f 6c 6f 72 3d <td><font color=
4640: 5c 22 22 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d \"" (common:get-
4650: 63 6f 6c 6f 72 2d 66 72 6f 6d 2d 73 74 61 74 75 color-from-statu
4660: 73 20 73 74 61 74 75 73 29 20 22 5c 22 3e 22 20 s status) "\">"
4670: 73 74 61 74 75 73 0a 09 09 09 20 20 20 22 3c 2f status.... "</
4680: 66 6f 6e 74 3e 3c 2f 74 64 3e 3c 74 64 3e 22 20 font></td><td>"
4690: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 (hash-table-ref
46a0: 63 6f 75 6e 74 73 20 73 74 61 74 75 73 29 20 22 counts status) "
46b0: 3c 2f 74 64 3e 3c 2f 74 72 3e 22 29 29 0a 09 09 </td></tr>"))...
46c0: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 (hash-table-ke
46d0: 79 73 20 63 6f 75 6e 74 73 29 29 0a 09 28 70 72 ys counts))..(pr
46e0: 69 6e 74 20 22 3c 74 72 3e 3c 74 64 3e 54 6f 74 int "<tr><td>Tot
46f0: 61 6c 3c 2f 74 64 3e 3c 74 64 3e 22 20 74 6f 74 al</td><td>" tot
4700: 20 22 3c 2f 74 64 3e 3c 2f 74 72 3e 3c 2f 74 61 "</td></tr></ta
4710: 62 6c 65 3e 22 29 0a 09 28 70 72 69 6e 74 20 22 ble>")..(print "
4720: 3c 2f 74 64 3e 3c 2f 74 64 3e 3c 2f 74 72 3e 3c </td></td></tr><
4730: 2f 74 61 62 6c 65 3e 22 29 0a 09 0a 09 28 70 72 /table>")....(pr
4740: 69 6e 74 20 22 3c 74 61 62 6c 65 20 63 65 6c 6c int "<table cell
4750: 73 70 61 63 69 6e 67 3d 5c 22 30 5c 22 20 62 6f spacing=\"0\" bo
4760: 72 64 65 72 3d 5c 22 31 5c 22 3e 22 20 0a 09 20 rder=\"1\">" ..
4770: 20 20 20 20 20 20 22 3c 74 72 3e 3c 74 64 3e 49 "<tr><td>I
4780: 74 65 6d 3c 2f 74 64 3e 3c 74 64 3e 53 74 61 74 tem</td><td>Stat
4790: 65 3c 2f 74 64 3e 3c 74 64 3e 53 74 61 74 75 73 e</td><td>Status
47a0: 3c 2f 74 64 3e 3c 74 64 3e 43 6f 6d 6d 65 6e 74 </td><td>Comment
47b0: 3c 2f 74 64 3e 22 0a 09 20 20 20 20 20 20 20 6f </td>".. o
47c0: 75 74 74 78 74 20 22 3c 2f 74 61 62 6c 65 3e 3c uttxt "</table><
47d0: 2f 62 6f 64 79 3e 3c 2f 68 74 6d 6c 3e 22 29 0a /body></html>").
47e0: 09 3b 3b 20 28 72 65 6c 65 61 73 65 2d 64 6f 74 .;; (release-dot
47f0: 2d 6c 6f 63 6b 20 6f 75 74 70 75 74 66 69 6c 65 -lock outputfile
4800: 6e 61 6d 65 29 0a 09 29 29 29 29 0a 0a 3b 3b 20 name)..))))..;;
4810: 43 48 45 43 4b 20 2d 20 57 41 53 20 54 48 49 53 CHECK - WAS THIS
4820: 20 41 44 44 45 44 20 4f 52 20 52 45 4d 4f 56 45 ADDED OR REMOVE
4830: 44 3f 20 4d 41 4e 55 41 4c 20 4d 45 52 47 45 20 D? MANUAL MERGE
4840: 57 49 54 48 20 41 50 49 20 53 54 55 46 46 21 21 WITH API STUFF!!
4850: 21 0a 3b 3b 0a 3b 3b 20 67 65 74 20 61 20 70 72 !.;;.;; get a pr
4860: 65 74 74 79 20 74 61 62 6c 65 20 74 6f 20 73 75 etty table to su
4870: 6d 6d 61 72 69 7a 65 20 73 74 65 70 73 0a 3b 3b mmarize steps.;;
4880: 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 64 63 6f .;; (define (dco
4890: 6d 6d 6f 6e 3a 70 72 6f 63 65 73 73 2d 73 74 65 mmon:process-ste
48a0: 70 73 2d 74 61 62 6c 65 20 73 74 65 70 73 29 3b ps-table steps);
48b0: 3b 20 64 62 20 74 65 73 74 2d 69 64 20 23 21 6b ; db test-id #!k
48c0: 65 79 20 28 77 6f 72 6b 2d 61 72 65 61 20 23 66 ey (work-area #f
48d0: 29 29 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 )).(define (test
48e0: 73 3a 70 72 6f 63 65 73 73 2d 73 74 65 70 73 2d s:process-steps-
48f0: 74 61 62 6c 65 20 73 74 65 70 73 29 3b 3b 20 64 table steps);; d
4900: 62 20 74 65 73 74 2d 69 64 20 23 21 6b 65 79 20 b test-id #!key
4910: 28 77 6f 72 6b 2d 61 72 65 61 20 23 66 29 29 0a (work-area #f)).
4920: 3b 3b 20 20 28 6c 65 74 20 28 28 73 74 65 70 73 ;; (let ((steps
4930: 20 20 20 28 64 62 3a 67 65 74 2d 73 74 65 70 73 (db:get-steps
4940: 2d 66 6f 72 2d 74 65 73 74 20 64 62 20 74 65 73 -for-test db tes
4950: 74 2d 69 64 20 77 6f 72 6b 2d 61 72 65 61 3a 20 t-id work-area:
4960: 77 6f 72 6b 2d 61 72 65 61 29 29 29 0a 20 20 20 work-area))).
4970: 20 3b 3b 20 6f 72 67 61 6e 69 73 65 20 74 68 65 ;; organise the
4980: 20 73 74 65 70 73 20 66 6f 72 20 62 65 74 74 65 steps for bette
4990: 72 20 72 65 61 64 61 62 69 6c 69 74 79 0a 20 20 r readability.
49a0: 20 20 28 6c 65 74 20 28 28 72 65 73 20 28 6d 61 (let ((res (ma
49b0: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 ke-hash-table)))
49c0: 0a 20 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 . (for-each
49d0: 20 0a 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 . (lambda
49e0: 20 28 73 74 65 70 29 0a 09 20 28 64 65 62 75 67 (step).. (debug
49f0: 3a 70 72 69 6e 74 20 36 20 22 73 74 65 70 3d 22 :print 6 "step="
4a00: 20 73 74 65 70 29 0a 09 20 28 6c 65 74 20 28 28 step).. (let ((
4a10: 72 65 63 6f 72 64 20 28 68 61 73 68 2d 74 61 62 record (hash-tab
4a20: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 0a le-ref/default .
4a30: 09 09 09 72 65 73 20 0a 09 09 09 28 74 64 62 3a ...res ....(tdb:
4a40: 73 74 65 70 2d 67 65 74 2d 73 74 65 70 6e 61 6d step-get-stepnam
4a50: 65 20 73 74 65 70 29 20 0a 09 09 09 3b 3b 20 20 e step) ....;;
4a60: 20 20 20 20 20 20 73 74 65 70 6e 61 6d 65 20 20 stepname
4a70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 73 74 st
4a80: 61 72 74 20 65 6e 64 20 73 74 61 74 75 73 20 44 art end status D
4a90: 75 72 61 74 69 6f 6e 20 20 4c 6f 67 66 69 6c 65 uration Logfile
4aa0: 20 0a 09 09 09 28 76 65 63 74 6f 72 20 28 74 64 ....(vector (td
4ab0: 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 65 70 6e b:step-get-stepn
4ac0: 61 6d 65 20 73 74 65 70 29 20 22 22 20 20 20 22 ame step) "" "
4ad0: 22 20 22 22 20 20 20 20 20 22 22 20 20 20 20 20 " "" ""
4ae0: 20 20 20 22 22 29 29 29 29 0a 09 20 20 20 28 64 "")))).. (d
4af0: 65 62 75 67 3a 70 72 69 6e 74 20 36 20 22 72 65 ebug:print 6 "re
4b00: 63 6f 72 64 28 62 65 66 6f 72 65 29 20 3d 20 22 cord(before) = "
4b10: 20 72 65 63 6f 72 64 20 0a 09 09 09 22 5c 6e 69 record ...."\ni
4b20: 64 3a 20 20 20 20 20 20 20 22 20 28 74 64 62 3a d: " (tdb:
4b30: 73 74 65 70 2d 67 65 74 2d 69 64 20 73 74 65 70 step-get-id step
4b40: 29 0a 09 09 09 22 5c 6e 73 74 65 70 6e 61 6d 65 )...."\nstepname
4b50: 3a 20 22 20 28 74 64 62 3a 73 74 65 70 2d 67 65 : " (tdb:step-ge
4b60: 74 2d 73 74 65 70 6e 61 6d 65 20 73 74 65 70 29 t-stepname step)
4b70: 0a 09 09 09 22 5c 6e 73 74 61 74 65 3a 20 20 20 ...."\nstate:
4b80: 20 22 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 " (tdb:step-get
4b90: 2d 73 74 61 74 65 20 73 74 65 70 29 0a 09 09 09 -state step)....
4ba0: 22 5c 6e 73 74 61 74 75 73 3a 20 20 20 22 20 28 "\nstatus: " (
4bb0: 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 61 tdb:step-get-sta
4bc0: 74 75 73 20 73 74 65 70 29 0a 09 09 09 22 5c 6e tus step)...."\n
4bd0: 74 69 6d 65 3a 20 20 20 20 20 22 20 28 74 64 62 time: " (tdb
4be0: 3a 73 74 65 70 2d 67 65 74 2d 65 76 65 6e 74 5f :step-get-event_
4bf0: 74 69 6d 65 20 73 74 65 70 29 29 0a 09 20 20 20 time step))..
4c00: 28 63 61 73 65 20 28 73 74 72 69 6e 67 2d 3e 73 (case (string->s
4c10: 79 6d 62 6f 6c 20 28 74 64 62 3a 73 74 65 70 2d ymbol (tdb:step-
4c20: 67 65 74 2d 73 74 61 74 65 20 73 74 65 70 29 29 get-state step))
4c30: 0a 09 20 20 20 20 20 28 28 73 74 61 72 74 29 28 .. ((start)(
4c40: 76 65 63 74 6f 72 2d 73 65 74 21 20 72 65 63 6f vector-set! reco
4c50: 72 64 20 31 20 28 74 64 62 3a 73 74 65 70 2d 67 rd 1 (tdb:step-g
4c60: 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 73 74 et-event_time st
4c70: 65 70 29 29 0a 09 20 20 20 20 20 20 28 76 65 63 ep)).. (vec
4c80: 74 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 64 20 tor-set! record
4c90: 33 20 28 69 66 20 28 65 71 75 61 6c 3f 20 28 76 3 (if (equal? (v
4ca0: 65 63 74 6f 72 2d 72 65 66 20 72 65 63 6f 72 64 ector-ref record
4cb0: 20 33 29 20 22 22 29 0a 09 09 09 09 09 28 74 64 3) "")......(td
4cc0: 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 61 74 75 b:step-get-statu
4cd0: 73 20 73 74 65 70 29 29 29 0a 09 20 20 20 20 20 s step)))..
4ce0: 20 28 69 66 20 28 3e 20 28 73 74 72 69 6e 67 2d (if (> (string-
4cf0: 6c 65 6e 67 74 68 20 28 74 64 62 3a 73 74 65 70 length (tdb:step
4d00: 2d 67 65 74 2d 6c 6f 67 66 69 6c 65 20 73 74 65 -get-logfile ste
4d10: 70 29 29 0a 09 09 20 20 20 20 20 30 29 0a 09 09 p))... 0)...
4d20: 20 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 72 (vector-set! r
4d30: 65 63 6f 72 64 20 35 20 28 74 64 62 3a 73 74 65 ecord 5 (tdb:ste
4d40: 70 2d 67 65 74 2d 6c 6f 67 66 69 6c 65 20 73 74 p-get-logfile st
4d50: 65 70 29 29 29 29 0a 09 20 20 20 20 20 28 28 65 ep)))).. ((e
4d60: 6e 64 29 20 20 0a 09 20 20 20 20 20 20 28 76 65 nd) .. (ve
4d70: 63 74 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 64 ctor-set! record
4d80: 20 32 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 20 2 (any->number
4d90: 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 65 76 (tdb:step-get-ev
4da0: 65 6e 74 5f 74 69 6d 65 20 73 74 65 70 29 29 29 ent_time step)))
4db0: 0a 09 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d .. (vector-
4dc0: 73 65 74 21 20 72 65 63 6f 72 64 20 33 20 28 74 set! record 3 (t
4dd0: 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 61 74 db:step-get-stat
4de0: 75 73 20 73 74 65 70 29 29 0a 09 20 20 20 20 20 us step))..
4df0: 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 72 65 (vector-set! re
4e00: 63 6f 72 64 20 34 20 28 6c 65 74 20 28 28 73 74 cord 4 (let ((st
4e10: 61 72 74 74 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 artt (any->numbe
4e20: 72 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 65 r (vector-ref re
4e30: 63 6f 72 64 20 31 29 29 29 0a 09 09 09 09 09 20 cord 1)))......
4e40: 20 28 65 6e 64 74 20 20 20 28 61 6e 79 2d 3e 6e (endt (any->n
4e50: 75 6d 62 65 72 20 28 76 65 63 74 6f 72 2d 72 65 umber (vector-re
4e60: 66 20 72 65 63 6f 72 64 20 32 29 29 29 29 0a 09 f record 2))))..
4e70: 09 09 09 20 20 20 20 20 20 28 64 65 62 75 67 3a ... (debug:
4e80: 70 72 69 6e 74 20 34 20 22 72 65 63 6f 72 64 5b print 4 "record[
4e90: 31 5d 3d 22 20 28 76 65 63 74 6f 72 2d 72 65 66 1]=" (vector-ref
4ea0: 20 72 65 63 6f 72 64 20 31 29 20 0a 09 09 09 09 record 1) .....
4eb0: 09 09 20 20 20 22 2c 20 73 74 61 72 74 74 3d 22 .. ", startt="
4ec0: 20 73 74 61 72 74 74 20 22 2c 20 65 6e 64 74 3d startt ", endt=
4ed0: 22 20 65 6e 64 74 0a 09 09 09 09 09 09 20 20 20 " endt.......
4ee0: 22 2c 20 67 65 74 2d 73 74 61 74 75 73 3a 20 22 ", get-status: "
4ef0: 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 (tdb:step-get-s
4f00: 74 61 74 75 73 20 73 74 65 70 29 29 0a 09 09 09 tatus step))....
4f10: 09 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 . (if (and
4f20: 28 6e 75 6d 62 65 72 3f 20 73 74 61 72 74 74 29 (number? startt)
4f30: 28 6e 75 6d 62 65 72 3f 20 65 6e 64 74 29 29 0a (number? endt)).
4f40: 09 09 09 09 09 20 20 28 73 65 63 6f 6e 64 73 2d ..... (seconds-
4f50: 3e 68 72 2d 6d 69 6e 2d 73 65 63 20 28 2d 20 65 >hr-min-sec (- e
4f60: 6e 64 74 20 73 74 61 72 74 74 29 29 20 22 2d 31 ndt startt)) "-1
4f70: 22 29 29 29 0a 09 20 20 20 20 20 20 28 69 66 20 "))).. (if
4f80: 28 3e 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 (> (string-lengt
4f90: 68 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d h (tdb:step-get-
4fa0: 6c 6f 67 66 69 6c 65 20 73 74 65 70 29 29 0a 09 logfile step))..
4fb0: 09 20 20 20 20 20 30 29 0a 09 09 20 20 28 76 65 . 0)... (ve
4fc0: 63 74 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 64 ctor-set! record
4fd0: 20 35 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 5 (tdb:step-get
4fe0: 2d 6c 6f 67 66 69 6c 65 20 73 74 65 70 29 29 29 -logfile step)))
4ff0: 29 0a 09 20 20 20 20 20 28 65 6c 73 65 0a 09 20 ).. (else..
5000: 20 20 20 20 20 28 76 65 63 74 6f 72 2d 73 65 74 (vector-set
5010: 21 20 72 65 63 6f 72 64 20 32 20 28 74 64 62 3a ! record 2 (tdb:
5020: 73 74 65 70 2d 67 65 74 2d 73 74 61 74 65 20 73 step-get-state s
5030: 74 65 70 29 29 0a 09 20 20 20 20 20 20 28 76 65 tep)).. (ve
5040: 63 74 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 64 ctor-set! record
5050: 20 33 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 3 (tdb:step-get
5060: 2d 73 74 61 74 75 73 20 73 74 65 70 29 29 0a 09 -status step))..
5070: 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 73 65 (vector-se
5080: 74 21 20 72 65 63 6f 72 64 20 34 20 28 74 64 62 t! record 4 (tdb
5090: 3a 73 74 65 70 2d 67 65 74 2d 65 76 65 6e 74 5f :step-get-event_
50a0: 74 69 6d 65 20 73 74 65 70 29 29 29 29 0a 09 20 time step))))..
50b0: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
50c0: 74 21 20 72 65 73 20 28 74 64 62 3a 73 74 65 70 t! res (tdb:step
50d0: 2d 67 65 74 2d 73 74 65 70 6e 61 6d 65 20 73 74 -get-stepname st
50e0: 65 70 29 20 72 65 63 6f 72 64 29 0a 09 20 20 20 ep) record)..
50f0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 36 20 22 (debug:print 6 "
5100: 72 65 63 6f 72 64 28 61 66 74 65 72 29 20 20 3d record(after) =
5110: 20 22 20 72 65 63 6f 72 64 20 0a 09 09 09 22 5c " record ...."\
5120: 6e 69 64 3a 20 20 20 20 20 20 20 22 20 28 74 64 nid: " (td
5130: 62 3a 73 74 65 70 2d 67 65 74 2d 69 64 20 73 74 b:step-get-id st
5140: 65 70 29 0a 09 09 09 22 5c 6e 73 74 65 70 6e 61 ep)...."\nstepna
5150: 6d 65 3a 20 22 20 28 74 64 62 3a 73 74 65 70 2d me: " (tdb:step-
5160: 67 65 74 2d 73 74 65 70 6e 61 6d 65 20 73 74 65 get-stepname ste
5170: 70 29 0a 09 09 09 22 5c 6e 73 74 61 74 65 3a 20 p)...."\nstate:
5180: 20 20 20 22 20 28 74 64 62 3a 73 74 65 70 2d 67 " (tdb:step-g
5190: 65 74 2d 73 74 61 74 65 20 73 74 65 70 29 0a 09 et-state step)..
51a0: 09 09 22 5c 6e 73 74 61 74 75 73 3a 20 20 20 22 .."\nstatus: "
51b0: 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 (tdb:step-get-s
51c0: 74 61 74 75 73 20 73 74 65 70 29 0a 09 09 09 22 tatus step)...."
51d0: 5c 6e 74 69 6d 65 3a 20 20 20 20 20 22 20 28 74 \ntime: " (t
51e0: 64 62 3a 73 74 65 70 2d 67 65 74 2d 65 76 65 6e db:step-get-even
51f0: 74 5f 74 69 6d 65 20 73 74 65 70 29 29 29 29 0a t_time step)))).
5200: 20 20 20 20 20 20 20 3b 3b 20 28 65 6c 73 65 20 ;; (else
5210: 20 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 72 (vector-set! r
5220: 65 63 6f 72 64 20 31 20 28 74 64 62 3a 73 74 65 ecord 1 (tdb:ste
5230: 70 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 p-get-event_time
5240: 20 73 74 65 70 29 29 29 0a 20 20 20 20 20 20 20 step))).
5250: 28 73 6f 72 74 20 73 74 65 70 73 20 28 6c 61 6d (sort steps (lam
5260: 62 64 61 20 28 61 20 62 29 0a 09 09 20 20 20 20 bda (a b)...
5270: 20 28 63 6f 6e 64 0a 09 09 20 20 20 20 20 20 28 (cond... (
5280: 28 3c 20 20 20 28 74 64 62 3a 73 74 65 70 2d 67 (< (tdb:step-g
5290: 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 61 29 et-event_time a)
52a0: 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 65 76 (tdb:step-get-ev
52b0: 65 6e 74 5f 74 69 6d 65 20 62 29 29 20 23 74 29 ent_time b)) #t)
52c0: 0a 09 09 20 20 20 20 20 20 28 28 65 71 3f 20 28 ... ((eq? (
52d0: 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 65 76 65 tdb:step-get-eve
52e0: 6e 74 5f 74 69 6d 65 20 61 29 28 74 64 62 3a 73 nt_time a)(tdb:s
52f0: 74 65 70 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 tep-get-event_ti
5300: 6d 65 20 62 29 29 20 0a 09 09 20 20 20 20 20 20 me b)) ...
5310: 20 28 3c 20 20 20 28 74 64 62 3a 73 74 65 70 2d (< (tdb:step-
5320: 67 65 74 2d 69 64 20 61 29 20 20 20 20 20 20 20 get-id a)
5330: 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 69 (tdb:step-get-i
5340: 64 20 62 29 29 29 0a 09 09 20 20 20 20 20 20 28 d b)))... (
5350: 65 6c 73 65 20 23 66 29 29 29 29 29 0a 20 20 20 else #f))))).
5360: 20 20 20 72 65 73 29 29 0a 0a 0a 3b 3b 20 74 65 res))...;; te
5370: 6d 70 6f 72 61 72 69 6c 79 20 70 61 73 73 69 6e mporarily passin
5380: 67 20 69 6e 20 64 62 73 74 72 75 63 74 20 74 6f g in dbstruct to
5390: 20 73 75 70 70 6f 72 74 20 64 69 72 65 63 74 20 support direct
53a0: 61 63 63 65 73 73 20 28 69 2e 65 2e 20 62 79 70 access (i.e. byp
53b0: 61 73 73 69 6e 67 20 73 65 72 76 65 72 73 29 0a assing servers).
53c0: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 ;;.(define (test
53d0: 73 3a 67 65 74 2d 63 6f 6d 70 72 65 73 73 65 64 s:get-compressed
53e0: 2d 73 74 65 70 73 20 64 62 73 74 72 75 63 74 20 -steps dbstruct
53f0: 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 0a run-id test-id).
5400: 20 20 28 6c 65 74 2a 20 28 28 73 74 65 70 73 2d (let* ((steps-
5410: 64 61 74 61 20 20 28 69 66 20 64 62 73 74 72 75 data (if dbstru
5420: 63 74 20 0a 09 09 09 20 20 28 64 62 3a 67 65 74 ct .... (db:get
5430: 2d 73 74 65 70 73 2d 66 6f 72 2d 74 65 73 74 20 -steps-for-test
5440: 64 62 73 74 72 75 63 74 20 72 75 6e 2d 69 64 20 dbstruct run-id
5450: 74 65 73 74 2d 69 64 29 0a 09 09 09 20 20 28 72 test-id).... (r
5460: 6d 74 3a 67 65 74 2d 73 74 65 70 73 2d 66 6f 72 mt:get-steps-for
5470: 2d 74 65 73 74 20 72 75 6e 2d 69 64 20 74 65 73 -test run-id tes
5480: 74 2d 69 64 29 29 29 20 0a 09 20 28 63 6f 6d 70 t-id))) .. (comp
5490: 72 73 74 65 70 73 20 20 28 74 65 73 74 73 3a 70 rsteps (tests:p
54a0: 72 6f 63 65 73 73 2d 73 74 65 70 73 2d 74 61 62 rocess-steps-tab
54b0: 6c 65 20 73 74 65 70 73 2d 64 61 74 61 29 29 29 le steps-data)))
54c0: 20 3b 3b 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c ;; (open-run-cl
54d0: 6f 73 65 20 64 62 3a 67 65 74 2d 73 74 65 70 73 ose db:get-steps
54e0: 2d 74 61 62 6c 65 20 23 66 20 74 65 73 74 2d 69 -table #f test-i
54f0: 64 20 77 6f 72 6b 2d 61 72 65 61 3a 20 77 6f 72 d work-area: wor
5500: 6b 2d 61 72 65 61 29 29 29 0a 20 20 20 20 28 6d k-area))). (m
5510: 61 70 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 ap (lambda (x)..
5520: 20 20 20 3b 3b 20 74 61 6b 65 20 61 64 76 61 6e ;; take advan
5530: 74 61 67 65 20 6f 66 20 74 68 65 20 5c 6e 20 6f tage of the \n o
5540: 6e 20 74 69 6d 65 2d 3e 73 74 72 69 6e 67 0a 09 n time->string..
5550: 20 20 20 28 76 65 63 74 6f 72 0a 09 20 20 20 20 (vector..
5560: 28 76 65 63 74 6f 72 2d 72 65 66 20 78 20 30 29 (vector-ref x 0)
5570: 0a 09 20 20 20 20 28 6c 65 74 20 28 28 73 20 28 .. (let ((s (
5580: 76 65 63 74 6f 72 2d 72 65 66 20 78 20 31 29 29 vector-ref x 1))
5590: 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 6e 75 ).. (if (nu
55a0: 6d 62 65 72 3f 20 73 29 28 73 65 63 6f 6e 64 73 mber? s)(seconds
55b0: 2d 3e 74 69 6d 65 2d 73 74 72 69 6e 67 20 73 29 ->time-string s)
55c0: 20 73 29 29 0a 09 20 20 20 20 28 6c 65 74 20 28 s)).. (let (
55d0: 28 73 20 28 76 65 63 74 6f 72 2d 72 65 66 20 78 (s (vector-ref x
55e0: 20 32 29 29 29 0a 09 20 20 20 20 20 20 28 69 66 2))).. (if
55f0: 20 28 6e 75 6d 62 65 72 3f 20 73 29 28 73 65 63 (number? s)(sec
5600: 6f 6e 64 73 2d 3e 74 69 6d 65 2d 73 74 72 69 6e onds->time-strin
5610: 67 20 73 29 20 73 29 29 0a 09 20 20 20 20 28 76 g s) s)).. (v
5620: 65 63 74 6f 72 2d 72 65 66 20 78 20 33 29 20 20 ector-ref x 3)
5630: 20 20 3b 3b 20 73 74 61 74 75 73 0a 09 20 20 20 ;; status..
5640: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 78 20 34 (vector-ref x 4
5650: 29 0a 09 20 20 20 20 28 76 65 63 74 6f 72 2d 72 ).. (vector-r
5660: 65 66 20 78 20 35 29 29 29 20 20 3b 3b 20 74 69 ef x 5))) ;; ti
5670: 6d 65 20 64 65 6c 74 61 0a 09 20 28 73 6f 72 74 me delta.. (sort
5680: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 76 61 6c (hash-table-val
5690: 75 65 73 20 63 6f 6d 70 72 73 74 65 70 73 29 0a ues comprsteps).
56a0: 09 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 . (lambda
56b0: 28 61 20 62 29 0a 09 09 20 28 6c 65 74 20 28 28 (a b)... (let ((
56c0: 74 69 6d 65 2d 61 20 28 76 65 63 74 6f 72 2d 72 time-a (vector-r
56d0: 65 66 20 61 20 31 29 29 0a 09 09 20 20 20 20 20 ef a 1))...
56e0: 20 20 28 74 69 6d 65 2d 62 20 28 76 65 63 74 6f (time-b (vecto
56f0: 72 2d 72 65 66 20 62 20 31 29 29 29 0a 09 09 20 r-ref b 1)))...
5700: 20 20 28 69 66 20 28 61 6e 64 20 28 6e 75 6d 62 (if (and (numb
5710: 65 72 3f 20 74 69 6d 65 2d 61 29 28 6e 75 6d 62 er? time-a)(numb
5720: 65 72 3f 20 74 69 6d 65 2d 62 29 29 0a 09 09 20 er? time-b))...
5730: 20 20 20 20 20 20 28 69 66 20 28 3c 20 74 69 6d (if (< tim
5740: 65 2d 61 20 74 69 6d 65 2d 62 29 0a 09 09 09 20 e-a time-b)....
5750: 20 20 23 74 0a 09 09 09 20 20 20 28 69 66 20 28 #t.... (if (
5760: 65 71 3f 20 74 69 6d 65 2d 61 20 74 69 6d 65 2d eq? time-a time-
5770: 62 29 0a 09 09 09 20 20 20 20 20 20 20 28 73 74 b).... (st
5780: 72 69 6e 67 3c 3f 20 28 63 6f 6e 63 20 28 76 65 ring<? (conc (ve
5790: 63 74 6f 72 2d 72 65 66 20 61 20 32 29 29 0a 09 ctor-ref a 2))..
57a0: 09 09 09 09 20 28 63 6f 6e 63 20 28 76 65 63 74 .... (conc (vect
57b0: 6f 72 2d 72 65 66 20 62 20 32 29 29 29 0a 09 09 or-ref b 2)))...
57c0: 09 20 20 20 20 20 20 20 23 66 29 29 0a 09 09 20 . #f))...
57d0: 20 20 20 20 20 20 28 73 74 72 69 6e 67 3c 3f 20 (string<?
57e0: 28 63 6f 6e 63 20 74 69 6d 65 2d 61 29 28 63 6f (conc time-a)(co
57f0: 6e 63 20 74 69 6d 65 2d 62 29 29 29 29 29 29 29 nc time-b)))))))
5800: 29 29 0a 0a 0a 3b 3b 20 73 75 6d 6d 61 72 69 7a ))...;; summariz
5810: 65 20 74 65 73 74 0a 28 64 65 66 69 6e 65 20 28 e test.(define (
5820: 74 65 73 74 73 3a 73 75 6d 6d 61 72 69 7a 65 2d tests:summarize-
5830: 74 65 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 test run-id test
5840: 2d 69 64 29 0a 20 20 28 6c 65 74 2a 20 28 28 74 -id). (let* ((t
5850: 65 73 74 2d 64 61 74 20 20 28 72 6d 74 3a 67 65 est-dat (rmt:ge
5860: 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 t-test-info-by-i
5870: 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 d run-id test-id
5880: 29 29 0a 09 20 28 73 74 65 70 73 2d 64 61 74 20 )).. (steps-dat
5890: 28 72 6d 74 3a 67 65 74 2d 73 74 65 70 73 2d 66 (rmt:get-steps-f
58a0: 6f 72 2d 74 65 73 74 20 72 75 6e 2d 69 64 20 74 or-test run-id t
58b0: 65 73 74 2d 69 64 29 29 0a 09 20 28 74 65 73 74 est-id)).. (test
58c0: 2d 6e 61 6d 65 20 28 64 62 3a 74 65 73 74 2d 67 -name (db:test-g
58d0: 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 et-testname test
58e0: 2d 64 61 74 29 29 0a 09 20 28 69 74 65 6d 2d 70 -dat)).. (item-p
58f0: 61 74 68 20 28 64 62 3a 74 65 73 74 2d 67 65 74 ath (db:test-get
5900: 2d 69 74 65 6d 2d 70 61 74 68 20 74 65 73 74 2d -item-path test-
5910: 64 61 74 29 29 0a 09 20 28 66 75 6c 6c 2d 6e 61 dat)).. (full-na
5920: 6d 65 20 28 64 62 3a 74 65 73 74 2d 6d 61 6b 65 me (db:test-make
5930: 2d 66 75 6c 6c 2d 6e 61 6d 65 20 74 65 73 74 2d -full-name test-
5940: 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 name item-path))
5950: 0a 09 20 28 6f 75 70 20 20 20 20 20 20 20 28 6f .. (oup (o
5960: 70 65 6e 2d 6f 75 74 70 75 74 2d 66 69 6c 65 20 pen-output-file
5970: 28 63 6f 6e 63 20 28 64 62 3a 74 65 73 74 2d 67 (conc (db:test-g
5980: 65 74 2d 72 75 6e 64 69 72 20 74 65 73 74 2d 64 et-rundir test-d
5990: 61 74 29 20 22 2f 74 65 73 74 2d 73 75 6d 6d 61 at) "/test-summa
59a0: 72 79 2e 68 74 6d 6c 22 29 29 29 0a 09 20 28 73 ry.html"))).. (s
59b0: 74 61 74 75 73 20 20 20 20 28 64 62 3a 74 65 73 tatus (db:tes
59c0: 74 2d 67 65 74 2d 73 74 61 74 75 73 20 20 20 74 t-get-status t
59d0: 65 73 74 2d 64 61 74 29 29 0a 09 20 28 63 6f 6c est-dat)).. (col
59e0: 6f 72 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 or (common:g
59f0: 65 74 2d 63 6f 6c 6f 72 2d 66 72 6f 6d 2d 73 74 et-color-from-st
5a00: 61 74 75 73 20 73 74 61 74 75 73 29 29 0a 09 20 atus status))..
5a10: 28 6c 6f 67 66 20 20 20 20 20 20 28 64 62 3a 74 (logf (db:t
5a20: 65 73 74 2d 67 65 74 2d 66 69 6e 61 6c 5f 6c 6f est-get-final_lo
5a30: 67 66 20 74 65 73 74 2d 64 61 74 29 29 0a 09 20 gf test-dat))..
5a40: 28 73 74 65 70 73 2d 64 61 74 20 28 74 65 73 74 (steps-dat (test
5a50: 73 3a 67 65 74 2d 63 6f 6d 70 72 65 73 73 65 64 s:get-compressed
5a60: 2d 73 74 65 70 73 20 23 66 20 72 75 6e 2d 69 64 -steps #f run-id
5a70: 20 74 65 73 74 2d 69 64 29 29 29 0a 20 20 20 20 test-id))).
5a80: 3b 3b 20 28 64 63 6f 6d 6d 6f 6e 3a 67 65 74 2d ;; (dcommon:get-
5a90: 63 6f 6d 70 72 65 73 73 65 64 2d 73 74 65 70 73 compressed-steps
5aa0: 20 23 66 20 31 20 33 30 30 34 35 29 0a 20 20 20 #f 1 30045).
5ab0: 20 3b 3b 20 28 23 28 22 77 61 73 74 69 6e 67 5f ;; (#("wasting_
5ac0: 74 69 6d 65 22 20 22 32 33 3a 33 36 3a 31 33 22 time" "23:36:13"
5ad0: 20 22 32 33 3a 33 36 3a 32 31 22 20 22 30 22 20 "23:36:21" "0"
5ae0: 22 38 2e 30 73 22 20 22 77 61 73 74 69 6e 67 5f "8.0s" "wasting_
5af0: 74 69 6d 65 2e 6c 6f 67 22 29 29 0a 0a 20 20 20 time.log"))..
5b00: 20 28 73 3a 6f 75 74 70 75 74 2d 6e 65 77 0a 20 (s:output-new.
5b10: 20 20 20 20 6f 75 70 0a 20 20 20 20 20 28 73 3a oup. (s:
5b20: 68 74 6d 6c 0a 20 20 20 20 20 20 28 73 3a 74 69 html. (s:ti
5b30: 74 6c 65 20 22 53 75 6d 6d 61 72 79 20 66 6f 72 tle "Summary for
5b40: 20 22 20 66 75 6c 6c 2d 6e 61 6d 65 29 0a 20 20 " full-name).
5b50: 20 20 20 20 28 73 3a 62 6f 64 79 20 0a 20 20 20 (s:body .
5b60: 20 20 20 20 28 73 3a 68 32 20 22 53 75 6d 6d 61 (s:h2 "Summa
5b70: 72 79 20 66 6f 72 20 22 20 66 75 6c 6c 2d 6e 61 ry for " full-na
5b80: 6d 65 29 0a 20 20 20 20 20 20 20 28 73 3a 74 61 me). (s:ta
5b90: 62 6c 65 20 27 63 65 6c 6c 73 70 61 63 69 6e 67 ble 'cellspacing
5ba0: 20 22 30 22 20 27 62 6f 72 64 65 72 20 22 31 22 "0" 'border "1"
5bb0: 0a 09 28 73 3a 74 72 20 28 73 3a 74 64 20 22 72 ..(s:tr (s:td "r
5bc0: 75 6e 20 69 64 22 29 20 20 20 28 73 3a 74 64 20 un id") (s:td
5bd0: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e (db:test-get-run
5be0: 5f 69 64 20 20 20 74 65 73 74 2d 64 61 74 29 29 _id test-dat))
5bf0: 0a 09 20 20 20 20 20 20 28 73 3a 74 64 20 22 74 .. (s:td "t
5c00: 65 73 74 20 69 64 22 29 20 20 28 73 3a 74 64 20 est id") (s:td
5c10: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 (db:test-get-id
5c20: 20 20 20 20 20 20 74 65 73 74 2d 64 61 74 29 29 test-dat))
5c30: 29 0a 09 28 73 3a 74 72 20 28 73 3a 74 64 20 22 )..(s:tr (s:td "
5c40: 74 65 73 74 6e 61 6d 65 22 29 20 28 73 3a 74 64 testname") (s:td
5c50: 20 74 65 73 74 2d 6e 61 6d 65 29 0a 09 20 20 20 test-name)..
5c60: 20 20 20 28 73 3a 74 64 20 22 69 74 65 6d 70 61 (s:td "itempa
5c70: 74 68 22 29 20 28 73 3a 74 64 20 69 74 65 6d 2d th") (s:td item-
5c80: 70 61 74 68 29 29 0a 09 28 73 3a 74 72 20 28 73 path))..(s:tr (s
5c90: 3a 74 64 20 22 73 74 61 74 65 22 29 20 20 20 20 :td "state")
5ca0: 28 73 3a 74 64 20 28 64 62 3a 74 65 73 74 2d 67 (s:td (db:test-g
5cb0: 65 74 2d 73 74 61 74 65 20 20 20 20 74 65 73 74 et-state test
5cc0: 2d 64 61 74 29 29 0a 09 20 20 20 20 20 20 28 73 -dat)).. (s
5cd0: 3a 74 64 20 22 73 74 61 74 75 73 22 29 20 20 20 :td "status")
5ce0: 28 73 3a 74 64 20 28 73 3a 61 20 27 68 72 65 66 (s:td (s:a 'href
5cf0: 20 6c 6f 67 66 20 28 73 3a 66 6f 6e 74 20 27 63 logf (s:font 'c
5d00: 6f 6c 6f 72 20 63 6f 6c 6f 72 20 73 74 61 74 75 olor color statu
5d10: 73 29 29 29 29 0a 09 28 73 3a 74 72 20 28 73 3a s))))..(s:tr (s:
5d20: 74 64 20 22 54 65 73 74 44 61 74 65 22 29 20 28 td "TestDate") (
5d30: 73 3a 74 64 20 28 73 65 63 6f 6e 64 73 2d 3e 77 s:td (seconds->w
5d40: 6f 72 6b 2d 77 65 65 6b 2f 64 61 79 2d 74 69 6d ork-week/day-tim
5d50: 65 20 0a 09 09 09 09 20 20 20 20 20 20 20 28 64 e ..... (d
5d60: 62 3a 74 65 73 74 2d 67 65 74 2d 65 76 65 6e 74 b:test-get-event
5d70: 5f 74 69 6d 65 20 74 65 73 74 2d 64 61 74 29 29 _time test-dat))
5d80: 29 0a 09 20 20 20 20 20 20 28 73 3a 74 64 20 22 ).. (s:td "
5d90: 44 75 72 61 74 69 6f 6e 22 29 20 28 73 3a 74 64 Duration") (s:td
5da0: 20 28 73 65 63 6f 6e 64 73 2d 3e 68 72 2d 6d 69 (seconds->hr-mi
5db0: 6e 2d 73 65 63 20 28 64 62 3a 74 65 73 74 2d 67 n-sec (db:test-g
5dc0: 65 74 2d 72 75 6e 5f 64 75 72 61 74 69 6f 6e 20 et-run_duration
5dd0: 74 65 73 74 2d 64 61 74 29 29 29 29 29 0a 20 20 test-dat))))).
5de0: 20 20 20 20 20 28 73 3a 68 33 20 22 4c 6f 67 20 (s:h3 "Log
5df0: 66 69 6c 65 73 22 29 0a 20 20 20 20 20 20 20 28 files"). (
5e00: 73 3a 74 61 62 6c 65 0a 09 27 63 65 6c 6c 73 70 s:table..'cellsp
5e10: 61 63 69 6e 67 20 22 30 22 20 27 62 6f 72 64 65 acing "0" 'borde
5e20: 72 20 22 31 22 0a 09 28 73 3a 74 72 20 28 73 3a r "1"..(s:tr (s:
5e30: 74 64 20 22 46 69 6e 61 6c 20 6c 6f 67 22 29 28 td "Final log")(
5e40: 73 3a 74 64 20 28 73 3a 61 20 27 68 72 65 66 20 s:td (s:a 'href
5e50: 6c 6f 67 66 20 6c 6f 67 66 29 29 29 29 0a 20 20 logf logf)))).
5e60: 20 20 20 20 20 28 73 3a 74 61 62 6c 65 0a 09 27 (s:table..'
5e70: 63 65 6c 6c 73 70 61 63 69 6e 67 20 22 30 22 20 cellspacing "0"
5e80: 27 62 6f 72 64 65 72 20 22 31 22 0a 09 28 73 3a 'border "1"..(s:
5e90: 74 72 20 28 73 3a 74 64 20 22 53 74 65 70 20 4e tr (s:td "Step N
5ea0: 61 6d 65 22 29 28 73 3a 74 64 20 22 53 74 61 72 ame")(s:td "Star
5eb0: 74 22 29 28 73 3a 74 64 20 22 45 6e 64 22 29 28 t")(s:td "End")(
5ec0: 73 3a 74 64 20 22 53 74 61 74 75 73 22 29 28 73 s:td "Status")(s
5ed0: 3a 74 64 20 22 44 75 72 61 74 69 6f 6e 22 29 28 :td "Duration")(
5ee0: 73 3a 74 64 20 22 4c 6f 67 20 46 69 6c 65 22 29 s:td "Log File")
5ef0: 29 0a 09 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 )..(map (lambda
5f00: 28 73 74 65 70 2d 64 61 74 29 0a 09 20 20 20 20 (step-dat)..
5f10: 20 20 20 28 73 3a 74 72 20 28 73 3a 74 64 20 28 (s:tr (s:td (
5f20: 74 64 62 3a 73 74 65 70 73 2d 74 61 62 6c 65 2d tdb:steps-table-
5f30: 67 65 74 2d 73 74 65 70 6e 61 6d 65 20 73 74 65 get-stepname ste
5f40: 70 2d 64 61 74 29 29 0a 09 09 20 20 20 20 20 28 p-dat))... (
5f50: 73 3a 74 64 20 28 74 64 62 3a 73 74 65 70 73 2d s:td (tdb:steps-
5f60: 74 61 62 6c 65 2d 67 65 74 2d 73 74 61 72 74 20 table-get-start
5f70: 20 20 20 73 74 65 70 2d 64 61 74 29 29 0a 09 09 step-dat))...
5f80: 20 20 20 20 20 28 73 3a 74 64 20 28 74 64 62 3a (s:td (tdb:
5f90: 73 74 65 70 73 2d 74 61 62 6c 65 2d 67 65 74 2d steps-table-get-
5fa0: 65 6e 64 20 20 20 20 20 20 73 74 65 70 2d 64 61 end step-da
5fb0: 74 29 29 0a 09 09 20 20 20 20 20 28 73 3a 74 64 t))... (s:td
5fc0: 20 28 74 64 62 3a 73 74 65 70 73 2d 74 61 62 6c (tdb:steps-tabl
5fd0: 65 2d 67 65 74 2d 73 74 61 74 75 73 20 20 20 73 e-get-status s
5fe0: 74 65 70 2d 64 61 74 29 29 0a 09 09 20 20 20 20 tep-dat))...
5ff0: 20 28 73 3a 74 64 20 28 74 64 62 3a 73 74 65 70 (s:td (tdb:step
6000: 73 2d 74 61 62 6c 65 2d 67 65 74 2d 72 75 6e 74 s-table-get-runt
6010: 69 6d 65 20 20 73 74 65 70 2d 64 61 74 29 29 0a ime step-dat)).
6020: 09 09 20 20 20 20 20 28 73 3a 74 64 20 28 6c 65 .. (s:td (le
6030: 74 20 28 28 73 74 65 70 2d 6c 6f 67 20 28 74 64 t ((step-log (td
6040: 62 3a 73 74 65 70 73 2d 74 61 62 6c 65 2d 67 65 b:steps-table-ge
6050: 74 2d 6c 6f 67 2d 66 69 6c 65 20 73 74 65 70 2d t-log-file step-
6060: 64 61 74 29 29 29 0a 09 09 09 20 20 20 20 20 28 dat))).... (
6070: 73 3a 61 20 27 68 72 65 66 20 73 74 65 70 2d 6c s:a 'href step-l
6080: 6f 67 20 73 74 65 70 2d 6c 6f 67 29 29 29 29 29 og step-log)))))
6090: 0a 09 20 20 20 20 20 73 74 65 70 73 2d 64 61 74 .. steps-dat
60a0: 29 29 0a 09 29 29 29 0a 20 20 20 20 28 63 6c 6f ))..))). (clo
60b0: 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 6f se-output-port o
60c0: 75 70 29 29 29 0a 09 20 20 0a 09 20 20 0a 3b 3b up))).. .. .;;
60d0: 20 4d 55 53 54 20 42 45 20 43 41 4c 4c 45 44 20 MUST BE CALLED
60e0: 6c 6f 63 61 6c 21 0a 3b 3b 0a 28 64 65 66 69 6e local!.;;.(defin
60f0: 65 20 28 74 65 73 74 73 3a 74 65 73 74 2d 67 65 e (tests:test-ge
6100: 74 2d 70 61 74 68 73 2d 6d 61 74 63 68 69 6e 67 t-paths-matching
6110: 20 6b 65 79 6e 61 6d 65 73 20 74 61 72 67 65 74 keynames target
6120: 20 66 6e 61 6d 65 70 61 74 74 20 23 21 6b 65 79 fnamepatt #!key
6130: 20 28 72 65 73 20 27 28 29 29 29 0a 20 20 3b 3b (res '())). ;;
6140: 20 42 55 47 3a 20 4d 6f 76 65 20 74 68 65 20 76 BUG: Move the v
6150: 61 6c 75 65 73 20 64 65 72 69 76 65 64 20 66 72 alues derived fr
6160: 6f 6d 20 61 72 67 73 20 74 6f 20 70 61 72 61 6d om args to param
6170: 65 74 65 72 73 20 61 6e 64 20 70 75 73 68 20 74 eters and push t
6180: 6f 20 6d 65 67 61 74 65 73 74 2e 73 63 6d 0a 20 o megatest.scm.
6190: 20 28 6c 65 74 2a 20 28 28 74 65 73 74 70 61 74 (let* ((testpat
61a0: 74 20 20 20 28 69 66 20 28 61 72 67 73 3a 67 65 t (if (args:ge
61b0: 74 2d 61 72 67 20 22 2d 74 65 73 74 70 61 74 74 t-arg "-testpatt
61c0: 22 29 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 ")(args:get-arg
61d0: 22 2d 74 65 73 74 70 61 74 74 22 29 20 22 25 22 "-testpatt") "%"
61e0: 29 29 0a 09 20 28 73 74 61 74 65 70 61 74 74 20 )).. (statepatt
61f0: 20 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d 61 (if (args:get-a
6200: 72 67 20 22 3a 73 74 61 74 65 22 29 20 20 20 28 rg ":state") (
6210: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 3a 73 args:get-arg ":s
6220: 74 61 74 65 22 29 20 20 20 20 22 25 22 29 29 0a tate") "%")).
6230: 09 20 28 73 74 61 74 75 73 70 61 74 74 20 28 69 . (statuspatt (i
6240: 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 f (args:get-arg
6250: 22 3a 73 74 61 74 75 73 22 29 20 20 28 61 72 67 ":status") (arg
6260: 73 3a 67 65 74 2d 61 72 67 20 22 3a 73 74 61 74 s:get-arg ":stat
6270: 75 73 22 29 20 20 20 22 25 22 29 29 0a 09 20 28 us") "%")).. (
6280: 72 75 6e 6e 61 6d 65 20 20 20 20 28 69 66 20 28 runname (if (
6290: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 3a 72 args:get-arg ":r
62a0: 75 6e 6e 61 6d 65 22 29 20 28 61 72 67 73 3a 67 unname") (args:g
62b0: 65 74 2d 61 72 67 20 22 3a 72 75 6e 6e 61 6d 65 et-arg ":runname
62c0: 22 29 20 20 22 25 22 29 29 0a 09 20 28 70 61 74 ") "%")).. (pat
62d0: 68 73 2d 66 72 6f 6d 2d 64 62 20 28 72 6d 74 3a hs-from-db (rmt:
62e0: 74 65 73 74 2d 67 65 74 2d 70 61 74 68 73 2d 6d test-get-paths-m
62f0: 61 74 63 68 69 6e 67 2d 6b 65 79 6e 61 6d 65 73 atching-keynames
6300: 2d 74 61 72 67 65 74 2d 6e 65 77 20 6b 65 79 6e -target-new keyn
6310: 61 6d 65 73 20 74 61 72 67 65 74 20 72 65 73 0a ames target res.
6320: 09 09 09 09 09 74 65 73 74 70 61 74 74 0a 09 09 .....testpatt...
6330: 09 09 09 73 74 61 74 65 70 61 74 74 0a 09 09 09 ...statepatt....
6340: 09 09 73 74 61 74 75 73 70 61 74 74 0a 09 09 09 ..statuspatt....
6350: 09 09 72 75 6e 6e 61 6d 65 29 29 29 0a 20 20 20 ..runname))).
6360: 20 28 69 66 20 66 6e 61 6d 65 70 61 74 74 0a 09 (if fnamepatt..
6370: 28 61 70 70 6c 79 20 61 70 70 65 6e 64 20 0a 09 (apply append ..
6380: 20 20 20 20 20 20 20 28 6d 61 70 20 28 6c 61 6d (map (lam
6390: 62 64 61 20 28 70 29 0a 09 09 20 20 20 20 20 20 bda (p)...
63a0: 28 69 66 20 28 64 69 72 65 63 74 6f 72 79 2d 65 (if (directory-e
63b0: 78 69 73 74 73 3f 20 70 29 0a 09 09 09 20 20 28 xists? p).... (
63c0: 67 6c 6f 62 20 28 63 6f 6e 63 20 70 20 22 2f 22 glob (conc p "/"
63d0: 20 66 6e 61 6d 65 70 61 74 74 29 29 0a 09 09 09 fnamepatt))....
63e0: 20 20 27 28 29 29 29 0a 09 09 20 20 20 20 70 61 '()))... pa
63f0: 74 68 73 2d 66 72 6f 6d 2d 64 62 29 29 0a 09 70 ths-from-db))..p
6400: 61 74 68 73 2d 66 72 6f 6d 2d 64 62 29 29 29 0a aths-from-db))).
6410: 0a 09 09 09 20 20 20 20 20 20 0a 3b 3b 3d 3d 3d .... .;;===
6420: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6430: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6440: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6450: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6460: 3d 3d 3d 0a 3b 3b 20 47 61 74 68 65 72 20 64 61 ===.;; Gather da
6470: 74 61 20 66 72 6f 6d 20 74 65 73 74 2f 74 61 73 ta from test/tas
6480: 6b 20 73 70 65 63 69 66 69 63 61 74 69 6f 6e 73 k specifications
6490: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
64a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
64b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
64c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
64d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 28 64 =========..;; (d
64e0: 65 66 69 6e 65 20 28 74 65 73 74 73 3a 67 65 74 efine (tests:get
64f0: 2d 76 61 6c 69 64 2d 74 65 73 74 73 20 74 65 73 -valid-tests tes
6500: 74 73 64 69 72 20 74 65 73 74 2d 70 61 74 74 73 tsdir test-patts
6510: 29 20 3b 3b 20 20 23 21 6b 65 79 20 28 74 65 73 ) ;; #!key (tes
6520: 74 2d 6e 61 6d 65 73 20 27 28 29 29 29 0a 3b 3b t-names '())).;;
6530: 20 20 20 28 6c 65 74 20 28 28 74 65 73 74 73 20 (let ((tests
6540: 28 67 6c 6f 62 20 28 63 6f 6e 63 20 74 65 73 74 (glob (conc test
6550: 73 64 69 72 20 22 2f 74 65 73 74 73 2f 2a 22 29 sdir "/tests/*")
6560: 29 29 29 20 3b 3b 20 22 20 28 73 74 72 69 6e 67 ))) ;; " (string
6570: 2d 74 72 61 6e 73 6c 61 74 65 20 70 61 74 74 20 -translate patt
6580: 22 25 22 20 22 2a 22 29 29 29 29 29 0a 3b 3b 20 "%" "*"))))).;;
6590: 20 20 20 20 28 73 65 74 21 20 74 65 73 74 73 20 (set! tests
65a0: 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 (filter (lambda
65b0: 28 74 65 73 74 29 28 66 69 6c 65 2d 65 78 69 73 (test)(file-exis
65c0: 74 73 3f 20 28 63 6f 6e 63 20 74 65 73 74 20 22 ts? (conc test "
65d0: 2f 74 65 73 74 63 6f 6e 66 69 67 22 29 29 29 20 /testconfig")))
65e0: 74 65 73 74 73 29 29 0a 3b 3b 20 20 20 20 20 28 tests)).;; (
65f0: 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 74 65 delete-duplicate
6600: 73 0a 3b 3b 20 20 20 20 20 20 28 66 69 6c 74 65 s.;; (filte
6610: 72 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 6e r (lambda (testn
6620: 61 6d 65 29 0a 3b 3b 20 09 20 20 20 20 20 20 20 ame).;; .
6630: 28 74 65 73 74 73 3a 6d 61 74 63 68 20 74 65 73 (tests:match tes
6640: 74 2d 70 61 74 74 73 20 74 65 73 74 6e 61 6d 65 t-patts testname
6650: 20 23 66 29 29 0a 3b 3b 20 09 20 20 20 20 20 28 #f)).;; . (
6660: 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 74 65 73 map (lambda (tes
6670: 74 70 29 0a 3b 3b 20 09 09 20 20 20 20 28 6c 61 tp).;; .. (la
6680: 73 74 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 st (string-split
6690: 20 74 65 73 74 70 20 22 2f 22 29 29 29 0a 3b 3b testp "/"))).;;
66a0: 20 09 09 20 20 74 65 73 74 73 29 29 29 29 29 0a .. tests))))).
66b0: 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 ..(define (tests
66c0: 3a 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 :get-testconfig
66d0: 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 72 test-name test-r
66e0: 65 67 69 73 74 72 79 20 73 79 73 74 65 6d 2d 61 egistry system-a
66f0: 6c 6c 6f 77 65 64 29 0a 20 20 28 6c 65 74 2a 20 llowed). (let*
6700: 28 28 74 65 73 74 2d 70 61 74 68 20 20 20 20 28 ((test-path (
6710: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
6720: 65 66 61 75 6c 74 20 74 65 73 74 2d 72 65 67 69 efault test-regi
6730: 73 74 72 79 20 74 65 73 74 2d 6e 61 6d 65 20 28 stry test-name (
6740: 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 conc *toppath* "
6750: 2f 74 65 73 74 73 2f 22 20 74 65 73 74 2d 6e 61 /tests/" test-na
6760: 6d 65 29 29 29 0a 09 20 28 74 65 73 74 2d 63 6f me))).. (test-co
6770: 6e 66 69 67 66 20 28 63 6f 6e 63 20 74 65 73 74 nfigf (conc test
6780: 2d 70 61 74 68 20 22 2f 74 65 73 74 63 6f 6e 66 -path "/testconf
6790: 69 67 22 29 29 0a 09 20 28 74 65 73 74 65 78 69 ig")).. (testexi
67a0: 73 74 73 20 20 20 28 61 6e 64 20 28 66 69 6c 65 sts (and (file
67b0: 2d 65 78 69 73 74 73 3f 20 74 65 73 74 2d 63 6f -exists? test-co
67c0: 6e 66 69 67 66 29 28 66 69 6c 65 2d 72 65 61 64 nfigf)(file-read
67d0: 2d 61 63 63 65 73 73 3f 20 74 65 73 74 2d 63 6f -access? test-co
67e0: 6e 66 69 67 66 29 29 29 0a 09 20 28 74 63 66 67 nfigf))).. (tcfg
67f0: 20 20 20 20 20 20 20 20 20 28 69 66 20 74 65 73 (if tes
6800: 74 65 78 69 73 74 73 0a 09 09 09 20 20 20 28 72 texists.... (r
6810: 65 61 64 2d 63 6f 6e 66 69 67 20 74 65 73 74 2d ead-config test-
6820: 63 6f 6e 66 69 67 66 20 23 66 20 73 79 73 74 65 configf #f syste
6830: 6d 2d 61 6c 6c 6f 77 65 64 20 65 6e 76 69 72 6f m-allowed enviro
6840: 6e 2d 70 61 74 74 3a 20 28 69 66 20 73 79 73 74 n-patt: (if syst
6850: 65 6d 2d 61 6c 6c 6f 77 65 64 0a 09 09 09 09 09 em-allowed......
6860: 09 09 09 09 09 09 20 22 70 72 65 2d 6c 61 75 6e ...... "pre-laun
6870: 63 68 2d 65 6e 76 2d 76 61 72 73 22 0a 09 09 09 ch-env-vars"....
6880: 09 09 09 09 09 09 09 09 20 23 66 29 29 0a 09 09 ........ #f))...
6890: 09 20 20 20 23 66 29 29 29 0a 20 20 20 20 28 68 . #f))). (h
68a0: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a ash-table-set! *
68b0: 74 65 73 74 63 6f 6e 66 69 67 73 2a 20 74 65 73 testconfigs* tes
68c0: 74 2d 6e 61 6d 65 20 74 63 66 67 29 0a 20 20 20 t-name tcfg).
68d0: 20 74 63 66 67 29 29 0a 20 20 0a 3b 3b 20 73 6f tcfg)). .;; so
68e0: 72 74 20 74 65 73 74 73 20 62 79 20 70 72 69 6f rt tests by prio
68f0: 72 69 74 79 20 61 6e 64 20 77 61 69 74 6f 6e 0a rity and waiton.
6900: 3b 3b 20 4d 6f 76 65 20 74 65 73 74 20 73 70 65 ;; Move test spe
6910: 63 69 66 69 63 20 73 74 75 66 66 20 74 6f 20 61 cific stuff to a
6920: 20 74 65 73 74 20 75 6e 69 74 20 46 49 58 4d 45 test unit FIXME
6930: 20 6f 6e 65 20 6f 66 20 74 68 65 73 65 20 64 61 one of these da
6940: 79 73 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 ys.(define (test
6950: 73 3a 73 6f 72 74 2d 62 79 2d 70 72 69 6f 72 69 s:sort-by-priori
6960: 74 79 2d 61 6e 64 2d 77 61 69 74 6f 6e 20 74 65 ty-and-waiton te
6970: 73 74 2d 72 65 63 6f 72 64 73 29 0a 20 20 28 6c st-records). (l
6980: 65 74 20 28 28 6d 75 6e 67 65 70 72 69 6f 72 69 et ((mungepriori
6990: 74 79 20 28 6c 61 6d 62 64 61 20 28 70 72 69 6f ty (lambda (prio
69a0: 72 69 74 79 29 0a 09 09 09 20 28 69 66 20 70 72 rity).... (if pr
69b0: 69 6f 72 69 74 79 0a 09 09 09 20 20 20 20 20 28 iority.... (
69c0: 6c 65 74 20 28 28 74 6d 70 20 28 61 6e 79 2d 3e let ((tmp (any->
69d0: 6e 75 6d 62 65 72 20 70 72 69 6f 72 69 74 79 29 number priority)
69e0: 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 69 66 )).... (if
69f0: 20 74 6d 70 20 74 6d 70 20 28 62 65 67 69 6e 20 tmp tmp (begin
6a00: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
6a10: 45 52 52 4f 52 3a 20 62 61 64 20 70 72 69 6f 72 ERROR: bad prior
6a20: 69 74 79 20 76 61 6c 75 65 20 22 20 70 72 69 6f ity value " prio
6a30: 72 69 74 79 20 22 2c 20 75 73 69 6e 67 20 30 22 rity ", using 0"
6a40: 29 20 30 29 29 29 0a 09 09 09 20 20 20 20 20 30 ) 0))).... 0
6a50: 29 29 29 29 0a 20 20 20 20 28 73 6f 72 74 20 0a )))). (sort .
6a60: 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
6a70: 2d 6b 65 79 73 20 74 65 73 74 2d 72 65 63 6f 72 -keys test-recor
6a80: 64 73 29 20 3b 3b 20 61 76 6f 69 64 20 64 65 61 ds) ;; avoid dea
6a90: 6c 69 6e 67 20 77 69 74 68 20 64 65 6c 65 74 65 ling with delete
6aa0: 64 20 74 65 73 74 73 2c 20 6c 6f 6f 6b 20 61 74 d tests, look at
6ab0: 20 74 68 65 20 68 61 73 68 20 74 61 62 6c 65 0a the hash table.
6ac0: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 61 20 (lambda (a
6ad0: 62 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 b). (let*
6ae0: 28 28 61 2d 72 65 63 6f 72 64 20 20 20 28 68 61 ((a-record (ha
6af0: 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 74 65 73 sh-table-ref tes
6b00: 74 2d 72 65 63 6f 72 64 73 20 61 29 29 0a 09 20 t-records a))..
6b10: 20 20 20 20 20 28 62 2d 72 65 63 6f 72 64 20 20 (b-record
6b20: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
6b30: 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 62 29 test-records b)
6b40: 29 0a 09 20 20 20 20 20 20 28 61 2d 77 61 69 74 ).. (a-wait
6b50: 6f 6e 73 20 20 28 74 65 73 74 73 3a 74 65 73 74 ons (tests:test
6b60: 71 75 65 75 65 2d 67 65 74 2d 77 61 69 74 6f 6e queue-get-waiton
6b70: 73 20 61 2d 72 65 63 6f 72 64 29 29 0a 09 20 20 s a-record))..
6b80: 20 20 20 20 28 62 2d 77 61 69 74 6f 6e 73 20 20 (b-waitons
6b90: 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 (tests:testqueue
6ba0: 2d 67 65 74 2d 77 61 69 74 6f 6e 73 20 62 2d 72 -get-waitons b-r
6bb0: 65 63 6f 72 64 29 29 0a 09 20 20 20 20 20 20 28 ecord)).. (
6bc0: 61 2d 63 6f 6e 66 69 67 20 20 20 28 74 65 73 74 a-config (test
6bd0: 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d s:testqueue-get-
6be0: 74 65 73 74 63 6f 6e 66 69 67 20 20 61 2d 72 65 testconfig a-re
6bf0: 63 6f 72 64 29 29 0a 09 20 20 20 20 20 20 28 62 cord)).. (b
6c00: 2d 63 6f 6e 66 69 67 20 20 20 28 74 65 73 74 73 -config (tests
6c10: 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 74 :testqueue-get-t
6c20: 65 73 74 63 6f 6e 66 69 67 20 20 62 2d 72 65 63 estconfig b-rec
6c30: 6f 72 64 29 29 0a 09 20 20 20 20 20 20 28 61 2d ord)).. (a-
6c40: 72 61 77 2d 70 72 69 20 20 28 63 6f 6e 66 69 67 raw-pri (config
6c50: 2d 6c 6f 6f 6b 75 70 20 61 2d 63 6f 6e 66 69 67 -lookup a-config
6c60: 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 22 20 "requirements"
6c70: 22 70 72 69 6f 72 69 74 79 22 29 29 0a 09 20 20 "priority"))..
6c80: 20 20 20 20 28 62 2d 72 61 77 2d 70 72 69 20 20 (b-raw-pri
6c90: 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 62 (config-lookup b
6ca0: 2d 63 6f 6e 66 69 67 20 22 72 65 71 75 69 72 65 -config "require
6cb0: 6d 65 6e 74 73 22 20 22 70 72 69 6f 72 69 74 79 ments" "priority
6cc0: 22 29 29 0a 09 20 20 20 20 20 20 28 61 2d 70 72 ")).. (a-pr
6cd0: 69 6f 72 69 74 79 20 28 6d 75 6e 67 65 70 72 69 iority (mungepri
6ce0: 6f 72 69 74 79 20 61 2d 72 61 77 2d 70 72 69 29 ority a-raw-pri)
6cf0: 29 0a 09 20 20 20 20 20 20 28 62 2d 70 72 69 6f ).. (b-prio
6d00: 72 69 74 79 20 28 6d 75 6e 67 65 70 72 69 6f 72 rity (mungeprior
6d10: 69 74 79 20 62 2d 72 61 77 2d 70 72 69 29 29 29 ity b-raw-pri)))
6d20: 0a 09 3b 3b 20 20 28 64 65 62 75 67 3a 70 72 69 ..;; (debug:pri
6d30: 6e 74 20 35 20 22 73 6f 72 74 2d 62 79 2d 70 72 nt 5 "sort-by-pr
6d40: 69 6f 72 69 74 79 2d 61 6e 64 2d 77 61 69 74 6f iority-and-waito
6d50: 6e 2c 20 61 3a 20 22 20 61 20 22 20 62 3a 20 22 n, a: " a " b: "
6d60: 20 62 0a 09 3b 3b 20 09 20 20 20 20 20 20 22 5c b..;; . "\
6d70: 6e 20 20 20 20 20 61 2d 72 65 63 6f 72 64 3a 20 n a-record:
6d80: 20 20 22 20 61 2d 72 65 63 6f 72 64 20 0a 09 3b " a-record ..;
6d90: 3b 20 09 20 20 20 20 20 20 22 5c 6e 20 20 20 20 ; . "\n
6da0: 20 62 2d 72 65 63 6f 72 64 3a 20 20 20 22 20 62 b-record: " b
6db0: 2d 72 65 63 6f 72 64 0a 09 3b 3b 20 09 20 20 20 -record..;; .
6dc0: 20 20 20 22 5c 6e 20 20 20 20 20 61 2d 77 61 69 "\n a-wai
6dd0: 74 6f 6e 73 3a 20 20 22 20 61 2d 77 61 69 74 6f tons: " a-waito
6de0: 6e 73 0a 09 3b 3b 20 09 20 20 20 20 20 20 22 5c ns..;; . "\
6df0: 6e 20 20 20 20 20 62 2d 77 61 69 74 6f 6e 73 3a n b-waitons:
6e00: 20 20 22 20 62 2d 77 61 69 74 6f 6e 73 0a 09 3b " b-waitons..;
6e10: 3b 20 09 20 20 20 20 20 20 22 5c 6e 20 20 20 20 ; . "\n
6e20: 20 61 2d 63 6f 6e 66 69 67 3a 20 20 20 22 20 28 a-config: " (
6e30: 68 61 73 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 hash-table->alis
6e40: 74 20 61 2d 63 6f 6e 66 69 67 29 0a 09 3b 3b 20 t a-config)..;;
6e50: 09 20 20 20 20 20 20 22 5c 6e 20 20 20 20 20 62 . "\n b
6e60: 2d 63 6f 6e 66 69 67 3a 20 20 20 22 20 28 68 61 -config: " (ha
6e70: 73 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 20 sh-table->alist
6e80: 62 2d 63 6f 6e 66 69 67 29 0a 09 3b 3b 20 09 20 b-config)..;; .
6e90: 20 20 20 20 20 22 5c 6e 20 20 20 20 20 61 2d 72 "\n a-r
6ea0: 61 77 2d 70 72 69 3a 20 20 22 20 61 2d 72 61 77 aw-pri: " a-raw
6eb0: 2d 70 72 69 0a 09 3b 3b 20 09 20 20 20 20 20 20 -pri..;; .
6ec0: 22 5c 6e 20 20 20 20 20 62 2d 72 61 77 2d 70 72 "\n b-raw-pr
6ed0: 69 3a 20 20 22 20 62 2d 72 61 77 2d 70 72 69 0a i: " b-raw-pri.
6ee0: 09 3b 3b 20 09 20 20 20 20 20 20 22 5c 6e 20 20 .;; . "\n
6ef0: 20 20 20 61 2d 70 72 69 6f 72 69 74 79 3a 20 22 a-priority: "
6f00: 20 61 2d 70 72 69 6f 72 69 74 79 0a 09 3b 3b 20 a-priority..;;
6f10: 09 20 20 20 20 20 20 22 5c 6e 20 20 20 20 20 62 . "\n b
6f20: 2d 70 72 69 6f 72 69 74 79 3a 20 22 20 62 2d 70 -priority: " b-p
6f30: 72 69 6f 72 69 74 79 29 0a 09 20 28 74 65 73 74 riority).. (test
6f40: 73 3a 74 65 73 74 71 75 65 75 65 2d 73 65 74 2d s:testqueue-set-
6f50: 70 72 69 6f 72 69 74 79 21 20 61 2d 72 65 63 6f priority! a-reco
6f60: 72 64 20 61 2d 70 72 69 6f 72 69 74 79 29 0a 09 rd a-priority)..
6f70: 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 (tests:testqueu
6f80: 65 2d 73 65 74 2d 70 72 69 6f 72 69 74 79 21 20 e-set-priority!
6f90: 62 2d 72 65 63 6f 72 64 20 62 2d 70 72 69 6f 72 b-record b-prior
6fa0: 69 74 79 29 0a 09 20 28 69 66 20 28 61 6e 64 20 ity).. (if (and
6fb0: 61 2d 77 61 69 74 6f 6e 73 20 28 6d 65 6d 62 65 a-waitons (membe
6fc0: 72 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 r (tests:testque
6fd0: 75 65 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 ue-get-testname
6fe0: 62 2d 72 65 63 6f 72 64 29 20 61 2d 77 61 69 74 b-record) a-wait
6ff0: 6f 6e 73 29 29 0a 09 20 20 20 20 20 23 66 20 3b ons)).. #f ;
7000: 3b 20 63 61 6e 6e 6f 74 20 68 61 76 65 20 61 20 ; cannot have a
7010: 77 68 69 63 68 20 69 73 20 77 61 69 74 69 6e 67 which is waiting
7020: 20 6f 6e 20 62 20 68 61 70 70 65 6e 69 6e 67 20 on b happening
7030: 62 65 66 6f 72 65 20 62 0a 09 20 20 20 20 20 28 before b.. (
7040: 69 66 20 28 61 6e 64 20 62 2d 77 61 69 74 6f 6e if (and b-waiton
7050: 73 20 28 6d 65 6d 62 65 72 20 28 74 65 73 74 73 s (member (tests
7060: 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 74 :testqueue-get-t
7070: 65 73 74 6e 61 6d 65 20 61 2d 72 65 63 6f 72 64 estname a-record
7080: 29 20 62 2d 77 61 69 74 6f 6e 73 29 29 0a 09 09 ) b-waitons))...
7090: 20 23 74 20 3b 3b 20 74 68 69 73 20 69 73 20 74 #t ;; this is t
70a0: 68 65 20 63 6f 72 72 65 63 74 20 6f 72 64 65 72 he correct order
70b0: 2c 20 62 20 69 73 20 77 61 69 74 69 6e 67 20 6f , b is waiting o
70c0: 6e 20 61 20 61 6e 64 20 62 20 69 73 20 62 65 66 n a and b is bef
70d0: 6f 72 65 20 61 0a 09 09 20 28 69 66 20 28 3e 20 ore a... (if (>
70e0: 61 2d 70 72 69 6f 72 69 74 79 20 62 2d 70 72 69 a-priority b-pri
70f0: 6f 72 69 74 79 29 0a 09 09 20 20 20 20 20 23 74 ority)... #t
7100: 20 3b 3b 20 69 66 20 61 20 69 73 20 61 20 68 69 ;; if a is a hi
7110: 67 68 65 72 20 70 72 69 6f 72 69 74 79 20 74 68 gher priority th
7120: 61 6e 20 62 20 74 68 65 6e 20 77 65 20 61 72 65 an b then we are
7130: 20 67 6f 6f 64 20 74 6f 20 67 6f 0a 09 09 20 20 good to go...
7140: 20 20 20 28 73 74 72 69 6e 67 2d 63 6f 6d 70 61 (string-compa
7150: 72 65 33 20 61 20 62 29 29 29 29 29 29 29 29 29 re3 a b)))))))))
7160: 0a 0a 3b 3b 20 66 6f 72 20 65 61 63 68 20 74 65 ..;; for each te
7170: 73 74 3a 0a 3b 3b 20 20 20 0a 28 64 65 66 69 6e st:.;; .(defin
7180: 65 20 28 74 65 73 74 73 3a 66 69 6c 74 65 72 2d e (tests:filter-
7190: 6e 6f 6e 2d 72 75 6e 6e 61 62 6c 65 20 72 75 6e non-runnable run
71a0: 2d 69 64 20 74 65 73 74 6b 65 79 6e 61 6d 65 73 -id testkeynames
71b0: 20 74 65 73 74 72 65 63 6f 72 64 73 68 61 73 68 testrecordshash
71c0: 29 0a 20 20 28 6c 65 74 20 28 28 72 75 6e 6e 61 ). (let ((runna
71d0: 62 6c 65 73 20 27 28 29 29 29 0a 20 20 20 20 28 bles '())). (
71e0: 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 6c for-each. (l
71f0: 61 6d 62 64 61 20 28 74 65 73 74 6b 65 79 6e 61 ambda (testkeyna
7200: 6d 65 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a me). (let*
7210: 20 28 28 74 65 73 74 2d 72 65 63 6f 72 64 20 28 ((test-record (
7220: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 74 hash-table-ref t
7230: 65 73 74 72 65 63 6f 72 64 73 68 61 73 68 20 74 estrecordshash t
7240: 65 73 74 6b 65 79 6e 61 6d 65 29 29 0a 09 20 20 estkeyname))..
7250: 20 20 20 20 28 74 65 73 74 2d 6e 61 6d 65 20 20 (test-name
7260: 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 (tests:testqueu
7270: 65 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 20 e-get-testname
7280: 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 test-record))..
7290: 20 20 20 20 20 28 69 74 65 6d 64 61 74 20 20 20 (itemdat
72a0: 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 (tests:testque
72b0: 75 65 2d 67 65 74 2d 69 74 65 6d 64 61 74 20 20 ue-get-itemdat
72c0: 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 test-record))..
72d0: 20 20 20 20 20 20 28 69 74 65 6d 2d 70 61 74 68 (item-path
72e0: 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 (tests:testqu
72f0: 65 75 65 2d 67 65 74 2d 69 74 65 6d 5f 70 61 74 eue-get-item_pat
7300: 68 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a h test-record)).
7310: 09 20 20 20 20 20 20 28 77 61 69 74 6f 6e 73 20 . (waitons
7320: 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 (tests:testq
7330: 75 65 75 65 2d 67 65 74 2d 77 61 69 74 6f 6e 73 ueue-get-waitons
7340: 20 20 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 test-record))
7350: 0a 09 20 20 20 20 20 20 28 6b 65 65 70 2d 74 65 .. (keep-te
7360: 73 74 20 20 20 23 74 29 0a 09 20 20 20 20 20 20 st #t)..
7370: 28 74 65 73 74 2d 69 64 20 20 20 20 20 28 72 6d (test-id (rm
7380: 74 3a 67 65 74 2d 74 65 73 74 2d 69 64 20 72 75 t:get-test-id ru
7390: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 n-id test-name i
73a0: 74 65 6d 2d 70 61 74 68 29 29 0a 09 20 20 20 20 tem-path))..
73b0: 20 20 28 74 64 61 74 20 20 20 20 20 20 20 20 28 (tdat (
73c0: 72 6d 74 3a 67 65 74 2d 74 65 73 74 69 6e 66 6f rmt:get-testinfo
73d0: 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 72 75 -state-status ru
73e0: 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 29 29 20 n-id test-id)))
73f0: 3b 3b 20 28 63 64 62 3a 67 65 74 2d 74 65 73 74 ;; (cdb:get-test
7400: 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 2a 72 75 6e -info-by-id *run
7410: 72 65 6d 6f 74 65 2a 20 74 65 73 74 2d 69 64 29 remote* test-id)
7420: 29 29 0a 09 20 28 69 66 20 74 64 61 74 0a 09 20 )).. (if tdat..
7430: 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 (begin..
7440: 20 20 20 3b 3b 20 4c 6f 6f 6b 20 61 74 20 74 68 ;; Look at th
7450: 65 20 74 65 73 74 20 73 74 61 74 65 20 61 6e 64 e test state and
7460: 20 73 74 61 74 75 73 0a 09 20 20 20 20 20 20 20 status..
7470: 28 69 66 20 28 6f 72 20 28 61 6e 64 20 28 6d 65 (if (or (and (me
7480: 6d 62 65 72 20 28 64 62 3a 74 65 73 74 2d 67 65 mber (db:test-ge
7490: 74 2d 73 74 61 74 75 73 20 74 64 61 74 29 20 0a t-status tdat) .
74a0: 09 09 09 09 20 20 20 20 27 28 22 50 41 53 53 22 .... '("PASS"
74b0: 20 22 57 41 52 4e 22 20 22 57 41 49 56 45 44 22 "WARN" "WAIVED"
74c0: 20 22 43 48 45 43 4b 22 20 22 53 4b 49 50 22 29 "CHECK" "SKIP")
74d0: 29 0a 09 09 09 20 20 20 20 28 65 71 75 61 6c 3f ).... (equal?
74e0: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 (db:test-get-st
74f0: 61 74 65 20 74 64 61 74 29 20 22 43 4f 4d 50 4c ate tdat) "COMPL
7500: 45 54 45 44 22 29 29 0a 09 09 20 20 20 20 20 20 ETED"))...
7510: 20 28 6d 65 6d 62 65 72 20 28 64 62 3a 74 65 73 (member (db:tes
7520: 74 2d 67 65 74 2d 73 74 61 74 65 20 74 64 61 74 t-get-state tdat
7530: 29 0a 09 09 09 09 20 20 20 20 27 28 22 49 4e 43 )..... '("INC
7540: 4f 4d 50 4c 45 54 45 22 20 22 4b 49 4c 4c 45 44 OMPLETE" "KILLED
7550: 22 29 29 29 0a 09 09 20 20 20 28 73 65 74 21 20 ")))... (set!
7560: 6b 65 65 70 2d 74 65 73 74 20 23 66 29 29 0a 0a keep-test #f))..
7570: 09 20 20 20 20 20 20 20 3b 3b 20 65 78 61 6d 69 . ;; exami
7580: 6e 65 20 77 61 69 74 6f 6e 73 20 66 6f 72 20 61 ne waitons for a
7590: 6e 79 20 66 61 69 6c 73 2e 20 49 66 20 69 74 20 ny fails. If it
75a0: 69 73 20 46 41 49 4c 20 6f 72 20 49 4e 43 4f 4d is FAIL or INCOM
75b0: 50 4c 45 54 45 20 74 68 65 6e 20 65 6c 69 6d 69 PLETE then elimi
75c0: 6e 61 74 65 20 74 68 69 73 20 74 65 73 74 0a 09 nate this test..
75d0: 20 20 20 20 20 20 20 3b 3b 20 66 72 6f 6d 20 74 ;; from t
75e0: 68 65 20 72 75 6e 6e 61 62 6c 65 20 6c 69 73 74 he runnable list
75f0: 0a 09 20 20 20 20 20 20 20 28 69 66 20 6b 65 65 .. (if kee
7600: 70 2d 74 65 73 74 0a 09 09 20 20 20 28 66 6f 72 p-test... (for
7610: 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 77 -each (lambda (w
7620: 61 69 74 6f 6e 29 0a 09 09 09 20 20 20 20 20 20 aiton)....
7630: 20 3b 3b 20 66 6f 72 20 6e 6f 77 20 77 65 20 61 ;; for now we a
7640: 72 65 20 77 61 69 74 69 6e 67 20 6f 6e 6c 79 20 re waiting only
7650: 6f 6e 20 74 68 65 20 70 61 72 65 6e 74 20 74 65 on the parent te
7660: 73 74 0a 09 09 09 20 20 20 20 20 20 20 28 6c 65 st.... (le
7670: 74 2a 20 28 28 70 61 72 65 6e 74 2d 74 65 73 74 t* ((parent-test
7680: 2d 69 64 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 -id (rmt:get-tes
7690: 74 2d 69 64 20 72 75 6e 2d 69 64 20 77 61 69 74 t-id run-id wait
76a0: 6f 6e 20 22 22 29 29 0a 09 09 09 09 20 20 20 20 on "")).....
76b0: 20 20 28 77 74 64 61 74 20 20 20 20 20 20 20 20 (wtdat
76c0: 20 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 69 (rmt:get-testi
76d0: 6e 66 6f 2d 73 74 61 74 65 2d 73 74 61 74 75 73 nfo-state-status
76e0: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 run-id test-id)
76f0: 29 29 20 3b 3b 20 28 63 64 62 3a 67 65 74 2d 74 )) ;; (cdb:get-t
7700: 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 2a est-info-by-id *
7710: 72 75 6e 72 65 6d 6f 74 65 2a 20 74 65 73 74 2d runremote* test-
7720: 69 64 29 29 29 0a 09 09 09 09 20 28 69 66 20 28 id)))..... (if (
7730: 6f 72 20 28 61 6e 64 20 28 65 71 75 61 6c 3f 20 or (and (equal?
7740: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 (db:test-get-sta
7750: 74 65 20 77 74 64 61 74 29 20 22 43 4f 4d 50 4c te wtdat) "COMPL
7760: 45 54 45 44 22 29 0a 09 09 09 09 09 20 20 20 20 ETED")......
7770: 20 20 28 6d 65 6d 62 65 72 20 28 64 62 3a 74 65 (member (db:te
7780: 73 74 2d 67 65 74 2d 73 74 61 74 75 73 20 77 74 st-get-status wt
7790: 64 61 74 29 20 27 28 22 46 41 49 4c 22 20 22 41 dat) '("FAIL" "A
77a0: 42 4f 52 54 22 29 29 29 0a 09 09 09 09 09 20 28 BORT")))...... (
77b0: 6d 65 6d 62 65 72 20 28 64 62 3a 74 65 73 74 2d member (db:test-
77c0: 67 65 74 2d 73 74 61 74 75 73 20 77 74 64 61 74 get-status wtdat
77d0: 29 20 20 27 28 22 4b 49 4c 4c 45 44 22 29 29 0a ) '("KILLED")).
77e0: 09 09 09 09 09 20 28 6d 65 6d 62 65 72 20 28 64 ..... (member (d
77f0: 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 b:test-get-state
7800: 20 77 74 64 61 74 29 20 20 20 27 28 22 49 4e 43 wtdat) '("INC
7810: 4f 4d 50 45 54 45 22 29 29 29 0a 09 09 09 09 20 OMPETE"))).....
7820: 3b 3b 20 28 69 66 20 28 6f 72 20 28 6d 65 6d 62 ;; (if (or (memb
7830: 65 72 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d er (db:test-get-
7840: 73 74 61 74 75 73 20 77 74 64 61 74 29 0a 09 09 status wtdat)...
7850: 09 09 20 3b 3b 20 20 20 20 20 20 20 20 09 20 27 .. ;; . '
7860: 28 22 46 41 49 4c 22 20 22 4b 49 4c 4c 45 44 22 ("FAIL" "KILLED"
7870: 29 29 0a 09 09 09 09 20 3b 3b 20 20 20 20 20 20 ))..... ;;
7880: 20 20 20 28 6d 65 6d 62 65 72 20 28 64 62 3a 74 (member (db:t
7890: 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 77 74 est-get-state wt
78a0: 64 61 74 29 0a 09 09 09 09 20 3b 3b 20 20 20 20 dat)..... ;;
78b0: 20 20 20 20 09 20 27 28 22 49 4e 43 4f 4d 50 45 . '("INCOMPE
78c0: 54 45 22 29 29 29 0a 09 09 09 09 20 20 20 20 20 TE"))).....
78d0: 28 73 65 74 21 20 6b 65 65 70 2d 74 65 73 74 20 (set! keep-test
78e0: 23 66 29 29 29 29 20 3b 3b 20 6e 6f 20 70 6f 69 #f)))) ;; no poi
78f0: 6e 74 20 69 6e 20 72 75 6e 6e 69 6e 67 20 74 68 nt in running th
7900: 69 73 20 6f 6e 65 20 61 67 61 69 6e 0a 09 09 09 is one again....
7910: 20 20 20 20 20 77 61 69 74 6f 6e 73 29 29 29 29 waitons))))
7920: 0a 09 20 28 69 66 20 6b 65 65 70 2d 74 65 73 74 .. (if keep-test
7930: 20 28 73 65 74 21 20 72 75 6e 6e 61 62 6c 65 73 (set! runnables
7940: 20 28 63 6f 6e 73 20 74 65 73 74 6b 65 79 6e 61 (cons testkeyna
7950: 6d 65 20 72 75 6e 6e 61 62 6c 65 73 29 29 29 29 me runnables))))
7960: 29 0a 20 20 20 20 20 74 65 73 74 6b 65 79 6e 61 ). testkeyna
7970: 6d 65 73 29 0a 20 20 20 20 72 75 6e 6e 61 62 6c mes). runnabl
7980: 65 73 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d es))..;;========
7990: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
79a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
79b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
79c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
79d0: 3b 20 72 65 66 61 63 74 6f 72 69 6e 67 20 74 68 ; refactoring th
79e0: 69 73 20 62 6c 6f 63 6b 20 69 6e 74 6f 20 74 65 is block into te
79f0: 73 74 73 3a 67 65 74 2d 66 75 6c 6c 2d 64 61 74 sts:get-full-dat
7a00: 61 20 66 72 6f 6d 20 6c 69 6e 65 20 32 36 33 20 a from line 263
7a10: 6f 66 20 72 75 6e 73 2e 73 63 6d 0a 3b 3b 3d 3d of runs.scm.;;==
7a20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7a30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7a40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7a50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7a60: 3d 3d 3d 3d 0a 3b 3b 20 68 65 64 20 69 73 20 74 ====.;; hed is t
7a70: 68 65 20 74 65 73 74 20 6e 61 6d 65 0a 3b 3b 20 he test name.;;
7a80: 74 65 73 74 2d 72 65 63 6f 72 64 73 20 69 73 20 test-records is
7a90: 61 20 68 61 73 68 20 6f 66 20 74 65 73 74 2d 6e a hash of test-n
7aa0: 61 6d 65 20 3d 3e 20 74 65 73 74 20 72 65 63 6f ame => test reco
7ab0: 72 64 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 rd.(define (test
7ac0: 73 3a 67 65 74 2d 66 75 6c 6c 2d 64 61 74 61 20 s:get-full-data
7ad0: 74 65 73 74 2d 6e 61 6d 65 73 20 74 65 73 74 2d test-names test-
7ae0: 72 65 63 6f 72 64 73 20 72 65 71 75 69 72 65 64 records required
7af0: 2d 74 65 73 74 73 20 61 6c 6c 2d 74 65 73 74 73 -tests all-tests
7b00: 2d 72 65 67 69 73 74 72 79 29 0a 20 20 28 69 66 -registry). (if
7b10: 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 65 73 (not (null? tes
7b20: 74 2d 6e 61 6d 65 73 29 29 0a 20 20 20 20 20 20 t-names)).
7b30: 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 (let loop ((hed
7b40: 28 63 61 72 20 74 65 73 74 2d 6e 61 6d 65 73 29 (car test-names)
7b50: 29 0a 09 09 20 28 74 61 6c 20 28 63 64 72 20 74 )... (tal (cdr t
7b60: 65 73 74 2d 6e 61 6d 65 73 29 29 29 20 20 20 20 est-names)))
7b70: 20 20 20 20 20 3b 3b 20 27 72 65 74 75 72 6e 2d ;; 'return-
7b80: 70 72 6f 63 73 20 74 65 6c 6c 73 20 74 68 65 20 procs tells the
7b90: 63 6f 6e 66 69 67 20 72 65 61 64 65 72 20 74 6f config reader to
7ba0: 20 70 72 65 70 20 72 75 6e 6e 69 6e 67 20 73 79 prep running sy
7bb0: 73 74 65 6d 20 62 75 74 20 72 65 74 75 72 6e 20 stem but return
7bc0: 61 20 70 72 6f 63 0a 09 28 64 65 62 75 67 3a 70 a proc..(debug:p
7bd0: 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 68 65 64 rint-info 4 "hed
7be0: 3d 22 20 68 65 64 20 22 20 61 74 20 74 6f 70 20 =" hed " at top
7bf0: 6f 66 20 6c 6f 6f 70 22 29 0a 09 28 6c 65 74 2a of loop")..(let*
7c00: 20 28 28 63 6f 6e 66 69 67 20 20 28 74 65 73 74 ((config (test
7c10: 73 3a 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 s:get-testconfig
7c20: 20 68 65 64 20 61 6c 6c 2d 74 65 73 74 73 2d 72 hed all-tests-r
7c30: 65 67 69 73 74 72 79 20 27 72 65 74 75 72 6e 2d egistry 'return-
7c40: 70 72 6f 63 73 29 29 0a 09 20 20 20 20 20 20 20 procs))..
7c50: 28 77 61 69 74 6f 6e 73 20 28 6c 65 74 20 28 28 (waitons (let ((
7c60: 69 6e 73 74 72 20 28 69 66 20 63 6f 6e 66 69 67 instr (if config
7c70: 20 0a 09 09 09 09 09 20 28 63 6f 6e 66 69 67 2d ...... (config-
7c80: 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 20 22 72 lookup config "r
7c90: 65 71 75 69 72 65 6d 65 6e 74 73 22 20 22 77 61 equirements" "wa
7ca0: 69 74 6f 6e 22 29 0a 09 09 09 09 09 20 28 62 65 iton")...... (be
7cb0: 67 69 6e 20 3b 3b 20 4e 6f 20 63 6f 6e 66 69 67 gin ;; No config
7cc0: 20 6d 65 61 6e 73 20 74 68 69 73 20 69 73 20 61 means this is a
7cd0: 20 6e 6f 6e 2d 65 78 69 73 74 61 6e 74 20 74 65 non-existant te
7ce0: 73 74 0a 09 09 09 09 09 20 20 20 28 64 65 62 75 st...... (debu
7cf0: 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 g:print 0 "ERROR
7d00: 3a 20 6e 6f 6e 2d 65 78 69 73 74 65 6e 74 20 72 : non-existent r
7d10: 65 71 75 69 72 65 64 20 74 65 73 74 20 5c 22 22 equired test \""
7d20: 20 68 65 64 20 22 5c 22 2c 20 67 72 65 70 20 74 hed "\", grep t
7d30: 68 72 6f 75 67 68 20 79 6f 75 72 20 74 65 73 74 hrough your test
7d40: 63 6f 6e 66 69 67 73 20 74 6f 20 66 69 6e 64 20 configs to find
7d50: 61 6e 64 20 72 65 6d 6f 76 65 20 6f 72 20 63 72 and remove or cr
7d60: 65 61 74 65 20 74 68 65 20 74 65 73 74 2e 20 44 eate the test. D
7d70: 69 73 63 61 72 64 69 6e 67 20 61 6e 64 20 63 6f iscarding and co
7d80: 6e 74 69 6e 75 69 6e 67 2e 22 29 0a 09 09 09 09 ntinuing.").....
7d90: 09 20 20 20 20 20 22 22 29 29 29 29 0a 09 09 09 . ""))))....
7da0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
7db0: 6e 66 6f 20 38 20 22 77 61 69 74 6f 6e 73 20 73 nfo 8 "waitons s
7dc0: 74 72 69 6e 67 20 69 73 20 22 20 69 6e 73 74 72 tring is " instr
7dd0: 29 0a 09 09 09 20 20 28 73 74 72 69 6e 67 2d 73 ).... (string-s
7de0: 70 6c 69 74 20 28 63 6f 6e 64 0a 09 09 09 09 09 plit (cond......
7df0: 20 28 28 70 72 6f 63 65 64 75 72 65 3f 20 69 6e ((procedure? in
7e00: 73 74 72 29 0a 09 09 09 09 09 20 20 28 6c 65 74 str)...... (let
7e10: 20 28 28 72 65 73 20 28 69 6e 73 74 72 29 29 29 ((res (instr)))
7e20: 0a 09 09 09 09 09 20 20 20 20 28 64 65 62 75 67 ...... (debug
7e30: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 38 20 22 77 :print-info 8 "w
7e40: 61 69 74 6f 6e 20 70 72 6f 63 65 64 75 72 65 20 aiton procedure
7e50: 72 65 73 75 6c 74 73 20 69 6e 20 73 74 72 69 6e results in strin
7e60: 67 20 22 20 72 65 73 20 22 20 66 6f 72 20 74 65 g " res " for te
7e70: 73 74 20 22 20 68 65 64 29 0a 09 09 09 09 09 20 st " hed)......
7e80: 20 20 20 72 65 73 29 29 0a 09 09 09 09 09 20 28 res))...... (
7e90: 28 73 74 72 69 6e 67 3f 20 69 6e 73 74 72 29 20 (string? instr)
7ea0: 20 20 20 20 69 6e 73 74 72 29 0a 09 09 09 09 09 instr)......
7eb0: 20 28 65 6c 73 65 20 0a 09 09 09 09 09 20 20 3b (else ...... ;
7ec0: 3b 20 4e 4f 54 45 3a 20 54 68 69 73 20 69 73 20 ; NOTE: This is
7ed0: 61 63 74 75 61 6c 6c 79 20 74 68 65 20 63 61 73 actually the cas
7ee0: 65 20 6f 66 20 2a 6e 6f 2a 20 77 61 69 74 6f 6e e of *no* waiton
7ef0: 73 21 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 s! ;; (debug:pri
7f00: 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 73 6f 6d nt 0 "ERROR: som
7f10: 65 74 68 69 6e 67 20 77 65 6e 74 20 77 72 6f 6e ething went wron
7f20: 67 20 69 6e 20 70 72 6f 63 65 73 73 69 6e 67 20 g in processing
7f30: 77 61 69 74 6f 6e 73 20 66 6f 72 20 74 65 73 74 waitons for test
7f40: 20 22 20 68 65 64 29 0a 09 09 09 09 09 20 20 22 " hed)...... "
7f50: 22 29 29 29 29 29 29 0a 09 20 20 28 69 66 20 28 ")))))).. (if (
7f60: 6e 6f 74 20 63 6f 6e 66 69 67 29 20 3b 3b 20 74 not config) ;; t
7f70: 68 69 73 20 69 73 20 61 20 6e 6f 6e 2d 65 78 69 his is a non-exi
7f80: 73 74 61 6e 74 20 74 65 73 74 20 63 61 6c 6c 65 stant test calle
7f90: 64 20 69 6e 20 61 20 77 61 69 74 6f 6e 2e 20 0a d in a waiton. .
7fa0: 09 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c . (if (null
7fb0: 3f 20 74 61 6c 29 0a 09 09 20 20 74 65 73 74 2d ? tal)... test-
7fc0: 72 65 63 6f 72 64 73 0a 09 09 20 20 28 6c 6f 6f records... (loo
7fd0: 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 p (car tal)(cdr
7fe0: 74 61 6c 29 29 29 0a 09 20 20 20 20 20 20 28 62 tal))).. (b
7ff0: 65 67 69 6e 0a 09 09 28 64 65 62 75 67 3a 70 72 egin...(debug:pr
8000: 69 6e 74 2d 69 6e 66 6f 20 38 20 22 77 61 69 74 int-info 8 "wait
8010: 6f 6e 73 3a 20 22 20 77 61 69 74 6f 6e 73 29 0a ons: " waitons).
8020: 09 09 3b 3b 20 63 68 65 63 6b 20 66 6f 72 20 68 ..;; check for h
8030: 65 64 20 69 6e 20 77 61 69 74 6f 6e 73 20 3d 3e ed in waitons =>
8040: 20 74 68 69 73 20 77 6f 75 6c 64 20 62 65 20 63 this would be c
8050: 69 72 63 75 6c 61 72 2c 20 72 65 6d 6f 76 65 20 ircular, remove
8060: 69 74 20 61 6e 64 20 69 73 73 75 65 20 61 6e 0a it and issue an.
8070: 09 09 3b 3b 20 65 72 72 6f 72 0a 09 09 28 69 66 ..;; error...(if
8080: 20 28 6d 65 6d 62 65 72 20 68 65 64 20 77 61 69 (member hed wai
8090: 74 6f 6e 73 29 0a 09 09 20 20 20 20 28 62 65 67 tons)... (beg
80a0: 69 6e 0a 09 09 20 20 20 20 20 20 28 64 65 62 75 in... (debu
80b0: 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 g:print 0 "ERROR
80c0: 3a 20 74 65 73 74 20 22 20 68 65 64 20 22 20 68 : test " hed " h
80d0: 61 73 20 6c 69 73 74 65 64 20 69 74 73 65 6c 66 as listed itself
80e0: 20 61 73 20 61 20 77 61 69 74 6f 6e 2c 20 70 6c as a waiton, pl
80f0: 65 61 73 65 20 63 6f 72 72 65 63 74 20 74 68 69 ease correct thi
8100: 73 21 22 29 0a 09 09 20 20 20 20 20 20 28 73 65 s!")... (se
8110: 74 21 20 77 61 69 74 6f 6e 73 20 28 66 69 6c 74 t! waitons (filt
8120: 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 28 6e er (lambda (x)(n
8130: 6f 74 20 28 65 71 75 61 6c 3f 20 78 20 68 65 64 ot (equal? x hed
8140: 29 29 29 20 77 61 69 74 6f 6e 73 29 29 29 29 0a ))) waitons)))).
8150: 09 09 0a 09 09 3b 3b 20 28 69 74 65 6d 73 20 20 .....;; (items
8160: 20 28 69 74 65 6d 73 3a 67 65 74 2d 69 74 65 6d (items:get-item
8170: 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 20 63 6f s-from-config co
8180: 6e 66 69 67 29 29 29 0a 09 09 28 69 66 20 28 6e nfig)))...(if (n
8190: 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 ot (hash-table-r
81a0: 65 66 2f 64 65 66 61 75 6c 74 20 74 65 73 74 2d ef/default test-
81b0: 72 65 63 6f 72 64 73 20 68 65 64 20 23 66 29 29 records hed #f))
81c0: 0a 09 09 20 20 20 20 28 68 61 73 68 2d 74 61 62 ... (hash-tab
81d0: 6c 65 2d 73 65 74 21 20 74 65 73 74 2d 72 65 63 le-set! test-rec
81e0: 6f 72 64 73 0a 09 09 09 09 20 20 20 20 20 68 65 ords..... he
81f0: 64 20 28 76 65 63 74 6f 72 20 68 65 64 20 20 20 d (vector hed
8200: 20 20 3b 3b 20 30 0a 09 09 09 09 09 09 20 63 6f ;; 0....... co
8210: 6e 66 69 67 20 20 3b 3b 20 31 0a 09 09 09 09 09 nfig ;; 1......
8220: 09 20 77 61 69 74 6f 6e 73 20 3b 3b 20 32 0a 09 . waitons ;; 2..
8230: 09 09 09 09 09 20 28 63 6f 6e 66 69 67 2d 6c 6f ..... (config-lo
8240: 6f 6b 75 70 20 63 6f 6e 66 69 67 20 22 72 65 71 okup config "req
8250: 75 69 72 65 6d 65 6e 74 73 22 20 22 70 72 69 6f uirements" "prio
8260: 72 69 74 79 22 29 20 20 20 20 20 3b 3b 20 70 72 rity") ;; pr
8270: 69 6f 72 69 74 79 20 33 0a 09 09 09 09 09 09 20 iority 3.......
8280: 28 6c 65 74 20 28 28 69 74 65 6d 73 20 20 20 20 (let ((items
8290: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 (hash-table-re
82a0: 66 2f 64 65 66 61 75 6c 74 20 63 6f 6e 66 69 67 f/default config
82b0: 20 22 69 74 65 6d 73 22 20 23 66 29 29 20 3b 3b "items" #f)) ;;
82c0: 20 69 74 65 6d 73 20 34 0a 09 09 09 09 09 09 20 items 4.......
82d0: 20 20 20 20 20 20 28 69 74 65 6d 73 74 61 62 6c (itemstabl
82e0: 65 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 e (hash-table-re
82f0: 66 2f 64 65 66 61 75 6c 74 20 63 6f 6e 66 69 67 f/default config
8300: 20 22 69 74 65 6d 73 74 61 62 6c 65 22 20 23 66 "itemstable" #f
8310: 29 29 29 20 0a 09 09 09 09 09 09 20 20 20 3b 3b ))) ....... ;;
8320: 20 69 66 20 65 69 74 68 65 72 20 69 74 65 6d 73 if either items
8330: 20 6f 72 20 69 74 65 6d 73 20 74 61 62 6c 65 20 or items table
8340: 69 73 20 61 20 70 72 6f 63 20 72 65 74 75 72 6e is a proc return
8350: 20 69 74 20 73 6f 20 74 65 73 74 20 72 75 6e 6e it so test runn
8360: 69 6e 67 0a 09 09 09 09 09 09 20 20 20 3b 3b 20 ing....... ;;
8370: 70 72 6f 63 65 73 73 20 63 61 6e 20 6b 6e 6f 77 process can know
8380: 20 74 6f 20 63 61 6c 6c 20 69 74 65 6d 73 3a 67 to call items:g
8390: 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f et-items-from-co
83a0: 6e 66 69 67 0a 09 09 09 09 09 09 20 20 20 3b 3b nfig....... ;;
83b0: 20 69 66 20 65 69 74 68 65 72 20 69 73 20 61 20 if either is a
83c0: 6c 69 73 74 20 61 6e 64 20 6e 6f 6e 65 20 69 73 list and none is
83d0: 20 61 20 70 72 6f 63 20 67 6f 20 61 68 65 61 64 a proc go ahead
83e0: 20 61 6e 64 20 63 61 6c 6c 20 67 65 74 2d 69 74 and call get-it
83f0: 65 6d 73 0a 09 09 09 09 09 09 20 20 20 3b 3b 20 ems....... ;;
8400: 6f 74 68 65 72 77 69 73 65 20 72 65 74 75 72 6e otherwise return
8410: 20 23 66 20 2d 20 74 68 69 73 20 69 73 20 6e 6f #f - this is no
8420: 74 20 61 6e 20 69 74 65 72 61 74 65 64 20 74 65 t an iterated te
8430: 73 74 0a 09 09 09 09 09 09 20 20 20 28 63 6f 6e st....... (con
8440: 64 0a 09 09 09 09 09 09 20 20 20 20 28 28 70 72 d....... ((pr
8450: 6f 63 65 64 75 72 65 3f 20 69 74 65 6d 73 29 20 ocedure? items)
8460: 20 20 20 20 20 0a 09 09 09 09 09 09 20 20 20 20 .......
8470: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
8480: 66 6f 20 34 20 22 69 74 65 6d 73 20 69 73 20 61 fo 4 "items is a
8490: 20 70 72 6f 63 65 64 75 72 65 2c 20 77 69 6c 6c procedure, will
84a0: 20 63 61 6c 63 20 6c 61 74 65 72 22 29 0a 09 09 calc later")...
84b0: 09 09 09 09 20 20 20 20 20 69 74 65 6d 73 29 20 .... items)
84c0: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 63 61 ;; ca
84d0: 6c 63 20 6c 61 74 65 72 0a 09 09 09 09 09 09 20 lc later.......
84e0: 20 20 20 28 28 70 72 6f 63 65 64 75 72 65 3f 20 ((procedure?
84f0: 69 74 65 6d 73 74 61 62 6c 65 29 0a 09 09 09 09 itemstable).....
8500: 09 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 .. (debug:pr
8510: 69 6e 74 2d 69 6e 66 6f 20 34 20 22 69 74 65 6d int-info 4 "item
8520: 73 74 61 62 6c 65 20 69 73 20 61 20 70 72 6f 63 stable is a proc
8530: 65 64 75 72 65 2c 20 77 69 6c 6c 20 63 61 6c 63 edure, will calc
8540: 20 6c 61 74 65 72 22 29 0a 09 09 09 09 09 09 20 later").......
8550: 20 20 20 20 69 74 65 6d 73 74 61 62 6c 65 29 20 itemstable)
8560: 20 20 20 20 20 20 3b 3b 20 63 61 6c 63 20 6c 61 ;; calc la
8570: 74 65 72 0a 09 09 09 09 09 09 20 20 20 20 28 28 ter....... ((
8580: 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 filter (lambda (
8590: 78 29 0a 09 09 09 09 09 09 09 20 20 20 20 20 20 x)........
85a0: 20 28 6c 65 74 20 28 28 76 61 6c 20 28 63 61 72 (let ((val (car
85b0: 20 78 29 29 29 0a 09 09 09 09 09 09 09 09 20 28 x)))......... (
85c0: 69 66 20 28 70 72 6f 63 65 64 75 72 65 3f 20 76 if (procedure? v
85d0: 61 6c 29 20 76 61 6c 20 23 66 29 29 29 0a 09 09 al) val #f)))...
85e0: 09 09 09 09 09 20 20 20 20 20 28 61 70 70 65 6e ..... (appen
85f0: 64 20 28 69 66 20 28 6c 69 73 74 3f 20 69 74 65 d (if (list? ite
8600: 6d 73 29 20 69 74 65 6d 73 20 27 28 29 29 0a 09 ms) items '())..
8610: 09 09 09 09 09 09 09 20 20 20 20 20 28 69 66 20 ....... (if
8620: 28 6c 69 73 74 3f 20 69 74 65 6d 73 74 61 62 6c (list? itemstabl
8630: 65 29 20 69 74 65 6d 73 74 61 62 6c 65 20 27 28 e) itemstable '(
8640: 29 29 29 29 0a 09 09 09 09 09 09 20 20 20 20 20 )))).......
8650: 27 68 61 76 65 2d 70 72 6f 63 65 64 75 72 65 29 'have-procedure)
8660: 0a 09 09 09 09 09 09 20 20 20 20 28 28 6f 72 20 ....... ((or
8670: 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 28 6c 69 (list? items)(li
8680: 73 74 3f 20 69 74 65 6d 73 74 61 62 6c 65 29 29 st? itemstable))
8690: 20 3b 3b 20 63 61 6c 63 20 6e 6f 77 0a 09 09 09 ;; calc now....
86a0: 09 09 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 ... (debug:p
86b0: 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 69 74 65 rint-info 4 "ite
86c0: 6d 73 20 61 6e 64 20 69 74 65 6d 73 74 61 62 6c ms and itemstabl
86d0: 65 20 61 72 65 20 6c 69 73 74 73 2c 20 63 61 6c e are lists, cal
86e0: 63 20 6e 6f 77 5c 6e 22 0a 09 09 09 09 09 09 09 c now\n"........
86f0: 09 20 20 20 20 20 20 20 22 20 20 20 20 69 74 65 . " ite
8700: 6d 73 3a 20 22 20 69 74 65 6d 73 20 22 20 69 74 ms: " items " it
8710: 65 6d 73 74 61 62 6c 65 3a 20 22 20 69 74 65 6d emstable: " item
8720: 73 74 61 62 6c 65 29 0a 09 09 09 09 09 09 20 20 stable).......
8730: 20 20 20 28 69 74 65 6d 73 3a 67 65 74 2d 69 74 (items:get-it
8740: 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 20 ems-from-config
8750: 63 6f 6e 66 69 67 29 29 0a 09 09 09 09 09 09 20 config)).......
8760: 20 20 20 28 65 6c 73 65 20 23 66 29 29 29 20 20 (else #f)))
8770: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8780: 20 20 20 20 20 20 20 20 20 3b 3b 20 6e 6f 74 20 ;; not
8790: 69 74 65 72 61 74 65 64 0a 09 09 09 09 09 09 20 iterated.......
87a0: 23 66 20 20 20 20 20 20 3b 3b 20 69 74 65 6d 73 #f ;; items
87b0: 64 61 74 20 35 0a 09 09 09 09 09 09 20 23 66 20 dat 5....... #f
87c0: 20 20 20 20 20 3b 3b 20 73 70 61 72 65 20 2d 20 ;; spare -
87d0: 75 73 65 64 20 66 6f 72 20 69 74 65 6d 2d 70 61 used for item-pa
87e0: 74 68 0a 09 09 09 09 09 09 20 29 29 29 0a 09 09 th....... )))...
87f0: 28 66 6f 72 2d 65 61 63 68 20 0a 09 09 20 28 6c (for-each ... (l
8800: 61 6d 62 64 61 20 28 77 61 69 74 6f 6e 29 0a 09 ambda (waiton)..
8810: 09 20 20 20 28 69 66 20 28 61 6e 64 20 77 61 69 . (if (and wai
8820: 74 6f 6e 20 28 6e 6f 74 20 28 6d 65 6d 62 65 72 ton (not (member
8830: 20 77 61 69 74 6f 6e 20 74 65 73 74 2d 6e 61 6d waiton test-nam
8840: 65 73 29 29 29 0a 09 09 20 20 20 20 20 20 20 28 es)))... (
8850: 62 65 67 69 6e 0a 09 09 09 20 28 73 65 74 21 20 begin.... (set!
8860: 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 20 28 required-tests (
8870: 63 6f 6e 73 20 77 61 69 74 6f 6e 20 72 65 71 75 cons waiton requ
8880: 69 72 65 64 2d 74 65 73 74 73 29 29 0a 09 09 09 ired-tests))....
8890: 20 28 73 65 74 21 20 74 65 73 74 2d 6e 61 6d 65 (set! test-name
88a0: 73 20 28 63 6f 6e 73 20 77 61 69 74 6f 6e 20 74 s (cons waiton t
88b0: 65 73 74 2d 6e 61 6d 65 73 29 29 29 29 29 20 3b est-names))))) ;
88c0: 3b 20 77 61 73 20 61 6e 20 61 70 70 65 6e 64 2c ; was an append,
88d0: 20 6e 6f 77 20 61 20 63 6f 6e 73 0a 09 09 20 77 now a cons... w
88e0: 61 69 74 6f 6e 73 29 0a 09 09 28 6c 65 74 20 28 aitons)...(let (
88f0: 28 72 65 6d 74 65 73 74 73 20 28 64 65 6c 65 74 (remtests (delet
8900: 65 2d 64 75 70 6c 69 63 61 74 65 73 20 28 61 70 e-duplicates (ap
8910: 70 65 6e 64 20 77 61 69 74 6f 6e 73 20 74 61 6c pend waitons tal
8920: 29 29 29 29 0a 09 09 20 20 28 69 66 20 28 6e 6f ))))... (if (no
8930: 74 20 28 6e 75 6c 6c 3f 20 72 65 6d 74 65 73 74 t (null? remtest
8940: 73 29 29 0a 09 09 20 20 20 20 20 20 28 6c 6f 6f s))... (loo
8950: 70 20 28 63 61 72 20 72 65 6d 74 65 73 74 73 29 p (car remtests)
8960: 28 63 64 72 20 72 65 6d 74 65 73 74 73 29 29 0a (cdr remtests)).
8970: 09 09 20 20 20 20 20 20 74 65 73 74 2d 72 65 63 .. test-rec
8980: 6f 72 64 73 29 29 29 29 29 29 29 29 0a 0a 3b 3b ords))))))))..;;
8990: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
89a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
89b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
89c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
89d0: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 74 65 73 74 20 73 ======.;; test s
89e0: 74 65 70 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d teps.;;=========
89f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8a00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8a10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8a20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b =============..;
8a30: 3b 20 74 65 73 74 73 74 65 70 2d 73 65 74 2d 73 ; teststep-set-s
8a40: 74 61 74 75 73 21 20 75 73 65 64 20 74 6f 20 62 tatus! used to b
8a50: 65 20 68 65 72 65 0a 0a 28 64 65 66 69 6e 65 20 e here..(define
8a60: 28 74 65 73 74 2d 67 65 74 2d 6b 69 6c 6c 2d 72 (test-get-kill-r
8a70: 65 71 75 65 73 74 20 72 75 6e 2d 69 64 20 74 65 equest run-id te
8a80: 73 74 2d 69 64 29 20 3b 3b 20 72 75 6e 2d 69 64 st-id) ;; run-id
8a90: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 64 test-name itemd
8aa0: 61 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 74 65 at). (let* ((te
8ab0: 73 74 64 61 74 20 20 20 28 72 6d 74 3a 67 65 74 stdat (rmt:get
8ac0: 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 -test-info-by-id
8ad0: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 run-id test-id)
8ae0: 29 29 0a 20 20 20 20 28 61 6e 64 20 74 65 73 74 )). (and test
8af0: 64 61 74 0a 09 20 28 65 71 75 61 6c 3f 20 28 74 dat.. (equal? (t
8b00: 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 est:get-state te
8b10: 73 74 64 61 74 29 20 22 4b 49 4c 4c 52 45 51 22 stdat) "KILLREQ"
8b20: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 ))))..(define (t
8b30: 65 73 74 3a 74 64 62 2d 67 65 74 2d 72 75 6e 64 est:tdb-get-rund
8b40: 61 74 2d 63 6f 75 6e 74 20 74 64 62 29 0a 20 20 at-count tdb).
8b50: 28 69 66 20 74 64 62 0a 20 20 20 20 20 20 28 6c (if tdb. (l
8b60: 65 74 20 28 28 72 65 73 20 30 29 29 0a 09 28 73 et ((res 0))..(s
8b70: 71 6c 69 74 65 33 3a 66 6f 72 2d 65 61 63 68 2d qlite3:for-each-
8b80: 72 6f 77 0a 09 20 28 6c 61 6d 62 64 61 20 28 63 row.. (lambda (c
8b90: 6f 75 6e 74 29 0a 09 20 20 20 28 73 65 74 21 20 ount).. (set!
8ba0: 72 65 73 20 63 6f 75 6e 74 29 29 0a 09 20 74 64 res count)).. td
8bb0: 62 0a 09 20 22 53 45 4c 45 43 54 20 63 6f 75 6e b.. "SELECT coun
8bc0: 74 28 69 64 29 20 46 52 4f 4d 20 74 65 73 74 5f t(id) FROM test_
8bd0: 72 75 6e 64 61 74 3b 22 29 0a 09 72 65 73 29 29 rundat;")..res))
8be0: 0a 20 20 30 29 0a 0a 28 64 65 66 69 6e 65 20 28 . 0)..(define (
8bf0: 74 65 73 74 73 3a 75 70 64 61 74 65 2d 63 65 6e tests:update-cen
8c00: 74 72 61 6c 2d 6d 65 74 61 2d 69 6e 66 6f 20 72 tral-meta-info r
8c10: 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 63 70 un-id test-id cp
8c20: 75 6c 6f 61 64 20 64 69 73 6b 66 72 65 65 20 6d uload diskfree m
8c30: 69 6e 75 74 65 73 20 75 6e 61 6d 65 20 68 6f 73 inutes uname hos
8c40: 74 6e 61 6d 65 29 0a 20 20 28 72 6d 74 3a 67 65 tname). (rmt:ge
8c50: 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 75 70 64 61 neral-call 'upda
8c60: 74 65 2d 63 70 75 6c 6f 61 64 2d 64 69 73 6b 66 te-cpuload-diskf
8c70: 72 65 65 20 72 75 6e 2d 69 64 20 63 70 75 6c 6f ree run-id cpulo
8c80: 61 64 20 64 69 73 6b 66 72 65 65 20 74 65 73 74 ad diskfree test
8c90: 2d 69 64 29 0a 20 20 28 69 66 20 6d 69 6e 75 74 -id). (if minut
8ca0: 65 73 20 0a 20 20 20 20 20 20 28 72 6d 74 3a 67 es . (rmt:g
8cb0: 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 75 70 64 eneral-call 'upd
8cc0: 61 74 65 2d 72 75 6e 2d 64 75 72 61 74 69 6f 6e ate-run-duration
8cd0: 20 72 75 6e 2d 69 64 20 6d 69 6e 75 74 65 73 20 run-id minutes
8ce0: 74 65 73 74 2d 69 64 29 29 0a 20 20 28 69 66 20 test-id)). (if
8cf0: 28 61 6e 64 20 75 6e 61 6d 65 20 68 6f 73 74 6e (and uname hostn
8d00: 61 6d 65 29 0a 20 20 20 20 20 20 28 72 6d 74 3a ame). (rmt:
8d10: 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 75 70 general-call 'up
8d20: 64 61 74 65 2d 75 6e 61 6d 65 2d 68 6f 73 74 20 date-uname-host
8d30: 72 75 6e 2d 69 64 20 75 6e 61 6d 65 20 68 6f 73 run-id uname hos
8d40: 74 6e 61 6d 65 20 74 65 73 74 2d 69 64 29 29 29 tname test-id)))
8d50: 0a 20 20 0a 3b 3b 20 54 68 69 73 20 6f 6e 65 20 . .;; This one
8d60: 69 73 20 66 6f 72 20 72 75 6e 6e 69 6e 67 20 77 is for running w
8d70: 69 74 68 20 6e 6f 20 64 62 20 61 63 63 65 73 73 ith no db access
8d80: 20 28 69 2e 65 2e 20 76 69 61 20 72 6d 74 3a 20 (i.e. via rmt:
8d90: 69 6e 74 65 72 6e 61 6c 6c 79 29 0a 28 64 65 66 internally).(def
8da0: 69 6e 65 20 28 74 65 73 74 73 3a 73 65 74 2d 66 ine (tests:set-f
8db0: 75 6c 6c 2d 6d 65 74 61 2d 69 6e 66 6f 20 64 62 ull-meta-info db
8dc0: 20 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 test-id run-id
8dd0: 6d 69 6e 75 74 65 73 20 77 6f 72 6b 2d 61 72 65 minutes work-are
8de0: 61 20 72 65 6d 74 72 69 65 73 29 0a 3b 3b 20 28 a remtries).;; (
8df0: 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 73 65 define (tests:se
8e00: 74 2d 66 75 6c 6c 2d 6d 65 74 61 2d 69 6e 66 6f t-full-meta-info
8e10: 20 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 test-id run-id
8e20: 6d 69 6e 75 74 65 73 20 77 6f 72 6b 2d 61 72 65 minutes work-are
8e30: 61 29 0a 3b 3b 20 20 28 6c 65 74 20 28 28 72 65 a).;; (let ((re
8e40: 6d 74 72 69 65 73 20 31 30 29 29 0a 20 20 28 6c mtries 10)). (l
8e50: 65 74 2a 20 28 28 63 70 75 6c 6f 61 64 20 20 28 et* ((cpuload (
8e60: 67 65 74 2d 63 70 75 2d 6c 6f 61 64 29 29 0a 09 get-cpu-load))..
8e70: 20 28 64 69 73 6b 66 72 65 65 20 28 67 65 74 2d (diskfree (get-
8e80: 64 66 20 28 63 75 72 72 65 6e 74 2d 64 69 72 65 df (current-dire
8e90: 63 74 6f 72 79 29 29 29 0a 09 20 28 75 6e 61 6d ctory))).. (unam
8ea0: 65 20 20 20 20 28 67 65 74 2d 75 6e 61 6d 65 20 e (get-uname
8eb0: 22 2d 73 72 76 70 69 6f 22 29 29 0a 09 20 28 68 "-srvpio")).. (h
8ec0: 6f 73 74 6e 61 6d 65 20 28 67 65 74 2d 68 6f 73 ostname (get-hos
8ed0: 74 2d 6e 61 6d 65 29 29 29 0a 20 20 20 20 28 74 t-name))). (t
8ee0: 65 73 74 73 3a 75 70 64 61 74 65 2d 63 65 6e 74 ests:update-cent
8ef0: 72 61 6c 2d 6d 65 74 61 2d 69 6e 66 6f 20 72 75 ral-meta-info ru
8f00: 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 63 70 75 n-id test-id cpu
8f10: 6c 6f 61 64 20 64 69 73 6b 66 72 65 65 20 6d 69 load diskfree mi
8f20: 6e 75 74 65 73 20 75 6e 61 6d 65 20 68 6f 73 74 nutes uname host
8f30: 6e 61 6d 65 29 29 29 0a 20 20 20 20 0a 3b 3b 20 name))). .;;
8f40: 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 73 (define (tests:s
8f50: 65 74 2d 70 61 72 74 69 61 6c 2d 6d 65 74 61 2d et-partial-meta-
8f60: 69 6e 66 6f 20 74 65 73 74 2d 69 64 20 72 75 6e info test-id run
8f70: 2d 69 64 20 6d 69 6e 75 74 65 73 20 77 6f 72 6b -id minutes work
8f80: 2d 61 72 65 61 29 0a 28 64 65 66 69 6e 65 20 28 -area).(define (
8f90: 74 65 73 74 73 3a 73 65 74 2d 70 61 72 74 69 61 tests:set-partia
8fa0: 6c 2d 6d 65 74 61 2d 69 6e 66 6f 20 74 65 73 74 l-meta-info test
8fb0: 2d 69 64 20 72 75 6e 2d 69 64 20 6d 69 6e 75 74 -id run-id minut
8fc0: 65 73 20 77 6f 72 6b 2d 61 72 65 61 20 72 65 6d es work-area rem
8fd0: 74 72 69 65 73 29 0a 20 20 28 6c 65 74 2a 20 28 tries). (let* (
8fe0: 28 63 70 75 6c 6f 61 64 20 20 28 67 65 74 2d 63 (cpuload (get-c
8ff0: 70 75 2d 6c 6f 61 64 29 29 0a 09 20 28 64 69 73 pu-load)).. (dis
9000: 6b 66 72 65 65 20 28 67 65 74 2d 64 66 20 28 63 kfree (get-df (c
9010: 75 72 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 79 urrent-directory
9020: 29 29 29 0a 09 20 28 72 65 6d 74 72 69 65 73 20 ))).. (remtries
9030: 31 30 29 29 0a 20 20 20 20 28 68 61 6e 64 6c 65 10)). (handle
9040: 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 20 -exceptions.
9050: 20 65 78 6e 0a 20 20 20 20 20 28 69 66 20 28 3e exn. (if (>
9060: 20 72 65 6d 74 72 69 65 73 20 30 29 0a 09 20 28 remtries 0).. (
9070: 62 65 67 69 6e 0a 09 20 20 20 28 70 72 69 6e 74 begin.. (print
9080: 2d 63 61 6c 6c 2d 63 68 61 69 6e 20 28 63 75 72 -call-chain (cur
9090: 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 rent-error-port)
90a0: 29 0a 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 ).. (debug:pri
90b0: 6e 74 2d 69 6e 66 6f 20 30 20 22 57 41 52 4e 49 nt-info 0 "WARNI
90c0: 4e 47 3a 20 66 61 69 6c 65 64 20 74 6f 20 73 65 NG: failed to se
90d0: 74 20 6d 65 74 61 20 69 6e 66 6f 2e 20 57 69 6c t meta info. Wil
90e0: 6c 20 74 72 79 20 22 20 72 65 6d 74 72 69 65 73 l try " remtries
90f0: 20 22 20 6d 6f 72 65 20 74 69 6d 65 73 22 29 0a " more times").
9100: 09 20 20 20 28 73 65 74 21 20 72 65 6d 74 72 69 . (set! remtri
9110: 65 73 20 28 2d 20 72 65 6d 74 72 69 65 73 20 31 es (- remtries 1
9120: 29 29 0a 09 20 20 20 28 74 68 72 65 61 64 2d 73 )).. (thread-s
9130: 6c 65 65 70 21 20 31 30 29 0a 09 20 20 20 28 74 leep! 10).. (t
9140: 65 73 74 73 3a 73 65 74 2d 66 75 6c 6c 2d 6d 65 ests:set-full-me
9150: 74 61 2d 69 6e 66 6f 20 64 62 20 74 65 73 74 2d ta-info db test-
9160: 69 64 20 72 75 6e 2d 69 64 20 6d 69 6e 75 74 65 id run-id minute
9170: 73 20 77 6f 72 6b 2d 61 72 65 61 20 28 2d 20 72 s work-area (- r
9180: 65 6d 74 72 69 65 73 20 31 29 29 29 0a 09 20 28 emtries 1))).. (
9190: 6c 65 74 20 28 28 65 72 72 2d 73 74 61 74 75 73 let ((err-status
91a0: 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f ((condition-pro
91b0: 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 perty-accessor '
91c0: 73 71 6c 69 74 65 33 20 27 73 74 61 74 75 73 20 sqlite3 'status
91d0: 23 66 29 20 65 78 6e 29 29 29 0a 09 20 20 20 28 #f) exn))).. (
91e0: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 debug:print 0 "E
91f0: 52 52 4f 52 3a 20 74 72 69 65 64 20 66 6f 72 20 RROR: tried for
9200: 6f 76 65 72 20 61 20 6d 69 6e 75 74 65 20 74 6f over a minute to
9210: 20 75 70 64 61 74 65 20 6d 65 74 61 20 69 6e 66 update meta inf
9220: 6f 20 61 6e 64 20 66 61 69 6c 65 64 2e 20 47 69 o and failed. Gi
9230: 76 69 6e 67 20 75 70 22 29 0a 09 20 20 20 28 64 ving up").. (d
9240: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 58 ebug:print 0 "EX
9250: 43 45 50 54 49 4f 4e 3a 20 64 61 74 61 62 61 73 CEPTION: databas
9260: 65 20 70 72 6f 62 61 62 6c 79 20 6f 76 65 72 6c e probably overl
9270: 6f 61 64 65 64 20 6f 72 20 75 6e 72 65 61 64 61 oaded or unreada
9280: 62 6c 65 2e 22 29 0a 09 20 20 20 28 64 65 62 75 ble.").. (debu
9290: 67 3a 70 72 69 6e 74 20 30 20 22 20 6d 65 73 73 g:print 0 " mess
92a0: 61 67 65 3a 20 22 20 28 28 63 6f 6e 64 69 74 69 age: " ((conditi
92b0: 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 on-property-acce
92c0: 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 ssor 'exn 'messa
92d0: 67 65 29 20 65 78 6e 29 29 0a 09 20 20 20 28 70 ge) exn)).. (p
92e0: 72 69 6e 74 20 22 65 78 6e 3d 22 20 28 63 6f 6e rint "exn=" (con
92f0: 64 69 74 69 6f 6e 2d 3e 6c 69 73 74 20 65 78 6e dition->list exn
9300: 29 29 0a 09 20 20 20 28 64 65 62 75 67 3a 70 72 )).. (debug:pr
9310: 69 6e 74 20 30 20 22 20 73 74 61 74 75 73 3a 20 int 0 " status:
9320: 20 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 " ((condition-p
9330: 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 roperty-accessor
9340: 20 27 73 71 6c 69 74 65 33 20 27 73 74 61 74 75 'sqlite3 'statu
9350: 73 29 20 65 78 6e 29 29 0a 09 20 20 20 28 70 72 s) exn)).. (pr
9360: 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 20 28 int-call-chain (
9370: 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f current-error-po
9380: 72 74 29 29 29 29 0a 20 20 20 20 20 28 74 65 73 rt)))). (tes
9390: 74 73 3a 75 70 64 61 74 65 2d 74 65 73 74 64 61 ts:update-testda
93a0: 74 2d 6d 65 74 61 2d 69 6e 66 6f 20 64 62 20 74 t-meta-info db t
93b0: 65 73 74 2d 69 64 20 77 6f 72 6b 2d 61 72 65 61 est-id work-area
93c0: 20 63 70 75 6c 6f 61 64 20 64 69 73 6b 66 72 65 cpuload diskfre
93d0: 65 20 6d 69 6e 75 74 65 73 29 0a 20 20 29 29 29 e minutes). )))
93e0: 0a 09 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .. .;;==========
93f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9400: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9410: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9420: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
9430: 41 20 52 20 43 20 48 20 49 20 56 20 49 20 4e 20 A R C H I V I N
9440: 47 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d G.;;============
9450: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9460: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9470: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9480: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 ==========..(def
9490: 69 6e 65 20 28 74 65 73 74 3a 61 72 63 68 69 76 ine (test:archiv
94a0: 65 20 64 62 20 74 65 73 74 2d 69 64 29 0a 20 20 e db test-id).
94b0: 23 66 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 #f)..(define (te
94c0: 73 74 3a 61 72 63 68 69 76 65 2d 74 65 73 74 73 st:archive-tests
94d0: 20 64 62 20 6b 65 79 6e 61 6d 65 73 20 74 61 72 db keynames tar
94e0: 67 65 74 29 0a 20 20 23 66 29 0a 0a get). #f)..