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 32 2c right 2006-2012,
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 0a te3 sqlite3:))..
02f0: 28 64 65 63 6c 61 72 65 20 28 75 6e 69 74 20 74 (declare (unit t
0300: 65 73 74 73 29 29 0a 28 64 65 63 6c 61 72 65 20 ests)).(declare
0310: 28 75 73 65 73 20 64 62 29 29 0a 28 64 65 63 6c (uses db)).(decl
0320: 61 72 65 20 28 75 73 65 73 20 63 6f 6d 6d 6f 6e are (uses common
0330: 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 )).(declare (use
0340: 73 20 69 74 65 6d 73 29 29 0a 28 64 65 63 6c 61 s items)).(decla
0350: 72 65 20 28 75 73 65 73 20 72 75 6e 63 6f 6e 66 re (uses runconf
0360: 69 67 29 29 0a 0a 28 69 6e 63 6c 75 64 65 20 22 ig))..(include "
0370: 63 6f 6d 6d 6f 6e 5f 72 65 63 6f 72 64 73 2e 73 common_records.s
0380: 63 6d 22 29 0a 28 69 6e 63 6c 75 64 65 20 22 6b cm").(include "k
0390: 65 79 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 ey_records.scm")
03a0: 0a 28 69 6e 63 6c 75 64 65 20 22 64 62 5f 72 65 .(include "db_re
03b0: 63 6f 72 64 73 2e 73 63 6d 22 29 0a 28 69 6e 63 cords.scm").(inc
03c0: 6c 75 64 65 20 22 72 75 6e 5f 72 65 63 6f 72 64 lude "run_record
03d0: 73 2e 73 63 6d 22 29 0a 28 69 6e 63 6c 75 64 65 s.scm").(include
03e0: 20 22 74 65 73 74 5f 72 65 63 6f 72 64 73 2e 73 "test_records.s
03f0: 63 6d 22 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 cm")..(define (t
0400: 65 73 74 73 3a 67 65 74 2d 76 61 6c 69 64 2d 74 ests:get-valid-t
0410: 65 73 74 73 20 74 65 73 74 73 64 69 72 20 74 65 ests testsdir te
0420: 73 74 2d 70 61 74 74 73 29 20 3b 3b 20 20 23 21 st-patts) ;; #!
0430: 6b 65 79 20 28 74 65 73 74 2d 6e 61 6d 65 73 20 key (test-names
0440: 27 28 29 29 29 0a 20 20 28 6c 65 74 20 28 28 74 '())). (let ((t
0450: 65 73 74 73 20 28 67 6c 6f 62 20 28 63 6f 6e 63 ests (glob (conc
0460: 20 74 65 73 74 73 64 69 72 20 22 2f 74 65 73 74 testsdir "/test
0470: 73 2f 2a 22 29 29 29 29 20 3b 3b 20 22 20 28 73 s/*")))) ;; " (s
0480: 74 72 69 6e 67 2d 74 72 61 6e 73 6c 61 74 65 20 tring-translate
0490: 70 61 74 74 20 22 25 22 20 22 2a 22 29 29 29 29 patt "%" "*"))))
04a0: 29 0a 20 20 20 20 28 73 65 74 21 20 74 65 73 74 ). (set! test
04b0: 73 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 s (filter (lambd
04c0: 61 20 28 74 65 73 74 29 28 66 69 6c 65 2d 65 78 a (test)(file-ex
04d0: 69 73 74 73 3f 20 28 63 6f 6e 63 20 74 65 73 74 ists? (conc test
04e0: 20 22 2f 74 65 73 74 63 6f 6e 66 69 67 22 29 29 "/testconfig"))
04f0: 29 20 74 65 73 74 73 29 29 0a 20 20 20 20 28 64 ) tests)). (d
0500: 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 74 65 73 elete-duplicates
0510: 0a 20 20 20 20 20 28 66 69 6c 74 65 72 20 28 6c . (filter (l
0520: 61 6d 62 64 61 20 28 74 65 73 74 6e 61 6d 65 29 ambda (testname)
0530: 0a 09 20 20 20 20 20 20 20 28 74 65 73 74 73 3a .. (tests:
0540: 6d 61 74 63 68 20 74 65 73 74 2d 70 61 74 74 73 match test-patts
0550: 20 74 65 73 74 6e 61 6d 65 20 23 66 29 29 0a 09 testname #f))..
0560: 20 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 (map (lambd
0570: 61 20 28 74 65 73 74 70 29 0a 09 09 20 20 20 20 a (testp)...
0580: 28 6c 61 73 74 20 28 73 74 72 69 6e 67 2d 73 70 (last (string-sp
0590: 6c 69 74 20 74 65 73 74 70 20 22 2f 22 29 29 29 lit testp "/")))
05a0: 0a 09 09 20 20 74 65 73 74 73 29 29 29 29 29 0a ... tests))))).
05b0: 0a 3b 3b 20 74 65 73 74 73 3a 67 6c 6f 62 2d 6c .;; tests:glob-l
05c0: 69 6b 65 2d 6d 61 74 63 68 0a 28 64 65 66 69 6e ike-match.(defin
05d0: 65 20 28 74 65 73 74 73 3a 67 6c 6f 62 2d 6c 69 e (tests:glob-li
05e0: 6b 65 2d 6d 61 74 63 68 20 70 61 74 74 20 73 74 ke-match patt st
05f0: 72 29 20 0a 20 20 28 6c 65 74 20 28 28 6c 69 6b r) . (let ((lik
0600: 65 20 28 73 75 62 73 74 72 69 6e 67 2d 69 6e 64 e (substring-ind
0610: 65 78 20 22 25 22 20 70 61 74 74 29 29 29 0a 20 ex "%" patt))).
0620: 20 20 20 28 6c 65 74 2a 20 28 28 6e 6f 74 70 61 (let* ((notpa
0630: 74 74 20 20 28 65 71 75 61 6c 3f 20 28 73 75 62 tt (equal? (sub
0640: 73 74 72 69 6e 67 2d 69 6e 64 65 78 20 22 7e 22 string-index "~"
0650: 20 70 61 74 74 29 20 30 29 29 0a 09 20 20 20 28 patt) 0)).. (
0660: 6e 65 77 70 61 74 74 20 20 28 69 66 20 6e 6f 74 newpatt (if not
0670: 70 61 74 74 20 28 73 75 62 73 74 72 69 6e 67 20 patt (substring
0680: 70 61 74 74 20 31 29 20 70 61 74 74 29 29 0a 09 patt 1) patt))..
0690: 20 20 20 28 66 69 6e 70 61 74 74 20 20 28 69 66 (finpatt (if
06a0: 20 6c 69 6b 65 0a 09 09 09 28 73 74 72 69 6e 67 like....(string
06b0: 2d 73 75 62 73 74 69 74 75 74 65 20 28 72 65 67 -substitute (reg
06c0: 65 78 70 20 22 25 22 29 20 22 2e 2a 22 20 6e 65 exp "%") ".*" ne
06d0: 77 70 61 74 74 29 0a 09 09 09 28 73 74 72 69 6e wpatt)....(strin
06e0: 67 2d 73 75 62 73 74 69 74 75 74 65 20 28 72 65 g-substitute (re
06f0: 67 65 78 70 20 22 5c 5c 2a 22 29 20 22 2e 2a 22 gexp "\\*") ".*"
0700: 20 6e 65 77 70 61 74 74 29 29 29 0a 09 20 20 20 newpatt)))..
0710: 28 72 65 73 20 20 20 20 20 20 23 66 29 29 0a 20 (res #f)).
0720: 20 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 ;; (print "
0730: 74 65 73 74 73 3a 67 6c 6f 62 2d 6c 69 6b 65 2d tests:glob-like-
0740: 6d 61 74 63 68 20 3d 3e 20 6e 6f 74 70 61 74 74 match => notpatt
0750: 3a 20 22 20 6e 6f 74 70 61 74 74 20 22 2c 20 6e : " notpatt ", n
0760: 65 77 70 61 74 74 3a 20 22 20 6e 65 77 70 61 74 ewpatt: " newpat
0770: 74 20 22 2c 20 66 69 6e 70 61 74 74 3a 20 22 20 t ", finpatt: "
0780: 66 69 6e 70 61 74 74 29 0a 20 20 20 20 20 20 28 finpatt). (
0790: 73 65 74 21 20 72 65 73 20 28 73 74 72 69 6e 67 set! res (string
07a0: 2d 6d 61 74 63 68 20 28 72 65 67 65 78 70 20 66 -match (regexp f
07b0: 69 6e 70 61 74 74 20 28 69 66 20 6c 69 6b 65 20 inpatt (if like
07c0: 23 74 20 23 66 29 29 20 73 74 72 29 29 0a 20 20 #t #f)) str)).
07d0: 20 20 20 20 28 69 66 20 6e 6f 74 70 61 74 74 20 (if notpatt
07e0: 28 6e 6f 74 20 72 65 73 29 20 72 65 73 29 29 29 (not res) res)))
07f0: 29 0a 0a 3b 3b 20 69 66 20 69 74 65 6d 70 61 74 )..;; if itempat
0800: 68 20 69 73 20 23 66 20 74 68 65 6e 20 6c 6f 6f h is #f then loo
0810: 6b 20 6f 6e 6c 79 20 61 74 20 74 68 65 20 74 65 k only at the te
0820: 73 74 6e 61 6d 65 20 70 61 72 74 0a 3b 3b 0a 28 stname part.;;.(
0830: 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 6d 61 define (tests:ma
0840: 74 63 68 20 70 61 74 74 65 72 6e 73 20 74 65 73 tch patterns tes
0850: 74 6e 61 6d 65 20 69 74 65 6d 70 61 74 68 29 0a tname itempath).
0860: 20 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 70 (if (string? p
0870: 61 74 74 65 72 6e 73 29 0a 20 20 20 20 20 20 28 atterns). (
0880: 6c 65 74 20 28 28 70 61 74 74 73 20 28 73 74 72 let ((patts (str
0890: 69 6e 67 2d 73 70 6c 69 74 20 70 61 74 74 65 72 ing-split patter
08a0: 6e 73 20 22 2c 22 29 29 29 0a 09 28 69 66 20 28 ns ",")))..(if (
08b0: 6e 75 6c 6c 3f 20 70 61 74 74 73 29 20 3b 3b 3b null? patts) ;;;
08c0: 20 6e 6f 20 70 61 74 74 65 72 6e 28 73 29 20 6d no pattern(s) m
08d0: 65 61 6e 73 20 6e 6f 20 6d 61 74 63 68 0a 09 20 eans no match..
08e0: 20 20 20 23 66 0a 09 20 20 20 20 28 6c 65 74 20 #f.. (let
08f0: 6c 6f 6f 70 20 28 28 70 61 74 74 20 28 63 61 72 loop ((patt (car
0900: 20 70 61 74 74 73 29 29 0a 09 09 20 20 20 20 20 patts))...
0910: 20 20 28 74 61 6c 20 20 28 63 64 72 20 70 61 74 (tal (cdr pat
0920: 74 73 29 29 29 0a 09 20 20 20 20 20 20 3b 3b 20 ts))).. ;;
0930: 28 70 72 69 6e 74 20 22 6c 6f 6f 70 3a 20 70 61 (print "loop: pa
0940: 74 74 3a 20 22 20 70 61 74 74 20 22 2c 20 74 61 tt: " patt ", ta
0950: 6c 20 22 20 74 61 6c 29 0a 09 20 20 20 20 20 20 l " tal)..
0960: 28 69 66 20 28 73 74 72 69 6e 67 3d 3f 20 70 61 (if (string=? pa
0970: 74 74 20 22 22 29 0a 09 09 20 20 23 66 20 3b 3b tt "")... #f ;;
0980: 20 6e 6f 74 68 69 6e 67 20 65 76 65 72 20 6d 61 nothing ever ma
0990: 74 63 68 65 73 20 65 6d 70 74 79 20 73 74 72 69 tches empty stri
09a0: 6e 67 20 2d 20 70 6f 6c 69 63 79 0a 09 09 20 20 ng - policy...
09b0: 28 6c 65 74 2a 20 28 28 70 61 74 74 2d 70 61 72 (let* ((patt-par
09c0: 74 73 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 ts (string-match
09d0: 20 28 72 65 67 65 78 70 20 22 5e 28 5b 5e 5c 5c (regexp "^([^\\
09e0: 2f 5d 2a 29 28 5c 5c 2f 28 2e 2a 29 7c 29 24 22 /]*)(\\/(.*)|)$"
09f0: 29 20 70 61 74 74 29 29 0a 09 09 09 20 28 74 65 ) patt)).... (te
0a00: 73 74 2d 70 61 74 74 20 20 28 63 61 64 72 20 70 st-patt (cadr p
0a10: 61 74 74 2d 70 61 72 74 73 29 29 0a 09 09 09 20 att-parts))....
0a20: 28 69 74 65 6d 2d 70 61 74 74 20 20 28 63 61 64 (item-patt (cad
0a30: 64 64 72 20 70 61 74 74 2d 70 61 72 74 73 29 29 ddr patt-parts))
0a40: 29 0a 09 09 20 20 20 20 3b 3b 20 73 70 65 63 69 )... ;; speci
0a50: 61 6c 20 63 61 73 65 3a 20 74 65 73 74 20 76 73 al case: test vs
0a60: 2e 20 74 65 73 74 2f 0a 09 09 20 20 20 20 3b 3b . test/... ;;
0a70: 20 20 20 74 65 73 74 20 20 3d 3e 20 22 74 65 73 test => "tes
0a80: 74 22 20 22 25 22 0a 09 09 20 20 20 20 3b 3b 20 t" "%"... ;;
0a90: 20 20 74 65 73 74 2f 20 3d 3e 20 22 74 65 73 74 test/ => "test
0aa0: 22 20 22 22 0a 09 09 20 20 20 20 28 69 66 20 28 " ""... (if (
0ab0: 61 6e 64 20 28 6e 6f 74 20 28 73 75 62 73 74 72 and (not (substr
0ac0: 69 6e 67 2d 69 6e 64 65 78 20 22 2f 22 20 70 61 ing-index "/" pa
0ad0: 74 74 29 29 20 3b 3b 20 6e 6f 20 73 6c 61 73 68 tt)) ;; no slash
0ae0: 20 69 6e 20 74 68 65 20 6f 72 69 67 69 6e 61 6c in the original
0af0: 0a 09 09 09 20 20 20 20 20 28 6f 72 20 28 6e 6f .... (or (no
0b00: 74 20 69 74 65 6d 2d 70 61 74 74 29 0a 09 09 09 t item-patt)....
0b10: 09 20 28 65 71 75 61 6c 3f 20 69 74 65 6d 2d 70 . (equal? item-p
0b20: 61 74 74 20 22 22 29 29 29 20 20 20 20 20 20 3b att ""))) ;
0b30: 3b 20 73 68 6f 75 6c 64 20 61 6c 77 61 79 73 20 ; should always
0b40: 62 65 20 74 72 75 65 20 74 68 61 74 20 69 74 65 be true that ite
0b50: 6d 2d 70 61 74 74 20 69 73 20 22 22 0a 09 09 09 m-patt is ""....
0b60: 28 73 65 74 21 20 69 74 65 6d 2d 70 61 74 74 20 (set! item-patt
0b70: 22 25 22 29 29 0a 09 09 20 20 20 20 3b 3b 20 28 "%"))... ;; (
0b80: 70 72 69 6e 74 20 22 74 65 73 74 73 3a 6d 61 74 print "tests:mat
0b90: 63 68 20 3d 3e 20 70 61 74 74 2d 70 61 72 74 73 ch => patt-parts
0ba0: 3a 20 22 20 70 61 74 74 2d 70 61 72 74 73 20 22 : " patt-parts "
0bb0: 2c 20 74 65 73 74 2d 70 61 74 74 3a 20 22 20 74 , test-patt: " t
0bc0: 65 73 74 2d 70 61 74 74 20 22 2c 20 69 74 65 6d est-patt ", item
0bd0: 2d 70 61 74 74 3a 20 22 20 69 74 65 6d 2d 70 61 -patt: " item-pa
0be0: 74 74 29 0a 09 09 20 20 20 20 28 69 66 20 28 61 tt)... (if (a
0bf0: 6e 64 20 28 74 65 73 74 73 3a 67 6c 6f 62 2d 6c nd (tests:glob-l
0c00: 69 6b 65 2d 6d 61 74 63 68 20 74 65 73 74 2d 70 ike-match test-p
0c10: 61 74 74 20 74 65 73 74 6e 61 6d 65 29 0a 09 09 att testname)...
0c20: 09 20 20 20 20 20 28 6f 72 20 28 6e 6f 74 20 69 . (or (not i
0c30: 74 65 6d 70 61 74 68 29 0a 09 09 09 09 20 28 74 tempath)..... (t
0c40: 65 73 74 73 3a 67 6c 6f 62 2d 6c 69 6b 65 2d 6d ests:glob-like-m
0c50: 61 74 63 68 20 28 69 66 20 69 74 65 6d 2d 70 61 atch (if item-pa
0c60: 74 74 20 69 74 65 6d 2d 70 61 74 74 20 22 22 29 tt item-patt "")
0c70: 20 69 74 65 6d 70 61 74 68 29 29 29 0a 09 09 09 itempath)))....
0c80: 23 74 0a 09 09 09 28 69 66 20 28 6e 75 6c 6c 3f #t....(if (null?
0c90: 20 74 61 6c 29 0a 09 09 09 20 20 20 20 23 66 0a tal).... #f.
0ca0: 09 09 09 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 ... (loop (ca
0cb0: 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 29 r tal)(cdr tal))
0cc0: 29 29 29 29 29 29 29 29 29 0a 0a 3b 3b 20 69 66 )))))))))..;; if
0cd0: 20 69 74 65 6d 70 61 74 68 20 69 73 20 23 66 20 itempath is #f
0ce0: 74 68 65 6e 20 6c 6f 6f 6b 20 6f 6e 6c 79 20 61 then look only a
0cf0: 74 20 74 68 65 20 74 65 73 74 6e 61 6d 65 20 70 t the testname p
0d00: 61 72 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 art.;;.(define (
0d10: 74 65 73 74 73 3a 6d 61 74 63 68 2d 3e 73 71 6c tests:match->sql
0d20: 71 72 79 20 70 61 74 74 65 72 6e 73 29 0a 20 20 qry patterns).
0d30: 28 69 66 20 28 73 74 72 69 6e 67 3f 20 70 61 74 (if (string? pat
0d40: 74 65 72 6e 73 29 0a 20 20 20 20 20 20 28 6c 65 terns). (le
0d50: 74 20 28 28 70 61 74 74 73 20 28 73 74 72 69 6e t ((patts (strin
0d60: 67 2d 73 70 6c 69 74 20 70 61 74 74 65 72 6e 73 g-split patterns
0d70: 20 22 2c 22 29 29 29 0a 09 28 69 66 20 28 6e 75 ",")))..(if (nu
0d80: 6c 6c 3f 20 70 61 74 74 73 29 20 3b 3b 3b 20 6e ll? patts) ;;; n
0d90: 6f 20 70 61 74 74 65 72 6e 28 73 29 20 6d 65 61 o pattern(s) mea
0da0: 6e 73 20 6e 6f 20 6d 61 74 63 68 2c 20 77 65 20 ns no match, we
0db0: 77 69 6c 6c 20 64 6f 20 6e 6f 20 71 75 65 72 79 will do no query
0dc0: 0a 09 20 20 20 20 23 66 0a 09 20 20 20 20 28 6c .. #f.. (l
0dd0: 65 74 20 6c 6f 6f 70 20 28 28 70 61 74 74 20 28 et loop ((patt (
0de0: 63 61 72 20 70 61 74 74 73 29 29 0a 09 09 20 20 car patts))...
0df0: 20 20 20 20 20 28 74 61 6c 20 20 28 63 64 72 20 (tal (cdr
0e00: 70 61 74 74 73 29 29 0a 09 09 20 20 20 20 20 20 patts))...
0e10: 20 28 72 65 73 20 20 27 28 29 29 29 0a 09 20 20 (res '()))..
0e20: 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 6c ;; (print "l
0e30: 6f 6f 70 3a 20 70 61 74 74 3a 20 22 20 70 61 74 oop: patt: " pat
0e40: 74 20 22 2c 20 74 61 6c 20 22 20 74 61 6c 29 0a t ", tal " tal).
0e50: 09 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 70 . (let* ((p
0e60: 61 74 74 2d 70 61 72 74 73 20 28 73 74 72 69 6e att-parts (strin
0e70: 67 2d 6d 61 74 63 68 20 28 72 65 67 65 78 70 20 g-match (regexp
0e80: 22 5e 28 5b 5e 5c 5c 2f 5d 2a 29 28 5c 5c 2f 28 "^([^\\/]*)(\\/(
0e90: 2e 2a 29 7c 29 24 22 29 20 70 61 74 74 29 29 0a .*)|)$") patt)).
0ea0: 09 09 20 20 20 20 20 28 74 65 73 74 2d 70 61 74 .. (test-pat
0eb0: 74 20 20 28 63 61 64 72 20 70 61 74 74 2d 70 61 t (cadr patt-pa
0ec0: 72 74 73 29 29 0a 09 09 20 20 20 20 20 28 69 74 rts))... (it
0ed0: 65 6d 2d 70 61 74 74 20 20 28 63 61 64 64 64 72 em-patt (cadddr
0ee0: 20 70 61 74 74 2d 70 61 72 74 73 29 29 0a 09 09 patt-parts))...
0ef0: 20 20 20 20 20 28 74 65 73 74 2d 71 72 79 20 20 (test-qry
0f00: 20 28 64 62 3a 70 61 74 74 2d 3e 6c 69 6b 65 20 (db:patt->like
0f10: 22 74 65 73 74 6e 61 6d 65 22 20 74 65 73 74 2d "testname" test-
0f20: 70 61 74 74 29 29 0a 09 09 20 20 20 20 20 28 69 patt))... (i
0f30: 74 65 6d 2d 71 72 79 20 20 20 28 64 62 3a 70 61 tem-qry (db:pa
0f40: 74 74 2d 3e 6c 69 6b 65 20 22 69 74 65 6d 5f 70 tt->like "item_p
0f50: 61 74 68 22 20 69 74 65 6d 2d 70 61 74 74 29 29 ath" item-patt))
0f60: 0a 09 09 20 20 20 20 20 28 71 72 79 20 20 20 20 ... (qry
0f70: 20 20 20 20 28 63 6f 6e 63 20 22 28 22 20 74 65 (conc "(" te
0f80: 73 74 2d 71 72 79 20 22 20 41 4e 44 20 22 20 69 st-qry " AND " i
0f90: 74 65 6d 2d 71 72 79 20 22 29 22 29 29 29 0a 09 tem-qry ")")))..
0fa0: 09 3b 3b 20 28 70 72 69 6e 74 20 22 74 65 73 74 .;; (print "test
0fb0: 73 3a 6d 61 74 63 68 20 3d 3e 20 70 61 74 74 2d s:match => patt-
0fc0: 70 61 72 74 73 3a 20 22 20 70 61 74 74 2d 70 61 parts: " patt-pa
0fd0: 72 74 73 20 22 2c 20 74 65 73 74 2d 70 61 74 74 rts ", test-patt
0fe0: 3a 20 22 20 74 65 73 74 2d 70 61 74 74 20 22 2c : " test-patt ",
0ff0: 20 69 74 65 6d 2d 70 61 74 74 3a 20 22 20 69 74 item-patt: " it
1000: 65 6d 2d 70 61 74 74 29 0a 09 09 28 69 66 20 28 em-patt)...(if (
1010: 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 20 20 20 null? tal)...
1020: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
1030: 65 72 73 65 20 28 61 70 70 65 6e 64 20 28 72 65 erse (append (re
1040: 76 65 72 73 65 20 72 65 73 29 28 6c 69 73 74 20 verse res)(list
1050: 71 72 79 29 29 20 22 20 4f 52 20 22 29 0a 09 09 qry)) " OR ")...
1060: 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 (loop (car t
1070: 61 6c 29 28 63 64 72 20 74 61 6c 29 28 63 6f 6e al)(cdr tal)(con
1080: 73 20 71 72 79 20 72 65 73 29 29 29 29 29 29 29 s qry res)))))))
1090: 0a 20 20 20 20 20 20 23 66 29 29 0a 0a 3b 3b 20 . #f))..;;
10a0: 67 65 74 20 74 68 65 20 70 72 65 76 69 6f 75 73 get the previous
10b0: 20 72 65 63 6f 72 64 20 66 6f 72 20 77 68 65 6e record for when
10c0: 20 74 68 69 73 20 74 65 73 74 20 77 61 73 20 72 this test was r
10d0: 75 6e 20 77 68 65 72 65 20 61 6c 6c 20 6b 65 79 un where all key
10e0: 73 20 6d 61 74 63 68 20 62 75 74 20 72 75 6e 6e s match but runn
10f0: 61 6d 65 0a 3b 3b 20 72 65 74 75 72 6e 73 20 23 ame.;; returns #
1100: 66 20 69 66 20 6e 6f 20 73 75 63 68 20 74 65 73 f if no such tes
1110: 74 20 66 6f 75 6e 64 2c 20 72 65 74 75 72 6e 73 t found, returns
1120: 20 61 20 73 69 6e 67 6c 65 20 74 65 73 74 20 72 a single test r
1130: 65 63 6f 72 64 20 69 66 20 66 6f 75 6e 64 0a 28 ecord if found.(
1140: 64 65 66 69 6e 65 20 28 74 65 73 74 3a 67 65 74 define (test:get
1150: 2d 70 72 65 76 69 6f 75 73 2d 74 65 73 74 2d 72 -previous-test-r
1160: 75 6e 2d 72 65 63 6f 72 64 20 64 62 20 72 75 6e un-record db run
1170: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 -id test-name it
1180: 65 6d 2d 70 61 74 68 29 0a 20 20 28 6c 65 74 2a em-path). (let*
1190: 20 28 28 6b 65 79 73 20 20 20 20 28 63 64 62 3a ((keys (cdb:
11a0: 72 65 6d 6f 74 65 2d 72 75 6e 20 64 62 3a 67 65 remote-run db:ge
11b0: 74 2d 6b 65 79 73 20 23 66 29 29 0a 09 20 28 73 t-keys #f)).. (s
11c0: 65 6c 73 74 72 20 20 28 73 74 72 69 6e 67 2d 69 elstr (string-i
11d0: 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 20 ntersperse (map
11e0: 28 6c 61 6d 62 64 61 20 28 78 29 28 76 65 63 74 (lambda (x)(vect
11f0: 6f 72 2d 72 65 66 20 78 20 30 29 29 20 6b 65 79 or-ref x 0)) key
1200: 73 29 20 22 2c 22 29 29 0a 09 20 28 71 72 79 73 s) ",")).. (qrys
1210: 74 72 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 tr (string-inte
1220: 72 73 70 65 72 73 65 20 28 6d 61 70 20 28 6c 61 rsperse (map (la
1230: 6d 62 64 61 20 28 78 29 28 63 6f 6e 63 20 28 76 mbda (x)(conc (v
1240: 65 63 74 6f 72 2d 72 65 66 20 78 20 30 29 20 22 ector-ref x 0) "
1250: 3d 3f 22 29 29 20 6b 65 79 73 29 20 22 20 41 4e =?")) keys) " AN
1260: 44 20 22 29 29 0a 09 20 28 6b 65 79 76 61 6c 73 D ")).. (keyvals
1270: 20 23 66 29 29 0a 20 20 20 20 3b 3b 20 66 69 72 #f)). ;; fir
1280: 73 74 20 6c 6f 6f 6b 20 75 70 20 74 68 65 20 6b st look up the k
1290: 65 79 20 76 61 6c 75 65 73 20 66 72 6f 6d 20 74 ey values from t
12a0: 68 65 20 72 75 6e 20 73 65 6c 65 63 74 65 64 20 he run selected
12b0: 62 79 20 72 75 6e 2d 69 64 0a 20 20 20 20 28 73 by run-id. (s
12c0: 71 6c 69 74 65 33 3a 66 6f 72 2d 65 61 63 68 2d qlite3:for-each-
12d0: 72 6f 77 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 row . (lambd
12e0: 61 20 28 61 20 2e 20 62 29 0a 20 20 20 20 20 20 a (a . b).
12f0: 20 28 73 65 74 21 20 6b 65 79 76 61 6c 73 20 28 (set! keyvals (
1300: 63 6f 6e 73 20 61 20 62 29 29 29 0a 20 20 20 20 cons a b))).
1310: 20 64 62 0a 20 20 20 20 20 28 63 6f 6e 63 20 22 db. (conc "
1320: 53 45 4c 45 43 54 20 22 20 73 65 6c 73 74 72 20 SELECT " selstr
1330: 22 20 46 52 4f 4d 20 72 75 6e 73 20 57 48 45 52 " FROM runs WHER
1340: 45 20 69 64 3d 3f 20 4f 52 44 45 52 20 42 59 20 E id=? ORDER BY
1350: 65 76 65 6e 74 5f 74 69 6d 65 20 44 45 53 43 3b event_time DESC;
1360: 22 29 20 72 75 6e 2d 69 64 29 0a 20 20 20 20 28 ") run-id). (
1370: 69 66 20 28 6e 6f 74 20 6b 65 79 76 61 6c 73 29 if (not keyvals)
1380: 0a 09 23 66 0a 09 28 6c 65 74 20 28 28 70 72 65 ..#f..(let ((pre
1390: 76 2d 72 75 6e 2d 69 64 73 20 27 28 29 29 29 0a v-run-ids '())).
13a0: 09 20 20 28 61 70 70 6c 79 20 73 71 6c 69 74 65 . (apply sqlite
13b0: 33 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 0a 09 3:for-each-row..
13c0: 09 20 28 6c 61 6d 62 64 61 20 28 69 64 29 0a 09 . (lambda (id)..
13d0: 09 20 20 20 28 73 65 74 21 20 70 72 65 76 2d 72 . (set! prev-r
13e0: 75 6e 2d 69 64 73 20 28 63 6f 6e 73 20 69 64 20 un-ids (cons id
13f0: 70 72 65 76 2d 72 75 6e 2d 69 64 73 29 29 29 0a prev-run-ids))).
1400: 09 09 20 64 62 0a 09 09 20 28 63 6f 6e 63 20 22 .. db... (conc "
1410: 53 45 4c 45 43 54 20 69 64 20 46 52 4f 4d 20 72 SELECT id FROM r
1420: 75 6e 73 20 57 48 45 52 45 20 22 20 71 72 79 73 uns WHERE " qrys
1430: 74 72 20 22 20 41 4e 44 20 69 64 20 21 3d 20 3f tr " AND id != ?
1440: 3b 22 29 20 28 61 70 70 65 6e 64 20 6b 65 79 76 ;") (append keyv
1450: 61 6c 73 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 als (list run-id
1460: 29 29 29 0a 09 20 20 3b 3b 20 66 6f 72 20 65 61 ))).. ;; for ea
1470: 63 68 20 72 75 6e 20 73 74 61 72 74 69 6e 67 20 ch run starting
1480: 77 69 74 68 20 74 68 65 20 6d 6f 73 74 20 72 65 with the most re
1490: 63 65 6e 74 20 6c 6f 6f 6b 20 74 6f 20 73 65 65 cent look to see
14a0: 20 69 66 20 74 68 65 72 65 20 69 73 20 61 20 6d if there is a m
14b0: 61 74 63 68 69 6e 67 20 74 65 73 74 0a 09 20 20 atching test..
14c0: 3b 3b 20 69 66 20 66 6f 75 6e 64 20 74 68 65 6e ;; if found then
14d0: 20 72 65 74 75 72 6e 20 74 68 61 74 20 6d 61 74 return that mat
14e0: 63 68 69 6e 67 20 74 65 73 74 20 72 65 63 6f 72 ching test recor
14f0: 64 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e d.. (debug:prin
1500: 74 20 34 20 22 73 65 6c 73 74 72 3a 20 22 20 73 t 4 "selstr: " s
1510: 65 6c 73 74 72 20 22 2c 20 71 72 79 73 74 72 3a elstr ", qrystr:
1520: 20 22 20 71 72 79 73 74 72 20 22 2c 20 6b 65 79 " qrystr ", key
1530: 76 61 6c 73 3a 20 22 20 6b 65 79 76 61 6c 73 20 vals: " keyvals
1540: 22 2c 20 70 72 65 76 69 6f 75 73 20 72 75 6e 20 ", previous run
1550: 69 64 73 20 66 6f 75 6e 64 3a 20 22 20 70 72 65 ids found: " pre
1560: 76 2d 72 75 6e 2d 69 64 73 29 0a 09 20 20 28 69 v-run-ids).. (i
1570: 66 20 28 6e 75 6c 6c 3f 20 70 72 65 76 2d 72 75 f (null? prev-ru
1580: 6e 2d 69 64 73 29 20 23 66 0a 09 20 20 20 20 20 n-ids) #f..
1590: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 (let loop ((hed
15a0: 20 28 63 61 72 20 70 72 65 76 2d 72 75 6e 2d 69 (car prev-run-i
15b0: 64 73 29 29 0a 09 09 09 20 28 74 61 6c 20 28 63 ds)).... (tal (c
15c0: 64 72 20 70 72 65 76 2d 72 75 6e 2d 69 64 73 29 dr prev-run-ids)
15d0: 29 29 0a 09 09 28 6c 65 74 20 28 28 72 65 73 75 ))...(let ((resu
15e0: 6c 74 73 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d lts (cdb:remote-
15f0: 72 75 6e 20 64 62 3a 67 65 74 2d 74 65 73 74 73 run db:get-tests
1600: 2d 66 6f 72 2d 72 75 6e 20 23 66 20 68 65 64 20 -for-run #f hed
1610: 28 63 6f 6e 63 20 74 65 73 74 2d 6e 61 6d 65 20 (conc test-name
1620: 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 27 28 "/" item-path)'(
1630: 29 20 27 28 29 29 29 29 0a 09 09 20 20 28 64 65 ) '())))... (de
1640: 62 75 67 3a 70 72 69 6e 74 20 34 20 22 47 6f 74 bug:print 4 "Got
1650: 20 74 65 73 74 73 20 66 6f 72 20 72 75 6e 2d 69 tests for run-i
1660: 64 20 22 20 72 75 6e 2d 69 64 20 22 2c 20 74 65 d " run-id ", te
1670: 73 74 2d 6e 61 6d 65 20 22 20 74 65 73 74 2d 6e st-name " test-n
1680: 61 6d 65 20 22 2c 20 69 74 65 6d 2d 70 61 74 68 ame ", item-path
1690: 20 22 20 69 74 65 6d 2d 70 61 74 68 20 22 3a 20 " item-path ":
16a0: 22 20 72 65 73 75 6c 74 73 29 0a 09 09 20 20 28 " results)... (
16b0: 69 66 20 28 61 6e 64 20 28 6e 75 6c 6c 3f 20 72 if (and (null? r
16c0: 65 73 75 6c 74 73 29 0a 09 09 09 20 20 20 28 6e esults).... (n
16d0: 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 29 ot (null? tal)))
16e0: 0a 09 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 ... (loop (
16f0: 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c car tal)(cdr tal
1700: 29 29 0a 09 09 20 20 20 20 20 20 28 69 66 20 28 ))... (if (
1710: 6e 75 6c 6c 3f 20 72 65 73 75 6c 74 73 29 20 23 null? results) #
1720: 66 0a 09 09 09 20 20 28 63 61 72 20 72 65 73 75 f.... (car resu
1730: 6c 74 73 29 29 29 29 29 29 29 29 29 29 0a 20 20 lts)))))))))).
1740: 20 20 0a 3b 3b 20 67 65 74 20 74 68 65 20 70 72 .;; get the pr
1750: 65 76 69 6f 75 73 20 72 65 63 6f 72 64 73 20 66 evious records f
1760: 6f 72 20 77 68 65 6e 20 74 68 65 73 65 20 74 65 or when these te
1770: 73 74 73 20 77 65 72 65 20 72 75 6e 20 77 68 65 sts were run whe
1780: 72 65 20 61 6c 6c 20 6b 65 79 73 20 6d 61 74 63 re all keys matc
1790: 68 20 62 75 74 20 72 75 6e 6e 61 6d 65 0a 3b 3b h but runname.;;
17a0: 20 4e 42 2f 2f 20 4d 65 72 67 65 20 74 68 69 73 NB// Merge this
17b0: 20 77 69 74 68 20 74 65 73 74 3a 67 65 74 2d 70 with test:get-p
17c0: 72 65 76 69 6f 75 73 2d 74 65 73 74 2d 72 75 6e revious-test-run
17d0: 2d 72 65 63 6f 72 64 73 3f 20 54 68 69 73 20 6f -records? This o
17e0: 6e 65 20 6c 6f 6f 6b 73 20 66 6f 72 20 61 6c 6c ne looks for all
17f0: 20 6d 61 74 63 68 69 6e 67 20 74 65 73 74 73 0a matching tests.
1800: 3b 3b 20 63 61 6e 20 75 73 65 20 77 69 6c 64 63 ;; can use wildc
1810: 61 72 64 73 2e 20 41 6c 73 6f 20 63 61 6e 20 6c ards. Also can l
1820: 69 6b 65 6c 79 20 62 65 20 66 61 63 74 6f 72 65 ikely be factore
1830: 64 20 69 6e 20 77 69 74 68 20 67 65 74 20 74 65 d in with get te
1840: 73 74 20 70 61 74 68 73 3f 0a 28 64 65 66 69 6e st paths?.(defin
1850: 65 20 28 74 65 73 74 3a 67 65 74 2d 6d 61 74 63 e (test:get-matc
1860: 68 69 6e 67 2d 70 72 65 76 69 6f 75 73 2d 74 65 hing-previous-te
1870: 73 74 2d 72 75 6e 2d 72 65 63 6f 72 64 73 20 64 st-run-records d
1880: 62 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 b run-id test-na
1890: 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 0a 20 20 me item-path).
18a0: 28 6c 65 74 2a 20 28 28 6b 65 79 73 20 20 20 20 (let* ((keys
18b0: 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 (cdb:remote-run
18c0: 64 62 3a 67 65 74 2d 6b 65 79 73 20 23 66 29 29 db:get-keys #f))
18d0: 0a 09 20 28 73 65 6c 73 74 72 20 20 28 73 74 72 .. (selstr (str
18e0: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
18f0: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 78 29 (map (lambda (x)
1900: 28 76 65 63 74 6f 72 2d 72 65 66 20 78 20 30 29 (vector-ref x 0)
1910: 29 20 6b 65 79 73 29 20 22 2c 22 29 29 0a 09 20 ) keys) ","))..
1920: 28 71 72 79 73 74 72 20 20 28 73 74 72 69 6e 67 (qrystr (string
1930: 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 -intersperse (ma
1940: 70 20 28 6c 61 6d 62 64 61 20 28 78 29 28 63 6f p (lambda (x)(co
1950: 6e 63 20 28 76 65 63 74 6f 72 2d 72 65 66 20 78 nc (vector-ref x
1960: 20 30 29 20 22 3d 3f 22 29 29 20 6b 65 79 73 29 0) "=?")) keys)
1970: 20 22 20 41 4e 44 20 22 29 29 0a 09 20 28 6b 65 " AND ")).. (ke
1980: 79 76 61 6c 73 20 23 66 29 0a 09 20 28 74 65 73 yvals #f).. (tes
1990: 74 73 2d 68 61 73 68 20 28 6d 61 6b 65 2d 68 61 ts-hash (make-ha
19a0: 73 68 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 20 sh-table))).
19b0: 3b 3b 20 66 69 72 73 74 20 6c 6f 6f 6b 20 75 70 ;; first look up
19c0: 20 74 68 65 20 6b 65 79 20 76 61 6c 75 65 73 20 the key values
19d0: 66 72 6f 6d 20 74 68 65 20 72 75 6e 20 73 65 6c from the run sel
19e0: 65 63 74 65 64 20 62 79 20 72 75 6e 2d 69 64 0a ected by run-id.
19f0: 20 20 20 20 28 73 71 6c 69 74 65 33 3a 66 6f 72 (sqlite3:for
1a00: 2d 65 61 63 68 2d 72 6f 77 20 0a 20 20 20 20 20 -each-row .
1a10: 28 6c 61 6d 62 64 61 20 28 61 20 2e 20 62 29 0a (lambda (a . b).
1a20: 20 20 20 20 20 20 20 28 73 65 74 21 20 6b 65 79 (set! key
1a30: 76 61 6c 73 20 28 63 6f 6e 73 20 61 20 62 29 29 vals (cons a b))
1a40: 29 0a 20 20 20 20 20 64 62 0a 20 20 20 20 20 28 ). db. (
1a50: 63 6f 6e 63 20 22 53 45 4c 45 43 54 20 22 20 73 conc "SELECT " s
1a60: 65 6c 73 74 72 20 22 20 46 52 4f 4d 20 72 75 6e elstr " FROM run
1a70: 73 20 57 48 45 52 45 20 69 64 3d 3f 20 4f 52 44 s WHERE id=? ORD
1a80: 45 52 20 42 59 20 65 76 65 6e 74 5f 74 69 6d 65 ER BY event_time
1a90: 20 44 45 53 43 3b 22 29 20 72 75 6e 2d 69 64 29 DESC;") run-id)
1aa0: 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 6b 65 . (if (not ke
1ab0: 79 76 61 6c 73 29 0a 09 27 28 29 0a 09 28 6c 65 yvals)..'()..(le
1ac0: 74 20 28 28 70 72 65 76 2d 72 75 6e 2d 69 64 73 t ((prev-run-ids
1ad0: 20 27 28 29 29 29 0a 09 20 20 28 61 70 70 6c 79 '())).. (apply
1ae0: 20 73 71 6c 69 74 65 33 3a 66 6f 72 2d 65 61 63 sqlite3:for-eac
1af0: 68 2d 72 6f 77 0a 09 09 20 28 6c 61 6d 62 64 61 h-row... (lambda
1b00: 20 28 69 64 29 0a 09 09 20 20 20 28 73 65 74 21 (id)... (set!
1b10: 20 70 72 65 76 2d 72 75 6e 2d 69 64 73 20 28 63 prev-run-ids (c
1b20: 6f 6e 73 20 69 64 20 70 72 65 76 2d 72 75 6e 2d ons id prev-run-
1b30: 69 64 73 29 29 29 0a 09 09 20 64 62 0a 09 09 20 ids)))... db...
1b40: 28 63 6f 6e 63 20 22 53 45 4c 45 43 54 20 69 64 (conc "SELECT id
1b50: 20 46 52 4f 4d 20 72 75 6e 73 20 57 48 45 52 45 FROM runs WHERE
1b60: 20 22 20 71 72 79 73 74 72 20 22 20 41 4e 44 20 " qrystr " AND
1b70: 69 64 20 21 3d 20 3f 3b 22 29 20 28 61 70 70 65 id != ?;") (appe
1b80: 6e 64 20 6b 65 79 76 61 6c 73 20 28 6c 69 73 74 nd keyvals (list
1b90: 20 72 75 6e 2d 69 64 29 29 29 0a 09 20 20 3b 3b run-id))).. ;;
1ba0: 20 63 6f 6c 6c 65 63 74 20 61 6c 6c 20 6d 61 74 collect all mat
1bb0: 63 68 69 6e 67 20 74 65 73 74 73 20 66 6f 72 20 ching tests for
1bc0: 74 68 65 20 72 75 6e 73 20 74 68 65 6e 0a 09 20 the runs then..
1bd0: 20 3b 3b 20 65 78 74 72 61 63 74 20 74 68 65 20 ;; extract the
1be0: 6d 6f 73 74 20 72 65 63 65 6e 74 20 74 65 73 74 most recent test
1bf0: 20 61 6e 64 20 72 65 74 75 72 6e 20 74 68 61 74 and return that
1c00: 2e 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e ... (debug:prin
1c10: 74 20 34 20 22 73 65 6c 73 74 72 3a 20 22 20 73 t 4 "selstr: " s
1c20: 65 6c 73 74 72 20 22 2c 20 71 72 79 73 74 72 3a elstr ", qrystr:
1c30: 20 22 20 71 72 79 73 74 72 20 22 2c 20 6b 65 79 " qrystr ", key
1c40: 76 61 6c 73 3a 20 22 20 6b 65 79 76 61 6c 73 20 vals: " keyvals
1c50: 0a 09 09 20 20 20 20 20 20 20 22 2c 20 70 72 65 ... ", pre
1c60: 76 69 6f 75 73 20 72 75 6e 20 69 64 73 20 66 6f vious run ids fo
1c70: 75 6e 64 3a 20 22 20 70 72 65 76 2d 72 75 6e 2d und: " prev-run-
1c80: 69 64 73 29 0a 09 20 20 28 69 66 20 28 6e 75 6c ids).. (if (nul
1c90: 6c 3f 20 70 72 65 76 2d 72 75 6e 2d 69 64 73 29 l? prev-run-ids)
1ca0: 20 27 28 29 20 20 3b 3b 20 6e 6f 20 70 72 65 76 '() ;; no prev
1cb0: 69 6f 75 73 20 72 75 6e 73 3f 20 72 65 74 75 72 ious runs? retur
1cc0: 6e 20 6e 75 6c 6c 0a 09 20 20 20 20 20 20 28 6c n null.. (l
1cd0: 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 et loop ((hed (c
1ce0: 61 72 20 70 72 65 76 2d 72 75 6e 2d 69 64 73 29 ar prev-run-ids)
1cf0: 29 0a 09 09 09 20 28 74 61 6c 20 28 63 64 72 20 ).... (tal (cdr
1d00: 70 72 65 76 2d 72 75 6e 2d 69 64 73 29 29 29 0a prev-run-ids))).
1d10: 09 09 28 6c 65 74 20 28 28 72 65 73 75 6c 74 73 ..(let ((results
1d20: 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e (cdb:remote-run
1d30: 20 64 62 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f db:get-tests-fo
1d40: 72 2d 72 75 6e 20 23 66 20 68 65 64 20 28 63 6f r-run #f hed (co
1d50: 6e 63 20 74 65 73 74 2d 6e 61 6d 65 20 22 2f 22 nc test-name "/"
1d60: 20 69 74 65 6d 2d 70 61 74 68 29 20 27 28 29 20 item-path) '()
1d70: 27 28 29 29 29 29 0a 09 09 20 20 28 64 65 62 75 '())))... (debu
1d80: 67 3a 70 72 69 6e 74 20 34 20 22 47 6f 74 20 74 g:print 4 "Got t
1d90: 65 73 74 73 20 66 6f 72 20 72 75 6e 2d 69 64 20 ests for run-id
1da0: 22 20 72 75 6e 2d 69 64 20 22 2c 20 74 65 73 74 " run-id ", test
1db0: 2d 6e 61 6d 65 20 22 20 74 65 73 74 2d 6e 61 6d -name " test-nam
1dc0: 65 20 0a 09 09 09 20 20 20 20 20 20 20 22 2c 20 e .... ",
1dd0: 69 74 65 6d 2d 70 61 74 68 20 22 20 69 74 65 6d item-path " item
1de0: 2d 70 61 74 68 20 22 20 72 65 73 75 6c 74 73 3a -path " results:
1df0: 20 22 20 28 69 6e 74 65 72 73 70 65 72 73 65 20 " (intersperse
1e00: 72 65 73 75 6c 74 73 20 22 5c 6e 22 29 29 0a 09 results "\n"))..
1e10: 09 20 20 3b 3b 20 4b 65 65 70 20 6f 6e 6c 79 20 . ;; Keep only
1e20: 74 68 65 20 79 6f 75 6e 67 65 73 74 20 6f 66 20 the youngest of
1e30: 61 6e 79 20 74 65 73 74 2f 69 74 65 6d 20 63 6f any test/item co
1e40: 6d 62 69 6e 61 74 69 6f 6e 0a 09 09 20 20 28 66 mbination... (f
1e50: 6f 72 2d 65 61 63 68 20 0a 09 09 20 20 20 28 6c or-each ... (l
1e60: 61 6d 62 64 61 20 28 74 65 73 74 64 61 74 29 0a ambda (testdat).
1e70: 09 09 20 20 20 20 20 28 6c 65 74 2a 20 28 28 66 .. (let* ((f
1e80: 75 6c 6c 2d 74 65 73 74 6e 61 6d 65 20 28 63 6f ull-testname (co
1e90: 6e 63 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d nc (db:test-get-
1ea0: 74 65 73 74 6e 61 6d 65 20 74 65 73 74 64 61 74 testname testdat
1eb0: 29 20 22 2f 22 20 28 64 62 3a 74 65 73 74 2d 67 ) "/" (db:test-g
1ec0: 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 65 73 et-item-path tes
1ed0: 74 64 61 74 29 29 29 0a 09 09 09 20 20 20 20 28 tdat))).... (
1ee0: 73 74 6f 72 65 64 2d 74 65 73 74 20 20 20 28 68 stored-test (h
1ef0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
1f00: 66 61 75 6c 74 20 74 65 73 74 73 2d 68 61 73 68 fault tests-hash
1f10: 20 66 75 6c 6c 2d 74 65 73 74 6e 61 6d 65 20 23 full-testname #
1f20: 66 29 29 29 0a 09 09 20 20 20 20 20 20 20 28 69 f)))... (i
1f30: 66 20 28 6f 72 20 28 6e 6f 74 20 73 74 6f 72 65 f (or (not store
1f40: 64 2d 74 65 73 74 29 0a 09 09 09 20 20 20 20 20 d-test)....
1f50: 20 20 28 61 6e 64 20 73 74 6f 72 65 64 2d 74 65 (and stored-te
1f60: 73 74 0a 09 09 09 09 20 20 20 20 28 3e 20 28 64 st..... (> (d
1f70: 62 3a 74 65 73 74 2d 67 65 74 2d 65 76 65 6e 74 b:test-get-event
1f80: 5f 74 69 6d 65 20 74 65 73 74 64 61 74 29 28 64 _time testdat)(d
1f90: 62 3a 74 65 73 74 2d 67 65 74 2d 65 76 65 6e 74 b:test-get-event
1fa0: 5f 74 69 6d 65 20 73 74 6f 72 65 64 2d 74 65 73 _time stored-tes
1fb0: 74 29 29 29 29 0a 09 09 09 20 20 20 3b 3b 20 74 t)))).... ;; t
1fc0: 68 69 73 20 74 65 73 74 20 69 73 20 79 6f 75 6e his test is youn
1fd0: 67 65 72 2c 20 73 74 6f 72 65 20 69 74 20 69 6e ger, store it in
1fe0: 20 74 68 65 20 68 61 73 68 0a 09 09 09 20 20 20 the hash....
1ff0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
2000: 20 74 65 73 74 73 2d 68 61 73 68 20 66 75 6c 6c tests-hash full
2010: 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 64 61 -testname testda
2020: 74 29 29 29 29 0a 09 09 20 20 20 72 65 73 75 6c t))))... resul
2030: 74 73 29 0a 09 09 20 20 28 69 66 20 28 6e 75 6c ts)... (if (nul
2040: 6c 3f 20 74 61 6c 29 0a 09 09 20 20 20 20 20 20 l? tal)...
2050: 28 6d 61 70 20 63 64 72 20 28 68 61 73 68 2d 74 (map cdr (hash-t
2060: 61 62 6c 65 2d 3e 61 6c 69 73 74 20 74 65 73 74 able->alist test
2070: 73 2d 68 61 73 68 29 29 20 3b 3b 20 72 65 74 75 s-hash)) ;; retu
2080: 72 6e 20 61 20 6c 69 73 74 20 6f 66 20 74 68 65 rn a list of the
2090: 20 6d 6f 73 74 20 72 65 63 65 6e 74 20 74 65 73 most recent tes
20a0: 74 73 0a 09 09 20 20 20 20 20 20 28 6c 6f 6f 70 ts... (loop
20b0: 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 (car tal)(cdr t
20c0: 61 6c 29 29 29 29 29 29 29 29 29 29 0a 0a 3b 3b al))))))))))..;;
20d0: 20 43 68 65 63 6b 20 66 6f 72 20 77 61 69 76 65 Check for waive
20e0: 72 20 65 6c 69 67 69 62 69 6c 69 74 79 0a 3b 3b r eligibility.;;
20f0: 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a .(define (tests:
2100: 63 68 65 63 6b 2d 77 61 69 76 65 72 2d 65 6c 69 check-waiver-eli
2110: 67 69 62 69 6c 69 74 79 20 74 65 73 74 64 61 74 gibility testdat
2120: 20 70 72 65 76 2d 74 65 73 74 64 61 74 29 0a 20 prev-testdat).
2130: 20 28 6c 65 74 2a 20 28 28 74 65 73 74 63 6f 6e (let* ((testcon
2140: 66 69 67 20 20 28 74 65 73 74 73 3a 67 65 74 2d fig (tests:get-
2150: 74 65 73 74 63 6f 6e 66 69 67 20 28 64 62 3a 74 testconfig (db:t
2160: 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 est-get-testname
2170: 20 74 65 73 74 64 61 74 29 20 23 66 29 29 0a 09 testdat) #f))..
2180: 20 28 74 65 73 74 2d 72 75 6e 64 69 72 20 28 64 (test-rundir (d
2190: 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 b:test-get-rundi
21a0: 72 20 74 65 73 74 64 61 74 29 29 0a 09 20 28 70 r testdat)).. (p
21b0: 72 65 76 2d 72 75 6e 64 69 72 20 28 64 62 3a 74 rev-rundir (db:t
21c0: 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 20 70 est-get-rundir p
21d0: 72 65 76 2d 74 65 73 74 64 61 74 29 29 0a 09 20 rev-testdat))..
21e0: 28 77 61 69 76 65 72 73 20 20 20 20 20 28 63 6f (waivers (co
21f0: 6e 66 69 67 66 3a 73 65 63 74 69 6f 6e 2d 76 61 nfigf:section-va
2200: 72 73 20 74 65 73 74 63 6f 6e 66 69 67 20 22 77 rs testconfig "w
2210: 61 69 76 65 72 73 22 29 29 0a 09 20 28 77 61 69 aivers")).. (wai
2220: 76 65 72 2d 72 78 20 20 20 28 72 65 67 65 78 70 ver-rx (regexp
2230: 20 22 5e 28 5c 5c 53 2b 29 5c 5c 73 2b 28 2e 2a "^(\\S+)\\s+(.*
2240: 29 24 22 29 29 0a 09 20 28 64 69 66 66 2d 72 75 )$")).. (diff-ru
2250: 6c 65 20 20 20 22 64 69 66 66 20 25 66 69 6c 65 le "diff %file
2260: 31 25 20 25 66 69 6c 65 32 25 22 29 0a 09 20 28 1% %file2%").. (
2270: 6c 6f 67 70 72 6f 2d 72 75 6c 65 20 22 64 69 66 logpro-rule "dif
2280: 66 20 25 66 69 6c 65 31 25 20 25 66 69 6c 65 32 f %file1% %file2
2290: 25 20 7c 20 6c 6f 67 70 72 6f 20 25 77 61 69 76 % | logpro %waiv
22a0: 65 72 6e 61 6d 65 25 2e 6c 6f 67 70 72 6f 20 25 ername%.logpro %
22b0: 77 61 69 76 65 72 6e 61 6d 65 25 2e 68 74 6d 6c waivername%.html
22c0: 22 29 29 0a 20 20 20 20 28 70 75 73 68 2d 64 69 ")). (push-di
22d0: 72 65 63 74 6f 72 79 20 74 65 73 74 2d 72 75 6e rectory test-run
22e0: 64 69 72 29 0a 20 20 20 20 28 6c 65 74 20 28 28 dir). (let ((
22f0: 72 65 73 75 6c 74 20 28 69 66 20 28 6e 75 6c 6c result (if (null
2300: 3f 20 77 61 69 76 65 72 73 29 0a 09 09 20 20 20 ? waivers)...
2310: 20 20 20 23 66 0a 09 09 20 20 20 20 20 20 28 6c #f... (l
2320: 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 et loop ((hed (c
2330: 61 72 20 77 61 69 76 65 72 73 29 29 0a 09 09 09 ar waivers))....
2340: 09 20 28 74 61 6c 20 28 63 64 72 20 77 61 69 76 . (tal (cdr waiv
2350: 65 72 73 29 29 29 0a 09 09 09 28 64 65 62 75 67 ers)))....(debug
2360: 3a 70 72 69 6e 74 20 30 20 22 49 4e 46 4f 3a 20 :print 0 "INFO:
2370: 41 70 70 6c 79 69 6e 67 20 77 61 69 76 65 72 20 Applying waiver
2380: 72 75 6c 65 20 5c 22 22 20 68 65 64 20 22 5c 22 rule \"" hed "\"
2390: 22 29 0a 09 09 09 28 6c 65 74 2a 20 28 28 77 61 ")....(let* ((wa
23a0: 69 76 65 72 20 20 20 20 20 20 28 63 6f 6e 66 69 iver (confi
23b0: 67 66 3a 6c 6f 6f 6b 75 70 20 74 65 73 74 63 6f gf:lookup testco
23c0: 6e 66 69 67 20 22 77 61 69 76 65 72 73 22 20 68 nfig "waivers" h
23d0: 65 64 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 ed)).... (
23e0: 77 70 61 72 74 73 20 20 20 20 20 20 28 69 66 20 wparts (if
23f0: 77 61 69 76 65 72 20 28 73 74 72 69 6e 67 2d 6d waiver (string-m
2400: 61 74 63 68 20 77 61 69 76 65 72 2d 72 78 20 77 atch waiver-rx w
2410: 61 69 76 65 72 29 20 23 66 29 29 0a 09 09 09 20 aiver) #f))....
2420: 20 20 20 20 20 20 28 77 61 69 76 65 72 2d 72 75 (waiver-ru
2430: 6c 65 20 28 69 66 20 77 70 61 72 74 73 20 28 63 le (if wparts (c
2440: 61 64 72 20 77 70 61 72 74 73 29 20 20 23 66 29 adr wparts) #f)
2450: 29 0a 09 09 09 20 20 20 20 20 20 20 28 77 61 69 ).... (wai
2460: 76 65 72 2d 67 6c 6f 62 20 28 69 66 20 77 70 61 ver-glob (if wpa
2470: 72 74 73 20 28 63 61 64 64 72 20 77 70 61 72 74 rts (caddr wpart
2480: 73 29 20 23 66 29 29 0a 09 09 09 20 20 20 20 20 s) #f))....
2490: 20 20 28 6c 6f 67 70 72 6f 2d 66 69 6c 65 20 28 (logpro-file (
24a0: 69 66 20 77 61 69 76 65 72 0a 09 09 09 09 09 09 if waiver.......
24b0: 28 6c 65 74 20 28 28 66 6e 61 6d 65 20 28 63 6f (let ((fname (co
24c0: 6e 63 20 68 65 64 20 22 2e 6c 6f 67 70 72 6f 22 nc hed ".logpro"
24d0: 29 29 29 0a 09 09 09 09 09 09 20 20 28 69 66 20 )))....... (if
24e0: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 66 6e (file-exists? fn
24f0: 61 6d 65 29 0a 09 09 09 09 09 09 20 20 20 20 20 ame).......
2500: 20 66 6e 61 6d 65 20 0a 09 09 09 09 09 09 20 20 fname .......
2510: 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 09 09 (begin......
2520: 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 ..(debug:print 0
2530: 20 22 49 4e 46 4f 3a 20 4e 6f 20 6c 6f 67 70 72 "INFO: No logpr
2540: 6f 20 66 69 6c 65 20 22 20 66 6e 61 6d 65 20 22 o file " fname "
2550: 20 66 61 6c 6c 69 6e 67 20 62 61 63 6b 20 74 6f falling back to
2560: 20 64 69 66 66 22 29 0a 09 09 09 09 09 09 09 23 diff")........#
2570: 66 29 29 29 0a 09 09 09 09 09 09 23 66 29 29 0a f))).......#f)).
2580: 09 09 09 20 20 20 20 20 20 20 3b 3b 20 69 66 20 ... ;; if
2590: 72 75 6c 65 20 62 79 20 6e 61 6d 65 20 6f 66 20 rule by name of
25a0: 77 61 69 76 65 72 2d 72 75 6c 65 20 69 73 20 66 waiver-rule is f
25b0: 6f 75 6e 64 20 69 6e 20 74 65 73 74 63 6f 6e 66 ound in testconf
25c0: 69 67 20 2d 20 75 73 65 20 69 74 0a 09 09 09 20 ig - use it....
25d0: 20 20 20 20 20 20 3b 3b 20 65 6c 73 65 20 69 66 ;; else if
25e0: 20 77 61 69 76 65 72 6e 61 6d 65 2e 6c 6f 67 70 waivername.logp
25f0: 72 6f 20 65 78 69 73 74 73 20 75 73 65 20 6c 6f ro exists use lo
2600: 67 70 72 6f 2d 72 75 6c 65 0a 09 09 09 20 20 20 gpro-rule....
2610: 20 20 20 20 3b 3b 20 65 6c 73 65 20 64 65 66 61 ;; else defa
2620: 75 6c 74 20 74 6f 20 64 69 66 66 2d 72 75 6c 65 ult to diff-rule
2630: 0a 09 09 09 20 20 20 20 20 20 20 28 72 75 6c 65 .... (rule
2640: 2d 73 74 72 69 6e 67 20 28 6c 65 74 20 28 28 72 -string (let ((r
2650: 75 6c 65 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f ule (configf:loo
2660: 6b 75 70 20 74 65 73 74 63 6f 6e 66 69 67 20 22 kup testconfig "
2670: 77 61 69 76 65 72 5f 72 75 6c 65 73 22 20 77 61 waiver_rules" wa
2680: 69 76 65 72 2d 72 75 6c 65 29 29 29 0a 09 09 09 iver-rule)))....
2690: 09 09 20 20 20 20 20 20 28 69 66 20 72 75 6c 65 .. (if rule
26a0: 0a 09 09 09 09 09 09 20 20 72 75 6c 65 0a 09 09 ....... rule...
26b0: 09 09 09 09 20 20 28 69 66 20 6c 6f 67 70 72 6f .... (if logpro
26c0: 2d 66 69 6c 65 0a 09 09 09 09 09 09 20 20 20 20 -file.......
26d0: 20 20 6c 6f 67 70 72 6f 2d 72 75 6c 65 0a 09 09 logpro-rule...
26e0: 09 09 09 09 20 20 20 20 20 20 28 62 65 67 69 6e .... (begin
26f0: 0a 09 09 09 09 09 09 09 28 64 65 62 75 67 3a 70 ........(debug:p
2700: 72 69 6e 74 20 30 20 22 49 4e 46 4f 3a 20 4e 6f rint 0 "INFO: No
2710: 20 6c 6f 67 70 72 6f 20 66 69 6c 65 20 22 20 6c logpro file " l
2720: 6f 67 70 72 6f 2d 66 69 6c 65 20 22 20 66 6f 75 ogpro-file " fou
2730: 6e 64 2c 20 75 73 69 6e 67 20 64 69 66 66 20 72 nd, using diff r
2740: 75 6c 65 22 29 0a 09 09 09 09 09 09 09 64 69 66 ule")........dif
2750: 66 2d 72 75 6c 65 29 29 29 29 29 0a 09 09 09 20 f-rule)))))....
2760: 20 20 20 20 20 20 3b 3b 20 28 73 74 72 69 6e 67 ;; (string
2770: 2d 73 75 62 73 74 69 74 75 74 65 20 22 25 66 69 -substitute "%fi
2780: 6c 65 31 25 22 20 22 66 6f 6f 66 6f 6f 2e 74 78 le1%" "foofoo.tx
2790: 74 22 20 22 54 68 69 73 20 69 73 20 25 66 69 6c t" "This is %fil
27a0: 65 31 25 20 61 6e 64 20 73 6f 20 69 73 20 74 68 e1% and so is th
27b0: 69 73 20 25 66 69 6c 65 31 25 2e 22 20 23 74 29 is %file1%." #t)
27c0: 0a 09 09 09 20 20 20 20 20 20 20 28 70 72 6f 63 .... (proc
27d0: 65 73 73 65 64 2d 63 6d 64 20 28 73 74 72 69 6e essed-cmd (strin
27e0: 67 2d 73 75 62 73 74 69 74 75 74 65 20 0a 09 09 g-substitute ...
27f0: 09 09 09 20 20 20 20 20 20 20 22 25 66 69 6c 65 ... "%file
2800: 31 25 22 20 28 63 6f 6e 63 20 74 65 73 74 2d 72 1%" (conc test-r
2810: 75 6e 64 69 72 20 22 2f 22 20 77 61 69 76 65 72 undir "/" waiver
2820: 2d 67 6c 6f 62 29 0a 09 09 09 09 09 20 20 20 20 -glob)......
2830: 20 20 20 28 73 74 72 69 6e 67 2d 73 75 62 73 74 (string-subst
2840: 69 74 75 74 65 0a 09 09 09 09 09 09 22 25 66 69 itute......."%fi
2850: 6c 65 32 25 22 20 28 63 6f 6e 63 20 70 72 65 76 le2%" (conc prev
2860: 2d 72 75 6e 64 69 72 20 22 2f 22 20 77 61 69 76 -rundir "/" waiv
2870: 65 72 2d 67 6c 6f 62 29 0a 09 09 09 09 09 09 28 er-glob).......(
2880: 73 74 72 69 6e 67 2d 73 75 62 73 74 69 74 75 74 string-substitut
2890: 65 0a 09 09 09 09 09 09 20 22 25 77 61 69 76 65 e....... "%waive
28a0: 72 6e 61 6d 65 25 22 20 68 65 64 20 72 75 6c 65 rname%" hed rule
28b0: 2d 73 74 72 69 6e 67 20 23 74 29 20 23 74 29 20 -string #t) #t)
28c0: 23 74 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 #t)).... (
28d0: 72 65 73 20 20 20 20 20 20 20 20 20 20 20 20 23 res #
28e0: 66 29 29 0a 09 09 09 20 20 28 64 65 62 75 67 3a f)).... (debug:
28f0: 70 72 69 6e 74 20 30 20 22 49 4e 46 4f 3a 20 77 print 0 "INFO: w
2900: 61 69 76 65 72 20 63 6f 6d 6d 61 6e 64 20 69 73 aiver command is
2910: 20 5c 22 22 20 70 72 6f 63 65 73 73 65 64 2d 63 \"" processed-c
2920: 6d 64 20 22 5c 22 22 29 0a 09 09 09 20 20 28 69 md "\"").... (i
2930: 66 20 28 65 71 3f 20 28 73 79 73 74 65 6d 20 70 f (eq? (system p
2940: 72 6f 63 65 73 73 65 64 2d 63 6d 64 29 20 30 29 rocessed-cmd) 0)
2950: 0a 09 09 09 20 20 20 20 20 20 28 69 66 20 28 6e .... (if (n
2960: 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 09 09 20 20 ull? tal).....
2970: 23 74 0a 09 09 09 09 20 20 28 6c 6f 6f 70 20 28 #t..... (loop (
2980: 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c car tal)(cdr tal
2990: 29 29 29 0a 09 09 09 20 20 20 20 20 20 23 66 29 ))).... #f)
29a0: 29 29 29 29 29 0a 20 20 20 20 20 20 28 70 6f 70 ))))). (pop
29b0: 2d 64 69 72 65 63 74 6f 72 79 29 0a 20 20 20 20 -directory).
29c0: 20 20 72 65 73 75 6c 74 29 29 29 0a 0a 0a 3b 3b result)))...;;
29d0: 20 44 6f 20 6e 6f 74 20 72 70 63 20 74 68 69 73 Do not rpc this
29e0: 20 6f 6e 65 2c 20 64 6f 20 74 68 65 20 75 6e 64 one, do the und
29f0: 65 72 6c 79 69 6e 67 20 63 61 6c 6c 73 21 21 21 erlying calls!!!
2a00: 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a .(define (tests:
2a10: 74 65 73 74 2d 73 65 74 2d 73 74 61 74 75 73 21 test-set-status!
2a20: 20 74 65 73 74 2d 69 64 20 73 74 61 74 65 20 73 test-id state s
2a30: 74 61 74 75 73 20 63 6f 6d 6d 65 6e 74 20 64 61 tatus comment da
2a40: 74 29 0a 20 20 28 64 65 62 75 67 3a 70 72 69 6e t). (debug:prin
2a50: 74 2d 69 6e 66 6f 20 34 20 22 74 65 73 74 73 3a t-info 4 "tests:
2a60: 74 65 73 74 2d 73 65 74 2d 73 74 61 74 75 73 21 test-set-status!
2a70: 20 74 65 73 74 2d 69 64 3d 22 20 74 65 73 74 2d test-id=" test-
2a80: 69 64 20 22 2c 20 73 74 61 74 65 3d 22 20 73 74 id ", state=" st
2a90: 61 74 65 20 22 2c 20 73 74 61 74 75 73 3d 22 20 ate ", status="
2aa0: 73 74 61 74 75 73 20 22 2c 20 64 61 74 3d 22 20 status ", dat="
2ab0: 64 61 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 dat). (let* ((d
2ac0: 62 20 20 20 20 20 20 20 20 20 20 23 66 29 0a 09 b #f)..
2ad0: 20 28 72 65 61 6c 2d 73 74 61 74 75 73 20 73 74 (real-status st
2ae0: 61 74 75 73 29 0a 09 20 28 6f 74 68 65 72 64 61 atus).. (otherda
2af0: 74 20 20 20 20 28 69 66 20 64 61 74 20 64 61 74 t (if dat dat
2b00: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
2b10: 65 29 29 29 0a 09 20 28 74 65 73 74 64 61 74 20 e))).. (testdat
2b20: 20 20 20 20 28 63 64 62 3a 67 65 74 2d 74 65 73 (cdb:get-tes
2b30: 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 2a 72 75 t-info-by-id *ru
2b40: 6e 72 65 6d 6f 74 65 2a 20 74 65 73 74 2d 69 64 nremote* test-id
2b50: 29 29 0a 09 20 28 72 75 6e 2d 69 64 20 20 20 20 )).. (run-id
2b60: 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 (db:test-get-r
2b70: 75 6e 5f 69 64 20 74 65 73 74 64 61 74 29 29 0a un_id testdat)).
2b80: 09 20 28 74 65 73 74 2d 6e 61 6d 65 20 20 20 28 . (test-name (
2b90: 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 db:test-get-test
2ba0: 6e 61 6d 65 20 20 20 74 65 73 74 64 61 74 29 29 name testdat))
2bb0: 0a 09 20 28 69 74 65 6d 2d 70 61 74 68 20 20 20 .. (item-path
2bc0: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 (db:test-get-ite
2bd0: 6d 2d 70 61 74 68 20 74 65 73 74 64 61 74 29 29 m-path testdat))
2be0: 0a 09 20 3b 3b 20 62 65 66 6f 72 65 20 70 72 6f .. ;; before pro
2bf0: 63 65 65 64 69 6e 67 20 77 65 20 6d 75 73 74 20 ceeding we must
2c00: 66 69 6e 64 20 6f 75 74 20 69 66 20 74 68 65 20 find out if the
2c10: 70 72 65 76 69 6f 75 73 20 74 65 73 74 20 28 77 previous test (w
2c20: 68 65 72 65 20 61 6c 6c 20 6b 65 79 73 20 6d 61 here all keys ma
2c30: 74 63 68 65 64 20 65 78 63 65 70 74 20 72 75 6e tched except run
2c40: 6e 61 6d 65 29 0a 09 20 3b 3b 20 77 61 73 20 57 name).. ;; was W
2c50: 41 49 56 45 44 20 69 66 20 74 68 69 73 20 74 65 AIVED if this te
2c60: 73 74 20 69 73 20 46 41 49 4c 0a 0a 09 20 3b 3b st is FAIL... ;;
2c70: 20 4e 4f 54 45 53 3a 0a 09 20 3b 3b 20 20 31 2e NOTES:.. ;; 1.
2c80: 20 49 73 20 74 68 65 20 63 61 6c 6c 20 74 6f 20 Is the call to
2c90: 74 65 73 74 3a 67 65 74 2d 70 72 65 76 69 6f 75 test:get-previou
2ca0: 73 2d 72 75 6e 2d 72 65 63 6f 72 64 20 72 65 6d s-run-record rem
2cb0: 6f 74 69 66 69 65 64 3f 0a 09 20 3b 3b 20 20 32 otified?.. ;; 2
2cc0: 2e 20 41 64 64 20 74 65 73 74 20 66 6f 72 20 74 . Add test for t
2cd0: 65 73 74 63 6f 6e 66 69 67 20 77 61 69 76 65 72 estconfig waiver
2ce0: 20 70 72 6f 70 61 67 61 74 69 6f 6e 20 63 6f 6e propagation con
2cf0: 74 72 6f 6c 20 68 65 72 65 0a 09 20 3b 3b 0a 09 trol here.. ;;..
2d00: 20 28 70 72 65 76 2d 74 65 73 74 20 20 20 28 69 (prev-test (i
2d10: 66 20 28 65 71 75 61 6c 3f 20 73 74 61 74 75 73 f (equal? status
2d20: 20 22 46 41 49 4c 22 29 0a 09 09 09 20 20 28 6f "FAIL").... (o
2d30: 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 74 65 pen-run-close te
2d40: 73 74 3a 67 65 74 2d 70 72 65 76 69 6f 75 73 2d st:get-previous-
2d50: 74 65 73 74 2d 72 75 6e 2d 72 65 63 6f 72 64 20 test-run-record
2d60: 64 62 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e db run-id test-n
2d70: 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 0a 09 ame item-path)..
2d80: 09 09 20 20 23 66 29 29 0a 09 20 28 77 61 69 76 .. #f)).. (waiv
2d90: 65 64 20 20 20 28 69 66 20 70 72 65 76 2d 74 65 ed (if prev-te
2da0: 73 74 0a 09 09 20 20 20 20 20 20 20 28 69 66 20 st... (if
2db0: 70 72 65 76 2d 74 65 73 74 20 3b 3b 20 74 72 75 prev-test ;; tru
2dc0: 65 20 69 66 20 77 65 20 66 6f 75 6e 64 20 61 20 e if we found a
2dd0: 70 72 65 76 69 6f 75 73 20 74 65 73 74 20 69 6e previous test in
2de0: 20 74 68 69 73 20 72 75 6e 20 73 65 72 69 65 73 this run series
2df0: 0a 09 09 09 20 20 20 28 6c 65 74 20 28 28 70 72 .... (let ((pr
2e00: 65 76 2d 73 74 61 74 75 73 20 20 28 64 62 3a 74 ev-status (db:t
2e10: 65 73 74 2d 67 65 74 2d 73 74 61 74 75 73 20 20 est-get-status
2e20: 70 72 65 76 2d 74 65 73 74 29 29 0a 09 09 09 09 prev-test)).....
2e30: 20 28 70 72 65 76 2d 73 74 61 74 65 20 20 20 28 (prev-state (
2e40: 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 db:test-get-stat
2e50: 65 20 20 20 70 72 65 76 2d 74 65 73 74 29 29 0a e prev-test)).
2e60: 09 09 09 09 20 28 70 72 65 76 2d 63 6f 6d 6d 65 .... (prev-comme
2e70: 6e 74 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d nt (db:test-get-
2e80: 63 6f 6d 6d 65 6e 74 20 70 72 65 76 2d 74 65 73 comment prev-tes
2e90: 74 29 29 29 0a 09 09 09 20 20 20 20 20 28 64 65 t))).... (de
2ea0: 62 75 67 3a 70 72 69 6e 74 20 34 20 22 70 72 65 bug:print 4 "pre
2eb0: 76 2d 73 74 61 74 75 73 20 22 20 70 72 65 76 2d v-status " prev-
2ec0: 73 74 61 74 75 73 20 22 2c 20 70 72 65 76 2d 73 status ", prev-s
2ed0: 74 61 74 65 20 22 20 70 72 65 76 2d 73 74 61 74 tate " prev-stat
2ee0: 65 20 22 2c 20 70 72 65 76 2d 63 6f 6d 6d 65 6e e ", prev-commen
2ef0: 74 20 22 20 70 72 65 76 2d 63 6f 6d 6d 65 6e 74 t " prev-comment
2f00: 29 0a 09 09 09 20 20 20 20 20 28 69 66 20 28 61 ).... (if (a
2f10: 6e 64 20 28 65 71 75 61 6c 3f 20 70 72 65 76 2d nd (equal? prev-
2f20: 73 74 61 74 65 20 20 22 43 4f 4d 50 4c 45 54 45 state "COMPLETE
2f30: 44 22 29 0a 09 09 09 09 20 20 20 20 20 20 28 65 D")..... (e
2f40: 71 75 61 6c 3f 20 70 72 65 76 2d 73 74 61 74 75 qual? prev-statu
2f50: 73 20 22 57 41 49 56 45 44 22 29 29 0a 09 09 09 s "WAIVED"))....
2f60: 09 20 28 69 66 20 63 6f 6d 6d 65 6e 74 0a 09 09 . (if comment...
2f70: 09 09 20 20 20 20 20 63 6f 6d 6d 65 6e 74 0a 09 .. comment..
2f80: 09 09 09 20 20 20 20 20 70 72 65 76 2d 63 6f 6d ... prev-com
2f90: 6d 65 6e 74 29 20 3b 3b 20 77 61 69 76 65 64 20 ment) ;; waived
2fa0: 69 73 20 65 69 74 68 65 72 20 74 68 65 20 63 6f is either the co
2fb0: 6d 6d 65 6e 74 20 6f 72 20 23 66 0a 09 09 09 09 mment or #f.....
2fc0: 20 23 66 29 29 0a 09 09 09 20 20 20 23 66 29 0a #f)).... #f).
2fd0: 09 09 20 20 20 20 20 20 20 23 66 29 29 29 0a 20 .. #f))).
2fe0: 20 20 20 28 69 66 20 28 61 6e 64 20 77 61 69 76 (if (and waiv
2ff0: 65 64 20 0a 09 20 20 20 20 20 28 74 65 73 74 73 ed .. (tests
3000: 3a 63 68 65 63 6b 2d 77 61 69 76 65 72 2d 65 6c :check-waiver-el
3010: 69 67 69 62 69 6c 69 74 79 20 74 65 73 74 64 61 igibility testda
3020: 74 20 70 72 65 76 2d 74 65 73 74 29 29 0a 09 28 t prev-test))..(
3030: 73 65 74 21 20 72 65 61 6c 2d 73 74 61 74 75 73 set! real-status
3040: 20 22 57 41 49 56 45 44 22 29 29 0a 0a 20 20 20 "WAIVED"))..
3050: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 (debug:print 4
3060: 22 72 65 61 6c 2d 73 74 61 74 75 73 20 22 20 72 "real-status " r
3070: 65 61 6c 2d 73 74 61 74 75 73 20 22 2c 20 77 61 eal-status ", wa
3080: 69 76 65 64 20 22 20 77 61 69 76 65 64 20 22 2c ived " waived ",
3090: 20 73 74 61 74 75 73 20 22 20 73 74 61 74 75 73 status " status
30a0: 29 0a 0a 20 20 20 20 3b 3b 20 75 70 64 61 74 65 ).. ;; update
30b0: 20 74 68 65 20 70 72 69 6d 61 72 79 20 72 65 63 the primary rec
30c0: 6f 72 64 20 49 46 20 73 74 61 74 65 20 41 4e 44 ord IF state AND
30d0: 20 73 74 61 74 75 73 20 61 72 65 20 64 65 66 69 status are defi
30e0: 6e 65 64 0a 20 20 20 20 28 69 66 20 28 61 6e 64 ned. (if (and
30f0: 20 73 74 61 74 65 20 73 74 61 74 75 73 29 0a 09 state status)..
3100: 28 63 64 62 3a 74 65 73 74 2d 73 65 74 2d 73 74 (cdb:test-set-st
3110: 61 74 75 73 2d 73 74 61 74 65 20 2a 72 75 6e 72 atus-state *runr
3120: 65 6d 6f 74 65 2a 20 74 65 73 74 2d 69 64 20 72 emote* test-id r
3130: 65 61 6c 2d 73 74 61 74 75 73 20 73 74 61 74 65 eal-status state
3140: 20 28 69 66 20 77 61 69 76 65 64 20 77 61 69 76 (if waived waiv
3150: 65 64 20 63 6f 6d 6d 65 6e 74 29 29 29 0a 20 20 ed comment))).
3160: 20 20 0a 20 20 20 20 3b 3b 20 69 66 20 73 74 61 . ;; if sta
3170: 74 75 73 20 69 73 20 22 41 55 54 4f 22 20 74 68 tus is "AUTO" th
3180: 65 6e 20 63 61 6c 6c 20 72 6f 6c 6c 75 70 20 28 en call rollup (
3190: 6e 6f 74 65 2c 20 74 68 69 73 20 6f 6e 65 20 6d note, this one m
31a0: 6f 64 69 66 69 65 73 20 64 61 74 61 20 69 6e 20 odifies data in
31b0: 74 65 73 74 0a 20 20 20 20 3b 3b 20 72 75 6e 20 test. ;; run
31c0: 61 72 65 61 2c 20 69 74 20 64 6f 65 73 20 72 65 area, it does re
31d0: 6d 6f 74 65 20 63 61 6c 6c 73 20 75 6e 64 65 72 mote calls under
31e0: 20 74 68 65 20 68 6f 6f 64 2e 0a 20 20 20 20 28 the hood.. (
31f0: 69 66 20 28 61 6e 64 20 74 65 73 74 2d 69 64 20 if (and test-id
3200: 73 74 61 74 65 20 73 74 61 74 75 73 20 28 65 71 state status (eq
3210: 75 61 6c 3f 20 73 74 61 74 75 73 20 22 41 55 54 ual? status "AUT
3220: 4f 22 29 29 20 0a 09 28 64 62 3a 74 65 73 74 2d O")) ..(db:test-
3230: 64 61 74 61 2d 72 6f 6c 6c 75 70 20 23 66 20 74 data-rollup #f t
3240: 65 73 74 2d 69 64 20 73 74 61 74 75 73 29 29 0a est-id status)).
3250: 0a 20 20 20 20 3b 3b 20 61 64 64 20 6d 65 74 61 . ;; add meta
3260: 64 61 74 61 20 28 6e 65 65 64 20 74 6f 20 64 6f data (need to do
3270: 20 74 68 69 73 20 77 61 79 20 74 6f 20 61 76 6f this way to avo
3280: 69 64 20 53 51 4c 20 69 6e 6a 65 63 74 69 6f 6e id SQL injection
3290: 20 69 73 73 75 65 73 29 0a 0a 20 20 20 20 3b 3b issues).. ;;
32a0: 20 3a 66 69 72 73 74 5f 65 72 72 0a 20 20 20 20 :first_err.
32b0: 3b 3b 20 28 6c 65 74 20 28 28 76 61 6c 20 28 68 ;; (let ((val (h
32c0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
32d0: 66 61 75 6c 74 20 6f 74 68 65 72 64 61 74 20 22 fault otherdat "
32e0: 3a 66 69 72 73 74 5f 65 72 72 22 20 23 66 29 29 :first_err" #f))
32f0: 29 0a 20 20 20 20 3b 3b 20 20 20 28 69 66 20 76 ). ;; (if v
3300: 61 6c 0a 20 20 20 20 3b 3b 20 20 20 20 20 20 20 al. ;;
3310: 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 (sqlite3:execute
3320: 20 64 62 20 22 55 50 44 41 54 45 20 74 65 73 74 db "UPDATE test
3330: 73 20 53 45 54 20 66 69 72 73 74 5f 65 72 72 3d s SET first_err=
3340: 3f 20 57 48 45 52 45 20 72 75 6e 5f 69 64 3d 3f ? WHERE run_id=?
3350: 20 41 4e 44 20 74 65 73 74 6e 61 6d 65 3d 3f 20 AND testname=?
3360: 41 4e 44 20 69 74 65 6d 5f 70 61 74 68 3d 3f 3b AND item_path=?;
3370: 22 20 76 61 6c 20 72 75 6e 2d 69 64 20 74 65 73 " val run-id tes
3380: 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 t-name item-path
3390: 29 29 29 0a 20 20 20 20 3b 3b 20 0a 20 20 20 20 ))). ;; .
33a0: 3b 3b 20 3b 3b 20 3a 66 69 72 73 74 5f 77 61 72 ;; ;; :first_war
33b0: 6e 0a 20 20 20 20 3b 3b 20 28 6c 65 74 20 28 28 n. ;; (let ((
33c0: 76 61 6c 20 28 68 61 73 68 2d 74 61 62 6c 65 2d val (hash-table-
33d0: 72 65 66 2f 64 65 66 61 75 6c 74 20 6f 74 68 65 ref/default othe
33e0: 72 64 61 74 20 22 3a 66 69 72 73 74 5f 77 61 72 rdat ":first_war
33f0: 6e 22 20 23 66 29 29 29 0a 20 20 20 20 3b 3b 20 n" #f))). ;;
3400: 20 20 28 69 66 20 76 61 6c 0a 20 20 20 20 3b 3b (if val. ;;
3410: 20 20 20 20 20 20 20 28 73 71 6c 69 74 65 33 3a (sqlite3:
3420: 65 78 65 63 75 74 65 20 64 62 20 22 55 50 44 41 execute db "UPDA
3430: 54 45 20 74 65 73 74 73 20 53 45 54 20 66 69 72 TE tests SET fir
3440: 73 74 5f 77 61 72 6e 3d 3f 20 57 48 45 52 45 20 st_warn=? WHERE
3450: 72 75 6e 5f 69 64 3d 3f 20 41 4e 44 20 74 65 73 run_id=? AND tes
3460: 74 6e 61 6d 65 3d 3f 20 41 4e 44 20 69 74 65 6d tname=? AND item
3470: 5f 70 61 74 68 3d 3f 3b 22 20 76 61 6c 20 72 75 _path=?;" val ru
3480: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 n-id test-name i
3490: 74 65 6d 2d 70 61 74 68 29 29 29 0a 0a 20 20 20 tem-path)))..
34a0: 20 28 6c 65 74 20 28 28 63 61 74 65 67 6f 72 79 (let ((category
34b0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
34c0: 2f 64 65 66 61 75 6c 74 20 6f 74 68 65 72 64 61 /default otherda
34d0: 74 20 22 3a 63 61 74 65 67 6f 72 79 22 20 22 22 t ":category" ""
34e0: 29 29 0a 09 20 20 28 76 61 72 69 61 62 6c 65 20 )).. (variable
34f0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
3500: 64 65 66 61 75 6c 74 20 6f 74 68 65 72 64 61 74 default otherdat
3510: 20 22 3a 76 61 72 69 61 62 6c 65 22 20 22 22 29 ":variable" "")
3520: 29 0a 09 20 20 28 76 61 6c 75 65 20 20 20 20 28 ).. (value (
3530: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
3540: 65 66 61 75 6c 74 20 6f 74 68 65 72 64 61 74 20 efault otherdat
3550: 22 3a 76 61 6c 75 65 22 20 20 20 20 23 66 29 29 ":value" #f))
3560: 0a 09 20 20 28 65 78 70 65 63 74 65 64 20 28 68 .. (expected (h
3570: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
3580: 66 61 75 6c 74 20 6f 74 68 65 72 64 61 74 20 22 fault otherdat "
3590: 3a 65 78 70 65 63 74 65 64 22 20 23 66 29 29 0a :expected" #f)).
35a0: 09 20 20 28 74 6f 6c 20 20 20 20 20 20 28 68 61 . (tol (ha
35b0: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
35c0: 61 75 6c 74 20 6f 74 68 65 72 64 61 74 20 22 3a ault otherdat ":
35d0: 74 6f 6c 22 20 20 20 20 20 20 23 66 29 29 0a 09 tol" #f))..
35e0: 20 20 28 75 6e 69 74 73 20 20 20 20 28 68 61 73 (units (has
35f0: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
3600: 75 6c 74 20 6f 74 68 65 72 64 61 74 20 22 3a 75 ult otherdat ":u
3610: 6e 69 74 73 22 20 20 20 20 22 22 29 29 0a 09 20 nits" ""))..
3620: 20 28 74 79 70 65 20 20 20 20 20 28 68 61 73 68 (type (hash
3630: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
3640: 6c 74 20 6f 74 68 65 72 64 61 74 20 22 3a 74 79 lt otherdat ":ty
3650: 70 65 22 20 20 20 20 20 22 22 29 29 0a 09 20 20 pe" ""))..
3660: 28 64 63 6f 6d 6d 65 6e 74 20 28 68 61 73 68 2d (dcomment (hash-
3670: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
3680: 74 20 6f 74 68 65 72 64 61 74 20 22 3a 63 6f 6d t otherdat ":com
3690: 6d 65 6e 74 22 20 20 22 22 29 29 29 0a 20 20 20 ment" ""))).
36a0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
36b0: 34 20 0a 09 09 20 20 20 22 63 61 74 65 67 6f 72 4 ... "categor
36c0: 79 3a 20 22 20 63 61 74 65 67 6f 72 79 20 22 2c y: " category ",
36d0: 20 76 61 72 69 61 62 6c 65 3a 20 22 20 76 61 72 variable: " var
36e0: 69 61 62 6c 65 20 22 2c 20 76 61 6c 75 65 3a 20 iable ", value:
36f0: 22 20 76 61 6c 75 65 0a 09 09 20 20 20 22 2c 20 " value... ",
3700: 65 78 70 65 63 74 65 64 3a 20 22 20 65 78 70 65 expected: " expe
3710: 63 74 65 64 20 22 2c 20 74 6f 6c 3a 20 22 20 74 cted ", tol: " t
3720: 6f 6c 20 22 2c 20 75 6e 69 74 73 3a 20 22 20 75 ol ", units: " u
3730: 6e 69 74 73 29 0a 20 20 20 20 20 20 28 69 66 20 nits). (if
3740: 28 61 6e 64 20 76 61 6c 75 65 20 65 78 70 65 63 (and value expec
3750: 74 65 64 20 74 6f 6c 29 20 3b 3b 20 61 6c 6c 20 ted tol) ;; all
3760: 74 68 72 65 65 20 72 65 71 75 69 72 65 64 0a 09 three required..
3770: 20 20 28 6c 65 74 20 28 28 64 61 74 20 28 63 6f (let ((dat (co
3780: 6e 63 20 63 61 74 65 67 6f 72 79 20 22 2c 22 0a nc category ",".
3790: 09 09 09 20 20 20 76 61 72 69 61 62 6c 65 20 22 ... variable "
37a0: 2c 22 0a 09 09 09 20 20 20 76 61 6c 75 65 20 20 ,".... value
37b0: 20 20 22 2c 22 0a 09 09 09 20 20 20 65 78 70 65 ",".... expe
37c0: 63 74 65 64 20 22 2c 22 0a 09 09 09 20 20 20 74 cted ",".... t
37d0: 6f 6c 20 20 20 20 20 20 22 2c 22 0a 09 09 09 20 ol ","....
37e0: 20 20 75 6e 69 74 73 20 20 20 20 22 2c 22 0a 09 units ","..
37f0: 09 09 20 20 20 64 63 6f 6d 6d 65 6e 74 20 22 2c .. dcomment ",
3800: 2c 22 20 3b 3b 20 65 78 74 72 61 20 63 6f 6d 6d ," ;; extra comm
3810: 61 20 66 6f 72 20 73 74 61 74 75 73 0a 09 09 09 a for status....
3820: 20 20 20 74 79 70 65 20 20 20 20 20 29 29 29 0a type ))).
3830: 09 20 20 20 20 28 63 64 62 3a 72 65 6d 6f 74 65 . (cdb:remote
3840: 2d 72 75 6e 20 64 62 3a 63 73 76 2d 3e 74 65 73 -run db:csv->tes
3850: 74 2d 64 61 74 61 20 23 66 20 74 65 73 74 2d 69 t-data #f test-i
3860: 64 0a 09 09 09 09 64 61 74 29 29 29 29 0a 20 20 d.....dat)))).
3870: 20 20 20 20 0a 20 20 20 20 3b 3b 20 6e 65 65 64 . ;; need
3880: 20 74 6f 20 75 70 64 61 74 65 20 74 68 65 20 74 to update the t
3890: 6f 70 20 74 65 73 74 20 72 65 63 6f 72 64 20 69 op test record i
38a0: 66 20 50 41 53 53 20 6f 72 20 46 41 49 4c 20 61 f PASS or FAIL a
38b0: 6e 64 20 74 68 69 73 20 69 73 20 61 20 73 75 62 nd this is a sub
38c0: 74 65 73 74 0a 20 20 20 20 28 69 66 20 28 6e 6f test. (if (no
38d0: 74 20 28 65 71 75 61 6c 3f 20 69 74 65 6d 2d 70 t (equal? item-p
38e0: 61 74 68 20 22 22 29 29 0a 09 28 63 64 62 3a 72 ath ""))..(cdb:r
38f0: 6f 6c 6c 2d 75 70 2d 70 61 73 73 2d 66 61 69 6c oll-up-pass-fail
3900: 2d 63 6f 75 6e 74 73 20 2a 72 75 6e 72 65 6d 6f -counts *runremo
3910: 74 65 2a 20 72 75 6e 2d 69 64 20 74 65 73 74 2d te* run-id test-
3920: 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 73 name item-path s
3930: 74 61 74 75 73 29 29 0a 0a 20 20 20 20 28 69 66 tatus)).. (if
3940: 20 28 6f 72 20 28 61 6e 64 20 28 73 74 72 69 6e (or (and (strin
3950: 67 3f 20 63 6f 6d 6d 65 6e 74 29 0a 09 09 20 28 g? comment)... (
3960: 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 28 72 65 string-match (re
3970: 67 65 78 70 20 22 5c 5c 53 2b 22 29 20 63 6f 6d gexp "\\S+") com
3980: 6d 65 6e 74 29 29 0a 09 20 20 20 20 77 61 69 76 ment)).. waiv
3990: 65 64 29 0a 09 28 6c 65 74 20 28 28 63 6d 74 20 ed)..(let ((cmt
39a0: 20 28 69 66 20 77 61 69 76 65 64 20 77 61 69 76 (if waived waiv
39b0: 65 64 20 63 6f 6d 6d 65 6e 74 29 29 29 0a 09 20 ed comment)))..
39c0: 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e (cdb:remote-run
39d0: 20 64 62 3a 74 65 73 74 2d 73 65 74 2d 63 6f 6d db:test-set-com
39e0: 6d 65 6e 74 20 23 66 20 74 65 73 74 2d 69 64 20 ment #f test-id
39f0: 63 6d 74 29 29 29 0a 20 20 20 20 29 29 0a 0a 0a cmt))). ))...
3a00: 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 74 (define (tests:t
3a10: 65 73 74 2d 73 65 74 2d 74 6f 70 6c 6f 67 21 20 est-set-toplog!
3a20: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
3a30: 20 6c 6f 67 66 29 20 0a 20 20 28 63 64 62 3a 63 logf) . (cdb:c
3a40: 6c 69 65 6e 74 2d 63 61 6c 6c 20 2a 72 75 6e 72 lient-call *runr
3a50: 65 6d 6f 74 65 2a 20 27 74 65 73 74 73 3a 74 65 emote* 'tests:te
3a60: 73 74 2d 73 65 74 2d 74 6f 70 6c 6f 67 20 23 74 st-set-toplog #t
3a70: 20 32 20 6c 6f 67 66 20 72 75 6e 2d 69 64 20 74 2 logf run-id t
3a80: 65 73 74 2d 6e 61 6d 65 29 29 0a 0a 28 64 65 66 est-name))..(def
3a90: 69 6e 65 20 28 74 65 73 74 73 3a 73 75 6d 6d 61 ine (tests:summa
3aa0: 72 69 7a 65 2d 69 74 65 6d 73 20 72 75 6e 2d 69 rize-items run-i
3ab0: 64 20 74 65 73 74 2d 6e 61 6d 65 20 66 6f 72 63 d test-name forc
3ac0: 65 29 0a 20 20 3b 3b 20 69 66 20 6e 6f 74 20 66 e). ;; if not f
3ad0: 6f 72 63 65 20 74 68 65 6e 20 6f 6e 6c 79 20 75 orce then only u
3ae0: 70 64 61 74 65 20 74 68 65 20 72 65 63 6f 72 64 pdate the record
3af0: 20 69 66 20 6f 6e 65 20 6f 66 20 74 68 65 73 65 if one of these
3b00: 20 69 73 20 74 72 75 65 3a 0a 20 20 3b 3b 20 20 is true:. ;;
3b10: 20 31 2e 20 6c 6f 67 66 20 69 73 20 22 6c 6f 67 1. logf is "log
3b20: 2f 66 69 6e 61 6c 2e 6c 6f 67 0a 20 20 3b 3b 20 /final.log. ;;
3b30: 20 20 32 2e 20 6c 6f 67 66 20 69 73 20 73 61 6d 2. logf is sam
3b40: 65 20 61 73 20 6f 75 74 70 75 74 66 69 6c 65 6e e as outputfilen
3b50: 61 6d 65 0a 20 20 28 6c 65 74 2a 20 28 28 6f 75 ame. (let* ((ou
3b60: 74 70 75 74 66 69 6c 65 6e 61 6d 65 20 28 63 6f tputfilename (co
3b70: 6e 63 20 22 6d 65 67 61 74 65 73 74 2d 72 6f 6c nc "megatest-rol
3b80: 6c 75 70 2d 22 20 74 65 73 74 2d 6e 61 6d 65 20 lup-" test-name
3b90: 22 2e 68 74 6d 6c 22 29 29 0a 09 20 28 6f 72 69 ".html")).. (ori
3ba0: 67 2d 64 69 72 20 20 20 20 20 20 20 28 63 75 72 g-dir (cur
3bb0: 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 79 29 29 rent-directory))
3bc0: 0a 09 20 28 6c 6f 67 66 2d 69 6e 66 6f 20 20 20 .. (logf-info
3bd0: 20 20 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 (cdb:remote-r
3be0: 75 6e 20 64 62 3a 74 65 73 74 2d 67 65 74 2d 6c un db:test-get-l
3bf0: 6f 67 66 69 6c 65 2d 69 6e 66 6f 20 23 66 20 72 ogfile-info #f r
3c00: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 29 un-id test-name)
3c10: 29 0a 09 20 28 6c 6f 67 66 20 20 20 20 20 20 20 ).. (logf
3c20: 20 20 20 20 28 69 66 20 6c 6f 67 66 2d 69 6e 66 (if logf-inf
3c30: 6f 20 28 63 61 64 72 20 6c 6f 67 66 2d 69 6e 66 o (cadr logf-inf
3c40: 6f 29 20 23 66 29 29 0a 09 20 28 70 61 74 68 20 o) #f)).. (path
3c50: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 6c 6f (if lo
3c60: 67 66 2d 69 6e 66 6f 20 28 63 61 72 20 20 6c 6f gf-info (car lo
3c70: 67 66 2d 69 6e 66 6f 29 20 23 66 29 29 29 0a 20 gf-info) #f))).
3c80: 20 20 20 3b 3b 20 54 68 69 73 20 71 75 65 72 79 ;; This query
3c90: 20 66 69 6e 64 73 20 74 68 65 20 70 61 74 68 20 finds the path
3ca0: 61 6e 64 20 63 68 61 6e 67 65 73 20 74 68 65 20 and changes the
3cb0: 64 69 72 65 63 74 6f 72 79 20 74 6f 20 69 74 20 directory to it
3cc0: 66 6f 72 20 74 68 65 20 74 65 73 74 0a 20 20 20 for the test.
3cd0: 20 28 73 65 74 21 20 6c 6f 67 66 20 28 63 61 72 (set! logf (car
3ce0: 20 6c 6f 67 66 2d 69 6e 66 6f 29 29 0a 20 20 20 logf-info)).
3cf0: 20 28 69 66 20 28 64 69 72 65 63 74 6f 72 79 3f (if (directory?
3d00: 20 70 61 74 68 29 0a 09 28 62 65 67 69 6e 0a 09 path)..(begin..
3d10: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 (debug:print 4
3d20: 20 22 46 6f 75 6e 64 20 70 61 74 68 3a 20 22 20 "Found path: "
3d30: 70 61 74 68 29 0a 09 20 20 28 63 68 61 6e 67 65 path).. (change
3d40: 2d 64 69 72 65 63 74 6f 72 79 20 70 61 74 68 29 -directory path)
3d50: 29 0a 09 3b 3b 20 28 73 65 74 21 20 6f 75 74 70 )..;; (set! outp
3d60: 75 74 66 69 6c 65 6e 61 6d 65 20 28 63 6f 6e 63 utfilename (conc
3d70: 20 70 61 74 68 20 22 2f 22 20 6f 75 74 70 75 74 path "/" output
3d80: 66 69 6c 65 6e 61 6d 65 29 29 29 0a 09 28 70 72 filename)))..(pr
3d90: 69 6e 74 20 22 4e 6f 20 73 75 63 68 20 70 61 74 int "No such pat
3da0: 68 3a 20 22 20 70 61 74 68 29 29 0a 20 20 20 20 h: " path)).
3db0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 (debug:print 1 "
3dc0: 73 75 6d 6d 61 72 69 7a 65 2d 69 74 65 6d 73 20 summarize-items
3dd0: 77 69 74 68 20 6c 6f 67 66 20 22 20 6c 6f 67 66 with logf " logf
3de0: 29 0a 20 20 20 20 28 69 66 20 28 6f 72 20 28 65 ). (if (or (e
3df0: 71 75 61 6c 3f 20 6c 6f 67 66 20 22 6c 6f 67 73 qual? logf "logs
3e00: 2f 66 69 6e 61 6c 2e 6c 6f 67 22 29 0a 09 20 20 /final.log")..
3e10: 20 20 28 65 71 75 61 6c 3f 20 6c 6f 67 66 20 6f (equal? logf o
3e20: 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 29 0a 09 utputfilename)..
3e30: 20 20 20 20 66 6f 72 63 65 29 0a 09 28 62 65 67 force)..(beg
3e40: 69 6e 0a 09 20 20 28 69 66 20 28 6f 62 74 61 69 in.. (if (obtai
3e50: 6e 2d 64 6f 74 2d 6c 6f 63 6b 20 6f 75 74 70 75 n-dot-lock outpu
3e60: 74 66 69 6c 65 6e 61 6d 65 20 31 20 32 30 20 33 tfilename 1 20 3
3e70: 30 29 20 3b 3b 20 72 65 74 72 79 20 65 76 65 72 0) ;; retry ever
3e80: 79 20 73 65 63 6f 6e 64 20 66 6f 72 20 32 30 20 y second for 20
3e90: 73 65 63 6f 6e 64 73 2c 20 63 61 6c 6c 20 69 74 seconds, call it
3ea0: 20 64 65 61 64 20 61 66 74 65 72 20 33 30 20 73 dead after 30 s
3eb0: 65 63 6f 6e 64 73 20 61 6e 64 20 73 74 65 61 6c econds and steal
3ec0: 20 74 68 65 20 6c 6f 63 6b 0a 09 20 20 20 20 20 the lock..
3ed0: 20 28 70 72 69 6e 74 20 22 4f 62 74 61 69 6e 65 (print "Obtaine
3ee0: 64 20 6c 6f 63 6b 20 66 6f 72 20 22 20 6f 75 74 d lock for " out
3ef0: 70 75 74 66 69 6c 65 6e 61 6d 65 29 0a 09 20 20 putfilename)..
3f00: 20 20 20 20 28 70 72 69 6e 74 20 22 46 61 69 6c (print "Fail
3f10: 65 64 20 74 6f 20 6f 62 74 61 69 6e 20 6c 6f 63 ed to obtain loc
3f20: 6b 20 66 6f 72 20 22 20 6f 75 74 70 75 74 66 69 k for " outputfi
3f30: 6c 65 6e 61 6d 65 29 29 0a 09 20 20 28 6c 65 74 lename)).. (let
3f40: 20 28 28 6f 75 70 20 20 20 20 28 6f 70 65 6e 2d ((oup (open-
3f50: 6f 75 74 70 75 74 2d 66 69 6c 65 20 6f 75 74 70 output-file outp
3f60: 75 74 66 69 6c 65 6e 61 6d 65 29 29 0a 09 09 28 utfilename))...(
3f70: 63 6f 75 6e 74 73 20 28 6d 61 6b 65 2d 68 61 73 counts (make-has
3f80: 68 2d 74 61 62 6c 65 29 29 0a 09 09 28 73 74 61 h-table))...(sta
3f90: 74 65 63 6f 75 6e 74 73 20 28 6d 61 6b 65 2d 68 tecounts (make-h
3fa0: 61 73 68 2d 74 61 62 6c 65 29 29 0a 09 09 28 6f ash-table))...(o
3fb0: 75 74 74 78 74 20 22 22 29 0a 09 09 28 74 6f 74 uttxt "")...(tot
3fc0: 20 20 20 20 30 29 0a 09 09 28 74 65 73 74 64 61 0)...(testda
3fd0: 74 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 t (cdb:remote-ru
3fe0: 6e 20 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 65 n db:test-get-re
3ff0: 63 6f 72 64 73 2d 66 6f 72 2d 69 6e 64 65 78 2d cords-for-index-
4000: 66 69 6c 65 20 23 66 20 72 75 6e 2d 69 64 20 74 file #f run-id t
4010: 65 73 74 2d 6e 61 6d 65 29 29 29 0a 09 20 20 20 est-name)))..
4020: 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f (with-output-to
4030: 2d 70 6f 72 74 0a 09 09 6f 75 70 0a 09 20 20 20 -port...oup..
4040: 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 (lambda ()...
4050: 28 73 65 74 21 20 6f 75 74 74 78 74 20 28 63 6f (set! outtxt (co
4060: 6e 63 20 6f 75 74 74 78 74 20 22 3c 68 74 6d 6c nc outtxt "<html
4070: 3e 3c 74 69 74 6c 65 3e 53 75 6d 6d 61 72 79 3a ><title>Summary:
4080: 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 0a 09 09 " test-name ...
4090: 09 09 20 20 20 22 3c 2f 74 69 74 6c 65 3e 3c 62 .. "</title><b
40a0: 6f 64 79 3e 3c 68 32 3e 53 75 6d 6d 61 72 79 20 ody><h2>Summary
40b0: 66 6f 72 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 for " test-name
40c0: 22 3c 2f 68 32 3e 22 29 29 0a 09 09 28 66 6f 72 "</h2>"))...(for
40d0: 2d 65 61 63 68 0a 09 09 20 28 6c 61 6d 62 64 61 -each... (lambda
40e0: 20 28 74 65 73 74 72 65 63 6f 72 64 29 0a 09 09 (testrecord)...
40f0: 20 20 20 28 6c 65 74 20 28 28 69 64 20 20 20 20 (let ((id
4100: 20 20 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 (vector
4110: 2d 72 65 66 20 74 65 73 74 72 65 63 6f 72 64 20 -ref testrecord
4120: 30 29 29 0a 09 09 09 20 28 69 74 65 6d 70 61 74 0)).... (itempat
4130: 68 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d h (vector-
4140: 72 65 66 20 74 65 73 74 72 65 63 6f 72 64 20 31 ref testrecord 1
4150: 29 29 0a 09 09 09 20 28 73 74 61 74 65 20 20 20 )).... (state
4160: 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 (vector-r
4170: 65 66 20 74 65 73 74 72 65 63 6f 72 64 20 32 29 ef testrecord 2)
4180: 29 0a 09 09 09 20 28 73 74 61 74 75 73 20 20 20 ).... (status
4190: 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 (vector-re
41a0: 66 20 74 65 73 74 72 65 63 6f 72 64 20 33 29 29 f testrecord 3))
41b0: 0a 09 09 09 20 28 72 75 6e 5f 64 75 72 61 74 69 .... (run_durati
41c0: 6f 6e 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 on (vector-ref
41d0: 20 74 65 73 74 72 65 63 6f 72 64 20 34 29 29 0a testrecord 4)).
41e0: 09 09 09 20 28 6c 6f 67 66 20 20 20 20 20 20 20 ... (logf
41f0: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
4200: 74 65 73 74 72 65 63 6f 72 64 20 35 29 29 0a 09 testrecord 5))..
4210: 09 09 20 28 63 6f 6d 6d 65 6e 74 20 20 20 20 20 .. (comment
4220: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 (vector-ref t
4230: 65 73 74 72 65 63 6f 72 64 20 36 29 29 29 0a 09 estrecord 6)))..
4240: 09 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c . (hash-tabl
4250: 65 2d 73 65 74 21 20 63 6f 75 6e 74 73 20 73 74 e-set! counts st
4260: 61 74 75 73 20 28 2b 20 31 20 28 68 61 73 68 2d atus (+ 1 (hash-
4270: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
4280: 74 20 63 6f 75 6e 74 73 20 73 74 61 74 75 73 20 t counts status
4290: 30 29 29 29 0a 09 09 20 20 20 20 20 28 68 61 73 0)))... (has
42a0: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 73 74 61 h-table-set! sta
42b0: 74 65 63 6f 75 6e 74 73 20 73 74 61 74 65 20 28 tecounts state (
42c0: 2b 20 31 20 28 68 61 73 68 2d 74 61 62 6c 65 2d + 1 (hash-table-
42d0: 72 65 66 2f 64 65 66 61 75 6c 74 20 73 74 61 74 ref/default stat
42e0: 65 63 6f 75 6e 74 73 20 73 74 61 74 65 20 30 29 ecounts state 0)
42f0: 29 29 0a 09 09 20 20 20 20 20 28 73 65 74 21 20 ))... (set!
4300: 6f 75 74 74 78 74 20 28 63 6f 6e 63 20 6f 75 74 outtxt (conc out
4310: 74 78 74 20 22 3c 74 72 3e 22 0a 09 09 09 09 09 txt "<tr>"......
4320: 22 3c 74 64 3e 3c 61 20 68 72 65 66 3d 5c 22 22 "<td><a href=\""
4330: 20 69 74 65 6d 70 61 74 68 20 22 2f 22 20 6c 6f itempath "/" lo
4340: 67 66 20 22 5c 22 3e 20 22 20 69 74 65 6d 70 61 gf "\"> " itempa
4350: 74 68 20 22 3c 2f 61 3e 3c 2f 74 64 3e 22 20 0a th "</a></td>" .
4360: 09 09 09 09 09 22 3c 74 64 3e 22 20 73 74 61 74 ....."<td>" stat
4370: 65 20 20 20 20 22 3c 2f 74 64 3e 22 20 0a 09 09 e "</td>" ...
4380: 09 09 09 22 3c 74 64 3e 3c 66 6f 6e 74 20 63 6f ..."<td><font co
4390: 6c 6f 72 3d 22 20 28 63 6f 6d 6d 6f 6e 3a 67 65 lor=" (common:ge
43a0: 74 2d 63 6f 6c 6f 72 2d 66 72 6f 6d 2d 73 74 61 t-color-from-sta
43b0: 74 75 73 20 73 74 61 74 75 73 29 0a 09 09 09 09 tus status).....
43c0: 09 22 3e 22 20 20 20 73 74 61 74 75 73 20 20 20 .">" status
43d0: 22 3c 2f 66 6f 6e 74 3e 3c 2f 74 64 3e 22 0a 09 "</font></td>"..
43e0: 09 09 09 09 22 3c 74 64 3e 22 20 28 69 66 20 28 ...."<td>" (if (
43f0: 65 71 75 61 6c 3f 20 63 6f 6d 6d 65 6e 74 20 22 equal? comment "
4400: 22 29 0a 09 09 09 09 09 09 20 20 20 22 26 6e 62 ")....... "&nb
4410: 73 70 3b 22 0a 09 09 09 09 09 09 20 20 20 63 6f sp;"....... co
4420: 6d 6d 65 6e 74 29 20 22 3c 2f 74 64 3e 22 0a 09 mment) "</td>"..
4430: 09 09 09 09 09 20 20 20 22 3c 2f 74 72 3e 22 29 ..... "</tr>")
4440: 29 29 29 0a 09 09 20 74 65 73 74 64 61 74 29 0a )))... testdat).
4450: 09 09 28 70 72 69 6e 74 20 22 3c 74 61 62 6c 65 ..(print "<table
4460: 3e 3c 74 72 3e 3c 74 64 20 76 61 6c 69 67 6e 3d ><tr><td valign=
4470: 5c 22 74 6f 70 5c 22 3e 22 29 0a 09 09 3b 3b 20 \"top\">")...;;
4480: 50 72 69 6e 74 20 6f 75 74 20 73 74 61 74 73 20 Print out stats
4490: 66 6f 72 20 73 74 61 74 75 73 0a 09 09 28 73 65 for status...(se
44a0: 74 21 20 74 6f 74 20 30 29 0a 09 09 28 70 72 69 t! tot 0)...(pri
44b0: 6e 74 20 22 3c 74 61 62 6c 65 20 63 65 6c 6c 73 nt "<table cells
44c0: 70 61 63 69 6e 67 3d 5c 22 30 5c 22 20 62 6f 72 pacing=\"0\" bor
44d0: 64 65 72 3d 5c 22 31 5c 22 3e 3c 74 72 3e 3c 74 der=\"1\"><tr><t
44e0: 64 20 63 6f 6c 73 70 61 6e 3d 5c 22 32 5c 22 3e d colspan=\"2\">
44f0: 3c 68 32 3e 53 74 61 74 65 20 73 74 61 74 73 3c <h2>State stats<
4500: 2f 68 32 3e 3c 2f 74 64 3e 3c 2f 74 72 3e 22 29 /h2></td></tr>")
4510: 0a 09 09 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 ...(for-each (la
4520: 6d 62 64 61 20 28 73 74 61 74 65 29 0a 09 09 09 mbda (state)....
4530: 20 20 20 20 28 73 65 74 21 20 74 6f 74 20 28 2b (set! tot (+
4540: 20 74 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 tot (hash-table
4550: 2d 72 65 66 20 73 74 61 74 65 63 6f 75 6e 74 73 -ref statecounts
4560: 20 73 74 61 74 65 29 29 29 0a 09 09 09 20 20 20 state)))....
4570: 20 28 70 72 69 6e 74 20 22 3c 74 72 3e 3c 74 64 (print "<tr><td
4580: 3e 22 20 73 74 61 74 65 20 22 3c 2f 74 64 3e 3c >" state "</td><
4590: 74 64 3e 22 20 28 68 61 73 68 2d 74 61 62 6c 65 td>" (hash-table
45a0: 2d 72 65 66 20 73 74 61 74 65 63 6f 75 6e 74 73 -ref statecounts
45b0: 20 73 74 61 74 65 29 20 22 3c 2f 74 64 3e 3c 2f state) "</td></
45c0: 74 72 3e 22 29 29 0a 09 09 09 20 20 28 68 61 73 tr>")).... (has
45d0: 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 73 74 61 h-table-keys sta
45e0: 74 65 63 6f 75 6e 74 73 29 29 0a 09 09 28 70 72 tecounts))...(pr
45f0: 69 6e 74 20 22 3c 74 72 3e 3c 74 64 3e 54 6f 74 int "<tr><td>Tot
4600: 61 6c 3c 2f 74 64 3e 3c 74 64 3e 22 20 74 6f 74 al</td><td>" tot
4610: 20 22 3c 2f 74 64 3e 3c 2f 74 72 3e 3c 2f 74 61 "</td></tr></ta
4620: 62 6c 65 3e 22 29 0a 09 09 28 70 72 69 6e 74 20 ble>")...(print
4630: 22 3c 2f 74 64 3e 3c 74 64 20 76 61 6c 69 67 6e "</td><td valign
4640: 3d 5c 22 74 6f 70 5c 22 3e 22 29 0a 09 09 3b 3b =\"top\">")...;;
4650: 20 50 72 69 6e 74 20 6f 75 74 20 73 74 61 74 73 Print out stats
4660: 20 66 6f 72 20 73 74 61 74 65 0a 09 09 28 73 65 for state...(se
4670: 74 21 20 74 6f 74 20 30 29 0a 09 09 28 70 72 69 t! tot 0)...(pri
4680: 6e 74 20 22 3c 74 61 62 6c 65 20 63 65 6c 6c 73 nt "<table cells
4690: 70 61 63 69 6e 67 3d 5c 22 30 5c 22 20 62 6f 72 pacing=\"0\" bor
46a0: 64 65 72 3d 5c 22 31 5c 22 3e 3c 74 72 3e 3c 74 der=\"1\"><tr><t
46b0: 64 20 63 6f 6c 73 70 61 6e 3d 5c 22 32 5c 22 3e d colspan=\"2\">
46c0: 3c 68 32 3e 53 74 61 74 75 73 20 73 74 61 74 73 <h2>Status stats
46d0: 3c 2f 68 32 3e 3c 2f 74 64 3e 3c 2f 74 72 3e 22 </h2></td></tr>"
46e0: 29 0a 09 09 28 66 6f 72 2d 65 61 63 68 20 28 6c )...(for-each (l
46f0: 61 6d 62 64 61 20 28 73 74 61 74 75 73 29 0a 09 ambda (status)..
4700: 09 09 20 20 20 20 28 73 65 74 21 20 74 6f 74 20 .. (set! tot
4710: 28 2b 20 74 6f 74 20 28 68 61 73 68 2d 74 61 62 (+ tot (hash-tab
4720: 6c 65 2d 72 65 66 20 63 6f 75 6e 74 73 20 73 74 le-ref counts st
4730: 61 74 75 73 29 29 29 0a 09 09 09 20 20 20 20 28 atus))).... (
4740: 70 72 69 6e 74 20 22 3c 74 72 3e 3c 74 64 3e 3c print "<tr><td><
4750: 66 6f 6e 74 20 63 6f 6c 6f 72 3d 5c 22 22 20 28 font color=\"" (
4760: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 6f 6c 6f 72 common:get-color
4770: 2d 66 72 6f 6d 2d 73 74 61 74 75 73 20 73 74 61 -from-status sta
4780: 74 75 73 29 20 22 5c 22 3e 22 20 73 74 61 74 75 tus) "\">" statu
4790: 73 0a 09 09 09 09 20 20 20 22 3c 2f 66 6f 6e 74 s..... "</font
47a0: 3e 3c 2f 74 64 3e 3c 74 64 3e 22 20 28 68 61 73 ></td><td>" (has
47b0: 68 2d 74 61 62 6c 65 2d 72 65 66 20 63 6f 75 6e h-table-ref coun
47c0: 74 73 20 73 74 61 74 75 73 29 20 22 3c 2f 74 64 ts status) "</td
47d0: 3e 3c 2f 74 72 3e 22 29 29 0a 09 09 09 20 20 28 ></tr>")).... (
47e0: 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 hash-table-keys
47f0: 63 6f 75 6e 74 73 29 29 0a 09 09 28 70 72 69 6e counts))...(prin
4800: 74 20 22 3c 74 72 3e 3c 74 64 3e 54 6f 74 61 6c t "<tr><td>Total
4810: 3c 2f 74 64 3e 3c 74 64 3e 22 20 74 6f 74 20 22 </td><td>" tot "
4820: 3c 2f 74 64 3e 3c 2f 74 72 3e 3c 2f 74 61 62 6c </td></tr></tabl
4830: 65 3e 22 29 0a 09 09 28 70 72 69 6e 74 20 22 3c e>")...(print "<
4840: 2f 74 64 3e 3c 2f 74 64 3e 3c 2f 74 72 3e 3c 2f /td></td></tr></
4850: 74 61 62 6c 65 3e 22 29 0a 0a 09 09 28 70 72 69 table>")....(pri
4860: 6e 74 20 22 3c 74 61 62 6c 65 20 63 65 6c 6c 73 nt "<table cells
4870: 70 61 63 69 6e 67 3d 5c 22 30 5c 22 20 62 6f 72 pacing=\"0\" bor
4880: 64 65 72 3d 5c 22 31 5c 22 3e 22 20 0a 09 09 20 der=\"1\">" ...
4890: 20 20 20 20 20 20 22 3c 74 72 3e 3c 74 64 3e 49 "<tr><td>I
48a0: 74 65 6d 3c 2f 74 64 3e 3c 74 64 3e 53 74 61 74 tem</td><td>Stat
48b0: 65 3c 2f 74 64 3e 3c 74 64 3e 53 74 61 74 75 73 e</td><td>Status
48c0: 3c 2f 74 64 3e 3c 74 64 3e 43 6f 6d 6d 65 6e 74 </td><td>Comment
48d0: 3c 2f 74 64 3e 22 0a 09 09 20 20 20 20 20 20 20 </td>"...
48e0: 6f 75 74 74 78 74 20 22 3c 2f 74 61 62 6c 65 3e outtxt "</table>
48f0: 3c 2f 62 6f 64 79 3e 3c 2f 68 74 6d 6c 3e 22 29 </body></html>")
4900: 0a 09 09 28 72 65 6c 65 61 73 65 2d 64 6f 74 2d ...(release-dot-
4910: 6c 6f 63 6b 20 6f 75 74 70 75 74 66 69 6c 65 6e lock outputfilen
4920: 61 6d 65 29 29 29 0a 09 20 20 20 20 28 63 6c 6f ame))).. (clo
4930: 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 6f se-output-port o
4940: 75 70 29 0a 09 20 20 20 20 28 63 68 61 6e 67 65 up).. (change
4950: 2d 64 69 72 65 63 74 6f 72 79 20 6f 72 69 67 2d -directory orig-
4960: 64 69 72 29 0a 09 20 20 20 20 3b 3b 20 4e 42 2f dir).. ;; NB/
4970: 2f 20 74 65 73 74 73 3a 74 65 73 74 2d 73 65 74 / tests:test-set
4980: 2d 74 6f 70 6c 6f 67 21 20 69 73 20 72 65 6d 6f -toplog! is remo
4990: 74 65 20 69 6e 74 65 72 6e 61 6c 2e 2e 2e 0a 09 te internal.....
49a0: 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 2d (tests:test-
49b0: 73 65 74 2d 74 6f 70 6c 6f 67 21 20 72 75 6e 2d set-toplog! run-
49c0: 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 6f 75 74 id test-name out
49d0: 70 75 74 66 69 6c 65 6e 61 6d 65 29 0a 09 20 20 putfilename)..
49e0: 20 20 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 )))))..(define
49f0: 20 28 67 65 74 2d 61 6c 6c 2d 6c 65 67 61 6c 2d (get-all-legal-
4a00: 74 65 73 74 73 29 0a 20 20 28 6c 65 74 2a 20 28 tests). (let* (
4a10: 28 74 65 73 74 73 20 20 28 67 6c 6f 62 20 28 63 (tests (glob (c
4a20: 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f onc *toppath* "/
4a30: 74 65 73 74 73 2f 2a 22 29 29 29 0a 09 20 28 72 tests/*"))).. (r
4a40: 65 73 20 20 20 20 27 28 29 29 29 0a 20 20 20 20 es '())).
4a50: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
4a60: 6f 20 34 20 22 4c 6f 6f 6b 69 6e 67 20 61 74 20 o 4 "Looking at
4a70: 74 65 73 74 73 20 22 20 28 73 74 72 69 6e 67 2d tests " (string-
4a80: 69 6e 74 65 72 73 70 65 72 73 65 20 74 65 73 74 intersperse test
4a90: 73 20 22 2c 22 29 29 0a 20 20 20 20 28 66 6f 72 s ",")). (for
4aa0: 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 74 -each (lambda (t
4ab0: 65 73 74 70 61 74 68 29 0a 09 09 28 69 66 20 28 estpath)...(if (
4ac0: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 28 63 6f file-exists? (co
4ad0: 6e 63 20 74 65 73 74 70 61 74 68 20 22 2f 74 65 nc testpath "/te
4ae0: 73 74 63 6f 6e 66 69 67 22 29 29 0a 09 09 20 20 stconfig"))...
4af0: 20 20 28 73 65 74 21 20 72 65 73 20 28 63 6f 6e (set! res (con
4b00: 73 20 28 6c 61 73 74 20 28 73 74 72 69 6e 67 2d s (last (string-
4b10: 73 70 6c 69 74 20 74 65 73 74 70 61 74 68 20 22 split testpath "
4b20: 2f 22 29 29 20 72 65 73 29 29 29 29 0a 09 20 20 /")) res))))..
4b30: 20 20 20 20 74 65 73 74 73 29 0a 20 20 20 20 72 tests). r
4b40: 65 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 es))..(define (t
4b50: 65 73 74 73 3a 67 65 74 2d 74 65 73 74 63 6f 6e ests:get-testcon
4b60: 66 69 67 20 74 65 73 74 2d 6e 61 6d 65 20 73 79 fig test-name sy
4b70: 73 74 65 6d 2d 61 6c 6c 6f 77 65 64 29 0a 20 20 stem-allowed).
4b80: 28 6c 65 74 2a 20 28 28 74 65 73 74 2d 70 61 74 (let* ((test-pat
4b90: 68 20 20 20 20 28 63 6f 6e 63 20 2a 74 6f 70 70 h (conc *topp
4ba0: 61 74 68 2a 20 22 2f 74 65 73 74 73 2f 22 20 74 ath* "/tests/" t
4bb0: 65 73 74 2d 6e 61 6d 65 29 29 0a 09 20 28 74 65 est-name)).. (te
4bc0: 73 74 2d 63 6f 6e 66 69 67 66 20 28 63 6f 6e 63 st-configf (conc
4bd0: 20 74 65 73 74 2d 70 61 74 68 20 22 2f 74 65 73 test-path "/tes
4be0: 74 63 6f 6e 66 69 67 22 29 29 0a 09 20 28 74 65 tconfig")).. (te
4bf0: 73 74 65 78 69 73 74 73 20 20 20 28 61 6e 64 20 stexists (and
4c00: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 74 65 (file-exists? te
4c10: 73 74 2d 63 6f 6e 66 69 67 66 29 28 66 69 6c 65 st-configf)(file
4c20: 2d 72 65 61 64 2d 61 63 63 65 73 73 3f 20 74 65 -read-access? te
4c30: 73 74 2d 63 6f 6e 66 69 67 66 29 29 29 29 0a 20 st-configf)))).
4c40: 20 20 20 28 69 66 20 74 65 73 74 65 78 69 73 74 (if testexist
4c50: 73 0a 09 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 s..(read-config
4c60: 74 65 73 74 2d 63 6f 6e 66 69 67 66 20 23 66 20 test-configf #f
4c70: 73 79 73 74 65 6d 2d 61 6c 6c 6f 77 65 64 20 65 system-allowed e
4c80: 6e 76 69 72 6f 6e 2d 70 61 74 74 3a 20 28 69 66 nviron-patt: (if
4c90: 20 73 79 73 74 65 6d 2d 61 6c 6c 6f 77 65 64 0a system-allowed.
4ca0: 09 09 09 09 09 09 09 09 20 20 20 20 20 20 22 70 ........ "p
4cb0: 72 65 2d 6c 61 75 6e 63 68 2d 65 6e 76 2d 76 61 re-launch-env-va
4cc0: 72 73 22 0a 09 09 09 09 09 09 09 09 20 20 20 20 rs".........
4cd0: 20 20 23 66 29 29 0a 09 23 66 29 29 29 0a 20 20 #f))..#f))).
4ce0: 0a 3b 3b 20 73 6f 72 74 20 74 65 73 74 73 20 62 .;; sort tests b
4cf0: 79 20 70 72 69 6f 72 69 74 79 20 61 6e 64 20 77 y priority and w
4d00: 61 69 74 6f 6e 0a 3b 3b 20 4d 6f 76 65 20 74 65 aiton.;; Move te
4d10: 73 74 20 73 70 65 63 69 66 69 63 20 73 74 75 66 st specific stuf
4d20: 66 20 74 6f 20 61 20 74 65 73 74 20 75 6e 69 74 f to a test unit
4d30: 20 46 49 58 4d 45 20 6f 6e 65 20 6f 66 20 74 68 FIXME one of th
4d40: 65 73 65 20 64 61 79 73 0a 28 64 65 66 69 6e 65 ese days.(define
4d50: 20 28 74 65 73 74 73 3a 73 6f 72 74 2d 62 79 2d (tests:sort-by-
4d60: 70 72 69 6f 72 69 74 79 2d 61 6e 64 2d 77 61 69 priority-and-wai
4d70: 74 6f 6e 20 74 65 73 74 2d 72 65 63 6f 72 64 73 ton test-records
4d80: 29 0a 20 20 28 6c 65 74 20 28 28 6d 75 6e 67 65 ). (let ((munge
4d90: 70 72 69 6f 72 69 74 79 20 28 6c 61 6d 62 64 61 priority (lambda
4da0: 20 28 70 72 69 6f 72 69 74 79 29 0a 09 09 09 20 (priority)....
4db0: 28 69 66 20 70 72 69 6f 72 69 74 79 0a 09 09 09 (if priority....
4dc0: 20 20 20 20 20 28 6c 65 74 20 28 28 74 6d 70 20 (let ((tmp
4dd0: 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 20 70 72 69 (any->number pri
4de0: 6f 72 69 74 79 29 29 29 0a 09 09 09 20 20 20 20 ority)))....
4df0: 20 20 20 28 69 66 20 74 6d 70 20 74 6d 70 20 28 (if tmp tmp (
4e00: 62 65 67 69 6e 20 28 64 65 62 75 67 3a 70 72 69 begin (debug:pri
4e10: 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 62 61 64 nt 0 "ERROR: bad
4e20: 20 70 72 69 6f 72 69 74 79 20 76 61 6c 75 65 20 priority value
4e30: 22 20 70 72 69 6f 72 69 74 79 20 22 2c 20 75 73 " priority ", us
4e40: 69 6e 67 20 30 22 29 20 30 29 29 29 0a 09 09 09 ing 0") 0)))....
4e50: 20 20 20 20 20 30 29 29 29 29 0a 20 20 20 20 28 0)))). (
4e60: 73 6f 72 74 20 0a 20 20 20 20 20 28 68 61 73 68 sort . (hash
4e70: 2d 74 61 62 6c 65 2d 6b 65 79 73 20 74 65 73 74 -table-keys test
4e80: 2d 72 65 63 6f 72 64 73 29 20 3b 3b 20 61 76 6f -records) ;; avo
4e90: 69 64 20 64 65 61 6c 69 6e 67 20 77 69 74 68 20 id dealing with
4ea0: 64 65 6c 65 74 65 64 20 74 65 73 74 73 2c 20 6c deleted tests, l
4eb0: 6f 6f 6b 20 61 74 20 74 68 65 20 68 61 73 68 20 ook at the hash
4ec0: 74 61 62 6c 65 0a 20 20 20 20 20 28 6c 61 6d 62 table. (lamb
4ed0: 64 61 20 28 61 20 62 29 0a 20 20 20 20 20 20 20 da (a b).
4ee0: 28 6c 65 74 2a 20 28 28 61 2d 72 65 63 6f 72 64 (let* ((a-record
4ef0: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 (hash-table-r
4f00: 65 66 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 ef test-records
4f10: 61 29 29 0a 09 20 20 20 20 20 20 28 62 2d 72 65 a)).. (b-re
4f20: 63 6f 72 64 20 20 20 28 68 61 73 68 2d 74 61 62 cord (hash-tab
4f30: 6c 65 2d 72 65 66 20 74 65 73 74 2d 72 65 63 6f le-ref test-reco
4f40: 72 64 73 20 62 29 29 0a 09 20 20 20 20 20 20 28 rds b)).. (
4f50: 61 2d 77 61 69 74 6f 6e 73 20 20 28 74 65 73 74 a-waitons (test
4f60: 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d s:testqueue-get-
4f70: 77 61 69 74 6f 6e 73 20 61 2d 72 65 63 6f 72 64 waitons a-record
4f80: 29 29 0a 09 20 20 20 20 20 20 28 62 2d 77 61 69 )).. (b-wai
4f90: 74 6f 6e 73 20 20 28 74 65 73 74 73 3a 74 65 73 tons (tests:tes
4fa0: 74 71 75 65 75 65 2d 67 65 74 2d 77 61 69 74 6f tqueue-get-waito
4fb0: 6e 73 20 62 2d 72 65 63 6f 72 64 29 29 0a 09 20 ns b-record))..
4fc0: 20 20 20 20 20 28 61 2d 63 6f 6e 66 69 67 20 20 (a-config
4fd0: 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 (tests:testqueu
4fe0: 65 2d 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 e-get-testconfig
4ff0: 20 20 61 2d 72 65 63 6f 72 64 29 29 0a 09 20 20 a-record))..
5000: 20 20 20 20 28 62 2d 63 6f 6e 66 69 67 20 20 20 (b-config
5010: 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 (tests:testqueue
5020: 2d 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 -get-testconfig
5030: 20 62 2d 72 65 63 6f 72 64 29 29 0a 09 20 20 20 b-record))..
5040: 20 20 20 28 61 2d 72 61 77 2d 70 72 69 20 20 28 (a-raw-pri (
5050: 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 61 2d config-lookup a-
5060: 63 6f 6e 66 69 67 20 22 72 65 71 75 69 72 65 6d config "requirem
5070: 65 6e 74 73 22 20 22 70 72 69 6f 72 69 74 79 22 ents" "priority"
5080: 29 29 0a 09 20 20 20 20 20 20 28 62 2d 72 61 77 )).. (b-raw
5090: 2d 70 72 69 20 20 28 63 6f 6e 66 69 67 2d 6c 6f -pri (config-lo
50a0: 6f 6b 75 70 20 62 2d 63 6f 6e 66 69 67 20 22 72 okup b-config "r
50b0: 65 71 75 69 72 65 6d 65 6e 74 73 22 20 22 70 72 equirements" "pr
50c0: 69 6f 72 69 74 79 22 29 29 0a 09 20 20 20 20 20 iority"))..
50d0: 20 28 61 2d 70 72 69 6f 72 69 74 79 20 28 6d 75 (a-priority (mu
50e0: 6e 67 65 70 72 69 6f 72 69 74 79 20 61 2d 72 61 ngepriority a-ra
50f0: 77 2d 70 72 69 29 29 0a 09 20 20 20 20 20 20 28 w-pri)).. (
5100: 62 2d 70 72 69 6f 72 69 74 79 20 28 6d 75 6e 67 b-priority (mung
5110: 65 70 72 69 6f 72 69 74 79 20 62 2d 72 61 77 2d epriority b-raw-
5120: 70 72 69 29 29 29 0a 09 3b 3b 20 20 28 64 65 62 pri)))..;; (deb
5130: 75 67 3a 70 72 69 6e 74 20 35 20 22 73 6f 72 74 ug:print 5 "sort
5140: 2d 62 79 2d 70 72 69 6f 72 69 74 79 2d 61 6e 64 -by-priority-and
5150: 2d 77 61 69 74 6f 6e 2c 20 61 3a 20 22 20 61 20 -waiton, a: " a
5160: 22 20 62 3a 20 22 20 62 0a 09 3b 3b 20 09 20 20 " b: " b..;; .
5170: 20 20 20 20 22 5c 6e 20 20 20 20 20 61 2d 72 65 "\n a-re
5180: 63 6f 72 64 3a 20 20 20 22 20 61 2d 72 65 63 6f cord: " a-reco
5190: 72 64 20 0a 09 3b 3b 20 09 20 20 20 20 20 20 22 rd ..;; . "
51a0: 5c 6e 20 20 20 20 20 62 2d 72 65 63 6f 72 64 3a \n b-record:
51b0: 20 20 20 22 20 62 2d 72 65 63 6f 72 64 0a 09 3b " b-record..;
51c0: 3b 20 09 20 20 20 20 20 20 22 5c 6e 20 20 20 20 ; . "\n
51d0: 20 61 2d 77 61 69 74 6f 6e 73 3a 20 20 22 20 61 a-waitons: " a
51e0: 2d 77 61 69 74 6f 6e 73 0a 09 3b 3b 20 09 20 20 -waitons..;; .
51f0: 20 20 20 20 22 5c 6e 20 20 20 20 20 62 2d 77 61 "\n b-wa
5200: 69 74 6f 6e 73 3a 20 20 22 20 62 2d 77 61 69 74 itons: " b-wait
5210: 6f 6e 73 0a 09 3b 3b 20 09 20 20 20 20 20 20 22 ons..;; . "
5220: 5c 6e 20 20 20 20 20 61 2d 63 6f 6e 66 69 67 3a \n a-config:
5230: 20 20 20 22 20 28 68 61 73 68 2d 74 61 62 6c 65 " (hash-table
5240: 2d 3e 61 6c 69 73 74 20 61 2d 63 6f 6e 66 69 67 ->alist a-config
5250: 29 0a 09 3b 3b 20 09 20 20 20 20 20 20 22 5c 6e )..;; . "\n
5260: 20 20 20 20 20 62 2d 63 6f 6e 66 69 67 3a 20 20 b-config:
5270: 20 22 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 3e " (hash-table->
5280: 61 6c 69 73 74 20 62 2d 63 6f 6e 66 69 67 29 0a alist b-config).
5290: 09 3b 3b 20 09 20 20 20 20 20 20 22 5c 6e 20 20 .;; . "\n
52a0: 20 20 20 61 2d 72 61 77 2d 70 72 69 3a 20 20 22 a-raw-pri: "
52b0: 20 61 2d 72 61 77 2d 70 72 69 0a 09 3b 3b 20 09 a-raw-pri..;; .
52c0: 20 20 20 20 20 20 22 5c 6e 20 20 20 20 20 62 2d "\n b-
52d0: 72 61 77 2d 70 72 69 3a 20 20 22 20 62 2d 72 61 raw-pri: " b-ra
52e0: 77 2d 70 72 69 0a 09 3b 3b 20 09 20 20 20 20 20 w-pri..;; .
52f0: 20 22 5c 6e 20 20 20 20 20 61 2d 70 72 69 6f 72 "\n a-prior
5300: 69 74 79 3a 20 22 20 61 2d 70 72 69 6f 72 69 74 ity: " a-priorit
5310: 79 0a 09 3b 3b 20 09 20 20 20 20 20 20 22 5c 6e y..;; . "\n
5320: 20 20 20 20 20 62 2d 70 72 69 6f 72 69 74 79 3a b-priority:
5330: 20 22 20 62 2d 70 72 69 6f 72 69 74 79 29 0a 09 " b-priority)..
5340: 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 (tests:testqueu
5350: 65 2d 73 65 74 2d 70 72 69 6f 72 69 74 79 21 20 e-set-priority!
5360: 61 2d 72 65 63 6f 72 64 20 61 2d 70 72 69 6f 72 a-record a-prior
5370: 69 74 79 29 0a 09 20 28 74 65 73 74 73 3a 74 65 ity).. (tests:te
5380: 73 74 71 75 65 75 65 2d 73 65 74 2d 70 72 69 6f stqueue-set-prio
5390: 72 69 74 79 21 20 62 2d 72 65 63 6f 72 64 20 62 rity! b-record b
53a0: 2d 70 72 69 6f 72 69 74 79 29 0a 09 20 28 69 66 -priority).. (if
53b0: 20 28 61 6e 64 20 61 2d 77 61 69 74 6f 6e 73 20 (and a-waitons
53c0: 28 6d 65 6d 62 65 72 20 28 74 65 73 74 73 3a 74 (member (tests:t
53d0: 65 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 73 estqueue-get-tes
53e0: 74 6e 61 6d 65 20 62 2d 72 65 63 6f 72 64 29 20 tname b-record)
53f0: 61 2d 77 61 69 74 6f 6e 73 29 29 0a 09 20 20 20 a-waitons))..
5400: 20 20 23 66 20 3b 3b 20 63 61 6e 6e 6f 74 20 68 #f ;; cannot h
5410: 61 76 65 20 61 20 77 68 69 63 68 20 69 73 20 77 ave a which is w
5420: 61 69 74 69 6e 67 20 6f 6e 20 62 20 68 61 70 70 aiting on b happ
5430: 65 6e 69 6e 67 20 62 65 66 6f 72 65 20 62 0a 09 ening before b..
5440: 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 62 2d (if (and b-
5450: 77 61 69 74 6f 6e 73 20 28 6d 65 6d 62 65 72 20 waitons (member
5460: 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 (tests:testqueue
5470: 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 61 2d -get-testname a-
5480: 72 65 63 6f 72 64 29 20 62 2d 77 61 69 74 6f 6e record) b-waiton
5490: 73 29 29 0a 09 09 20 23 74 20 3b 3b 20 74 68 69 s))... #t ;; thi
54a0: 73 20 69 73 20 74 68 65 20 63 6f 72 72 65 63 74 s is the correct
54b0: 20 6f 72 64 65 72 2c 20 62 20 69 73 20 77 61 69 order, b is wai
54c0: 74 69 6e 67 20 6f 6e 20 61 20 61 6e 64 20 62 20 ting on a and b
54d0: 69 73 20 62 65 66 6f 72 65 20 61 0a 09 09 20 28 is before a... (
54e0: 69 66 20 28 3e 20 61 2d 70 72 69 6f 72 69 74 79 if (> a-priority
54f0: 20 62 2d 70 72 69 6f 72 69 74 79 29 0a 09 09 20 b-priority)...
5500: 20 20 20 20 23 74 20 3b 3b 20 69 66 20 61 20 69 #t ;; if a i
5510: 73 20 61 20 68 69 67 68 65 72 20 70 72 69 6f 72 s a higher prior
5520: 69 74 79 20 74 68 61 6e 20 62 20 74 68 65 6e 20 ity than b then
5530: 77 65 20 61 72 65 20 67 6f 6f 64 20 74 6f 20 67 we are good to g
5540: 6f 0a 09 09 20 20 20 20 20 23 66 29 29 29 29 29 o... #f)))))
5550: 29 29 29 0a 0a 3b 3b 20 66 6f 72 20 65 61 63 68 )))..;; for each
5560: 20 74 65 73 74 3a 0a 3b 3b 20 20 20 0a 28 64 65 test:.;; .(de
5570: 66 69 6e 65 20 28 74 65 73 74 73 3a 66 69 6c 74 fine (tests:filt
5580: 65 72 2d 6e 6f 6e 2d 72 75 6e 6e 61 62 6c 65 20 er-non-runnable
5590: 72 75 6e 2d 69 64 20 74 65 73 74 6b 65 79 6e 61 run-id testkeyna
55a0: 6d 65 73 20 74 65 73 74 72 65 63 6f 72 64 73 68 mes testrecordsh
55b0: 61 73 68 29 0a 20 20 28 6c 65 74 20 28 28 72 75 ash). (let ((ru
55c0: 6e 6e 61 62 6c 65 73 20 27 28 29 29 29 0a 20 20 nnables '())).
55d0: 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 (for-each.
55e0: 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 6b 65 (lambda (testke
55f0: 79 6e 61 6d 65 29 0a 20 20 20 20 20 20 20 28 6c yname). (l
5600: 65 74 2a 20 28 28 74 65 73 74 2d 72 65 63 6f 72 et* ((test-recor
5610: 64 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 d (hash-table-re
5620: 66 20 74 65 73 74 72 65 63 6f 72 64 73 68 61 73 f testrecordshas
5630: 68 20 74 65 73 74 6b 65 79 6e 61 6d 65 29 29 0a h testkeyname)).
5640: 09 20 20 20 20 20 20 28 74 65 73 74 2d 6e 61 6d . (test-nam
5650: 65 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 e (tests:testq
5660: 75 65 75 65 2d 67 65 74 2d 74 65 73 74 6e 61 6d ueue-get-testnam
5670: 65 20 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 e test-record))
5680: 0a 09 20 20 20 20 20 20 28 69 74 65 6d 64 61 74 .. (itemdat
5690: 20 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 (tests:test
56a0: 71 75 65 75 65 2d 67 65 74 2d 69 74 65 6d 64 61 queue-get-itemda
56b0: 74 20 20 20 74 65 73 74 2d 72 65 63 6f 72 64 29 t test-record)
56c0: 29 0a 09 20 20 20 20 20 20 28 69 74 65 6d 2d 70 ).. (item-p
56d0: 61 74 68 20 20 20 28 74 65 73 74 73 3a 74 65 73 ath (tests:tes
56e0: 74 71 75 65 75 65 2d 67 65 74 2d 69 74 65 6d 5f tqueue-get-item_
56f0: 70 61 74 68 20 74 65 73 74 2d 72 65 63 6f 72 64 path test-record
5700: 29 29 0a 09 20 20 20 20 20 20 28 77 61 69 74 6f )).. (waito
5710: 6e 73 20 20 20 20 20 28 74 65 73 74 73 3a 74 65 ns (tests:te
5720: 73 74 71 75 65 75 65 2d 67 65 74 2d 77 61 69 74 stqueue-get-wait
5730: 6f 6e 73 20 20 20 74 65 73 74 2d 72 65 63 6f 72 ons test-recor
5740: 64 29 29 0a 09 20 20 20 20 20 20 28 6b 65 65 70 d)).. (keep
5750: 2d 74 65 73 74 20 20 20 23 74 29 0a 09 20 20 20 -test #t)..
5760: 20 20 20 28 74 65 73 74 2d 69 64 20 20 20 20 20 (test-id
5770: 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 (cdb:remote-run
5780: 64 62 3a 67 65 74 2d 74 65 73 74 2d 69 64 20 23 db:get-test-id #
5790: 66 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 f run-id test-na
57a0: 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 0a 09 me item-path))..
57b0: 20 20 20 20 20 20 28 74 64 61 74 20 20 20 20 20 (tdat
57c0: 20 20 20 28 63 64 62 3a 67 65 74 2d 74 65 73 74 (cdb:get-test
57d0: 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 2a 72 75 6e -info-by-id *run
57e0: 72 65 6d 6f 74 65 2a 20 74 65 73 74 2d 69 64 29 remote* test-id)
57f0: 29 29 0a 09 20 28 69 66 20 74 64 61 74 0a 09 20 )).. (if tdat..
5800: 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 (begin..
5810: 20 20 20 3b 3b 20 4c 6f 6f 6b 20 61 74 20 74 68 ;; Look at th
5820: 65 20 74 65 73 74 20 73 74 61 74 65 20 61 6e 64 e test state and
5830: 20 73 74 61 74 75 73 0a 09 20 20 20 20 20 20 20 status..
5840: 28 69 66 20 28 6f 72 20 28 6d 65 6d 62 65 72 20 (if (or (member
5850: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 (db:test-get-sta
5860: 74 75 73 20 74 64 61 74 29 20 0a 09 09 09 20 20 tus tdat) ....
5870: 20 20 20 20 20 27 28 22 50 41 53 53 22 20 22 57 '("PASS" "W
5880: 41 52 4e 22 20 22 57 41 49 56 45 44 22 20 22 43 ARN" "WAIVED" "C
5890: 48 45 43 4b 22 29 29 0a 09 09 20 20 20 20 20 20 HECK"))...
58a0: 20 28 6d 65 6d 62 65 72 20 28 64 62 3a 74 65 73 (member (db:tes
58b0: 74 2d 67 65 74 2d 73 74 61 74 65 20 74 64 61 74 t-get-state tdat
58c0: 29 0a 09 09 09 20 20 20 20 20 20 20 27 28 22 49 ).... '("I
58d0: 4e 43 4f 4d 50 4c 45 54 45 22 20 22 4b 49 4c 4c NCOMPLETE" "KILL
58e0: 45 44 22 29 29 29 0a 09 09 20 20 20 28 73 65 74 ED")))... (set
58f0: 21 20 6b 65 65 70 2d 74 65 73 74 20 23 66 29 29 ! keep-test #f))
5900: 0a 0a 09 20 20 20 20 20 20 20 3b 3b 20 65 78 61 ... ;; exa
5910: 6d 69 6e 65 20 77 61 69 74 6f 6e 73 20 66 6f 72 mine waitons for
5920: 20 61 6e 79 20 66 61 69 6c 73 2e 20 49 66 20 69 any fails. If i
5930: 74 20 69 73 20 46 41 49 4c 20 6f 72 20 49 4e 43 t is FAIL or INC
5940: 4f 4d 50 4c 45 54 45 20 74 68 65 6e 20 65 6c 69 OMPLETE then eli
5950: 6d 69 6e 61 74 65 20 74 68 69 73 20 74 65 73 74 minate this test
5960: 0a 09 20 20 20 20 20 20 20 3b 3b 20 66 72 6f 6d .. ;; from
5970: 20 74 68 65 20 72 75 6e 6e 61 62 6c 65 20 6c 69 the runnable li
5980: 73 74 0a 09 20 20 20 20 20 20 20 28 69 66 20 6b st.. (if k
5990: 65 65 70 2d 74 65 73 74 0a 09 09 20 20 20 28 66 eep-test... (f
59a0: 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 or-each (lambda
59b0: 28 77 61 69 74 6f 6e 29 0a 09 09 09 20 20 20 20 (waiton)....
59c0: 20 20 20 3b 3b 20 66 6f 72 20 6e 6f 77 20 77 65 ;; for now we
59d0: 20 61 72 65 20 77 61 69 74 69 6e 67 20 6f 6e 6c are waiting onl
59e0: 79 20 6f 6e 20 74 68 65 20 70 61 72 65 6e 74 20 y on the parent
59f0: 74 65 73 74 0a 09 09 09 20 20 20 20 20 20 20 28 test.... (
5a00: 6c 65 74 2a 20 28 28 70 61 72 65 6e 74 2d 74 65 let* ((parent-te
5a10: 73 74 2d 69 64 20 28 63 64 62 3a 72 65 6d 6f 74 st-id (cdb:remot
5a20: 65 2d 72 75 6e 20 64 62 3a 67 65 74 2d 74 65 73 e-run db:get-tes
5a30: 74 2d 69 64 20 23 66 20 72 75 6e 2d 69 64 20 77 t-id #f run-id w
5a40: 61 69 74 6f 6e 20 22 22 29 29 0a 09 09 09 09 20 aiton "")).....
5a50: 20 20 20 20 20 28 77 74 64 61 74 20 28 63 64 62 (wtdat (cdb
5a60: 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 :get-test-info-b
5a70: 79 2d 69 64 20 2a 72 75 6e 72 65 6d 6f 74 65 2a y-id *runremote*
5a80: 20 74 65 73 74 2d 69 64 29 29 29 0a 09 09 09 09 test-id))).....
5a90: 20 28 69 66 20 28 6f 72 20 28 6d 65 6d 62 65 72 (if (or (member
5aa0: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 (db:test-get-st
5ab0: 61 74 75 73 20 77 74 64 61 74 29 0a 09 09 09 09 atus wtdat).....
5ac0: 09 09 20 27 28 22 46 41 49 4c 22 20 22 4b 49 4c .. '("FAIL" "KIL
5ad0: 4c 45 44 22 29 29 0a 09 09 09 09 09 20 28 6d 65 LED"))...... (me
5ae0: 6d 62 65 72 20 28 64 62 3a 74 65 73 74 2d 67 65 mber (db:test-ge
5af0: 74 2d 73 74 61 74 65 20 77 74 64 61 74 29 0a 09 t-state wtdat)..
5b00: 09 09 09 09 09 20 27 28 22 49 4e 43 4f 4d 50 45 ..... '("INCOMPE
5b10: 54 45 22 29 29 29 0a 09 09 09 09 20 20 20 20 20 TE"))).....
5b20: 28 73 65 74 21 20 6b 65 65 70 2d 74 65 73 74 20 (set! keep-test
5b30: 23 66 29 29 29 29 20 3b 3b 20 6e 6f 20 70 6f 69 #f)))) ;; no poi
5b40: 6e 74 20 69 6e 20 72 75 6e 6e 69 6e 67 20 74 68 nt in running th
5b50: 69 73 20 6f 6e 65 20 61 67 61 69 6e 0a 09 09 09 is one again....
5b60: 20 20 20 20 20 77 61 69 74 6f 6e 73 29 29 29 29 waitons))))
5b70: 0a 09 20 28 69 66 20 6b 65 65 70 2d 74 65 73 74 .. (if keep-test
5b80: 20 28 73 65 74 21 20 72 75 6e 6e 61 62 6c 65 73 (set! runnables
5b90: 20 28 63 6f 6e 73 20 74 65 73 74 6b 65 79 6e 61 (cons testkeyna
5ba0: 6d 65 20 72 75 6e 6e 61 62 6c 65 73 29 29 29 29 me runnables))))
5bb0: 29 0a 20 20 20 20 20 74 65 73 74 6b 65 79 6e 61 ). testkeyna
5bc0: 6d 65 73 29 0a 20 20 20 20 72 75 6e 6e 61 62 6c mes). runnabl
5bd0: 65 73 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d es))..;;========
5be0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5bf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5c00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5c10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
5c20: 3b 20 74 65 73 74 20 73 74 65 70 73 0a 3b 3b 3d ; test steps.;;=
5c30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5c40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5c50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5c60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5c70: 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 74 65 73 74 73 74 =====..;; testst
5c80: 65 70 2d 73 65 74 2d 73 74 61 74 75 73 21 20 75 ep-set-status! u
5c90: 73 65 64 20 74 6f 20 62 65 20 68 65 72 65 0a 0a sed to be here..
5ca0: 28 64 65 66 69 6e 65 20 28 74 65 73 74 2d 67 65 (define (test-ge
5cb0: 74 2d 6b 69 6c 6c 2d 72 65 71 75 65 73 74 20 74 t-kill-request t
5cc0: 65 73 74 2d 69 64 29 20 3b 3b 20 72 75 6e 2d 69 est-id) ;; run-i
5cd0: 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d d test-name item
5ce0: 64 61 74 29 0a 20 20 28 6c 65 74 2a 20 28 3b 3b dat). (let* (;;
5cf0: 20 28 69 74 65 6d 2d 70 61 74 68 20 28 69 74 65 (item-path (ite
5d00: 6d 2d 6c 69 73 74 2d 3e 70 61 74 68 20 69 74 65 m-list->path ite
5d10: 6d 64 61 74 29 29 0a 09 20 28 74 65 73 74 64 61 mdat)).. (testda
5d20: 74 20 20 20 28 63 64 62 3a 67 65 74 2d 74 65 73 t (cdb:get-tes
5d30: 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 2a 72 75 t-info-by-id *ru
5d40: 6e 72 65 6d 6f 74 65 2a 20 74 65 73 74 2d 69 64 nremote* test-id
5d50: 29 29 29 20 3b 3b 20 72 75 6e 2d 69 64 20 74 65 ))) ;; run-id te
5d60: 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 st-name item-pat
5d70: 68 29 29 29 0a 20 20 20 20 28 65 71 75 61 6c 3f h))). (equal?
5d80: 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 (test:get-state
5d90: 20 74 65 73 74 64 61 74 29 20 22 4b 49 4c 4c 52 testdat) "KILLR
5da0: 45 51 22 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 EQ")))..(define
5db0: 28 74 65 73 74 3a 74 64 62 2d 67 65 74 2d 72 75 (test:tdb-get-ru
5dc0: 6e 64 61 74 2d 63 6f 75 6e 74 20 74 64 62 29 0a ndat-count tdb).
5dd0: 20 20 28 69 66 20 74 64 62 0a 20 20 20 20 20 20 (if tdb.
5de0: 28 6c 65 74 20 28 28 72 65 73 20 30 29 29 0a 09 (let ((res 0))..
5df0: 28 73 71 6c 69 74 65 33 3a 66 6f 72 2d 65 61 63 (sqlite3:for-eac
5e00: 68 2d 72 6f 77 0a 09 20 28 6c 61 6d 62 64 61 20 h-row.. (lambda
5e10: 28 63 6f 75 6e 74 29 0a 09 20 20 20 28 73 65 74 (count).. (set
5e20: 21 20 72 65 73 20 63 6f 75 6e 74 29 29 0a 09 20 ! res count))..
5e30: 74 64 62 0a 09 20 22 53 45 4c 45 43 54 20 63 6f tdb.. "SELECT co
5e40: 75 6e 74 28 69 64 29 20 46 52 4f 4d 20 74 65 73 unt(id) FROM tes
5e50: 74 5f 72 75 6e 64 61 74 3b 22 29 0a 09 72 65 73 t_rundat;")..res
5e60: 29 29 0a 20 20 30 29 0a 0a 28 64 65 66 69 6e 65 )). 0)..(define
5e70: 20 28 64 62 3a 75 70 64 61 74 65 2d 63 65 6e 74 (db:update-cent
5e80: 72 61 6c 2d 6d 65 74 61 2d 69 6e 66 6f 20 64 62 ral-meta-info db
5e90: 20 74 65 73 74 2d 69 64 20 63 70 75 6c 6f 61 64 test-id cpuload
5ea0: 20 64 69 73 6b 66 72 65 65 20 6d 69 6e 75 74 65 diskfree minute
5eb0: 73 20 6e 75 6d 2d 72 65 63 6f 72 64 73 20 75 6e s num-records un
5ec0: 61 6d 65 20 68 6f 73 74 6e 61 6d 65 29 0a 20 20 ame hostname).
5ed0: 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 (sqlite3:execute
5ee0: 20 64 62 20 22 55 50 44 41 54 45 20 74 65 73 74 db "UPDATE test
5ef0: 73 20 53 45 54 20 63 70 75 6c 6f 61 64 3d 3f 2c s SET cpuload=?,
5f00: 64 69 73 6b 66 72 65 65 3d 3f 20 57 48 45 52 45 diskfree=? WHERE
5f10: 20 69 64 3d 3f 3b 22 0a 09 09 20 20 20 63 70 75 id=?;"... cpu
5f20: 6c 6f 61 64 0a 09 09 20 20 20 64 69 73 6b 66 72 load... diskfr
5f30: 65 65 0a 09 09 20 20 20 74 65 73 74 2d 69 64 29 ee... test-id)
5f40: 0a 20 20 28 69 66 20 6d 69 6e 75 74 65 73 20 28 . (if minutes (
5f50: 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 sqlite3:execute
5f60: 64 62 20 22 55 50 44 41 54 45 20 74 65 73 74 73 db "UPDATE tests
5f70: 20 53 45 54 20 72 75 6e 5f 64 75 72 61 74 69 6f SET run_duratio
5f80: 6e 3d 3f 20 57 48 45 52 45 20 69 64 3d 3f 3b 22 n=? WHERE id=?;"
5f90: 20 6d 69 6e 75 74 65 73 20 74 65 73 74 2d 69 64 minutes test-id
5fa0: 29 29 0a 20 20 28 69 66 20 28 65 71 3f 20 6e 75 )). (if (eq? nu
5fb0: 6d 2d 72 65 63 6f 72 64 73 20 30 29 0a 20 20 20 m-records 0).
5fc0: 20 20 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 (sqlite3:exec
5fd0: 75 74 65 20 64 62 20 22 55 50 44 41 54 45 20 74 ute db "UPDATE t
5fe0: 65 73 74 73 20 53 45 54 20 75 6e 61 6d 65 3d 3f ests SET uname=?
5ff0: 2c 68 6f 73 74 3d 3f 20 57 48 45 52 45 20 69 64 ,host=? WHERE id
6000: 3d 3f 3b 22 0a 09 09 20 20 20 20 20 20 20 75 6e =?;"... un
6010: 61 6d 65 20 68 6f 73 74 6e 61 6d 65 20 74 65 73 ame hostname tes
6020: 74 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 t-id)))..(define
6030: 20 28 74 65 73 74 2d 73 65 74 2d 6d 65 74 61 2d (test-set-meta-
6040: 69 6e 66 6f 20 64 62 20 74 65 73 74 2d 69 64 20 info db test-id
6050: 72 75 6e 2d 69 64 20 74 65 73 74 6e 61 6d 65 20 run-id testname
6060: 69 74 65 6d 64 61 74 20 6d 69 6e 75 74 65 73 29 itemdat minutes)
6070: 0a 20 20 3b 3b 20 44 4f 45 53 20 63 64 62 3a 72 . ;; DOES cdb:r
6080: 65 6d 6f 74 65 2d 72 75 6e 20 75 6e 64 65 72 20 emote-run under
6090: 74 68 65 20 68 6f 6f 64 21 0a 20 20 28 6c 65 74 the hood!. (let
60a0: 2a 20 28 28 74 64 62 20 20 20 20 20 20 20 20 20 * ((tdb
60b0: 28 64 62 3a 6f 70 65 6e 2d 74 65 73 74 2d 64 62 (db:open-test-db
60c0: 2d 62 79 2d 74 65 73 74 2d 69 64 20 64 62 20 74 -by-test-id db t
60d0: 65 73 74 2d 69 64 29 29 0a 09 20 28 6e 75 6d 2d est-id)).. (num-
60e0: 72 65 63 6f 72 64 73 20 28 74 65 73 74 3a 74 64 records (test:td
60f0: 62 2d 67 65 74 2d 72 75 6e 64 61 74 2d 63 6f 75 b-get-rundat-cou
6100: 6e 74 20 74 64 62 29 29 0a 09 20 28 63 70 75 6c nt tdb)).. (cpul
6110: 6f 61 64 20 20 28 67 65 74 2d 63 70 75 2d 6c 6f oad (get-cpu-lo
6120: 61 64 29 29 0a 09 20 28 64 69 73 6b 66 72 65 65 ad)).. (diskfree
6130: 20 28 67 65 74 2d 64 66 20 28 63 75 72 72 65 6e (get-df (curren
6140: 74 2d 64 69 72 65 63 74 6f 72 79 29 29 29 29 0a t-directory)))).
6150: 20 20 20 20 28 69 66 20 28 65 71 3f 20 28 6d 6f (if (eq? (mo
6160: 64 75 6c 6f 20 6e 75 6d 2d 72 65 63 6f 72 64 73 dulo num-records
6170: 20 31 30 29 20 30 29 20 3b 3b 20 65 76 65 72 79 10) 0) ;; every
6180: 20 74 65 6e 20 72 65 63 6f 72 64 73 20 75 70 64 ten records upd
6190: 61 74 65 20 63 65 6e 74 72 61 6c 0a 09 28 6c 65 ate central..(le
61a0: 74 20 28 28 75 6e 61 6d 65 20 20 20 20 28 67 65 t ((uname (ge
61b0: 74 2d 75 6e 61 6d 65 20 22 2d 73 72 76 70 69 6f t-uname "-srvpio
61c0: 22 29 29 0a 09 20 20 20 20 20 20 28 68 6f 73 74 ")).. (host
61d0: 6e 61 6d 65 20 28 67 65 74 2d 68 6f 73 74 2d 6e name (get-host-n
61e0: 61 6d 65 29 29 29 0a 09 20 20 28 63 64 62 3a 72 ame))).. (cdb:r
61f0: 65 6d 6f 74 65 2d 72 75 6e 20 64 62 3a 75 70 64 emote-run db:upd
6200: 61 74 65 2d 63 65 6e 74 72 61 6c 2d 6d 65 74 61 ate-central-meta
6210: 2d 69 6e 66 6f 20 64 62 20 74 65 73 74 2d 69 64 -info db test-id
6220: 20 63 70 75 6c 6f 61 64 20 64 69 73 6b 66 72 65 cpuload diskfre
6230: 65 20 6d 69 6e 75 74 65 73 20 6e 75 6d 2d 72 65 e minutes num-re
6240: 63 6f 72 64 73 20 75 6e 61 6d 65 20 68 6f 73 74 cords uname host
6250: 6e 61 6d 65 29 29 29 0a 20 20 20 20 28 73 71 6c name))). (sql
6260: 69 74 65 33 3a 65 78 65 63 75 74 65 20 74 64 62 ite3:execute tdb
6270: 20 22 49 4e 53 45 52 54 20 49 4e 54 4f 20 74 65 "INSERT INTO te
6280: 73 74 5f 72 75 6e 64 61 74 20 28 75 70 64 61 74 st_rundat (updat
6290: 65 5f 74 69 6d 65 2c 63 70 75 6c 6f 61 64 2c 64 e_time,cpuload,d
62a0: 69 73 6b 66 72 65 65 2c 72 75 6e 5f 64 75 72 61 iskfree,run_dura
62b0: 74 69 6f 6e 29 20 56 41 4c 55 45 53 20 28 73 74 tion) VALUES (st
62c0: 72 66 74 69 6d 65 28 27 25 73 27 2c 27 6e 6f 77 rftime('%s','now
62d0: 27 29 2c 3f 2c 3f 2c 3f 29 3b 22 0a 09 09 20 20 '),?,?,?);"...
62e0: 20 20 20 63 70 75 6c 6f 61 64 20 64 69 73 6b 66 cpuload diskf
62f0: 72 65 65 20 6d 69 6e 75 74 65 73 29 29 29 0a 09 ree minutes)))..
6300: 20 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;===========
6310: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6320: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6330: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6340: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 41 ===========.;; A
6350: 20 52 20 43 20 48 20 49 20 56 20 49 20 4e 20 47 R C H I V I N G
6360: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
6370: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6380: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6390: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
63a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 =========..(defi
63b0: 6e 65 20 28 74 65 73 74 3a 61 72 63 68 69 76 65 ne (test:archive
63c0: 20 64 62 20 74 65 73 74 2d 69 64 29 0a 20 20 23 db test-id). #
63d0: 66 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 f)..(define (tes
63e0: 74 3a 61 72 63 68 69 76 65 2d 74 65 73 74 73 20 t:archive-tests
63f0: 64 62 20 6b 65 79 6e 61 6d 65 73 20 74 61 72 67 db keynames targ
6400: 65 74 29 0a 20 20 23 66 29 0a 0a et). #f)..