0000: 0a 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 32 30 .;; Copyright 20
0010: 30 36 2d 32 30 31 31 2c 20 4d 61 74 74 68 65 77 06-2011, Matthew
0020: 20 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 0a 3b 3b Welland..;; .;;
0030: 20 20 54 68 69 73 20 70 72 6f 67 72 61 6d 20 69 This program i
0040: 73 20 6d 61 64 65 20 61 76 61 69 6c 61 62 6c 65 s made available
0050: 20 75 6e 64 65 72 20 74 68 65 20 47 4e 55 20 47 under the GNU G
0060: 50 4c 20 76 65 72 73 69 6f 6e 20 32 2e 30 20 6f PL version 2.0 o
0070: 72 0a 3b 3b 20 20 67 72 65 61 74 65 72 2e 20 53 r.;; greater. S
0080: 65 65 20 74 68 65 20 61 63 63 6f 6d 70 61 6e 79 ee the accompany
0090: 69 6e 67 20 66 69 6c 65 20 43 4f 50 59 49 4e 47 ing file COPYING
00a0: 20 66 6f 72 20 64 65 74 61 69 6c 73 2e 0a 3b 3b for details..;;
00b0: 20 0a 3b 3b 20 20 54 68 69 73 20 70 72 6f 67 72 .;; This progr
00c0: 61 6d 20 69 73 20 64 69 73 74 72 69 62 75 74 65 am is distribute
00d0: 64 20 57 49 54 48 4f 55 54 20 41 4e 59 20 57 41 d WITHOUT ANY WA
00e0: 52 52 41 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 RRANTY; without
00f0: 65 76 65 6e 20 74 68 65 0a 3b 3b 20 20 69 6d 70 even the.;; imp
0100: 6c 69 65 64 20 77 61 72 72 61 6e 74 79 20 6f 66 lied warranty of
0110: 20 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 MERCHANTABILITY
0120: 20 6f 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 or FITNESS FOR
0130: 41 20 50 41 52 54 49 43 55 4c 41 52 0a 3b 3b 20 A PARTICULAR.;;
0140: 20 50 55 52 50 4f 53 45 2e 0a 0a 3b 3b 20 20 73 PURPOSE...;; s
0150: 74 72 66 74 69 6d 65 28 27 25 6d 2f 25 64 2f 25 trftime('%m/%d/%
0160: 59 20 25 48 3a 25 4d 3a 25 53 27 2c 27 6e 6f 77 Y %H:%M:%S','now
0170: 27 2c 27 6c 6f 63 61 6c 74 69 6d 65 27 29 0a 0a ','localtime')..
0180: 28 75 73 65 20 73 71 6c 69 74 65 33 20 73 72 66 (use sqlite3 srf
0190: 69 2d 31 20 70 6f 73 69 78 20 72 65 67 65 78 20 i-1 posix regex
01a0: 72 65 67 65 78 2d 63 61 73 65 20 73 72 66 69 2d regex-case srfi-
01b0: 36 39 20 64 6f 74 2d 6c 6f 63 6b 69 6e 67 20 28 69 dot-locking (
01c0: 73 72 66 69 20 31 38 29 20 70 6f 73 69 78 2d 65 srfi 18) posix-e
01d0: 78 74 72 61 73 20 64 69 72 65 63 74 6f 72 79 2d xtras directory-
01e0: 75 74 69 6c 73 29 0a 28 69 6d 70 6f 72 74 20 28 utils).(import (
01f0: 70 72 65 66 69 78 20 73 71 6c 69 74 65 33 20 73 prefix sqlite3 s
0200: 71 6c 69 74 65 33 3a 29 29 0a 0a 28 64 65 63 6c qlite3:))..(decl
0210: 61 72 65 20 28 75 6e 69 74 20 72 75 6e 73 29 29 are (unit runs))
0220: 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 .(declare (uses
0230: 64 62 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 db)).(declare (u
0240: 73 65 73 20 63 6f 6d 6d 6f 6e 29 29 0a 28 64 65 ses common)).(de
0250: 63 6c 61 72 65 20 28 75 73 65 73 20 69 74 65 6d clare (uses item
0260: 73 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 s)).(declare (us
0270: 65 73 20 72 75 6e 63 6f 6e 66 69 67 29 29 0a 28 es runconfig)).(
0280: 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 74 65 declare (uses te
0290: 73 74 73 29 29 0a 28 64 65 63 6c 61 72 65 20 28 sts)).(declare (
02a0: 75 73 65 73 20 73 65 72 76 65 72 29 29 0a 0a 28 uses server))..(
02b0: 69 6e 63 6c 75 64 65 20 22 63 6f 6d 6d 6f 6e 5f include "common_
02c0: 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a 28 69 records.scm").(i
02d0: 6e 63 6c 75 64 65 20 22 6b 65 79 5f 72 65 63 6f nclude "key_reco
02e0: 72 64 73 2e 73 63 6d 22 29 0a 28 69 6e 63 6c 75 rds.scm").(inclu
02f0: 64 65 20 22 64 62 5f 72 65 63 6f 72 64 73 2e 73 de "db_records.s
0300: 63 6d 22 29 0a 28 69 6e 63 6c 75 64 65 20 22 72 cm").(include "r
0310: 75 6e 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 un_records.scm")
0320: 0a 28 69 6e 63 6c 75 64 65 20 22 74 65 73 74 5f .(include "test_
0330: 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a 0a 3b records.scm")..;
0340: 3b 20 72 75 6e 73 3a 67 65 74 2d 72 75 6e 73 2d ; runs:get-runs-
0350: 62 79 2d 70 61 74 74 0a 3b 3b 20 67 65 74 20 72 by-patt.;; get r
0360: 75 6e 73 20 62 79 20 6c 69 73 74 20 6f 66 20 63 uns by list of c
0370: 72 69 74 65 72 69 61 0a 3b 3b 20 72 65 67 69 73 riteria.;; regis
0380: 74 65 72 20 61 20 74 65 73 74 20 72 75 6e 20 77 ter a test run w
0390: 69 74 68 20 74 68 65 20 64 62 0a 3b 3b 0a 3b 3b ith the db.;;.;;
03a0: 20 55 73 65 3a 20 28 64 62 2d 67 65 74 2d 76 61 Use: (db-get-va
03b0: 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 28 64 lue-by-header (d
03c0: 62 3a 67 65 74 2d 68 65 61 64 65 72 20 72 75 6e b:get-header run
03d0: 69 6e 66 6f 29 28 64 62 3a 67 65 74 2d 72 6f 77 info)(db:get-row
03e0: 20 72 75 6e 69 6e 66 6f 29 29 0a 3b 3b 20 20 74 runinfo)).;; t
03f0: 6f 20 65 78 74 72 61 63 74 20 69 6e 66 6f 20 66 o extract info f
0400: 72 6f 6d 20 74 68 65 20 73 74 72 75 63 74 75 72 rom the structur
0410: 65 20 72 65 74 75 72 6e 65 64 0a 3b 3b 0a 28 64 e returned.;;.(d
0420: 65 66 69 6e 65 20 28 72 75 6e 73 3a 67 65 74 2d efine (runs:get-
0430: 72 75 6e 73 2d 62 79 2d 70 61 74 74 20 64 62 20 runs-by-patt db
0440: 6b 65 79 73 20 72 75 6e 6e 61 6d 65 70 61 74 74 keys runnamepatt
0450: 20 2e 20 70 61 72 61 6d 73 29 20 3b 3b 20 74 65 . params) ;; te
0460: 73 74 2d 6e 61 6d 65 29 0a 20 20 28 6c 65 74 2a st-name). (let*
0470: 20 28 28 6b 65 79 76 61 6c 6c 73 74 20 28 6b 65 ((keyvallst (ke
0480: 79 73 2d 3e 76 61 6c 6c 69 73 74 20 6b 65 79 73 ys->vallist keys
0490: 29 29 0a 09 20 28 74 6d 70 20 20 20 20 20 20 28 )).. (tmp (
04a0: 72 75 6e 73 3a 67 65 74 2d 73 74 64 2d 72 75 6e runs:get-std-run
04b0: 2d 66 69 65 6c 64 73 20 6b 65 79 73 20 27 28 22 -fields keys '("
04c0: 69 64 22 20 22 72 75 6e 6e 61 6d 65 22 20 22 73 id" "runname" "s
04d0: 74 61 74 65 22 20 22 73 74 61 74 75 73 22 20 22 tate" "status" "
04e0: 6f 77 6e 65 72 22 20 22 65 76 65 6e 74 5f 74 69 owner" "event_ti
04f0: 6d 65 22 29 29 29 0a 09 20 28 6b 65 79 73 74 72 me"))).. (keystr
0500: 20 20 20 28 63 61 72 20 74 6d 70 29 29 0a 09 20 (car tmp))..
0510: 28 68 65 61 64 65 72 20 20 20 28 63 61 64 72 20 (header (cadr
0520: 74 6d 70 29 29 0a 09 20 28 72 65 73 20 20 20 20 tmp)).. (res
0530: 20 27 28 29 29 0a 09 20 28 6b 65 79 2d 70 61 74 '()).. (key-pat
0540: 74 20 22 22 29 29 0a 20 20 20 20 28 66 6f 72 2d t "")). (for-
0550: 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 6b 65 each (lambda (ke
0560: 79 76 61 6c 29 0a 09 09 28 6c 65 74 2a 20 28 28 yval)...(let* ((
0570: 6b 65 79 20 20 20 20 28 76 65 63 74 6f 72 2d 72 key (vector-r
0580: 65 66 20 6b 65 79 76 61 6c 20 30 29 29 0a 09 09 ef keyval 0))...
0590: 20 20 20 20 20 20 20 28 66 75 6c 6b 65 79 20 28 (fulkey (
05a0: 63 6f 6e 63 20 22 3a 22 20 6b 65 79 29 29 0a 09 conc ":" key))..
05b0: 09 20 20 20 20 20 20 20 28 70 61 74 74 20 20 20 . (patt
05c0: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 66 75 (args:get-arg fu
05d0: 6c 6b 65 79 29 29 29 0a 09 09 20 20 28 69 66 20 lkey)))... (if
05e0: 70 61 74 74 0a 09 09 20 20 20 20 20 20 28 73 65 patt... (se
05f0: 74 21 20 6b 65 79 2d 70 61 74 74 20 28 63 6f 6e t! key-patt (con
0600: 63 20 6b 65 79 2d 70 61 74 74 20 22 20 41 4e 44 c key-patt " AND
0610: 20 22 20 6b 65 79 20 22 20 6c 69 6b 65 20 27 22 " key " like '"
0620: 20 70 61 74 74 20 22 27 22 29 29 0a 09 09 20 20 patt "'"))...
0630: 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 28 64 (begin....(d
0640: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 ebug:print 0 "ER
0650: 52 4f 52 3a 20 73 65 61 72 63 68 69 6e 67 20 66 ROR: searching f
0660: 6f 72 20 72 75 6e 73 20 77 69 74 68 20 6e 6f 20 or runs with no
0670: 70 61 74 74 65 72 6e 20 73 65 74 20 66 6f 72 20 pattern set for
0680: 22 20 66 75 6c 6b 65 79 29 0a 09 09 09 28 65 78 " fulkey)....(ex
0690: 69 74 20 36 29 29 29 29 29 0a 09 20 20 20 20 20 it 6)))))..
06a0: 20 6b 65 79 73 29 0a 20 20 20 20 28 73 71 6c 69 keys). (sqli
06b0: 74 65 33 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 te3:for-each-row
06c0: 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 . (lambda (
06d0: 61 20 2e 20 72 29 0a 20 20 20 20 20 20 20 28 73 a . r). (s
06e0: 65 74 21 20 72 65 73 20 28 63 6f 6e 73 20 28 6c et! res (cons (l
06f0: 69 73 74 2d 3e 76 65 63 74 6f 72 20 28 63 6f 6e ist->vector (con
0700: 73 20 61 20 72 29 29 20 72 65 73 29 29 29 0a 20 s a r)) res))).
0710: 20 20 20 20 64 62 20 0a 20 20 20 20 20 28 63 6f db . (co
0720: 6e 63 20 22 53 45 4c 45 43 54 20 22 20 6b 65 79 nc "SELECT " key
0730: 73 74 72 20 22 20 46 52 4f 4d 20 72 75 6e 73 20 str " FROM runs
0740: 57 48 45 52 45 20 72 75 6e 6e 61 6d 65 20 6c 69 WHERE runname li
0750: 6b 65 20 3f 20 22 20 6b 65 79 2d 70 61 74 74 20 ke ? " key-patt
0760: 22 3b 22 29 0a 20 20 20 20 20 72 75 6e 6e 61 6d ";"). runnam
0770: 65 70 61 74 74 29 0a 20 20 20 20 28 76 65 63 74 epatt). (vect
0780: 6f 72 20 68 65 61 64 65 72 20 72 65 73 29 29 29 or header res)))
0790: 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a ..(define (runs:
07a0: 74 65 73 74 2d 67 65 74 2d 66 75 6c 6c 2d 70 61 test-get-full-pa
07b0: 74 68 20 74 65 73 74 29 0a 20 20 28 6c 65 74 2a th test). (let*
07c0: 20 28 28 74 65 73 74 6e 61 6d 65 20 28 64 62 3a ((testname (db:
07d0: 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d test-get-testnam
07e0: 65 20 20 20 74 65 73 74 29 29 0a 09 20 28 69 74 e test)).. (it
07f0: 65 6d 70 61 74 68 20 28 64 62 3a 74 65 73 74 2d empath (db:test-
0800: 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 65 get-item-path te
0810: 73 74 29 29 29 0a 20 20 20 20 28 63 6f 6e 63 20 st))). (conc
0820: 74 65 73 74 6e 61 6d 65 20 28 69 66 20 28 65 71 testname (if (eq
0830: 75 61 6c 3f 20 69 74 65 6d 70 61 74 68 20 22 22 ual? itempath ""
0840: 29 20 22 22 20 28 63 6f 6e 63 20 22 28 22 20 69 ) "" (conc "(" i
0850: 74 65 6d 70 61 74 68 20 22 29 22 29 29 29 29 29 tempath ")")))))
0860: 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 74 2d 6d ..(define (set-m
0870: 65 67 61 74 65 73 74 2d 65 6e 76 2d 76 61 72 73 egatest-env-vars
0880: 20 64 62 20 72 75 6e 2d 69 64 29 0a 20 20 28 6c db run-id). (l
0890: 65 74 20 28 28 6b 65 79 73 20 28 64 62 3a 67 65 et ((keys (db:ge
08a0: 74 2d 6b 65 79 73 20 64 62 29 29 29 0a 20 20 20 t-keys db))).
08b0: 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 (for-each (lamb
08c0: 64 61 20 28 6b 65 79 29 0a 09 09 28 73 71 6c 69 da (key)...(sqli
08d0: 74 65 33 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 te3:for-each-row
08e0: 0a 09 09 20 28 6c 61 6d 62 64 61 20 28 76 61 6c ... (lambda (val
08f0: 29 0a 09 09 20 20 20 28 64 65 62 75 67 3a 70 72 )... (debug:pr
0900: 69 6e 74 20 32 20 22 73 65 74 65 6e 76 20 22 20 int 2 "setenv "
0910: 28 6b 65 79 3a 67 65 74 2d 66 69 65 6c 64 6e 61 (key:get-fieldna
0920: 6d 65 20 6b 65 79 29 20 22 20 22 20 76 61 6c 29 me key) " " val)
0930: 0a 09 09 20 20 20 28 73 65 74 65 6e 76 20 28 6b ... (setenv (k
0940: 65 79 3a 67 65 74 2d 66 69 65 6c 64 6e 61 6d 65 ey:get-fieldname
0950: 20 6b 65 79 29 20 76 61 6c 29 29 0a 09 09 20 64 key) val))... d
0960: 62 20 0a 09 09 20 28 63 6f 6e 63 20 22 53 45 4c b ... (conc "SEL
0970: 45 43 54 20 22 20 28 6b 65 79 3a 67 65 74 2d 66 ECT " (key:get-f
0980: 69 65 6c 64 6e 61 6d 65 20 6b 65 79 29 20 22 20 ieldname key) "
0990: 46 52 4f 4d 20 72 75 6e 73 20 57 48 45 52 45 20 FROM runs WHERE
09a0: 69 64 3d 3f 3b 22 29 0a 09 09 20 72 75 6e 2d 69 id=?;")... run-i
09b0: 64 29 29 0a 09 20 20 20 20 20 20 6b 65 79 73 29 d)).. keys)
09c0: 0a 20 20 20 20 28 61 6c 69 73 74 2d 3e 65 6e 76 . (alist->env
09d0: 2d 76 61 72 73 20 28 68 61 73 68 2d 74 61 62 6c -vars (hash-tabl
09e0: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 63 e-ref/default *c
09f0: 6f 6e 66 69 67 64 61 74 2a 20 22 65 6e 76 2d 6f onfigdat* "env-o
0a00: 76 65 72 72 69 64 65 22 20 27 28 29 29 29 0a 20 verride" '())).
0a10: 20 20 20 3b 3b 20 4c 65 74 73 20 75 73 65 20 74 ;; Lets use t
0a20: 68 69 73 20 61 73 20 61 6e 20 6f 70 70 6f 72 74 his as an opport
0a30: 75 6e 69 74 79 20 74 6f 20 70 75 74 20 4d 54 5f unity to put MT_
0a40: 52 55 4e 4e 41 4d 45 20 69 6e 20 74 68 65 20 65 RUNNAME in the e
0a50: 6e 76 69 72 6f 6e 6d 65 6e 74 0a 20 20 20 20 28 nvironment. (
0a60: 73 71 6c 69 74 65 33 3a 66 6f 72 2d 65 61 63 68 sqlite3:for-each
0a70: 2d 72 6f 77 0a 20 20 20 20 20 28 6c 61 6d 62 64 -row. (lambd
0a80: 61 20 28 72 75 6e 6e 61 6d 65 29 0a 20 20 20 20 a (runname).
0a90: 20 20 20 28 73 65 74 65 6e 76 20 22 4d 54 5f 52 (setenv "MT_R
0aa0: 55 4e 4e 41 4d 45 22 20 72 75 6e 6e 61 6d 65 29 UNNAME" runname)
0ab0: 29 0a 20 20 20 20 20 64 62 0a 20 20 20 20 20 22 ). db. "
0ac0: 53 45 4c 45 43 54 20 72 75 6e 6e 61 6d 65 20 46 SELECT runname F
0ad0: 52 4f 4d 20 72 75 6e 73 20 57 48 45 52 45 20 69 ROM runs WHERE i
0ae0: 64 3d 3f 3b 22 0a 20 20 20 20 20 72 75 6e 2d 69 d=?;". run-i
0af0: 64 29 0a 20 20 20 20 29 29 0a 0a 28 64 65 66 69 d). ))..(defi
0b00: 6e 65 20 28 73 65 74 2d 69 74 65 6d 2d 65 6e 76 ne (set-item-env
0b10: 2d 76 61 72 73 20 69 74 65 6d 64 61 74 29 0a 20 -vars itemdat).
0b20: 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 (for-each (lamb
0b30: 64 61 20 28 69 74 65 6d 29 0a 09 20 20 20 20 20 da (item)..
0b40: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 (debug:print 2
0b50: 22 73 65 74 65 6e 76 20 22 20 28 63 61 72 20 69 "setenv " (car i
0b60: 74 65 6d 29 20 22 20 22 20 28 63 61 64 72 20 69 tem) " " (cadr i
0b70: 74 65 6d 29 29 0a 09 20 20 20 20 20 20 28 73 65 tem)).. (se
0b80: 74 65 6e 76 20 28 63 61 72 20 69 74 65 6d 29 20 tenv (car item)
0b90: 28 63 61 64 72 20 69 74 65 6d 29 29 29 0a 09 20 (cadr item)))..
0ba0: 20 20 20 69 74 65 6d 64 61 74 29 29 0a 0a 28 64 itemdat))..(d
0bb0: 65 66 69 6e 65 20 28 72 75 6e 73 3a 63 61 6e 2d efine (runs:can-
0bc0: 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 20 64 run-more-tests d
0bd0: 62 20 74 65 73 74 2d 72 65 63 6f 72 64 29 0a 20 b test-record).
0be0: 20 28 6c 65 74 2a 20 28 28 74 63 6f 6e 66 69 67 (let* ((tconfig
0bf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0c00: 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 (tests:testqueu
0c10: 65 2d 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 e-get-testconfig
0c20: 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 test-record))..
0c30: 20 28 6a 6f 62 67 72 6f 75 70 20 20 20 20 20 20 (jobgroup
0c40: 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 66 69 (confi
0c50: 67 2d 6c 6f 6f 6b 75 70 20 74 63 6f 6e 66 69 67 g-lookup tconfig
0c60: 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 22 20 "requirements"
0c70: 22 6a 6f 62 67 72 6f 75 70 22 29 29 0a 09 20 28 "jobgroup")).. (
0c80: 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 20 20 20 20 num-running
0c90: 20 20 20 20 20 20 20 20 28 64 62 3a 67 65 74 2d (db:get-
0ca0: 63 6f 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e 6e count-tests-runn
0cb0: 69 6e 67 20 64 62 29 29 0a 09 20 28 6e 75 6d 2d ing db)).. (num-
0cc0: 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 running-in-jobgr
0cd0: 6f 75 70 20 28 64 62 3a 67 65 74 2d 63 6f 75 6e oup (db:get-coun
0ce0: 74 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 2d t-tests-running-
0cf0: 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 64 62 20 6a in-jobgroup db j
0d00: 6f 62 67 72 6f 75 70 29 29 0a 09 20 28 6d 61 78 obgroup)).. (max
0d10: 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 -concurrent-jobs
0d20: 20 20 20 20 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f (config-loo
0d30: 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 kup *configdat*
0d40: 22 73 65 74 75 70 22 20 20 20 20 20 22 6d 61 78 "setup" "max
0d50: 5f 63 6f 6e 63 75 72 72 65 6e 74 5f 6a 6f 62 73 _concurrent_jobs
0d60: 22 29 29 0a 09 20 28 6a 6f 62 2d 67 72 6f 75 70 ")).. (job-group
0d70: 2d 6c 69 6d 69 74 20 20 20 20 20 20 20 20 20 28 -limit (
0d80: 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 2a 63 config-lookup *c
0d90: 6f 6e 66 69 67 64 61 74 2a 20 22 6a 6f 62 67 72 onfigdat* "jobgr
0da0: 6f 75 70 73 22 20 6a 6f 62 67 72 6f 75 70 29 29 oups" jobgroup))
0db0: 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 ). (debug:pri
0dc0: 6e 74 20 32 20 22 6d 61 78 2d 63 6f 6e 63 75 72 nt 2 "max-concur
0dd0: 72 65 6e 74 2d 6a 6f 62 73 3a 20 22 20 6d 61 78 rent-jobs: " max
0de0: 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 -concurrent-jobs
0df0: 20 22 2c 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 3a ", num-running:
0e00: 20 22 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 29 0a " num-running).
0e10: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 (if (not (eq
0e20: 3f 20 30 20 2a 67 6c 6f 62 61 6c 65 78 69 74 73 ? 0 *globalexits
0e30: 74 61 74 75 73 2a 29 29 0a 09 23 66 0a 09 28 6c tatus*))..#f..(l
0e40: 65 74 20 28 28 63 61 6e 2d 6e 6f 74 2d 72 75 6e et ((can-not-run
0e50: 2d 6d 6f 72 65 20 28 63 6f 6e 64 0a 09 09 09 09 -more (cond.....
0e60: 20 3b 3b 20 69 66 20 6d 61 78 2d 63 6f 6e 63 75 ;; if max-concu
0e70: 72 72 65 6e 74 2d 6a 6f 62 73 20 69 73 20 73 65 rrent-jobs is se
0e80: 74 20 61 6e 64 20 74 68 65 20 6e 75 6d 62 65 72 t and the number
0e90: 20 72 75 6e 6e 69 6e 67 20 69 73 20 67 72 65 61 running is grea
0ea0: 74 65 72 20 0a 09 09 09 09 20 3b 3b 20 74 68 61 ter ..... ;; tha
0eb0: 6e 20 69 74 20 74 68 61 6e 20 63 61 6e 6e 6f 74 n it than cannot
0ec0: 20 72 75 6e 20 6d 6f 72 65 20 6a 6f 62 73 0a 09 run more jobs..
0ed0: 09 09 09 20 28 28 61 6e 64 20 6d 61 78 2d 63 6f ... ((and max-co
0ee0: 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 0a 09 09 ncurrent-jobs...
0ef0: 09 09 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 .. (string
0f00: 2d 3e 6e 75 6d 62 65 72 20 6d 61 78 2d 63 6f 6e ->number max-con
0f10: 63 75 72 72 65 6e 74 2d 6a 6f 62 73 29 0a 09 09 current-jobs)...
0f20: 09 09 20 20 20 20 20 20 20 28 3e 3d 20 6e 75 6d .. (>= num
0f30: 2d 72 75 6e 6e 69 6e 67 20 28 73 74 72 69 6e 67 -running (string
0f40: 2d 3e 6e 75 6d 62 65 72 20 6d 61 78 2d 63 6f 6e ->number max-con
0f50: 63 75 72 72 65 6e 74 2d 6a 6f 62 73 29 29 29 0a current-jobs))).
0f60: 09 09 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 .... (debug:pri
0f70: 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 4d nt 0 "WARNING: M
0f80: 61 78 20 72 75 6e 6e 69 6e 67 20 6a 6f 62 73 20 ax running jobs
0f90: 65 78 63 65 65 64 65 64 2c 20 63 75 72 72 65 6e exceeded, curren
0fa0: 74 20 6e 75 6d 62 65 72 20 72 75 6e 6e 69 6e 67 t number running
0fb0: 3a 20 22 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 : " num-running
0fc0: 0a 09 09 09 09 09 20 20 20 20 20 20 20 22 2c 20 ...... ",
0fd0: 6d 61 78 5f 63 6f 6e 63 75 72 72 65 6e 74 5f 6a max_concurrent_j
0fe0: 6f 62 73 3a 20 22 20 6d 61 78 2d 63 6f 6e 63 75 obs: " max-concu
0ff0: 72 72 65 6e 74 2d 6a 6f 62 73 29 0a 09 09 09 09 rrent-jobs).....
1000: 20 20 23 74 29 0a 09 09 09 09 20 3b 3b 20 69 66 #t)..... ;; if
1010: 20 6a 6f 62 2d 67 72 6f 75 70 2d 6c 69 6d 69 74 job-group-limit
1020: 20 69 73 20 73 65 74 20 61 6e 64 20 6e 75 6d 62 is set and numb
1030: 65 72 20 6f 66 20 6a 6f 62 73 20 69 6e 20 74 68 er of jobs in th
1040: 65 20 67 72 6f 75 70 20 69 73 20 67 72 65 61 74 e group is great
1050: 65 72 0a 09 09 09 09 20 3b 3b 20 74 68 61 6e 20 er..... ;; than
1060: 74 68 65 20 6c 69 6d 69 74 20 74 68 65 6e 20 63 the limit then c
1070: 61 6e 6e 6f 74 20 72 75 6e 20 6d 6f 72 65 20 6a annot run more j
1080: 6f 62 73 20 6f 66 20 74 68 69 73 20 6b 69 6e 64 obs of this kind
1090: 0a 09 09 09 09 20 28 28 61 6e 64 20 6a 6f 62 2d ..... ((and job-
10a0: 67 72 6f 75 70 2d 6c 69 6d 69 74 0a 09 09 09 09 group-limit.....
10b0: 20 20 20 20 20 20 20 28 3e 3d 20 6e 75 6d 2d 72 (>= num-r
10c0: 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f unning-in-jobgro
10d0: 75 70 20 6a 6f 62 2d 67 72 6f 75 70 2d 6c 69 6d up job-group-lim
10e0: 69 74 29 29 0a 09 09 09 09 20 20 28 64 65 62 75 it))..... (debu
10f0: 67 3a 70 72 69 6e 74 20 31 20 22 57 41 52 4e 49 g:print 1 "WARNI
1100: 4e 47 3a 20 6e 75 6d 62 65 72 20 6f 66 20 6a 6f NG: number of jo
1110: 62 73 20 22 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 bs " num-running
1120: 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 0a 09 09 -in-jobgroup ...
1130: 09 09 09 20 20 20 20 20 20 20 22 20 69 6e 20 22 ... " in "
1140: 20 6a 6f 62 67 72 6f 75 70 20 22 20 65 78 63 65 jobgroup " exce
1150: 65 64 65 64 2c 20 77 69 6c 6c 20 6e 6f 74 20 72 eded, will not r
1160: 75 6e 20 22 20 28 74 65 73 74 73 3a 74 65 73 74 un " (tests:test
1170: 71 75 65 75 65 2d 67 65 74 2d 74 65 73 74 6e 61 queue-get-testna
1180: 6d 65 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 me test-record))
1190: 0a 09 09 09 09 20 20 23 74 29 0a 09 09 09 09 20 ..... #t).....
11a0: 28 65 6c 73 65 20 23 66 29 29 29 29 0a 09 20 20 (else #f))))..
11b0: 28 6e 6f 74 20 63 61 6e 2d 6e 6f 74 2d 72 75 6e (not can-not-run
11c0: 2d 6d 6f 72 65 29 29 29 29 29 0a 0a 3b 3b 3d 3d -more)))))..;;==
11d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1200: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1210: 3d 3d 3d 3d 0a 3b 3b 20 4e 65 77 20 6d 65 74 68 ====.;; New meth
1220: 6f 64 6f 6c 6f 67 79 2e 20 54 68 65 73 65 20 72 odology. These r
1230: 6f 75 74 69 6e 65 73 20 77 69 6c 6c 20 72 65 70 outines will rep
1240: 6c 61 63 65 20 74 68 65 20 61 62 6f 76 65 20 69 lace the above i
1250: 6e 20 74 69 6d 65 2e 20 46 6f 72 0a 3b 3b 20 6e n time. For.;; n
1260: 6f 77 20 74 68 65 20 63 6f 64 65 20 69 73 20 64 ow the code is d
1270: 75 70 6c 69 63 61 74 65 64 2e 20 54 68 69 73 20 uplicated. This
1280: 73 74 75 66 66 20 69 73 20 69 6e 69 74 69 61 6c stuff is initial
1290: 6c 79 20 75 73 65 64 20 69 6e 20 74 68 65 20 6d ly used in the m
12a0: 6f 6e 69 74 6f 72 0a 3b 3b 20 62 61 73 65 64 20 onitor.;; based
12b0: 63 6f 64 65 2e 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d code..;;========
12c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
1300: 3b 3b 20 72 65 67 69 73 74 65 72 20 61 20 74 65 ;; register a te
1310: 73 74 20 72 75 6e 20 77 69 74 68 20 74 68 65 20 st run with the
1320: 64 62 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 db.(define (runs
1330: 3a 72 65 67 69 73 74 65 72 2d 72 75 6e 20 64 62 :register-run db
1340: 20 6b 65 79 73 20 6b 65 79 76 61 6c 6c 73 74 20 keys keyvallst
1350: 72 75 6e 6e 61 6d 65 20 73 74 61 74 65 20 73 74 runname state st
1360: 61 74 75 73 20 75 73 65 72 29 0a 20 20 28 64 65 atus user). (de
1370: 62 75 67 3a 70 72 69 6e 74 20 33 20 22 72 75 6e bug:print 3 "run
1380: 73 3a 72 65 67 69 73 74 65 72 2d 72 75 6e 2c 20 s:register-run,
1390: 6b 65 79 73 3a 20 22 20 6b 65 79 73 20 22 20 6b keys: " keys " k
13a0: 65 79 76 61 6c 6c 73 74 3a 20 22 20 6b 65 79 76 eyvallst: " keyv
13b0: 61 6c 6c 73 74 20 22 20 72 75 6e 6e 61 6d 65 3a allst " runname:
13c0: 20 22 20 72 75 6e 6e 61 6d 65 20 22 20 73 74 61 " runname " sta
13d0: 74 65 3a 20 22 20 73 74 61 74 65 20 22 20 73 74 te: " state " st
13e0: 61 74 75 73 3a 20 22 20 73 74 61 74 75 73 20 22 atus: " status "
13f0: 20 75 73 65 72 3a 20 22 20 75 73 65 72 29 0a 20 user: " user).
1400: 20 28 6c 65 74 2a 20 28 28 6b 65 79 73 74 72 20 (let* ((keystr
1410: 20 20 20 28 6b 65 79 73 2d 3e 6b 65 79 73 74 72 (keys->keystr
1420: 20 6b 65 79 73 29 29 0a 09 20 28 63 6f 6d 6d 61 keys)).. (comma
1430: 20 20 20 20 20 28 69 66 20 28 3e 20 28 6c 65 6e (if (> (len
1440: 67 74 68 20 6b 65 79 73 29 20 30 29 20 22 2c 22 gth keys) 0) ","
1450: 20 22 22 29 29 0a 09 20 28 61 6e 64 73 74 72 20 "")).. (andstr
1460: 20 20 20 28 69 66 20 28 3e 20 28 6c 65 6e 67 74 (if (> (lengt
1470: 68 20 6b 65 79 73 29 20 30 29 20 22 20 41 4e 44 h keys) 0) " AND
1480: 20 22 20 22 22 29 29 0a 09 20 28 76 61 6c 73 6c " "")).. (valsl
1490: 6f 74 73 20 20 28 6b 65 79 73 2d 3e 76 61 6c 73 ots (keys->vals
14a0: 6c 6f 74 73 20 6b 65 79 73 29 29 20 3b 3b 20 3f lots keys)) ;; ?
14b0: 2c 3f 2c 3f 20 2e 2e 2e 0a 09 20 28 6b 65 79 76 ,?,? ..... (keyv
14c0: 61 6c 73 20 20 20 28 6d 61 70 20 63 61 64 72 20 als (map cadr
14d0: 6b 65 79 76 61 6c 6c 73 74 29 29 0a 09 20 28 61 keyvallst)).. (a
14e0: 6c 6c 76 61 6c 73 20 20 20 28 61 70 70 65 6e 64 llvals (append
14f0: 20 28 6c 69 73 74 20 72 75 6e 6e 61 6d 65 20 73 (list runname s
1500: 74 61 74 65 20 73 74 61 74 75 73 20 75 73 65 72 tate status user
1510: 29 20 6b 65 79 76 61 6c 73 29 29 0a 09 20 28 71 ) keyvals)).. (q
1520: 72 79 76 61 6c 73 20 20 20 28 61 70 70 65 6e 64 ryvals (append
1530: 20 28 6c 69 73 74 20 72 75 6e 6e 61 6d 65 29 20 (list runname)
1540: 6b 65 79 76 61 6c 73 29 29 0a 09 20 28 6b 65 79 keyvals)).. (key
1550: 3d 3f 73 74 72 20 20 28 73 74 72 69 6e 67 2d 69 =?str (string-i
1560: 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 20 ntersperse (map
1570: 28 6c 61 6d 62 64 61 20 28 6b 29 28 63 6f 6e 63 (lambda (k)(conc
1580: 20 28 6b 65 79 3a 67 65 74 2d 66 69 65 6c 64 6e (key:get-fieldn
1590: 61 6d 65 20 6b 29 20 22 3d 3f 22 29 29 20 6b 65 ame k) "=?")) ke
15a0: 79 73 29 20 22 20 41 4e 44 20 22 29 29 29 0a 20 ys) " AND "))).
15b0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
15c0: 33 20 22 6b 65 79 73 3a 20 22 20 6b 65 79 73 20 3 "keys: " keys
15d0: 22 20 61 6c 6c 76 61 6c 73 3a 20 22 20 61 6c 6c " allvals: " all
15e0: 76 61 6c 73 20 22 20 6b 65 79 76 61 6c 73 3a 20 vals " keyvals:
15f0: 22 20 6b 65 79 76 61 6c 73 29 0a 20 20 20 20 28 " keyvals). (
1600: 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 4e debug:print 2 "N
1610: 4f 54 45 3a 20 75 73 69 6e 67 20 74 61 72 67 65 OTE: using targe
1620: 74 20 22 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 t " (string-inte
1630: 72 73 70 65 72 73 65 20 6b 65 79 76 61 6c 73 20 rsperse keyvals
1640: 22 2f 22 29 20 22 20 66 6f 72 20 74 68 69 73 20 "/") " for this
1650: 72 75 6e 22 29 0a 20 20 20 20 28 69 66 20 28 61 run"). (if (a
1660: 6e 64 20 72 75 6e 6e 61 6d 65 20 28 6e 75 6c 6c nd runname (null
1670: 3f 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 ? (filter (lambd
1680: 61 20 28 78 29 28 6e 6f 74 20 78 29 29 20 6b 65 a (x)(not x)) ke
1690: 79 76 61 6c 73 29 29 29 20 3b 3b 20 74 68 65 72 yvals))) ;; ther
16a0: 65 20 6d 75 73 74 20 62 65 20 61 20 62 65 74 74 e must be a bett
16b0: 65 72 20 77 61 79 20 74 6f 20 22 61 70 70 6c 79 er way to "apply
16c0: 20 61 6e 64 22 0a 09 28 6c 65 74 20 28 28 72 65 and"..(let ((re
16d0: 73 20 23 66 29 29 0a 09 20 20 28 61 70 70 6c 79 s #f)).. (apply
16e0: 20 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 sqlite3:execute
16f0: 20 64 62 20 28 63 6f 6e 63 20 22 49 4e 53 45 52 db (conc "INSER
1700: 54 20 4f 52 20 49 47 4e 4f 52 45 20 49 4e 54 4f T OR IGNORE INTO
1710: 20 72 75 6e 73 20 28 72 75 6e 6e 61 6d 65 2c 73 runs (runname,s
1720: 74 61 74 65 2c 73 74 61 74 75 73 2c 6f 77 6e 65 tate,status,owne
1730: 72 2c 65 76 65 6e 74 5f 74 69 6d 65 22 20 63 6f r,event_time" co
1740: 6d 6d 61 20 6b 65 79 73 74 72 20 22 29 20 56 41 mma keystr ") VA
1750: 4c 55 45 53 20 28 3f 2c 3f 2c 3f 2c 3f 2c 73 74 LUES (?,?,?,?,st
1760: 72 66 74 69 6d 65 28 27 25 73 27 2c 27 6e 6f 77 rftime('%s','now
1770: 27 29 22 20 63 6f 6d 6d 61 20 76 61 6c 73 6c 6f ')" comma valslo
1780: 74 73 20 22 29 3b 22 29 0a 09 09 20 61 6c 6c 76 ts ");")... allv
1790: 61 6c 73 29 0a 09 20 20 28 61 70 70 6c 79 20 73 als).. (apply s
17a0: 71 6c 69 74 65 33 3a 66 6f 72 2d 65 61 63 68 2d qlite3:for-each-
17b0: 72 6f 77 20 0a 09 20 20 20 28 6c 61 6d 62 64 61 row .. (lambda
17c0: 20 28 69 64 29 0a 09 20 20 20 20 20 28 73 65 74 (id).. (set
17d0: 21 20 72 65 73 20 69 64 29 29 0a 09 20 20 20 64 ! res id)).. d
17e0: 62 0a 09 20 20 20 28 6c 65 74 20 28 28 71 72 79 b.. (let ((qry
17f0: 20 28 63 6f 6e 63 20 22 53 45 4c 45 43 54 20 69 (conc "SELECT i
1800: 64 20 46 52 4f 4d 20 72 75 6e 73 20 57 48 45 52 d FROM runs WHER
1810: 45 20 28 72 75 6e 6e 61 6d 65 3d 3f 20 22 20 61 E (runname=? " a
1820: 6e 64 73 74 72 20 6b 65 79 3d 3f 73 74 72 20 22 ndstr key=?str "
1830: 29 3b 22 29 29 29 0a 09 20 20 20 20 20 3b 28 64 );"))).. ;(d
1840: 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 71 72 ebug:print 4 "qr
1850: 79 3a 20 22 20 71 72 79 29 20 0a 09 20 20 20 20 y: " qry) ..
1860: 20 71 72 79 29 0a 09 20 20 20 71 72 79 76 61 6c qry).. qryval
1870: 73 29 0a 09 20 20 28 73 71 6c 69 74 65 33 3a 65 s).. (sqlite3:e
1880: 78 65 63 75 74 65 20 64 62 20 22 55 50 44 41 54 xecute db "UPDAT
1890: 45 20 72 75 6e 73 20 53 45 54 20 73 74 61 74 65 E runs SET state
18a0: 3d 3f 2c 73 74 61 74 75 73 3d 3f 20 57 48 45 52 =?,status=? WHER
18b0: 45 20 69 64 3d 3f 3b 22 20 73 74 61 74 65 20 73 E id=?;" state s
18c0: 74 61 74 75 73 20 72 65 73 29 0a 09 20 20 72 65 tatus res).. re
18d0: 73 29 20 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 s) ..(begin.. (
18e0: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 debug:print 0 "E
18f0: 52 52 4f 52 3a 20 43 61 6c 6c 65 64 20 77 69 74 RROR: Called wit
1900: 68 6f 75 74 20 61 6c 6c 20 6e 65 63 65 73 73 61 hout all necessa
1910: 72 79 20 6b 65 79 73 22 29 0a 09 20 20 23 66 29 ry keys").. #f)
1920: 29 29 29 0a 0a 3b 3b 20 54 68 69 73 20 69 73 20 )))..;; This is
1930: 61 20 64 75 70 6c 69 63 61 74 65 20 6f 66 20 72 a duplicate of r
1940: 75 6e 2d 74 65 73 74 73 20 28 77 68 69 63 68 20 un-tests (which
1950: 68 61 73 20 62 65 65 6e 20 64 65 70 72 65 63 61 has been depreca
1960: 74 65 64 29 2e 20 55 73 65 20 74 68 69 73 20 6f ted). Use this o
1970: 6e 65 20 69 6e 73 74 65 61 64 20 6f 66 20 72 75 ne instead of ru
1980: 6e 20 74 65 73 74 73 2e 0a 3b 3b 20 6b 65 79 76 n tests..;; keyv
1990: 61 6c 73 0a 28 64 65 66 69 6e 65 20 28 72 75 6e als.(define (run
19a0: 73 3a 72 75 6e 2d 74 65 73 74 73 20 64 62 20 74 s:run-tests db t
19b0: 61 72 67 65 74 20 72 75 6e 6e 61 6d 65 20 74 65 arget runname te
19c0: 73 74 2d 70 61 74 74 73 20 75 73 65 72 20 66 6c st-patts user fl
19d0: 61 67 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 6b ags). (let* ((k
19e0: 65 79 73 20 20 20 20 20 20 20 20 28 72 64 62 3a eys (rdb:
19f0: 67 65 74 2d 6b 65 79 73 20 64 62 29 29 0a 09 20 get-keys db))..
1a00: 28 6b 65 79 76 61 6c 6c 73 74 20 20 20 28 6b 65 (keyvallst (ke
1a10: 79 73 3a 74 61 72 67 65 74 2d 3e 6b 65 79 76 61 ys:target->keyva
1a20: 6c 20 6b 65 79 73 20 74 61 72 67 65 74 29 29 0a l keys target)).
1a30: 09 20 28 72 75 6e 2d 69 64 20 20 20 20 20 20 28 . (run-id (
1a40: 72 75 6e 73 3a 72 65 67 69 73 74 65 72 2d 72 75 runs:register-ru
1a50: 6e 20 64 62 20 6b 65 79 73 20 6b 65 79 76 61 6c n db keys keyval
1a60: 6c 73 74 20 72 75 6e 6e 61 6d 65 20 22 6e 65 77 lst runname "new
1a70: 22 20 22 6e 2f 61 22 20 75 73 65 72 29 29 20 20 " "n/a" user))
1a80: 3b 3b 20 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 ;; test-name)))
1a90: 0a 09 20 28 64 65 66 65 72 72 65 64 20 20 20 20 .. (deferred
1aa0: 27 28 29 29 20 3b 3b 20 64 65 6c 61 79 20 72 75 '()) ;; delay ru
1ab0: 6e 6e 69 6e 67 20 74 68 65 73 65 20 73 69 6e 63 nning these sinc
1ac0: 65 20 74 68 65 79 20 68 61 76 65 20 61 20 77 61 e they have a wa
1ad0: 69 74 6f 6e 20 63 6c 61 75 73 65 0a 09 20 3b 3b iton clause.. ;;
1ae0: 20 6b 65 65 70 67 6f 69 6e 67 20 69 73 20 74 68 keepgoing is th
1af0: 65 20 64 65 66 61 63 74 6f 20 6d 6f 64 61 6c 69 e defacto modali
1b00: 74 79 20 6e 6f 77 2c 20 77 69 6c 6c 20 61 64 64 ty now, will add
1b10: 20 68 69 74 2d 6e 2d 72 75 6e 20 61 20 62 69 74 hit-n-run a bit
1b20: 20 6c 61 74 65 72 0a 09 20 3b 3b 20 28 6b 65 65 later.. ;; (kee
1b30: 70 67 6f 69 6e 67 20 20 20 28 68 61 73 68 2d 74 pgoing (hash-t
1b40: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
1b50: 20 66 6c 61 67 73 20 22 2d 6b 65 65 70 67 6f 69 flags "-keepgoi
1b60: 6e 67 22 20 23 66 29 29 0a 09 20 28 74 65 73 74 ng" #f)).. (test
1b70: 2d 6e 61 6d 65 73 20 20 27 28 29 29 0a 09 20 28 -names '()).. (
1b80: 72 75 6e 63 6f 6e 66 69 67 66 20 20 20 28 63 6f runconfigf (co
1b90: 6e 63 20 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f nc *toppath* "/
1ba0: 72 75 6e 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 69 runconfigs.confi
1bb0: 67 22 29 29 0a 09 20 28 72 65 71 75 69 72 65 64 g")).. (required
1bc0: 2d 74 65 73 74 73 20 27 28 29 29 0a 09 20 28 74 -tests '()).. (t
1bd0: 65 73 74 2d 72 65 63 6f 72 64 73 20 28 6d 61 6b est-records (mak
1be0: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 0a e-hash-table))).
1bf0: 0a 20 20 20 20 28 73 65 74 2d 6d 65 67 61 74 65 . (set-megate
1c00: 73 74 2d 65 6e 76 2d 76 61 72 73 20 64 62 20 72 st-env-vars db r
1c10: 75 6e 2d 69 64 29 20 3b 3b 20 74 68 65 73 65 20 un-id) ;; these
1c20: 6d 61 79 20 62 65 20 6e 65 65 64 65 64 20 62 79 may be needed by
1c30: 20 74 68 65 20 6c 61 75 6e 63 68 69 6e 67 20 70 the launching p
1c40: 72 6f 63 65 73 73 0a 0a 20 20 20 20 28 69 66 20 rocess.. (if
1c50: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 72 75 (file-exists? ru
1c60: 6e 63 6f 6e 66 69 67 66 29 0a 09 28 73 65 74 75 nconfigf)..(setu
1c70: 70 2d 65 6e 76 2d 64 65 66 61 75 6c 74 73 20 64 p-env-defaults d
1c80: 62 20 72 75 6e 63 6f 6e 66 69 67 66 20 72 75 6e b runconfigf run
1c90: 2d 69 64 20 2a 61 6c 72 65 61 64 79 2d 73 65 65 -id *already-see
1ca0: 6e 2d 72 75 6e 63 6f 6e 66 69 67 2d 69 6e 66 6f n-runconfig-info
1cb0: 2a 20 22 70 72 65 2d 6c 61 75 6e 63 68 2d 65 6e * "pre-launch-en
1cc0: 76 2d 76 61 72 73 22 29 0a 09 28 64 65 62 75 67 v-vars")..(debug
1cd0: 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e :print 0 "WARNIN
1ce0: 47 3a 20 59 6f 75 20 64 6f 20 6e 6f 74 20 68 61 G: You do not ha
1cf0: 76 65 20 61 20 72 75 6e 20 63 6f 6e 66 69 67 20 ve a run config
1d00: 66 69 6c 65 3a 20 22 20 72 75 6e 63 6f 6e 66 69 file: " runconfi
1d10: 67 66 29 29 0a 20 20 20 20 0a 20 20 20 20 3b 3b gf)). . ;;
1d20: 20 6c 6f 6f 6b 20 75 70 20 61 6c 6c 20 74 65 73 look up all tes
1d30: 74 73 20 6d 61 74 63 68 69 6e 67 20 74 68 65 20 ts matching the
1d40: 63 6f 6d 6d 61 20 73 65 70 61 72 61 74 65 64 20 comma separated
1d50: 6c 69 73 74 20 6f 66 20 67 6c 6f 62 73 20 69 6e list of globs in
1d60: 0a 20 20 20 20 3b 3b 20 74 65 73 74 2d 70 61 74 . ;; test-pat
1d70: 74 73 20 28 75 73 69 6e 67 20 25 20 61 73 20 77 ts (using % as w
1d80: 69 6c 64 63 61 72 64 29 0a 20 20 20 20 28 66 6f ildcard). (fo
1d90: 72 2d 65 61 63 68 20 0a 20 20 20 20 20 28 6c 61 r-each . (la
1da0: 6d 62 64 61 20 28 70 61 74 74 29 0a 20 20 20 20 mbda (patt).
1db0: 20 20 20 28 6c 65 74 20 28 28 74 65 73 74 73 20 (let ((tests
1dc0: 28 67 6c 6f 62 20 28 63 6f 6e 63 20 2a 74 6f 70 (glob (conc *top
1dd0: 70 61 74 68 2a 20 22 2f 74 65 73 74 73 2f 22 20 path* "/tests/"
1de0: 28 73 74 72 69 6e 67 2d 74 72 61 6e 73 6c 61 74 (string-translat
1df0: 65 20 70 61 74 74 20 22 25 22 20 22 2a 22 29 29 e patt "%" "*"))
1e00: 29 29 29 0a 09 20 28 73 65 74 21 20 74 65 73 74 ))).. (set! test
1e10: 73 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 s (filter (lambd
1e20: 61 20 28 74 65 73 74 29 28 66 69 6c 65 2d 65 78 a (test)(file-ex
1e30: 69 73 74 73 3f 20 28 63 6f 6e 63 20 74 65 73 74 ists? (conc test
1e40: 20 22 2f 74 65 73 74 63 6f 6e 66 69 67 22 29 29 "/testconfig"))
1e50: 29 20 74 65 73 74 73 29 29 0a 09 20 28 73 65 74 ) tests)).. (set
1e60: 21 20 74 65 73 74 2d 6e 61 6d 65 73 20 28 61 70 ! test-names (ap
1e70: 70 65 6e 64 20 74 65 73 74 2d 6e 61 6d 65 73 20 pend test-names
1e80: 0a 09 09 09 09 20 20 28 6d 61 70 20 28 6c 61 6d ..... (map (lam
1e90: 62 64 61 20 28 74 65 73 74 70 29 0a 09 09 09 09 bda (testp).....
1ea0: 09 20 28 6c 61 73 74 20 28 73 74 72 69 6e 67 2d . (last (string-
1eb0: 73 70 6c 69 74 20 74 65 73 74 70 20 22 2f 22 29 split testp "/")
1ec0: 29 29 0a 09 09 09 09 20 20 20 20 20 20 20 74 65 ))..... te
1ed0: 73 74 73 29 29 29 29 29 0a 20 20 20 20 20 28 69 sts))))). (i
1ee0: 66 20 74 65 73 74 2d 70 61 74 74 73 20 28 73 74 f test-patts (st
1ef0: 72 69 6e 67 2d 73 70 6c 69 74 20 74 65 73 74 2d ring-split test-
1f00: 70 61 74 74 73 20 22 2c 22 29 28 6c 69 73 74 20 patts ",")(list
1f10: 22 25 22 29 29 29 0a 0a 20 20 20 20 20 3b 3b 20 "%"))).. ;;
1f20: 6e 6f 77 20 72 65 6d 6f 76 65 20 64 75 70 6c 69 now remove dupli
1f30: 63 61 74 65 73 0a 20 20 20 20 28 73 65 74 21 20 cates. (set!
1f40: 74 65 73 74 2d 6e 61 6d 65 73 20 28 64 65 6c 65 test-names (dele
1f50: 74 65 2d 64 75 70 6c 69 63 61 74 65 73 20 74 65 te-duplicates te
1f60: 73 74 2d 6e 61 6d 65 73 29 29 0a 0a 20 20 20 20 st-names))..
1f70: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
1f80: 49 4e 46 4f 3a 20 74 65 73 74 20 6e 61 6d 65 73 INFO: test names
1f90: 20 22 20 74 65 73 74 2d 6e 61 6d 65 73 29 0a 0a " test-names)..
1fa0: 20 20 20 20 3b 3b 20 6f 6e 20 74 68 65 20 66 69 ;; on the fi
1fb0: 72 73 74 20 70 61 73 73 20 6f 72 20 63 61 6c 6c rst pass or call
1fc0: 20 74 6f 20 72 75 6e 2d 74 65 73 74 73 20 73 65 to run-tests se
1fd0: 74 20 46 41 49 4c 53 20 74 6f 20 4e 4f 54 5f 53 t FAILS to NOT_S
1fe0: 54 41 52 54 45 44 20 69 66 0a 20 20 20 20 3b 3b TARTED if. ;;
1ff0: 20 2d 6b 65 65 70 67 6f 69 6e 67 20 69 73 20 73 -keepgoing is s
2000: 70 65 63 69 66 69 65 64 0a 20 20 20 20 28 69 66 pecified. (if
2010: 20 28 65 71 3f 20 2a 70 61 73 73 6e 75 6d 2a 20 (eq? *passnum*
2020: 30 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 3b 3b 0)..(begin.. ;;
2030: 20 68 61 76 65 20 74 6f 20 64 65 6c 65 74 65 20 have to delete
2040: 74 65 73 74 20 72 65 63 6f 72 64 73 20 77 68 65 test records whe
2050: 72 65 20 4e 4f 54 5f 53 54 41 52 54 45 44 20 73 re NOT_STARTED s
2060: 69 6e 63 65 20 74 68 65 79 20 63 61 6e 20 63 61 ince they can ca
2070: 75 73 65 20 2d 6b 65 65 70 67 6f 69 6e 67 20 74 use -keepgoing t
2080: 6f 20 0a 09 20 20 3b 3b 20 67 65 74 20 73 74 75 o .. ;; get stu
2090: 63 6b 20 64 75 65 20 74 6f 20 62 65 63 6f 6d 69 ck due to becomi
20a0: 6e 67 20 69 6e 61 63 63 65 73 73 69 62 6c 65 20 ng inaccessible
20b0: 66 72 6f 6d 20 61 20 66 61 69 6c 65 64 20 74 65 from a failed te
20c0: 73 74 2e 20 49 2e 65 2e 20 69 66 20 74 65 73 74 st. I.e. if test
20d0: 20 42 20 64 65 70 65 6e 64 73 20 0a 09 20 20 3b B depends .. ;
20e0: 3b 20 6f 6e 20 74 65 73 74 20 41 20 62 75 74 20 ; on test A but
20f0: 74 65 73 74 20 42 20 72 65 61 63 68 65 64 20 74 test B reached t
2100: 68 65 20 70 6f 69 6e 74 20 6f 6e 20 62 65 69 6e he point on bein
2110: 67 20 72 65 67 69 73 74 65 72 65 64 20 61 73 20 g registered as
2120: 4e 4f 54 5f 53 54 41 52 54 45 44 20 61 6e 64 20 NOT_STARTED and
2130: 74 65 73 74 0a 09 20 20 3b 3b 20 41 20 66 61 69 test.. ;; A fai
2140: 6c 65 64 20 66 6f 72 20 73 6f 6d 65 20 72 65 61 led for some rea
2150: 73 6f 6e 20 74 68 65 6e 20 6f 6e 20 72 65 2d 72 son then on re-r
2160: 75 6e 20 75 73 69 6e 67 20 2d 6b 65 65 70 67 6f un using -keepgo
2170: 69 6e 67 20 74 68 65 20 72 75 6e 20 63 61 6e 20 ing the run can
2180: 6e 65 76 65 72 20 63 6f 6d 70 6c 65 74 65 2e 0a never complete..
2190: 09 20 20 28 64 62 3a 64 65 6c 65 74 65 2d 74 65 . (db:delete-te
21a0: 73 74 73 2d 69 6e 2d 73 74 61 74 65 20 64 62 20 sts-in-state db
21b0: 72 75 6e 2d 69 64 20 22 4e 4f 54 5f 53 54 41 52 run-id "NOT_STAR
21c0: 54 45 44 22 29 0a 09 20 20 28 72 64 62 3a 73 65 TED").. (rdb:se
21d0: 74 2d 74 65 73 74 73 2d 73 74 61 74 65 2d 73 74 t-tests-state-st
21e0: 61 74 75 73 20 64 62 20 72 75 6e 2d 69 64 20 74 atus db run-id t
21f0: 65 73 74 2d 6e 61 6d 65 73 20 23 66 20 22 46 41 est-names #f "FA
2200: 49 4c 22 20 22 4e 4f 54 5f 53 54 41 52 54 45 44 IL" "NOT_STARTED
2210: 22 20 22 46 41 49 4c 22 29 29 29 0a 0a 20 20 20 " "FAIL")))..
2220: 20 3b 3b 20 66 72 6f 6d 20 68 65 72 65 20 6f 6e ;; from here on
2230: 20 6f 75 74 20 74 68 65 20 64 62 20 77 69 6c 6c out the db will
2240: 20 62 65 20 6f 70 65 6e 65 64 20 61 6e 64 20 63 be opened and c
2250: 6c 6f 73 65 64 20 6f 6e 20 65 76 65 72 79 20 63 losed on every c
2260: 61 6c 6c 20 72 75 6e 73 3a 72 75 6e 2d 74 65 73 all runs:run-tes
2270: 74 73 2d 71 75 65 75 65 0a 20 20 20 20 28 73 71 ts-queue. (sq
2280: 6c 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 lite3:finalize!
2290: 64 62 29 20 0a 20 20 20 20 3b 3b 20 6e 6f 77 20 db) . ;; now
22a0: 61 64 64 20 6e 6f 6e 2d 64 69 72 65 63 74 6c 79 add non-directly
22b0: 20 72 65 66 65 72 65 6e 63 65 64 20 64 65 70 65 referenced depe
22c0: 6e 64 65 6e 63 69 65 73 20 28 69 2e 65 2e 20 77 ndencies (i.e. w
22d0: 61 69 74 6f 6e 29 0a 20 20 20 20 28 69 66 20 28 aiton). (if (
22e0: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 65 73 74 2d not (null? test-
22f0: 6e 61 6d 65 73 29 29 0a 09 28 6c 65 74 20 6c 6f names))..(let lo
2300: 6f 70 20 28 28 68 65 64 20 28 63 61 72 20 74 65 op ((hed (car te
2310: 73 74 2d 6e 61 6d 65 73 29 29 0a 09 09 20 20 20 st-names))...
2320: 28 74 61 6c 20 28 63 64 72 20 74 65 73 74 2d 6e (tal (cdr test-n
2330: 61 6d 65 73 29 29 29 20 20 20 20 20 20 20 20 20 ames)))
2340: 3b 3b 20 27 72 65 74 75 72 6e 2d 70 72 6f 63 73 ;; 'return-procs
2350: 20 74 65 6c 6c 73 20 74 68 65 20 63 6f 6e 66 69 tells the confi
2360: 67 20 72 65 61 64 65 72 20 74 6f 20 70 72 65 70 g reader to prep
2370: 20 72 75 6e 6e 69 6e 67 20 73 79 73 74 65 6d 20 running system
2380: 62 75 74 20 72 65 74 75 72 6e 20 61 20 70 72 6f but return a pro
2390: 63 0a 09 20 20 28 6c 65 74 2a 20 28 28 63 6f 6e c.. (let* ((con
23a0: 66 69 67 20 20 28 74 65 73 74 73 3a 67 65 74 2d fig (tests:get-
23b0: 74 65 73 74 63 6f 6e 66 69 67 20 68 65 64 20 27 testconfig hed '
23c0: 72 65 74 75 72 6e 2d 70 72 6f 63 73 29 29 0a 09 return-procs))..
23d0: 09 20 28 77 61 69 74 6f 6e 73 20 28 69 66 20 63 . (waitons (if c
23e0: 6f 6e 66 69 67 20 28 73 74 72 69 6e 67 2d 73 70 onfig (string-sp
23f0: 6c 69 74 20 28 6c 65 74 20 28 28 77 20 28 63 6f lit (let ((w (co
2400: 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 63 6f 6e 66 nfig-lookup conf
2410: 69 67 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 ig "requirements
2420: 22 20 22 77 61 69 74 6f 6e 22 29 29 29 0a 09 09 " "waiton")))...
2430: 09 09 09 09 20 20 20 20 20 28 69 66 20 77 20 77 .... (if w w
2440: 20 22 22 29 29 29 0a 09 09 09 20 20 20 20 20 20 "")))....
2450: 28 62 65 67 69 6e 0a 09 09 09 09 28 64 65 62 75 (begin.....(debu
2460: 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 g:print 0 "ERROR
2470: 3a 20 6e 6f 6e 2d 65 78 69 73 74 65 6e 74 20 72 : non-existent r
2480: 65 71 75 69 72 65 64 20 74 65 73 74 20 5c 22 22 equired test \""
2490: 20 68 65 64 20 22 5c 22 22 29 0a 20 20 20 20 20 hed "\"").
24a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
24b0: 20 20 20 20 20 20 20 20 20 20 20 28 73 71 6c 69 (sqli
24c0: 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 64 62 te3:finalize! db
24d0: 29 0a 09 09 09 09 28 65 78 69 74 20 31 29 29 29 ).....(exit 1)))
24e0: 29 29 0a 09 20 20 20 20 3b 3b 20 63 68 65 63 6b )).. ;; check
24f0: 20 66 6f 72 20 68 65 64 20 69 6e 20 77 61 69 74 for hed in wait
2500: 6f 6e 73 20 3d 3e 20 74 68 69 73 20 77 6f 75 6c ons => this woul
2510: 64 20 62 65 20 63 69 72 63 75 6c 61 72 2c 20 72 d be circular, r
2520: 65 6d 6f 76 65 20 69 74 20 61 6e 64 20 69 73 73 emove it and iss
2530: 75 65 20 61 6e 0a 09 20 20 20 20 3b 3b 20 65 72 ue an.. ;; er
2540: 72 6f 72 0a 09 20 20 20 20 28 69 66 20 28 6d 65 ror.. (if (me
2550: 6d 62 65 72 20 68 65 64 20 77 61 69 74 6f 6e 73 mber hed waitons
2560: 29 0a 09 09 28 62 65 67 69 6e 0a 09 09 20 20 28 )...(begin... (
2570: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 debug:print 0 "E
2580: 52 52 4f 52 3a 20 74 65 73 74 20 22 20 68 65 64 RROR: test " hed
2590: 20 22 20 68 61 73 20 6c 69 73 74 65 64 20 69 74 " has listed it
25a0: 73 65 6c 66 20 61 73 20 61 20 77 61 69 74 6f 6e self as a waiton
25b0: 2c 20 70 6c 65 61 73 65 20 63 6f 72 72 65 63 74 , please correct
25c0: 20 74 68 69 73 21 22 29 0a 09 09 20 20 28 73 65 this!")... (se
25d0: 74 21 20 77 61 69 74 6f 6e 73 20 28 66 69 6c 74 t! waitons (filt
25e0: 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 28 6e er (lambda (x)(n
25f0: 6f 74 20 28 65 71 75 61 6c 3f 20 78 20 68 65 64 ot (equal? x hed
2600: 29 29 29 20 77 61 69 74 6f 6e 73 29 29 29 29 0a ))) waitons)))).
2610: 09 20 20 20 20 0a 09 20 20 20 20 3b 3b 20 28 69 . .. ;; (i
2620: 74 65 6d 73 20 20 20 28 69 74 65 6d 73 3a 67 65 tems (items:ge
2630: 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e t-items-from-con
2640: 66 69 67 20 63 6f 6e 66 69 67 29 29 29 0a 09 20 fig config)))..
2650: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 68 61 73 (if (not (has
2660: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
2670: 75 6c 74 20 74 65 73 74 2d 72 65 63 6f 72 64 73 ult test-records
2680: 20 68 65 64 20 23 66 29 29 0a 09 09 28 68 61 73 hed #f))...(has
2690: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 65 73 h-table-set! tes
26a0: 74 2d 72 65 63 6f 72 64 73 0a 09 09 09 09 20 68 t-records..... h
26b0: 65 64 20 28 76 65 63 74 6f 72 20 68 65 64 20 20 ed (vector hed
26c0: 20 20 20 3b 3b 20 30 0a 09 09 09 09 09 20 20 20 ;; 0......
26d0: 20 20 63 6f 6e 66 69 67 20 20 3b 3b 20 31 0a 09 config ;; 1..
26e0: 09 09 09 09 20 20 20 20 20 77 61 69 74 6f 6e 73 .... waitons
26f0: 20 3b 3b 20 32 0a 09 09 09 09 09 20 20 20 20 20 ;; 2......
2700: 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 63 (config-lookup c
2710: 6f 6e 66 69 67 20 22 72 65 71 75 69 72 65 6d 65 onfig "requireme
2720: 6e 74 73 22 20 22 70 72 69 6f 72 69 74 79 22 29 nts" "priority")
2730: 20 20 20 20 20 3b 3b 20 70 72 69 6f 72 69 74 79 ;; priority
2740: 20 33 0a 09 09 09 09 09 20 20 20 20 20 28 6c 65 3...... (le
2750: 74 20 28 28 69 74 65 6d 73 20 20 20 20 20 20 28 t ((items (
2760: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
2770: 65 66 61 75 6c 74 20 63 6f 6e 66 69 67 20 22 69 efault config "i
2780: 74 65 6d 73 22 20 23 66 29 29 20 3b 3b 20 69 74 tems" #f)) ;; it
2790: 65 6d 73 20 34 0a 09 09 09 09 09 09 20 20 20 28 ems 4....... (
27a0: 69 74 65 6d 73 74 61 62 6c 65 20 28 68 61 73 68 itemstable (hash
27b0: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
27c0: 6c 74 20 63 6f 6e 66 69 67 20 22 69 74 65 6d 73 lt config "items
27d0: 74 61 62 6c 65 22 20 23 66 29 29 29 20 0a 09 09 table" #f))) ...
27e0: 09 09 09 20 20 20 20 20 20 20 3b 3b 20 69 66 20 ... ;; if
27f0: 65 69 74 68 65 72 20 69 74 65 6d 73 20 6f 72 20 either items or
2800: 69 74 65 6d 73 20 74 61 62 6c 65 20 69 73 20 61 items table is a
2810: 20 70 72 6f 63 20 72 65 74 75 72 6e 20 69 74 20 proc return it
2820: 73 6f 20 74 65 73 74 20 72 75 6e 6e 69 6e 67 0a so test running.
2830: 09 09 09 09 09 20 20 20 20 20 20 20 3b 3b 20 70 ..... ;; p
2840: 72 6f 63 65 73 73 20 63 61 6e 20 6b 6e 6f 77 20 rocess can know
2850: 74 6f 20 63 61 6c 6c 20 69 74 65 6d 73 3a 67 65 to call items:ge
2860: 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e t-items-from-con
2870: 66 69 67 0a 09 09 09 09 09 20 20 20 20 20 20 20 fig......
2880: 3b 3b 20 69 66 20 65 69 74 68 65 72 20 69 73 20 ;; if either is
2890: 61 20 6c 69 73 74 20 61 6e 64 20 6e 6f 6e 65 20 a list and none
28a0: 69 73 20 61 20 70 72 6f 63 20 67 6f 20 61 68 65 is a proc go ahe
28b0: 61 64 20 61 6e 64 20 63 61 6c 6c 20 67 65 74 2d ad and call get-
28c0: 69 74 65 6d 73 0a 09 09 09 09 09 20 20 20 20 20 items......
28d0: 20 20 3b 3b 20 6f 74 68 65 72 77 69 73 65 20 72 ;; otherwise r
28e0: 65 74 75 72 6e 20 23 66 20 2d 20 74 68 69 73 20 eturn #f - this
28f0: 69 73 20 6e 6f 74 20 61 6e 20 69 74 65 72 61 74 is not an iterat
2900: 65 64 20 74 65 73 74 0a 09 09 09 09 09 20 20 20 ed test......
2910: 20 20 20 20 28 63 6f 6e 64 0a 09 09 09 09 09 09 (cond.......
2920: 28 28 70 72 6f 63 65 64 75 72 65 3f 20 69 74 65 ((procedure? ite
2930: 6d 73 29 20 20 20 20 20 20 0a 09 09 09 09 09 09 ms) .......
2940: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 (debug:print 4
2950: 22 49 4e 46 4f 3a 20 69 74 65 6d 73 20 69 73 20 "INFO: items is
2960: 61 20 70 72 6f 63 65 64 75 72 65 2c 20 77 69 6c a procedure, wil
2970: 6c 20 63 61 6c 63 20 6c 61 74 65 72 22 29 0a 09 l calc later")..
2980: 09 09 09 09 09 20 69 74 65 6d 73 29 20 20 20 20 ..... items)
2990: 20 20 20 20 20 20 20 20 3b 3b 20 63 61 6c 63 20 ;; calc
29a0: 6c 61 74 65 72 0a 09 09 09 09 09 09 28 28 70 72 later.......((pr
29b0: 6f 63 65 64 75 72 65 3f 20 69 74 65 6d 73 74 61 ocedure? itemsta
29c0: 62 6c 65 29 0a 09 09 09 09 09 09 20 28 64 65 62 ble)....... (deb
29d0: 75 67 3a 70 72 69 6e 74 20 34 20 22 49 4e 46 4f ug:print 4 "INFO
29e0: 3a 20 69 74 65 6d 73 74 61 62 6c 65 20 69 73 20 : itemstable is
29f0: 61 20 70 72 6f 63 65 64 75 72 65 2c 20 77 69 6c a procedure, wil
2a00: 6c 20 63 61 6c 63 20 6c 61 74 65 72 22 29 0a 09 l calc later")..
2a10: 09 09 09 09 09 20 69 74 65 6d 73 74 61 62 6c 65 ..... itemstable
2a20: 29 20 20 20 20 20 20 20 3b 3b 20 63 61 6c 63 20 ) ;; calc
2a30: 6c 61 74 65 72 0a 09 09 09 09 09 09 28 28 66 69 later.......((fi
2a40: 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 lter (lambda (x)
2a50: 0a 09 09 09 09 09 09 09 20 20 20 28 6c 65 74 20 ........ (let
2a60: 28 28 76 61 6c 20 28 63 61 72 20 78 29 29 29 0a ((val (car x))).
2a70: 09 09 09 09 09 09 09 20 20 20 20 20 28 69 66 20 ....... (if
2a80: 28 70 72 6f 63 65 64 75 72 65 3f 20 76 61 6c 29 (procedure? val)
2a90: 20 76 61 6c 20 23 66 29 29 29 0a 09 09 09 09 09 val #f)))......
2aa0: 09 09 20 28 61 70 70 65 6e 64 20 28 69 66 20 28 .. (append (if (
2ab0: 6c 69 73 74 3f 20 69 74 65 6d 73 29 20 69 74 65 list? items) ite
2ac0: 6d 73 20 27 28 29 29 0a 09 09 09 09 09 09 09 09 ms '()).........
2ad0: 20 28 69 66 20 28 6c 69 73 74 3f 20 69 74 65 6d (if (list? item
2ae0: 73 74 61 62 6c 65 29 20 69 74 65 6d 73 74 61 62 stable) itemstab
2af0: 6c 65 20 27 28 29 29 29 29 0a 09 09 09 09 09 09 le '()))).......
2b00: 20 27 68 61 76 65 2d 70 72 6f 63 65 64 75 72 65 'have-procedure
2b10: 29 0a 09 09 09 09 09 09 28 28 6f 72 20 28 6c 69 ).......((or (li
2b20: 73 74 3f 20 69 74 65 6d 73 29 28 6c 69 73 74 3f st? items)(list?
2b30: 20 69 74 65 6d 73 74 61 62 6c 65 29 29 20 3b 3b itemstable)) ;;
2b40: 20 63 61 6c 63 20 6e 6f 77 0a 09 09 09 09 09 09 calc now.......
2b50: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 (debug:print 4
2b60: 22 49 4e 46 4f 3a 20 69 74 65 6d 73 20 61 6e 64 "INFO: items and
2b70: 20 69 74 65 6d 73 74 61 62 6c 65 20 61 72 65 20 itemstable are
2b80: 6c 69 73 74 73 2c 20 63 61 6c 63 20 6e 6f 77 5c lists, calc now\
2b90: 6e 22 0a 09 09 09 09 09 09 09 20 20 20 20 20 20 n"........
2ba0: 22 20 20 20 20 69 74 65 6d 73 3a 20 22 20 69 74 " items: " it
2bb0: 65 6d 73 20 22 20 69 74 65 6d 73 74 61 62 6c 65 ems " itemstable
2bc0: 3a 20 22 20 69 74 65 6d 73 74 61 62 6c 65 29 0a : " itemstable).
2bd0: 09 09 09 09 09 09 20 28 69 74 65 6d 73 3a 67 65 ...... (items:ge
2be0: 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e t-items-from-con
2bf0: 66 69 67 20 63 6f 6e 66 69 67 29 29 0a 09 09 09 fig config))....
2c00: 09 09 09 28 65 6c 73 65 20 23 66 29 29 29 20 20 ...(else #f)))
2c10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2c20: 20 20 20 20 20 20 20 20 20 3b 3b 20 6e 6f 74 20 ;; not
2c30: 69 74 65 72 61 74 65 64 0a 09 09 09 09 09 20 20 iterated......
2c40: 20 20 20 23 66 20 20 20 20 20 20 3b 3b 20 69 74 #f ;; it
2c50: 65 6d 73 64 61 74 20 35 0a 09 09 09 09 09 20 20 emsdat 5......
2c60: 20 20 20 23 66 20 20 20 20 20 20 3b 3b 20 73 70 #f ;; sp
2c70: 61 72 65 20 2d 20 75 73 65 64 20 66 6f 72 20 69 are - used for i
2c80: 74 65 6d 2d 70 61 74 68 0a 09 09 09 09 09 20 20 tem-path......
2c90: 20 20 20 29 29 29 0a 09 20 20 20 20 28 66 6f 72 ))).. (for
2ca0: 2d 65 61 63 68 20 0a 09 20 20 20 20 20 28 6c 61 -each .. (la
2cb0: 6d 62 64 61 20 28 77 61 69 74 6f 6e 29 0a 09 20 mbda (waiton)..
2cc0: 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 77 (if (and w
2cd0: 61 69 74 6f 6e 20 28 6e 6f 74 20 28 6d 65 6d 62 aiton (not (memb
2ce0: 65 72 20 77 61 69 74 6f 6e 20 74 65 73 74 2d 6e er waiton test-n
2cf0: 61 6d 65 73 29 29 29 0a 09 09 20 20 20 28 62 65 ames)))... (be
2d00: 67 69 6e 0a 09 09 20 20 20 20 20 28 73 65 74 21 gin... (set!
2d10: 20 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 20 required-tests
2d20: 28 63 6f 6e 73 20 77 61 69 74 6f 6e 20 72 65 71 (cons waiton req
2d30: 75 69 72 65 64 2d 74 65 73 74 73 29 29 0a 09 09 uired-tests))...
2d40: 20 20 20 20 20 28 73 65 74 21 20 74 65 73 74 2d (set! test-
2d50: 6e 61 6d 65 73 20 28 63 6f 6e 73 20 77 61 69 74 names (cons wait
2d60: 6f 6e 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 29 on test-names)))
2d70: 29 29 20 3b 3b 20 77 61 73 20 61 6e 20 61 70 70 )) ;; was an app
2d80: 65 6e 64 2c 20 6e 6f 77 20 61 20 63 6f 6e 73 0a end, now a cons.
2d90: 09 20 20 20 20 20 77 61 69 74 6f 6e 73 29 0a 09 . waitons)..
2da0: 20 20 20 20 28 6c 65 74 20 28 28 72 65 6d 74 65 (let ((remte
2db0: 73 74 73 20 28 64 65 6c 65 74 65 2d 64 75 70 6c sts (delete-dupl
2dc0: 69 63 61 74 65 73 20 28 61 70 70 65 6e 64 20 77 icates (append w
2dd0: 61 69 74 6f 6e 73 20 74 61 6c 29 29 29 29 0a 09 aitons tal))))..
2de0: 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 (if (not (
2df0: 6e 75 6c 6c 3f 20 72 65 6d 74 65 73 74 73 29 29 null? remtests))
2e00: 0a 09 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 ... (loop (car
2e10: 72 65 6d 74 65 73 74 73 29 28 63 64 72 20 72 65 remtests)(cdr re
2e20: 6d 74 65 73 74 73 29 29 29 29 29 29 29 0a 0a 20 mtests)))))))..
2e30: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c (if (not (nul
2e40: 6c 3f 20 72 65 71 75 69 72 65 64 2d 74 65 73 74 l? required-test
2e50: 73 29 29 0a 09 28 64 65 62 75 67 3a 70 72 69 6e s))..(debug:prin
2e60: 74 20 31 20 22 49 4e 46 4f 3a 20 41 64 64 69 6e t 1 "INFO: Addin
2e70: 67 20 22 20 72 65 71 75 69 72 65 64 2d 74 65 73 g " required-tes
2e80: 74 73 20 22 20 74 6f 20 74 68 65 20 72 75 6e 20 ts " to the run
2e90: 71 75 65 75 65 22 29 29 0a 20 20 20 20 3b 3b 20 queue")). ;;
2ea0: 4e 4f 54 45 3a 20 74 68 65 73 65 20 61 72 65 20 NOTE: these are
2eb0: 61 6c 6c 20 70 61 72 65 6e 74 20 74 65 73 74 73 all parent tests
2ec0: 2c 20 69 74 65 6d 73 20 61 72 65 20 6e 6f 74 20 , items are not
2ed0: 65 78 70 61 6e 64 65 64 20 79 65 74 2e 0a 20 20 expanded yet..
2ee0: 20 20 28 72 75 6e 73 3a 72 75 6e 2d 74 65 73 74 (runs:run-test
2ef0: 73 2d 71 75 65 75 65 20 72 75 6e 2d 69 64 20 72 s-queue run-id r
2f00: 75 6e 6e 61 6d 65 20 74 65 73 74 2d 72 65 63 6f unname test-reco
2f10: 72 64 73 20 6b 65 79 76 61 6c 6c 73 74 20 66 6c rds keyvallst fl
2f20: 61 67 73 29 0a 20 20 20 20 28 64 65 62 75 67 3a ags). (debug:
2f30: 70 72 69 6e 74 20 34 20 22 49 4e 46 4f 3a 20 41 print 4 "INFO: A
2f40: 6c 6c 20 64 6f 6e 65 20 62 79 20 68 65 72 65 22 ll done by here"
2f50: 29 29 29 0a 0a 3b 3b 20 74 65 73 74 2d 72 65 63 )))..;; test-rec
2f60: 6f 72 64 73 20 69 73 20 61 20 68 61 73 68 20 74 ords is a hash t
2f70: 61 62 6c 65 20 74 65 73 74 6e 61 6d 65 3a 69 74 able testname:it
2f80: 65 6d 5f 70 61 74 68 20 3d 3e 20 76 65 63 74 6f em_path => vecto
2f90: 72 20 3c 20 74 65 73 74 6e 61 6d 65 20 74 65 73 r < testname tes
2fa0: 74 63 6f 6e 66 69 67 20 77 61 69 74 6f 6e 73 20 tconfig waitons
2fb0: 70 72 69 6f 72 69 74 79 20 69 74 65 6d 73 2d 69 priority items-i
2fc0: 6e 66 6f 20 2e 2e 2e 20 3e 0a 28 64 65 66 69 6e nfo ... >.(defin
2fd0: 65 20 28 72 75 6e 73 3a 72 75 6e 2d 74 65 73 74 e (runs:run-test
2fe0: 73 2d 71 75 65 75 65 20 72 75 6e 2d 69 64 20 72 s-queue run-id r
2ff0: 75 6e 6e 61 6d 65 20 74 65 73 74 2d 72 65 63 6f unname test-reco
3000: 72 64 73 20 6b 65 79 76 61 6c 6c 73 74 20 66 6c rds keyvallst fl
3010: 61 67 73 29 0a 20 20 20 20 3b 3b 20 41 74 20 74 ags). ;; At t
3020: 68 69 73 20 70 6f 69 6e 74 20 74 68 65 20 6c 69 his point the li
3030: 73 74 20 6f 66 20 70 61 72 65 6e 74 20 74 65 73 st of parent tes
3040: 74 73 20 69 73 20 65 78 70 61 6e 64 65 64 20 0a ts is expanded .
3050: 20 20 20 20 3b 3b 20 4e 42 2f 2f 20 53 68 6f 75 ;; NB// Shou
3060: 6c 64 20 65 78 70 61 6e 64 20 69 74 65 6d 73 20 ld expand items
3070: 68 65 72 65 20 61 6e 64 20 74 68 65 6e 20 69 6e here and then in
3080: 73 65 72 74 20 69 6e 74 6f 20 74 68 65 20 72 75 sert into the ru
3090: 6e 20 71 75 65 75 65 2e 0a 20 20 28 64 65 62 75 n queue.. (debu
30a0: 67 3a 70 72 69 6e 74 20 35 20 22 74 65 73 74 2d g:print 5 "test-
30b0: 72 65 63 6f 72 64 73 3a 20 22 20 74 65 73 74 2d records: " test-
30c0: 72 65 63 6f 72 64 73 20 22 2c 20 6b 65 79 76 61 records ", keyva
30d0: 6c 6c 73 74 3a 20 22 20 6b 65 79 76 61 6c 6c 73 llst: " keyvalls
30e0: 74 20 22 20 66 6c 61 67 73 3a 20 22 20 28 68 61 t " flags: " (ha
30f0: 73 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 20 sh-table->alist
3100: 66 6c 61 67 73 29 29 0a 20 20 28 6c 65 74 20 28 flags)). (let (
3110: 28 73 6f 72 74 65 64 2d 74 65 73 74 2d 6e 61 6d (sorted-test-nam
3120: 65 73 20 28 74 65 73 74 73 3a 73 6f 72 74 2d 62 es (tests:sort-b
3130: 79 2d 70 72 69 6f 72 69 74 79 2d 61 6e 64 2d 77 y-priority-and-w
3140: 61 69 74 6f 6e 20 74 65 73 74 2d 72 65 63 6f 72 aiton test-recor
3150: 64 73 29 29 0a 09 28 69 74 65 6d 2d 70 61 74 74 ds))..(item-patt
3160: 73 20 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 s (hash-t
3170: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
3180: 20 66 6c 61 67 73 20 22 2d 69 74 65 6d 70 61 74 flags "-itempat
3190: 74 22 20 23 66 29 29 29 0a 20 20 20 20 28 69 66 t" #f))). (if
31a0: 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 73 6f 72 (not (null? sor
31b0: 74 65 64 2d 74 65 73 74 2d 6e 61 6d 65 73 29 29 ted-test-names))
31c0: 0a 09 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 ..(let loop ((he
31d0: 64 20 20 20 20 20 20 20 20 20 28 63 61 72 20 73 d (car s
31e0: 6f 72 74 65 64 2d 74 65 73 74 2d 6e 61 6d 65 73 orted-test-names
31f0: 29 29 0a 09 09 20 20 20 28 74 61 6c 20 20 20 20 ))... (tal
3200: 20 20 20 20 20 28 63 64 72 20 73 6f 72 74 65 64 (cdr sorted
3210: 2d 74 65 73 74 2d 6e 61 6d 65 73 29 29 29 0a 09 -test-names)))..
3220: 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
3230: 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 *global-delta*)
3240: 20 3b 3b 20 67 69 76 65 20 6f 74 68 65 72 20 61 ;; give other a
3250: 70 70 6c 69 63 61 74 69 6f 6e 73 20 73 6f 6d 65 pplications some
3260: 20 74 69 6d 65 20 77 69 74 68 20 74 68 65 20 64 time with the d
3270: 62 0a 09 20 20 28 6c 65 74 2a 20 28 28 74 65 73 b.. (let* ((tes
3280: 74 2d 72 65 63 6f 72 64 20 28 68 61 73 68 2d 74 t-record (hash-t
3290: 61 62 6c 65 2d 72 65 66 20 74 65 73 74 2d 72 65 able-ref test-re
32a0: 63 6f 72 64 73 20 68 65 64 29 29 0a 09 09 20 28 cords hed))... (
32b0: 74 63 6f 6e 66 69 67 20 20 20 20 20 28 74 65 73 tconfig (tes
32c0: 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 ts:testqueue-get
32d0: 2d 74 65 73 74 63 6f 6e 66 69 67 20 74 65 73 74 -testconfig test
32e0: 2d 72 65 63 6f 72 64 29 29 0a 09 09 20 28 74 65 -record))... (te
32f0: 73 74 6d 6f 64 65 20 20 20 20 28 6c 65 74 20 28 stmode (let (
3300: 28 6d 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 (m (config-looku
3310: 70 20 74 63 6f 6e 66 69 67 20 22 72 65 71 75 69 p tconfig "requi
3320: 72 65 6d 65 6e 74 73 22 20 22 6d 6f 64 65 22 29 rements" "mode")
3330: 29 29 0a 09 09 09 09 28 69 66 20 6d 20 28 73 74 )).....(if m (st
3340: 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 6d 29 20 ring->symbol m)
3350: 27 6e 6f 72 6d 61 6c 29 29 29 0a 09 09 20 28 77 'normal)))... (w
3360: 61 69 74 6f 6e 73 20 20 20 20 20 28 74 65 73 74 aitons (test
3370: 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d s:testqueue-get-
3380: 77 61 69 74 6f 6e 73 20 20 20 20 74 65 73 74 2d waitons test-
3390: 72 65 63 6f 72 64 29 29 0a 09 09 20 28 70 72 69 record))... (pri
33a0: 6f 72 69 74 79 20 20 20 20 28 74 65 73 74 73 3a ority (tests:
33b0: 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 70 72 testqueue-get-pr
33c0: 69 6f 72 69 74 79 20 20 20 74 65 73 74 2d 72 65 iority test-re
33d0: 63 6f 72 64 29 29 0a 09 09 20 28 69 74 65 6d 64 cord))... (itemd
33e0: 61 74 20 20 20 20 20 28 74 65 73 74 73 3a 74 65 at (tests:te
33f0: 73 74 71 75 65 75 65 2d 67 65 74 2d 69 74 65 6d stqueue-get-item
3400: 64 61 74 20 20 20 20 74 65 73 74 2d 72 65 63 6f dat test-reco
3410: 72 64 29 29 20 3b 3b 20 69 74 65 6d 64 61 74 20 rd)) ;; itemdat
3420: 63 61 6e 20 62 65 20 61 20 73 74 72 69 6e 67 2c can be a string,
3430: 20 6c 69 73 74 20 6f 72 20 23 66 0a 09 09 20 28 list or #f... (
3440: 69 74 65 6d 73 20 20 20 20 20 20 20 28 74 65 73 items (tes
3450: 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 ts:testqueue-get
3460: 2d 69 74 65 6d 73 20 20 20 20 20 20 74 65 73 74 -items test
3470: 2d 72 65 63 6f 72 64 29 29 0a 09 09 20 28 69 74 -record))... (it
3480: 65 6d 2d 70 61 74 68 20 20 20 28 69 74 65 6d 2d em-path (item-
3490: 6c 69 73 74 2d 3e 70 61 74 68 20 69 74 65 6d 64 list->path itemd
34a0: 61 74 29 29 0a 09 09 20 28 6e 65 77 74 61 6c 20 at))... (newtal
34b0: 20 20 20 20 20 28 61 70 70 65 6e 64 20 74 61 6c (append tal
34c0: 20 28 6c 69 73 74 20 68 65 64 29 29 29 0a 09 09 (list hed)))...
34d0: 20 28 63 61 6c 63 2d 66 61 69 6c 73 20 20 28 6c (calc-fails (l
34e0: 61 6d 62 64 61 20 28 70 72 65 72 65 71 73 2d 6e ambda (prereqs-n
34f0: 6f 74 2d 6d 65 74 29 0a 09 09 09 09 28 66 69 6c ot-met).....(fil
3500: 74 65 72 20 28 6c 61 6d 62 64 61 20 28 74 65 73 ter (lambda (tes
3510: 74 29 0a 09 09 09 09 09 20 20 28 64 65 62 75 67 t)...... (debug
3520: 3a 70 72 69 6e 74 20 39 20 22 74 65 73 74 3a 20 :print 9 "test:
3530: 22 20 74 65 73 74 29 0a 09 09 09 09 09 20 20 28 " test)...... (
3540: 61 6e 64 20 28 76 65 63 74 6f 72 3f 20 74 65 73 and (vector? tes
3550: 74 29 20 3b 3b 20 6e 6f 74 20 28 73 74 72 69 6e t) ;; not (strin
3560: 67 3f 20 74 65 73 74 29 29 0a 09 09 09 09 09 20 g? test))......
3570: 20 20 20 20 20 20 28 65 71 75 61 6c 3f 20 28 64 (equal? (d
3580: 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 b:test-get-state
3590: 20 74 65 73 74 29 20 22 43 4f 4d 50 4c 45 54 45 test) "COMPLETE
35a0: 44 22 29 0a 09 09 09 09 09 20 20 20 20 20 20 20 D")......
35b0: 28 6e 6f 74 20 28 6d 65 6d 62 65 72 20 28 64 62 (not (member (db
35c0: 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 73 :test-get-status
35d0: 20 74 65 73 74 29 0a 09 09 09 09 09 09 09 20 20 test)........
35e0: 20 20 27 28 22 50 41 53 53 22 20 22 57 41 52 4e '("PASS" "WARN
35f0: 22 20 22 43 48 45 43 4b 22 20 22 57 41 49 56 45 " "CHECK" "WAIVE
3600: 44 22 29 29 29 29 29 0a 09 09 09 09 09 70 72 65 D")))))......pre
3610: 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 29 0a reqs-not-met))).
3620: 09 09 20 28 63 61 6c 63 2d 6e 6f 74 2d 63 6f 6d .. (calc-not-com
3630: 70 6c 65 74 65 64 20 28 6c 61 6d 62 64 61 20 28 pleted (lambda (
3640: 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 prereqs-not-met)
3650: 0a 09 09 09 09 20 20 20 20 20 20 20 28 66 69 6c ..... (fil
3660: 74 65 72 0a 09 09 09 09 09 28 6c 61 6d 62 64 61 ter......(lambda
3670: 20 28 74 29 0a 09 09 09 09 09 20 20 28 6f 72 20 (t)...... (or
3680: 28 6e 6f 74 20 28 76 65 63 74 6f 72 3f 20 74 29 (not (vector? t)
3690: 29 0a 09 09 09 09 09 20 20 20 20 20 20 28 6e 6f )...... (no
36a0: 74 20 28 65 71 75 61 6c 3f 20 22 43 4f 4d 50 4c t (equal? "COMPL
36b0: 45 54 45 44 22 20 28 64 62 3a 74 65 73 74 2d 67 ETED" (db:test-g
36c0: 65 74 2d 73 74 61 74 65 20 74 29 29 29 29 29 0a et-state t))))).
36d0: 09 09 09 09 09 70 72 65 72 65 71 73 2d 6e 6f 74 .....prereqs-not
36e0: 2d 6d 65 74 29 29 29 0a 09 09 20 28 70 72 65 74 -met)))... (pret
36f0: 74 79 2d 73 74 72 69 6e 67 20 28 6c 61 6d 62 64 ty-string (lambd
3700: 61 20 28 6c 73 74 29 0a 09 09 09 09 20 20 28 6d a (lst)..... (m
3710: 61 70 20 28 6c 61 6d 62 64 61 20 28 74 29 0a 09 ap (lambda (t)..
3720: 09 09 09 09 20 28 69 66 20 28 6e 6f 74 20 28 76 .... (if (not (v
3730: 65 63 74 6f 72 3f 20 74 29 29 0a 09 09 09 09 09 ector? t))......
3740: 20 20 20 20 20 28 63 6f 6e 63 20 74 29 0a 09 09 (conc t)...
3750: 09 09 09 20 20 20 20 20 28 63 6f 6e 63 20 28 64 ... (conc (d
3760: 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e b:test-get-testn
3770: 61 6d 65 20 74 29 20 22 3a 22 20 28 64 62 3a 74 ame t) ":" (db:t
3780: 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 74 29 est-get-state t)
3790: 20 22 2f 22 20 28 64 62 3a 74 65 73 74 2d 67 65 "/" (db:test-ge
37a0: 74 2d 73 74 61 74 75 73 20 74 29 29 29 29 0a 09 t-status t))))..
37b0: 09 09 09 20 20 20 20 20 20 20 6c 73 74 29 29 29 ... lst)))
37c0: 29 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 ).. (debug:pr
37d0: 69 6e 74 20 36 0a 09 09 09 20 22 69 74 65 6d 64 int 6.... "itemd
37e0: 61 74 3a 20 20 20 20 20 22 20 69 74 65 6d 64 61 at: " itemda
37f0: 74 0a 09 09 09 20 22 5c 6e 20 20 69 74 65 6d 73 t.... "\n items
3800: 3a 20 20 20 20 20 22 20 69 74 65 6d 73 0a 09 09 : " items...
3810: 09 20 22 5c 6e 20 20 69 74 65 6d 2d 70 61 74 68 . "\n item-path
3820: 3a 20 22 20 69 74 65 6d 2d 70 61 74 68 0a 09 09 : " item-path...
3830: 09 20 22 5c 6e 20 20 77 61 69 74 6f 6e 73 3a 20 . "\n waitons:
3840: 20 20 22 20 77 61 69 74 6f 6e 73 29 0a 0a 09 20 " waitons)...
3850: 20 20 20 3b 3b 20 63 68 65 63 6b 20 66 6f 72 20 ;; check for
3860: 68 65 64 20 69 6e 20 77 61 69 74 6f 6e 73 20 3d hed in waitons =
3870: 3e 20 74 68 69 73 20 77 6f 75 6c 64 20 62 65 20 > this would be
3880: 63 69 72 63 75 6c 61 72 2c 20 72 65 6d 6f 76 65 circular, remove
3890: 20 69 74 20 61 6e 64 20 69 73 73 75 65 20 61 6e it and issue an
38a0: 0a 09 20 20 20 20 3b 3b 20 65 72 72 6f 72 0a 09 .. ;; error..
38b0: 20 20 20 20 28 69 66 20 28 6d 65 6d 62 65 72 20 (if (member
38c0: 68 65 64 20 77 61 69 74 6f 6e 73 29 0a 09 09 28 hed waitons)...(
38d0: 62 65 67 69 6e 0a 09 09 20 20 28 64 65 62 75 67 begin... (debug
38e0: 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a :print 0 "ERROR:
38f0: 20 74 65 73 74 20 22 20 68 65 64 20 22 20 68 61 test " hed " ha
3900: 73 20 6c 69 73 74 65 64 20 69 74 73 65 6c 66 20 s listed itself
3910: 61 73 20 61 20 77 61 69 74 6f 6e 2c 20 70 6c 65 as a waiton, ple
3920: 61 73 65 20 63 6f 72 72 65 63 74 20 74 68 69 73 ase correct this
3930: 21 22 29 0a 09 09 20 20 28 73 65 74 21 20 77 61 !")... (set! wa
3940: 69 74 6f 6e 20 28 66 69 6c 74 65 72 20 28 6c 61 iton (filter (la
3950: 6d 62 64 61 20 28 78 29 28 6e 6f 74 20 28 65 71 mbda (x)(not (eq
3960: 75 61 6c 3f 20 78 20 68 65 64 29 29 29 20 77 61 ual? x hed))) wa
3970: 69 74 6f 6e 73 29 29 29 29 0a 0a 09 20 20 20 20 itons))))...
3980: 28 63 6f 6e 64 0a 09 20 20 20 20 20 28 28 6e 6f (cond.. ((no
3990: 74 20 69 74 65 6d 73 29 20 3b 3b 20 77 68 65 6e t items) ;; when
39a0: 20 66 61 6c 73 65 20 74 68 65 20 74 65 73 74 20 false the test
39b0: 69 73 20 6f 6b 20 74 6f 20 62 65 20 68 61 6e 64 is ok to be hand
39c0: 65 64 20 6f 66 66 20 74 6f 20 6c 61 75 6e 63 68 ed off to launch
39d0: 20 28 62 75 74 20 6e 6f 74 20 62 65 66 6f 72 65 (but not before
39e0: 29 0a 09 20 20 20 20 20 20 28 6c 65 74 2a 20 28 ).. (let* (
39f0: 28 68 61 76 65 2d 72 65 73 6f 75 72 63 65 73 20 (have-resources
3a00: 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 (open-run-close
3a10: 20 72 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f runs:can-run-mo
3a20: 72 65 2d 74 65 73 74 73 20 23 66 20 74 65 73 74 re-tests #f test
3a30: 2d 72 65 63 6f 72 64 29 29 20 3b 3b 20 6c 6f 6f -record)) ;; loo
3a40: 6b 20 61 74 20 74 68 65 20 74 65 73 74 20 6a 6f k at the test jo
3a50: 62 67 72 6f 75 70 20 61 6e 64 20 74 6f 74 20 6a bgroup and tot j
3a60: 6f 62 73 20 72 75 6e 6e 69 6e 67 0a 09 09 20 20 obs running...
3a70: 20 20 20 28 70 72 65 72 65 71 73 2d 6e 6f 74 2d (prereqs-not-
3a80: 6d 65 74 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c met (open-run-cl
3a90: 6f 73 65 20 64 62 3a 67 65 74 2d 70 72 65 72 65 ose db:get-prere
3aa0: 71 73 2d 6e 6f 74 2d 6d 65 74 20 23 66 20 72 75 qs-not-met #f ru
3ab0: 6e 2d 69 64 20 77 61 69 74 6f 6e 73 20 69 74 65 n-id waitons ite
3ac0: 6d 2d 70 61 74 68 20 6d 6f 64 65 3a 20 74 65 73 m-path mode: tes
3ad0: 74 6d 6f 64 65 29 29 0a 09 09 20 20 20 20 20 28 tmode))... (
3ae0: 66 61 69 6c 73 20 20 20 20 20 20 20 20 20 20 20 fails
3af0: 28 63 61 6c 63 2d 66 61 69 6c 73 20 70 72 65 72 (calc-fails prer
3b00: 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 0a 09 09 eqs-not-met))...
3b10: 20 20 20 20 20 28 6e 6f 6e 2d 63 6f 6d 70 6c 65 (non-comple
3b20: 74 65 64 20 20 20 28 63 61 6c 63 2d 6e 6f 74 2d ted (calc-not-
3b30: 63 6f 6d 70 6c 65 74 65 64 20 70 72 65 72 65 71 completed prereq
3b40: 73 2d 6e 6f 74 2d 6d 65 74 29 29 29 0a 09 09 28 s-not-met)))...(
3b50: 64 65 62 75 67 3a 70 72 69 6e 74 20 38 20 22 49 debug:print 8 "I
3b60: 4e 46 4f 3a 20 68 61 76 65 2d 72 65 73 6f 75 72 NFO: have-resour
3b70: 63 65 73 3a 20 22 20 68 61 76 65 2d 72 65 73 6f ces: " have-reso
3b80: 75 72 63 65 73 20 22 20 70 72 65 72 65 71 73 2d urces " prereqs-
3b90: 6e 6f 74 2d 6d 65 74 3a 20 22 20 0a 09 09 09 20 not-met: " ....
3ba0: 20 20 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 (string-inte
3bb0: 72 73 70 65 72 73 65 20 0a 09 09 09 20 20 20 20 rsperse ....
3bc0: 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 (map (lambda (
3bd0: 74 29 0a 09 09 09 09 20 20 20 20 20 28 69 66 20 t)..... (if
3be0: 28 76 65 63 74 6f 72 3f 20 74 29 0a 09 09 09 09 (vector? t).....
3bf0: 09 20 28 63 6f 6e 63 20 28 64 62 3a 74 65 73 74 . (conc (db:test
3c00: 2d 67 65 74 2d 73 74 61 74 65 20 74 29 20 22 2f -get-state t) "/
3c10: 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 " (db:test-get-s
3c20: 74 61 74 75 73 20 74 29 29 0a 09 09 09 09 09 20 tatus t))......
3c30: 28 63 6f 6e 63 20 22 20 57 41 52 4e 49 4e 47 3a (conc " WARNING:
3c40: 20 74 20 69 73 20 6e 6f 74 20 61 20 76 65 63 74 t is not a vect
3c50: 6f 72 3d 22 20 74 20 29 29 29 0a 09 09 09 09 20 or=" t ))).....
3c60: 20 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 prereqs-not-me
3c70: 74 29 20 22 2c 20 22 29 20 22 20 66 61 69 6c 73 t) ", ") " fails
3c80: 3a 20 22 20 66 61 69 6c 73 29 0a 09 09 3b 3b 20 : " fails)...;;
3c90: 44 6f 6e 27 74 20 6b 6e 6f 77 20 61 74 20 74 68 Don't know at th
3ca0: 69 73 20 74 69 6d 65 20 69 66 20 74 68 65 20 74 is time if the t
3cb0: 65 73 74 20 68 61 76 65 20 62 65 65 6e 20 6c 61 est have been la
3cc0: 75 6e 63 68 65 64 20 61 74 20 73 6f 6d 65 20 74 unched at some t
3cd0: 69 6d 65 20 69 6e 20 74 68 65 20 70 61 73 74 0a ime in the past.
3ce0: 09 09 3b 3b 20 69 2e 65 2e 20 69 73 20 74 68 69 ..;; i.e. is thi
3cf0: 73 20 61 20 72 65 2d 6c 61 75 6e 63 68 3f 0a 09 s a re-launch?..
3d00: 09 28 63 6f 6e 64 0a 09 09 20 28 28 61 6e 64 20 .(cond... ((and
3d10: 68 61 76 65 2d 72 65 73 6f 75 72 63 65 73 0a 09 have-resources..
3d20: 09 20 20 20 20 20 20 20 28 6f 72 20 28 6e 75 6c . (or (nul
3d30: 6c 3f 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d l? prereqs-not-m
3d40: 65 74 29 0a 09 09 09 20 20 20 28 61 6e 64 20 28 et).... (and (
3d50: 65 71 3f 20 74 65 73 74 6d 6f 64 65 20 27 74 6f eq? testmode 'to
3d60: 70 6c 65 76 65 6c 29 0a 09 09 09 09 28 6e 75 6c plevel).....(nul
3d70: 6c 3f 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 l? non-completed
3d80: 29 29 29 29 0a 09 09 20 20 3b 3b 20 6e 6f 20 6c ))))... ;; no l
3d90: 6f 6f 70 20 68 65 72 65 2c 20 6a 75 73 74 20 64 oop here, just d
3da0: 72 6f 70 20 74 68 6f 75 67 68 20 61 6e 64 20 75 rop though and u
3db0: 73 65 20 74 68 65 20 6c 6f 6f 70 20 61 74 20 74 se the loop at t
3dc0: 68 65 20 62 6f 74 74 6f 6d 20 0a 09 09 20 20 28 he bottom ... (
3dd0: 69 66 20 28 70 61 74 74 2d 6c 69 73 74 2d 6d 61 if (patt-list-ma
3de0: 74 63 68 20 69 74 65 6d 2d 70 61 74 68 20 69 74 tch item-path it
3df0: 65 6d 2d 70 61 74 74 73 29 0a 09 09 20 20 20 20 em-patts)...
3e00: 20 20 28 72 75 6e 3a 74 65 73 74 20 72 75 6e 2d (run:test run-
3e10: 69 64 20 72 75 6e 6e 61 6d 65 20 6b 65 79 76 61 id runname keyva
3e20: 6c 6c 73 74 20 74 65 73 74 2d 72 65 63 6f 72 64 llst test-record
3e30: 20 66 6c 61 67 73 20 23 66 29 0a 09 09 20 20 20 flags #f)...
3e40: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
3e50: 31 20 22 49 4e 46 4f 3a 20 53 6b 69 70 70 69 6e 1 "INFO: Skippin
3e60: 67 20 22 20 28 74 65 73 74 73 3a 74 65 73 74 71 g " (tests:testq
3e70: 75 65 75 65 2d 67 65 74 2d 74 65 73 74 6e 61 6d ueue-get-testnam
3e80: 65 20 74 65 73 74 2d 72 65 63 6f 72 64 29 20 22 e test-record) "
3e90: 20 22 20 69 74 65 6d 2d 70 61 74 68 20 22 20 61 " item-path " a
3ea0: 73 20 69 74 20 64 6f 65 73 6e 27 74 20 6d 61 74 s it doesn't mat
3eb0: 63 68 20 22 20 69 74 65 6d 2d 70 61 74 74 73 29 ch " item-patts)
3ec0: 29 0a 09 09 20 20 3b 3b 20 65 6c 73 65 20 74 68 )... ;; else th
3ed0: 65 20 72 75 6e 20 69 73 20 73 74 75 63 6b 2c 20 e run is stuck,
3ee0: 74 65 6d 70 6f 72 61 72 69 6c 79 20 6f 72 20 70 temporarily or p
3ef0: 65 72 6d 61 6e 65 6e 74 6c 79 0a 09 09 20 20 3b ermanently... ;
3f00: 3b 20 62 75 74 20 73 68 6f 75 6c 64 20 63 68 65 ; but should che
3f10: 63 6b 20 69 66 20 69 74 20 69 73 20 64 75 65 20 ck if it is due
3f20: 74 6f 20 6c 61 63 6b 20 6f 66 20 72 65 73 6f 75 to lack of resou
3f30: 72 63 65 73 20 76 73 2e 20 70 72 65 72 65 71 75 rces vs. prerequ
3f40: 69 73 69 74 65 73 0a 09 09 20 20 29 0a 09 09 20 isites... )...
3f50: 28 28 6e 6f 74 20 68 61 76 65 2d 72 65 73 6f 75 ((not have-resou
3f60: 72 63 65 73 29 20 3b 3b 20 73 69 6d 70 6c 79 20 rces) ;; simply
3f70: 74 72 79 20 61 67 61 69 6e 20 61 66 74 65 72 20 try again after
3f80: 77 61 69 74 69 6e 67 20 61 20 73 65 63 6f 6e 64 waiting a second
3f90: 0a 09 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 ... (thread-sle
3fa0: 65 70 21 20 28 2b 20 31 20 2a 67 6c 6f 62 61 6c ep! (+ 1 *global
3fb0: 2d 64 65 6c 74 61 2a 29 29 0a 09 09 20 20 28 64 -delta*))... (d
3fc0: 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 49 4e ebug:print 1 "IN
3fd0: 46 4f 3a 20 6e 6f 20 72 65 73 6f 75 72 63 65 73 FO: no resources
3fe0: 20 74 6f 20 72 75 6e 20 6e 65 77 20 74 65 73 74 to run new test
3ff0: 73 2c 20 77 61 69 74 69 6e 67 20 2e 2e 2e 22 29 s, waiting ...")
4000: 0a 09 09 20 20 3b 3b 20 63 6f 75 6c 64 20 68 61 ... ;; could ha
4010: 76 65 20 64 6f 6e 65 20 68 65 64 20 74 61 6c 20 ve done hed tal
4020: 68 65 72 65 20 62 75 74 20 64 6f 69 6e 67 20 63 here but doing c
4030: 61 72 2f 63 64 72 20 6f 66 20 6e 65 77 74 61 6c ar/cdr of newtal
4040: 20 74 6f 20 72 6f 74 61 74 65 20 74 65 73 74 73 to rotate tests
4050: 0a 09 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 ... (loop (car
4060: 6e 65 77 74 61 6c 29 28 63 64 72 20 6e 65 77 74 newtal)(cdr newt
4070: 61 6c 29 29 29 0a 09 09 20 28 65 6c 73 65 20 3b al)))... (else ;
4080: 3b 20 6d 75 73 74 20 62 65 20 77 65 20 68 61 76 ; must be we hav
4090: 65 20 75 6e 6d 65 74 20 70 72 65 72 65 71 75 69 e unmet prerequi
40a0: 73 69 74 65 73 0a 09 09 20 20 20 20 28 64 65 62 sites... (deb
40b0: 75 67 3a 70 72 69 6e 74 20 34 20 22 46 41 49 4c ug:print 4 "FAIL
40c0: 53 3a 20 22 20 66 61 69 6c 73 29 0a 09 09 20 20 S: " fails)...
40d0: 20 20 3b 3b 20 49 66 20 6f 6e 65 20 6f 72 20 6d ;; If one or m
40e0: 6f 72 65 20 6f 66 20 74 68 65 20 70 72 65 72 65 ore of the prere
40f0: 71 73 2d 6e 6f 74 2d 6d 65 74 20 61 72 65 20 46 qs-not-met are F
4100: 41 49 4c 20 74 68 65 6e 20 77 65 20 63 61 6e 20 AIL then we can
4110: 69 73 73 75 65 0a 09 09 20 20 20 20 3b 3b 20 61 issue... ;; a
4120: 20 6d 65 73 73 61 67 65 20 61 6e 64 20 64 72 6f message and dro
4130: 70 20 68 65 64 20 66 72 6f 6d 20 74 68 65 20 69 p hed from the i
4140: 74 65 6d 73 20 74 6f 20 62 65 20 70 72 6f 63 65 tems to be proce
4150: 73 73 65 64 2e 0a 09 09 20 20 20 20 28 69 66 20 ssed.... (if
4160: 28 6e 75 6c 6c 3f 20 66 61 69 6c 73 29 0a 09 09 (null? fails)...
4170: 09 28 62 65 67 69 6e 0a 09 09 09 20 20 3b 3b 20 .(begin.... ;;
4180: 63 6f 75 6c 64 6e 27 74 20 72 75 6e 2c 20 74 61 couldn't run, ta
4190: 6b 65 20 61 20 62 72 65 61 74 68 65 72 0a 09 09 ke a breather...
41a0: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 . (debug:print
41b0: 34 20 22 49 4e 46 4f 3a 20 53 68 6f 75 6c 64 6e 4 "INFO: Shouldn
41c0: 27 74 20 72 65 61 6c 6c 79 20 67 65 74 20 68 65 't really get he
41d0: 72 65 2c 20 72 61 63 65 20 63 6f 6e 64 69 74 69 re, race conditi
41e0: 6f 6e 3f 20 55 6e 61 62 6c 65 20 74 6f 20 6c 61 on? Unable to la
41f0: 75 6e 63 68 20 6d 6f 72 65 20 74 65 73 74 73 20 unch more tests
4200: 61 74 20 74 68 69 73 20 6d 6f 6d 65 6e 74 2c 20 at this moment,
4210: 6b 69 6c 6c 69 6e 67 20 74 69 6d 65 20 2e 2e 2e killing time ...
4220: 22 29 0a 09 09 09 20 20 28 74 68 72 65 61 64 2d ").... (thread-
4230: 73 6c 65 65 70 21 20 28 2b 20 31 20 2a 67 6c 6f sleep! (+ 1 *glo
4240: 62 61 6c 2d 64 65 6c 74 61 2a 29 29 20 3b 3b 20 bal-delta*)) ;;
4250: 6c 6f 6e 67 20 73 6c 65 65 70 20 68 65 72 65 20 long sleep here
4260: 2d 20 6e 6f 20 72 65 73 6f 75 72 63 65 73 2c 20 - no resources,
4270: 6d 61 79 20 61 73 20 77 65 6c 6c 20 62 65 20 70 may as well be p
4280: 61 74 69 65 6e 74 0a 09 09 09 20 20 3b 3b 20 77 atient.... ;; w
4290: 65 20 6d 61 64 65 20 6e 65 77 20 74 61 6c 20 62 e made new tal b
42a0: 79 20 73 74 69 63 6b 69 6e 67 20 68 65 64 20 61 y sticking hed a
42b0: 74 20 74 68 65 20 62 61 63 6b 20 6f 66 20 74 68 t the back of th
42c0: 65 20 6c 69 73 74 0a 09 09 09 20 20 28 6c 6f 6f e list.... (loo
42d0: 70 20 28 63 61 72 20 6e 65 77 74 61 6c 29 28 63 p (car newtal)(c
42e0: 64 72 20 6e 65 77 74 61 6c 29 29 29 0a 09 09 09 dr newtal)))....
42f0: 3b 3b 20 74 68 65 20 77 61 69 74 6f 6e 20 69 73 ;; the waiton is
4300: 20 46 41 49 4c 20 73 6f 20 6e 6f 20 70 6f 69 6e FAIL so no poin
4310: 74 20 69 6e 20 74 72 79 69 6e 67 20 74 6f 20 72 t in trying to r
4320: 75 6e 20 68 65 64 20 65 76 65 72 20 61 67 61 69 un hed ever agai
4330: 6e 0a 09 09 09 28 69 66 20 28 6e 6f 74 20 28 6e n....(if (not (n
4340: 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 09 09 20 20 ull? tal))....
4350: 20 20 28 62 65 67 69 6e 0a 09 09 09 20 20 20 20 (begin....
4360: 20 20 28 69 66 20 28 76 65 63 74 6f 72 3f 20 68 (if (vector? h
4370: 65 64 29 0a 09 09 09 09 20 20 28 64 65 62 75 67 ed)..... (debug
4380: 3a 70 72 69 6e 74 20 31 20 22 57 41 52 4e 3a 20 :print 1 "WARN:
4390: 44 72 6f 70 70 69 6e 67 20 74 65 73 74 20 22 20 Dropping test "
43a0: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 (db:test-get-tes
43b0: 74 6e 61 6d 65 20 68 65 64 29 20 22 2f 22 20 28 tname hed) "/" (
43c0: 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 6d db:test-get-item
43d0: 2d 70 61 74 68 20 68 65 64 29 0a 09 09 09 09 09 -path hed)......
43e0: 20 20 20 20 20 20 20 22 20 66 72 6f 6d 20 74 68 " from th
43f0: 65 20 6c 61 75 6e 63 68 20 6c 69 73 74 20 61 73 e launch list as
4400: 20 69 74 20 68 61 73 20 70 72 65 72 65 71 75 69 it has prerequi
4410: 73 74 65 73 20 74 68 61 74 20 61 72 65 20 46 41 stes that are FA
4420: 49 4c 22 29 0a 09 09 09 09 20 20 28 64 65 62 75 IL")..... (debu
4430: 67 3a 70 72 69 6e 74 20 31 20 22 57 41 52 4e 3a g:print 1 "WARN:
4440: 20 44 72 6f 70 70 69 6e 67 20 74 65 73 74 20 22 Dropping test "
4450: 20 68 65 64 20 22 20 61 73 20 69 74 20 68 61 73 hed " as it has
4460: 20 70 72 65 72 65 71 75 69 73 74 65 73 20 74 68 prerequistes th
4470: 61 74 20 61 72 65 20 46 41 49 4c 2e 20 28 4e 4f at are FAIL. (NO
4480: 54 45 3a 20 68 65 64 20 69 73 20 6e 6f 74 20 61 TE: hed is not a
4490: 20 76 65 63 74 6f 72 29 22 29 29 0a 09 09 09 20 vector)"))....
44a0: 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 (loop (car
44b0: 74 61 6c 29 28 63 64 72 20 74 61 6c 29 29 29 29 tal)(cdr tal))))
44c0: 29 29 29 29 29 0a 09 20 20 20 20 20 0a 09 20 20 ))))).. ..
44d0: 20 20 20 3b 3b 20 63 61 73 65 20 77 68 65 72 65 ;; case where
44e0: 20 61 6e 20 69 74 65 6d 73 20 63 61 6d 65 20 69 an items came i
44f0: 6e 20 61 73 20 61 20 6c 69 73 74 20 62 65 65 6e n as a list been
4500: 20 70 72 6f 63 65 73 73 65 64 0a 09 20 20 20 20 processed..
4510: 20 28 28 61 6e 64 20 28 6c 69 73 74 3f 20 69 74 ((and (list? it
4520: 65 6d 73 29 20 20 20 20 20 3b 3b 20 74 68 75 73 ems) ;; thus
4530: 20 77 65 20 6b 6e 6f 77 20 6f 75 72 20 69 74 65 we know our ite
4540: 6d 73 20 61 72 65 20 61 6c 72 65 61 64 79 20 63 ms are already c
4550: 61 6c 63 75 6c 61 74 65 64 0a 09 09 20 20 20 28 alculated... (
4560: 6e 6f 74 20 20 20 69 74 65 6d 64 61 74 29 29 20 not itemdat))
4570: 3b 3b 20 61 6e 64 20 6e 6f 74 20 79 65 74 20 65 ;; and not yet e
4580: 78 70 61 6e 64 65 64 20 69 6e 74 6f 20 74 68 65 xpanded into the
4590: 20 6c 69 73 74 20 6f 66 20 74 68 69 6e 67 73 20 list of things
45a0: 74 6f 20 62 65 20 64 6f 6e 65 0a 09 20 20 20 20 to be done..
45b0: 20 20 28 69 66 20 28 61 6e 64 20 28 3e 3d 20 2a (if (and (>= *
45c0: 76 65 72 62 6f 73 69 74 79 2a 20 31 29 0a 09 09 verbosity* 1)...
45d0: 20 20 20 20 20 20 20 28 3e 20 28 6c 65 6e 67 74 (> (lengt
45e0: 68 20 69 74 65 6d 73 29 20 30 29 0a 09 09 20 20 h items) 0)...
45f0: 20 20 20 20 20 28 3e 20 28 6c 65 6e 67 74 68 20 (> (length
4600: 28 63 61 72 20 69 74 65 6d 73 29 29 20 30 29 29 (car items)) 0))
4610: 0a 09 09 20 20 28 70 70 20 69 74 65 6d 73 29 29 ... (pp items))
4620: 0a 09 20 20 20 20 20 20 3b 3b 20 28 69 66 20 28 .. ;; (if (
4630: 3e 3d 20 2a 76 65 72 62 6f 73 69 74 79 2a 20 35 >= *verbosity* 5
4640: 29 0a 09 20 20 20 20 20 20 3b 3b 20 20 20 20 20 ).. ;;
4650: 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 3b 3b (begin.. ;;
4660: 20 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 69 (print "i
4670: 74 65 6d 73 3a 20 22 29 20 20 20 20 20 28 70 70 tems: ") (pp
4680: 20 28 69 74 65 6d 2d 61 73 73 6f 63 2d 3e 69 74 (item-assoc->it
4690: 65 6d 2d 6c 69 73 74 20 69 74 65 6d 73 29 29 0a em-list items)).
46a0: 09 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 . ;;
46b0: 28 70 72 69 6e 74 20 22 69 74 65 6d 73 74 61 62 (print "itemstab
46c0: 6c 65 3a 20 22 29 28 70 70 20 28 69 74 65 6d 2d le: ")(pp (item-
46d0: 74 61 62 6c 65 2d 3e 69 74 65 6d 2d 6c 69 73 74 table->item-list
46e0: 20 69 74 65 6d 73 74 61 62 6c 65 29 29 29 29 0a itemstable)))).
46f0: 09 20 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 . (for-each
4700: 0a 09 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 .. (lambda
4710: 20 28 6d 79 2d 69 74 65 6d 64 61 74 29 0a 09 09 (my-itemdat)...
4720: 20 28 6c 65 74 2a 20 28 28 6e 65 77 2d 74 65 73 (let* ((new-tes
4730: 74 2d 72 65 63 6f 72 64 20 28 6c 65 74 20 28 28 t-record (let ((
4740: 6e 65 77 72 65 63 20 28 6d 61 6b 65 2d 74 65 73 newrec (make-tes
4750: 74 73 3a 74 65 73 74 71 75 65 75 65 29 29 29 0a ts:testqueue))).
4760: 09 09 09 09 09 20 20 20 28 76 65 63 74 6f 72 2d ..... (vector-
4770: 63 6f 70 79 21 20 74 65 73 74 2d 72 65 63 6f 72 copy! test-recor
4780: 64 20 6e 65 77 72 65 63 29 0a 09 09 09 09 09 20 d newrec)......
4790: 20 20 6e 65 77 72 65 63 29 29 0a 09 09 09 28 6d newrec))....(m
47a0: 79 2d 69 74 65 6d 2d 70 61 74 68 20 28 69 74 65 y-item-path (ite
47b0: 6d 2d 6c 69 73 74 2d 3e 70 61 74 68 20 6d 79 2d m-list->path my-
47c0: 69 74 65 6d 64 61 74 29 29 29 0a 09 09 20 20 20 itemdat)))...
47d0: 28 69 66 20 28 70 61 74 74 2d 6c 69 73 74 2d 6d (if (patt-list-m
47e0: 61 74 63 68 20 6d 79 2d 69 74 65 6d 2d 70 61 74 atch my-item-pat
47f0: 68 20 69 74 65 6d 2d 70 61 74 74 73 29 20 20 20 h item-patts)
4800: 20 20 20 20 20 20 20 20 3b 3b 20 79 65 73 2c 20 ;; yes,
4810: 77 65 20 77 61 6e 74 20 74 6f 20 70 72 6f 63 65 we want to proce
4820: 73 73 20 74 68 69 73 20 69 74 65 6d 2c 20 4e 4f ss this item, NO
4830: 54 45 3a 20 53 68 6f 75 6c 64 20 6e 6f 74 20 6e TE: Should not n
4840: 65 65 64 20 74 68 69 73 20 63 68 65 63 6b 20 68 eed this check h
4850: 65 72 65 21 0a 09 09 20 20 20 20 20 20 20 28 6c ere!... (l
4860: 65 74 20 28 28 6e 65 77 74 65 73 74 6e 61 6d 65 et ((newtestname
4870: 20 28 63 6f 6e 63 20 68 65 64 20 22 2f 22 20 6d (conc hed "/" m
4880: 79 2d 69 74 65 6d 2d 70 61 74 68 29 29 29 20 20 y-item-path)))
4890: 20 20 3b 3b 20 74 65 73 74 20 6e 61 6d 65 73 20 ;; test names
48a0: 61 72 65 20 75 6e 69 71 75 65 20 6f 6e 20 74 65 are unique on te
48b0: 73 74 6e 61 6d 65 2f 69 74 65 6d 2d 70 61 74 68 stname/item-path
48c0: 0a 09 09 09 20 28 74 65 73 74 73 3a 74 65 73 74 .... (tests:test
48d0: 71 75 65 75 65 2d 73 65 74 2d 69 74 65 6d 73 21 queue-set-items!
48e0: 20 20 20 20 20 6e 65 77 2d 74 65 73 74 2d 72 65 new-test-re
48f0: 63 6f 72 64 20 23 66 29 0a 09 09 09 20 28 74 65 cord #f).... (te
4900: 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 73 65 sts:testqueue-se
4910: 74 2d 69 74 65 6d 64 61 74 21 20 20 20 6e 65 77 t-itemdat! new
4920: 2d 74 65 73 74 2d 72 65 63 6f 72 64 20 6d 79 2d -test-record my-
4930: 69 74 65 6d 64 61 74 29 0a 09 09 09 20 28 74 65 itemdat).... (te
4940: 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 73 65 sts:testqueue-se
4950: 74 2d 69 74 65 6d 5f 70 61 74 68 21 20 6e 65 77 t-item_path! new
4960: 2d 74 65 73 74 2d 72 65 63 6f 72 64 20 6d 79 2d -test-record my-
4970: 69 74 65 6d 2d 70 61 74 68 29 0a 09 09 09 20 28 item-path).... (
4980: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
4990: 74 65 73 74 2d 72 65 63 6f 72 64 73 20 6e 65 77 test-records new
49a0: 74 65 73 74 6e 61 6d 65 20 6e 65 77 2d 74 65 73 testname new-tes
49b0: 74 2d 72 65 63 6f 72 64 29 0a 09 09 09 20 28 73 t-record).... (s
49c0: 65 74 21 20 74 61 6c 20 28 63 6f 6e 73 20 6e 65 et! tal (cons ne
49d0: 77 74 65 73 74 6e 61 6d 65 20 74 61 6c 29 29 29 wtestname tal)))
49e0: 29 29 29 20 3b 3b 20 73 69 6e 63 65 20 74 68 65 ))) ;; since the
49f0: 73 65 20 61 72 65 20 69 74 65 6d 69 7a 65 64 20 se are itemized
4a00: 63 72 65 61 74 65 20 6e 65 77 20 74 65 73 74 20 create new test
4a10: 6e 61 6d 65 73 20 74 65 73 74 6e 61 6d 65 2f 69 names testname/i
4a20: 74 65 6d 70 61 74 68 0a 09 20 20 20 20 20 20 20 tempath..
4a30: 69 74 65 6d 73 29 0a 09 20 20 20 20 20 20 28 69 items).. (i
4a40: 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 f (not (null? ta
4a50: 6c 29 29 0a 09 09 20 20 28 6c 6f 6f 70 20 28 63 l))... (loop (c
4a60: 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 ar tal)(cdr tal)
4a70: 29 29 29 0a 0a 09 20 20 20 20 20 3b 3b 20 69 66 )))... ;; if
4a80: 20 69 74 65 6d 73 20 69 73 20 61 20 70 72 6f 63 items is a proc
4a90: 20 74 68 65 6e 20 6e 65 65 64 20 74 6f 20 72 75 then need to ru
4aa0: 6e 20 69 74 65 6d 73 3a 67 65 74 2d 69 74 65 6d n items:get-item
4ab0: 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 2c 20 67 s-from-config, g
4ac0: 65 74 20 74 68 65 20 6c 69 73 74 20 61 6e 64 20 et the list and
4ad0: 6c 6f 6f 70 20 0a 09 20 20 20 20 20 3b 3b 20 20 loop .. ;;
4ae0: 20 20 2d 20 62 75 74 20 6f 6e 6c 79 20 64 6f 20 - but only do
4af0: 74 68 61 74 20 69 66 20 72 65 73 6f 75 72 63 65 that if resource
4b00: 73 20 65 78 69 73 74 20 74 6f 20 6b 69 63 6b 20 s exist to kick
4b10: 6f 66 66 20 74 68 65 20 6a 6f 62 0a 09 20 20 20 off the job..
4b20: 20 20 28 28 6f 72 20 28 70 72 6f 63 65 64 75 72 ((or (procedur
4b30: 65 3f 20 69 74 65 6d 73 29 28 65 71 3f 20 69 74 e? items)(eq? it
4b40: 65 6d 73 20 27 68 61 76 65 2d 70 72 6f 63 65 64 ems 'have-proced
4b50: 75 72 65 29 29 0a 09 20 20 20 20 20 20 28 6c 65 ure)).. (le
4b60: 74 20 28 28 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 t ((can-run-more
4b70: 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c (open-run-cl
4b80: 6f 73 65 20 72 75 6e 73 3a 63 61 6e 2d 72 75 6e ose runs:can-run
4b90: 2d 6d 6f 72 65 2d 74 65 73 74 73 20 23 66 20 74 -more-tests #f t
4ba0: 65 73 74 2d 72 65 63 6f 72 64 29 29 29 0a 09 09 est-record)))...
4bb0: 28 69 66 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 (if can-run-more
4bc0: 0a 09 09 20 20 20 20 28 6c 65 74 2a 20 28 28 70 ... (let* ((p
4bd0: 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 28 rereqs-not-met (
4be0: 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 open-run-close d
4bf0: 62 3a 67 65 74 2d 70 72 65 72 65 71 73 2d 6e 6f b:get-prereqs-no
4c00: 74 2d 6d 65 74 20 23 66 20 72 75 6e 2d 69 64 20 t-met #f run-id
4c10: 77 61 69 74 6f 6e 73 20 69 74 65 6d 2d 70 61 74 waitons item-pat
4c20: 68 20 6d 6f 64 65 3a 20 74 65 73 74 6d 6f 64 65 h mode: testmode
4c30: 29 29 0a 09 09 09 20 20 20 28 66 61 69 6c 73 20 )).... (fails
4c40: 20 20 20 20 20 20 20 20 20 20 28 63 61 6c 63 2d (calc-
4c50: 66 61 69 6c 73 20 70 72 65 72 65 71 73 2d 6e 6f fails prereqs-no
4c60: 74 2d 6d 65 74 29 29 0a 09 09 09 20 20 20 28 6e t-met)).... (n
4c70: 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 20 20 20 28 on-completed (
4c80: 63 61 6c 63 2d 6e 6f 74 2d 63 6f 6d 70 6c 65 74 calc-not-complet
4c90: 65 64 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d ed prereqs-not-m
4ca0: 65 74 29 29 29 0a 09 09 20 20 20 20 20 20 28 64 et)))... (d
4cb0: 65 62 75 67 3a 70 72 69 6e 74 20 38 20 22 49 4e ebug:print 8 "IN
4cc0: 46 4f 3a 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 FO: can-run-more
4cd0: 3a 20 22 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 : " can-run-more
4ce0: 0a 09 09 09 09 20 20 20 22 5c 6e 20 70 72 65 72 ..... "\n prer
4cf0: 65 71 73 2d 6e 6f 74 2d 6d 65 74 3a 20 22 20 28 eqs-not-met: " (
4d00: 70 72 65 74 74 79 2d 73 74 72 69 6e 67 20 70 72 pretty-string pr
4d10: 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 0a 09 ereqs-not-met)..
4d20: 09 09 09 20 20 20 22 5c 6e 20 6e 6f 6e 2d 63 6f ... "\n non-co
4d30: 6d 70 6c 65 74 65 64 3a 20 20 20 22 20 28 70 72 mpleted: " (pr
4d40: 65 74 74 79 2d 73 74 72 69 6e 67 20 6e 6f 6e 2d etty-string non-
4d50: 63 6f 6d 70 6c 65 74 65 64 29 20 0a 09 09 09 09 completed) .....
4d60: 20 20 20 22 5c 6e 20 66 61 69 6c 73 3a 20 20 20 "\n fails:
4d70: 20 20 20 20 20 20 20 20 22 20 28 70 72 65 74 74 " (prett
4d80: 79 2d 73 74 72 69 6e 67 20 66 61 69 6c 73 29 0a y-string fails).
4d90: 09 09 09 09 20 20 20 22 5c 6e 20 74 65 73 74 6d .... "\n testm
4da0: 6f 64 65 3a 20 20 20 20 20 20 20 20 22 20 74 65 ode: " te
4db0: 73 74 6d 6f 64 65 0a 09 09 09 09 20 20 20 22 5c stmode..... "\
4dc0: 6e 20 28 65 71 3f 20 74 65 73 74 6d 6f 64 65 20 n (eq? testmode
4dd0: 27 74 6f 70 6c 65 76 65 6c 29 20 22 20 28 65 71 'toplevel) " (eq
4de0: 3f 20 74 65 73 74 6d 6f 64 65 20 27 74 6f 70 6c ? testmode 'topl
4df0: 65 76 65 6c 29 0a 09 09 09 09 20 20 20 22 5c 6e evel)..... "\n
4e00: 20 28 6e 75 6c 6c 3f 20 6e 6f 6e 2d 63 6f 6d 70 (null? non-comp
4e10: 6c 65 74 65 64 29 20 20 20 20 22 20 28 6e 75 6c leted) " (nul
4e20: 6c 3f 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 l? non-completed
4e30: 29 29 0a 09 09 20 20 20 20 20 20 28 63 6f 6e 64 ))... (cond
4e40: 20 0a 09 09 20 20 20 20 20 20 20 28 28 6f 72 20 ... ((or
4e50: 28 6e 75 6c 6c 3f 20 70 72 65 72 65 71 73 2d 6e (null? prereqs-n
4e60: 6f 74 2d 6d 65 74 29 20 3b 3b 20 61 6c 6c 20 70 ot-met) ;; all p
4e70: 72 65 72 65 71 73 20 6d 65 74 2c 20 66 69 72 65 rereqs met, fire
4e80: 20 6f 66 66 20 74 68 65 20 74 65 73 74 0a 09 09 off the test...
4e90: 09 20 20 20 20 3b 3b 20 6f 72 2c 20 69 66 20 69 . ;; or, if i
4ea0: 74 20 69 73 20 61 20 27 74 6f 70 6c 65 76 65 6c t is a 'toplevel
4eb0: 20 74 65 73 74 20 61 6e 64 20 61 6c 6c 20 70 72 test and all pr
4ec0: 65 72 65 71 73 20 6e 6f 74 20 6d 65 74 20 61 72 ereqs not met ar
4ed0: 65 20 43 4f 4d 50 4c 45 54 45 44 20 74 68 65 6e e COMPLETED then
4ee0: 20 6c 61 75 6e 63 68 0a 09 09 09 20 20 20 20 28 launch.... (
4ef0: 61 6e 64 20 28 65 71 3f 20 74 65 73 74 6d 6f 64 and (eq? testmod
4f00: 65 20 27 74 6f 70 6c 65 76 65 6c 29 0a 09 09 09 e 'toplevel)....
4f10: 09 20 28 6e 75 6c 6c 3f 20 6e 6f 6e 2d 63 6f 6d . (null? non-com
4f20: 70 6c 65 74 65 64 29 29 29 0a 09 09 09 28 6c 65 pleted)))....(le
4f30: 74 20 28 28 74 65 73 74 2d 6e 61 6d 65 20 28 74 t ((test-name (t
4f40: 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 ests:testqueue-g
4f50: 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 et-testname test
4f60: 2d 72 65 63 6f 72 64 29 29 29 0a 09 09 09 20 20 -record)))....
4f70: 28 73 65 74 65 6e 76 20 22 4d 54 5f 54 45 53 54 (setenv "MT_TEST
4f80: 5f 4e 41 4d 45 22 20 74 65 73 74 2d 6e 61 6d 65 _NAME" test-name
4f90: 29 20 3b 3b 20 0a 09 09 09 20 20 28 73 65 74 65 ) ;; .... (sete
4fa0: 6e 76 20 22 4d 54 5f 52 55 4e 4e 41 4d 45 22 20 nv "MT_RUNNAME"
4fb0: 20 20 72 75 6e 6e 61 6d 65 29 0a 09 09 09 20 20 runname)....
4fc0: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 2d (open-run-close-
4fd0: 6d 65 61 73 75 72 65 20 73 65 74 2d 6d 65 67 61 measure set-mega
4fe0: 74 65 73 74 2d 65 6e 76 2d 76 61 72 73 20 23 66 test-env-vars #f
4ff0: 20 72 75 6e 2d 69 64 29 20 3b 3b 20 74 68 65 73 run-id) ;; thes
5000: 65 20 6d 61 79 20 62 65 20 6e 65 65 64 65 64 20 e may be needed
5010: 62 79 20 74 68 65 20 6c 61 75 6e 63 68 69 6e 67 by the launching
5020: 20 70 72 6f 63 65 73 73 0a 09 09 09 20 20 28 6c process.... (l
5030: 65 74 20 28 28 69 74 65 6d 73 2d 6c 69 73 74 20 et ((items-list
5040: 28 69 74 65 6d 73 3a 67 65 74 2d 69 74 65 6d 73 (items:get-items
5050: 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 20 74 63 6f -from-config tco
5060: 6e 66 69 67 29 29 29 0a 09 09 09 20 20 20 20 28 nfig))).... (
5070: 69 66 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 2d if (list? items-
5080: 6c 69 73 74 29 0a 09 09 09 09 28 62 65 67 69 6e list).....(begin
5090: 0a 09 09 09 09 20 20 28 74 65 73 74 73 3a 74 65 ..... (tests:te
50a0: 73 74 71 75 65 75 65 2d 73 65 74 2d 69 74 65 6d stqueue-set-item
50b0: 73 21 20 74 65 73 74 2d 72 65 63 6f 72 64 20 69 s! test-record i
50c0: 74 65 6d 73 2d 6c 69 73 74 29 0a 09 09 09 09 20 tems-list).....
50d0: 20 28 6c 6f 6f 70 20 68 65 64 20 74 61 6c 29 29 (loop hed tal))
50e0: 0a 09 09 09 09 28 62 65 67 69 6e 0a 09 09 09 09 .....(begin.....
50f0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
5100: 20 22 45 52 52 4f 52 3a 20 54 68 65 20 70 72 6f "ERROR: The pro
5110: 63 20 66 72 6f 6d 20 72 65 61 64 69 6e 67 20 74 c from reading t
5120: 68 65 20 73 65 74 75 70 20 64 69 64 20 6e 6f 74 he setup did not
5130: 20 79 69 65 6c 64 20 61 20 6c 69 73 74 20 2d 20 yield a list -
5140: 70 6c 65 61 73 65 20 72 65 70 6f 72 74 20 74 68 please report th
5150: 69 73 22 29 0a 09 09 09 09 20 20 28 65 78 69 74 is")..... (exit
5160: 20 31 29 29 29 29 29 29 0a 09 09 20 20 20 20 20 1))))))...
5170: 20 20 28 28 6e 75 6c 6c 3f 20 66 61 69 6c 73 29 ((null? fails)
5180: 0a 09 09 09 28 6c 6f 6f 70 20 28 63 61 72 20 6e ....(loop (car n
5190: 65 77 74 61 6c 29 28 63 64 72 20 6e 65 77 74 61 ewtal)(cdr newta
51a0: 6c 29 29 29 20 3b 3b 20 61 6e 20 69 73 73 75 65 l))) ;; an issue
51b0: 20 77 69 74 68 20 70 72 65 72 65 71 73 20 6e 6f with prereqs no
51c0: 74 20 79 65 74 20 6d 65 74 3f 0a 09 09 20 20 20 t yet met?...
51d0: 20 20 20 20 28 28 61 6e 64 20 28 6e 6f 74 20 28 ((and (not (
51e0: 6e 75 6c 6c 3f 20 66 61 69 6c 73 29 29 28 65 71 null? fails))(eq
51f0: 3f 20 74 65 73 74 6d 6f 64 65 20 27 6e 6f 72 6d ? testmode 'norm
5200: 61 6c 29 29 0a 09 09 09 28 64 65 62 75 67 3a 70 al))....(debug:p
5210: 72 69 6e 74 20 31 20 22 49 4e 46 4f 3a 20 74 65 rint 1 "INFO: te
5220: 73 74 20 22 20 20 68 65 64 20 22 20 28 6d 6f 64 st " hed " (mod
5230: 65 3d 22 20 74 65 73 74 6d 6f 64 65 20 22 29 20 e=" testmode ")
5240: 68 61 73 20 66 61 69 6c 65 64 20 70 72 65 72 65 has failed prere
5250: 71 75 69 73 69 74 65 28 73 29 3b 20 22 0a 09 09 quisite(s); "...
5260: 09 09 20 20 20 20 20 28 73 74 72 69 6e 67 2d 69 .. (string-i
5270: 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 20 ntersperse (map
5280: 28 6c 61 6d 62 64 61 20 28 74 29 28 63 6f 6e 63 (lambda (t)(conc
5290: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 (db:test-get-te
52a0: 73 74 6e 61 6d 65 20 74 29 20 22 3a 22 20 28 64 stname t) ":" (d
52b0: 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 b:test-get-state
52c0: 20 74 29 22 2f 22 28 64 62 3a 74 65 73 74 2d 67 t)"/"(db:test-g
52d0: 65 74 2d 73 74 61 74 75 73 20 74 29 29 29 20 66 et-status t))) f
52e0: 61 69 6c 73 29 20 22 2c 20 22 29 0a 09 09 09 09 ails) ", ").....
52f0: 20 20 20 20 20 22 2c 20 72 65 6d 6f 76 69 6e 67 ", removing
5300: 20 69 74 20 66 72 6f 6d 20 74 6f 2d 64 6f 20 6c it from to-do l
5310: 69 73 74 22 29 0a 09 09 09 28 69 66 20 28 6e 6f ist")....(if (no
5320: 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 t (null? tal))..
5330: 09 09 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 .. (loop (car
5340: 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 29 29 tal)(cdr tal)))
5350: 29 0a 09 09 20 20 20 20 20 20 20 28 65 6c 73 65 )... (else
5360: 0a 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 ....(debug:print
5370: 20 38 20 22 45 52 52 4f 52 3a 20 4e 6f 20 68 61 8 "ERROR: No ha
5380: 6e 64 6c 65 72 20 66 6f 72 20 74 68 69 73 20 63 ndler for this c
5390: 6f 6e 64 69 74 69 6f 6e 2e 22 29 0a 09 09 09 3b ondition.")....;
53a0: 3b 20 09 20 20 20 20 20 22 5c 6e 20 20 68 65 64 ; . "\n hed
53b0: 3a 20 20 20 20 20 20 20 20 20 20 20 20 22 20 68 : " h
53c0: 65 64 20 0a 09 09 09 3b 3b 20 09 20 20 20 20 20 ed ....;; .
53d0: 22 5c 6e 20 66 61 69 6c 73 3a 20 20 20 20 20 20 "\n fails:
53e0: 20 20 20 20 20 22 20 28 73 74 72 69 6e 67 2d 69 " (string-i
53f0: 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 20 ntersperse (map
5400: 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 db:test-get-test
5410: 6e 61 6d 65 20 66 61 69 6c 73 29 20 22 2c 22 29 name fails) ",")
5420: 0a 09 09 09 3b 3b 20 09 20 20 20 20 20 22 5c 6e ....;; . "\n
5430: 20 74 65 73 74 6d 6f 64 65 3a 20 20 20 20 20 20 testmode:
5440: 20 20 22 20 74 65 73 74 6d 6f 64 65 0a 09 09 09 " testmode....
5450: 3b 3b 20 09 20 20 20 20 20 22 5c 6e 20 70 72 65 ;; . "\n pre
5460: 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 3a 20 22 20 reqs-not-met: "
5470: 28 70 72 65 74 74 79 2d 73 74 72 69 6e 67 20 70 (pretty-string p
5480: 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 0a rereqs-not-met).
5490: 09 09 09 3b 3b 20 09 20 20 20 20 20 22 5c 6e 20 ...;; . "\n
54a0: 69 74 65 6d 73 3a 20 20 20 20 20 20 20 20 20 20 items:
54b0: 20 22 20 69 74 65 6d 73 29 0a 09 09 09 28 6c 6f " items)....(lo
54c0: 6f 70 20 28 63 61 72 20 6e 65 77 74 61 6c 29 28 op (car newtal)(
54d0: 63 64 72 20 6e 65 77 74 61 6c 29 29 29 29 29 0a cdr newtal))))).
54e0: 09 09 20 20 20 20 3b 3b 20 69 66 20 63 61 6e 27 .. ;; if can'
54f0: 74 20 72 75 6e 20 6d 6f 72 65 20 6a 75 73 74 20 t run more just
5500: 6c 6f 6f 70 20 77 69 74 68 20 6e 65 78 74 20 70 loop with next p
5510: 6f 73 73 69 62 6c 65 20 74 65 73 74 0a 09 09 20 ossible test...
5520: 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 (loop (car ne
5530: 77 74 61 6c 29 28 63 64 72 20 6e 65 77 74 61 6c wtal)(cdr newtal
5540: 29 29 29 29 29 0a 09 20 20 20 20 20 0a 09 20 20 ))))).. ..
5550: 20 20 20 3b 3b 20 74 68 69 73 20 63 61 73 65 20 ;; this case
5560: 73 68 6f 75 6c 64 20 6e 6f 74 20 68 61 70 70 65 should not happe
5570: 6e 2c 20 61 64 64 65 64 20 74 6f 20 68 65 6c 70 n, added to help
5580: 20 63 61 74 63 68 20 61 6e 79 20 62 75 67 73 0a catch any bugs.
5590: 09 20 20 20 20 20 28 28 61 6e 64 20 28 6c 69 73 . ((and (lis
55a0: 74 3f 20 69 74 65 6d 73 29 20 69 74 65 6d 64 61 t? items) itemda
55b0: 74 29 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 t).. (debug
55c0: 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a :print 0 "ERROR:
55d0: 20 53 68 6f 75 6c 64 20 6e 6f 74 20 68 61 76 65 Should not have
55e0: 20 61 20 6c 69 73 74 20 6f 66 20 69 74 65 6d 73 a list of items
55f0: 20 69 6e 20 61 20 74 65 73 74 20 61 6e 64 20 74 in a test and t
5600: 68 65 20 69 74 65 6d 73 70 61 74 68 20 73 65 74 he itemspath set
5610: 20 2d 20 70 6c 65 61 73 65 20 72 65 70 6f 72 74 - please report
5620: 20 74 68 69 73 22 29 0a 09 20 20 20 20 20 20 28 this").. (
5630: 65 78 69 74 20 31 29 29 29 29 0a 09 20 20 0a 09 exit 1)))).. ..
5640: 20 20 3b 3b 20 77 65 20 67 65 74 20 68 65 72 65 ;; we get here
5650: 20 6f 6e 20 22 64 72 6f 70 20 74 68 72 6f 75 67 on "drop throug
5660: 68 22 20 2d 20 6c 6f 6f 70 20 66 6f 72 20 6e 65 h" - loop for ne
5670: 78 74 20 74 65 73 74 20 69 6e 20 71 75 65 75 65 xt test in queue
5680: 0a 09 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 .. (if (null? t
5690: 61 6c 29 0a 09 20 20 20 20 20 20 28 62 65 67 69 al).. (begi
56a0: 6e 0a 09 09 3b 3b 20 46 49 58 4d 45 21 21 21 21 n...;; FIXME!!!!
56b0: 20 54 48 49 53 20 53 48 4f 55 4c 44 20 4e 4f 54 THIS SHOULD NOT
56c0: 20 52 45 51 55 49 52 45 20 41 4e 20 45 58 49 54 REQUIRE AN EXIT
56d0: 21 21 21 21 21 21 21 0a 09 09 28 64 65 62 75 67 !!!!!!!...(debug
56e0: 3a 70 72 69 6e 74 20 31 20 22 49 4e 46 4f 3a 20 :print 1 "INFO:
56f0: 41 6c 6c 20 74 65 73 74 73 20 6c 61 75 6e 63 68 All tests launch
5700: 65 64 22 29 0a 09 09 28 74 68 72 65 61 64 2d 73 ed")...(thread-s
5710: 6c 65 65 70 21 20 30 2e 35 29 0a 09 09 3b 3b 20 leep! 0.5)...;;
5720: 46 49 58 4d 45 21 20 54 68 69 73 20 68 61 72 73 FIXME! This hars
5730: 68 20 65 78 69 74 20 73 68 6f 75 6c 64 20 6e 6f h exit should no
5740: 74 20 62 65 20 6e 65 63 65 73 73 61 72 79 2e 2e t be necessary..
5750: 2e 2e 0a 09 09 28 69 66 20 28 6e 6f 74 20 2a 72 .....(if (not *r
5760: 75 6e 72 65 6d 6f 74 65 2a 29 28 65 78 69 74 29 unremote*)(exit)
5770: 29 20 3b 3b 20 0a 09 09 23 66 29 20 3b 3b 20 72 ) ;; ...#f) ;; r
5780: 65 74 75 72 6e 20 61 20 23 66 20 61 73 20 61 20 eturn a #f as a
5790: 68 69 6e 74 20 74 68 61 74 20 77 65 20 61 72 65 hint that we are
57a0: 20 64 6f 6e 65 0a 09 20 20 20 20 20 20 3b 3b 20 done.. ;;
57b0: 48 65 72 65 20 77 65 20 6e 65 65 64 20 74 6f 20 Here we need to
57c0: 63 68 65 63 6b 20 74 68 61 74 20 61 6c 6c 20 74 check that all t
57d0: 68 65 20 74 65 73 74 73 20 72 65 6d 61 69 6e 69 he tests remaini
57e0: 6e 67 20 74 6f 20 62 65 20 72 75 6e 20 61 72 65 ng to be run are
57f0: 20 65 6c 69 67 69 62 6c 65 20 74 6f 20 72 75 6e eligible to run
5800: 0a 09 20 20 20 20 20 20 3b 3b 20 61 6e 64 20 61 .. ;; and a
5810: 72 65 20 6e 6f 74 20 62 6c 6f 63 6b 65 64 20 62 re not blocked b
5820: 79 20 66 61 69 6c 65 64 0a 09 20 20 20 20 20 20 y failed..
5830: 28 6c 65 74 20 28 28 6e 65 77 6c 73 74 20 28 6f (let ((newlst (o
5840: 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 74 65 pen-run-close te
5850: 73 74 73 3a 66 69 6c 74 65 72 2d 6e 6f 6e 2d 72 sts:filter-non-r
5860: 75 6e 6e 61 62 6c 65 20 23 66 20 72 75 6e 2d 69 unnable #f run-i
5870: 64 20 74 61 6c 20 74 65 73 74 2d 72 65 63 6f 72 d tal test-recor
5880: 64 73 29 29 29 20 3b 3b 20 69 2e 65 2e 20 6e 6f ds))) ;; i.e. no
5890: 74 20 46 41 49 4c 2c 20 57 41 49 56 45 44 2c 20 t FAIL, WAIVED,
58a0: 49 4e 43 4f 4d 50 4c 45 54 45 2c 20 50 41 53 53 INCOMPLETE, PASS
58b0: 2c 20 4b 49 4c 4c 45 44 2c 0a 09 09 28 74 68 72 , KILLED,...(thr
58c0: 65 61 64 2d 73 6c 65 65 70 21 20 2a 67 6c 6f 62 ead-sleep! *glob
58d0: 61 6c 2d 64 65 6c 74 61 2a 29 0a 09 09 28 69 66 al-delta*)...(if
58e0: 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 6e 65 77 (not (null? new
58f0: 6c 73 74 29 29 0a 09 09 20 20 20 20 28 6c 6f 6f lst))... (loo
5900: 70 20 28 63 61 72 20 6e 65 77 6c 73 74 29 28 63 p (car newlst)(c
5910: 64 72 20 6e 65 77 6c 73 74 29 29 29 29 29 29 29 dr newlst)))))))
5920: 29 29 0a 0a 3b 3b 20 70 61 72 65 6e 74 2d 74 65 ))..;; parent-te
5930: 73 74 20 69 73 20 74 68 65 72 65 20 61 73 20 61 st is there as a
5940: 20 70 6c 61 63 65 68 6f 6c 64 65 72 20 66 6f 72 placeholder for
5950: 20 77 68 65 6e 20 70 61 72 65 6e 74 2d 74 65 73 when parent-tes
5960: 74 73 20 63 61 6e 20 62 65 20 72 75 6e 20 61 73 ts can be run as
5970: 20 61 20 73 65 74 75 70 20 73 74 65 70 0a 28 64 a setup step.(d
5980: 65 66 69 6e 65 20 28 72 75 6e 3a 74 65 73 74 20 efine (run:test
5990: 72 75 6e 2d 69 64 20 72 75 6e 6e 61 6d 65 20 6b run-id runname k
59a0: 65 79 76 61 6c 6c 73 74 20 74 65 73 74 2d 72 65 eyvallst test-re
59b0: 63 6f 72 64 20 66 6c 61 67 73 20 70 61 72 65 6e cord flags paren
59c0: 74 2d 74 65 73 74 29 0a 20 20 3b 3b 20 41 6c 6c t-test). ;; All
59d0: 20 74 68 65 73 65 20 76 61 72 73 20 6d 69 67 68 these vars migh
59e0: 74 20 62 65 20 72 65 66 65 72 65 6e 63 65 64 20 t be referenced
59f0: 62 79 20 74 68 65 20 74 65 73 74 63 6f 6e 66 69 by the testconfi
5a00: 67 20 66 69 6c 65 20 72 65 61 64 65 72 0a 20 20 g file reader.
5a10: 28 6c 65 74 2a 20 28 28 74 65 73 74 2d 6e 61 6d (let* ((test-nam
5a20: 65 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 e (tests:test
5a30: 71 75 65 75 65 2d 67 65 74 2d 74 65 73 74 6e 61 queue-get-testna
5a40: 6d 65 20 20 20 74 65 73 74 2d 72 65 63 6f 72 64 me test-record
5a50: 29 29 0a 09 20 28 74 65 73 74 2d 77 61 69 74 6f )).. (test-waito
5a60: 6e 73 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 ns (tests:testqu
5a70: 65 75 65 2d 67 65 74 2d 77 61 69 74 6f 6e 73 20 eue-get-waitons
5a80: 20 20 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 test-record))
5a90: 0a 09 20 28 74 65 73 74 2d 63 6f 6e 66 20 20 20 .. (test-conf
5aa0: 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 (tests:testqueu
5ab0: 65 2d 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 e-get-testconfig
5ac0: 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 test-record))..
5ad0: 20 28 69 74 65 6d 64 61 74 20 20 20 20 20 20 28 (itemdat (
5ae0: 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d tests:testqueue-
5af0: 67 65 74 2d 69 74 65 6d 64 61 74 20 20 20 20 74 get-itemdat t
5b00: 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 28 est-record)).. (
5b10: 74 65 73 74 2d 70 61 74 68 20 20 20 20 28 63 6f test-path (co
5b20: 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 74 nc *toppath* "/t
5b30: 65 73 74 73 2f 22 20 74 65 73 74 2d 6e 61 6d 65 ests/" test-name
5b40: 29 29 20 3b 3b 20 63 6f 75 6c 64 20 75 73 65 20 )) ;; could use
5b50: 74 65 73 74 73 3a 67 65 74 2d 74 65 73 74 63 6f tests:get-testco
5b60: 6e 66 69 67 20 68 65 72 65 20 2e 2e 2e 0a 09 20 nfig here .....
5b70: 28 66 6f 72 63 65 20 20 20 20 20 20 20 20 28 68 (force (h
5b80: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
5b90: 66 61 75 6c 74 20 66 6c 61 67 73 20 22 2d 66 6f fault flags "-fo
5ba0: 72 63 65 22 20 23 66 29 29 0a 09 20 28 72 65 72 rce" #f)).. (rer
5bb0: 75 6e 20 20 20 20 20 20 20 20 28 68 61 73 68 2d un (hash-
5bc0: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
5bd0: 74 20 66 6c 61 67 73 20 22 2d 72 65 72 75 6e 22 t flags "-rerun"
5be0: 20 23 66 29 29 0a 09 20 28 6b 65 65 70 67 6f 69 #f)).. (keepgoi
5bf0: 6e 67 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c ng (hash-tabl
5c00: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 66 6c e-ref/default fl
5c10: 61 67 73 20 22 2d 6b 65 65 70 67 6f 69 6e 67 22 ags "-keepgoing"
5c20: 20 23 66 29 29 0a 09 20 28 69 74 65 6d 2d 70 61 #f)).. (item-pa
5c30: 74 68 20 20 20 20 20 22 22 29 0a 09 20 28 64 62 th "").. (db
5c40: 20 20 20 20 20 20 20 20 20 20 20 23 66 29 29 0a #f)).
5c50: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
5c60: 20 35 0a 09 09 20 22 74 65 73 74 2d 63 6f 6e 66 5... "test-conf
5c70: 69 67 3a 20 22 20 28 68 61 73 68 2d 74 61 62 6c ig: " (hash-tabl
5c80: 65 2d 3e 61 6c 69 73 74 20 74 65 73 74 2d 63 6f e->alist test-co
5c90: 6e 66 29 0a 09 09 20 22 5c 6e 20 20 20 69 74 65 nf)... "\n ite
5ca0: 6d 64 61 74 3a 20 22 20 69 74 65 6d 64 61 74 0a mdat: " itemdat.
5cb0: 09 09 20 29 0a 20 20 20 20 3b 3b 20 73 65 74 74 .. ). ;; sett
5cc0: 69 6e 67 20 69 74 65 6d 64 61 74 20 74 6f 20 61 ing itemdat to a
5cd0: 20 6c 69 73 74 20 69 66 20 69 74 20 69 73 20 23 list if it is #
5ce0: 66 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 69 f. (if (not i
5cf0: 74 65 6d 64 61 74 29 28 73 65 74 21 20 69 74 65 temdat)(set! ite
5d00: 6d 64 61 74 20 27 28 29 29 29 0a 20 20 20 20 28 mdat '())). (
5d10: 73 65 74 21 20 69 74 65 6d 2d 70 61 74 68 20 28 set! item-path (
5d20: 69 74 65 6d 2d 6c 69 73 74 2d 3e 70 61 74 68 20 item-list->path
5d30: 69 74 65 6d 64 61 74 29 29 0a 20 20 20 20 28 64 itemdat)). (d
5d40: 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 41 74 ebug:print 2 "At
5d50: 74 65 6d 70 74 69 6e 67 20 74 6f 20 6c 61 75 6e tempting to laun
5d60: 63 68 20 74 65 73 74 20 22 20 74 65 73 74 2d 6e ch test " test-n
5d70: 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 ame "/" item-pat
5d80: 68 29 0a 20 20 20 20 28 73 65 74 65 6e 76 20 22 h). (setenv "
5d90: 4d 54 5f 54 45 53 54 5f 4e 41 4d 45 22 20 74 65 MT_TEST_NAME" te
5da0: 73 74 2d 6e 61 6d 65 29 20 3b 3b 20 0a 20 20 20 st-name) ;; .
5db0: 20 28 73 65 74 65 6e 76 20 22 4d 54 5f 52 55 4e (setenv "MT_RUN
5dc0: 4e 41 4d 45 22 20 20 20 72 75 6e 6e 61 6d 65 29 NAME" runname)
5dd0: 0a 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 . (open-run-c
5de0: 6c 6f 73 65 2d 6d 65 61 73 75 72 65 20 73 65 74 lose-measure set
5df0: 2d 6d 65 67 61 74 65 73 74 2d 65 6e 76 2d 76 61 -megatest-env-va
5e00: 72 73 20 64 62 20 72 75 6e 2d 69 64 29 20 3b 3b rs db run-id) ;;
5e10: 20 74 68 65 73 65 20 6d 61 79 20 62 65 20 6e 65 these may be ne
5e20: 65 64 65 64 20 62 79 20 74 68 65 20 6c 61 75 6e eded by the laun
5e30: 63 68 69 6e 67 20 70 72 6f 63 65 73 73 0a 20 20 ching process.
5e40: 20 20 28 63 68 61 6e 67 65 2d 64 69 72 65 63 74 (change-direct
5e50: 6f 72 79 20 2a 74 6f 70 70 61 74 68 2a 29 0a 0a ory *toppath*)..
5e60: 20 20 20 20 3b 3b 20 48 65 72 65 20 69 73 20 77 ;; Here is w
5e70: 68 65 72 65 20 74 68 65 20 74 65 73 74 5f 6d 65 here the test_me
5e80: 74 61 20 74 61 62 6c 65 20 69 73 20 62 65 73 74 ta table is best
5e90: 20 75 70 64 61 74 65 64 0a 20 20 20 20 3b 3b 20 updated. ;;
5ea0: 59 65 73 2c 20 61 6e 6f 74 68 65 72 20 75 73 65 Yes, another use
5eb0: 20 6f 66 20 61 20 67 6c 6f 62 61 6c 20 66 6f 72 of a global for
5ec0: 20 63 61 63 68 69 6e 67 2e 20 4e 65 65 64 20 61 caching. Need a
5ed0: 20 62 65 74 74 65 72 20 77 61 79 3f 0a 20 20 20 better way?.
5ee0: 20 28 69 66 20 28 6e 6f 74 20 28 68 61 73 68 2d (if (not (hash-
5ef0: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
5f00: 74 20 2a 74 65 73 74 2d 6d 65 74 61 2d 75 70 64 t *test-meta-upd
5f10: 61 74 65 64 2a 20 74 65 73 74 2d 6e 61 6d 65 20 ated* test-name
5f20: 23 66 29 29 0a 20 20 20 20 20 20 20 20 28 62 65 #f)). (be
5f30: 67 69 6e 0a 09 20 20 20 28 68 61 73 68 2d 74 61 gin.. (hash-ta
5f40: 62 6c 65 2d 73 65 74 21 20 2a 74 65 73 74 2d 6d ble-set! *test-m
5f50: 65 74 61 2d 75 70 64 61 74 65 64 2a 20 74 65 73 eta-updated* tes
5f60: 74 2d 6e 61 6d 65 20 23 74 29 0a 20 20 20 20 20 t-name #t).
5f70: 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d (open-run-
5f80: 63 6c 6f 73 65 20 72 75 6e 73 3a 75 70 64 61 74 close runs:updat
5f90: 65 2d 74 65 73 74 5f 6d 65 74 61 20 64 62 20 74 e-test_meta db t
5fa0: 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 63 6f est-name test-co
5fb0: 6e 66 29 29 29 0a 20 20 20 20 0a 20 20 20 20 3b nf))). . ;
5fc0: 3b 20 28 6c 61 6d 62 64 61 20 28 69 74 65 6d 64 ; (lambda (itemd
5fd0: 61 74 29 20 3b 3b 3b 20 28 28 72 69 70 65 6e 65 at) ;;; ((ripene
5fe0: 73 73 20 22 6f 76 65 72 72 69 70 65 22 29 20 28 ss "overripe") (
5ff0: 74 65 6d 70 65 72 61 74 75 72 65 20 22 63 6f 6f temperature "coo
6000: 6c 22 29 20 28 73 65 61 73 6f 6e 20 22 73 75 6d l") (season "sum
6010: 6d 65 72 22 29 29 0a 20 20 20 20 28 6c 65 74 2a mer")). (let*
6020: 20 28 28 6e 65 77 2d 74 65 73 74 2d 70 61 74 68 ((new-test-path
6030: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
6040: 65 72 73 65 20 28 63 6f 6e 73 20 74 65 73 74 2d erse (cons test-
6050: 70 61 74 68 20 28 6d 61 70 20 63 61 64 72 20 69 path (map cadr i
6060: 74 65 6d 64 61 74 29 29 20 22 2f 22 29 29 0a 09 temdat)) "/"))..
6070: 20 20 20 28 6e 65 77 2d 74 65 73 74 2d 6e 61 6d (new-test-nam
6080: 65 20 28 69 66 20 28 65 71 75 61 6c 3f 20 69 74 e (if (equal? it
6090: 65 6d 2d 70 61 74 68 20 22 22 29 20 74 65 73 74 em-path "") test
60a0: 2d 6e 61 6d 65 20 28 63 6f 6e 63 20 74 65 73 74 -name (conc test
60b0: 2d 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 -name "/" item-p
60c0: 61 74 68 29 29 29 20 3b 3b 20 6a 75 73 74 20 6e ath))) ;; just n
60d0: 65 65 64 20 69 74 20 74 6f 20 62 65 20 75 6e 69 eed it to be uni
60e0: 71 75 65 0a 09 20 20 20 28 74 65 73 74 2d 69 64 que.. (test-id
60f0: 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e (open-run
6100: 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d 74 65 -close db:get-te
6110: 73 74 2d 69 64 20 64 62 20 20 72 75 6e 2d 69 64 st-id db run-id
6120: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item-
6130: 70 61 74 68 29 29 0a 09 20 20 20 28 74 65 73 74 path)).. (test
6140: 64 61 74 20 20 20 20 20 20 20 28 6f 70 65 6e 2d dat (open-
6150: 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 run-close db:get
6160: 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 -test-info-by-id
6170: 20 64 62 20 74 65 73 74 2d 69 64 29 29 29 0a 20 db test-id))).
6180: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 74 65 (if (not te
6190: 73 74 64 61 74 29 0a 09 20 20 28 62 65 67 69 6e stdat).. (begin
61a0: 0a 09 20 20 20 20 3b 3b 20 65 6e 73 75 72 65 20 .. ;; ensure
61b0: 74 68 61 74 20 74 68 65 20 70 61 74 68 20 65 78 that the path ex
61c0: 69 73 74 73 20 62 65 66 6f 72 65 20 72 65 67 69 ists before regi
61d0: 73 74 65 72 69 6e 67 20 74 68 65 20 74 65 73 74 stering the test
61e0: 0a 09 20 20 20 20 3b 3b 20 4e 4f 50 45 3a 20 43 .. ;; NOPE: C
61f0: 61 6e 6e 6f 74 21 20 44 6f 6e 27 74 20 6b 6e 6f annot! Don't kno
6200: 77 20 79 65 74 20 77 68 69 63 68 20 64 69 73 6b w yet which disk
6210: 20 61 72 65 61 20 77 69 6c 6c 20 62 65 20 61 73 area will be as
6220: 73 69 67 6e 65 64 2e 2e 2e 2e 0a 09 20 20 20 20 signed......
6230: 3b 3b 20 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 ;; (system (conc
6240: 20 22 6d 6b 64 69 72 20 2d 70 20 22 20 6e 65 77 "mkdir -p " new
6250: 2d 74 65 73 74 2d 70 61 74 68 29 29 0a 09 20 20 -test-path))..
6260: 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 (open-run-clos
6270: 65 20 74 65 73 74 73 3a 72 65 67 69 73 74 65 72 e tests:register
6280: 2d 74 65 73 74 20 64 62 20 72 75 6e 2d 69 64 20 -test db run-id
6290: 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 test-name item-p
62a0: 61 74 68 29 0a 09 20 20 20 20 28 73 65 74 21 20 ath).. (set!
62b0: 74 65 73 74 2d 69 64 20 28 6f 70 65 6e 2d 72 75 test-id (open-ru
62c0: 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d 74 n-close db:get-t
62d0: 65 73 74 2d 69 64 20 64 62 20 72 75 6e 2d 69 64 est-id db run-id
62e0: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item-
62f0: 70 61 74 68 29 29 0a 09 20 20 20 20 28 73 65 74 path)).. (set
6300: 21 20 74 65 73 74 64 61 74 20 28 6f 70 65 6e 2d ! testdat (open-
6310: 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 run-close db:get
6320: 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 -test-info-by-id
6330: 20 64 62 20 74 65 73 74 2d 69 64 29 29 29 29 0a db test-id)))).
6340: 20 20 20 20 20 20 28 73 65 74 21 20 74 65 73 74 (set! test
6350: 2d 69 64 20 28 64 62 3a 74 65 73 74 2d 67 65 74 -id (db:test-get
6360: 2d 69 64 20 74 65 73 74 64 61 74 29 29 0a 20 20 -id testdat)).
6370: 20 20 20 20 28 63 68 61 6e 67 65 2d 64 69 72 65 (change-dire
6380: 63 74 6f 72 79 20 74 65 73 74 2d 70 61 74 68 29 ctory test-path)
6390: 0a 20 20 20 20 20 20 28 63 61 73 65 20 28 69 66 . (case (if
63a0: 20 66 6f 72 63 65 20 3b 3b 20 28 61 72 67 73 3a force ;; (args:
63b0: 67 65 74 2d 61 72 67 20 22 2d 66 6f 72 63 65 22 get-arg "-force"
63c0: 29 0a 09 09 27 4e 4f 54 5f 53 54 41 52 54 45 44 )...'NOT_STARTED
63d0: 0a 09 09 28 69 66 20 74 65 73 74 64 61 74 0a 09 ...(if testdat..
63e0: 09 20 20 20 20 28 73 74 72 69 6e 67 2d 3e 73 79 . (string->sy
63f0: 6d 62 6f 6c 20 28 74 65 73 74 3a 67 65 74 2d 73 mbol (test:get-s
6400: 74 61 74 65 20 74 65 73 74 64 61 74 29 29 0a 09 tate testdat))..
6410: 09 20 20 20 20 27 66 61 69 6c 65 64 2d 74 6f 2d . 'failed-to-
6420: 69 6e 73 65 72 74 29 29 0a 09 28 28 66 61 69 6c insert))..((fail
6430: 65 64 2d 74 6f 2d 69 6e 73 65 72 74 29 0a 09 20 ed-to-insert)..
6440: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
6450: 45 52 52 4f 52 3a 20 46 61 69 6c 65 64 20 74 6f ERROR: Failed to
6460: 20 69 6e 73 65 72 74 20 74 68 65 20 72 65 63 6f insert the reco
6470: 72 64 20 69 6e 74 6f 20 74 68 65 20 64 62 22 29 rd into the db")
6480: 29 0a 09 28 28 4e 4f 54 5f 53 54 41 52 54 45 44 )..((NOT_STARTED
6490: 20 43 4f 4d 50 4c 45 54 45 44 29 0a 09 20 28 6c COMPLETED).. (l
64a0: 65 74 20 28 28 72 75 6e 66 6c 61 67 20 23 66 29 et ((runflag #f)
64b0: 29 0a 09 20 20 20 28 63 6f 6e 64 0a 09 20 20 20 ).. (cond..
64c0: 20 3b 3b 20 2d 66 6f 72 63 65 2c 20 72 75 6e 20 ;; -force, run
64d0: 6e 6f 20 6d 61 74 74 65 72 20 77 68 61 74 0a 09 no matter what..
64e0: 20 20 20 20 28 66 6f 72 63 65 20 28 73 65 74 21 (force (set!
64f0: 20 72 75 6e 66 6c 61 67 20 23 74 29 29 0a 09 20 runflag #t))..
6500: 20 20 20 3b 3b 20 4e 4f 54 5f 53 54 41 52 54 45 ;; NOT_STARTE
6510: 44 2c 20 72 75 6e 20 6e 6f 20 6d 61 74 74 65 72 D, run no matter
6520: 20 77 68 61 74 0a 09 20 20 20 20 28 28 65 71 75 what.. ((equ
6530: 61 6c 3f 20 28 74 65 73 74 3a 67 65 74 2d 73 74 al? (test:get-st
6540: 61 74 65 20 74 65 73 74 64 61 74 29 20 22 4e 4f ate testdat) "NO
6550: 54 5f 53 54 41 52 54 45 44 22 29 28 73 65 74 21 T_STARTED")(set!
6560: 20 72 75 6e 66 6c 61 67 20 23 74 29 29 0a 09 20 runflag #t))..
6570: 20 20 20 3b 3b 20 6e 6f 74 20 2d 72 65 72 75 6e ;; not -rerun
6580: 20 61 6e 64 20 50 41 53 53 2c 20 57 41 52 4e 20 and PASS, WARN
6590: 6f 72 20 43 48 45 43 4b 2c 20 64 6f 20 6e 6f 20 or CHECK, do no
65a0: 72 75 6e 0a 09 20 20 20 20 28 28 61 6e 64 20 28 run.. ((and (
65b0: 6f 72 20 28 6e 6f 74 20 72 65 72 75 6e 29 0a 09 or (not rerun)..
65c0: 09 20 20 20 20 20 20 6b 65 65 70 67 6f 69 6e 67 . keepgoing
65d0: 29 0a 09 09 20 20 3b 3b 20 52 65 71 75 69 72 65 )... ;; Require
65e0: 20 74 6f 20 66 6f 72 63 65 20 72 65 2d 72 75 6e to force re-run
65f0: 20 66 6f 72 20 43 4f 4d 50 4c 45 54 45 44 20 6f for COMPLETED o
6600: 72 20 2a 61 6e 79 74 68 69 6e 67 2a 20 2b 20 50 r *anything* + P
6610: 41 53 53 2c 57 41 52 4e 20 6f 72 20 43 48 45 43 ASS,WARN or CHEC
6620: 4b 0a 09 09 20 20 28 6f 72 20 28 6d 65 6d 62 65 K... (or (membe
6630: 72 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 r (test:get-stat
6640: 75 73 20 74 65 73 74 64 61 74 29 20 27 28 22 50 us testdat) '("P
6650: 41 53 53 22 20 22 57 41 52 4e 22 20 22 43 48 45 ASS" "WARN" "CHE
6660: 43 4b 22 29 29 0a 09 09 20 20 20 20 20 20 28 6d CK"))... (m
6670: 65 6d 62 65 72 20 28 74 65 73 74 3a 67 65 74 2d ember (test:get-
6680: 73 74 61 74 65 20 20 74 65 73 74 64 61 74 29 20 state testdat)
6690: 27 28 22 43 4f 4d 50 4c 45 54 45 44 22 29 29 29 '("COMPLETED")))
66a0: 29 20 0a 09 20 20 20 20 20 28 64 65 62 75 67 3a ) .. (debug:
66b0: 70 72 69 6e 74 20 32 20 22 49 4e 46 4f 3a 20 72 print 2 "INFO: r
66c0: 75 6e 6e 69 6e 67 20 74 65 73 74 20 22 20 74 65 unning test " te
66d0: 73 74 2d 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d st-name "/" item
66e0: 2d 70 61 74 68 20 22 20 73 75 70 70 72 65 73 73 -path " suppress
66f0: 65 64 20 61 73 20 69 74 20 69 73 20 22 20 28 74 ed as it is " (t
6700: 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 est:get-state te
6710: 73 74 64 61 74 29 20 22 20 61 6e 64 20 22 20 28 stdat) " and " (
6720: 74 65 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 test:get-status
6730: 74 65 73 74 64 61 74 29 29 0a 09 20 20 20 20 20 testdat))..
6740: 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 66 (set! runflag #f
6750: 29 29 0a 09 20 20 20 20 3b 3b 20 2d 72 65 72 75 )).. ;; -reru
6760: 6e 20 61 6e 64 20 73 74 61 74 75 73 20 69 73 20 n and status is
6770: 6f 6e 65 20 6f 66 20 74 68 65 20 73 70 65 63 69 one of the speci
6780: 66 65 64 2c 20 72 75 6e 20 69 74 0a 09 20 20 20 fed, run it..
6790: 20 28 28 61 6e 64 20 72 65 72 75 6e 0a 09 09 20 ((and rerun...
67a0: 20 28 6c 65 74 2a 20 28 28 72 65 72 75 6e 6c 73 (let* ((rerunls
67b0: 74 20 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 t (string-spli
67c0: 74 20 72 65 72 75 6e 20 22 2c 22 29 29 0a 09 09 t rerun ","))...
67d0: 09 20 28 6d 75 73 74 2d 72 65 72 75 6e 20 28 6d . (must-rerun (m
67e0: 65 6d 62 65 72 20 28 74 65 73 74 3a 67 65 74 2d ember (test:get-
67f0: 73 74 61 74 75 73 20 74 65 73 74 64 61 74 29 20 status testdat)
6800: 72 65 72 75 6e 6c 73 74 29 29 29 0a 09 09 20 20 rerunlst)))...
6810: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 33 (debug:print 3
6820: 20 22 49 4e 46 4f 3a 20 2d 72 65 72 75 6e 20 6c "INFO: -rerun l
6830: 69 73 74 3a 20 22 20 72 65 72 75 6e 20 22 2c 20 ist: " rerun ",
6840: 74 65 73 74 2d 73 74 61 74 75 73 3a 20 22 20 28 test-status: " (
6850: 74 65 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 test:get-status
6860: 74 65 73 74 64 61 74 29 22 2c 20 6d 75 73 74 2d testdat)", must-
6870: 72 65 72 75 6e 3a 20 22 20 6d 75 73 74 2d 72 65 rerun: " must-re
6880: 72 75 6e 29 0a 09 09 20 20 20 20 6d 75 73 74 2d run)... must-
6890: 72 65 72 75 6e 29 29 0a 09 20 20 20 20 20 28 64 rerun)).. (d
68a0: 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 49 4e ebug:print 2 "IN
68b0: 46 4f 3a 20 52 65 72 75 6e 20 66 6f 72 63 65 64 FO: Rerun forced
68c0: 20 66 6f 72 20 74 65 73 74 20 22 20 74 65 73 74 for test " test
68d0: 2d 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 -name "/" item-p
68e0: 61 74 68 29 0a 09 20 20 20 20 20 28 73 65 74 21 ath).. (set!
68f0: 20 72 75 6e 66 6c 61 67 20 23 74 29 29 0a 09 20 runflag #t))..
6900: 20 20 20 3b 3b 20 2d 6b 65 65 70 67 6f 69 6e 67 ;; -keepgoing
6910: 2c 20 64 6f 20 6e 6f 74 20 72 65 72 75 6e 20 46 , do not rerun F
6920: 41 49 4c 0a 09 20 20 20 20 28 28 61 6e 64 20 6b AIL.. ((and k
6930: 65 65 70 67 6f 69 6e 67 0a 09 09 20 20 28 6d 65 eepgoing... (me
6940: 6d 62 65 72 20 28 74 65 73 74 3a 67 65 74 2d 73 mber (test:get-s
6950: 74 61 74 75 73 20 74 65 73 74 64 61 74 29 20 27 tatus testdat) '
6960: 28 22 46 41 49 4c 22 29 29 29 0a 09 20 20 20 20 ("FAIL")))..
6970: 20 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 (set! runflag #
6980: 66 29 29 0a 09 20 20 20 20 28 28 61 6e 64 20 28 f)).. ((and (
6990: 6e 6f 74 20 72 65 72 75 6e 29 0a 09 09 20 20 28 not rerun)... (
69a0: 6d 65 6d 62 65 72 20 28 74 65 73 74 3a 67 65 74 member (test:get
69b0: 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 74 29 -status testdat)
69c0: 20 27 28 22 46 41 49 4c 22 20 22 6e 2f 61 22 29 '("FAIL" "n/a")
69d0: 29 29 0a 09 20 20 20 20 20 28 73 65 74 21 20 72 )).. (set! r
69e0: 75 6e 66 6c 61 67 20 23 74 29 29 0a 09 20 20 20 unflag #t))..
69f0: 20 28 65 6c 73 65 20 28 73 65 74 21 20 72 75 6e (else (set! run
6a00: 66 6c 61 67 20 23 66 29 29 29 0a 09 20 20 20 28 flag #f))).. (
6a10: 64 65 62 75 67 3a 70 72 69 6e 74 20 36 20 22 52 debug:print 6 "R
6a20: 55 4e 4e 49 4e 47 20 3d 3e 20 72 75 6e 66 6c 61 UNNING => runfla
6a30: 67 3a 20 22 20 72 75 6e 66 6c 61 67 20 22 20 53 g: " runflag " S
6a40: 54 41 54 45 3a 20 22 20 28 74 65 73 74 3a 67 65 TATE: " (test:ge
6a50: 74 2d 73 74 61 74 65 20 74 65 73 74 64 61 74 29 t-state testdat)
6a60: 20 22 20 53 54 41 54 55 53 3a 20 22 20 28 74 65 " STATUS: " (te
6a70: 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 st:get-status te
6a80: 73 74 64 61 74 29 29 0a 09 20 20 20 28 69 66 20 stdat)).. (if
6a90: 28 6e 6f 74 20 72 75 6e 66 6c 61 67 29 0a 09 20 (not runflag)..
6aa0: 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 70 (if (not p
6ab0: 61 72 65 6e 74 2d 74 65 73 74 29 0a 09 09 20 20 arent-test)...
6ac0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 (debug:print 1
6ad0: 22 4e 4f 54 45 3a 20 4e 6f 74 20 73 74 61 72 74 "NOTE: Not start
6ae0: 69 6e 67 20 74 65 73 74 20 22 20 6e 65 77 2d 74 ing test " new-t
6af0: 65 73 74 2d 6e 61 6d 65 20 22 20 61 73 20 69 74 est-name " as it
6b00: 20 69 73 20 73 74 61 74 65 20 5c 22 22 20 28 74 is state \"" (t
6b10: 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 est:get-state te
6b20: 73 74 64 61 74 29 20 0a 09 09 09 09 22 5c 22 20 stdat) ....."\"
6b30: 61 6e 64 20 73 74 61 74 75 73 20 5c 22 22 20 28 and status \"" (
6b40: 74 65 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 test:get-status
6b50: 74 65 73 74 64 61 74 29 20 22 5c 22 2c 20 75 73 testdat) "\", us
6b60: 65 20 2d 72 65 72 75 6e 20 5c 22 22 20 28 74 65 e -rerun \"" (te
6b70: 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 st:get-status te
6b80: 73 74 64 61 74 29 0a 20 20 20 20 20 20 20 20 20 stdat).
6b90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6ba0: 20 20 20 20 20 20 20 22 5c 22 20 6f 72 20 2d 66 "\" or -f
6bb0: 6f 72 63 65 20 74 6f 20 6f 76 65 72 72 69 64 65 orce to override
6bc0: 22 29 29 0a 09 20 20 20 20 20 20 20 3b 3b 20 4e ")).. ;; N
6bd0: 4f 54 45 3a 20 4e 6f 20 6c 6f 6e 67 65 72 20 62 OTE: No longer b
6be0: 65 20 63 68 65 63 6b 69 6e 67 20 70 72 65 72 65 e checking prere
6bf0: 71 75 69 73 69 74 65 73 20 68 65 72 65 21 20 57 quisites here! W
6c00: 69 6c 6c 20 6e 65 76 65 72 20 67 65 74 20 68 65 ill never get he
6c10: 72 65 20 75 6e 6c 65 73 73 20 70 72 65 72 65 71 re unless prereq
6c20: 73 20 61 72 65 0a 09 20 20 20 20 20 20 20 3b 3b s are.. ;;
6c30: 20 20 20 20 20 20 20 61 6c 72 65 61 64 79 20 6d already m
6c40: 65 74 2e 0a 09 20 20 20 20 20 20 20 28 69 66 20 et... (if
6c50: 28 6e 6f 74 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 (not (open-run-c
6c60: 6c 6f 73 65 20 6c 61 75 6e 63 68 2d 74 65 73 74 lose launch-test
6c70: 20 64 62 20 72 75 6e 2d 69 64 20 72 75 6e 6e 61 db run-id runna
6c80: 6d 65 20 74 65 73 74 2d 63 6f 6e 66 20 6b 65 79 me test-conf key
6c90: 76 61 6c 6c 73 74 20 74 65 73 74 2d 6e 61 6d 65 vallst test-name
6ca0: 20 74 65 73 74 2d 70 61 74 68 20 69 74 65 6d 64 test-path itemd
6cb0: 61 74 20 66 6c 61 67 73 29 29 0a 09 09 20 20 20 at flags))...
6cc0: 28 62 65 67 69 6e 0a 09 09 20 20 20 20 20 28 70 (begin... (p
6cd0: 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 46 61 69 rint "ERROR: Fai
6ce0: 6c 65 64 20 74 6f 20 6c 61 75 6e 63 68 20 74 68 led to launch th
6cf0: 65 20 74 65 73 74 2e 20 45 78 69 74 69 6e 67 20 e test. Exiting
6d00: 61 73 20 73 6f 6f 6e 20 61 73 20 70 6f 73 73 69 as soon as possi
6d10: 62 6c 65 22 29 0a 09 09 20 20 20 20 20 28 73 65 ble")... (se
6d20: 74 21 20 2a 67 6c 6f 62 61 6c 65 78 69 74 73 74 t! *globalexitst
6d30: 61 74 75 73 2a 20 31 29 20 3b 3b 20 0a 09 09 20 atus* 1) ;; ...
6d40: 20 20 20 20 28 70 72 6f 63 65 73 73 2d 73 69 67 (process-sig
6d50: 6e 61 6c 20 28 63 75 72 72 65 6e 74 2d 70 72 6f nal (current-pro
6d60: 63 65 73 73 2d 69 64 29 20 73 69 67 6e 61 6c 2f cess-id) signal/
6d70: 6b 69 6c 6c 29 29 29 29 29 29 0a 09 28 28 4b 49 kill))))))..((KI
6d80: 4c 4c 45 44 29 20 0a 09 20 28 64 65 62 75 67 3a LLED) .. (debug:
6d90: 70 72 69 6e 74 20 31 20 22 4e 4f 54 45 3a 20 22 print 1 "NOTE: "
6da0: 20 6e 65 77 2d 74 65 73 74 2d 6e 61 6d 65 20 22 new-test-name "
6db0: 20 69 73 20 61 6c 72 65 61 64 79 20 72 75 6e 6e is already runn
6dc0: 69 6e 67 20 6f 72 20 77 61 73 20 65 78 70 6c 69 ing or was expli
6dd0: 63 74 6c 79 20 6b 69 6c 6c 65 64 2c 20 75 73 65 ctly killed, use
6de0: 20 2d 66 6f 72 63 65 20 74 6f 20 6c 61 75 6e 63 -force to launc
6df0: 68 20 69 74 2e 22 29 29 0a 09 28 28 4c 41 55 4e h it."))..((LAUN
6e00: 43 48 45 44 20 52 45 4d 4f 54 45 48 4f 53 54 53 CHED REMOTEHOSTS
6e10: 54 41 52 54 20 52 55 4e 4e 49 4e 47 29 20 20 0a TART RUNNING) .
6e20: 09 20 28 69 66 20 28 3e 20 28 2d 20 28 63 75 72 . (if (> (- (cur
6e30: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 28 2b 20 rent-seconds)(+
6e40: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 65 76 65 (db:test-get-eve
6e50: 6e 74 5f 74 69 6d 65 20 74 65 73 74 64 61 74 29 nt_time testdat)
6e60: 0a 09 09 09 09 20 20 20 20 20 20 20 28 64 62 3a ..... (db:
6e70: 74 65 73 74 2d 67 65 74 2d 72 75 6e 5f 64 75 72 test-get-run_dur
6e80: 61 74 69 6f 6e 20 74 65 73 74 64 61 74 29 29 29 ation testdat)))
6e90: 0a 09 09 36 30 30 29 20 3b 3b 20 69 2e 65 2e 20 ...600) ;; i.e.
6ea0: 6e 6f 20 75 70 64 61 74 65 20 66 6f 72 20 6d 6f no update for mo
6eb0: 72 65 20 74 68 61 6e 20 36 30 30 20 73 65 63 6f re than 600 seco
6ec0: 6e 64 73 0a 09 20 20 20 20 20 28 62 65 67 69 6e nds.. (begin
6ed0: 0a 09 20 20 20 20 20 20 20 28 64 65 62 75 67 3a .. (debug:
6ee0: 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 print 0 "WARNING
6ef0: 3a 20 54 65 73 74 20 22 20 74 65 73 74 2d 6e 61 : Test " test-na
6f00: 6d 65 20 22 20 61 70 70 65 61 72 73 20 74 6f 20 me " appears to
6f10: 62 65 20 64 65 61 64 2e 20 46 6f 72 63 69 6e 67 be dead. Forcing
6f20: 20 69 74 20 74 6f 20 73 74 61 74 65 20 49 4e 43 it to state INC
6f30: 4f 4d 50 4c 45 54 45 20 61 6e 64 20 73 74 61 74 OMPLETE and stat
6f40: 75 73 20 53 54 55 43 4b 2f 44 45 41 44 22 29 0a us STUCK/DEAD").
6f50: 09 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 . (open-ru
6f60: 6e 2d 63 6c 6f 73 65 20 74 65 73 74 2d 73 65 74 n-close test-set
6f70: 2d 73 74 61 74 75 73 21 20 64 62 20 74 65 73 74 -status! db test
6f80: 2d 69 64 20 22 49 4e 43 4f 4d 50 4c 45 54 45 22 -id "INCOMPLETE"
6f90: 20 22 53 54 55 43 4b 2f 44 45 41 44 22 20 22 54 "STUCK/DEAD" "T
6fa0: 65 73 74 20 69 73 20 73 74 75 63 6b 20 6f 72 20 est is stuck or
6fb0: 64 65 61 64 22 20 23 66 29 29 0a 09 20 20 20 20 dead" #f))..
6fc0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 (debug:print 2
6fd0: 22 4e 4f 54 45 3a 20 22 20 74 65 73 74 2d 6e 61 "NOTE: " test-na
6fe0: 6d 65 20 22 20 69 73 20 61 6c 72 65 61 64 79 20 me " is already
6ff0: 72 75 6e 6e 69 6e 67 22 29 29 29 0a 09 28 65 6c running")))..(el
7000: 73 65 20 20 20 20 20 20 20 28 64 65 62 75 67 3a se (debug:
7010: 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 print 0 "ERROR:
7020: 46 61 69 6c 65 64 20 74 6f 20 6c 61 75 6e 63 68 Failed to launch
7030: 20 74 65 73 74 20 22 20 6e 65 77 2d 74 65 73 74 test " new-test
7040: 2d 6e 61 6d 65 20 22 2e 20 55 6e 72 65 63 6f 67 -name ". Unrecog
7050: 6e 69 73 65 64 20 73 74 61 74 65 20 22 20 28 74 nised state " (t
7060: 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 est:get-state te
7070: 73 74 64 61 74 29 29 29 29 29 29 29 0a 0a 3b 3b stdat)))))))..;;
7080: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7090: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
70a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
70b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
70c0: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 45 4e 44 20 4f 46 ======.;; END OF
70d0: 20 4e 45 57 20 53 54 55 46 46 0a 3b 3b 3d 3d 3d NEW STUFF.;;===
70e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
70f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7100: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7110: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7120: 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 67 65 ===..(define (ge
7130: 74 2d 64 69 72 2d 75 70 2d 6e 20 64 69 72 20 2e t-dir-up-n dir .
7140: 20 70 61 72 61 6d 73 29 20 0a 20 20 28 6c 65 74 params) . (let
7150: 20 28 28 64 70 61 72 74 73 20 20 28 73 74 72 69 ((dparts (stri
7160: 6e 67 2d 73 70 6c 69 74 20 64 69 72 20 22 2f 22 ng-split dir "/"
7170: 29 29 0a 09 28 63 6f 75 6e 74 20 20 20 28 69 66 ))..(count (if
7180: 20 28 6e 75 6c 6c 3f 20 70 61 72 61 6d 73 29 20 (null? params)
7190: 31 20 28 63 61 72 20 70 61 72 61 6d 73 29 29 29 1 (car params)))
71a0: 29 0a 20 20 20 20 28 63 6f 6e 63 20 22 2f 22 20 ). (conc "/"
71b0: 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 (string-interspe
71c0: 72 73 65 20 0a 09 20 20 20 20 20 20 20 28 74 61 rse .. (ta
71d0: 6b 65 20 64 70 61 72 74 73 20 28 2d 20 28 6c 65 ke dparts (- (le
71e0: 6e 67 74 68 20 64 70 61 72 74 73 29 20 63 6f 75 ngth dparts) cou
71f0: 6e 74 29 29 0a 09 20 20 20 20 20 20 20 22 2f 22 nt)).. "/"
7200: 29 29 29 29 0a 3b 3b 20 52 65 6d 6f 76 65 20 72 )))).;; Remove r
7210: 75 6e 73 0a 3b 3b 20 66 69 65 6c 64 73 20 61 72 uns.;; fields ar
7220: 65 20 70 61 73 73 69 6e 67 20 69 6e 20 74 68 72 e passing in thr
7230: 6f 75 67 68 20 0a 3b 3b 20 61 63 74 69 6f 6e 3a ough .;; action:
7240: 0a 3b 3b 20 20 20 20 27 72 65 6d 6f 76 65 2d 72 .;; 'remove-r
7250: 75 6e 73 0a 3b 3b 20 20 20 20 27 73 65 74 2d 73 uns.;; 'set-s
7260: 74 61 74 65 2d 73 74 61 74 75 73 0a 3b 3b 0a 3b tate-status.;;.;
7270: 3b 20 4e 42 2f 2f 20 73 68 6f 75 6c 64 20 70 61 ; NB// should pa
7280: 73 73 20 69 6e 20 6b 65 79 73 3f 0a 3b 3b 0a 28 ss in keys?.;;.(
7290: 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 6f 70 65 define (runs:ope
72a0: 72 61 74 65 2d 6f 6e 20 64 62 20 61 63 74 69 6f rate-on db actio
72b0: 6e 20 72 75 6e 6e 61 6d 65 70 61 74 74 20 74 65 n runnamepatt te
72c0: 73 74 70 61 74 74 20 69 74 65 6d 70 61 74 74 20 stpatt itempatt
72d0: 23 21 6b 65 79 20 28 73 74 61 74 65 20 23 66 29 #!key (state #f)
72e0: 28 73 74 61 74 75 73 20 23 66 29 28 6e 65 77 2d (status #f)(new-
72f0: 73 74 61 74 65 2d 73 74 61 74 75 73 20 23 66 29 state-status #f)
7300: 29 0a 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 73 ). (let* ((keys
7310: 20 20 20 20 20 20 20 20 20 28 72 64 62 3a 67 65 (rdb:ge
7320: 74 2d 6b 65 79 73 20 64 62 29 29 0a 09 20 28 72 t-keys db)).. (r
7330: 75 6e 64 61 74 20 20 20 20 20 20 20 28 72 75 6e undat (run
7340: 73 3a 67 65 74 2d 72 75 6e 73 2d 62 79 2d 70 61 s:get-runs-by-pa
7350: 74 74 20 64 62 20 6b 65 79 73 20 72 75 6e 6e 61 tt db keys runna
7360: 6d 65 70 61 74 74 29 29 0a 09 20 28 68 65 61 64 mepatt)).. (head
7370: 65 72 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 er (vector
7380: 2d 72 65 66 20 72 75 6e 64 61 74 20 30 29 29 0a -ref rundat 0)).
7390: 09 20 28 72 75 6e 73 20 20 20 20 20 20 20 20 20 . (runs
73a0: 28 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 64 (vector-ref rund
73b0: 61 74 20 31 29 29 0a 09 20 28 73 74 61 74 65 73 at 1)).. (states
73c0: 20 20 20 20 20 20 20 28 69 66 20 73 74 61 74 65 (if state
73d0: 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 (string-split
73e0: 73 74 61 74 65 20 20 22 2c 22 29 20 27 28 29 29 state ",") '())
73f0: 29 0a 09 20 28 73 74 61 74 75 73 65 73 20 20 20 ).. (statuses
7400: 20 20 28 69 66 20 73 74 61 74 75 73 20 28 73 74 (if status (st
7410: 72 69 6e 67 2d 73 70 6c 69 74 20 73 74 61 74 75 ring-split statu
7420: 73 20 22 2c 22 29 20 27 28 29 29 29 0a 09 20 28 s ",") '())).. (
7430: 73 74 61 74 65 2d 73 74 61 74 75 73 20 28 69 66 state-status (if
7440: 20 28 73 74 72 69 6e 67 3f 20 6e 65 77 2d 73 74 (string? new-st
7450: 61 74 65 2d 73 74 61 74 75 73 29 20 28 73 74 72 ate-status) (str
7460: 69 6e 67 2d 73 70 6c 69 74 20 6e 65 77 2d 73 74 ing-split new-st
7470: 61 74 65 2d 73 74 61 74 75 73 20 22 2c 22 29 20 ate-status ",")
7480: 27 28 23 66 20 23 66 29 29 29 29 0a 20 20 20 20 '(#f #f)))).
7490: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 (debug:print 2 "
74a0: 48 65 61 64 65 72 3a 20 22 20 68 65 61 64 65 72 Header: " header
74b0: 20 22 20 61 63 74 69 6f 6e 3a 20 22 20 61 63 74 " action: " act
74c0: 69 6f 6e 20 22 20 6e 65 77 2d 73 74 61 74 65 2d ion " new-state-
74d0: 73 74 61 74 75 73 3a 20 22 20 6e 65 77 2d 73 74 status: " new-st
74e0: 61 74 65 2d 73 74 61 74 75 73 29 0a 20 20 20 20 ate-status).
74f0: 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 (for-each. (
7500: 6c 61 6d 62 64 61 20 28 72 75 6e 29 0a 20 20 20 lambda (run).
7510: 20 20 20 20 28 6c 65 74 20 28 28 72 75 6e 6b 65 (let ((runke
7520: 79 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 y (string-inters
7530: 70 65 72 73 65 20 28 6d 61 70 20 28 6c 61 6d 62 perse (map (lamb
7540: 64 61 20 28 6b 29 0a 09 09 09 09 09 09 28 64 62 da (k).......(db
7550: 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 :get-value-by-he
7560: 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 ader run header
7570: 28 76 65 63 74 6f 72 2d 72 65 66 20 6b 20 30 29 (vector-ref k 0)
7580: 29 29 20 6b 65 79 73 29 20 22 2f 22 29 29 0a 09 )) keys) "/"))..
7590: 20 20 20 20 20 28 64 69 72 73 2d 74 6f 2d 72 65 (dirs-to-re
75a0: 6d 6f 76 65 20 28 6d 61 6b 65 2d 68 61 73 68 2d move (make-hash-
75b0: 74 61 62 6c 65 29 29 29 0a 09 20 28 6c 65 74 2a table))).. (let*
75c0: 20 28 28 72 75 6e 2d 69 64 20 20 20 20 28 64 62 ((run-id (db
75d0: 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 :get-value-by-he
75e0: 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 ader run header
75f0: 22 69 64 22 29 29 0a 09 09 28 72 75 6e 2d 73 74 "id"))...(run-st
7600: 61 74 65 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 ate (db:get-valu
7610: 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 e-by-header run
7620: 68 65 61 64 65 72 20 22 73 74 61 74 65 22 29 29 header "state"))
7630: 0a 09 09 28 74 65 73 74 73 20 20 20 20 20 28 69 ...(tests (i
7640: 66 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 72 f (not (equal? r
7650: 75 6e 2d 73 74 61 74 65 20 22 6c 6f 63 6b 65 64 un-state "locked
7660: 22 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 72 ")).... (r
7670: 64 62 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 db:get-tests-for
7680: 2d 72 75 6e 20 64 62 20 28 64 62 3a 67 65 74 2d -run db (db:get-
7690: 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 value-by-header
76a0: 72 75 6e 20 68 65 61 64 65 72 20 22 69 64 22 29 run header "id")
76b0: 0a 09 09 09 09 09 09 20 20 20 20 20 20 74 65 73 ....... tes
76c0: 74 70 61 74 74 20 69 74 65 6d 70 61 74 74 20 73 tpatt itempatt s
76d0: 74 61 74 65 73 20 73 74 61 74 75 73 65 73 0a 09 tates statuses..
76e0: 09 09 09 09 09 20 20 20 20 20 20 6e 6f 74 2d 69 ..... not-i
76f0: 6e 3a 20 20 23 66 0a 09 09 09 09 09 09 20 20 20 n: #f.......
7700: 20 20 20 73 6f 72 74 2d 62 79 3a 20 28 63 61 73 sort-by: (cas
7710: 65 20 61 63 74 69 6f 6e 0a 09 09 09 09 09 09 09 e action........
7720: 09 20 28 28 72 65 6d 6f 76 65 2d 72 75 6e 73 29 . ((remove-runs)
7730: 20 27 72 75 6e 64 69 72 29 0a 09 09 09 09 09 09 'rundir).......
7740: 09 09 20 28 65 6c 73 65 20 20 20 20 20 20 20 20 .. (else
7750: 20 20 27 65 76 65 6e 74 5f 74 69 6d 65 29 29 29 'event_time)))
7760: 0a 09 09 09 20 20 20 20 20 20 20 27 28 29 29 29 .... '()))
7770: 0a 09 09 28 6c 61 73 74 74 70 61 74 68 20 22 2f ...(lasttpath "/
7780: 64 6f 65 73 2f 6e 6f 74 2f 65 78 69 73 74 2f 49 does/not/exist/I
7790: 2f 68 6f 70 65 22 29 29 0a 0a 09 20 20 20 28 69 /hope"))... (i
77a0: 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 65 f (not (null? te
77b0: 73 74 73 29 29 0a 09 20 20 20 20 20 20 20 28 62 sts)).. (b
77c0: 65 67 69 6e 0a 09 09 20 28 63 61 73 65 20 61 63 egin... (case ac
77d0: 74 69 6f 6e 0a 09 09 20 20 20 28 28 72 65 6d 6f tion... ((remo
77e0: 76 65 2d 72 75 6e 73 29 0a 09 09 20 20 20 20 28 ve-runs)... (
77f0: 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 52 debug:print 1 "R
7800: 65 6d 6f 76 69 6e 67 20 74 65 73 74 73 20 66 6f emoving tests fo
7810: 72 20 72 75 6e 3a 20 22 20 72 75 6e 6b 65 79 20 r run: " runkey
7820: 22 20 22 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 " " (db:get-valu
7830: 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 e-by-header run
7840: 68 65 61 64 65 72 20 22 72 75 6e 6e 61 6d 65 22 header "runname"
7850: 29 29 29 0a 09 09 20 20 20 28 28 73 65 74 2d 73 )))... ((set-s
7860: 74 61 74 65 2d 73 74 61 74 75 73 29 0a 09 09 20 tate-status)...
7870: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
7880: 31 20 22 4d 6f 64 69 66 79 69 6e 67 20 73 74 61 1 "Modifying sta
7890: 74 65 20 61 6e 64 20 73 74 61 75 73 20 66 6f 72 te and staus for
78a0: 20 74 65 73 74 73 20 66 6f 72 20 72 75 6e 3a 20 tests for run:
78b0: 22 20 72 75 6e 6b 65 79 20 22 20 22 20 28 64 62 " runkey " " (db
78c0: 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 :get-value-by-he
78d0: 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 ader run header
78e0: 22 72 75 6e 6e 61 6d 65 22 29 29 29 0a 09 09 20 "runname")))...
78f0: 20 20 28 65 6c 73 65 0a 09 09 20 20 20 20 28 70 (else... (p
7900: 72 69 6e 74 20 22 49 4e 46 4f 3a 20 61 63 74 69 rint "INFO: acti
7910: 6f 6e 20 6e 6f 74 20 72 65 63 6f 67 6e 69 73 65 on not recognise
7920: 64 20 22 20 61 63 74 69 6f 6e 29 29 29 0a 09 09 d " action)))...
7930: 20 28 66 6f 72 2d 65 61 63 68 0a 09 09 20 20 28 (for-each... (
7940: 6c 61 6d 62 64 61 20 28 74 65 73 74 29 0a 09 09 lambda (test)...
7950: 20 20 20 20 28 6c 65 74 2a 20 28 28 69 74 65 6d (let* ((item
7960: 2d 70 61 74 68 20 28 64 62 3a 74 65 73 74 2d 67 -path (db:test-g
7970: 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 65 73 et-item-path tes
7980: 74 29 29 0a 09 09 09 20 20 20 28 74 65 73 74 2d t)).... (test-
7990: 6e 61 6d 65 20 28 64 62 3a 74 65 73 74 2d 67 65 name (db:test-ge
79a0: 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 29 t-testname test)
79b0: 29 0a 09 09 09 20 20 20 28 72 75 6e 2d 64 69 72 ).... (run-dir
79c0: 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d (db:test-get-
79d0: 72 75 6e 64 69 72 20 74 65 73 74 29 29 29 0a 09 rundir test)))..
79e0: 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
79f0: 69 6e 74 20 31 20 22 20 20 22 20 28 64 62 3a 74 int 1 " " (db:t
7a00: 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 est-get-testname
7a10: 20 74 65 73 74 29 20 22 20 69 64 3a 20 22 20 28 test) " id: " (
7a20: 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 db:test-get-id t
7a30: 65 73 74 29 20 22 20 22 20 69 74 65 6d 2d 70 61 est) " " item-pa
7a40: 74 68 20 22 20 61 63 74 69 6f 6e 3a 20 22 20 61 th " action: " a
7a50: 63 74 69 6f 6e 29 0a 09 09 20 20 20 20 20 20 28 ction)... (
7a60: 63 61 73 65 20 61 63 74 69 6f 6e 0a 09 09 09 28 case action....(
7a70: 28 72 65 6d 6f 76 65 2d 72 75 6e 73 29 0a 09 09 (remove-runs)...
7a80: 09 20 28 72 64 62 3a 64 65 6c 65 74 65 2d 74 65 . (rdb:delete-te
7a90: 73 74 2d 72 65 63 6f 72 64 73 20 64 62 20 28 64 st-records db (d
7aa0: 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 b:test-get-id te
7ab0: 73 74 29 29 0a 09 09 09 20 28 64 65 62 75 67 3a st)).... (debug:
7ac0: 70 72 69 6e 74 20 31 20 22 49 4e 46 4f 3a 20 41 print 1 "INFO: A
7ad0: 74 74 65 6d 70 74 69 6e 67 20 74 6f 20 72 65 6d ttempting to rem
7ae0: 6f 76 65 20 64 69 72 20 22 20 72 75 6e 2d 64 69 ove dir " run-di
7af0: 72 29 0a 09 09 09 20 28 69 66 20 28 61 6e 64 20 r).... (if (and
7b00: 28 3e 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 (> (string-lengt
7b10: 68 20 72 75 6e 2d 64 69 72 29 20 35 29 0a 09 09 h run-dir) 5)...
7b20: 09 09 20 20 28 66 69 6c 65 2d 65 78 69 73 74 73 .. (file-exists
7b30: 3f 20 72 75 6e 2d 64 69 72 29 29 20 3b 3b 20 62 ? run-dir)) ;; b
7b40: 61 64 20 68 65 75 72 69 73 74 69 63 20 62 75 74 ad heuristic but
7b50: 20 73 68 6f 75 6c 64 20 70 72 65 76 65 6e 74 20 should prevent
7b60: 2f 74 6d 70 20 2f 68 6f 6d 65 20 65 74 63 2e 0a /tmp /home etc..
7b70: 09 09 09 20 20 20 20 20 28 6c 65 74 2a 20 28 28 ... (let* ((
7b80: 72 65 61 6c 70 61 74 68 20 28 72 65 73 6f 6c 76 realpath (resolv
7b90: 65 2d 70 61 74 68 6e 61 6d 65 20 72 75 6e 2d 64 e-pathname run-d
7ba0: 69 72 29 29 29 0a 09 09 09 20 20 20 20 20 20 20 ir)))....
7bb0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 (debug:print 1 "
7bc0: 49 4e 46 4f 3a 20 52 65 61 6c 20 70 61 74 68 20 INFO: Real path
7bd0: 6f 66 20 69 73 20 22 20 72 65 61 6c 70 61 74 68 of is " realpath
7be0: 29 0a 09 09 09 20 20 20 20 20 20 20 28 69 66 20 ).... (if
7bf0: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 72 65 (file-exists? re
7c00: 61 6c 70 61 74 68 29 0a 09 09 09 09 20 20 20 28 alpath)..... (
7c10: 69 66 20 28 3e 20 28 73 79 73 74 65 6d 20 28 63 if (> (system (c
7c20: 6f 6e 63 20 22 72 6d 20 2d 72 66 20 22 20 72 65 onc "rm -rf " re
7c30: 61 6c 70 61 74 68 29 29 20 30 29 0a 09 09 09 09 alpath)) 0).....
7c40: 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 (debug:pr
7c50: 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 54 68 int 0 "ERROR: Th
7c60: 65 72 65 20 77 61 73 20 61 20 70 72 6f 62 6c 65 ere was a proble
7c70: 6d 20 72 65 6d 6f 76 69 6e 67 20 22 20 72 65 61 m removing " rea
7c80: 6c 70 61 74 68 20 22 20 77 69 74 68 20 72 6d 20 lpath " with rm
7c90: 2d 66 22 29 29 0a 09 09 09 09 20 20 20 28 64 65 -f"))..... (de
7ca0: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 bug:print 0 "WAR
7cb0: 4e 49 4e 47 3a 20 74 65 73 74 20 72 75 6e 20 64 NING: test run d
7cc0: 69 72 20 22 20 72 65 61 6c 70 61 74 68 20 22 20 ir " realpath "
7cd0: 61 70 70 65 61 72 73 20 74 6f 20 6e 6f 74 20 65 appears to not e
7ce0: 78 69 73 74 22 29 29 0a 09 09 09 20 20 20 20 20 xist"))....
7cf0: 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 (if (file-exis
7d00: 74 73 3f 20 72 75 6e 2d 64 69 72 29 20 3b 3b 20 ts? run-dir) ;;
7d10: 74 68 65 20 6c 69 6e 6b 0a 09 09 09 09 20 20 20 the link.....
7d20: 28 69 66 20 28 73 79 6d 62 6f 6c 69 63 2d 6c 69 (if (symbolic-li
7d30: 6e 6b 3f 20 72 75 6e 2d 64 69 72 29 0a 09 09 09 nk? run-dir)....
7d40: 09 20 20 20 20 20 20 20 28 64 65 6c 65 74 65 2d . (delete-
7d50: 66 69 6c 65 20 72 75 6e 2d 64 69 72 29 0a 09 09 file run-dir)...
7d60: 09 09 20 20 20 20 20 20 20 28 69 66 20 28 64 69 .. (if (di
7d70: 72 65 63 74 6f 72 79 3f 20 72 75 6e 2d 64 69 72 rectory? run-dir
7d80: 29 0a 09 09 09 09 09 20 20 20 28 69 66 20 28 3e )...... (if (>
7d90: 20 28 64 69 72 65 63 74 6f 72 79 2d 66 6f 6c 64 (directory-fold
7da0: 20 28 6c 61 6d 62 64 61 20 28 66 20 78 29 28 2b (lambda (f x)(+
7db0: 20 31 20 78 29 29 20 30 20 72 75 6e 2d 64 69 72 1 x)) 0 run-dir
7dc0: 29 20 30 29 0a 09 09 09 09 09 20 20 20 20 20 20 ) 0)......
7dd0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
7de0: 22 57 41 52 4e 49 4e 47 3a 20 72 65 66 75 73 69 "WARNING: refusi
7df0: 6e 67 20 74 6f 20 72 65 6d 6f 76 65 20 22 20 72 ng to remove " r
7e00: 75 6e 2d 64 69 72 20 22 20 61 73 20 69 74 20 69 un-dir " as it i
7e10: 73 20 6e 6f 74 20 65 6d 70 74 79 22 29 0a 09 09 s not empty")...
7e20: 09 09 09 20 20 20 20 20 20 20 28 64 65 6c 65 74 ... (delet
7e30: 65 2d 64 69 72 65 63 74 6f 72 79 20 72 75 6e 2d e-directory run-
7e40: 64 69 72 29 29 20 3b 3b 20 69 74 20 73 68 6f 75 dir)) ;; it shou
7e50: 6c 64 20 62 65 20 65 6d 70 74 79 20 62 79 20 68 ld be empty by h
7e60: 65 72 65 20 42 55 47 20 42 55 47 2c 20 61 64 64 ere BUG BUG, add
7e70: 20 65 72 72 6f 72 20 63 61 74 63 68 0a 09 09 09 error catch....
7e80: 09 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e .. (debug:prin
7e90: 74 20 30 20 22 45 52 52 4f 52 3a 20 72 65 66 75 t 0 "ERROR: refu
7ea0: 73 69 6e 67 20 74 6f 20 72 65 6d 6f 76 65 20 22 sing to remove "
7eb0: 20 72 75 6e 2d 64 69 72 20 22 20 61 73 20 69 74 run-dir " as it
7ec0: 20 69 73 20 6e 65 69 74 68 65 72 20 61 20 73 79 is neither a sy
7ed0: 6d 6c 69 6e 6b 20 6e 6f 72 20 61 20 64 69 72 65 mlink nor a dire
7ee0: 63 74 6f 72 79 22 29 0a 09 09 09 09 09 20 20 20 ctory")......
7ef0: 29 29 29 29 0a 09 09 09 20 20 20 20 20 28 64 65 )))).... (de
7f00: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 bug:print 0 "WAR
7f10: 4e 49 4e 47 3a 20 64 69 72 65 63 74 6f 72 79 20 NING: directory
7f20: 61 6c 72 65 61 64 79 20 72 65 6d 6f 76 65 64 20 already removed
7f30: 22 20 72 75 6e 2d 64 69 72 29 29 29 0a 09 09 09 " run-dir)))....
7f40: 28 28 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 ((set-state-stat
7f50: 75 73 29 0a 09 09 09 20 28 64 65 62 75 67 3a 70 us).... (debug:p
7f60: 72 69 6e 74 20 32 20 22 49 4e 46 4f 3a 20 6e 65 rint 2 "INFO: ne
7f70: 77 20 73 74 61 74 65 20 22 20 28 63 61 72 20 73 w state " (car s
7f80: 74 61 74 65 2d 73 74 61 74 75 73 29 20 22 2c 20 tate-status) ",
7f90: 6e 65 77 20 73 74 61 74 75 73 20 22 20 28 63 61 new status " (ca
7fa0: 64 72 20 73 74 61 74 65 2d 73 74 61 74 75 73 29 dr state-status)
7fb0: 29 0a 09 09 09 20 28 64 62 3a 74 65 73 74 2d 73 ).... (db:test-s
7fc0: 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d et-state-status-
7fd0: 62 79 2d 69 64 20 64 62 20 28 64 62 3a 74 65 73 by-id db (db:tes
7fe0: 74 2d 67 65 74 2d 69 64 20 74 65 73 74 29 20 28 t-get-id test) (
7ff0: 63 61 72 20 73 74 61 74 65 2d 73 74 61 74 75 73 car state-status
8000: 29 28 63 61 64 72 20 73 74 61 74 65 2d 73 74 61 )(cadr state-sta
8010: 74 75 73 29 20 23 66 29 29 29 29 29 0a 09 09 20 tus) #f)))))...
8020: 20 74 65 73 74 73 29 29 29 0a 09 20 20 20 0a 09 tests))).. ..
8030: 20 20 20 3b 3b 20 72 65 6d 6f 76 65 20 74 68 65 ;; remove the
8040: 20 72 75 6e 20 69 66 20 7a 65 72 6f 20 74 65 73 run if zero tes
8050: 74 73 20 72 65 6d 61 69 6e 0a 09 20 20 20 28 69 ts remain.. (i
8060: 66 20 28 65 71 3f 20 61 63 74 69 6f 6e 20 27 72 f (eq? action 'r
8070: 65 6d 6f 76 65 2d 72 75 6e 73 29 0a 09 20 20 20 emove-runs)..
8080: 20 20 20 20 28 6c 65 74 20 28 28 72 65 6d 74 65 (let ((remte
8090: 73 74 73 20 28 72 64 62 3a 67 65 74 2d 74 65 73 sts (rdb:get-tes
80a0: 74 73 2d 66 6f 72 2d 72 75 6e 20 64 62 20 28 64 ts-for-run db (d
80b0: 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 b:get-value-by-h
80c0: 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 eader run header
80d0: 20 22 69 64 22 29 20 23 66 20 23 66 20 27 28 29 "id") #f #f '()
80e0: 20 27 28 29 29 29 29 0a 09 09 20 28 69 66 20 28 '())))... (if (
80f0: 6e 75 6c 6c 3f 20 72 65 6d 74 65 73 74 73 29 20 null? remtests)
8100: 3b 3b 20 6e 6f 20 6d 6f 72 65 20 74 65 73 74 73 ;; no more tests
8110: 20 72 65 6d 61 69 6e 69 6e 67 0a 09 09 20 20 20 remaining...
8120: 20 20 28 6c 65 74 2a 20 28 28 64 70 61 72 74 73 (let* ((dparts
8130: 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 (string-split
8140: 6c 61 73 74 74 70 61 74 68 20 22 2f 22 29 29 0a lasttpath "/")).
8150: 09 09 09 20 20 20 20 28 72 75 6e 70 61 74 68 20 ... (runpath
8160: 28 63 6f 6e 63 20 22 2f 22 20 28 73 74 72 69 6e (conc "/" (strin
8170: 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 0a 09 g-intersperse ..
8180: 09 09 09 09 09 28 74 61 6b 65 20 64 70 61 72 74 .....(take dpart
8190: 73 20 28 2d 20 28 6c 65 6e 67 74 68 20 64 70 61 s (- (length dpa
81a0: 72 74 73 29 20 31 29 29 0a 09 09 09 09 09 09 22 rts) 1))......."
81b0: 2f 22 29 29 29 29 0a 09 09 20 20 20 20 20 20 20 /"))))...
81c0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 (debug:print 1 "
81d0: 52 65 6d 6f 76 69 6e 67 20 72 75 6e 3a 20 22 20 Removing run: "
81e0: 72 75 6e 6b 65 79 20 22 20 22 20 28 64 62 3a 67 runkey " " (db:g
81f0: 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 et-value-by-head
8200: 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 72 er run header "r
8210: 75 6e 6e 61 6d 65 22 29 29 0a 09 09 20 20 20 20 unname"))...
8220: 20 20 20 28 64 62 3a 64 65 6c 65 74 65 2d 72 75 (db:delete-ru
8230: 6e 20 64 62 20 72 75 6e 2d 69 64 29 0a 09 09 20 n db run-id)...
8240: 20 20 20 20 20 20 3b 3b 20 6e 65 65 64 20 74 6f ;; need to
8250: 20 66 69 67 75 72 65 20 6f 75 74 20 74 68 65 20 figure out the
8260: 70 61 74 68 20 74 6f 20 74 68 65 20 72 75 6e 20 path to the run
8270: 64 69 72 20 61 6e 64 20 72 65 6d 6f 76 65 20 69 dir and remove i
8280: 74 20 69 66 20 65 6d 70 74 79 0a 09 09 20 20 20 t if empty...
8290: 20 20 20 20 3b 3b 20 20 20 20 28 69 66 20 28 6e ;; (if (n
82a0: 75 6c 6c 3f 20 28 67 6c 6f 62 20 28 63 6f 6e 63 ull? (glob (conc
82b0: 20 72 75 6e 70 61 74 68 20 22 2f 2a 22 29 29 29 runpath "/*")))
82c0: 0a 09 09 20 20 20 20 20 20 20 3b 3b 20 20 20 20 ... ;;
82d0: 20 20 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 (begin...
82e0: 20 20 20 20 3b 3b 20 09 20 28 64 65 62 75 67 3a ;; . (debug:
82f0: 70 72 69 6e 74 20 31 20 22 52 65 6d 6f 76 69 6e print 1 "Removin
8300: 67 20 72 75 6e 20 64 69 72 20 22 20 72 75 6e 70 g run dir " runp
8310: 61 74 68 29 0a 09 09 20 20 20 20 20 20 20 3b 3b ath)... ;;
8320: 20 09 20 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 . (system (conc
8330: 20 22 72 6d 64 69 72 20 2d 70 20 22 20 72 75 6e "rmdir -p " run
8340: 70 61 74 68 29 29 29 29 0a 09 09 20 20 20 20 20 path))))...
8350: 20 20 29 29 29 29 29 0a 09 20 29 29 0a 20 20 20 ))))).. )).
8360: 20 20 72 75 6e 73 29 29 29 0a 0a 3b 3b 3d 3d 3d runs)))..;;===
8370: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8380: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8390: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
83a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
83b0: 3d 3d 3d 0a 3b 3b 20 52 6f 75 74 69 6e 65 73 20 ===.;; Routines
83c0: 66 6f 72 20 6d 61 6e 69 70 75 6c 61 74 69 6e 67 for manipulating
83d0: 20 72 75 6e 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d runs.;;========
83e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
83f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8400: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8410: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
8420: 3b 3b 20 53 69 6e 63 65 20 6d 61 6e 79 20 63 61 ;; Since many ca
8430: 6c 6c 73 20 74 6f 20 61 20 72 75 6e 20 72 65 71 lls to a run req
8440: 75 69 72 65 20 70 72 65 74 74 79 20 6d 75 63 68 uire pretty much
8450: 20 74 68 65 20 73 61 6d 65 20 73 65 74 75 70 20 the same setup
8460: 0a 3b 3b 20 74 68 69 73 20 77 72 61 70 70 65 72 .;; this wrapper
8470: 20 69 73 20 75 73 65 64 20 74 6f 20 72 65 64 75 is used to redu
8480: 63 65 20 74 68 65 20 72 65 70 6c 69 63 61 74 69 ce the replicati
8490: 6f 6e 20 6f 66 20 63 6f 64 65 0a 28 64 65 66 69 on of code.(defi
84a0: 6e 65 20 28 67 65 6e 65 72 61 6c 2d 72 75 6e 2d ne (general-run-
84b0: 63 61 6c 6c 20 73 77 69 74 63 68 6e 61 6d 65 20 call switchname
84c0: 61 63 74 69 6f 6e 2d 64 65 73 63 20 70 72 6f 63 action-desc proc
84d0: 29 0a 20 20 28 6c 65 74 20 28 28 72 75 6e 6e 61 ). (let ((runna
84e0: 6d 65 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 me (args:get-arg
84f0: 20 22 3a 72 75 6e 6e 61 6d 65 22 29 29 0a 09 28 ":runname"))..(
8500: 74 61 72 67 65 74 20 20 28 69 66 20 28 61 72 67 target (if (arg
8510: 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 72 67 s:get-arg "-targ
8520: 65 74 22 29 0a 09 09 20 20 20 20 20 28 61 72 67 et")... (arg
8530: 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 72 67 s:get-arg "-targ
8540: 65 74 22 29 0a 09 09 20 20 20 20 20 28 61 72 67 et")... (arg
8550: 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 71 74 s:get-arg "-reqt
8560: 61 72 67 22 29 29 29 0a 09 28 74 68 31 20 20 20 arg")))..(th1
8570: 20 20 23 66 29 29 0a 20 20 20 20 28 63 6f 6e 64 #f)). (cond
8580: 0a 20 20 20 20 20 28 28 6e 6f 74 20 74 61 72 67 . ((not targ
8590: 65 74 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 et). (debug
85a0: 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a :print 0 "ERROR:
85b0: 20 4d 69 73 73 69 6e 67 20 72 65 71 75 69 72 65 Missing require
85c0: 64 20 70 61 72 61 6d 65 74 65 72 20 66 6f 72 20 d parameter for
85d0: 22 20 73 77 69 74 63 68 6e 61 6d 65 20 22 2c 20 " switchname ",
85e0: 79 6f 75 20 6d 75 73 74 20 73 70 65 63 69 66 79 you must specify
85f0: 20 74 68 65 20 74 61 72 67 65 74 20 77 69 74 68 the target with
8600: 20 2d 74 61 72 67 65 74 22 29 0a 20 20 20 20 20 -target").
8610: 20 28 65 78 69 74 20 33 29 29 0a 20 20 20 20 20 (exit 3)).
8620: 28 28 6e 6f 74 20 72 75 6e 6e 61 6d 65 29 0a 20 ((not runname).
8630: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
8640: 74 20 30 20 22 45 52 52 4f 52 3a 20 4d 69 73 73 t 0 "ERROR: Miss
8650: 69 6e 67 20 72 65 71 75 69 72 65 64 20 70 61 72 ing required par
8660: 61 6d 65 74 65 72 20 66 6f 72 20 22 20 73 77 69 ameter for " swi
8670: 74 63 68 6e 61 6d 65 20 22 2c 20 79 6f 75 20 6d tchname ", you m
8680: 75 73 74 20 73 70 65 63 69 66 79 20 74 68 65 20 ust specify the
8690: 72 75 6e 20 6e 61 6d 65 20 77 69 74 68 20 3a 72 run name with :r
86a0: 75 6e 6e 61 6d 65 20 72 75 6e 6e 61 6d 65 22 29 unname runname")
86b0: 0a 20 20 20 20 20 20 28 65 78 69 74 20 33 29 29 . (exit 3))
86c0: 0a 20 20 20 20 20 28 65 6c 73 65 0a 20 20 20 20 . (else.
86d0: 20 20 28 6c 65 74 20 28 28 64 62 20 20 20 23 66 (let ((db #f
86e0: 29 0a 09 20 20 20 20 28 6b 65 79 73 20 23 66 29 ).. (keys #f)
86f0: 29 0a 09 28 69 66 20 28 6e 6f 74 20 28 73 65 74 )..(if (not (set
8700: 75 70 2d 66 6f 72 2d 72 75 6e 29 29 0a 09 20 20 up-for-run))..
8710: 20 20 28 62 65 67 69 6e 20 0a 09 20 20 20 20 20 (begin ..
8720: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
8730: 22 46 61 69 6c 65 64 20 74 6f 20 73 65 74 75 70 "Failed to setup
8740: 2c 20 65 78 69 74 69 6e 67 22 29 0a 09 20 20 20 , exiting")..
8750: 20 20 20 28 65 78 69 74 20 31 29 29 29 0a 09 28 (exit 1)))..(
8760: 73 65 74 21 20 64 62 20 20 20 28 6f 70 65 6e 2d set! db (open-
8770: 64 62 29 29 0a 09 28 69 66 20 28 61 72 67 73 3a db))..(if (args:
8780: 67 65 74 2d 61 72 67 20 22 2d 73 65 72 76 65 72 get-arg "-server
8790: 22 29 0a 09 20 20 20 20 28 73 65 72 76 65 72 3a ").. (server:
87a0: 73 74 61 72 74 20 64 62 20 28 61 72 67 73 3a 67 start db (args:g
87b0: 65 74 2d 61 72 67 20 22 2d 73 65 72 76 65 72 22 et-arg "-server"
87c0: 29 29 0a 09 20 20 20 20 28 69 66 20 28 6e 6f 74 )).. (if (not
87d0: 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 (or (args:get-a
87e0: 72 67 20 22 2d 72 75 6e 61 6c 6c 22 29 0a 09 09 rg "-runall")...
87f0: 09 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 . (args:get-arg
8800: 20 22 2d 72 75 6e 74 65 73 74 73 22 29 29 29 0a "-runtests"))).
8810: 09 09 28 73 65 72 76 65 72 3a 63 6c 69 65 6e 74 ..(server:client
8820: 2d 73 65 74 75 70 20 64 62 29 29 29 0a 09 28 73 -setup db)))..(s
8830: 65 74 21 20 6b 65 79 73 20 28 72 64 62 3a 67 65 et! keys (rdb:ge
8840: 74 2d 6b 65 79 73 20 64 62 29 29 0a 09 3b 3b 20 t-keys db))..;;
8850: 68 61 76 65 20 65 6e 6f 75 67 68 20 74 6f 20 70 have enough to p
8860: 72 6f 63 65 73 73 20 2d 74 61 72 67 65 74 20 6f rocess -target o
8870: 72 20 2d 72 65 71 74 61 72 67 20 68 65 72 65 0a r -reqtarg here.
8880: 09 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d 61 .(if (args:get-a
8890: 72 67 20 22 2d 72 65 71 74 61 72 67 22 29 0a 09 rg "-reqtarg")..
88a0: 20 20 20 20 28 6c 65 74 2a 20 28 28 72 75 6e 63 (let* ((runc
88b0: 6f 6e 66 69 67 66 20 28 63 6f 6e 63 20 20 2a 74 onfigf (conc *t
88c0: 6f 70 70 61 74 68 2a 20 22 2f 72 75 6e 63 6f 6e oppath* "/runcon
88d0: 66 69 67 73 2e 63 6f 6e 66 69 67 22 29 29 20 3b figs.config")) ;
88e0: 3b 20 44 4f 20 4e 4f 54 20 45 56 41 4c 55 41 54 ; DO NOT EVALUAT
88f0: 45 20 41 4c 4c 20 0a 09 09 20 20 20 28 72 75 6e E ALL ... (run
8900: 63 6f 6e 66 69 67 20 20 28 72 65 61 64 2d 63 6f config (read-co
8910: 6e 66 69 67 20 72 75 6e 63 6f 6e 66 69 67 66 20 nfig runconfigf
8920: 23 66 20 23 66 20 65 6e 76 69 72 6f 6e 2d 70 61 #f #f environ-pa
8930: 74 74 3a 20 23 66 29 29 29 20 0a 09 20 20 20 20 tt: #f))) ..
8940: 20 20 28 69 66 20 28 68 61 73 68 2d 74 61 62 6c (if (hash-tabl
8950: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 72 75 e-ref/default ru
8960: 6e 63 6f 6e 66 69 67 20 28 61 72 67 73 3a 67 65 nconfig (args:ge
8970: 74 2d 61 72 67 20 22 2d 72 65 71 74 61 72 67 22 t-arg "-reqtarg"
8980: 29 20 23 66 29 0a 09 09 20 20 28 6b 65 79 73 3a ) #f)... (keys:
8990: 74 61 72 67 65 74 2d 73 65 74 2d 61 72 67 73 20 target-set-args
89a0: 6b 65 79 73 20 28 61 72 67 73 3a 67 65 74 2d 61 keys (args:get-a
89b0: 72 67 20 22 2d 72 65 71 74 61 72 67 22 29 20 61 rg "-reqtarg") a
89c0: 72 67 73 3a 61 72 67 2d 68 61 73 68 29 0a 09 09 rgs:arg-hash)...
89d0: 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 28 (begin... (
89e0: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 debug:print 0 "E
89f0: 52 52 4f 52 3a 20 5b 22 20 28 61 72 67 73 3a 67 RROR: [" (args:g
8a00: 65 74 2d 61 72 67 20 22 2d 72 65 71 74 61 72 67 et-arg "-reqtarg
8a10: 22 29 20 22 5d 20 6e 6f 74 20 66 6f 75 6e 64 20 ") "] not found
8a20: 69 6e 20 22 20 72 75 6e 63 6f 6e 66 69 67 66 29 in " runconfigf)
8a30: 0a 09 09 20 20 20 20 28 73 71 6c 69 74 65 33 3a ... (sqlite3:
8a40: 66 69 6e 61 6c 69 7a 65 21 20 64 62 29 0a 09 09 finalize! db)...
8a50: 20 20 20 20 28 65 78 69 74 20 31 29 29 29 29 0a (exit 1)))).
8a60: 09 20 20 20 20 28 69 66 20 28 61 72 67 73 3a 67 . (if (args:g
8a70: 65 74 2d 61 72 67 20 22 2d 74 61 72 67 65 74 22 et-arg "-target"
8a80: 29 0a 09 09 28 6b 65 79 73 3a 74 61 72 67 65 74 )...(keys:target
8a90: 2d 73 65 74 2d 61 72 67 73 20 6b 65 79 73 20 28 -set-args keys (
8aa0: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 args:get-arg "-t
8ab0: 61 72 67 65 74 22 20 61 72 67 73 3a 61 72 67 2d arget" args:arg-
8ac0: 68 61 73 68 29 20 61 72 67 73 3a 61 72 67 2d 68 hash) args:arg-h
8ad0: 61 73 68 29 29 29 0a 09 28 69 66 20 28 6e 6f 74 ash)))..(if (not
8ae0: 20 28 63 61 72 20 2a 63 6f 6e 66 69 67 69 6e 66 (car *configinf
8af0: 6f 2a 29 29 0a 09 20 20 20 20 28 62 65 67 69 6e o*)).. (begin
8b00: 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 .. (debug:p
8b10: 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 41 rint 0 "ERROR: A
8b20: 74 74 65 6d 70 74 65 64 20 74 6f 20 22 20 61 63 ttempted to " ac
8b30: 74 69 6f 6e 2d 64 65 73 63 20 22 20 62 75 74 20 tion-desc " but
8b40: 72 75 6e 20 61 72 65 61 20 63 6f 6e 66 69 67 20 run area config
8b50: 66 69 6c 65 20 6e 6f 74 20 66 6f 75 6e 64 22 29 file not found")
8b60: 0a 09 20 20 20 20 20 20 28 65 78 69 74 20 31 29 .. (exit 1)
8b70: 29 0a 09 20 20 20 20 3b 3b 20 45 78 74 72 61 63 ).. ;; Extrac
8b80: 74 20 6f 75 74 20 73 74 75 66 66 20 6e 65 65 64 t out stuff need
8b90: 65 64 20 69 6e 20 6d 6f 73 74 20 6f 72 20 6d 61 ed in most or ma
8ba0: 6e 79 20 63 61 6c 6c 73 0a 09 20 20 20 20 3b 3b ny calls.. ;;
8bb0: 20 68 65 72 65 20 74 68 65 6e 20 63 61 6c 6c 20 here then call
8bc0: 70 72 6f 63 0a 09 20 20 20 20 28 6c 65 74 2a 20 proc.. (let*
8bd0: 28 28 6b 65 79 6e 61 6d 65 73 20 20 20 28 6d 61 ((keynames (ma
8be0: 70 20 6b 65 79 3a 67 65 74 2d 66 69 65 6c 64 6e p key:get-fieldn
8bf0: 61 6d 65 20 6b 65 79 73 29 29 0a 09 09 20 20 20 ame keys))...
8c00: 28 6b 65 79 76 61 6c 6c 73 74 20 20 28 6b 65 79 (keyvallst (key
8c10: 73 2d 3e 76 61 6c 6c 69 73 74 20 6b 65 79 73 20 s->vallist keys
8c20: 23 74 29 29 29 0a 09 20 20 20 20 20 20 28 70 72 #t))).. (pr
8c30: 6f 63 20 64 62 20 74 61 72 67 65 74 20 72 75 6e oc db target run
8c40: 6e 61 6d 65 20 6b 65 79 73 20 6b 65 79 6e 61 6d name keys keynam
8c50: 65 73 20 6b 65 79 76 61 6c 6c 73 74 29 29 29 0a es keyvallst))).
8c60: 09 28 69 66 20 74 68 31 20 28 74 68 72 65 61 64 .(if th1 (thread
8c70: 2d 6a 6f 69 6e 21 20 74 68 31 29 29 0a 09 28 73 -join! th1))..(s
8c80: 71 6c 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 qlite3:finalize!
8c90: 20 64 62 29 0a 09 28 73 65 74 21 20 2a 64 69 64 db)..(set! *did
8ca0: 73 6f 6d 65 74 68 69 6e 67 2a 20 23 74 29 29 29 something* #t)))
8cb0: 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d )))..;;=========
8cc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8cd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8ce0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8cf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
8d00: 20 4c 6f 63 6b 2f 75 6e 6c 6f 63 6b 20 72 75 6e Lock/unlock run
8d10: 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d s.;;============
8d20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8d30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8d40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8d50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 ==========..(def
8d60: 69 6e 65 20 28 72 75 6e 73 3a 68 61 6e 64 6c 65 ine (runs:handle
8d70: 2d 6c 6f 63 6b 69 6e 67 20 64 62 20 74 61 72 67 -locking db targ
8d80: 65 74 20 6b 65 79 73 20 72 75 6e 6e 61 6d 65 20 et keys runname
8d90: 6c 6f 63 6b 20 75 6e 6c 6f 63 6b 20 75 73 65 72 lock unlock user
8da0: 29 0a 20 20 28 6c 65 74 2a 20 28 28 72 75 6e 64 ). (let* ((rund
8db0: 61 74 20 20 20 28 72 75 6e 73 3a 67 65 74 2d 72 at (runs:get-r
8dc0: 75 6e 73 2d 62 79 2d 70 61 74 74 20 64 62 20 6b uns-by-patt db k
8dd0: 65 79 73 20 72 75 6e 6e 61 6d 65 29 29 0a 09 20 eys runname))..
8de0: 28 68 65 61 64 65 72 20 20 20 28 76 65 63 74 6f (header (vecto
8df0: 72 2d 72 65 66 20 72 75 6e 64 61 74 20 30 29 29 r-ref rundat 0))
8e00: 0a 09 20 28 72 75 6e 73 20 20 20 20 20 28 76 65 .. (runs (ve
8e10: 63 74 6f 72 2d 72 65 66 20 72 75 6e 64 61 74 20 ctor-ref rundat
8e20: 31 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 1))). (for-ea
8e30: 63 68 20 28 6c 61 6d 62 64 61 20 28 72 75 6e 29 ch (lambda (run)
8e40: 0a 09 09 28 6c 65 74 20 28 28 72 75 6e 2d 69 64 ...(let ((run-id
8e50: 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 (db:get-value-b
8e60: 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 y-header run hea
8e70: 64 65 72 20 22 69 64 22 29 29 29 0a 09 09 20 20 der "id")))...
8e80: 28 69 66 20 28 6f 72 20 6c 6f 63 6b 0a 09 09 09 (if (or lock....
8e90: 20 20 28 61 6e 64 20 75 6e 6c 6f 63 6b 0a 09 09 (and unlock...
8ea0: 09 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 . (begin..
8eb0: 09 09 09 20 28 70 72 69 6e 74 20 22 44 6f 20 79 ... (print "Do y
8ec0: 6f 75 20 72 65 61 6c 6c 79 20 77 69 73 68 20 74 ou really wish t
8ed0: 6f 20 75 6e 6c 6f 63 6b 20 72 75 6e 20 22 20 72 o unlock run " r
8ee0: 75 6e 2d 69 64 20 22 3f 5c 6e 20 20 20 79 2f 6e un-id "?\n y/n
8ef0: 3a 20 22 29 0a 09 09 09 09 20 28 65 71 75 61 6c : ")..... (equal
8f00: 3f 20 22 79 22 20 28 72 65 61 64 2d 6c 69 6e 65 ? "y" (read-line
8f10: 29 29 29 29 29 0a 09 09 20 20 20 20 20 20 28 64 )))))... (d
8f20: 62 3a 6c 6f 63 6b 2f 75 6e 6c 6f 63 6b 2d 72 75 b:lock/unlock-ru
8f30: 6e 20 64 62 20 72 75 6e 2d 69 64 20 6c 6f 63 6b n db run-id lock
8f40: 20 75 6e 6c 6f 63 6b 20 75 73 65 72 29 0a 09 09 unlock user)...
8f50: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
8f60: 6e 74 20 30 20 22 49 4e 46 4f 3a 20 53 6b 69 70 nt 0 "INFO: Skip
8f70: 70 69 6e 67 20 6c 6f 63 6b 2f 75 6e 6c 6f 63 6b ping lock/unlock
8f80: 20 6f 6e 20 22 20 72 75 6e 2d 69 64 29 29 29 29 on " run-id))))
8f90: 0a 09 20 20 20 20 20 20 72 75 6e 73 29 29 29 0a .. runs))).
8fa0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
8fb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8fc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8fd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8fe0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 52 6f 6c 6c ========.;; Roll
8ff0: 75 70 20 72 75 6e 73 0a 3b 3b 3d 3d 3d 3d 3d 3d up runs.;;======
9000: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9010: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9020: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9030: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9040: 0a 0a 3b 3b 20 55 70 64 61 74 65 20 74 68 65 20 ..;; Update the
9050: 74 65 73 74 5f 6d 65 74 61 20 74 61 62 6c 65 20 test_meta table
9060: 66 6f 72 20 74 68 69 73 20 74 65 73 74 0a 28 64 for this test.(d
9070: 65 66 69 6e 65 20 28 72 75 6e 73 3a 75 70 64 61 efine (runs:upda
9080: 74 65 2d 74 65 73 74 5f 6d 65 74 61 20 64 62 20 te-test_meta db
9090: 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 63 test-name test-c
90a0: 6f 6e 66 29 0a 20 20 28 6c 65 74 20 28 28 63 75 onf). (let ((cu
90b0: 72 72 72 65 63 6f 72 64 20 28 64 62 3a 74 65 73 rrrecord (db:tes
90c0: 74 6d 65 74 61 2d 67 65 74 2d 72 65 63 6f 72 64 tmeta-get-record
90d0: 20 64 62 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 db test-name)))
90e0: 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 63 75 . (if (not cu
90f0: 72 72 72 65 63 6f 72 64 29 0a 09 28 62 65 67 69 rrrecord)..(begi
9100: 6e 0a 09 20 20 28 73 65 74 21 20 63 75 72 72 72 n.. (set! currr
9110: 65 63 6f 72 64 20 28 6d 61 6b 65 2d 76 65 63 74 ecord (make-vect
9120: 6f 72 20 31 30 20 23 66 29 29 0a 09 20 20 28 64 or 10 #f)).. (d
9130: 62 3a 74 65 73 74 6d 65 74 61 2d 61 64 64 2d 72 b:testmeta-add-r
9140: 65 63 6f 72 64 20 64 62 20 74 65 73 74 2d 6e 61 ecord db test-na
9150: 6d 65 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 me))). (for-e
9160: 61 63 68 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 ach . (lambd
9170: 61 20 28 6b 65 79 29 0a 20 20 20 20 20 20 20 28 a (key). (
9180: 6c 65 74 2a 20 28 28 69 64 78 20 28 63 61 64 72 let* ((idx (cadr
9190: 20 6b 65 79 29 29 0a 09 20 20 20 20 20 20 28 66 key)).. (f
91a0: 6c 64 20 28 63 61 72 20 20 6b 65 79 29 29 0a 09 ld (car key))..
91b0: 20 20 20 20 20 20 28 76 61 6c 20 28 63 6f 6e 66 (val (conf
91c0: 69 67 2d 6c 6f 6f 6b 75 70 20 74 65 73 74 2d 63 ig-lookup test-c
91d0: 6f 6e 66 20 22 74 65 73 74 5f 6d 65 74 61 22 20 onf "test_meta"
91e0: 66 6c 64 29 29 29 0a 09 20 3b 3b 20 28 64 65 62 fld))).. ;; (deb
91f0: 75 67 3a 70 72 69 6e 74 20 35 20 22 69 64 78 3a ug:print 5 "idx:
9200: 20 22 20 69 64 78 20 22 20 66 6c 64 3a 20 22 20 " idx " fld: "
9210: 66 6c 64 20 22 20 76 61 6c 3a 20 22 20 76 61 6c fld " val: " val
9220: 29 0a 09 20 28 69 66 20 28 61 6e 64 20 76 61 6c ).. (if (and val
9230: 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 28 76 (not (equal? (v
9240: 65 63 74 6f 72 2d 72 65 66 20 63 75 72 72 72 65 ector-ref currre
9250: 63 6f 72 64 20 69 64 78 29 20 76 61 6c 29 29 29 cord idx) val)))
9260: 0a 09 20 20 20 20 20 28 62 65 67 69 6e 0a 09 20 .. (begin..
9270: 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 55 70 (print "Up
9280: 64 61 74 69 6e 67 20 22 20 74 65 73 74 2d 6e 61 dating " test-na
9290: 6d 65 20 22 20 22 20 66 6c 64 20 22 20 74 6f 20 me " " fld " to
92a0: 22 20 76 61 6c 29 0a 09 20 20 20 20 20 20 20 28 " val).. (
92b0: 64 62 3a 74 65 73 74 6d 65 74 61 2d 75 70 64 61 db:testmeta-upda
92c0: 74 65 2d 66 69 65 6c 64 20 64 62 20 74 65 73 74 te-field db test
92d0: 2d 6e 61 6d 65 20 66 6c 64 20 76 61 6c 29 29 29 -name fld val)))
92e0: 29 29 0a 20 20 20 20 20 27 28 28 22 61 75 74 68 )). '(("auth
92f0: 6f 72 22 20 32 29 28 22 6f 77 6e 65 72 22 20 33 or" 2)("owner" 3
9300: 29 28 22 64 65 73 63 72 69 70 74 69 6f 6e 22 20 )("description"
9310: 34 29 28 22 72 65 76 69 65 77 65 64 22 20 35 29 4)("reviewed" 5)
9320: 28 22 74 61 67 73 22 20 39 29 29 29 29 29 0a 0a ("tags" 9)))))..
9330: 3b 3b 20 55 70 64 61 74 65 20 74 65 73 74 5f 6d ;; Update test_m
9340: 65 74 61 20 66 6f 72 20 61 6c 6c 20 74 65 73 74 eta for all test
9350: 73 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a s.(define (runs:
9360: 75 70 64 61 74 65 2d 61 6c 6c 2d 74 65 73 74 5f update-all-test_
9370: 6d 65 74 61 20 64 62 29 0a 20 20 28 6c 65 74 20 meta db). (let
9380: 28 28 74 65 73 74 2d 6e 61 6d 65 73 20 28 67 65 ((test-names (ge
9390: 74 2d 61 6c 6c 2d 6c 65 67 61 6c 2d 74 65 73 74 t-all-legal-test
93a0: 73 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 s))). (for-ea
93b0: 63 68 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 ch . (lambda
93c0: 20 28 74 65 73 74 2d 6e 61 6d 65 29 0a 20 20 20 (test-name).
93d0: 20 20 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 (let* ((test
93e0: 2d 70 61 74 68 20 20 20 20 28 63 6f 6e 63 20 2a -path (conc *
93f0: 74 6f 70 70 61 74 68 2a 20 22 2f 74 65 73 74 73 toppath* "/tests
9400: 2f 22 20 74 65 73 74 2d 6e 61 6d 65 29 29 0a 09 /" test-name))..
9410: 20 20 20 20 20 20 28 74 65 73 74 2d 63 6f 6e 66 (test-conf
9420: 69 67 66 20 28 63 6f 6e 63 20 74 65 73 74 2d 70 igf (conc test-p
9430: 61 74 68 20 22 2f 74 65 73 74 63 6f 6e 66 69 67 ath "/testconfig
9440: 22 29 29 0a 09 20 20 20 20 20 20 28 74 65 73 74 ")).. (test
9450: 65 78 69 73 74 73 20 20 20 28 61 6e 64 20 28 66 exists (and (f
9460: 69 6c 65 2d 65 78 69 73 74 73 3f 20 74 65 73 74 ile-exists? test
9470: 2d 63 6f 6e 66 69 67 66 29 28 66 69 6c 65 2d 72 -configf)(file-r
9480: 65 61 64 2d 61 63 63 65 73 73 3f 20 74 65 73 74 ead-access? test
9490: 2d 63 6f 6e 66 69 67 66 29 29 29 0a 09 20 20 20 -configf)))..
94a0: 20 20 20 3b 3b 20 72 65 61 64 20 63 6f 6e 66 69 ;; read confi
94b0: 67 73 20 77 69 74 68 20 74 72 69 63 6b 73 20 74 gs with tricks t
94c0: 75 72 6e 65 64 20 6f 66 66 20 28 69 2e 65 2e 20 urned off (i.e.
94d0: 6e 6f 20 73 79 73 74 65 6d 29 0a 09 20 20 20 20 no system)..
94e0: 20 20 28 74 65 73 74 2d 63 6f 6e 66 20 20 20 20 (test-conf
94f0: 28 69 66 20 74 65 73 74 65 78 69 73 74 73 20 28 (if testexists (
9500: 72 65 61 64 2d 63 6f 6e 66 69 67 20 74 65 73 74 read-config test
9510: 2d 63 6f 6e 66 69 67 66 20 23 66 20 23 66 29 28 -configf #f #f)(
9520: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
9530: 29 29 29 0a 09 20 28 72 75 6e 73 3a 75 70 64 61 ))).. (runs:upda
9540: 74 65 2d 74 65 73 74 5f 6d 65 74 61 20 64 62 20 te-test_meta db
9550: 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 63 test-name test-c
9560: 6f 6e 66 29 29 29 0a 20 20 20 20 20 74 65 73 74 onf))). test
9570: 2d 6e 61 6d 65 73 29 29 29 0a 0a 3b 3b 20 54 68 -names)))..;; Th
9580: 69 73 20 63 6f 75 6c 64 20 70 72 6f 62 61 62 6c is could probabl
9590: 79 20 62 65 20 72 65 66 61 63 74 6f 72 65 64 20 y be refactored
95a0: 69 6e 74 6f 20 6f 6e 65 20 63 6f 6d 70 6c 65 78 into one complex
95b0: 20 71 75 65 72 79 20 2e 2e 2e 0a 28 64 65 66 69 query ....(defi
95c0: 6e 65 20 28 72 75 6e 73 3a 72 6f 6c 6c 75 70 2d ne (runs:rollup-
95d0: 72 75 6e 20 64 62 20 6b 65 79 73 20 6b 65 79 76 run db keys keyv
95e0: 61 6c 6c 73 74 20 72 75 6e 6e 61 6d 65 20 75 73 allst runname us
95f0: 65 72 29 20 3b 3b 20 77 61 73 20 74 61 72 67 65 er) ;; was targe
9600: 74 2c 20 6e 6f 77 20 6b 65 79 76 61 6c 6c 73 74 t, now keyvallst
9610: 0a 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 . (debug:print
9620: 34 20 22 72 75 6e 73 3a 72 6f 6c 6c 75 70 2d 72 4 "runs:rollup-r
9630: 75 6e 2c 20 6b 65 79 73 3a 20 22 20 6b 65 79 73 un, keys: " keys
9640: 20 22 20 6b 65 79 76 61 6c 6c 73 74 3a 20 22 20 " keyvallst: "
9650: 6b 65 79 76 61 6c 6c 73 74 20 22 20 3a 72 75 6e keyvallst " :run
9660: 6e 61 6d 65 20 22 20 72 75 6e 6e 61 6d 65 20 22 name " runname "
9670: 20 75 73 65 72 3a 20 22 20 75 73 65 72 29 0a 20 user: " user).
9680: 20 28 6c 65 74 2a 20 28 3b 20 28 6b 65 79 76 61 (let* (; (keyva
9690: 6c 6c 6c 73 74 20 20 20 20 20 20 28 6b 65 79 73 lllst (keys
96a0: 3a 74 61 72 67 65 74 2d 3e 6b 65 79 76 61 6c 20 :target->keyval
96b0: 6b 65 79 73 20 74 61 72 67 65 74 29 29 0a 09 20 keys target))..
96c0: 28 6e 65 77 2d 72 75 6e 2d 69 64 20 20 20 20 20 (new-run-id
96d0: 20 28 72 75 6e 73 3a 72 65 67 69 73 74 65 72 2d (runs:register-
96e0: 72 75 6e 20 64 62 20 6b 65 79 73 20 6b 65 79 76 run db keys keyv
96f0: 61 6c 6c 73 74 20 72 75 6e 6e 61 6d 65 20 22 6e allst runname "n
9700: 65 77 22 20 22 6e 2f 61 22 20 75 73 65 72 29 29 ew" "n/a" user))
9710: 0a 09 20 28 70 72 65 76 2d 74 65 73 74 73 20 20 .. (prev-tests
9720: 20 20 20 20 28 74 65 73 74 3a 67 65 74 2d 6d 61 (test:get-ma
9730: 74 63 68 69 6e 67 2d 70 72 65 76 69 6f 75 73 2d tching-previous-
9740: 74 65 73 74 2d 72 75 6e 2d 72 65 63 6f 72 64 73 test-run-records
9750: 20 64 62 20 6e 65 77 2d 72 75 6e 2d 69 64 20 22 db new-run-id "
9760: 25 22 20 22 25 22 29 29 0a 09 20 28 63 75 72 72 %" "%")).. (curr
9770: 2d 74 65 73 74 73 20 20 20 20 20 20 28 72 64 62 -tests (rdb
9780: 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 :get-tests-for-r
9790: 75 6e 20 64 62 20 6e 65 77 2d 72 75 6e 2d 69 64 un db new-run-id
97a0: 20 22 25 22 20 22 25 22 20 27 28 29 20 27 28 29 "%" "%" '() '()
97b0: 29 29 0a 09 20 28 63 75 72 72 2d 74 65 73 74 73 )).. (curr-tests
97c0: 2d 68 61 73 68 20 28 6d 61 6b 65 2d 68 61 73 68 -hash (make-hash
97d0: 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 20 28 64 -table))). (d
97e0: 62 3a 75 70 64 61 74 65 2d 72 75 6e 2d 65 76 65 b:update-run-eve
97f0: 6e 74 5f 74 69 6d 65 20 64 62 20 6e 65 77 2d 72 nt_time db new-r
9800: 75 6e 2d 69 64 29 0a 20 20 20 20 3b 3b 20 69 6e un-id). ;; in
9810: 64 65 78 20 74 68 65 20 61 6c 72 65 61 64 79 20 dex the already
9820: 73 61 76 65 64 20 74 65 73 74 73 20 62 79 20 74 saved tests by t
9830: 65 73 74 6e 61 6d 65 20 61 6e 64 20 69 74 65 6d estname and item
9840: 64 61 74 20 69 6e 20 63 75 72 72 2d 74 65 73 74 dat in curr-test
9850: 73 2d 68 61 73 68 0a 20 20 20 20 28 66 6f 72 2d s-hash. (for-
9860: 65 61 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 each. (lambd
9870: 61 20 28 74 65 73 74 64 61 74 29 0a 20 20 20 20 a (testdat).
9880: 20 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 6e (let* ((testn
9890: 61 6d 65 20 20 28 64 62 3a 74 65 73 74 2d 67 65 ame (db:test-ge
98a0: 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 64 t-testname testd
98b0: 61 74 29 29 0a 09 20 20 20 20 20 20 28 69 74 65 at)).. (ite
98c0: 6d 2d 70 61 74 68 20 28 64 62 3a 74 65 73 74 2d m-path (db:test-
98d0: 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 65 get-item-path te
98e0: 73 74 64 61 74 29 29 0a 09 20 20 20 20 20 20 28 stdat)).. (
98f0: 66 75 6c 6c 2d 6e 61 6d 65 20 28 63 6f 6e 63 20 full-name (conc
9900: 74 65 73 74 6e 61 6d 65 20 22 2f 22 20 69 74 65 testname "/" ite
9910: 6d 2d 70 61 74 68 29 29 29 0a 09 20 28 68 61 73 m-path))).. (has
9920: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 63 75 72 h-table-set! cur
9930: 72 2d 74 65 73 74 73 2d 68 61 73 68 20 66 75 6c r-tests-hash ful
9940: 6c 2d 6e 61 6d 65 20 74 65 73 74 64 61 74 29 29 l-name testdat))
9950: 29 0a 20 20 20 20 20 63 75 72 72 2d 74 65 73 74 ). curr-test
9960: 73 29 0a 20 20 20 20 3b 3b 20 4e 4f 50 45 3a 20 s). ;; NOPE:
9970: 4e 6f 6e 2d 6f 70 74 69 6d 61 6c 20 61 70 70 72 Non-optimal appr
9980: 6f 61 63 68 2e 20 54 72 79 20 74 68 69 73 20 69 oach. Try this i
9990: 6e 73 74 65 61 64 2e 0a 20 20 20 20 3b 3b 20 20 nstead.. ;;
99a0: 20 31 2e 20 74 65 73 74 73 20 61 72 65 20 72 65 1. tests are re
99b0: 63 65 69 76 65 64 20 69 6e 20 61 20 6c 69 73 74 ceived in a list
99c0: 2c 20 6d 6f 73 74 20 72 65 63 65 6e 74 20 66 69 , most recent fi
99d0: 72 73 74 0a 20 20 20 20 3b 3b 20 20 20 32 2e 20 rst. ;; 2.
99e0: 72 65 70 6c 61 63 65 20 74 68 65 20 72 6f 6c 6c replace the roll
99f0: 75 70 20 74 65 73 74 20 77 69 74 68 20 74 68 65 up test with the
9a00: 20 6e 65 77 20 2a 61 6c 77 61 79 73 2a 0a 20 20 new *always*.
9a10: 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 (for-each .
9a20: 20 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 64 (lambda (testd
9a30: 61 74 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a at). (let*
9a40: 20 28 28 74 65 73 74 6e 61 6d 65 20 20 28 64 62 ((testname (db
9a50: 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 :test-get-testna
9a60: 6d 65 20 74 65 73 74 64 61 74 29 29 0a 09 20 20 me testdat))..
9a70: 20 20 20 20 28 69 74 65 6d 2d 70 61 74 68 20 28 (item-path (
9a80: 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 6d db:test-get-item
9a90: 2d 70 61 74 68 20 74 65 73 74 64 61 74 29 29 0a -path testdat)).
9aa0: 09 20 20 20 20 20 20 28 66 75 6c 6c 2d 6e 61 6d . (full-nam
9ab0: 65 20 28 63 6f 6e 63 20 74 65 73 74 6e 61 6d 65 e (conc testname
9ac0: 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 29 "/" item-path))
9ad0: 0a 09 20 20 20 20 20 20 28 70 72 65 76 2d 74 65 .. (prev-te
9ae0: 73 74 2d 64 61 74 20 28 68 61 73 68 2d 74 61 62 st-dat (hash-tab
9af0: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 63 le-ref/default c
9b00: 75 72 72 2d 74 65 73 74 73 2d 68 61 73 68 20 66 urr-tests-hash f
9b10: 75 6c 6c 2d 6e 61 6d 65 20 23 66 29 29 0a 09 20 ull-name #f))..
9b20: 20 20 20 20 20 28 74 65 73 74 2d 73 74 65 70 73 (test-steps
9b30: 20 20 20 20 20 20 28 64 62 3a 67 65 74 2d 73 74 (db:get-st
9b40: 65 70 73 2d 66 6f 72 2d 74 65 73 74 20 64 62 20 eps-for-test db
9b50: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 (db:test-get-id
9b60: 74 65 73 74 64 61 74 29 29 29 0a 09 20 20 20 20 testdat)))..
9b70: 20 20 28 6e 65 77 2d 74 65 73 74 2d 72 65 63 6f (new-test-reco
9b80: 72 64 20 23 66 29 29 0a 09 20 3b 3b 20 72 65 70 rd #f)).. ;; rep
9b90: 6c 61 63 65 20 74 68 65 73 65 20 77 69 74 68 20 lace these with
9ba0: 69 6e 73 65 72 74 20 2e 2e 2e 20 73 65 6c 65 63 insert ... selec
9bb0: 74 0a 09 20 28 61 70 70 6c 79 20 73 71 6c 69 74 t.. (apply sqlit
9bc0: 65 33 3a 65 78 65 63 75 74 65 20 0a 09 09 64 62 e3:execute ...db
9bd0: 20 0a 09 09 28 63 6f 6e 63 20 22 49 4e 53 45 52 ...(conc "INSER
9be0: 54 20 4f 52 20 52 45 50 4c 41 43 45 20 49 4e 54 T OR REPLACE INT
9bf0: 4f 20 74 65 73 74 73 20 28 72 75 6e 5f 69 64 2c O tests (run_id,
9c00: 74 65 73 74 6e 61 6d 65 2c 73 74 61 74 65 2c 73 testname,state,s
9c10: 74 61 74 75 73 2c 65 76 65 6e 74 5f 74 69 6d 65 tatus,event_time
9c20: 2c 68 6f 73 74 2c 63 70 75 6c 6f 61 64 2c 64 69 ,host,cpuload,di
9c30: 73 6b 66 72 65 65 2c 75 6e 61 6d 65 2c 72 75 6e skfree,uname,run
9c40: 64 69 72 2c 69 74 65 6d 5f 70 61 74 68 2c 72 75 dir,item_path,ru
9c50: 6e 5f 64 75 72 61 74 69 6f 6e 2c 66 69 6e 61 6c n_duration,final
9c60: 5f 6c 6f 67 66 2c 63 6f 6d 6d 65 6e 74 29 20 22 _logf,comment) "
9c70: 0a 09 09 20 20 20 20 20 20 22 56 41 4c 55 45 53 ... "VALUES
9c80: 20 28 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c (?,?,?,?,?,?,?,
9c90: 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 29 3b 22 ?,?,?,?,?,?,?);"
9ca0: 29 0a 09 09 6e 65 77 2d 72 75 6e 2d 69 64 20 28 )...new-run-id (
9cb0: 63 64 64 72 20 28 76 65 63 74 6f 72 2d 3e 6c 69 cddr (vector->li
9cc0: 73 74 20 74 65 73 74 64 61 74 29 29 29 0a 09 20 st testdat)))..
9cd0: 28 73 65 74 21 20 6e 65 77 2d 74 65 73 74 64 61 (set! new-testda
9ce0: 74 20 28 63 61 72 20 28 72 64 62 3a 67 65 74 2d t (car (rdb:get-
9cf0: 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 64 62 tests-for-run db
9d00: 20 6e 65 77 2d 72 75 6e 2d 69 64 20 74 65 73 74 new-run-id test
9d10: 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 27 name item-path '
9d20: 28 29 20 27 28 29 29 29 29 0a 09 20 28 68 61 73 () '()))).. (has
9d30: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 63 75 72 h-table-set! cur
9d40: 72 2d 74 65 73 74 73 2d 68 61 73 68 20 66 75 6c r-tests-hash ful
9d50: 6c 2d 6e 61 6d 65 20 6e 65 77 2d 74 65 73 74 64 l-name new-testd
9d60: 61 74 29 20 3b 3b 20 74 68 69 73 20 63 6f 75 6c at) ;; this coul
9d70: 64 20 62 65 20 63 6f 6e 66 75 73 69 6e 67 2c 20 d be confusing,
9d80: 77 68 69 63 68 20 72 65 63 6f 72 64 20 73 68 6f which record sho
9d90: 75 6c 64 20 67 6f 20 69 6e 74 6f 20 74 68 65 20 uld go into the
9da0: 6c 6f 6f 6b 75 70 20 74 61 62 6c 65 3f 0a 09 20 lookup table?..
9db0: 3b 3b 20 4e 6f 77 20 64 75 70 6c 69 63 61 74 65 ;; Now duplicate
9dc0: 20 74 68 65 20 74 65 73 74 20 73 74 65 70 73 0a the test steps.
9dd0: 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 . (debug:print 4
9de0: 20 22 43 6f 70 79 69 6e 67 20 72 65 63 6f 72 64 "Copying record
9df0: 73 20 69 6e 20 74 65 73 74 5f 73 74 65 70 73 20 s in test_steps
9e00: 66 72 6f 6d 20 74 65 73 74 5f 69 64 3d 22 20 28 from test_id=" (
9e10: 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 db:test-get-id t
9e20: 65 73 74 64 61 74 29 20 22 20 74 6f 20 22 20 28 estdat) " to " (
9e30: 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 6e db:test-get-id n
9e40: 65 77 2d 74 65 73 74 64 61 74 29 29 0a 09 20 28 ew-testdat)).. (
9e50: 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 sqlite3:execute
9e60: 0a 09 20 20 64 62 20 0a 09 20 20 28 63 6f 6e 63 .. db .. (conc
9e70: 20 22 49 4e 53 45 52 54 20 4f 52 20 52 45 50 4c "INSERT OR REPL
9e80: 41 43 45 20 49 4e 54 4f 20 74 65 73 74 5f 73 74 ACE INTO test_st
9e90: 65 70 73 20 28 74 65 73 74 5f 69 64 2c 73 74 65 eps (test_id,ste
9ea0: 70 6e 61 6d 65 2c 73 74 61 74 65 2c 73 74 61 74 pname,state,stat
9eb0: 75 73 2c 65 76 65 6e 74 5f 74 69 6d 65 2c 63 6f us,event_time,co
9ec0: 6d 6d 65 6e 74 29 20 22 0a 09 09 22 53 45 4c 45 mment) "..."SELE
9ed0: 43 54 20 22 20 28 64 62 3a 74 65 73 74 2d 67 65 CT " (db:test-ge
9ee0: 74 2d 69 64 20 6e 65 77 2d 74 65 73 74 64 61 74 t-id new-testdat
9ef0: 29 20 22 2c 73 74 65 70 6e 61 6d 65 2c 73 74 61 ) ",stepname,sta
9f00: 74 65 2c 73 74 61 74 75 73 2c 65 76 65 6e 74 5f te,status,event_
9f10: 74 69 6d 65 2c 63 6f 6d 6d 65 6e 74 20 46 52 4f time,comment FRO
9f20: 4d 20 74 65 73 74 5f 73 74 65 70 73 20 57 48 45 M test_steps WHE
9f30: 52 45 20 74 65 73 74 5f 69 64 3d 3f 3b 22 29 0a RE test_id=?;").
9f40: 09 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d . (db:test-get-
9f50: 69 64 20 74 65 73 74 64 61 74 29 29 0a 09 20 3b id testdat)).. ;
9f60: 3b 20 4e 6f 77 20 64 75 70 6c 69 63 61 74 65 20 ; Now duplicate
9f70: 74 68 65 20 74 65 73 74 20 64 61 74 61 0a 09 20 the test data..
9f80: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 (debug:print 4 "
9f90: 43 6f 70 79 69 6e 67 20 72 65 63 6f 72 64 73 20 Copying records
9fa0: 69 6e 20 74 65 73 74 5f 64 61 74 61 20 66 72 6f in test_data fro
9fb0: 6d 20 74 65 73 74 5f 69 64 3d 22 20 28 64 62 3a m test_id=" (db:
9fc0: 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 test-get-id test
9fd0: 64 61 74 29 20 22 20 74 6f 20 22 20 28 64 62 3a dat) " to " (db:
9fe0: 74 65 73 74 2d 67 65 74 2d 69 64 20 6e 65 77 2d test-get-id new-
9ff0: 74 65 73 74 64 61 74 29 29 0a 09 20 28 73 71 6c testdat)).. (sql
a000: 69 74 65 33 3a 65 78 65 63 75 74 65 20 0a 09 20 ite3:execute ..
a010: 20 64 62 20 0a 09 20 20 28 63 6f 6e 63 20 22 49 db .. (conc "I
a020: 4e 53 45 52 54 20 4f 52 20 52 45 50 4c 41 43 45 NSERT OR REPLACE
a030: 20 49 4e 54 4f 20 74 65 73 74 5f 64 61 74 61 20 INTO test_data
a040: 28 74 65 73 74 5f 69 64 2c 63 61 74 65 67 6f 72 (test_id,categor
a050: 79 2c 76 61 72 69 61 62 6c 65 2c 76 61 6c 75 65 y,variable,value
a060: 2c 65 78 70 65 63 74 65 64 2c 74 6f 6c 2c 75 6e ,expected,tol,un
a070: 69 74 73 2c 63 6f 6d 6d 65 6e 74 29 20 22 0a 09 its,comment) "..
a080: 09 22 53 45 4c 45 43 54 20 22 20 28 64 62 3a 74 ."SELECT " (db:t
a090: 65 73 74 2d 67 65 74 2d 69 64 20 6e 65 77 2d 74 est-get-id new-t
a0a0: 65 73 74 64 61 74 29 20 22 2c 63 61 74 65 67 6f estdat) ",catego
a0b0: 72 79 2c 76 61 72 69 61 62 6c 65 2c 76 61 6c 75 ry,variable,valu
a0c0: 65 2c 65 78 70 65 63 74 65 64 2c 74 6f 6c 2c 75 e,expected,tol,u
a0d0: 6e 69 74 73 2c 63 6f 6d 6d 65 6e 74 20 46 52 4f nits,comment FRO
a0e0: 4d 20 74 65 73 74 5f 64 61 74 61 20 57 48 45 52 M test_data WHER
a0f0: 45 20 74 65 73 74 5f 69 64 3d 3f 3b 22 29 0a 09 E test_id=?;")..
a100: 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 (db:test-get-i
a110: 64 20 74 65 73 74 64 61 74 29 29 0a 09 20 29 29 d testdat)).. ))
a120: 0a 20 20 20 20 20 70 72 65 76 2d 74 65 73 74 73 . prev-tests
a130: 29 29 29 0a 09 20 0a 20 20 20 20 20 0a ))).. . .