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 32 2c 20 4d 61 74 74 68 65 77 06-2012, 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 74 61 72 67 70 61 74 74 29 20 3b 3b 20 74 65 targpatt) ;; 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 74 6d 70 20 20 20 20 20 20 28 72 75 6e ((tmp (run
0480: 73 3a 67 65 74 2d 73 74 64 2d 72 75 6e 2d 66 69 s:get-std-run-fi
0490: 65 6c 64 73 20 6b 65 79 73 20 27 28 22 69 64 22 elds keys '("id"
04a0: 20 22 72 75 6e 6e 61 6d 65 22 20 22 73 74 61 74 "runname" "stat
04b0: 65 22 20 22 73 74 61 74 75 73 22 20 22 6f 77 6e e" "status" "own
04c0: 65 72 22 20 22 65 76 65 6e 74 5f 74 69 6d 65 22 er" "event_time"
04d0: 29 29 29 0a 09 20 28 6b 65 79 73 74 72 20 20 20 ))).. (keystr
04e0: 28 63 61 72 20 74 6d 70 29 29 0a 09 20 28 68 65 (car tmp)).. (he
04f0: 61 64 65 72 20 20 20 28 63 61 64 72 20 74 6d 70 ader (cadr tmp
0500: 29 29 0a 09 20 28 72 65 73 20 20 20 20 20 27 28 )).. (res '(
0510: 29 29 0a 09 20 28 6b 65 79 2d 70 61 74 74 20 22 )).. (key-patt "
0520: 22 29 0a 09 20 28 72 75 6e 77 69 6c 64 74 79 70 ").. (runwildtyp
0530: 65 20 28 69 66 20 28 73 75 62 73 74 72 69 6e 67 e (if (substring
0540: 2d 69 6e 64 65 78 20 22 25 22 20 72 75 6e 6e 61 -index "%" runna
0550: 6d 65 70 61 74 74 29 20 22 6c 69 6b 65 22 20 22 mepatt) "like" "
0560: 67 6c 6f 62 22 29 29 0a 09 20 28 71 72 79 2d 73 glob")).. (qry-s
0570: 74 72 20 20 23 66 29 0a 09 20 28 6b 65 79 76 61 tr #f).. (keyva
0580: 6c 73 20 20 28 6b 65 79 73 3a 74 61 72 67 65 74 ls (keys:target
0590: 2d 3e 6b 65 79 76 61 6c 20 6b 65 79 73 20 74 61 ->keyval keys ta
05a0: 72 67 70 61 74 74 29 29 29 0a 20 20 20 20 28 66 rgpatt))). (f
05b0: 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 or-each (lambda
05c0: 28 6b 65 79 76 61 6c 29 0a 09 09 28 6c 65 74 2a (keyval)...(let*
05d0: 20 28 28 6b 65 79 20 20 20 20 28 63 61 72 20 6b ((key (car k
05e0: 65 79 76 61 6c 29 29 0a 09 09 20 20 20 20 20 20 eyval))...
05f0: 20 28 70 61 74 74 20 20 20 28 63 61 64 72 20 6b (patt (cadr k
0600: 65 79 76 61 6c 29 29 0a 09 09 20 20 20 20 20 20 eyval))...
0610: 20 28 66 75 6c 6b 65 79 20 28 63 6f 6e 63 20 22 (fulkey (conc "
0620: 3a 22 20 6b 65 79 29 29 0a 09 09 20 20 20 20 20 :" key))...
0630: 20 20 28 77 69 6c 64 74 79 70 65 20 28 69 66 20 (wildtype (if
0640: 28 73 75 62 73 74 72 69 6e 67 2d 69 6e 64 65 78 (substring-index
0650: 20 22 25 22 20 70 61 74 74 29 20 22 6c 69 6b 65 "%" patt) "like
0660: 22 20 22 67 6c 6f 62 22 29 29 29 0a 09 09 20 20 " "glob")))...
0670: 28 69 66 20 70 61 74 74 0a 09 09 20 20 20 20 20 (if patt...
0680: 20 28 73 65 74 21 20 6b 65 79 2d 70 61 74 74 20 (set! key-patt
0690: 28 63 6f 6e 63 20 6b 65 79 2d 70 61 74 74 20 22 (conc key-patt "
06a0: 20 41 4e 44 20 22 20 6b 65 79 20 22 20 22 20 77 AND " key " " w
06b0: 69 6c 64 74 79 70 65 20 22 20 27 22 20 70 61 74 ildtype " '" pat
06c0: 74 20 22 27 22 29 29 0a 09 09 20 20 20 20 20 20 t "'"))...
06d0: 28 62 65 67 69 6e 0a 09 09 09 28 64 65 62 75 67 (begin....(debug
06e0: 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a :print 0 "ERROR:
06f0: 20 73 65 61 72 63 68 69 6e 67 20 66 6f 72 20 72 searching for r
0700: 75 6e 73 20 77 69 74 68 20 6e 6f 20 70 61 74 74 uns with no patt
0710: 65 72 6e 20 73 65 74 20 66 6f 72 20 22 20 66 75 ern set for " fu
0720: 6c 6b 65 79 29 0a 09 09 09 28 65 78 69 74 20 36 lkey)....(exit 6
0730: 29 29 29 29 29 0a 09 20 20 20 20 20 20 6b 65 79 ))))).. key
0740: 76 61 6c 73 29 0a 20 20 20 20 28 73 65 74 21 20 vals). (set!
0750: 71 72 79 2d 73 74 72 20 28 63 6f 6e 63 20 22 53 qry-str (conc "S
0760: 45 4c 45 43 54 20 22 20 6b 65 79 73 74 72 20 22 ELECT " keystr "
0770: 20 46 52 4f 4d 20 72 75 6e 73 20 57 48 45 52 45 FROM runs WHERE
0780: 20 72 75 6e 6e 61 6d 65 20 22 20 72 75 6e 77 69 runname " runwi
0790: 6c 64 74 79 70 65 20 22 20 3f 20 22 20 6b 65 79 ldtype " ? " key
07a0: 2d 70 61 74 74 20 22 3b 22 29 29 0a 20 20 20 20 -patt ";")).
07b0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
07c0: 6f 20 34 20 22 72 75 6e 73 3a 67 65 74 2d 72 75 o 4 "runs:get-ru
07d0: 6e 73 2d 62 79 2d 70 61 74 74 20 71 72 79 3d 22 ns-by-patt qry="
07e0: 20 71 72 79 2d 73 74 72 20 22 20 22 20 72 75 6e qry-str " " run
07f0: 6e 61 6d 65 70 61 74 74 29 0a 20 20 20 20 28 73 namepatt). (s
0800: 71 6c 69 74 65 33 3a 66 6f 72 2d 65 61 63 68 2d qlite3:for-each-
0810: 72 6f 77 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 row . (lambd
0820: 61 20 28 61 20 2e 20 72 29 0a 20 20 20 20 20 20 a (a . r).
0830: 20 28 73 65 74 21 20 72 65 73 20 28 63 6f 6e 73 (set! res (cons
0840: 20 28 6c 69 73 74 2d 3e 76 65 63 74 6f 72 20 28 (list->vector (
0850: 63 6f 6e 73 20 61 20 72 29 29 20 72 65 73 29 29 cons a r)) res))
0860: 29 0a 20 20 20 20 20 64 62 20 0a 20 20 20 20 20 ). db .
0870: 71 72 79 2d 73 74 72 0a 20 20 20 20 20 72 75 6e qry-str. run
0880: 6e 61 6d 65 70 61 74 74 29 0a 20 20 20 20 28 76 namepatt). (v
0890: 65 63 74 6f 72 20 68 65 61 64 65 72 20 72 65 73 ector header res
08a0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 )))..(define (ru
08b0: 6e 73 3a 74 65 73 74 2d 67 65 74 2d 66 75 6c 6c ns:test-get-full
08c0: 2d 70 61 74 68 20 74 65 73 74 29 0a 20 20 28 6c -path test). (l
08d0: 65 74 2a 20 28 28 74 65 73 74 6e 61 6d 65 20 28 et* ((testname (
08e0: 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 db:test-get-test
08f0: 6e 61 6d 65 20 20 20 74 65 73 74 29 29 0a 09 20 name test))..
0900: 28 69 74 65 6d 70 61 74 68 20 28 64 62 3a 74 65 (itempath (db:te
0910: 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 st-get-item-path
0920: 20 74 65 73 74 29 29 29 0a 20 20 20 20 28 63 6f test))). (co
0930: 6e 63 20 74 65 73 74 6e 61 6d 65 20 28 69 66 20 nc testname (if
0940: 28 65 71 75 61 6c 3f 20 69 74 65 6d 70 61 74 68 (equal? itempath
0950: 20 22 22 29 20 22 22 20 28 63 6f 6e 63 20 22 28 "") "" (conc "(
0960: 22 20 69 74 65 6d 70 61 74 68 20 22 29 22 29 29 " itempath ")"))
0970: 29 29 29 0a 0a 3b 3b 20 54 68 69 73 20 69 73 20 )))..;; This is
0980: 74 68 65 20 2a 6e 65 77 2a 20 6d 65 74 68 6f 64 the *new* method
0990: 6f 6c 6f 67 79 2e 20 4f 6e 65 20 72 65 63 6f 72 ology. One recor
09a0: 64 20 74 6f 20 69 6e 66 6f 72 6d 20 74 68 65 6d d to inform them
09b0: 20 61 6e 64 20 69 6e 20 74 68 65 20 63 68 61 6f and in the chao
09c0: 73 2c 20 6f 72 67 61 6e 69 73 65 20 74 68 65 6d s, organise them
09d0: 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 72 75 ..;;.(define (ru
09e0: 6e 73 3a 63 72 65 61 74 65 2d 72 75 6e 2d 72 65 ns:create-run-re
09f0: 63 6f 72 64 29 0a 20 20 28 6c 65 74 2a 20 28 28 cord). (let* ((
0a00: 6d 63 6f 6e 66 69 67 20 20 20 20 20 20 28 69 66 mconfig (if
0a10: 20 2a 63 6f 6e 66 69 67 64 61 74 2a 0a 09 09 20 *configdat*...
0a20: 20 20 20 20 20 20 20 20 20 20 2a 63 6f 6e 66 69 *confi
0a30: 67 64 61 74 2a 0a 09 09 20 20 20 20 20 20 20 20 gdat*...
0a40: 20 20 20 28 69 66 20 28 73 65 74 75 70 2d 66 6f (if (setup-fo
0a50: 72 2d 72 75 6e 29 0a 09 09 20 20 20 20 20 20 20 r-run)...
0a60: 20 20 20 20 20 20 20 20 2a 63 6f 6e 66 69 67 64 *configd
0a70: 61 74 2a 0a 09 09 20 20 20 20 20 20 20 20 20 20 at*...
0a80: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 20 20 (begin...
0a90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
0aa0: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 debug:print 0 "E
0ab0: 52 52 4f 52 3a 20 43 61 6c 6c 65 64 20 73 65 74 RROR: Called set
0ac0: 75 70 20 69 6e 20 61 20 6e 6f 6e 2d 6d 65 67 61 up in a non-mega
0ad0: 74 65 73 74 20 61 72 65 61 2c 20 65 78 69 74 69 test area, exiti
0ae0: 6e 67 22 29 0a 09 09 20 20 20 20 20 20 20 20 20 ng")...
0af0: 20 20 20 20 20 20 20 20 28 65 78 69 74 20 31 29 (exit 1)
0b00: 29 29 29 29 0a 09 20 20 28 72 75 6e 72 65 63 20 )))).. (runrec
0b10: 20 20 20 20 20 28 72 75 6e 73 3a 72 75 6e 72 65 (runs:runre
0b20: 63 2d 6d 61 6b 65 2d 72 65 63 6f 72 64 29 29 0a c-make-record)).
0b30: 09 20 20 28 74 61 72 67 65 74 20 20 20 20 20 20 . (target
0b40: 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (or (args:get-ar
0b50: 67 20 22 2d 72 65 71 74 61 72 67 22 29 0a 09 09 g "-reqtarg")...
0b60: 20 20 20 20 20 20 20 20 20 20 20 28 61 72 67 73 (args
0b70: 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 72 67 65 :get-arg "-targe
0b80: 74 22 29 29 29 0a 09 20 20 28 72 75 6e 6e 61 6d t"))).. (runnam
0b90: 65 20 20 20 20 20 28 6f 72 20 28 61 72 67 73 3a e (or (args:
0ba0: 67 65 74 2d 61 72 67 20 22 3a 72 75 6e 6e 61 6d get-arg ":runnam
0bb0: 65 22 29 0a 09 09 20 20 20 20 20 20 20 20 20 20 e")...
0bc0: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
0bd0: 2d 72 75 6e 6e 61 6d 65 22 29 29 29 0a 09 20 20 -runname")))..
0be0: 28 74 65 73 74 70 61 74 74 20 20 20 20 28 6f 72 (testpatt (or
0bf0: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
0c00: 2d 74 65 73 74 70 61 74 74 22 29 0a 09 09 20 20 -testpatt")...
0c10: 20 20 20 20 20 20 20 20 20 28 61 72 67 73 3a 67 (args:g
0c20: 65 74 2d 61 72 67 20 22 2d 72 75 6e 74 65 73 74 et-arg "-runtest
0c30: 73 22 29 29 29 0a 09 20 20 28 6b 65 79 73 20 20 s"))).. (keys
0c40: 20 20 20 20 20 20 28 6b 65 79 73 3a 63 6f 6e 66 (keys:conf
0c50: 69 67 2d 67 65 74 2d 66 69 65 6c 64 73 20 6d 63 ig-get-fields mc
0c60: 6f 6e 66 69 67 29 29 0a 09 20 20 28 6b 65 79 76 onfig)).. (keyv
0c70: 61 6c 73 20 20 20 20 20 28 6b 65 79 73 3a 74 61 als (keys:ta
0c80: 72 67 65 74 2d 3e 6b 65 79 76 61 6c 20 6b 65 79 rget->keyval key
0c90: 73 20 74 61 72 67 65 74 29 29 0a 09 20 20 28 74 s target)).. (t
0ca0: 6f 70 70 61 74 68 20 20 20 20 20 2a 74 6f 70 70 oppath *topp
0cb0: 61 74 68 2a 29 0a 09 20 20 28 65 6e 76 64 61 74 ath*).. (envdat
0cc0: 20 20 20 20 20 20 6b 65 79 76 61 6c 73 29 20 3b keyvals) ;
0cd0: 3b 20 69 6e 69 74 69 61 6c 20 76 61 6c 75 65 73 ; initial values
0ce0: 20 73 74 61 72 74 20 77 69 74 68 20 6b 65 79 76 start with keyv
0cf0: 61 6c 73 0a 09 20 20 28 72 75 6e 63 6f 6e 66 69 als.. (runconfi
0d00: 67 20 20 20 23 66 29 0a 09 20 20 28 73 65 72 76 g #f).. (serv
0d10: 65 72 64 61 74 20 20 20 28 69 66 20 28 61 72 67 erdat (if (arg
0d20: 73 3a 67 65 74 2d 61 72 67 20 22 2d 73 65 72 76 s:get-arg "-serv
0d30: 65 72 22 29 0a 09 09 09 20 20 20 2a 72 75 6e 72 er").... *runr
0d40: 65 6d 6f 74 65 2a 0a 09 09 09 20 20 20 23 66 29 emote*.... #f)
0d50: 29 20 3b 3b 20 74 6f 20 62 65 20 75 73 65 64 20 ) ;; to be used
0d60: 6c 61 74 65 72 0a 09 20 20 28 74 72 61 6e 73 70 later.. (transp
0d70: 6f 72 74 20 20 20 28 6f 72 20 28 61 72 67 73 3a ort (or (args:
0d80: 67 65 74 2d 61 72 67 20 22 2d 74 72 61 6e 73 70 get-arg "-transp
0d90: 6f 72 74 22 29 20 27 68 74 74 70 29 29 0a 09 20 ort") 'http))..
0da0: 20 28 64 62 20 20 20 20 20 20 20 20 20 20 28 69 (db (i
0db0: 66 20 28 61 6e 64 20 6d 63 6f 6e 66 69 67 0a 09 f (and mconfig..
0dc0: 09 09 09 28 6f 72 20 28 61 72 67 73 3a 67 65 74 ...(or (args:get
0dd0: 2d 61 72 67 20 22 2d 73 65 72 76 65 72 22 29 0a -arg "-server").
0de0: 09 09 09 09 20 20 20 20 28 65 71 3f 20 74 72 61 .... (eq? tra
0df0: 6e 73 70 6f 72 74 20 27 66 73 29 29 29 0a 09 09 nsport 'fs)))...
0e00: 09 20 20 20 28 6f 70 65 6e 2d 64 62 29 0a 09 09 . (open-db)...
0e10: 09 20 20 20 23 66 29 29 0a 09 20 20 28 72 75 6e . #f)).. (run
0e20: 2d 69 64 20 20 20 20 20 20 23 66 29 29 0a 20 20 -id #f)).
0e30: 20 20 3b 3b 20 53 65 74 20 61 6c 6c 20 74 68 65 ;; Set all the
0e40: 20 65 6e 76 69 72 6f 6e 6d 65 6e 74 20 76 61 72 environment var
0e50: 73 20 77 65 20 6b 6e 6f 77 20 73 6f 20 66 61 72 s we know so far
0e60: 2c 20 73 74 61 72 74 20 77 69 74 68 20 6b 65 79 , start with key
0e70: 73 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 s. (for-each
0e80: 28 6c 61 6d 62 64 61 20 28 6b 65 79 76 61 6c 29 (lambda (keyval)
0e90: 0a 09 09 28 73 65 74 65 6e 76 20 28 63 61 72 20 ...(setenv (car
0ea0: 6b 65 79 76 61 6c 29 28 63 61 64 72 20 6b 65 79 keyval)(cadr key
0eb0: 76 61 6c 29 29 29 0a 09 20 20 20 20 20 20 6b 65 val))).. ke
0ec0: 79 76 61 6c 73 29 0a 20 20 20 20 3b 3b 20 53 65 yvals). ;; Se
0ed0: 74 20 75 70 20 76 61 72 69 6f 75 73 20 61 6e 64 t up various and
0ee0: 20 73 75 6e 64 72 79 20 6b 6e 6f 77 6e 20 76 61 sundry known va
0ef0: 72 73 20 68 65 72 65 0a 20 20 20 20 28 73 65 74 rs here. (set
0f00: 65 6e 76 20 22 4d 54 5f 52 55 4e 5f 41 52 45 41 env "MT_RUN_AREA
0f10: 5f 48 4f 4d 45 22 20 74 6f 70 70 61 74 68 29 0a _HOME" toppath).
0f20: 20 20 20 20 28 73 65 74 65 6e 76 20 22 4d 54 5f (setenv "MT_
0f30: 52 55 4e 4e 41 4d 45 22 20 72 75 6e 6e 61 6d 65 RUNNAME" runname
0f40: 29 0a 20 20 20 20 28 73 65 74 65 6e 76 20 22 4d ). (setenv "M
0f50: 54 5f 54 41 52 47 45 54 22 20 20 74 61 72 67 65 T_TARGET" targe
0f60: 74 29 0a 20 20 20 20 28 73 65 74 21 20 65 6e 76 t). (set! env
0f70: 64 61 74 20 28 61 70 70 65 6e 64 20 0a 09 09 20 dat (append ...
0f80: 20 65 6e 76 64 61 74 0a 09 09 20 20 28 6c 69 73 envdat... (lis
0f90: 74 20 28 6c 69 73 74 20 22 4d 54 5f 52 55 4e 5f t (list "MT_RUN_
0fa0: 41 52 45 41 5f 48 4f 4d 45 22 20 74 6f 70 70 61 AREA_HOME" toppa
0fb0: 74 68 29 0a 09 09 09 28 6c 69 73 74 20 22 4d 54 th)....(list "MT
0fc0: 5f 52 55 4e 4e 41 4d 45 22 20 20 20 20 20 20 20 _RUNNAME"
0fd0: 72 75 6e 6e 61 6d 65 29 0a 09 09 09 28 6c 69 73 runname)....(lis
0fe0: 74 20 22 4d 54 5f 54 41 52 47 45 54 22 20 20 20 t "MT_TARGET"
0ff0: 20 20 20 20 20 74 61 72 67 65 74 29 29 29 29 0a target)))).
1000: 20 20 20 20 3b 3b 20 4e 6f 77 20 63 61 6e 20 72 ;; Now can r
1010: 65 61 64 20 74 68 65 20 72 75 6e 63 6f 6e 66 69 ead the runconfi
1020: 67 73 20 66 69 6c 65 0a 20 20 20 20 3b 3b 20 0a gs file. ;; .
1030: 20 20 20 20 28 73 65 74 21 20 72 75 6e 63 6f 6e (set! runcon
1040: 66 69 67 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 fig (read-config
1050: 20 28 63 6f 6e 63 20 20 2a 74 6f 70 70 61 74 68 (conc *toppath
1060: 2a 20 22 2f 72 75 6e 63 6f 6e 66 69 67 73 2e 63 * "/runconfigs.c
1070: 6f 6e 66 69 67 22 29 20 23 66 20 23 74 20 73 65 onfig") #f #t se
1080: 63 74 69 6f 6e 73 3a 20 28 6c 69 73 74 20 22 64 ctions: (list "d
1090: 65 66 61 75 6c 74 22 20 74 61 72 67 65 74 29 29 efault" target))
10a0: 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 ). (if (not (
10b0: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
10c0: 65 66 61 75 6c 74 20 72 75 6e 63 6f 6e 66 69 67 efault runconfig
10d0: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
10e0: 2d 72 65 71 74 61 72 67 22 29 20 23 66 29 29 0a -reqtarg") #f)).
10f0: 09 28 62 65 67 69 6e 0a 09 20 20 28 64 65 62 75 .(begin.. (debu
1100: 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 g:print 0 "ERROR
1110: 3a 20 5b 22 20 28 61 72 67 73 3a 67 65 74 2d 61 : [" (args:get-a
1120: 72 67 20 22 2d 72 65 71 74 61 72 67 22 29 20 22 rg "-reqtarg") "
1130: 5d 20 6e 6f 74 20 66 6f 75 6e 64 20 69 6e 20 22 ] not found in "
1140: 20 72 75 6e 63 6f 6e 66 69 67 66 29 0a 09 20 20 runconfigf)..
1150: 28 69 66 20 64 62 20 28 73 71 6c 69 74 65 33 3a (if db (sqlite3:
1160: 66 69 6e 61 6c 69 7a 65 21 20 64 62 29 29 0a 09 finalize! db))..
1170: 20 20 28 65 78 69 74 20 31 29 29 29 0a 20 20 20 (exit 1))).
1180: 20 3b 3b 20 4e 6f 77 20 68 61 76 65 20 72 75 6e ;; Now have run
1190: 63 6f 6e 66 69 67 73 20 64 61 74 61 20 6c 6f 61 configs data loa
11a0: 64 65 64 2c 20 73 65 74 20 65 6e 76 69 72 6f 6e ded, set environ
11b0: 6d 65 6e 74 20 76 61 72 73 0a 20 20 20 20 28 66 ment vars. (f
11c0: 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 or-each (lambda
11d0: 28 73 65 63 74 69 6f 6e 29 0a 09 09 28 66 6f 72 (section)...(for
11e0: 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 76 -each (lambda (v
11f0: 61 72 76 61 6c 29 0a 09 09 09 20 20 20 20 28 73 arval).... (s
1200: 65 74 21 20 65 6e 76 64 61 74 20 28 61 70 70 65 et! envdat (appe
1210: 6e 64 20 65 6e 76 64 61 74 20 28 6c 69 73 74 20 nd envdat (list
1220: 76 61 72 76 61 6c 29 29 29 0a 09 09 09 20 20 20 varval)))....
1230: 20 28 73 65 74 65 6e 76 20 28 63 61 72 20 76 61 (setenv (car va
1240: 72 76 61 6c 29 28 63 61 64 72 20 76 61 72 76 61 rval)(cadr varva
1250: 6c 29 29 29 0a 09 09 09 20 20 28 63 6f 6e 66 69 l))).... (confi
1260: 67 66 3a 67 65 74 2d 73 65 63 74 69 6f 6e 20 72 gf:get-section r
1270: 75 6e 63 6f 6e 66 69 67 20 73 65 63 74 69 6f 6e unconfig section
1280: 29 29 29 0a 09 20 20 20 20 20 20 28 6c 69 73 74 ))).. (list
1290: 20 22 64 65 66 61 75 6c 74 22 20 74 61 72 67 65 "default" targe
12a0: 74 29 29 0a 20 20 20 20 28 76 65 63 74 6f 72 20 t)). (vector
12b0: 74 61 72 67 65 74 20 72 75 6e 6e 61 6d 65 20 74 target runname t
12c0: 65 73 74 70 61 74 74 20 6b 65 79 73 20 6b 65 79 estpatt keys key
12d0: 76 61 6c 73 20 65 6e 76 64 61 74 20 6d 63 6f 6e vals envdat mcon
12e0: 66 69 67 20 72 75 6e 63 6f 6e 66 69 67 20 73 65 fig runconfig se
12f0: 72 76 65 72 64 61 74 20 74 72 61 6e 73 70 6f 72 rverdat transpor
1300: 74 20 64 62 20 74 6f 70 70 61 74 68 20 72 75 6e t db toppath run
1310: 2d 69 64 29 29 29 0a 0a 09 20 0a 28 64 65 66 69 -id)))... .(defi
1320: 6e 65 20 28 73 65 74 2d 6d 65 67 61 74 65 73 74 ne (set-megatest
1330: 2d 65 6e 76 2d 76 61 72 73 20 72 75 6e 2d 69 64 -env-vars run-id
1340: 20 23 21 6b 65 79 20 28 69 6e 6b 65 79 73 20 23 #!key (inkeys #
1350: 66 29 28 69 6e 72 75 6e 6e 61 6d 65 20 23 66 29 f)(inrunname #f)
1360: 28 69 6e 6b 65 79 76 61 6c 73 20 23 66 29 29 0a (inkeyvals #f)).
1370: 20 20 28 6c 65 74 2a 20 28 28 74 61 72 67 65 74 (let* ((target
1380: 20 20 20 20 20 20 28 6f 72 20 28 61 72 67 73 3a (or (args:
1390: 67 65 74 2d 61 72 67 20 22 2d 72 65 71 74 61 72 get-arg "-reqtar
13a0: 67 22 29 0a 09 09 20 20 20 20 20 20 20 20 20 20 g")...
13b0: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
13c0: 2d 74 61 72 67 65 74 22 29 29 29 0a 09 20 28 6b -target"))).. (k
13d0: 65 79 73 20 20 20 20 28 69 66 20 69 6e 6b 65 79 eys (if inkey
13e0: 73 20 20 20 20 69 6e 6b 65 79 73 20 20 20 20 28 s inkeys (
13f0: 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 64 cdb:remote-run d
1400: 62 3a 67 65 74 2d 6b 65 79 73 20 23 66 29 29 29 b:get-keys #f)))
1410: 0a 09 20 28 6b 65 79 76 61 6c 73 20 28 69 66 20 .. (keyvals (if
1420: 69 6e 6b 65 79 76 61 6c 73 20 69 6e 6b 65 79 76 inkeyvals inkeyv
1430: 61 6c 73 20 28 6b 65 79 73 3a 74 61 72 67 65 74 als (keys:target
1440: 2d 3e 6b 65 79 76 61 6c 20 6b 65 79 73 20 74 61 ->keyval keys ta
1450: 72 67 65 74 29 29 29 0a 09 20 28 76 61 6c 73 20 rget))).. (vals
1460: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
1470: 64 65 66 61 75 6c 74 20 2a 65 6e 76 2d 76 61 72 default *env-var
1480: 73 2d 62 79 2d 72 75 6e 2d 69 64 2a 20 72 75 6e s-by-run-id* run
1490: 2d 69 64 20 23 66 29 29 29 0a 20 20 20 20 3b 3b -id #f))). ;;
14a0: 20 67 65 74 20 74 68 65 20 69 6e 66 6f 20 66 72 get the info fr
14b0: 6f 6d 20 74 68 65 20 64 62 20 61 6e 64 20 70 75 om the db and pu
14c0: 74 20 69 74 20 69 6e 20 74 68 65 20 63 61 63 68 t it in the cach
14d0: 65 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 76 e. (if (not v
14e0: 61 6c 73 29 0a 09 28 6c 65 74 20 28 28 68 74 20 als)..(let ((ht
14f0: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
1500: 29 29 29 0a 09 20 20 28 68 61 73 68 2d 74 61 62 ))).. (hash-tab
1510: 6c 65 2d 73 65 74 21 20 2a 65 6e 76 2d 76 61 72 le-set! *env-var
1520: 73 2d 62 79 2d 72 75 6e 2d 69 64 2a 20 72 75 6e s-by-run-id* run
1530: 2d 69 64 20 68 74 29 0a 09 20 20 28 73 65 74 21 -id ht).. (set!
1540: 20 76 61 6c 73 20 68 74 29 0a 09 20 20 28 66 6f vals ht).. (fo
1550: 72 2d 65 61 63 68 0a 09 20 20 20 28 6c 61 6d 62 r-each.. (lamb
1560: 64 61 20 28 6b 65 79 29 0a 09 20 20 20 20 20 28 da (key).. (
1570: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
1580: 76 61 6c 73 20 28 63 61 72 20 6b 65 79 29 20 28 vals (car key) (
1590: 63 61 64 72 20 6b 65 79 29 29 29 20 3b 3b 20 28 cadr key))) ;; (
15a0: 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 64 cdb:remote-run d
15b0: 62 3a 67 65 74 2d 72 75 6e 2d 6b 65 79 2d 76 61 b:get-run-key-va
15c0: 6c 20 23 66 20 72 75 6e 2d 69 64 20 28 63 61 72 l #f run-id (car
15d0: 20 6b 65 79 29 29 29 29 0a 09 20 20 20 6b 65 79 key)))).. key
15e0: 76 61 6c 73 29 29 29 0a 20 20 20 20 3b 3b 20 66 vals))). ;; f
15f0: 72 6f 6d 20 74 68 65 20 63 61 63 68 65 64 20 64 rom the cached d
1600: 61 74 61 20 73 65 74 20 74 68 65 20 76 61 72 73 ata set the vars
1610: 0a 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 . (hash-table
1620: 2d 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 76 -for-each. v
1630: 61 6c 73 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 als. (lambda
1640: 20 28 6b 65 79 20 76 61 6c 29 0a 20 20 20 20 20 (key val).
1650: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 (debug:print 2
1660: 20 22 73 65 74 65 6e 76 20 22 20 6b 65 79 20 22 "setenv " key "
1670: 20 22 20 76 61 6c 29 0a 20 20 20 20 20 20 20 28 " val). (
1680: 73 65 74 65 6e 76 20 6b 65 79 20 76 61 6c 29 29 setenv key val))
1690: 29 0a 20 20 20 20 28 61 6c 69 73 74 2d 3e 65 6e ). (alist->en
16a0: 76 2d 76 61 72 73 20 28 68 61 73 68 2d 74 61 62 v-vars (hash-tab
16b0: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a le-ref/default *
16c0: 63 6f 6e 66 69 67 64 61 74 2a 20 22 65 6e 76 2d configdat* "env-
16d0: 6f 76 65 72 72 69 64 65 22 20 27 28 29 29 29 0a override" '())).
16e0: 20 20 20 20 3b 3b 20 4c 65 74 73 20 75 73 65 20 ;; Lets use
16f0: 74 68 69 73 20 61 73 20 61 6e 20 6f 70 70 6f 72 this as an oppor
1700: 74 75 6e 69 74 79 20 74 6f 20 70 75 74 20 4d 54 tunity to put MT
1710: 5f 52 55 4e 4e 41 4d 45 20 69 6e 20 74 68 65 20 _RUNNAME in the
1720: 65 6e 76 69 72 6f 6e 6d 65 6e 74 0a 20 20 20 20 environment.
1730: 28 73 65 74 65 6e 76 20 22 4d 54 5f 52 55 4e 4e (setenv "MT_RUNN
1740: 41 4d 45 22 20 28 69 66 20 69 6e 72 75 6e 6e 61 AME" (if inrunna
1750: 6d 65 20 69 6e 72 75 6e 6e 61 6d 65 20 28 63 64 me inrunname (cd
1760: 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 64 62 3a b:remote-run db:
1770: 67 65 74 2d 72 75 6e 2d 6e 61 6d 65 2d 66 72 6f get-run-name-fro
1780: 6d 2d 69 64 20 23 66 20 72 75 6e 2d 69 64 29 29 m-id #f run-id))
1790: 29 0a 20 20 20 20 28 73 65 74 65 6e 76 20 22 4d ). (setenv "M
17a0: 54 5f 52 55 4e 5f 41 52 45 41 5f 48 4f 4d 45 22 T_RUN_AREA_HOME"
17b0: 20 2a 74 6f 70 70 61 74 68 2a 29 29 29 0a 0a 28 *toppath*)))..(
17c0: 64 65 66 69 6e 65 20 28 73 65 74 2d 69 74 65 6d define (set-item
17d0: 2d 65 6e 76 2d 76 61 72 73 20 69 74 65 6d 64 61 -env-vars itemda
17e0: 74 29 0a 20 20 28 66 6f 72 2d 65 61 63 68 20 28 t). (for-each (
17f0: 6c 61 6d 62 64 61 20 28 69 74 65 6d 29 0a 09 20 lambda (item)..
1800: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
1810: 74 20 32 20 22 73 65 74 65 6e 76 20 22 20 28 63 t 2 "setenv " (c
1820: 61 72 20 69 74 65 6d 29 20 22 20 22 20 28 63 61 ar item) " " (ca
1830: 64 72 20 69 74 65 6d 29 29 0a 09 20 20 20 20 20 dr item))..
1840: 20 28 73 65 74 65 6e 76 20 28 63 61 72 20 69 74 (setenv (car it
1850: 65 6d 29 20 28 63 61 64 72 20 69 74 65 6d 29 29 em) (cadr item))
1860: 29 0a 09 20 20 20 20 69 74 65 6d 64 61 74 29 29 ).. itemdat))
1870: 0a 0a 28 64 65 66 69 6e 65 20 2a 6c 61 73 74 2d ..(define *last-
1880: 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 74 65 73 74 num-running-test
1890: 73 2a 20 30 29 0a 0a 3b 3b 20 45 76 65 72 79 20 s* 0)..;; Every
18a0: 74 69 6d 65 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 time can-run-mor
18b0: 65 2d 74 65 73 74 73 20 69 73 20 63 61 6c 6c 65 e-tests is calle
18c0: 64 20 69 6e 63 72 65 6d 65 6e 74 20 74 68 65 20 d increment the
18d0: 64 65 6c 61 79 0a 3b 3b 20 69 66 20 74 68 65 20 delay.;; if the
18e0: 63 6f 75 0a 28 64 65 66 69 6e 65 20 2a 72 75 6e cou.(define *run
18f0: 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 s:can-run-more-t
1900: 65 73 74 73 2d 63 6f 75 6e 74 2a 20 30 29 0a 28 ests-count* 0).(
1910: 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 73 68 72 define (runs:shr
1920: 69 6e 6b 2d 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 ink-can-run-more
1930: 2d 74 65 73 74 73 2d 63 6f 75 6e 74 29 0a 20 20 -tests-count).
1940: 28 73 65 74 21 20 2a 72 75 6e 73 3a 63 61 6e 2d (set! *runs:can-
1950: 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 2d 63 run-more-tests-c
1960: 6f 75 6e 74 2a 20 30 29 29 20 3b 3b 20 28 2f 20 ount* 0)) ;; (/
1970: 2a 72 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f *runs:can-run-mo
1980: 72 65 2d 74 65 73 74 73 2d 63 6f 75 6e 74 2a 20 re-tests-count*
1990: 32 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 2)))..(define (r
19a0: 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 uns:can-run-more
19b0: 2d 74 65 73 74 73 20 74 65 73 74 2d 72 65 63 6f -tests test-reco
19c0: 72 64 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e rd max-concurren
19d0: 74 2d 6a 6f 62 73 29 0a 20 20 28 74 68 72 65 61 t-jobs). (threa
19e0: 64 2d 73 6c 65 65 70 21 20 28 63 6f 6e 64 0a 09 d-sleep! (cond..
19f0: 09 20 20 28 28 3e 20 2a 72 75 6e 73 3a 63 61 6e . ((> *runs:can
1a00: 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 2d -run-more-tests-
1a10: 63 6f 75 6e 74 2a 20 32 30 29 20 32 29 3b 3b 20 count* 20) 2);;
1a20: 6f 62 76 69 6f 75 73 6c 79 20 68 61 76 65 6e 27 obviously haven'
1a30: 74 20 68 61 64 20 61 6e 79 20 77 6f 72 6b 20 74 t had any work t
1a40: 6f 20 64 6f 20 66 6f 72 20 61 20 77 68 69 6c 65 o do for a while
1a50: 0a 09 09 20 20 28 65 6c 73 65 20 30 29 29 29 0a ... (else 0))).
1a60: 20 20 28 6c 65 74 2a 20 28 28 74 63 6f 6e 66 69 (let* ((tconfi
1a70: 67 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 g
1a80: 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 (tests:testque
1a90: 75 65 2d 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 ue-get-testconfi
1aa0: 67 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a g test-record)).
1ab0: 09 20 28 6a 6f 62 67 72 6f 75 70 20 20 20 20 20 . (jobgroup
1ac0: 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 66 (conf
1ad0: 69 67 2d 6c 6f 6f 6b 75 70 20 74 63 6f 6e 66 69 ig-lookup tconfi
1ae0: 67 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 22 g "requirements"
1af0: 20 22 6a 6f 62 67 72 6f 75 70 22 29 29 0a 09 20 "jobgroup"))..
1b00: 28 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 20 20 20 (num-running
1b10: 20 20 20 20 20 20 20 20 20 28 63 64 62 3a 72 65 (cdb:re
1b20: 6d 6f 74 65 2d 72 75 6e 20 64 62 3a 67 65 74 2d mote-run db:get-
1b30: 63 6f 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e 6e count-tests-runn
1b40: 69 6e 67 20 23 66 29 29 0a 09 20 28 6e 75 6d 2d ing #f)).. (num-
1b50: 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 running-in-jobgr
1b60: 6f 75 70 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d oup (cdb:remote-
1b70: 72 75 6e 20 64 62 3a 67 65 74 2d 63 6f 75 6e 74 run db:get-count
1b80: 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 2d 69 -tests-running-i
1b90: 6e 2d 6a 6f 62 67 72 6f 75 70 20 23 66 20 6a 6f n-jobgroup #f jo
1ba0: 62 67 72 6f 75 70 29 29 0a 09 20 28 6a 6f 62 2d bgroup)).. (job-
1bb0: 67 72 6f 75 70 2d 6c 69 6d 69 74 20 20 20 20 20 group-limit
1bc0: 20 20 20 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b (config-look
1bd0: 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 up *configdat* "
1be0: 6a 6f 62 67 72 6f 75 70 73 22 20 6a 6f 62 67 72 jobgroups" jobgr
1bf0: 6f 75 70 29 29 29 0a 20 20 20 20 28 69 66 20 28 oup))). (if (
1c00: 3e 20 28 2b 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 > (+ num-running
1c10: 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d num-running-in-
1c20: 6a 6f 62 67 72 6f 75 70 29 20 30 29 0a 09 28 73 jobgroup) 0)..(s
1c30: 65 74 21 20 2a 72 75 6e 73 3a 63 61 6e 2d 72 75 et! *runs:can-ru
1c40: 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 2d 63 6f 75 n-more-tests-cou
1c50: 6e 74 2a 20 28 2b 20 2a 72 75 6e 73 3a 63 61 6e nt* (+ *runs:can
1c60: 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 2d -run-more-tests-
1c70: 63 6f 75 6e 74 2a 20 31 29 29 29 0a 20 20 20 20 count* 1))).
1c80: 28 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 2a 6c (if (not (eq? *l
1c90: 61 73 74 2d 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d ast-num-running-
1ca0: 74 65 73 74 73 2a 20 6e 75 6d 2d 72 75 6e 6e 69 tests* num-runni
1cb0: 6e 67 29 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 ng))..(begin..
1cc0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 (debug:print 2 "
1cd0: 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a max-concurrent-j
1ce0: 6f 62 73 3a 20 22 20 6d 61 78 2d 63 6f 6e 63 75 obs: " max-concu
1cf0: 72 72 65 6e 74 2d 6a 6f 62 73 20 22 2c 20 6e 75 rrent-jobs ", nu
1d00: 6d 2d 72 75 6e 6e 69 6e 67 3a 20 22 20 6e 75 6d m-running: " num
1d10: 2d 72 75 6e 6e 69 6e 67 29 0a 09 20 20 28 73 65 -running).. (se
1d20: 74 21 20 2a 6c 61 73 74 2d 6e 75 6d 2d 72 75 6e t! *last-num-run
1d30: 6e 69 6e 67 2d 74 65 73 74 73 2a 20 6e 75 6d 2d ning-tests* num-
1d40: 72 75 6e 6e 69 6e 67 29 29 29 0a 20 20 20 20 28 running))). (
1d50: 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 30 20 2a if (not (eq? 0 *
1d60: 67 6c 6f 62 61 6c 65 78 69 74 73 74 61 74 75 73 globalexitstatus
1d70: 2a 29 29 0a 09 28 6c 69 73 74 20 23 66 20 6e 75 *))..(list #f nu
1d80: 6d 2d 72 75 6e 6e 69 6e 67 20 6e 75 6d 2d 72 75 m-running num-ru
1d90: 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 nning-in-jobgrou
1da0: 70 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 p max-concurrent
1db0: 2d 6a 6f 62 73 20 6a 6f 62 2d 67 72 6f 75 70 2d -jobs job-group-
1dc0: 6c 69 6d 69 74 29 0a 09 28 6c 65 74 20 28 28 63 limit)..(let ((c
1dd0: 61 6e 2d 6e 6f 74 2d 72 75 6e 2d 6d 6f 72 65 20 an-not-run-more
1de0: 28 63 6f 6e 64 0a 09 09 09 09 20 3b 3b 20 69 66 (cond..... ;; if
1df0: 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d max-concurrent-
1e00: 6a 6f 62 73 20 69 73 20 73 65 74 20 61 6e 64 20 jobs is set and
1e10: 74 68 65 20 6e 75 6d 62 65 72 20 72 75 6e 6e 69 the number runni
1e20: 6e 67 20 69 73 20 67 72 65 61 74 65 72 20 0a 09 ng is greater ..
1e30: 09 09 09 20 3b 3b 20 74 68 61 6e 20 69 74 20 74 ... ;; than it t
1e40: 68 61 6e 20 63 61 6e 6e 6f 74 20 72 75 6e 20 6d han cannot run m
1e50: 6f 72 65 20 6a 6f 62 73 0a 09 09 09 09 20 28 28 ore jobs..... ((
1e60: 61 6e 64 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 and max-concurre
1e70: 6e 74 2d 6a 6f 62 73 20 28 3e 3d 20 6e 75 6d 2d nt-jobs (>= num-
1e80: 72 75 6e 6e 69 6e 67 20 6d 61 78 2d 63 6f 6e 63 running max-conc
1e90: 75 72 72 65 6e 74 2d 6a 6f 62 73 29 29 0a 09 09 urrent-jobs))...
1ea0: 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
1eb0: 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 4d 61 78 0 "WARNING: Max
1ec0: 20 72 75 6e 6e 69 6e 67 20 6a 6f 62 73 20 65 78 running jobs ex
1ed0: 63 65 65 64 65 64 2c 20 63 75 72 72 65 6e 74 20 ceeded, current
1ee0: 6e 75 6d 62 65 72 20 72 75 6e 6e 69 6e 67 3a 20 number running:
1ef0: 22 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 0a 09 " num-running ..
1f00: 09 09 09 09 20 20 20 20 20 20 20 22 2c 20 6d 61 .... ", ma
1f10: 78 5f 63 6f 6e 63 75 72 72 65 6e 74 5f 6a 6f 62 x_concurrent_job
1f20: 73 3a 20 22 20 6d 61 78 2d 63 6f 6e 63 75 72 72 s: " max-concurr
1f30: 65 6e 74 2d 6a 6f 62 73 29 0a 09 09 09 09 20 20 ent-jobs).....
1f40: 23 74 29 0a 09 09 09 09 20 3b 3b 20 69 66 20 6a #t)..... ;; if j
1f50: 6f 62 2d 67 72 6f 75 70 2d 6c 69 6d 69 74 20 69 ob-group-limit i
1f60: 73 20 73 65 74 20 61 6e 64 20 6e 75 6d 62 65 72 s set and number
1f70: 20 6f 66 20 6a 6f 62 73 20 69 6e 20 74 68 65 20 of jobs in the
1f80: 67 72 6f 75 70 20 69 73 20 67 72 65 61 74 65 72 group is greater
1f90: 0a 09 09 09 09 20 3b 3b 20 74 68 61 6e 20 74 68 ..... ;; than th
1fa0: 65 20 6c 69 6d 69 74 20 74 68 65 6e 20 63 61 6e e limit then can
1fb0: 6e 6f 74 20 72 75 6e 20 6d 6f 72 65 20 6a 6f 62 not run more job
1fc0: 73 20 6f 66 20 74 68 69 73 20 6b 69 6e 64 0a 09 s of this kind..
1fd0: 09 09 09 20 28 28 61 6e 64 20 6a 6f 62 2d 67 72 ... ((and job-gr
1fe0: 6f 75 70 2d 6c 69 6d 69 74 0a 09 09 09 09 20 20 oup-limit.....
1ff0: 20 20 20 20 20 28 3e 3d 20 6e 75 6d 2d 72 75 6e (>= num-run
2000: 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 ning-in-jobgroup
2010: 20 6a 6f 62 2d 67 72 6f 75 70 2d 6c 69 6d 69 74 job-group-limit
2020: 29 29 0a 09 09 09 09 20 20 28 64 65 62 75 67 3a ))..... (debug:
2030: 70 72 69 6e 74 20 31 20 22 57 41 52 4e 49 4e 47 print 1 "WARNING
2040: 3a 20 6e 75 6d 62 65 72 20 6f 66 20 6a 6f 62 73 : number of jobs
2050: 20 22 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 69 " num-running-i
2060: 6e 2d 6a 6f 62 67 72 6f 75 70 20 0a 09 09 09 09 n-jobgroup .....
2070: 09 20 20 20 20 20 20 20 22 20 69 6e 20 22 20 6a . " in " j
2080: 6f 62 67 72 6f 75 70 20 22 20 65 78 63 65 65 64 obgroup " exceed
2090: 65 64 2c 20 77 69 6c 6c 20 6e 6f 74 20 72 75 6e ed, will not run
20a0: 20 22 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 " (tests:testqu
20b0: 65 75 65 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 eue-get-testname
20c0: 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 test-record))..
20d0: 09 09 09 20 20 23 74 29 0a 09 09 09 09 20 28 65 ... #t)..... (e
20e0: 6c 73 65 20 23 66 29 29 29 29 0a 09 20 20 28 6c lse #f)))).. (l
20f0: 69 73 74 20 28 6e 6f 74 20 63 61 6e 2d 6e 6f 74 ist (not can-not
2100: 2d 72 75 6e 2d 6d 6f 72 65 29 20 6e 75 6d 2d 72 -run-more) num-r
2110: 75 6e 6e 69 6e 67 20 6e 75 6d 2d 72 75 6e 6e 69 unning num-runni
2120: 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 6d ng-in-jobgroup m
2130: 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f ax-concurrent-jo
2140: 62 73 20 6a 6f 62 2d 67 72 6f 75 70 2d 6c 69 6d bs job-group-lim
2150: 69 74 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d it)))))..;;=====
2160: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2170: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2180: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2190: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
21a0: 3d 0a 3b 3b 20 4e 65 77 20 6d 65 74 68 6f 64 6f =.;; New methodo
21b0: 6c 6f 67 79 2e 20 54 68 65 73 65 20 72 6f 75 74 logy. These rout
21c0: 69 6e 65 73 20 77 69 6c 6c 20 72 65 70 6c 61 63 ines will replac
21d0: 65 20 74 68 65 20 61 62 6f 76 65 20 69 6e 20 74 e the above in t
21e0: 69 6d 65 2e 20 46 6f 72 0a 3b 3b 20 6e 6f 77 20 ime. For.;; now
21f0: 74 68 65 20 63 6f 64 65 20 69 73 20 64 75 70 6c the code is dupl
2200: 69 63 61 74 65 64 2e 20 54 68 69 73 20 73 74 75 icated. This stu
2210: 66 66 20 69 73 20 69 6e 69 74 69 61 6c 6c 79 20 ff is initially
2220: 75 73 65 64 20 69 6e 20 74 68 65 20 6d 6f 6e 69 used in the moni
2230: 74 6f 72 0a 3b 3b 20 62 61 73 65 64 20 63 6f 64 tor.;; based cod
2240: 65 2e 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d e..;;===========
2250: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2260: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2270: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2280: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 0a 3b 3b ===========...;;
2290: 20 54 68 69 73 20 69 73 20 61 20 64 75 70 6c 69 This is a dupli
22a0: 63 61 74 65 20 6f 66 20 72 75 6e 2d 74 65 73 74 cate of run-test
22b0: 73 20 28 77 68 69 63 68 20 68 61 73 20 62 65 65 s (which has bee
22c0: 6e 20 64 65 70 72 65 63 61 74 65 64 29 2e 20 55 n deprecated). U
22d0: 73 65 20 74 68 69 73 20 6f 6e 65 20 69 6e 73 74 se this one inst
22e0: 65 61 64 20 6f 66 20 72 75 6e 20 74 65 73 74 73 ead of run tests
22f0: 2e 0a 3b 3b 20 6b 65 79 76 61 6c 73 2e 0a 3b 3b ..;; keyvals..;;
2300: 0a 3b 3b 20 20 74 65 73 74 2d 6e 61 6d 65 73 3a .;; test-names:
2310: 20 43 6f 6d 6d 61 20 73 65 70 61 72 61 74 65 64 Comma separated
2320: 20 70 61 74 74 65 72 6e 73 20 73 61 6d 65 20 61 patterns same a
2330: 73 20 74 65 73 74 2d 70 61 74 74 73 20 62 75 74 s test-patts but
2340: 20 75 73 65 64 20 69 6e 20 73 65 6c 65 63 74 69 used in selecti
2350: 6f 6e 20 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 on .;;
2360: 20 20 20 20 6f 66 20 74 65 73 74 73 20 74 6f 20 of tests to
2370: 72 75 6e 2e 20 54 68 65 20 69 74 65 6d 20 70 6f run. The item po
2380: 72 74 69 6f 6e 73 20 61 72 65 20 6e 6f 74 20 72 rtions are not r
2390: 65 73 70 65 63 74 65 64 2e 0a 3b 3b 20 20 20 20 espected..;;
23a0: 20 20 20 20 20 20 20 20 20 20 46 49 58 4d 45 3a FIXME:
23b0: 20 65 72 72 6f 72 20 6f 75 74 20 69 66 20 2f 70 error out if /p
23c0: 61 74 74 20 73 70 65 63 69 66 69 65 64 0a 3b 3b att specified.;;
23d0: 20 20 20 20 20 20 20 20 20 20 20 20 0a 28 64 65 .(de
23e0: 66 69 6e 65 20 28 72 75 6e 73 3a 72 75 6e 2d 74 fine (runs:run-t
23f0: 65 73 74 73 20 74 61 72 67 65 74 20 72 75 6e 6e ests target runn
2400: 61 6d 65 20 74 65 73 74 2d 70 61 74 74 73 20 75 ame test-patts u
2410: 73 65 72 20 66 6c 61 67 73 29 20 3b 3b 20 74 65 ser flags) ;; te
2420: 73 74 2d 6e 61 6d 65 73 0a 20 20 28 63 6f 6d 6d st-names. (comm
2430: 6f 6e 3a 63 6c 65 61 72 2d 63 61 63 68 65 73 29 on:clear-caches)
2440: 20 3b 3b 20 63 6c 65 61 72 20 61 6c 6c 20 63 61 ;; clear all ca
2450: 63 68 65 73 0a 20 20 28 6c 65 74 2a 20 28 28 64 ches. (let* ((d
2460: 62 20 20 20 20 20 20 20 20 20 20 23 66 29 0a 09 b #f)..
2470: 20 28 6b 65 79 73 20 20 20 20 20 20 20 20 28 6b (keys (k
2480: 65 79 73 3a 63 6f 6e 66 69 67 2d 67 65 74 2d 66 eys:config-get-f
2490: 69 65 6c 64 73 20 2a 63 6f 6e 66 69 67 64 61 74 ields *configdat
24a0: 2a 29 29 0a 09 20 28 6b 65 79 76 61 6c 73 20 20 *)).. (keyvals
24b0: 20 20 20 28 6b 65 79 73 3a 74 61 72 67 65 74 2d (keys:target-
24c0: 3e 6b 65 79 76 61 6c 20 6b 65 79 73 20 74 61 72 >keyval keys tar
24d0: 67 65 74 29 29 0a 09 20 28 72 75 6e 2d 69 64 20 get)).. (run-id
24e0: 20 20 20 20 20 28 63 64 62 3a 72 65 6d 6f 74 65 (cdb:remote
24f0: 2d 72 75 6e 20 64 62 3a 72 65 67 69 73 74 65 72 -run db:register
2500: 2d 72 75 6e 20 23 66 20 6b 65 79 73 20 6b 65 79 -run #f keys key
2510: 76 61 6c 73 20 72 75 6e 6e 61 6d 65 20 22 6e 65 vals runname "ne
2520: 77 22 20 22 6e 2f 61 22 20 75 73 65 72 29 29 20 w" "n/a" user))
2530: 20 3b 3b 20 20 74 65 73 74 2d 6e 61 6d 65 29 29 ;; test-name))
2540: 29 0a 09 20 28 64 65 66 65 72 72 65 64 20 20 20 ).. (deferred
2550: 20 27 28 29 29 20 3b 3b 20 64 65 6c 61 79 20 72 '()) ;; delay r
2560: 75 6e 6e 69 6e 67 20 74 68 65 73 65 20 73 69 6e unning these sin
2570: 63 65 20 74 68 65 79 20 68 61 76 65 20 61 20 77 ce they have a w
2580: 61 69 74 6f 6e 20 63 6c 61 75 73 65 0a 09 20 3b aiton clause.. ;
2590: 3b 20 6b 65 65 70 67 6f 69 6e 67 20 69 73 20 74 ; keepgoing is t
25a0: 68 65 20 64 65 66 61 63 74 6f 20 6d 6f 64 61 6c he defacto modal
25b0: 69 74 79 20 6e 6f 77 2c 20 77 69 6c 6c 20 61 64 ity now, will ad
25c0: 64 20 68 69 74 2d 6e 2d 72 75 6e 20 61 20 62 69 d hit-n-run a bi
25d0: 74 20 6c 61 74 65 72 0a 09 20 3b 3b 20 28 6b 65 t later.. ;; (ke
25e0: 65 70 67 6f 69 6e 67 20 20 20 28 68 61 73 68 2d epgoing (hash-
25f0: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
2600: 74 20 66 6c 61 67 73 20 22 2d 6b 65 65 70 67 6f t flags "-keepgo
2610: 69 6e 67 22 20 23 66 29 29 0a 09 20 28 72 75 6e ing" #f)).. (run
2620: 63 6f 6e 66 69 67 66 20 20 20 28 63 6f 6e 63 20 configf (conc
2630: 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 72 75 6e *toppath* "/run
2640: 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 69 67 22 29 configs.config")
2650: 29 0a 09 20 28 72 65 71 75 69 72 65 64 2d 74 65 ).. (required-te
2660: 73 74 73 20 27 28 29 29 0a 09 20 28 74 65 73 74 sts '()).. (test
2670: 2d 72 65 63 6f 72 64 73 20 28 6d 61 6b 65 2d 68 -records (make-h
2680: 61 73 68 2d 74 61 62 6c 65 29 29 0a 09 20 28 74 ash-table)).. (t
2690: 65 73 74 2d 6e 61 6d 65 73 20 27 28 29 29 29 0a est-names '())).
26a0: 0a 20 20 20 20 28 73 65 74 2d 6d 65 67 61 74 65 . (set-megate
26b0: 73 74 2d 65 6e 76 2d 76 61 72 73 20 72 75 6e 2d st-env-vars run-
26c0: 69 64 20 69 6e 6b 65 79 73 3a 20 6b 65 79 73 29 id inkeys: keys)
26d0: 20 3b 3b 20 74 68 65 73 65 20 6d 61 79 20 62 65 ;; these may be
26e0: 20 6e 65 65 64 65 64 20 62 79 20 74 68 65 20 6c needed by the l
26f0: 61 75 6e 63 68 69 6e 67 20 70 72 6f 63 65 73 73 aunching process
2700: 0a 0a 20 20 20 20 28 69 66 20 28 66 69 6c 65 2d .. (if (file-
2710: 65 78 69 73 74 73 3f 20 72 75 6e 63 6f 6e 66 69 exists? runconfi
2720: 67 66 29 0a 09 28 73 65 74 75 70 2d 65 6e 76 2d gf)..(setup-env-
2730: 64 65 66 61 75 6c 74 73 20 72 75 6e 63 6f 6e 66 defaults runconf
2740: 69 67 66 20 72 75 6e 2d 69 64 20 2a 61 6c 72 65 igf run-id *alre
2750: 61 64 79 2d 73 65 65 6e 2d 72 75 6e 63 6f 6e 66 ady-seen-runconf
2760: 69 67 2d 69 6e 66 6f 2a 20 6b 65 79 73 20 6b 65 ig-info* keys ke
2770: 79 76 61 6c 73 20 22 70 72 65 2d 6c 61 75 6e 63 yvals "pre-launc
2780: 68 2d 65 6e 76 2d 76 61 72 73 22 29 0a 09 28 64 h-env-vars")..(d
2790: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 ebug:print 0 "WA
27a0: 52 4e 49 4e 47 3a 20 59 6f 75 20 64 6f 20 6e 6f RNING: You do no
27b0: 74 20 68 61 76 65 20 61 20 72 75 6e 20 63 6f 6e t have a run con
27c0: 66 69 67 20 66 69 6c 65 3a 20 22 20 72 75 6e 63 fig file: " runc
27d0: 6f 6e 66 69 67 66 29 29 0a 20 20 20 20 0a 20 20 onfigf)). .
27e0: 20 20 3b 3b 20 6c 6f 6f 6b 20 75 70 20 61 6c 6c ;; look up all
27f0: 20 74 65 73 74 73 20 6d 61 74 63 68 69 6e 67 20 tests matching
2800: 74 68 65 20 63 6f 6d 6d 61 20 73 65 70 61 72 61 the comma separa
2810: 74 65 64 20 6c 69 73 74 20 6f 66 20 67 6c 6f 62 ted list of glob
2820: 73 20 69 6e 0a 20 20 20 20 3b 3b 20 74 65 73 74 s in. ;; test
2830: 2d 70 61 74 74 73 20 28 75 73 69 6e 67 20 25 20 -patts (using %
2840: 61 73 20 77 69 6c 64 63 61 72 64 29 0a 0a 20 20 as wildcard)..
2850: 20 20 28 73 65 74 21 20 74 65 73 74 2d 6e 61 6d (set! test-nam
2860: 65 73 20 28 74 65 73 74 73 3a 67 65 74 2d 76 61 es (tests:get-va
2870: 6c 69 64 2d 74 65 73 74 73 20 2a 74 6f 70 70 61 lid-tests *toppa
2880: 74 68 2a 20 74 65 73 74 2d 70 61 74 74 73 29 29 th* test-patts))
2890: 0a 20 20 20 20 28 73 65 74 21 20 74 65 73 74 2d . (set! test-
28a0: 6e 61 6d 65 73 20 28 64 65 6c 65 74 65 2d 64 75 names (delete-du
28b0: 70 6c 69 63 61 74 65 73 20 74 65 73 74 2d 6e 61 plicates test-na
28c0: 6d 65 73 29 29 0a 0a 20 20 20 20 28 64 65 62 75 mes)).. (debu
28d0: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 g:print-info 0 "
28e0: 74 65 73 74 20 6e 61 6d 65 73 20 22 20 74 65 73 test names " tes
28f0: 74 2d 6e 61 6d 65 73 29 0a 0a 20 20 20 20 3b 3b t-names).. ;;
2900: 20 6f 6e 20 74 68 65 20 66 69 72 73 74 20 70 61 on the first pa
2910: 73 73 20 6f 72 20 63 61 6c 6c 20 74 6f 20 72 75 ss or call to ru
2920: 6e 2d 74 65 73 74 73 20 73 65 74 20 46 41 49 4c n-tests set FAIL
2930: 53 20 74 6f 20 4e 4f 54 5f 53 54 41 52 54 45 44 S to NOT_STARTED
2940: 20 69 66 0a 20 20 20 20 3b 3b 20 2d 6b 65 65 70 if. ;; -keep
2950: 67 6f 69 6e 67 20 69 73 20 73 70 65 63 69 66 69 going is specifi
2960: 65 64 0a 20 20 20 20 28 69 66 20 28 65 71 3f 20 ed. (if (eq?
2970: 2a 70 61 73 73 6e 75 6d 2a 20 30 29 0a 09 28 62 *passnum* 0)..(b
2980: 65 67 69 6e 0a 09 20 20 3b 3b 20 68 61 76 65 20 egin.. ;; have
2990: 74 6f 20 64 65 6c 65 74 65 20 74 65 73 74 20 72 to delete test r
29a0: 65 63 6f 72 64 73 20 77 68 65 72 65 20 4e 4f 54 ecords where NOT
29b0: 5f 53 54 41 52 54 45 44 20 73 69 6e 63 65 20 74 _STARTED since t
29c0: 68 65 79 20 63 61 6e 20 63 61 75 73 65 20 2d 6b hey can cause -k
29d0: 65 65 70 67 6f 69 6e 67 20 74 6f 20 0a 09 20 20 eepgoing to ..
29e0: 3b 3b 20 67 65 74 20 73 74 75 63 6b 20 64 75 65 ;; get stuck due
29f0: 20 74 6f 20 62 65 63 6f 6d 69 6e 67 20 69 6e 61 to becoming ina
2a00: 63 63 65 73 73 69 62 6c 65 20 66 72 6f 6d 20 61 ccessible from a
2a10: 20 66 61 69 6c 65 64 20 74 65 73 74 2e 20 49 2e failed test. I.
2a20: 65 2e 20 69 66 20 74 65 73 74 20 42 20 64 65 70 e. if test B dep
2a30: 65 6e 64 73 20 0a 09 20 20 3b 3b 20 6f 6e 20 74 ends .. ;; on t
2a40: 65 73 74 20 41 20 62 75 74 20 74 65 73 74 20 42 est A but test B
2a50: 20 72 65 61 63 68 65 64 20 74 68 65 20 70 6f 69 reached the poi
2a60: 6e 74 20 6f 6e 20 62 65 69 6e 67 20 72 65 67 69 nt on being regi
2a70: 73 74 65 72 65 64 20 61 73 20 4e 4f 54 5f 53 54 stered as NOT_ST
2a80: 41 52 54 45 44 20 61 6e 64 20 74 65 73 74 0a 09 ARTED and test..
2a90: 20 20 3b 3b 20 41 20 66 61 69 6c 65 64 20 66 6f ;; A failed fo
2aa0: 72 20 73 6f 6d 65 20 72 65 61 73 6f 6e 20 74 68 r some reason th
2ab0: 65 6e 20 6f 6e 20 72 65 2d 72 75 6e 20 75 73 69 en on re-run usi
2ac0: 6e 67 20 2d 6b 65 65 70 67 6f 69 6e 67 20 74 68 ng -keepgoing th
2ad0: 65 20 72 75 6e 20 63 61 6e 20 6e 65 76 65 72 20 e run can never
2ae0: 63 6f 6d 70 6c 65 74 65 2e 0a 09 20 20 28 63 64 complete... (cd
2af0: 62 3a 64 65 6c 65 74 65 2d 74 65 73 74 73 2d 69 b:delete-tests-i
2b00: 6e 2d 73 74 61 74 65 20 2a 72 75 6e 72 65 6d 6f n-state *runremo
2b10: 74 65 2a 20 72 75 6e 2d 69 64 20 22 4e 4f 54 5f te* run-id "NOT_
2b20: 53 54 41 52 54 45 44 22 29 0a 09 20 20 28 63 64 STARTED").. (cd
2b30: 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 64 62 3a b:remote-run db:
2b40: 73 65 74 2d 74 65 73 74 73 2d 73 74 61 74 65 2d set-tests-state-
2b50: 73 74 61 74 75 73 20 23 66 20 72 75 6e 2d 69 64 status #f run-id
2b60: 20 74 65 73 74 2d 6e 61 6d 65 73 20 23 66 20 22 test-names #f "
2b70: 46 41 49 4c 22 20 22 4e 4f 54 5f 53 54 41 52 54 FAIL" "NOT_START
2b80: 45 44 22 20 22 46 41 49 4c 22 29 29 29 0a 0a 20 ED" "FAIL")))..
2b90: 20 20 20 3b 3b 20 66 72 6f 6d 20 68 65 72 65 20 ;; from here
2ba0: 6f 6e 20 6f 75 74 20 74 68 65 20 64 62 20 77 69 on out the db wi
2bb0: 6c 6c 20 62 65 20 6f 70 65 6e 65 64 20 61 6e 64 ll be opened and
2bc0: 20 63 6c 6f 73 65 64 20 6f 6e 20 65 76 65 72 79 closed on every
2bd0: 20 63 61 6c 6c 20 72 75 6e 73 3a 72 75 6e 2d 74 call runs:run-t
2be0: 65 73 74 73 2d 71 75 65 75 65 0a 20 20 20 20 3b ests-queue. ;
2bf0: 3b 20 28 73 71 6c 69 74 65 33 3a 66 69 6e 61 6c ; (sqlite3:final
2c00: 69 7a 65 21 20 64 62 29 20 0a 20 20 20 20 3b 3b ize! db) . ;;
2c10: 20 6e 6f 77 20 61 64 64 20 6e 6f 6e 2d 64 69 72 now add non-dir
2c20: 65 63 74 6c 79 20 72 65 66 65 72 65 6e 63 65 64 ectly referenced
2c30: 20 64 65 70 65 6e 64 65 6e 63 69 65 73 20 28 69 dependencies (i
2c40: 2e 65 2e 20 77 61 69 74 6f 6e 29 0a 20 20 20 20 .e. waiton).
2c50: 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 (if (not (null?
2c60: 74 65 73 74 2d 6e 61 6d 65 73 29 29 0a 09 28 6c test-names))..(l
2c70: 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 et loop ((hed (c
2c80: 61 72 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 0a ar test-names)).
2c90: 09 09 20 20 20 28 74 61 6c 20 28 63 64 72 20 74 .. (tal (cdr t
2ca0: 65 73 74 2d 6e 61 6d 65 73 29 29 29 20 20 20 20 est-names)))
2cb0: 20 20 20 20 20 3b 3b 20 27 72 65 74 75 72 6e 2d ;; 'return-
2cc0: 70 72 6f 63 73 20 74 65 6c 6c 73 20 74 68 65 20 procs tells the
2cd0: 63 6f 6e 66 69 67 20 72 65 61 64 65 72 20 74 6f config reader to
2ce0: 20 70 72 65 70 20 72 75 6e 6e 69 6e 67 20 73 79 prep running sy
2cf0: 73 74 65 6d 20 62 75 74 20 72 65 74 75 72 6e 20 stem but return
2d00: 61 20 70 72 6f 63 0a 09 20 20 28 64 65 62 75 67 a proc.. (debug
2d10: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 68 :print-info 4 "h
2d20: 65 64 3d 22 20 68 65 64 20 22 20 61 74 20 74 6f ed=" hed " at to
2d30: 70 20 6f 66 20 6c 6f 6f 70 22 29 0a 09 20 20 28 p of loop").. (
2d40: 6c 65 74 2a 20 28 28 63 6f 6e 66 69 67 20 20 28 let* ((config (
2d50: 74 65 73 74 73 3a 67 65 74 2d 74 65 73 74 63 6f tests:get-testco
2d60: 6e 66 69 67 20 68 65 64 20 27 72 65 74 75 72 6e nfig hed 'return
2d70: 2d 70 72 6f 63 73 29 29 0a 09 09 20 28 77 61 69 -procs))... (wai
2d80: 74 6f 6e 73 20 28 6c 65 74 20 28 28 69 6e 73 74 tons (let ((inst
2d90: 72 20 28 69 66 20 63 6f 6e 66 69 67 20 0a 09 09 r (if config ...
2da0: 09 09 09 20 20 20 28 63 6f 6e 66 69 67 2d 6c 6f ... (config-lo
2db0: 6f 6b 75 70 20 63 6f 6e 66 69 67 20 22 72 65 71 okup config "req
2dc0: 75 69 72 65 6d 65 6e 74 73 22 20 22 77 61 69 74 uirements" "wait
2dd0: 6f 6e 22 29 0a 09 09 09 09 09 20 20 20 28 62 65 on")...... (be
2de0: 67 69 6e 20 3b 3b 20 4e 6f 20 63 6f 6e 66 69 67 gin ;; No config
2df0: 20 6d 65 61 6e 73 20 74 68 69 73 20 69 73 20 61 means this is a
2e00: 20 6e 6f 6e 2d 65 78 69 73 74 61 6e 74 20 74 65 non-existant te
2e10: 73 74 0a 09 09 09 09 09 20 20 20 20 20 28 64 65 st...... (de
2e20: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 bug:print 0 "ERR
2e30: 4f 52 3a 20 6e 6f 6e 2d 65 78 69 73 74 65 6e 74 OR: non-existent
2e40: 20 72 65 71 75 69 72 65 64 20 74 65 73 74 20 5c required test \
2e50: 22 22 20 68 65 64 20 22 5c 22 22 29 0a 09 09 09 "" hed "\"")....
2e60: 09 09 20 20 20 20 20 28 69 66 20 64 62 20 28 73 .. (if db (s
2e70: 71 6c 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 qlite3:finalize!
2e80: 20 64 62 29 29 0a 09 09 09 09 09 20 20 20 20 20 db))......
2e90: 28 65 78 69 74 20 31 29 29 29 29 29 0a 09 09 09 (exit 1)))))....
2ea0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
2eb0: 2d 69 6e 66 6f 20 38 20 22 77 61 69 74 6f 6e 73 -info 8 "waitons
2ec0: 20 73 74 72 69 6e 67 20 69 73 20 22 20 69 6e 73 string is " ins
2ed0: 74 72 29 0a 09 09 09 20 20 20 20 28 73 74 72 69 tr).... (stri
2ee0: 6e 67 2d 73 70 6c 69 74 20 28 63 6f 6e 64 0a 09 ng-split (cond..
2ef0: 09 09 09 09 20 20 20 28 28 70 72 6f 63 65 64 75 .... ((procedu
2f00: 72 65 3f 20 69 6e 73 74 72 29 0a 09 09 09 09 09 re? instr)......
2f10: 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 20 28 (let ((res (
2f20: 69 6e 73 74 72 29 29 29 0a 09 09 09 09 09 20 20 instr)))......
2f30: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
2f40: 2d 69 6e 66 6f 20 38 20 22 77 61 69 74 6f 6e 20 -info 8 "waiton
2f50: 70 72 6f 63 65 64 75 72 65 20 72 65 73 75 6c 74 procedure result
2f60: 73 20 69 6e 20 73 74 72 69 6e 67 20 22 20 72 65 s in string " re
2f70: 73 20 22 20 66 6f 72 20 74 65 73 74 20 22 20 68 s " for test " h
2f80: 65 64 29 0a 09 09 09 09 09 20 20 20 20 20 20 72 ed)...... r
2f90: 65 73 29 29 0a 09 09 09 09 09 20 20 20 28 28 73 es))...... ((s
2fa0: 74 72 69 6e 67 3f 20 69 6e 73 74 72 29 20 20 20 tring? instr)
2fb0: 20 20 69 6e 73 74 72 29 0a 09 09 09 09 09 20 20 instr)......
2fc0: 20 28 65 6c 73 65 20 0a 09 09 09 09 09 20 20 20 (else ......
2fd0: 20 3b 3b 20 4e 4f 54 45 3a 20 54 68 69 73 20 69 ;; NOTE: This i
2fe0: 73 20 61 63 74 75 61 6c 6c 79 20 74 68 65 20 63 s actually the c
2ff0: 61 73 65 20 6f 66 20 2a 6e 6f 2a 20 77 61 69 74 ase of *no* wait
3000: 6f 6e 73 21 20 3b 3b 20 28 64 65 62 75 67 3a 70 ons! ;; (debug:p
3010: 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 73 rint 0 "ERROR: s
3020: 6f 6d 65 74 68 69 6e 67 20 77 65 6e 74 20 77 72 omething went wr
3030: 6f 6e 67 20 69 6e 20 70 72 6f 63 65 73 73 69 6e ong in processin
3040: 67 20 77 61 69 74 6f 6e 73 20 66 6f 72 20 74 65 g waitons for te
3050: 73 74 20 22 20 68 65 64 29 0a 09 09 09 09 09 20 st " hed)......
3060: 20 20 20 22 22 29 29 29 29 29 29 0a 09 20 20 20 ""))))))..
3070: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
3080: 66 6f 20 38 20 22 77 61 69 74 6f 6e 73 3a 20 22 fo 8 "waitons: "
3090: 20 77 61 69 74 6f 6e 73 29 0a 09 20 20 20 20 3b waitons).. ;
30a0: 3b 20 63 68 65 63 6b 20 66 6f 72 20 68 65 64 20 ; check for hed
30b0: 69 6e 20 77 61 69 74 6f 6e 73 20 3d 3e 20 74 68 in waitons => th
30c0: 69 73 20 77 6f 75 6c 64 20 62 65 20 63 69 72 63 is would be circ
30d0: 75 6c 61 72 2c 20 72 65 6d 6f 76 65 20 69 74 20 ular, remove it
30e0: 61 6e 64 20 69 73 73 75 65 20 61 6e 0a 09 20 20 and issue an..
30f0: 20 20 3b 3b 20 65 72 72 6f 72 0a 09 20 20 20 20 ;; error..
3100: 28 69 66 20 28 6d 65 6d 62 65 72 20 68 65 64 20 (if (member hed
3110: 77 61 69 74 6f 6e 73 29 0a 09 09 28 62 65 67 69 waitons)...(begi
3120: 6e 0a 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 n... (debug:pri
3130: 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 74 65 73 nt 0 "ERROR: tes
3140: 74 20 22 20 68 65 64 20 22 20 68 61 73 20 6c 69 t " hed " has li
3150: 73 74 65 64 20 69 74 73 65 6c 66 20 61 73 20 61 sted itself as a
3160: 20 77 61 69 74 6f 6e 2c 20 70 6c 65 61 73 65 20 waiton, please
3170: 63 6f 72 72 65 63 74 20 74 68 69 73 21 22 29 0a correct this!").
3180: 09 09 20 20 28 73 65 74 21 20 77 61 69 74 6f 6e .. (set! waiton
3190: 73 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 s (filter (lambd
31a0: 61 20 28 78 29 28 6e 6f 74 20 28 65 71 75 61 6c a (x)(not (equal
31b0: 3f 20 78 20 68 65 64 29 29 29 20 77 61 69 74 6f ? x hed))) waito
31c0: 6e 73 29 29 29 29 0a 09 20 20 20 20 0a 09 20 20 ns)))).. ..
31d0: 20 20 3b 3b 20 28 69 74 65 6d 73 20 20 20 28 69 ;; (items (i
31e0: 74 65 6d 73 3a 67 65 74 2d 69 74 65 6d 73 2d 66 tems:get-items-f
31f0: 72 6f 6d 2d 63 6f 6e 66 69 67 20 63 6f 6e 66 69 rom-config confi
3200: 67 29 29 29 0a 09 20 20 20 20 28 69 66 20 28 6e g))).. (if (n
3210: 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 ot (hash-table-r
3220: 65 66 2f 64 65 66 61 75 6c 74 20 74 65 73 74 2d ef/default test-
3230: 72 65 63 6f 72 64 73 20 68 65 64 20 23 66 29 29 records hed #f))
3240: 0a 09 09 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 ...(hash-table-s
3250: 65 74 21 20 74 65 73 74 2d 72 65 63 6f 72 64 73 et! test-records
3260: 0a 09 09 09 09 20 68 65 64 20 28 76 65 63 74 6f ..... hed (vecto
3270: 72 20 68 65 64 20 20 20 20 20 3b 3b 20 30 0a 09 r hed ;; 0..
3280: 09 09 09 09 20 20 20 20 20 63 6f 6e 66 69 67 20 .... config
3290: 20 3b 3b 20 31 0a 09 09 09 09 09 20 20 20 20 20 ;; 1......
32a0: 77 61 69 74 6f 6e 73 20 3b 3b 20 32 0a 09 09 09 waitons ;; 2....
32b0: 09 09 20 20 20 20 20 28 63 6f 6e 66 69 67 2d 6c .. (config-l
32c0: 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 20 22 72 65 ookup config "re
32d0: 71 75 69 72 65 6d 65 6e 74 73 22 20 22 70 72 69 quirements" "pri
32e0: 6f 72 69 74 79 22 29 20 20 20 20 20 3b 3b 20 70 ority") ;; p
32f0: 72 69 6f 72 69 74 79 20 33 0a 09 09 09 09 09 20 riority 3......
3300: 20 20 20 20 28 6c 65 74 20 28 28 69 74 65 6d 73 (let ((items
3310: 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c (hash-tabl
3320: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 63 6f e-ref/default co
3330: 6e 66 69 67 20 22 69 74 65 6d 73 22 20 23 66 29 nfig "items" #f)
3340: 29 20 3b 3b 20 69 74 65 6d 73 20 34 0a 09 09 09 ) ;; items 4....
3350: 09 09 09 20 20 20 28 69 74 65 6d 73 74 61 62 6c ... (itemstabl
3360: 65 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 e (hash-table-re
3370: 66 2f 64 65 66 61 75 6c 74 20 63 6f 6e 66 69 67 f/default config
3380: 20 22 69 74 65 6d 73 74 61 62 6c 65 22 20 23 66 "itemstable" #f
3390: 29 29 29 20 0a 09 09 09 09 09 20 20 20 20 20 20 ))) ......
33a0: 20 3b 3b 20 69 66 20 65 69 74 68 65 72 20 69 74 ;; if either it
33b0: 65 6d 73 20 6f 72 20 69 74 65 6d 73 20 74 61 62 ems or items tab
33c0: 6c 65 20 69 73 20 61 20 70 72 6f 63 20 72 65 74 le is a proc ret
33d0: 75 72 6e 20 69 74 20 73 6f 20 74 65 73 74 20 72 urn it so test r
33e0: 75 6e 6e 69 6e 67 0a 09 09 09 09 09 20 20 20 20 unning......
33f0: 20 20 20 3b 3b 20 70 72 6f 63 65 73 73 20 63 61 ;; process ca
3400: 6e 20 6b 6e 6f 77 20 74 6f 20 63 61 6c 6c 20 69 n know to call i
3410: 74 65 6d 73 3a 67 65 74 2d 69 74 65 6d 73 2d 66 tems:get-items-f
3420: 72 6f 6d 2d 63 6f 6e 66 69 67 0a 09 09 09 09 09 rom-config......
3430: 20 20 20 20 20 20 20 3b 3b 20 69 66 20 65 69 74 ;; if eit
3440: 68 65 72 20 69 73 20 61 20 6c 69 73 74 20 61 6e her is a list an
3450: 64 20 6e 6f 6e 65 20 69 73 20 61 20 70 72 6f 63 d none is a proc
3460: 20 67 6f 20 61 68 65 61 64 20 61 6e 64 20 63 61 go ahead and ca
3470: 6c 6c 20 67 65 74 2d 69 74 65 6d 73 0a 09 09 09 ll get-items....
3480: 09 09 20 20 20 20 20 20 20 3b 3b 20 6f 74 68 65 .. ;; othe
3490: 72 77 69 73 65 20 72 65 74 75 72 6e 20 23 66 20 rwise return #f
34a0: 2d 20 74 68 69 73 20 69 73 20 6e 6f 74 20 61 6e - this is not an
34b0: 20 69 74 65 72 61 74 65 64 20 74 65 73 74 0a 09 iterated test..
34c0: 09 09 09 09 20 20 20 20 20 20 20 28 63 6f 6e 64 .... (cond
34d0: 0a 09 09 09 09 09 09 28 28 70 72 6f 63 65 64 75 .......((procedu
34e0: 72 65 3f 20 69 74 65 6d 73 29 20 20 20 20 20 20 re? items)
34f0: 0a 09 09 09 09 09 09 20 28 64 65 62 75 67 3a 70 ....... (debug:p
3500: 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 69 74 65 rint-info 4 "ite
3510: 6d 73 20 69 73 20 61 20 70 72 6f 63 65 64 75 72 ms is a procedur
3520: 65 2c 20 77 69 6c 6c 20 63 61 6c 63 20 6c 61 74 e, will calc lat
3530: 65 72 22 29 0a 09 09 09 09 09 09 20 69 74 65 6d er")....... item
3540: 73 29 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b s) ;;
3550: 20 63 61 6c 63 20 6c 61 74 65 72 0a 09 09 09 09 calc later.....
3560: 09 09 28 28 70 72 6f 63 65 64 75 72 65 3f 20 69 ..((procedure? i
3570: 74 65 6d 73 74 61 62 6c 65 29 0a 09 09 09 09 09 temstable)......
3580: 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 . (debug:print-i
3590: 6e 66 6f 20 34 20 22 69 74 65 6d 73 74 61 62 6c nfo 4 "itemstabl
35a0: 65 20 69 73 20 61 20 70 72 6f 63 65 64 75 72 65 e is a procedure
35b0: 2c 20 77 69 6c 6c 20 63 61 6c 63 20 6c 61 74 65 , will calc late
35c0: 72 22 29 0a 09 09 09 09 09 09 20 69 74 65 6d 73 r")....... items
35d0: 74 61 62 6c 65 29 20 20 20 20 20 20 20 3b 3b 20 table) ;;
35e0: 63 61 6c 63 20 6c 61 74 65 72 0a 09 09 09 09 09 calc later......
35f0: 09 28 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 .((filter (lambd
3600: 61 20 28 78 29 0a 09 09 09 09 09 09 09 20 20 20 a (x)........
3610: 28 6c 65 74 20 28 28 76 61 6c 20 28 63 61 72 20 (let ((val (car
3620: 78 29 29 29 0a 09 09 09 09 09 09 09 20 20 20 20 x)))........
3630: 20 28 69 66 20 28 70 72 6f 63 65 64 75 72 65 3f (if (procedure?
3640: 20 76 61 6c 29 20 76 61 6c 20 23 66 29 29 29 0a val) val #f))).
3650: 09 09 09 09 09 09 09 20 28 61 70 70 65 6e 64 20 ....... (append
3660: 28 69 66 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 (if (list? items
3670: 29 20 69 74 65 6d 73 20 27 28 29 29 0a 09 09 09 ) items '())....
3680: 09 09 09 09 09 20 28 69 66 20 28 6c 69 73 74 3f ..... (if (list?
3690: 20 69 74 65 6d 73 74 61 62 6c 65 29 20 69 74 65 itemstable) ite
36a0: 6d 73 74 61 62 6c 65 20 27 28 29 29 29 29 0a 09 mstable '())))..
36b0: 09 09 09 09 09 20 27 68 61 76 65 2d 70 72 6f 63 ..... 'have-proc
36c0: 65 64 75 72 65 29 0a 09 09 09 09 09 09 28 28 6f edure).......((o
36d0: 72 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 28 r (list? items)(
36e0: 6c 69 73 74 3f 20 69 74 65 6d 73 74 61 62 6c 65 list? itemstable
36f0: 29 29 20 3b 3b 20 63 61 6c 63 20 6e 6f 77 0a 09 )) ;; calc now..
3700: 09 09 09 09 09 20 28 64 65 62 75 67 3a 70 72 69 ..... (debug:pri
3710: 6e 74 2d 69 6e 66 6f 20 34 20 22 69 74 65 6d 73 nt-info 4 "items
3720: 20 61 6e 64 20 69 74 65 6d 73 74 61 62 6c 65 20 and itemstable
3730: 61 72 65 20 6c 69 73 74 73 2c 20 63 61 6c 63 20 are lists, calc
3740: 6e 6f 77 5c 6e 22 0a 09 09 09 09 09 09 09 20 20 now\n"........
3750: 20 20 20 20 22 20 20 20 20 69 74 65 6d 73 3a 20 " items:
3760: 22 20 69 74 65 6d 73 20 22 20 69 74 65 6d 73 74 " items " itemst
3770: 61 62 6c 65 3a 20 22 20 69 74 65 6d 73 74 61 62 able: " itemstab
3780: 6c 65 29 0a 09 09 09 09 09 09 20 28 69 74 65 6d le)....... (item
3790: 73 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d s:get-items-from
37a0: 2d 63 6f 6e 66 69 67 20 63 6f 6e 66 69 67 29 29 -config config))
37b0: 0a 09 09 09 09 09 09 28 65 6c 73 65 20 23 66 29 .......(else #f)
37c0: 29 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ))
37d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ;;
37e0: 6e 6f 74 20 69 74 65 72 61 74 65 64 0a 09 09 09 not iterated....
37f0: 09 09 20 20 20 20 20 23 66 20 20 20 20 20 20 3b .. #f ;
3800: 3b 20 69 74 65 6d 73 64 61 74 20 35 0a 09 09 09 ; itemsdat 5....
3810: 09 09 20 20 20 20 20 23 66 20 20 20 20 20 20 3b .. #f ;
3820: 3b 20 73 70 61 72 65 20 2d 20 75 73 65 64 20 66 ; spare - used f
3830: 6f 72 20 69 74 65 6d 2d 70 61 74 68 0a 09 09 09 or item-path....
3840: 09 09 20 20 20 20 20 29 29 29 0a 09 20 20 20 20 .. )))..
3850: 28 66 6f 72 2d 65 61 63 68 20 0a 09 20 20 20 20 (for-each ..
3860: 20 28 6c 61 6d 62 64 61 20 28 77 61 69 74 6f 6e (lambda (waiton
3870: 29 0a 09 20 20 20 20 20 20 20 28 69 66 20 28 61 ).. (if (a
3880: 6e 64 20 77 61 69 74 6f 6e 20 28 6e 6f 74 20 28 nd waiton (not (
3890: 6d 65 6d 62 65 72 20 77 61 69 74 6f 6e 20 74 65 member waiton te
38a0: 73 74 2d 6e 61 6d 65 73 29 29 29 0a 09 09 20 20 st-names)))...
38b0: 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 20 28 (begin... (
38c0: 73 65 74 21 20 72 65 71 75 69 72 65 64 2d 74 65 set! required-te
38d0: 73 74 73 20 28 63 6f 6e 73 20 77 61 69 74 6f 6e sts (cons waiton
38e0: 20 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 29 required-tests)
38f0: 29 0a 09 09 20 20 20 20 20 28 73 65 74 21 20 74 )... (set! t
3900: 65 73 74 2d 6e 61 6d 65 73 20 28 63 6f 6e 73 20 est-names (cons
3910: 77 61 69 74 6f 6e 20 74 65 73 74 2d 6e 61 6d 65 waiton test-name
3920: 73 29 29 29 29 29 20 3b 3b 20 77 61 73 20 61 6e s))))) ;; was an
3930: 20 61 70 70 65 6e 64 2c 20 6e 6f 77 20 61 20 63 append, now a c
3940: 6f 6e 73 0a 09 20 20 20 20 20 77 61 69 74 6f 6e ons.. waiton
3950: 73 29 0a 09 20 20 20 20 28 6c 65 74 20 28 28 72 s).. (let ((r
3960: 65 6d 74 65 73 74 73 20 28 64 65 6c 65 74 65 2d emtests (delete-
3970: 64 75 70 6c 69 63 61 74 65 73 20 28 61 70 70 65 duplicates (appe
3980: 6e 64 20 77 61 69 74 6f 6e 73 20 74 61 6c 29 29 nd waitons tal))
3990: 29 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 6e )).. (if (n
39a0: 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 6d 74 65 73 ot (null? remtes
39b0: 74 73 29 29 0a 09 09 20 20 28 6c 6f 6f 70 20 28 ts))... (loop (
39c0: 63 61 72 20 72 65 6d 74 65 73 74 73 29 28 63 64 car remtests)(cd
39d0: 72 20 72 65 6d 74 65 73 74 73 29 29 29 29 29 29 r remtests))))))
39e0: 29 0a 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 ).. (if (not
39f0: 28 6e 75 6c 6c 3f 20 72 65 71 75 69 72 65 64 2d (null? required-
3a00: 74 65 73 74 73 29 29 0a 09 28 64 65 62 75 67 3a tests))..(debug:
3a10: 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 22 41 64 print-info 1 "Ad
3a20: 64 69 6e 67 20 22 20 72 65 71 75 69 72 65 64 2d ding " required-
3a30: 74 65 73 74 73 20 22 20 74 6f 20 74 68 65 20 72 tests " to the r
3a40: 75 6e 20 71 75 65 75 65 22 29 29 0a 20 20 20 20 un queue")).
3a50: 3b 3b 20 4e 4f 54 45 3a 20 74 68 65 73 65 20 61 ;; NOTE: these a
3a60: 72 65 20 61 6c 6c 20 70 61 72 65 6e 74 20 74 65 re all parent te
3a70: 73 74 73 2c 20 69 74 65 6d 73 20 61 72 65 20 6e sts, items are n
3a80: 6f 74 20 65 78 70 61 6e 64 65 64 20 79 65 74 2e ot expanded yet.
3a90: 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
3aa0: 74 2d 69 6e 66 6f 20 34 20 22 74 65 73 74 2d 72 t-info 4 "test-r
3ab0: 65 63 6f 72 64 73 3d 22 20 28 68 61 73 68 2d 74 ecords=" (hash-t
3ac0: 61 62 6c 65 2d 3e 61 6c 69 73 74 20 74 65 73 74 able->alist test
3ad0: 2d 72 65 63 6f 72 64 73 29 29 0a 20 20 20 20 28 -records)). (
3ae0: 6c 65 74 20 28 28 72 65 67 6c 65 6e 20 28 61 6e let ((reglen (an
3af0: 79 2d 3e 6e 75 6d 62 65 72 20 20 28 63 6f 6e 66 y->number (conf
3b00: 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 igf:lookup *conf
3b10: 69 67 64 61 74 2a 20 22 73 65 74 75 70 22 20 22 igdat* "setup" "
3b20: 72 75 6e 71 75 65 75 65 22 29 29 29 29 0a 20 20 runqueue")))).
3b30: 20 20 20 20 28 69 66 20 72 65 67 6c 65 6e 0a 09 (if reglen..
3b40: 20 20 28 72 75 6e 73 3a 72 75 6e 2d 74 65 73 74 (runs:run-test
3b50: 73 2d 71 75 65 75 65 2d 6e 65 77 20 72 75 6e 2d s-queue-new run-
3b60: 69 64 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 2d id runname test-
3b70: 72 65 63 6f 72 64 73 20 66 6c 61 67 73 20 74 65 records flags te
3b80: 73 74 2d 70 61 74 74 73 20 72 65 67 6c 65 6e 29 st-patts reglen)
3b90: 0a 09 20 20 28 72 75 6e 73 3a 72 75 6e 2d 74 65 .. (runs:run-te
3ba0: 73 74 73 2d 71 75 65 75 65 2d 63 6c 61 73 73 69 sts-queue-classi
3bb0: 63 20 72 75 6e 2d 69 64 20 72 75 6e 6e 61 6d 65 c run-id runname
3bc0: 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 66 6c test-records fl
3bd0: 61 67 73 20 74 65 73 74 2d 70 61 74 74 73 29 29 ags test-patts))
3be0: 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 ). (debug:pri
3bf0: 6e 74 2d 69 6e 66 6f 20 34 20 22 41 6c 6c 20 64 nt-info 4 "All d
3c00: 6f 6e 65 20 62 79 20 68 65 72 65 22 29 29 29 0a one by here"))).
3c10: 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 63 .(define (runs:c
3c20: 61 6c 63 2d 66 61 69 6c 73 20 70 72 65 72 65 71 alc-fails prereq
3c30: 73 2d 6e 6f 74 2d 6d 65 74 29 0a 20 20 28 66 69 s-not-met). (fi
3c40: 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 74 65 lter (lambda (te
3c50: 73 74 29 0a 09 20 20 20 20 28 61 6e 64 20 28 76 st).. (and (v
3c60: 65 63 74 6f 72 3f 20 74 65 73 74 29 20 3b 3b 20 ector? test) ;;
3c70: 6e 6f 74 20 28 73 74 72 69 6e 67 3f 20 74 65 73 not (string? tes
3c80: 74 29 29 0a 09 09 20 28 65 71 75 61 6c 3f 20 28 t))... (equal? (
3c90: 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 db:test-get-stat
3ca0: 65 20 74 65 73 74 29 20 22 43 4f 4d 50 4c 45 54 e test) "COMPLET
3cb0: 45 44 22 29 0a 09 09 20 28 6e 6f 74 20 28 6d 65 ED")... (not (me
3cc0: 6d 62 65 72 20 28 64 62 3a 74 65 73 74 2d 67 65 mber (db:test-ge
3cd0: 74 2d 73 74 61 74 75 73 20 74 65 73 74 29 0a 09 t-status test)..
3ce0: 09 09 20 20 20 20 20 20 27 28 22 50 41 53 53 22 .. '("PASS"
3cf0: 20 22 57 41 52 4e 22 20 22 43 48 45 43 4b 22 20 "WARN" "CHECK"
3d00: 22 57 41 49 56 45 44 22 20 22 53 4b 49 50 22 29 "WAIVED" "SKIP")
3d10: 29 29 29 29 0a 09 20 20 70 72 65 72 65 71 73 2d )))).. prereqs-
3d20: 6e 6f 74 2d 6d 65 74 29 29 0a 0a 28 64 65 66 69 not-met))..(defi
3d30: 6e 65 20 28 72 75 6e 73 3a 63 61 6c 63 2d 6e 6f ne (runs:calc-no
3d40: 74 2d 63 6f 6d 70 6c 65 74 65 64 20 70 72 65 72 t-completed prer
3d50: 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 0a 20 20 28 eqs-not-met). (
3d60: 66 69 6c 74 65 72 0a 20 20 20 28 6c 61 6d 62 64 filter. (lambd
3d70: 61 20 28 74 29 0a 20 20 20 20 20 28 6f 72 20 28 a (t). (or (
3d80: 6e 6f 74 20 28 76 65 63 74 6f 72 3f 20 74 29 29 not (vector? t))
3d90: 0a 09 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 .. (not (equal?
3da0: 22 43 4f 4d 50 4c 45 54 45 44 22 20 28 64 62 3a "COMPLETED" (db:
3db0: 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 74 test-get-state t
3dc0: 29 29 29 29 29 0a 20 20 20 70 72 65 72 65 71 73 ))))). prereqs
3dd0: 2d 6e 6f 74 2d 6d 65 74 29 29 0a 0a 28 64 65 66 -not-met))..(def
3de0: 69 6e 65 20 28 72 75 6e 73 3a 70 72 65 74 74 79 ine (runs:pretty
3df0: 2d 73 74 72 69 6e 67 20 6c 73 74 29 0a 20 20 28 -string lst). (
3e00: 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 74 29 0a map (lambda (t).
3e10: 09 20 28 69 66 20 28 6e 6f 74 20 28 76 65 63 74 . (if (not (vect
3e20: 6f 72 3f 20 74 29 29 0a 09 20 20 20 20 20 28 63 or? t)).. (c
3e30: 6f 6e 63 20 74 29 0a 09 20 20 20 20 20 28 63 6f onc t).. (co
3e40: 6e 63 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d nc (db:test-get-
3e50: 74 65 73 74 6e 61 6d 65 20 74 29 20 22 3a 22 20 testname t) ":"
3e60: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 (db:test-get-sta
3e70: 74 65 20 74 29 20 22 2f 22 20 28 64 62 3a 74 65 te t) "/" (db:te
3e80: 73 74 2d 67 65 74 2d 73 74 61 74 75 73 20 74 29 st-get-status t)
3e90: 29 29 29 0a 20 20 20 20 20 20 20 6c 73 74 29 29 ))). lst))
3ea0: 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a ..(define (runs:
3eb0: 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 74 2d 6e make-full-test-n
3ec0: 61 6d 65 20 74 65 73 74 6e 61 6d 65 20 69 74 65 ame testname ite
3ed0: 6d 70 61 74 68 29 0a 20 20 28 69 66 20 28 65 71 mpath). (if (eq
3ee0: 75 61 6c 3f 20 69 74 65 6d 70 61 74 68 20 22 22 ual? itempath ""
3ef0: 29 20 74 65 73 74 6e 61 6d 65 20 28 63 6f 6e 63 ) testname (conc
3f00: 20 74 65 73 74 6e 61 6d 65 20 22 2f 22 20 69 74 testname "/" it
3f10: 65 6d 70 61 74 68 29 29 29 0a 0a 28 64 65 66 69 empath)))..(defi
3f20: 6e 65 20 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e ne (runs:queue-n
3f30: 65 78 74 2d 68 65 64 20 74 61 6c 20 72 65 67 20 ext-hed tal reg
3f40: 6e 20 72 65 67 66 75 6c 29 0a 20 20 28 69 66 20 n regful). (if
3f50: 72 65 67 66 75 6c 0a 20 20 20 20 20 20 28 69 66 regful. (if
3f60: 20 28 6e 75 6c 6c 3f 20 72 65 67 29 20 3b 3b 20 (null? reg) ;;
3f70: 64 6f 65 73 6e 27 74 20 6d 61 6b 65 20 73 65 6e doesn't make sen
3f80: 73 65 2c 20 74 68 69 73 20 69 73 20 70 72 6f 62 se, this is prob
3f90: 61 62 6c 79 20 4e 4f 54 20 74 68 65 20 70 72 6f ably NOT the pro
3fa0: 62 6c 65 6d 20 6f 66 20 74 68 65 20 63 61 72 0a blem of the car.
3fb0: 09 20 20 28 63 61 72 20 74 61 6c 29 0a 09 20 20 . (car tal)..
3fc0: 28 63 61 72 20 72 65 67 29 29 0a 20 20 20 20 20 (car reg)).
3fd0: 20 28 63 61 72 20 74 61 6c 29 29 29 0a 0a 28 64 (car tal)))..(d
3fe0: 65 66 69 6e 65 20 28 72 75 6e 73 3a 71 75 65 75 efine (runs:queu
3ff0: 65 2d 6e 65 78 74 2d 74 61 6c 20 74 61 6c 20 72 e-next-tal tal r
4000: 65 67 20 6e 20 72 65 67 66 75 6c 29 0a 20 20 28 eg n regful). (
4010: 69 66 20 72 65 67 66 75 6c 0a 20 20 20 20 20 20 if regful.
4020: 74 61 6c 0a 20 20 20 20 20 20 28 6c 65 74 20 28 tal. (let (
4030: 28 6e 65 77 74 61 6c 20 28 63 64 72 20 74 61 6c (newtal (cdr tal
4040: 29 29 29 0a 09 28 69 66 20 28 6e 75 6c 6c 3f 20 )))..(if (null?
4050: 6e 65 77 74 61 6c 29 0a 09 20 20 20 20 72 65 67 newtal).. reg
4060: 0a 09 20 20 20 20 6e 65 77 74 61 6c 0a 09 20 20 .. newtal..
4070: 20 20 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ))))..(define
4080: 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 (runs:queue-next
4090: 2d 72 65 67 20 74 61 6c 20 72 65 67 20 6e 20 72 -reg tal reg n r
40a0: 65 67 66 75 6c 29 0a 20 20 28 69 66 20 72 65 67 egful). (if reg
40b0: 66 75 6c 0a 20 20 20 20 20 20 28 63 64 72 20 72 ful. (cdr r
40c0: 65 67 29 0a 20 20 20 20 20 20 28 69 66 20 28 65 eg). (if (e
40d0: 71 3f 20 28 6c 65 6e 67 74 68 20 74 61 6c 29 20 q? (length tal)
40e0: 31 29 0a 09 20 20 27 28 29 0a 09 20 20 72 65 67 1).. '().. reg
40f0: 29 29 29 0a 0a 28 69 6e 63 6c 75 64 65 20 22 72 )))..(include "r
4100: 75 6e 2d 74 65 73 74 73 2d 71 75 65 75 65 2d 63 un-tests-queue-c
4110: 6c 61 73 73 69 63 2e 73 63 6d 22 29 0a 28 69 6e lassic.scm").(in
4120: 63 6c 75 64 65 20 22 72 75 6e 2d 74 65 73 74 73 clude "run-tests
4130: 2d 71 75 65 75 65 2d 6e 65 77 2e 73 63 6d 22 29 -queue-new.scm")
4140: 0a 0a 3b 3b 20 70 61 72 65 6e 74 2d 74 65 73 74 ..;; parent-test
4150: 20 69 73 20 74 68 65 72 65 20 61 73 20 61 20 70 is there as a p
4160: 6c 61 63 65 68 6f 6c 64 65 72 20 66 6f 72 20 77 laceholder for w
4170: 68 65 6e 20 70 61 72 65 6e 74 2d 74 65 73 74 73 hen parent-tests
4180: 20 63 61 6e 20 62 65 20 72 75 6e 20 61 73 20 61 can be run as a
4190: 20 73 65 74 75 70 20 73 74 65 70 0a 28 64 65 66 setup step.(def
41a0: 69 6e 65 20 28 72 75 6e 3a 74 65 73 74 20 72 75 ine (run:test ru
41b0: 6e 2d 69 64 20 72 75 6e 2d 69 6e 66 6f 20 6b 65 n-id run-info ke
41c0: 79 2d 76 61 6c 73 20 72 75 6e 6e 61 6d 65 20 74 y-vals runname t
41d0: 65 73 74 2d 72 65 63 6f 72 64 20 66 6c 61 67 73 est-record flags
41e0: 20 70 61 72 65 6e 74 2d 74 65 73 74 29 0a 20 20 parent-test).
41f0: 3b 3b 20 41 6c 6c 20 74 68 65 73 65 20 76 61 72 ;; All these var
4200: 73 20 6d 69 67 68 74 20 62 65 20 72 65 66 65 72 s might be refer
4210: 65 6e 63 65 64 20 62 79 20 74 68 65 20 74 65 73 enced by the tes
4220: 74 63 6f 6e 66 69 67 20 66 69 6c 65 20 72 65 61 tconfig file rea
4230: 64 65 72 0a 20 20 28 6c 65 74 2a 20 28 28 74 65 der. (let* ((te
4240: 73 74 2d 6e 61 6d 65 20 20 20 20 28 74 65 73 74 st-name (test
4250: 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d s:testqueue-get-
4260: 74 65 73 74 6e 61 6d 65 20 20 20 74 65 73 74 2d testname test-
4270: 72 65 63 6f 72 64 29 29 0a 09 20 28 74 65 73 74 record)).. (test
4280: 2d 77 61 69 74 6f 6e 73 20 28 74 65 73 74 73 3a -waitons (tests:
4290: 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 77 61 testqueue-get-wa
42a0: 69 74 6f 6e 73 20 20 20 20 74 65 73 74 2d 72 65 itons test-re
42b0: 63 6f 72 64 29 29 0a 09 20 28 74 65 73 74 2d 63 cord)).. (test-c
42c0: 6f 6e 66 20 20 20 20 28 74 65 73 74 73 3a 74 65 onf (tests:te
42d0: 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 73 74 stqueue-get-test
42e0: 63 6f 6e 66 69 67 20 74 65 73 74 2d 72 65 63 6f config test-reco
42f0: 72 64 29 29 0a 09 20 28 69 74 65 6d 64 61 74 20 rd)).. (itemdat
4300: 20 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 (tests:test
4310: 71 75 65 75 65 2d 67 65 74 2d 69 74 65 6d 64 61 queue-get-itemda
4320: 74 20 20 20 20 74 65 73 74 2d 72 65 63 6f 72 64 t test-record
4330: 29 29 0a 09 20 28 74 65 73 74 2d 70 61 74 68 20 )).. (test-path
4340: 20 20 20 28 63 6f 6e 63 20 2a 74 6f 70 70 61 74 (conc *toppat
4350: 68 2a 20 22 2f 74 65 73 74 73 2f 22 20 74 65 73 h* "/tests/" tes
4360: 74 2d 6e 61 6d 65 29 29 20 3b 3b 20 63 6f 75 6c t-name)) ;; coul
4370: 64 20 75 73 65 20 74 65 73 74 73 3a 67 65 74 2d d use tests:get-
4380: 74 65 73 74 63 6f 6e 66 69 67 20 68 65 72 65 20 testconfig here
4390: 2e 2e 2e 0a 09 20 28 66 6f 72 63 65 20 20 20 20 ..... (force
43a0: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
43b0: 72 65 66 2f 64 65 66 61 75 6c 74 20 66 6c 61 67 ref/default flag
43c0: 73 20 22 2d 66 6f 72 63 65 22 20 23 66 29 29 0a s "-force" #f)).
43d0: 09 20 28 72 65 72 75 6e 20 20 20 20 20 20 20 20 . (rerun
43e0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
43f0: 64 65 66 61 75 6c 74 20 66 6c 61 67 73 20 22 2d default flags "-
4400: 72 65 72 75 6e 22 20 23 66 29 29 0a 09 20 28 6b rerun" #f)).. (k
4410: 65 65 70 67 6f 69 6e 67 20 20 20 20 28 68 61 73 eepgoing (has
4420: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
4430: 75 6c 74 20 66 6c 61 67 73 20 22 2d 6b 65 65 70 ult flags "-keep
4440: 67 6f 69 6e 67 22 20 23 66 29 29 0a 09 20 28 69 going" #f)).. (i
4450: 74 65 6d 2d 70 61 74 68 20 20 20 20 20 22 22 29 tem-path "")
4460: 0a 09 20 28 64 62 20 20 20 20 20 20 20 20 20 20 .. (db
4470: 20 23 66 29 29 0a 20 20 20 20 28 64 65 62 75 67 #f)). (debug
4480: 3a 70 72 69 6e 74 20 34 0a 09 09 20 22 74 65 73 :print 4... "tes
4490: 74 2d 63 6f 6e 66 69 67 3a 20 22 20 28 68 61 73 t-config: " (has
44a0: 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 20 74 h-table->alist t
44b0: 65 73 74 2d 63 6f 6e 66 29 0a 09 09 20 22 5c 6e est-conf)... "\n
44c0: 20 20 20 69 74 65 6d 64 61 74 3a 20 22 20 69 74 itemdat: " it
44d0: 65 6d 64 61 74 0a 09 09 20 29 0a 20 20 20 20 3b emdat... ). ;
44e0: 3b 20 73 65 74 74 69 6e 67 20 69 74 65 6d 64 61 ; setting itemda
44f0: 74 20 74 6f 20 61 20 6c 69 73 74 20 69 66 20 69 t to a list if i
4500: 74 20 69 73 20 23 66 0a 20 20 20 20 28 69 66 20 t is #f. (if
4510: 28 6e 6f 74 20 69 74 65 6d 64 61 74 29 28 73 65 (not itemdat)(se
4520: 74 21 20 69 74 65 6d 64 61 74 20 27 28 29 29 29 t! itemdat '()))
4530: 0a 20 20 20 20 28 73 65 74 21 20 69 74 65 6d 2d . (set! item-
4540: 70 61 74 68 20 28 69 74 65 6d 2d 6c 69 73 74 2d path (item-list-
4550: 3e 70 61 74 68 20 69 74 65 6d 64 61 74 29 29 0a >path itemdat)).
4560: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
4570: 20 32 20 22 41 74 74 65 6d 70 74 69 6e 67 20 74 2 "Attempting t
4580: 6f 20 6c 61 75 6e 63 68 20 74 65 73 74 20 22 20 o launch test "
4590: 74 65 73 74 2d 6e 61 6d 65 20 28 69 66 20 28 65 test-name (if (e
45a0: 71 75 61 6c 3f 20 69 74 65 6d 2d 70 61 74 68 20 qual? item-path
45b0: 22 2f 22 29 20 22 2f 22 20 69 74 65 6d 2d 70 61 "/") "/" item-pa
45c0: 74 68 29 29 0a 20 20 20 20 28 73 65 74 65 6e 76 th)). (setenv
45d0: 20 22 4d 54 5f 54 45 53 54 5f 4e 41 4d 45 22 20 "MT_TEST_NAME"
45e0: 74 65 73 74 2d 6e 61 6d 65 29 20 3b 3b 20 0a 20 test-name) ;; .
45f0: 20 20 20 28 73 65 74 65 6e 76 20 22 4d 54 5f 52 (setenv "MT_R
4600: 55 4e 4e 41 4d 45 22 20 20 20 72 75 6e 6e 61 6d UNNAME" runnam
4610: 65 29 0a 20 20 20 20 28 73 65 74 2d 6d 65 67 61 e). (set-mega
4620: 74 65 73 74 2d 65 6e 76 2d 76 61 72 73 20 72 75 test-env-vars ru
4630: 6e 2d 69 64 20 69 6e 72 75 6e 6e 61 6d 65 3a 20 n-id inrunname:
4640: 72 75 6e 6e 61 6d 65 29 20 3b 3b 20 74 68 65 73 runname) ;; thes
4650: 65 20 6d 61 79 20 62 65 20 6e 65 65 64 65 64 20 e may be needed
4660: 62 79 20 74 68 65 20 6c 61 75 6e 63 68 69 6e 67 by the launching
4670: 20 70 72 6f 63 65 73 73 0a 20 20 20 20 28 63 68 process. (ch
4680: 61 6e 67 65 2d 64 69 72 65 63 74 6f 72 79 20 2a ange-directory *
4690: 74 6f 70 70 61 74 68 2a 29 0a 0a 20 20 20 20 3b toppath*).. ;
46a0: 3b 20 48 65 72 65 20 69 73 20 77 68 65 72 65 20 ; Here is where
46b0: 74 68 65 20 74 65 73 74 5f 6d 65 74 61 20 74 61 the test_meta ta
46c0: 62 6c 65 20 69 73 20 62 65 73 74 20 75 70 64 61 ble is best upda
46d0: 74 65 64 0a 20 20 20 20 3b 3b 20 59 65 73 2c 20 ted. ;; Yes,
46e0: 61 6e 6f 74 68 65 72 20 75 73 65 20 6f 66 20 61 another use of a
46f0: 20 67 6c 6f 62 61 6c 20 66 6f 72 20 63 61 63 68 global for cach
4700: 69 6e 67 2e 20 4e 65 65 64 20 61 20 62 65 74 74 ing. Need a bett
4710: 65 72 20 77 61 79 3f 0a 20 20 20 20 28 69 66 20 er way?. (if
4720: 28 6e 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 (not (hash-table
4730: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 74 65 -ref/default *te
4740: 73 74 2d 6d 65 74 61 2d 75 70 64 61 74 65 64 2a st-meta-updated*
4750: 20 74 65 73 74 2d 6e 61 6d 65 20 23 66 29 29 0a test-name #f)).
4760: 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 (begin..
4770: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 (hash-table-s
4780: 65 74 21 20 2a 74 65 73 74 2d 6d 65 74 61 2d 75 et! *test-meta-u
4790: 70 64 61 74 65 64 2a 20 74 65 73 74 2d 6e 61 6d pdated* test-nam
47a0: 65 20 23 74 29 0a 20 20 20 20 20 20 20 20 20 20 e #t).
47b0: 20 28 72 75 6e 73 3a 75 70 64 61 74 65 2d 74 65 (runs:update-te
47c0: 73 74 5f 6d 65 74 61 20 74 65 73 74 2d 6e 61 6d st_meta test-nam
47d0: 65 20 74 65 73 74 2d 63 6f 6e 66 29 29 29 0a 20 e test-conf))).
47e0: 20 20 20 0a 20 20 20 20 3b 3b 20 28 6c 61 6d 62 . ;; (lamb
47f0: 64 61 20 28 69 74 65 6d 64 61 74 29 20 3b 3b 3b da (itemdat) ;;;
4800: 20 28 28 72 69 70 65 6e 65 73 73 20 22 6f 76 65 ((ripeness "ove
4810: 72 72 69 70 65 22 29 20 28 74 65 6d 70 65 72 61 rripe") (tempera
4820: 74 75 72 65 20 22 63 6f 6f 6c 22 29 20 28 73 65 ture "cool") (se
4830: 61 73 6f 6e 20 22 73 75 6d 6d 65 72 22 29 29 0a ason "summer")).
4840: 20 20 20 20 28 6c 65 74 2a 20 28 28 6e 65 77 2d (let* ((new-
4850: 74 65 73 74 2d 70 61 74 68 20 28 73 74 72 69 6e test-path (strin
4860: 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 63 g-intersperse (c
4870: 6f 6e 73 20 74 65 73 74 2d 70 61 74 68 20 28 6d ons test-path (m
4880: 61 70 20 63 61 64 72 20 69 74 65 6d 64 61 74 29 ap cadr itemdat)
4890: 29 20 22 2f 22 29 29 0a 09 20 20 20 28 6e 65 77 ) "/")).. (new
48a0: 2d 74 65 73 74 2d 6e 61 6d 65 20 28 69 66 20 28 -test-name (if (
48b0: 65 71 75 61 6c 3f 20 69 74 65 6d 2d 70 61 74 68 equal? item-path
48c0: 20 22 22 29 20 74 65 73 74 2d 6e 61 6d 65 20 28 "") test-name (
48d0: 63 6f 6e 63 20 74 65 73 74 2d 6e 61 6d 65 20 22 conc test-name "
48e0: 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 29 29 20 /" item-path)))
48f0: 3b 3b 20 6a 75 73 74 20 6e 65 65 64 20 69 74 20 ;; just need it
4900: 74 6f 20 62 65 20 75 6e 69 71 75 65 0a 09 20 20 to be unique..
4910: 20 28 74 65 73 74 2d 69 64 20 20 20 20 20 20 20 (test-id
4920: 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 (cdb:remote-run
4930: 64 62 3a 67 65 74 2d 74 65 73 74 2d 69 64 20 23 db:get-test-id #
4940: 66 20 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e f run-id test-n
4950: 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 0a ame item-path)).
4960: 09 20 20 20 28 74 65 73 74 64 61 74 20 20 20 20 . (testdat
4970: 20 20 20 28 63 64 62 3a 67 65 74 2d 74 65 73 74 (cdb:get-test
4980: 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 2a 72 75 6e -info-by-id *run
4990: 72 65 6d 6f 74 65 2a 20 74 65 73 74 2d 69 64 29 remote* test-id)
49a0: 29 29 0a 20 20 20 20 20 20 28 69 66 20 28 6e 6f )). (if (no
49b0: 74 20 74 65 73 74 64 61 74 29 0a 09 20 20 28 62 t testdat).. (b
49c0: 65 67 69 6e 0a 09 20 20 20 20 3b 3b 20 65 6e 73 egin.. ;; ens
49d0: 75 72 65 20 74 68 61 74 20 74 68 65 20 70 61 74 ure that the pat
49e0: 68 20 65 78 69 73 74 73 20 62 65 66 6f 72 65 20 h exists before
49f0: 72 65 67 69 73 74 65 72 69 6e 67 20 74 68 65 20 registering the
4a00: 74 65 73 74 0a 09 20 20 20 20 3b 3b 20 4e 4f 50 test.. ;; NOP
4a10: 45 3a 20 43 61 6e 6e 6f 74 21 20 44 6f 6e 27 74 E: Cannot! Don't
4a20: 20 6b 6e 6f 77 20 79 65 74 20 77 68 69 63 68 20 know yet which
4a30: 64 69 73 6b 20 61 72 65 61 20 77 69 6c 6c 20 62 disk area will b
4a40: 65 20 61 73 73 69 67 6e 65 64 2e 2e 2e 2e 0a 09 e assigned......
4a50: 20 20 20 20 3b 3b 20 28 73 79 73 74 65 6d 20 28 ;; (system (
4a60: 63 6f 6e 63 20 22 6d 6b 64 69 72 20 2d 70 20 22 conc "mkdir -p "
4a70: 20 6e 65 77 2d 74 65 73 74 2d 70 61 74 68 29 29 new-test-path))
4a80: 0a 09 20 20 20 20 3b 3b 0a 09 20 20 20 20 3b 3b .. ;;.. ;;
4a90: 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 (open-run-close
4aa0: 20 74 65 73 74 73 3a 72 65 67 69 73 74 65 72 2d tests:register-
4ab0: 74 65 73 74 20 64 62 20 72 75 6e 2d 69 64 20 74 test db run-id t
4ac0: 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 est-name item-pa
4ad0: 74 68 29 0a 09 20 20 20 20 3b 3b 0a 09 20 20 20 th).. ;;..
4ae0: 20 3b 3b 20 4e 42 2f 2f 20 66 6f 72 20 74 68 65 ;; NB// for the
4af0: 20 61 62 6f 76 65 20 6c 69 6e 65 2e 20 49 20 77 above line. I w
4b00: 61 6e 74 20 74 68 65 20 74 65 73 74 20 74 6f 20 ant the test to
4b10: 62 65 20 72 65 67 69 73 74 65 72 65 64 20 6c 6f be registered lo
4b20: 6e 67 20 62 65 66 6f 72 65 20 74 68 69 73 20 72 ng before this r
4b30: 6f 75 74 69 6e 65 20 67 65 74 73 20 63 61 6c 6c outine gets call
4b40: 65 64 21 0a 09 20 20 20 20 3b 3b 0a 09 20 20 20 ed!.. ;;..
4b50: 20 28 73 65 74 21 20 74 65 73 74 2d 69 64 20 28 (set! test-id (
4b60: 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 open-run-close d
4b70: 62 3a 67 65 74 2d 74 65 73 74 2d 69 64 20 64 62 b:get-test-id db
4b80: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
4b90: 65 20 69 74 65 6d 2d 70 61 74 68 29 29 0a 09 20 e item-path))..
4ba0: 20 20 20 28 69 66 20 28 6e 6f 74 20 74 65 73 74 (if (not test
4bb0: 2d 69 64 29 0a 09 09 28 62 65 67 69 6e 0a 09 09 -id)...(begin...
4bc0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 (debug:print 2
4bd0: 20 22 57 41 52 4e 3a 20 54 65 73 74 20 6e 6f 74 "WARN: Test not
4be0: 20 70 72 65 2d 63 72 65 61 74 65 64 3f 20 74 65 pre-created? te
4bf0: 73 74 2d 6e 61 6d 65 3d 22 20 74 65 73 74 2d 6e st-name=" test-n
4c00: 61 6d 65 20 22 2c 20 69 74 65 6d 2d 70 61 74 68 ame ", item-path
4c10: 3d 22 20 69 74 65 6d 2d 70 61 74 68 20 22 2c 20 =" item-path ",
4c20: 72 75 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 64 29 run-id=" run-id)
4c30: 0a 09 09 20 20 28 63 64 62 3a 74 65 73 74 73 2d ... (cdb:tests-
4c40: 72 65 67 69 73 74 65 72 2d 74 65 73 74 20 2a 72 register-test *r
4c50: 75 6e 72 65 6d 6f 74 65 2a 20 72 75 6e 2d 69 64 unremote* run-id
4c60: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item-
4c70: 70 61 74 68 29 0a 09 09 20 20 28 73 65 74 21 20 path)... (set!
4c80: 74 65 73 74 2d 69 64 20 28 6f 70 65 6e 2d 72 75 test-id (open-ru
4c90: 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d 74 n-close db:get-t
4ca0: 65 73 74 2d 69 64 20 64 62 20 72 75 6e 2d 69 64 est-id db run-id
4cb0: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item-
4cc0: 70 61 74 68 29 29 29 29 0a 09 20 20 20 20 28 64 path)))).. (d
4cd0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
4ce0: 34 20 22 74 65 73 74 2d 69 64 3d 22 20 74 65 73 4 "test-id=" tes
4cf0: 74 2d 69 64 20 22 2c 20 72 75 6e 2d 69 64 3d 22 t-id ", run-id="
4d00: 20 72 75 6e 2d 69 64 20 22 2c 20 74 65 73 74 2d run-id ", test-
4d10: 6e 61 6d 65 3d 22 20 74 65 73 74 2d 6e 61 6d 65 name=" test-name
4d20: 20 22 2c 20 69 74 65 6d 2d 70 61 74 68 3d 5c 22 ", item-path=\"
4d30: 22 20 69 74 65 6d 2d 70 61 74 68 20 22 5c 22 22 " item-path "\""
4d40: 29 0a 09 20 20 20 20 28 73 65 74 21 20 74 65 73 ).. (set! tes
4d50: 74 64 61 74 20 28 63 64 62 3a 67 65 74 2d 74 65 tdat (cdb:get-te
4d60: 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 2a 72 st-info-by-id *r
4d70: 75 6e 72 65 6d 6f 74 65 2a 20 74 65 73 74 2d 69 unremote* test-i
4d80: 64 29 29 29 29 0a 20 20 20 20 20 20 28 73 65 74 d)))). (set
4d90: 21 20 74 65 73 74 2d 69 64 20 28 64 62 3a 74 65 ! test-id (db:te
4da0: 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 64 61 st-get-id testda
4db0: 74 29 29 0a 20 20 20 20 20 20 28 63 68 61 6e 67 t)). (chang
4dc0: 65 2d 64 69 72 65 63 74 6f 72 79 20 74 65 73 74 e-directory test
4dd0: 2d 70 61 74 68 29 0a 20 20 20 20 20 20 28 63 61 -path). (ca
4de0: 73 65 20 28 69 66 20 66 6f 72 63 65 20 3b 3b 20 se (if force ;;
4df0: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
4e00: 66 6f 72 63 65 22 29 0a 09 09 27 4e 4f 54 5f 53 force")...'NOT_S
4e10: 54 41 52 54 45 44 0a 09 09 28 69 66 20 74 65 73 TARTED...(if tes
4e20: 74 64 61 74 0a 09 09 20 20 20 20 28 73 74 72 69 tdat... (stri
4e30: 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 74 65 73 74 ng->symbol (test
4e40: 3a 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 64 :get-state testd
4e50: 61 74 29 29 0a 09 09 20 20 20 20 27 66 61 69 6c at))... 'fail
4e60: 65 64 2d 74 6f 2d 69 6e 73 65 72 74 29 29 0a 09 ed-to-insert))..
4e70: 28 28 66 61 69 6c 65 64 2d 74 6f 2d 69 6e 73 65 ((failed-to-inse
4e80: 72 74 29 0a 09 20 28 64 65 62 75 67 3a 70 72 69 rt).. (debug:pri
4e90: 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 46 61 69 nt 0 "ERROR: Fai
4ea0: 6c 65 64 20 74 6f 20 69 6e 73 65 72 74 20 74 68 led to insert th
4eb0: 65 20 72 65 63 6f 72 64 20 69 6e 74 6f 20 74 68 e record into th
4ec0: 65 20 64 62 22 29 29 0a 09 28 28 4e 4f 54 5f 53 e db"))..((NOT_S
4ed0: 54 41 52 54 45 44 20 43 4f 4d 50 4c 45 54 45 44 TARTED COMPLETED
4ee0: 20 44 45 4c 45 54 45 44 29 0a 09 20 28 6c 65 74 DELETED).. (let
4ef0: 20 28 28 72 75 6e 66 6c 61 67 20 23 66 29 29 0a ((runflag #f)).
4f00: 09 20 20 20 28 63 6f 6e 64 0a 09 20 20 20 20 3b . (cond.. ;
4f10: 3b 20 2d 66 6f 72 63 65 2c 20 72 75 6e 20 6e 6f ; -force, run no
4f20: 20 6d 61 74 74 65 72 20 77 68 61 74 0a 09 20 20 matter what..
4f30: 20 20 28 66 6f 72 63 65 20 28 73 65 74 21 20 72 (force (set! r
4f40: 75 6e 66 6c 61 67 20 23 74 29 29 0a 09 20 20 20 unflag #t))..
4f50: 20 3b 3b 20 4e 4f 54 5f 53 54 41 52 54 45 44 2c ;; NOT_STARTED,
4f60: 20 72 75 6e 20 6e 6f 20 6d 61 74 74 65 72 20 77 run no matter w
4f70: 68 61 74 0a 09 20 20 20 20 28 28 6d 65 6d 62 65 hat.. ((membe
4f80: 72 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 r (test:get-stat
4f90: 65 20 74 65 73 74 64 61 74 29 20 27 28 22 44 45 e testdat) '("DE
4fa0: 4c 45 54 45 44 22 20 22 4e 4f 54 5f 53 54 41 52 LETED" "NOT_STAR
4fb0: 54 45 44 22 29 29 28 73 65 74 21 20 72 75 6e 66 TED"))(set! runf
4fc0: 6c 61 67 20 23 74 29 29 0a 09 20 20 20 20 3b 3b lag #t)).. ;;
4fd0: 20 6e 6f 74 20 2d 72 65 72 75 6e 20 61 6e 64 20 not -rerun and
4fe0: 50 41 53 53 2c 20 57 41 52 4e 20 6f 72 20 43 48 PASS, WARN or CH
4ff0: 45 43 4b 2c 20 64 6f 20 6e 6f 20 72 75 6e 0a 09 ECK, do no run..
5000: 20 20 20 20 28 28 61 6e 64 20 28 6f 72 20 28 6e ((and (or (n
5010: 6f 74 20 72 65 72 75 6e 29 0a 09 09 20 20 20 20 ot rerun)...
5020: 20 20 6b 65 65 70 67 6f 69 6e 67 29 0a 09 09 20 keepgoing)...
5030: 20 3b 3b 20 52 65 71 75 69 72 65 20 74 6f 20 66 ;; Require to f
5040: 6f 72 63 65 20 72 65 2d 72 75 6e 20 66 6f 72 20 orce re-run for
5050: 43 4f 4d 50 4c 45 54 45 44 20 6f 72 20 2a 61 6e COMPLETED or *an
5060: 79 74 68 69 6e 67 2a 20 2b 20 50 41 53 53 2c 57 ything* + PASS,W
5070: 41 52 4e 20 6f 72 20 43 48 45 43 4b 0a 09 09 20 ARN or CHECK...
5080: 20 28 6f 72 20 28 6d 65 6d 62 65 72 20 28 74 65 (or (member (te
5090: 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 st:get-status te
50a0: 73 74 64 61 74 29 20 27 28 22 50 41 53 53 22 20 stdat) '("PASS"
50b0: 22 57 41 52 4e 22 20 22 43 48 45 43 4b 22 20 22 "WARN" "CHECK" "
50c0: 53 4b 49 50 22 29 29 0a 09 09 20 20 20 20 20 20 SKIP"))...
50d0: 28 6d 65 6d 62 65 72 20 28 74 65 73 74 3a 67 65 (member (test:ge
50e0: 74 2d 73 74 61 74 65 20 20 74 65 73 74 64 61 74 t-state testdat
50f0: 29 20 27 28 22 43 4f 4d 50 4c 45 54 45 44 22 29 ) '("COMPLETED")
5100: 29 29 29 20 0a 09 20 20 20 20 20 28 64 65 62 75 ))) .. (debu
5110: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 22 g:print-info 2 "
5120: 72 75 6e 6e 69 6e 67 20 74 65 73 74 20 22 20 74 running test " t
5130: 65 73 74 2d 6e 61 6d 65 20 22 2f 22 20 69 74 65 est-name "/" ite
5140: 6d 2d 70 61 74 68 20 22 20 73 75 70 70 72 65 73 m-path " suppres
5150: 73 65 64 20 61 73 20 69 74 20 69 73 20 22 20 28 sed as it is " (
5160: 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 test:get-state t
5170: 65 73 74 64 61 74 29 20 22 20 61 6e 64 20 22 20 estdat) " and "
5180: 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 75 73 (test:get-status
5190: 20 74 65 73 74 64 61 74 29 29 0a 09 20 20 20 20 testdat))..
51a0: 20 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 (set! runflag #
51b0: 66 29 29 0a 09 20 20 20 20 3b 3b 20 2d 72 65 72 f)).. ;; -rer
51c0: 75 6e 20 61 6e 64 20 73 74 61 74 75 73 20 69 73 un and status is
51d0: 20 6f 6e 65 20 6f 66 20 74 68 65 20 73 70 65 63 one of the spec
51e0: 69 66 65 64 2c 20 72 75 6e 20 69 74 0a 09 20 20 ifed, run it..
51f0: 20 20 28 28 61 6e 64 20 72 65 72 75 6e 0a 09 09 ((and rerun...
5200: 20 20 28 6c 65 74 2a 20 28 28 72 65 72 75 6e 6c (let* ((rerunl
5210: 73 74 20 20 20 28 73 74 72 69 6e 67 2d 73 70 6c st (string-spl
5220: 69 74 20 72 65 72 75 6e 20 22 2c 22 29 29 0a 09 it rerun ","))..
5230: 09 09 20 28 6d 75 73 74 2d 72 65 72 75 6e 20 28 .. (must-rerun (
5240: 6d 65 6d 62 65 72 20 28 74 65 73 74 3a 67 65 74 member (test:get
5250: 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 74 29 -status testdat)
5260: 20 72 65 72 75 6e 6c 73 74 29 29 29 0a 09 09 20 rerunlst)))...
5270: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
5280: 69 6e 66 6f 20 33 20 22 2d 72 65 72 75 6e 20 6c info 3 "-rerun l
5290: 69 73 74 3a 20 22 20 72 65 72 75 6e 20 22 2c 20 ist: " rerun ",
52a0: 74 65 73 74 2d 73 74 61 74 75 73 3a 20 22 20 28 test-status: " (
52b0: 74 65 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 test:get-status
52c0: 74 65 73 74 64 61 74 29 22 2c 20 6d 75 73 74 2d testdat)", must-
52d0: 72 65 72 75 6e 3a 20 22 20 6d 75 73 74 2d 72 65 rerun: " must-re
52e0: 72 75 6e 29 0a 09 09 20 20 20 20 6d 75 73 74 2d run)... must-
52f0: 72 65 72 75 6e 29 29 0a 09 20 20 20 20 20 28 64 rerun)).. (d
5300: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
5310: 32 20 22 52 65 72 75 6e 20 66 6f 72 63 65 64 20 2 "Rerun forced
5320: 66 6f 72 20 74 65 73 74 20 22 20 74 65 73 74 2d for test " test-
5330: 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 name "/" item-pa
5340: 74 68 29 0a 09 20 20 20 20 20 28 73 65 74 21 20 th).. (set!
5350: 72 75 6e 66 6c 61 67 20 23 74 29 29 0a 09 20 20 runflag #t))..
5360: 20 20 3b 3b 20 2d 6b 65 65 70 67 6f 69 6e 67 2c ;; -keepgoing,
5370: 20 64 6f 20 6e 6f 74 20 72 65 72 75 6e 20 46 41 do not rerun FA
5380: 49 4c 0a 09 20 20 20 20 28 28 61 6e 64 20 6b 65 IL.. ((and ke
5390: 65 70 67 6f 69 6e 67 0a 09 09 20 20 28 6d 65 6d epgoing... (mem
53a0: 62 65 72 20 28 74 65 73 74 3a 67 65 74 2d 73 74 ber (test:get-st
53b0: 61 74 75 73 20 74 65 73 74 64 61 74 29 20 27 28 atus testdat) '(
53c0: 22 46 41 49 4c 22 29 29 29 0a 09 20 20 20 20 20 "FAIL")))..
53d0: 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 66 (set! runflag #f
53e0: 29 29 0a 09 20 20 20 20 28 28 61 6e 64 20 28 6e )).. ((and (n
53f0: 6f 74 20 72 65 72 75 6e 29 0a 09 09 20 20 28 6d ot rerun)... (m
5400: 65 6d 62 65 72 20 28 74 65 73 74 3a 67 65 74 2d ember (test:get-
5410: 73 74 61 74 75 73 20 74 65 73 74 64 61 74 29 20 status testdat)
5420: 27 28 22 46 41 49 4c 22 20 22 6e 2f 61 22 29 29 '("FAIL" "n/a"))
5430: 29 0a 09 20 20 20 20 20 28 73 65 74 21 20 72 75 ).. (set! ru
5440: 6e 66 6c 61 67 20 23 74 29 29 0a 09 20 20 20 20 nflag #t))..
5450: 28 65 6c 73 65 20 28 73 65 74 21 20 72 75 6e 66 (else (set! runf
5460: 6c 61 67 20 23 66 29 29 29 0a 09 20 20 20 28 64 lag #f))).. (d
5470: 65 62 75 67 3a 70 72 69 6e 74 20 36 20 22 52 55 ebug:print 6 "RU
5480: 4e 4e 49 4e 47 20 3d 3e 20 72 75 6e 66 6c 61 67 NNING => runflag
5490: 3a 20 22 20 72 75 6e 66 6c 61 67 20 22 20 53 54 : " runflag " ST
54a0: 41 54 45 3a 20 22 20 28 74 65 73 74 3a 67 65 74 ATE: " (test:get
54b0: 2d 73 74 61 74 65 20 74 65 73 74 64 61 74 29 20 -state testdat)
54c0: 22 20 53 54 41 54 55 53 3a 20 22 20 28 74 65 73 " STATUS: " (tes
54d0: 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 t:get-status tes
54e0: 74 64 61 74 29 29 0a 09 20 20 20 28 69 66 20 28 tdat)).. (if (
54f0: 6e 6f 74 20 72 75 6e 66 6c 61 67 29 0a 09 20 20 not runflag)..
5500: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 70 61 (if (not pa
5510: 72 65 6e 74 2d 74 65 73 74 29 0a 09 09 20 20 20 rent-test)...
5520: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 (debug:print 1 "
5530: 4e 4f 54 45 3a 20 4e 6f 74 20 73 74 61 72 74 69 NOTE: Not starti
5540: 6e 67 20 74 65 73 74 20 22 20 6e 65 77 2d 74 65 ng test " new-te
5550: 73 74 2d 6e 61 6d 65 20 22 20 61 73 20 69 74 20 st-name " as it
5560: 69 73 20 73 74 61 74 65 20 5c 22 22 20 28 74 65 is state \"" (te
5570: 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 73 st:get-state tes
5580: 74 64 61 74 29 20 0a 09 09 09 09 22 5c 22 20 61 tdat) ....."\" a
5590: 6e 64 20 73 74 61 74 75 73 20 5c 22 22 20 28 74 nd status \"" (t
55a0: 65 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 est:get-status t
55b0: 65 73 74 64 61 74 29 20 22 5c 22 2c 20 75 73 65 estdat) "\", use
55c0: 20 2d 72 65 72 75 6e 20 5c 22 22 20 28 74 65 73 -rerun \"" (tes
55d0: 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 t:get-status tes
55e0: 74 64 61 74 29 0a 20 20 20 20 20 20 20 20 20 20 tdat).
55f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5600: 20 20 20 20 20 20 22 5c 22 20 6f 72 20 2d 66 6f "\" or -fo
5610: 72 63 65 20 74 6f 20 6f 76 65 72 72 69 64 65 22 rce to override"
5620: 29 29 0a 09 20 20 20 20 20 20 20 3b 3b 20 4e 4f )).. ;; NO
5630: 54 45 3a 20 4e 6f 20 6c 6f 6e 67 65 72 20 62 65 TE: No longer be
5640: 20 63 68 65 63 6b 69 6e 67 20 70 72 65 72 65 71 checking prereq
5650: 75 69 73 69 74 65 73 20 68 65 72 65 21 20 57 69 uisites here! Wi
5660: 6c 6c 20 6e 65 76 65 72 20 67 65 74 20 68 65 72 ll never get her
5670: 65 20 75 6e 6c 65 73 73 20 70 72 65 72 65 71 73 e unless prereqs
5680: 20 61 72 65 0a 09 20 20 20 20 20 20 20 3b 3b 20 are.. ;;
5690: 20 20 20 20 20 20 61 6c 72 65 61 64 79 20 6d 65 already me
56a0: 74 2e 0a 09 20 20 20 20 20 20 20 3b 3b 20 54 68 t... ;; Th
56b0: 69 73 20 77 6f 75 6c 64 20 62 65 20 61 20 67 72 is would be a gr
56c0: 65 61 74 20 70 6c 61 63 65 20 74 6f 20 64 6f 20 eat place to do
56d0: 74 68 65 20 70 72 6f 63 65 73 73 2d 66 6f 72 6b the process-fork
56e0: 0a 09 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f .. (if (no
56f0: 74 20 28 6c 61 75 6e 63 68 2d 74 65 73 74 20 74 t (launch-test t
5700: 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 72 75 est-id run-id ru
5710: 6e 2d 69 6e 66 6f 20 6b 65 79 2d 76 61 6c 73 20 n-info key-vals
5720: 72 75 6e 6e 61 6d 65 20 74 65 73 74 2d 63 6f 6e runname test-con
5730: 66 20 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 f test-name test
5740: 2d 70 61 74 68 20 69 74 65 6d 64 61 74 20 66 6c -path itemdat fl
5750: 61 67 73 29 29 0a 09 09 20 20 20 28 62 65 67 69 ags))... (begi
5760: 6e 0a 09 09 20 20 20 20 20 28 70 72 69 6e 74 20 n... (print
5770: 22 45 52 52 4f 52 3a 20 46 61 69 6c 65 64 20 74 "ERROR: Failed t
5780: 6f 20 6c 61 75 6e 63 68 20 74 68 65 20 74 65 73 o launch the tes
5790: 74 2e 20 45 78 69 74 69 6e 67 20 61 73 20 73 6f t. Exiting as so
57a0: 6f 6e 20 61 73 20 70 6f 73 73 69 62 6c 65 22 29 on as possible")
57b0: 0a 09 09 20 20 20 20 20 28 73 65 74 21 20 2a 67 ... (set! *g
57c0: 6c 6f 62 61 6c 65 78 69 74 73 74 61 74 75 73 2a lobalexitstatus*
57d0: 20 31 29 20 3b 3b 20 0a 09 09 20 20 20 20 20 28 1) ;; ... (
57e0: 70 72 6f 63 65 73 73 2d 73 69 67 6e 61 6c 20 28 process-signal (
57f0: 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d current-process-
5800: 69 64 29 20 73 69 67 6e 61 6c 2f 6b 69 6c 6c 29 id) signal/kill)
5810: 29 29 29 29 29 0a 09 28 28 4b 49 4c 4c 45 44 29 )))))..((KILLED)
5820: 20 0a 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
5830: 20 31 20 22 4e 4f 54 45 3a 20 22 20 6e 65 77 2d 1 "NOTE: " new-
5840: 74 65 73 74 2d 6e 61 6d 65 20 22 20 69 73 20 61 test-name " is a
5850: 6c 72 65 61 64 79 20 72 75 6e 6e 69 6e 67 20 6f lready running o
5860: 72 20 77 61 73 20 65 78 70 6c 69 63 74 6c 79 20 r was explictly
5870: 6b 69 6c 6c 65 64 2c 20 75 73 65 20 2d 66 6f 72 killed, use -for
5880: 63 65 20 74 6f 20 6c 61 75 6e 63 68 20 69 74 2e ce to launch it.
5890: 22 29 29 0a 09 28 28 4c 41 55 4e 43 48 45 44 20 "))..((LAUNCHED
58a0: 52 45 4d 4f 54 45 48 4f 53 54 53 54 41 52 54 20 REMOTEHOSTSTART
58b0: 52 55 4e 4e 49 4e 47 29 20 20 0a 09 20 28 69 66 RUNNING) .. (if
58c0: 20 28 3e 20 28 2d 20 28 63 75 72 72 65 6e 74 2d (> (- (current-
58d0: 73 65 63 6f 6e 64 73 29 28 2b 20 28 64 62 3a 74 seconds)(+ (db:t
58e0: 65 73 74 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 est-get-event_ti
58f0: 6d 65 20 74 65 73 74 64 61 74 29 0a 09 09 09 09 me testdat).....
5900: 20 20 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d (db:test-
5910: 67 65 74 2d 72 75 6e 5f 64 75 72 61 74 69 6f 6e get-run_duration
5920: 20 74 65 73 74 64 61 74 29 29 29 0a 09 09 36 30 testdat)))...60
5930: 30 29 20 3b 3b 20 69 2e 65 2e 20 6e 6f 20 75 70 0) ;; i.e. no up
5940: 64 61 74 65 20 66 6f 72 20 6d 6f 72 65 20 74 68 date for more th
5950: 61 6e 20 36 30 30 20 73 65 63 6f 6e 64 73 0a 09 an 600 seconds..
5960: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 (begin..
5970: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
5980: 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 54 65 73 0 "WARNING: Tes
5990: 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 t " test-name "
59a0: 61 70 70 65 61 72 73 20 74 6f 20 62 65 20 64 65 appears to be de
59b0: 61 64 2e 20 46 6f 72 63 69 6e 67 20 69 74 20 74 ad. Forcing it t
59c0: 6f 20 73 74 61 74 65 20 49 4e 43 4f 4d 50 4c 45 o state INCOMPLE
59d0: 54 45 20 61 6e 64 20 73 74 61 74 75 73 20 53 54 TE and status ST
59e0: 55 43 4b 2f 44 45 41 44 22 29 0a 09 20 20 20 20 UCK/DEAD")..
59f0: 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 2d 73 (tests:test-s
5a00: 65 74 2d 73 74 61 74 75 73 21 20 74 65 73 74 2d et-status! test-
5a10: 69 64 20 22 49 4e 43 4f 4d 50 4c 45 54 45 22 20 id "INCOMPLETE"
5a20: 22 53 54 55 43 4b 2f 44 45 41 44 22 20 22 54 65 "STUCK/DEAD" "Te
5a30: 73 74 20 69 73 20 73 74 75 63 6b 20 6f 72 20 64 st is stuck or d
5a40: 65 61 64 22 20 23 66 29 29 0a 09 20 20 20 20 20 ead" #f))..
5a50: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 (debug:print 2 "
5a60: 4e 4f 54 45 3a 20 22 20 74 65 73 74 2d 6e 61 6d NOTE: " test-nam
5a70: 65 20 22 20 69 73 20 61 6c 72 65 61 64 79 20 72 e " is already r
5a80: 75 6e 6e 69 6e 67 22 29 29 29 0a 09 28 65 6c 73 unning")))..(els
5a90: 65 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 e (debug:p
5aa0: 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 46 rint 0 "ERROR: F
5ab0: 61 69 6c 65 64 20 74 6f 20 6c 61 75 6e 63 68 20 ailed to launch
5ac0: 74 65 73 74 20 22 20 6e 65 77 2d 74 65 73 74 2d test " new-test-
5ad0: 6e 61 6d 65 20 22 2e 20 55 6e 72 65 63 6f 67 6e name ". Unrecogn
5ae0: 69 73 65 64 20 73 74 61 74 65 20 22 20 28 74 65 ised state " (te
5af0: 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 73 st:get-state tes
5b00: 74 64 61 74 29 29 29 29 29 29 29 0a 0a 3b 3b 3d tdat)))))))..;;=
5b10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5b20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5b30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5b40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5b50: 3d 3d 3d 3d 3d 0a 3b 3b 20 45 4e 44 20 4f 46 20 =====.;; END OF
5b60: 4e 45 57 20 53 54 55 46 46 0a 3b 3b 3d 3d 3d 3d NEW STUFF.;;====
5b70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5b80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5b90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5ba0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5bb0: 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 67 65 74 ==..(define (get
5bc0: 2d 64 69 72 2d 75 70 2d 6e 20 64 69 72 20 2e 20 -dir-up-n dir .
5bd0: 70 61 72 61 6d 73 29 20 0a 20 20 28 6c 65 74 20 params) . (let
5be0: 28 28 64 70 61 72 74 73 20 20 28 73 74 72 69 6e ((dparts (strin
5bf0: 67 2d 73 70 6c 69 74 20 64 69 72 20 22 2f 22 29 g-split dir "/")
5c00: 29 0a 09 28 63 6f 75 6e 74 20 20 20 28 69 66 20 )..(count (if
5c10: 28 6e 75 6c 6c 3f 20 70 61 72 61 6d 73 29 20 31 (null? params) 1
5c20: 20 28 63 61 72 20 70 61 72 61 6d 73 29 29 29 29 (car params))))
5c30: 0a 20 20 20 20 28 63 6f 6e 63 20 22 2f 22 20 28 . (conc "/" (
5c40: 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
5c50: 73 65 20 0a 09 20 20 20 20 20 20 20 28 74 61 6b se .. (tak
5c60: 65 20 64 70 61 72 74 73 20 28 2d 20 28 6c 65 6e e dparts (- (len
5c70: 67 74 68 20 64 70 61 72 74 73 29 20 63 6f 75 6e gth dparts) coun
5c80: 74 29 29 0a 09 20 20 20 20 20 20 20 22 2f 22 29 t)).. "/")
5c90: 29 29 29 0a 3b 3b 20 52 65 6d 6f 76 65 20 72 75 ))).;; Remove ru
5ca0: 6e 73 0a 3b 3b 20 66 69 65 6c 64 73 20 61 72 65 ns.;; fields are
5cb0: 20 70 61 73 73 69 6e 67 20 69 6e 20 74 68 72 6f passing in thro
5cc0: 75 67 68 20 0a 3b 3b 20 61 63 74 69 6f 6e 3a 0a ugh .;; action:.
5cd0: 3b 3b 20 20 20 20 27 72 65 6d 6f 76 65 2d 72 75 ;; 'remove-ru
5ce0: 6e 73 0a 3b 3b 20 20 20 20 27 73 65 74 2d 73 74 ns.;; 'set-st
5cf0: 61 74 65 2d 73 74 61 74 75 73 0a 3b 3b 0a 3b 3b ate-status.;;.;;
5d00: 20 4e 42 2f 2f 20 73 68 6f 75 6c 64 20 70 61 73 NB// should pas
5d10: 73 20 69 6e 20 6b 65 79 73 3f 0a 3b 3b 0a 28 64 s in keys?.;;.(d
5d20: 65 66 69 6e 65 20 28 72 75 6e 73 3a 6f 70 65 72 efine (runs:oper
5d30: 61 74 65 2d 6f 6e 20 61 63 74 69 6f 6e 20 74 61 ate-on action ta
5d40: 72 67 65 74 20 72 75 6e 6e 61 6d 65 70 61 74 74 rget runnamepatt
5d50: 20 74 65 73 74 70 61 74 74 20 23 21 6b 65 79 20 testpatt #!key
5d60: 28 73 74 61 74 65 20 23 66 29 28 73 74 61 74 75 (state #f)(statu
5d70: 73 20 23 66 29 28 6e 65 77 2d 73 74 61 74 65 2d s #f)(new-state-
5d80: 73 74 61 74 75 73 20 23 66 29 29 0a 20 20 28 63 status #f)). (c
5d90: 6f 6d 6d 6f 6e 3a 63 6c 65 61 72 2d 63 61 63 68 ommon:clear-cach
5da0: 65 73 29 20 3b 3b 20 63 6c 65 61 72 20 61 6c 6c es) ;; clear all
5db0: 20 63 61 63 68 65 73 0a 20 20 28 6c 65 74 2a 20 caches. (let*
5dc0: 28 28 64 62 20 20 20 20 20 20 20 20 20 20 20 23 ((db #
5dd0: 66 29 0a 09 20 28 6b 65 79 73 20 20 20 20 20 20 f).. (keys
5de0: 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f (open-run-clo
5df0: 73 65 20 64 62 3a 67 65 74 2d 6b 65 79 73 20 64 se db:get-keys d
5e00: 62 29 29 0a 09 20 28 72 75 6e 64 61 74 20 20 20 b)).. (rundat
5e10: 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c (open-run-cl
5e20: 6f 73 65 20 72 75 6e 73 3a 67 65 74 2d 72 75 6e ose runs:get-run
5e30: 73 2d 62 79 2d 70 61 74 74 20 64 62 20 6b 65 79 s-by-patt db key
5e40: 73 20 72 75 6e 6e 61 6d 65 70 61 74 74 20 74 61 s runnamepatt ta
5e50: 72 67 65 74 29 29 0a 09 20 28 68 65 61 64 65 72 rget)).. (header
5e60: 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 (vector-r
5e70: 65 66 20 72 75 6e 64 61 74 20 30 29 29 0a 09 20 ef rundat 0))..
5e80: 28 72 75 6e 73 20 20 20 20 20 20 20 20 20 28 76 (runs (v
5e90: 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 64 61 74 ector-ref rundat
5ea0: 20 31 29 29 0a 09 20 28 73 74 61 74 65 73 20 20 1)).. (states
5eb0: 20 20 20 20 20 28 69 66 20 73 74 61 74 65 20 20 (if state
5ec0: 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 73 74 (string-split st
5ed0: 61 74 65 20 20 22 2c 22 29 20 27 28 29 29 29 0a ate ",") '())).
5ee0: 09 20 28 73 74 61 74 75 73 65 73 20 20 20 20 20 . (statuses
5ef0: 28 69 66 20 73 74 61 74 75 73 20 28 73 74 72 69 (if status (stri
5f00: 6e 67 2d 73 70 6c 69 74 20 73 74 61 74 75 73 20 ng-split status
5f10: 22 2c 22 29 20 27 28 29 29 29 0a 09 20 28 73 74 ",") '())).. (st
5f20: 61 74 65 2d 73 74 61 74 75 73 20 28 69 66 20 28 ate-status (if (
5f30: 73 74 72 69 6e 67 3f 20 6e 65 77 2d 73 74 61 74 string? new-stat
5f40: 65 2d 73 74 61 74 75 73 29 20 28 73 74 72 69 6e e-status) (strin
5f50: 67 2d 73 70 6c 69 74 20 6e 65 77 2d 73 74 61 74 g-split new-stat
5f60: 65 2d 73 74 61 74 75 73 20 22 2c 22 29 20 27 28 e-status ",") '(
5f70: 23 66 20 23 66 29 29 29 29 0a 20 20 20 20 28 64 #f #f)))). (d
5f80: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
5f90: 34 20 22 72 75 6e 73 3a 6f 70 65 72 61 74 65 2d 4 "runs:operate-
5fa0: 6f 6e 20 3d 3e 20 48 65 61 64 65 72 3a 20 22 20 on => Header: "
5fb0: 68 65 61 64 65 72 20 22 20 61 63 74 69 6f 6e 3a header " action:
5fc0: 20 22 20 61 63 74 69 6f 6e 20 22 20 6e 65 77 2d " action " new-
5fd0: 73 74 61 74 65 2d 73 74 61 74 75 73 3a 20 22 20 state-status: "
5fe0: 6e 65 77 2d 73 74 61 74 65 2d 73 74 61 74 75 73 new-state-status
5ff0: 29 0a 20 20 20 20 28 69 66 20 28 3e 20 32 20 28 ). (if (> 2 (
6000: 6c 65 6e 67 74 68 20 73 74 61 74 65 2d 73 74 61 length state-sta
6010: 74 75 73 29 29 0a 09 28 62 65 67 69 6e 0a 09 20 tus))..(begin..
6020: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
6030: 22 45 52 52 4f 52 3a 20 74 68 65 20 70 61 72 61 "ERROR: the para
6040: 6d 65 74 65 72 20 74 6f 20 2d 73 65 74 2d 73 74 meter to -set-st
6050: 61 74 65 2d 73 74 61 74 75 73 20 69 73 20 61 20 ate-status is a
6060: 63 6f 6d 6d 61 20 64 65 6c 69 6d 69 74 65 64 20 comma delimited
6070: 73 74 72 69 6e 67 2e 20 45 2e 67 2e 20 43 4f 4d string. E.g. COM
6080: 50 4c 45 54 45 44 2c 46 41 49 4c 22 29 0a 09 20 PLETED,FAIL")..
6090: 20 28 65 78 69 74 29 29 29 0a 20 20 20 20 28 66 (exit))). (f
60a0: 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 6c 61 or-each. (la
60b0: 6d 62 64 61 20 28 72 75 6e 29 0a 20 20 20 20 20 mbda (run).
60c0: 20 20 28 6c 65 74 20 28 28 72 75 6e 6b 65 79 20 (let ((runkey
60d0: 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 (string-interspe
60e0: 72 73 65 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 rse (map (lambda
60f0: 20 28 6b 29 0a 09 09 09 09 09 09 28 64 62 3a 67 (k).......(db:g
6100: 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 et-value-by-head
6110: 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 6b 29 er run header k)
6120: 29 20 6b 65 79 73 29 20 22 2f 22 29 29 0a 09 20 ) keys) "/"))..
6130: 20 20 20 20 28 64 69 72 73 2d 74 6f 2d 72 65 6d (dirs-to-rem
6140: 6f 76 65 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 ove (make-hash-t
6150: 61 62 6c 65 29 29 29 0a 09 20 28 6c 65 74 2a 20 able))).. (let*
6160: 28 28 72 75 6e 2d 69 64 20 20 20 20 28 64 62 3a ((run-id (db:
6170: 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 get-value-by-hea
6180: 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 der run header "
6190: 69 64 22 29 29 0a 09 09 28 72 75 6e 2d 73 74 61 id"))...(run-sta
61a0: 74 65 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 te (db:get-value
61b0: 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 -by-header run h
61c0: 65 61 64 65 72 20 22 73 74 61 74 65 22 29 29 0a eader "state")).
61d0: 09 09 28 74 65 73 74 73 20 20 20 20 20 28 69 66 ..(tests (if
61e0: 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 72 75 (not (equal? ru
61f0: 6e 2d 73 74 61 74 65 20 22 6c 6f 63 6b 65 64 22 n-state "locked"
6200: 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 6f 70 )).... (op
6210: 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a en-run-close db:
6220: 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 get-tests-for-ru
6230: 6e 20 64 62 20 72 75 6e 2d 69 64 0a 09 09 09 09 n db run-id.....
6240: 09 09 20 20 20 20 20 20 74 65 73 74 70 61 74 74 .. testpatt
6250: 20 73 74 61 74 65 73 20 73 74 61 74 75 73 65 73 states statuses
6260: 0a 09 09 09 09 09 09 20 20 20 20 20 20 6e 6f 74 ....... not
6270: 2d 69 6e 3a 20 20 23 66 0a 09 09 09 09 09 09 20 -in: #f.......
6280: 20 20 20 20 20 73 6f 72 74 2d 62 79 3a 20 28 63 sort-by: (c
6290: 61 73 65 20 61 63 74 69 6f 6e 0a 09 09 09 09 09 ase action......
62a0: 09 09 09 20 28 28 72 65 6d 6f 76 65 2d 72 75 6e ... ((remove-run
62b0: 73 29 20 27 72 75 6e 64 69 72 29 0a 09 09 09 09 s) 'rundir).....
62c0: 09 09 09 09 20 28 65 6c 73 65 20 20 20 20 20 20 .... (else
62d0: 20 20 20 20 27 65 76 65 6e 74 5f 74 69 6d 65 29 'event_time)
62e0: 29 29 0a 09 09 09 20 20 20 20 20 20 20 27 28 29 )).... '()
62f0: 29 29 0a 09 09 28 6c 61 73 74 74 70 61 74 68 20 ))...(lasttpath
6300: 22 2f 64 6f 65 73 2f 6e 6f 74 2f 65 78 69 73 74 "/does/not/exist
6310: 2f 49 2f 68 6f 70 65 22 29 29 0a 09 20 20 20 28 /I/hope")).. (
6320: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
6330: 20 34 20 22 72 75 6e 73 3a 6f 70 65 72 61 74 65 4 "runs:operate
6340: 2d 6f 6e 20 72 75 6e 3d 22 20 72 75 6e 20 22 2c -on run=" run ",
6350: 20 68 65 61 64 65 72 3d 22 20 68 65 61 64 65 72 header=" header
6360: 29 0a 09 20 20 20 28 69 66 20 28 6e 6f 74 20 28 ).. (if (not (
6370: 6e 75 6c 6c 3f 20 74 65 73 74 73 29 29 0a 09 20 null? tests))..
6380: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 20 (begin...
6390: 28 63 61 73 65 20 61 63 74 69 6f 6e 0a 09 09 20 (case action...
63a0: 20 20 28 28 72 65 6d 6f 76 65 2d 72 75 6e 73 29 ((remove-runs)
63b0: 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 ... (debug:pr
63c0: 69 6e 74 20 31 20 22 52 65 6d 6f 76 69 6e 67 20 int 1 "Removing
63d0: 74 65 73 74 73 20 66 6f 72 20 72 75 6e 3a 20 22 tests for run: "
63e0: 20 72 75 6e 6b 65 79 20 22 20 22 20 28 64 62 3a runkey " " (db:
63f0: 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 get-value-by-hea
6400: 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 der run header "
6410: 72 75 6e 6e 61 6d 65 22 29 29 29 0a 09 09 20 20 runname")))...
6420: 20 28 28 73 65 74 2d 73 74 61 74 65 2d 73 74 61 ((set-state-sta
6430: 74 75 73 29 0a 09 09 20 20 20 20 28 64 65 62 75 tus)... (debu
6440: 67 3a 70 72 69 6e 74 20 31 20 22 4d 6f 64 69 66 g:print 1 "Modif
6450: 79 69 6e 67 20 73 74 61 74 65 20 61 6e 64 20 73 ying state and s
6460: 74 61 75 73 20 66 6f 72 20 74 65 73 74 73 20 66 taus for tests f
6470: 6f 72 20 72 75 6e 3a 20 22 20 72 75 6e 6b 65 79 or run: " runkey
6480: 20 22 20 22 20 28 64 62 3a 67 65 74 2d 76 61 6c " " (db:get-val
6490: 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e ue-by-header run
64a0: 20 68 65 61 64 65 72 20 22 72 75 6e 6e 61 6d 65 header "runname
64b0: 22 29 29 29 0a 09 09 20 20 20 28 28 70 72 69 6e ")))... ((prin
64c0: 74 2d 72 75 6e 29 0a 09 09 20 20 20 20 28 64 65 t-run)... (de
64d0: 62 75 67 3a 70 72 69 6e 74 20 31 20 22 50 72 69 bug:print 1 "Pri
64e0: 6e 74 69 6e 67 20 69 6e 66 6f 20 66 6f 72 20 72 nting info for r
64f0: 75 6e 20 22 20 72 75 6e 6b 65 79 20 22 2c 20 72 un " runkey ", r
6500: 75 6e 3d 22 20 72 75 6e 20 22 2c 20 74 65 73 74 un=" run ", test
6510: 73 3d 22 20 74 65 73 74 73 20 22 2c 20 68 65 61 s=" tests ", hea
6520: 64 65 72 3d 22 20 68 65 61 64 65 72 29 0a 09 09 der=" header)...
6530: 20 20 20 20 61 63 74 69 6f 6e 29 0a 09 09 20 20 action)...
6540: 20 28 65 6c 73 65 0a 09 09 20 20 20 20 28 64 65 (else... (de
6550: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
6560: 20 22 61 63 74 69 6f 6e 20 6e 6f 74 20 72 65 63 "action not rec
6570: 6f 67 6e 69 73 65 64 20 22 20 61 63 74 69 6f 6e ognised " action
6580: 29 29 29 0a 09 09 20 28 66 6f 72 2d 65 61 63 68 )))... (for-each
6590: 0a 09 09 20 20 28 6c 61 6d 62 64 61 20 28 74 65 ... (lambda (te
65a0: 73 74 29 0a 09 09 20 20 20 20 28 6c 65 74 2a 20 st)... (let*
65b0: 28 28 69 74 65 6d 2d 70 61 74 68 20 28 64 62 3a ((item-path (db:
65c0: 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 test-get-item-pa
65d0: 74 68 20 74 65 73 74 29 29 0a 09 09 09 20 20 20 th test))....
65e0: 28 74 65 73 74 2d 6e 61 6d 65 20 28 64 62 3a 74 (test-name (db:t
65f0: 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 est-get-testname
6600: 20 74 65 73 74 29 29 0a 09 09 09 20 20 20 28 72 test)).... (r
6610: 75 6e 2d 64 69 72 20 20 20 28 64 62 3a 74 65 73 un-dir (db:tes
6620: 74 2d 67 65 74 2d 72 75 6e 64 69 72 20 74 65 73 t-get-rundir tes
6630: 74 29 29 20 20 20 20 3b 3b 20 72 75 6e 20 64 69 t)) ;; run di
6640: 72 20 69 73 20 66 72 6f 6d 20 74 68 65 20 6c 69 r is from the li
6650: 6e 6b 20 74 72 65 65 0a 09 09 09 20 20 20 28 72 nk tree.... (r
6660: 65 61 6c 2d 64 69 72 20 20 28 69 66 20 28 66 69 eal-dir (if (fi
6670: 6c 65 2d 65 78 69 73 74 73 3f 20 72 75 6e 2d 64 le-exists? run-d
6680: 69 72 29 0a 09 09 09 09 09 20 20 28 72 65 73 6f ir)...... (reso
6690: 6c 76 65 2d 70 61 74 68 6e 61 6d 65 20 72 75 6e lve-pathname run
66a0: 2d 64 69 72 29 0a 09 09 09 09 09 20 20 23 66 29 -dir)...... #f)
66b0: 29 0a 09 09 09 20 20 20 28 74 65 73 74 2d 69 64 ).... (test-id
66c0: 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d (db:test-get-
66d0: 69 64 20 74 65 73 74 29 29 29 0a 09 09 20 20 20 id test)))...
66e0: 20 20 20 3b 3b 20 20 20 28 74 64 62 20 20 20 20 ;; (tdb
66f0: 20 20 20 28 64 62 3a 6f 70 65 6e 2d 74 65 73 74 (db:open-test
6700: 2d 64 62 20 72 75 6e 2d 64 69 72 29 29 29 0a 09 -db run-dir)))..
6710: 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
6720: 69 6e 74 2d 69 6e 66 6f 20 34 20 22 74 65 73 74 int-info 4 "test
6730: 3d 22 20 74 65 73 74 29 20 3b 3b 20 20 20 22 20 =" test) ;; "
6740: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 (db:test-get-tes
6750: 74 6e 61 6d 65 20 74 65 73 74 29 20 22 20 69 64 tname test) " id
6760: 3a 20 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 : " (db:test-get
6770: 2d 69 64 20 74 65 73 74 29 20 22 20 22 20 69 74 -id test) " " it
6780: 65 6d 2d 70 61 74 68 20 22 20 61 63 74 69 6f 6e em-path " action
6790: 3a 20 22 20 61 63 74 69 6f 6e 29 0a 09 09 20 20 : " action)...
67a0: 20 20 20 20 28 63 61 73 65 20 61 63 74 69 6f 6e (case action
67b0: 0a 09 09 09 28 28 72 65 6d 6f 76 65 2d 72 75 6e ....((remove-run
67c0: 73 29 20 3b 3b 20 74 68 65 20 74 64 62 20 69 73 s) ;; the tdb is
67d0: 20 66 6f 72 20 66 75 74 75 72 65 20 70 6f 73 73 for future poss
67e0: 69 62 6c 65 2e 20 0a 09 09 09 20 28 6f 70 65 6e ible. .... (open
67f0: 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 64 65 -run-close db:de
6800: 6c 65 74 65 2d 74 65 73 74 2d 72 65 63 6f 72 64 lete-test-record
6810: 73 20 64 62 20 23 66 20 28 64 62 3a 74 65 73 74 s db #f (db:test
6820: 2d 67 65 74 2d 69 64 20 74 65 73 74 29 29 0a 09 -get-id test))..
6830: 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d .. (debug:print-
6840: 69 6e 66 6f 20 31 20 22 41 74 74 65 6d 70 74 69 info 1 "Attempti
6850: 6e 67 20 74 6f 20 72 65 6d 6f 76 65 20 22 20 28 ng to remove " (
6860: 69 66 20 72 65 61 6c 2d 64 69 72 20 28 63 6f 6e if real-dir (con
6870: 63 20 22 20 64 69 72 20 22 20 72 65 61 6c 2d 64 c " dir " real-d
6880: 69 72 20 22 20 61 6e 64 20 22 29 20 22 22 29 20 ir " and ") "")
6890: 22 20 6c 69 6e 6b 20 22 20 72 75 6e 2d 64 69 72 " link " run-dir
68a0: 29 0a 09 09 09 20 28 69 66 20 28 61 6e 64 20 72 ).... (if (and r
68b0: 65 61 6c 2d 64 69 72 20 0a 09 09 09 09 20 20 28 eal-dir ..... (
68c0: 3e 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 > (string-length
68d0: 20 72 65 61 6c 2d 64 69 72 29 20 35 29 0a 09 09 real-dir) 5)...
68e0: 09 09 20 20 28 66 69 6c 65 2d 65 78 69 73 74 73 .. (file-exists
68f0: 3f 20 72 65 61 6c 2d 64 69 72 29 29 20 3b 3b 20 ? real-dir)) ;;
6900: 62 61 64 20 68 65 75 72 69 73 74 69 63 20 62 75 bad heuristic bu
6910: 74 20 73 68 6f 75 6c 64 20 70 72 65 76 65 6e 74 t should prevent
6920: 20 2f 74 6d 70 20 2f 68 6f 6d 65 20 65 74 63 2e /tmp /home etc.
6930: 0a 09 09 09 20 20 20 20 20 28 62 65 67 69 6e 20 .... (begin
6940: 3b 3b 20 6c 65 74 2a 20 28 28 72 65 61 6c 70 61 ;; let* ((realpa
6950: 74 68 20 28 72 65 73 6f 6c 76 65 2d 70 61 74 68 th (resolve-path
6960: 6e 61 6d 65 20 72 75 6e 2d 64 69 72 29 29 29 0a name run-dir))).
6970: 09 09 09 20 20 20 20 20 20 20 28 64 65 62 75 67 ... (debug
6980: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 22 52 :print-info 1 "R
6990: 65 63 75 72 73 69 76 65 6c 79 20 72 65 6d 6f 76 ecursively remov
69a0: 69 6e 67 20 22 20 72 65 61 6c 2d 64 69 72 29 0a ing " real-dir).
69b0: 09 09 09 20 20 20 20 20 20 20 28 69 66 20 28 66 ... (if (f
69c0: 69 6c 65 2d 65 78 69 73 74 73 3f 20 72 65 61 6c ile-exists? real
69d0: 2d 64 69 72 29 0a 09 09 09 09 20 20 20 28 69 66 -dir)..... (if
69e0: 20 28 3e 20 28 73 79 73 74 65 6d 20 28 63 6f 6e (> (system (con
69f0: 63 20 22 72 6d 20 2d 72 66 20 22 20 72 65 61 6c c "rm -rf " real
6a00: 2d 64 69 72 29 29 20 30 29 0a 09 09 09 09 20 20 -dir)) 0).....
6a10: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
6a20: 74 20 30 20 22 45 52 52 4f 52 3a 20 54 68 65 72 t 0 "ERROR: Ther
6a30: 65 20 77 61 73 20 61 20 70 72 6f 62 6c 65 6d 20 e was a problem
6a40: 72 65 6d 6f 76 69 6e 67 20 22 20 72 65 61 6c 2d removing " real-
6a50: 64 69 72 20 22 20 77 69 74 68 20 72 6d 20 2d 66 dir " with rm -f
6a60: 22 29 29 0a 09 09 09 09 20 20 20 28 64 65 62 75 "))..... (debu
6a70: 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 g:print 0 "WARNI
6a80: 4e 47 3a 20 74 65 73 74 20 64 69 72 20 22 20 72 NG: test dir " r
6a90: 65 61 6c 2d 64 69 72 20 22 20 61 70 70 65 61 72 eal-dir " appear
6aa0: 73 20 74 6f 20 6e 6f 74 20 65 78 69 73 74 20 6f s to not exist o
6ab0: 72 20 69 73 20 6e 6f 74 20 72 65 61 64 61 62 6c r is not readabl
6ac0: 65 22 29 29 29 0a 09 09 09 20 20 20 20 20 28 69 e"))).... (i
6ad0: 66 20 72 65 61 6c 2d 64 69 72 20 0a 09 09 09 09 f real-dir .....
6ae0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
6af0: 22 57 41 52 4e 49 4e 47 3a 20 64 69 72 65 63 74 "WARNING: direct
6b00: 6f 72 79 20 22 20 72 65 61 6c 2d 64 69 72 20 22 ory " real-dir "
6b10: 20 64 6f 65 73 20 6e 6f 74 20 65 78 69 73 74 22 does not exist"
6b20: 29 0a 09 09 09 09 20 28 64 65 62 75 67 3a 70 72 )..... (debug:pr
6b30: 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 int 0 "WARNING:
6b40: 6e 6f 20 72 65 61 6c 20 64 69 72 65 63 74 6f 72 no real director
6b50: 79 20 63 6f 72 72 6f 73 70 6f 6e 64 69 6e 67 20 y corrosponding
6b60: 74 6f 20 6c 69 6e 6b 20 22 20 72 75 6e 2d 64 69 to link " run-di
6b70: 72 20 22 2c 20 6e 6f 74 68 69 6e 67 20 64 6f 6e r ", nothing don
6b80: 65 22 29 29 29 0a 09 09 09 20 28 69 66 20 28 73 e"))).... (if (s
6b90: 79 6d 62 6f 6c 69 63 2d 6c 69 6e 6b 3f 20 72 75 ymbolic-link? ru
6ba0: 6e 2d 64 69 72 29 0a 09 09 09 20 20 20 20 20 28 n-dir).... (
6bb0: 62 65 67 69 6e 0a 09 09 09 20 20 20 20 20 20 20 begin....
6bc0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
6bd0: 6f 20 31 20 22 52 65 6d 6f 76 69 6e 67 20 73 79 o 1 "Removing sy
6be0: 6d 6c 69 6e 6b 20 22 20 72 75 6e 2d 64 69 72 29 mlink " run-dir)
6bf0: 0a 09 09 09 20 20 20 20 20 20 20 28 68 61 6e 64 .... (hand
6c00: 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 le-exceptions...
6c10: 09 09 65 78 6e 0a 09 09 09 09 28 64 65 62 75 67 ..exn.....(debug
6c20: 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a :print 0 "ERROR:
6c30: 20 20 46 61 69 6c 65 64 20 74 6f 20 72 65 6d 6f Failed to remo
6c40: 76 65 20 73 79 6d 6c 69 6e 6b 20 22 20 72 75 6e ve symlink " run
6c50: 2d 64 69 72 20 28 28 63 6f 6e 64 69 74 69 6f 6e -dir ((condition
6c60: 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 -property-access
6c70: 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 or 'exn 'message
6c80: 29 20 65 78 6e 29 20 22 2c 20 61 74 74 65 6d 70 ) exn) ", attemp
6c90: 74 69 6e 67 20 74 6f 20 63 6f 6e 74 69 6e 75 65 ting to continue
6ca0: 22 29 0a 09 09 09 09 28 64 65 6c 65 74 65 2d 66 ").....(delete-f
6cb0: 69 6c 65 20 72 75 6e 2d 64 69 72 29 29 29 0a 09 ile run-dir)))..
6cc0: 09 09 20 20 20 20 20 28 69 66 20 28 64 69 72 65 .. (if (dire
6cd0: 63 74 6f 72 79 3f 20 72 75 6e 2d 64 69 72 29 0a ctory? run-dir).
6ce0: 09 09 09 09 20 28 69 66 20 28 3e 20 28 64 69 72 .... (if (> (dir
6cf0: 65 63 74 6f 72 79 2d 66 6f 6c 64 20 28 6c 61 6d ectory-fold (lam
6d00: 62 64 61 20 28 66 20 78 29 28 2b 20 31 20 78 29 bda (f x)(+ 1 x)
6d10: 29 20 30 20 72 75 6e 2d 64 69 72 29 20 30 29 0a ) 0 run-dir) 0).
6d20: 09 09 09 09 20 20 20 20 20 28 64 65 62 75 67 3a .... (debug:
6d30: 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 print 0 "WARNING
6d40: 3a 20 72 65 66 75 73 69 6e 67 20 74 6f 20 72 65 : refusing to re
6d50: 6d 6f 76 65 20 22 20 72 75 6e 2d 64 69 72 20 22 move " run-dir "
6d60: 20 61 73 20 69 74 20 69 73 20 6e 6f 74 20 65 6d as it is not em
6d70: 70 74 79 22 29 0a 09 09 09 09 20 20 20 20 20 20 pty").....
6d80: 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f (handle-exceptio
6d90: 6e 73 0a 09 09 09 09 20 20 20 20 20 20 20 65 78 ns..... ex
6da0: 6e 0a 09 09 09 09 20 20 20 20 20 20 20 28 64 65 n..... (de
6db0: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 bug:print 0 "ERR
6dc0: 4f 52 3a 20 20 46 61 69 6c 65 64 20 74 6f 20 72 OR: Failed to r
6dd0: 65 6d 6f 76 65 20 64 69 72 65 63 74 6f 72 79 20 emove directory
6de0: 22 20 72 75 6e 2d 64 69 72 20 28 28 63 6f 6e 64 " run-dir ((cond
6df0: 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 ition-property-a
6e00: 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 ccessor 'exn 'me
6e10: 73 73 61 67 65 29 20 65 78 6e 29 20 22 2c 20 61 ssage) exn) ", a
6e20: 74 74 65 6d 70 74 69 6e 67 20 74 6f 20 63 6f 6e ttempting to con
6e30: 74 69 6e 75 65 22 29 0a 09 09 09 09 20 20 20 20 tinue").....
6e40: 20 20 20 28 64 65 6c 65 74 65 2d 64 69 72 65 63 (delete-direc
6e50: 74 6f 72 79 20 72 75 6e 2d 64 69 72 29 29 29 0a tory run-dir))).
6e60: 09 09 09 09 20 28 69 66 20 72 75 6e 2d 64 69 72 .... (if run-dir
6e70: 0a 09 09 09 09 20 20 20 20 20 28 64 65 62 75 67 ..... (debug
6e80: 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e :print 0 "WARNIN
6e90: 47 3a 20 6e 6f 74 20 72 65 6d 6f 76 69 6e 67 20 G: not removing
6ea0: 22 20 72 75 6e 2d 64 69 72 20 22 20 61 73 20 69 " run-dir " as i
6eb0: 74 20 65 69 74 68 65 72 20 64 6f 65 73 6e 27 74 t either doesn't
6ec0: 20 65 78 69 73 74 20 6f 72 20 69 73 20 6e 6f 74 exist or is not
6ed0: 20 61 20 73 79 6d 6c 69 6e 6b 22 29 0a 09 09 09 a symlink")....
6ee0: 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 . (debug:pri
6ef0: 6e 74 20 30 20 22 4e 4f 54 45 3a 20 74 68 65 20 nt 0 "NOTE: the
6f00: 72 75 6e 20 64 69 72 20 66 6f 72 20 74 68 69 73 run dir for this
6f10: 20 74 65 73 74 20 69 73 20 75 6e 64 65 66 69 6e test is undefin
6f20: 65 64 2e 20 54 65 73 74 20 6d 61 79 20 68 61 76 ed. Test may hav
6f30: 65 20 61 6c 72 65 61 64 79 20 62 65 65 6e 20 64 e already been d
6f40: 65 6c 65 74 65 64 2e 22 29 29 0a 09 09 09 09 20 eleted.")).....
6f50: 29 29 29 0a 09 09 09 28 28 73 65 74 2d 73 74 61 )))....((set-sta
6f60: 74 65 2d 73 74 61 74 75 73 29 0a 09 09 09 20 28 te-status).... (
6f70: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
6f80: 20 32 20 22 6e 65 77 20 73 74 61 74 65 20 22 20 2 "new state "
6f90: 28 63 61 72 20 73 74 61 74 65 2d 73 74 61 74 75 (car state-statu
6fa0: 73 29 20 22 2c 20 6e 65 77 20 73 74 61 74 75 73 s) ", new status
6fb0: 20 22 20 28 63 61 64 72 20 73 74 61 74 65 2d 73 " (cadr state-s
6fc0: 74 61 74 75 73 29 29 0a 09 09 09 20 28 6f 70 65 tatus)).... (ope
6fd0: 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 74 n-run-close db:t
6fe0: 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 est-set-state-st
6ff0: 61 74 75 73 2d 62 79 2d 69 64 20 64 62 20 28 64 atus-by-id db (d
7000: 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 b:test-get-id te
7010: 73 74 29 20 28 63 61 72 20 73 74 61 74 65 2d 73 st) (car state-s
7020: 74 61 74 75 73 29 28 63 61 64 72 20 73 74 61 74 tatus)(cadr stat
7030: 65 2d 73 74 61 74 75 73 29 20 23 66 29 29 29 29 e-status) #f))))
7040: 29 0a 09 09 20 20 28 73 6f 72 74 20 74 65 73 74 )... (sort test
7050: 73 20 28 6c 61 6d 62 64 61 20 28 61 20 62 29 28 s (lambda (a b)(
7060: 6c 65 74 20 28 28 64 69 72 61 20 28 64 62 3a 74 let ((dira (db:t
7070: 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 20 61 est-get-rundir a
7080: 29 29 0a 09 09 09 09 09 09 20 28 64 69 72 62 20 ))....... (dirb
7090: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e (db:test-get-run
70a0: 64 69 72 20 62 29 29 29 0a 09 09 09 09 09 20 20 dir b)))......
70b0: 20 20 20 28 69 66 20 28 61 6e 64 20 28 73 74 72 (if (and (str
70c0: 69 6e 67 3f 20 64 69 72 61 29 28 73 74 72 69 6e ing? dira)(strin
70d0: 67 3f 20 64 69 72 62 29 29 0a 09 09 09 09 09 09 g? dirb)).......
70e0: 20 28 3e 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 (> (string-leng
70f0: 74 68 20 64 69 72 61 29 28 73 74 72 69 6e 67 2d th dira)(string-
7100: 6c 65 6e 67 74 68 20 64 69 72 62 29 29 0a 09 09 length dirb))...
7110: 09 09 09 09 20 23 66 29 29 29 29 29 29 29 0a 09 .... #f)))))))..
7120: 20 20 20 3b 3b 20 72 65 6d 6f 76 65 20 74 68 65 ;; remove the
7130: 20 72 75 6e 20 69 66 20 7a 65 72 6f 20 74 65 73 run if zero tes
7140: 74 73 20 72 65 6d 61 69 6e 0a 09 20 20 20 28 69 ts remain.. (i
7150: 66 20 28 65 71 3f 20 61 63 74 69 6f 6e 20 27 72 f (eq? action 'r
7160: 65 6d 6f 76 65 2d 72 75 6e 73 29 0a 09 20 20 20 emove-runs)..
7170: 20 20 20 20 28 6c 65 74 20 28 28 72 65 6d 74 65 (let ((remte
7180: 73 74 73 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c sts (open-run-cl
7190: 6f 73 65 20 64 62 3a 67 65 74 2d 74 65 73 74 73 ose db:get-tests
71a0: 2d 66 6f 72 2d 72 75 6e 20 64 62 20 28 64 62 3a -for-run db (db:
71b0: 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 get-value-by-hea
71c0: 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 der run header "
71d0: 69 64 22 29 20 23 66 20 27 28 22 44 45 4c 45 54 id") #f '("DELET
71e0: 45 44 22 29 20 27 28 22 6e 2f 61 22 29 20 6e 6f ED") '("n/a") no
71f0: 74 2d 69 6e 3a 20 23 74 29 29 29 0a 09 09 20 28 t-in: #t)))... (
7200: 69 66 20 28 6e 75 6c 6c 3f 20 72 65 6d 74 65 73 if (null? remtes
7210: 74 73 29 20 3b 3b 20 6e 6f 20 6d 6f 72 65 20 74 ts) ;; no more t
7220: 65 73 74 73 20 72 65 6d 61 69 6e 69 6e 67 0a 09 ests remaining..
7230: 09 20 20 20 20 20 28 6c 65 74 2a 20 28 28 64 70 . (let* ((dp
7240: 61 72 74 73 20 20 28 73 74 72 69 6e 67 2d 73 70 arts (string-sp
7250: 6c 69 74 20 6c 61 73 74 74 70 61 74 68 20 22 2f lit lasttpath "/
7260: 22 29 29 0a 09 09 09 20 20 20 20 28 72 75 6e 70 ")).... (runp
7270: 61 74 68 20 28 63 6f 6e 63 20 22 2f 22 20 28 73 ath (conc "/" (s
7280: 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 tring-interspers
7290: 65 20 0a 09 09 09 09 09 09 28 74 61 6b 65 20 64 e .......(take d
72a0: 70 61 72 74 73 20 28 2d 20 28 6c 65 6e 67 74 68 parts (- (length
72b0: 20 64 70 61 72 74 73 29 20 31 29 29 0a 09 09 09 dparts) 1))....
72c0: 09 09 09 22 2f 22 29 29 29 29 0a 09 09 20 20 20 ..."/"))))...
72d0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
72e0: 20 31 20 22 52 65 6d 6f 76 69 6e 67 20 72 75 6e 1 "Removing run
72f0: 3a 20 22 20 72 75 6e 6b 65 79 20 22 20 22 20 28 : " runkey " " (
7300: 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d db:get-value-by-
7310: 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 header run heade
7320: 72 20 22 72 75 6e 6e 61 6d 65 22 29 20 22 20 61 r "runname") " a
7330: 6e 64 20 72 65 6c 61 74 65 64 20 72 65 63 6f 72 nd related recor
7340: 64 22 29 0a 09 09 20 20 20 20 20 20 20 28 6f 70 d")... (op
7350: 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a en-run-close db:
7360: 64 65 6c 65 74 65 2d 72 75 6e 20 64 62 20 72 75 delete-run db ru
7370: 6e 2d 69 64 29 0a 09 09 20 20 20 20 20 20 20 3b n-id)... ;
7380: 3b 20 54 68 69 73 20 69 73 20 61 20 70 72 65 74 ; This is a pret
7390: 74 79 20 67 6f 6f 64 20 70 6c 61 63 65 20 74 6f ty good place to
73a0: 20 70 75 72 67 65 20 6f 6c 64 20 44 45 4c 45 54 purge old DELET
73b0: 45 44 20 74 65 73 74 73 0a 09 09 20 20 20 20 20 ED tests...
73c0: 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 (open-run-clos
73d0: 65 20 64 62 3a 64 65 6c 65 74 65 2d 74 65 73 74 e db:delete-test
73e0: 73 2d 66 6f 72 2d 72 75 6e 20 64 62 20 72 75 6e s-for-run db run
73f0: 2d 69 64 29 0a 09 09 20 20 20 20 20 20 20 28 6f -id)... (o
7400: 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 pen-run-close db
7410: 3a 64 65 6c 65 74 65 2d 6f 6c 64 2d 64 65 6c 65 :delete-old-dele
7420: 74 65 64 2d 74 65 73 74 2d 72 65 63 6f 72 64 73 ted-test-records
7430: 20 64 62 29 0a 09 09 20 20 20 20 20 20 20 28 6f db)... (o
7440: 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 pen-run-close db
7450: 3a 73 65 74 2d 76 61 72 20 64 62 20 22 44 45 4c :set-var db "DEL
7460: 45 54 45 44 5f 54 45 53 54 53 22 20 28 63 75 72 ETED_TESTS" (cur
7470: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 rent-seconds))..
7480: 09 20 20 20 20 20 20 20 3b 3b 20 6e 65 65 64 20 . ;; need
7490: 74 6f 20 66 69 67 75 72 65 20 6f 75 74 20 74 68 to figure out th
74a0: 65 20 70 61 74 68 20 74 6f 20 74 68 65 20 72 75 e path to the ru
74b0: 6e 20 64 69 72 20 61 6e 64 20 72 65 6d 6f 76 65 n dir and remove
74c0: 20 69 74 20 69 66 20 65 6d 70 74 79 0a 09 09 20 it if empty...
74d0: 20 20 20 20 20 20 3b 3b 20 20 20 20 28 69 66 20 ;; (if
74e0: 28 6e 75 6c 6c 3f 20 28 67 6c 6f 62 20 28 63 6f (null? (glob (co
74f0: 6e 63 20 72 75 6e 70 61 74 68 20 22 2f 2a 22 29 nc runpath "/*")
7500: 29 29 0a 09 09 20 20 20 20 20 20 20 3b 3b 20 20 ))... ;;
7510: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 20 (begin...
7520: 20 20 20 20 20 20 3b 3b 20 09 20 28 64 65 62 75 ;; . (debu
7530: 67 3a 70 72 69 6e 74 20 31 20 22 52 65 6d 6f 76 g:print 1 "Remov
7540: 69 6e 67 20 72 75 6e 20 64 69 72 20 22 20 72 75 ing run dir " ru
7550: 6e 70 61 74 68 29 0a 09 09 20 20 20 20 20 20 20 npath)...
7560: 3b 3b 20 09 20 28 73 79 73 74 65 6d 20 28 63 6f ;; . (system (co
7570: 6e 63 20 22 72 6d 64 69 72 20 2d 70 20 22 20 72 nc "rmdir -p " r
7580: 75 6e 70 61 74 68 29 29 29 29 0a 09 09 20 20 20 unpath))))...
7590: 20 20 20 20 29 29 29 29 29 0a 09 20 29 29 0a 20 ))))).. )).
75a0: 20 20 20 20 72 75 6e 73 29 29 0a 20 20 23 74 29 runs)). #t)
75b0: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
75c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
75d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
75e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
75f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 52 6f ==========.;; Ro
7600: 75 74 69 6e 65 73 20 66 6f 72 20 6d 61 6e 69 70 utines for manip
7610: 75 6c 61 74 69 6e 67 20 72 75 6e 73 0a 3b 3b 3d ulating runs.;;=
7620: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7630: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7640: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7650: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7660: 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 53 69 6e 63 65 20 =====..;; Since
7670: 6d 61 6e 79 20 63 61 6c 6c 73 20 74 6f 20 61 20 many calls to a
7680: 72 75 6e 20 72 65 71 75 69 72 65 20 70 72 65 74 run require pret
7690: 74 79 20 6d 75 63 68 20 74 68 65 20 73 61 6d 65 ty much the same
76a0: 20 73 65 74 75 70 20 0a 3b 3b 20 74 68 69 73 20 setup .;; this
76b0: 77 72 61 70 70 65 72 20 69 73 20 75 73 65 64 20 wrapper is used
76c0: 74 6f 20 72 65 64 75 63 65 20 74 68 65 20 72 65 to reduce the re
76d0: 70 6c 69 63 61 74 69 6f 6e 20 6f 66 20 63 6f 64 plication of cod
76e0: 65 0a 28 64 65 66 69 6e 65 20 28 67 65 6e 65 72 e.(define (gener
76f0: 61 6c 2d 72 75 6e 2d 63 61 6c 6c 20 73 77 69 74 al-run-call swit
7700: 63 68 6e 61 6d 65 20 61 63 74 69 6f 6e 2d 64 65 chname action-de
7710: 73 63 20 70 72 6f 63 29 0a 20 20 28 6c 65 74 20 sc proc). (let
7720: 28 28 72 75 6e 6e 61 6d 65 20 28 61 72 67 73 3a ((runname (args:
7730: 67 65 74 2d 61 72 67 20 22 3a 72 75 6e 6e 61 6d get-arg ":runnam
7740: 65 22 29 29 0a 09 28 74 61 72 67 65 74 20 20 28 e"))..(target (
7750: 69 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 if (args:get-arg
7760: 20 22 2d 74 61 72 67 65 74 22 29 0a 09 09 20 20 "-target")...
7770: 20 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 (args:get-arg
7780: 20 22 2d 74 61 72 67 65 74 22 29 0a 09 09 20 20 "-target")...
7790: 20 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 (args:get-arg
77a0: 20 22 2d 72 65 71 74 61 72 67 22 29 29 29 29 0a "-reqtarg")))).
77b0: 09 3b 3b 20 28 74 68 31 20 20 20 20 20 23 66 29 .;; (th1 #f)
77c0: 29 0a 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 ). (cond.
77d0: 20 28 28 6e 6f 74 20 74 61 72 67 65 74 29 0a 20 ((not target).
77e0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
77f0: 74 20 30 20 22 45 52 52 4f 52 3a 20 4d 69 73 73 t 0 "ERROR: Miss
7800: 69 6e 67 20 72 65 71 75 69 72 65 64 20 70 61 72 ing required par
7810: 61 6d 65 74 65 72 20 66 6f 72 20 22 20 73 77 69 ameter for " swi
7820: 74 63 68 6e 61 6d 65 20 22 2c 20 79 6f 75 20 6d tchname ", you m
7830: 75 73 74 20 73 70 65 63 69 66 79 20 74 68 65 20 ust specify the
7840: 74 61 72 67 65 74 20 77 69 74 68 20 2d 74 61 72 target with -tar
7850: 67 65 74 22 29 0a 20 20 20 20 20 20 28 65 78 69 get"). (exi
7860: 74 20 33 29 29 0a 20 20 20 20 20 28 28 6e 6f 74 t 3)). ((not
7870: 20 72 75 6e 6e 61 6d 65 29 0a 20 20 20 20 20 20 runname).
7880: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
7890: 45 52 52 4f 52 3a 20 4d 69 73 73 69 6e 67 20 72 ERROR: Missing r
78a0: 65 71 75 69 72 65 64 20 70 61 72 61 6d 65 74 65 equired paramete
78b0: 72 20 66 6f 72 20 22 20 73 77 69 74 63 68 6e 61 r for " switchna
78c0: 6d 65 20 22 2c 20 79 6f 75 20 6d 75 73 74 20 73 me ", you must s
78d0: 70 65 63 69 66 79 20 74 68 65 20 72 75 6e 20 6e pecify the run n
78e0: 61 6d 65 20 77 69 74 68 20 3a 72 75 6e 6e 61 6d ame with :runnam
78f0: 65 20 72 75 6e 6e 61 6d 65 22 29 0a 20 20 20 20 e runname").
7900: 20 20 28 65 78 69 74 20 33 29 29 0a 20 20 20 20 (exit 3)).
7910: 20 28 65 6c 73 65 0a 20 20 20 20 20 20 28 6c 65 (else. (le
7920: 74 20 28 28 64 62 20 20 20 23 66 29 0a 09 20 20 t ((db #f)..
7930: 20 20 28 6b 65 79 73 20 23 66 29 0a 09 20 20 20 (keys #f)..
7940: 20 28 74 61 72 67 65 74 20 28 6f 72 20 28 61 72 (target (or (ar
7950: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 71 gs:get-arg "-req
7960: 74 61 72 67 22 29 0a 09 09 09 28 61 72 67 73 3a targ")....(args:
7970: 67 65 74 2d 61 72 67 20 22 2d 74 61 72 67 65 74 get-arg "-target
7980: 22 29 29 29 29 0a 09 28 69 66 20 28 6e 6f 74 20 "))))..(if (not
7990: 28 73 65 74 75 70 2d 66 6f 72 2d 72 75 6e 29 29 (setup-for-run))
79a0: 0a 09 20 20 20 20 28 62 65 67 69 6e 20 0a 09 20 .. (begin ..
79b0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
79c0: 74 20 30 20 22 46 61 69 6c 65 64 20 74 6f 20 73 t 0 "Failed to s
79d0: 65 74 75 70 2c 20 65 78 69 74 69 6e 67 22 29 0a etup, exiting").
79e0: 09 20 20 20 20 20 20 28 65 78 69 74 20 31 29 29 . (exit 1))
79f0: 29 0a 09 28 69 66 20 28 61 72 67 73 3a 67 65 74 )..(if (args:get
7a00: 2d 61 72 67 20 22 2d 73 65 72 76 65 72 22 29 0a -arg "-server").
7a10: 09 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 . (open-run-c
7a20: 6c 6f 73 65 20 73 65 72 76 65 72 3a 73 74 61 72 lose server:star
7a30: 74 20 64 62 20 28 61 72 67 73 3a 67 65 74 2d 61 t db (args:get-a
7a40: 72 67 20 22 2d 73 65 72 76 65 72 22 29 29 29 0a rg "-server"))).
7a50: 09 28 73 65 74 21 20 6b 65 79 73 20 28 6b 65 79 .(set! keys (key
7a60: 73 3a 63 6f 6e 66 69 67 2d 67 65 74 2d 66 69 65 s:config-get-fie
7a70: 6c 64 73 20 2a 63 6f 6e 66 69 67 64 61 74 2a 29 lds *configdat*)
7a80: 29 0a 09 3b 3b 20 68 61 76 65 20 65 6e 6f 75 67 )..;; have enoug
7a90: 68 20 74 6f 20 70 72 6f 63 65 73 73 20 2d 74 61 h to process -ta
7aa0: 72 67 65 74 20 6f 72 20 2d 72 65 71 74 61 72 67 rget or -reqtarg
7ab0: 20 68 65 72 65 0a 09 28 69 66 20 28 61 72 67 73 here..(if (args
7ac0: 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 71 74 61 :get-arg "-reqta
7ad0: 72 67 22 29 0a 09 20 20 20 20 28 6c 65 74 2a 20 rg").. (let*
7ae0: 28 28 72 75 6e 63 6f 6e 66 69 67 66 20 28 63 6f ((runconfigf (co
7af0: 6e 63 20 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f nc *toppath* "/
7b00: 72 75 6e 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 69 runconfigs.confi
7b10: 67 22 29 29 20 3b 3b 20 44 4f 20 4e 4f 54 20 45 g")) ;; DO NOT E
7b20: 56 41 4c 55 41 54 45 20 41 4c 4c 20 0a 09 09 20 VALUATE ALL ...
7b30: 20 20 28 72 75 6e 63 6f 6e 66 69 67 20 20 28 72 (runconfig (r
7b40: 65 61 64 2d 63 6f 6e 66 69 67 20 72 75 6e 63 6f ead-config runco
7b50: 6e 66 69 67 66 20 23 66 20 23 74 20 65 6e 76 69 nfigf #f #t envi
7b60: 72 6f 6e 2d 70 61 74 74 3a 20 23 66 29 29 29 20 ron-patt: #f)))
7b70: 0a 09 20 20 20 20 20 20 28 69 66 20 28 68 61 73 .. (if (has
7b80: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
7b90: 75 6c 74 20 72 75 6e 63 6f 6e 66 69 67 20 28 61 ult runconfig (a
7ba0: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 rgs:get-arg "-re
7bb0: 71 74 61 72 67 22 29 20 23 66 29 0a 09 09 20 20 qtarg") #f)...
7bc0: 28 6b 65 79 73 3a 74 61 72 67 65 74 2d 73 65 74 (keys:target-set
7bd0: 2d 61 72 67 73 20 6b 65 79 73 20 28 61 72 67 73 -args keys (args
7be0: 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 71 74 61 :get-arg "-reqta
7bf0: 72 67 22 29 20 61 72 67 73 3a 61 72 67 2d 68 61 rg") args:arg-ha
7c00: 73 68 29 0a 09 09 20 20 20 20 0a 09 09 20 20 28 sh)... ... (
7c10: 62 65 67 69 6e 0a 09 09 20 20 20 20 28 64 65 62 begin... (deb
7c20: 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO
7c30: 52 3a 20 5b 22 20 28 61 72 67 73 3a 67 65 74 2d R: [" (args:get-
7c40: 61 72 67 20 22 2d 72 65 71 74 61 72 67 22 29 20 arg "-reqtarg")
7c50: 22 5d 20 6e 6f 74 20 66 6f 75 6e 64 20 69 6e 20 "] not found in
7c60: 22 20 72 75 6e 63 6f 6e 66 69 67 66 29 0a 09 09 " runconfigf)...
7c70: 20 20 20 20 28 69 66 20 64 62 20 28 73 71 6c 69 (if db (sqli
7c80: 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 64 62 te3:finalize! db
7c90: 29 29 0a 09 09 20 20 20 20 28 65 78 69 74 20 31 ))... (exit 1
7ca0: 29 29 29 29 0a 09 20 20 20 20 28 69 66 20 28 61 )))).. (if (a
7cb0: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 rgs:get-arg "-ta
7cc0: 72 67 65 74 22 29 0a 09 09 28 6b 65 79 73 3a 74 rget")...(keys:t
7cd0: 61 72 67 65 74 2d 73 65 74 2d 61 72 67 73 20 6b arget-set-args k
7ce0: 65 79 73 20 28 61 72 67 73 3a 67 65 74 2d 61 72 eys (args:get-ar
7cf0: 67 20 22 2d 74 61 72 67 65 74 22 20 61 72 67 73 g "-target" args
7d00: 3a 61 72 67 2d 68 61 73 68 29 20 61 72 67 73 3a :arg-hash) args:
7d10: 61 72 67 2d 68 61 73 68 29 29 29 0a 09 28 69 66 arg-hash)))..(if
7d20: 20 28 6e 6f 74 20 28 63 61 72 20 2a 63 6f 6e 66 (not (car *conf
7d30: 69 67 69 6e 66 6f 2a 29 29 0a 09 20 20 20 20 28 iginfo*)).. (
7d40: 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 64 65 begin.. (de
7d50: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 bug:print 0 "ERR
7d60: 4f 52 3a 20 41 74 74 65 6d 70 74 65 64 20 74 6f OR: Attempted to
7d70: 20 22 20 61 63 74 69 6f 6e 2d 64 65 73 63 20 22 " action-desc "
7d80: 20 62 75 74 20 72 75 6e 20 61 72 65 61 20 63 6f but run area co
7d90: 6e 66 69 67 20 66 69 6c 65 20 6e 6f 74 20 66 6f nfig file not fo
7da0: 75 6e 64 22 29 0a 09 20 20 20 20 20 20 28 65 78 und").. (ex
7db0: 69 74 20 31 29 29 0a 09 20 20 20 20 3b 3b 20 45 it 1)).. ;; E
7dc0: 78 74 72 61 63 74 20 6f 75 74 20 73 74 75 66 66 xtract out stuff
7dd0: 20 6e 65 65 64 65 64 20 69 6e 20 6d 6f 73 74 20 needed in most
7de0: 6f 72 20 6d 61 6e 79 20 63 61 6c 6c 73 0a 09 20 or many calls..
7df0: 20 20 20 3b 3b 20 68 65 72 65 20 74 68 65 6e 20 ;; here then
7e00: 63 61 6c 6c 20 70 72 6f 63 0a 09 20 20 20 20 28 call proc.. (
7e10: 6c 65 74 2a 20 28 28 6b 65 79 76 61 6c 73 20 20 let* ((keyvals
7e20: 20 20 28 6b 65 79 73 3a 74 61 72 67 65 74 2d 3e (keys:target->
7e30: 6b 65 79 76 61 6c 20 6b 65 79 73 20 74 61 72 67 keyval keys targ
7e40: 65 74 29 29 29 0a 09 20 20 20 20 20 20 28 70 72 et))).. (pr
7e50: 6f 63 20 74 61 72 67 65 74 20 72 75 6e 6e 61 6d oc target runnam
7e60: 65 20 6b 65 79 73 20 6b 65 79 76 61 6c 73 29 29 e keys keyvals))
7e70: 29 0a 09 28 69 66 20 64 62 20 28 73 71 6c 69 74 )..(if db (sqlit
7e80: 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 64 62 29 e3:finalize! db)
7e90: 29 0a 09 28 73 65 74 21 20 2a 64 69 64 73 6f 6d )..(set! *didsom
7ea0: 65 74 68 69 6e 67 2a 20 23 74 29 29 29 29 29 29 ething* #t))))))
7eb0: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
7ec0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7ed0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7ee0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7ef0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4c 6f ==========.;; Lo
7f00: 63 6b 2f 75 6e 6c 6f 63 6b 20 72 75 6e 73 0a 3b ck/unlock runs.;
7f10: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
7f20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7f30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7f40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7f50: 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 =======..(define
7f60: 20 28 72 75 6e 73 3a 68 61 6e 64 6c 65 2d 6c 6f (runs:handle-lo
7f70: 63 6b 69 6e 67 20 74 61 72 67 65 74 20 6b 65 79 cking target key
7f80: 73 20 72 75 6e 6e 61 6d 65 20 6c 6f 63 6b 20 75 s runname lock u
7f90: 6e 6c 6f 63 6b 20 75 73 65 72 29 0a 20 20 28 6c nlock user). (l
7fa0: 65 74 2a 20 28 28 64 62 20 20 20 20 20 20 20 23 et* ((db #
7fb0: 66 29 0a 09 20 28 72 75 6e 64 61 74 20 20 20 28 f).. (rundat (
7fc0: 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 72 open-run-close r
7fd0: 75 6e 73 3a 67 65 74 2d 72 75 6e 73 2d 62 79 2d uns:get-runs-by-
7fe0: 70 61 74 74 20 64 62 20 6b 65 79 73 20 72 75 6e patt db keys run
7ff0: 6e 61 6d 65 20 74 61 72 67 65 74 29 29 0a 09 20 name target))..
8000: 28 68 65 61 64 65 72 20 20 20 28 76 65 63 74 6f (header (vecto
8010: 72 2d 72 65 66 20 72 75 6e 64 61 74 20 30 29 29 r-ref rundat 0))
8020: 0a 09 20 28 72 75 6e 73 20 20 20 20 20 28 76 65 .. (runs (ve
8030: 63 74 6f 72 2d 72 65 66 20 72 75 6e 64 61 74 20 ctor-ref rundat
8040: 31 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 1))). (for-ea
8050: 63 68 20 28 6c 61 6d 62 64 61 20 28 72 75 6e 29 ch (lambda (run)
8060: 0a 09 09 28 6c 65 74 20 28 28 72 75 6e 2d 69 64 ...(let ((run-id
8070: 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 (db:get-value-b
8080: 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 y-header run hea
8090: 64 65 72 20 22 69 64 22 29 29 29 0a 09 09 20 20 der "id")))...
80a0: 28 69 66 20 28 6f 72 20 6c 6f 63 6b 0a 09 09 09 (if (or lock....
80b0: 20 20 28 61 6e 64 20 75 6e 6c 6f 63 6b 0a 09 09 (and unlock...
80c0: 09 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 . (begin..
80d0: 09 09 09 20 28 70 72 69 6e 74 20 22 44 6f 20 79 ... (print "Do y
80e0: 6f 75 20 72 65 61 6c 6c 79 20 77 69 73 68 20 74 ou really wish t
80f0: 6f 20 75 6e 6c 6f 63 6b 20 72 75 6e 20 22 20 72 o unlock run " r
8100: 75 6e 2d 69 64 20 22 3f 5c 6e 20 20 20 79 2f 6e un-id "?\n y/n
8110: 3a 20 22 29 0a 09 09 09 09 20 28 65 71 75 61 6c : ")..... (equal
8120: 3f 20 22 79 22 20 28 72 65 61 64 2d 6c 69 6e 65 ? "y" (read-line
8130: 29 29 29 29 29 0a 09 09 20 20 20 20 20 20 28 6f )))))... (o
8140: 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 pen-run-close db
8150: 3a 6c 6f 63 6b 2f 75 6e 6c 6f 63 6b 2d 72 75 6e :lock/unlock-run
8160: 20 64 62 20 72 75 6e 2d 69 64 20 6c 6f 63 6b 20 db run-id lock
8170: 75 6e 6c 6f 63 6b 20 75 73 65 72 29 0a 09 09 20 unlock user)...
8180: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
8190: 74 2d 69 6e 66 6f 20 30 20 22 53 6b 69 70 70 69 t-info 0 "Skippi
81a0: 6e 67 20 6c 6f 63 6b 2f 75 6e 6c 6f 63 6b 20 6f ng lock/unlock o
81b0: 6e 20 22 20 72 75 6e 2d 69 64 29 29 29 29 0a 09 n " run-id))))..
81c0: 20 20 20 20 20 20 72 75 6e 73 29 29 29 0a 3b 3b runs))).;;
81d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
81e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
81f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8200: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8210: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 52 6f 6c 6c 75 70 ======.;; Rollup
8220: 20 72 75 6e 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d runs.;;========
8230: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8240: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8250: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8260: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
8270: 3b 3b 20 55 70 64 61 74 65 20 74 68 65 20 74 65 ;; Update the te
8280: 73 74 5f 6d 65 74 61 20 74 61 62 6c 65 20 66 6f st_meta table fo
8290: 72 20 74 68 69 73 20 74 65 73 74 0a 28 64 65 66 r this test.(def
82a0: 69 6e 65 20 28 72 75 6e 73 3a 75 70 64 61 74 65 ine (runs:update
82b0: 2d 74 65 73 74 5f 6d 65 74 61 20 74 65 73 74 2d -test_meta test-
82c0: 6e 61 6d 65 20 74 65 73 74 2d 63 6f 6e 66 29 0a name test-conf).
82d0: 20 20 28 6c 65 74 20 28 28 63 75 72 72 72 65 63 (let ((currrec
82e0: 6f 72 64 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d ord (cdb:remote-
82f0: 72 75 6e 20 64 62 3a 74 65 73 74 6d 65 74 61 2d run db:testmeta-
8300: 67 65 74 2d 72 65 63 6f 72 64 20 23 66 20 74 65 get-record #f te
8310: 73 74 2d 6e 61 6d 65 29 29 29 0a 20 20 20 20 28 st-name))). (
8320: 69 66 20 28 6e 6f 74 20 63 75 72 72 72 65 63 6f if (not currreco
8330: 72 64 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 rd)..(begin.. (
8340: 73 65 74 21 20 63 75 72 72 72 65 63 6f 72 64 20 set! currrecord
8350: 28 6d 61 6b 65 2d 76 65 63 74 6f 72 20 31 30 20 (make-vector 10
8360: 23 66 29 29 0a 09 20 20 28 63 64 62 3a 72 65 6d #f)).. (cdb:rem
8370: 6f 74 65 2d 72 75 6e 20 64 62 3a 74 65 73 74 6d ote-run db:testm
8380: 65 74 61 2d 61 64 64 2d 72 65 63 6f 72 64 20 23 eta-add-record #
8390: 66 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a 20 f test-name))).
83a0: 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 (for-each .
83b0: 20 20 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 29 (lambda (key)
83c0: 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 . (let* ((
83d0: 69 64 78 20 28 63 61 64 72 20 6b 65 79 29 29 0a idx (cadr key)).
83e0: 09 20 20 20 20 20 20 28 66 6c 64 20 28 63 61 72 . (fld (car
83f0: 20 20 6b 65 79 29 29 0a 09 20 20 20 20 20 20 28 key)).. (
8400: 76 61 6c 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b val (config-look
8410: 75 70 20 74 65 73 74 2d 63 6f 6e 66 20 22 74 65 up test-conf "te
8420: 73 74 5f 6d 65 74 61 22 20 66 6c 64 29 29 29 0a st_meta" fld))).
8430: 09 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e . ;; (debug:prin
8440: 74 20 35 20 22 69 64 78 3a 20 22 20 69 64 78 20 t 5 "idx: " idx
8450: 22 20 66 6c 64 3a 20 22 20 66 6c 64 20 22 20 76 " fld: " fld " v
8460: 61 6c 3a 20 22 20 76 61 6c 29 0a 09 20 28 69 66 al: " val).. (if
8470: 20 28 61 6e 64 20 76 61 6c 20 28 6e 6f 74 20 28 (and val (not (
8480: 65 71 75 61 6c 3f 20 28 76 65 63 74 6f 72 2d 72 equal? (vector-r
8490: 65 66 20 63 75 72 72 72 65 63 6f 72 64 20 69 64 ef currrecord id
84a0: 78 29 20 76 61 6c 29 29 29 0a 09 20 20 20 20 20 x) val)))..
84b0: 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 20 28 (begin.. (
84c0: 70 72 69 6e 74 20 22 55 70 64 61 74 69 6e 67 20 print "Updating
84d0: 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 22 20 " test-name " "
84e0: 66 6c 64 20 22 20 74 6f 20 22 20 76 61 6c 29 0a fld " to " val).
84f0: 09 20 20 20 20 20 20 20 28 63 64 62 3a 72 65 6d . (cdb:rem
8500: 6f 74 65 2d 72 75 6e 20 64 62 3a 74 65 73 74 6d ote-run db:testm
8510: 65 74 61 2d 75 70 64 61 74 65 2d 66 69 65 6c 64 eta-update-field
8520: 20 23 66 20 74 65 73 74 2d 6e 61 6d 65 20 66 6c #f test-name fl
8530: 64 20 76 61 6c 29 29 29 29 29 0a 20 20 20 20 20 d val))))).
8540: 27 28 28 22 61 75 74 68 6f 72 22 20 32 29 28 22 '(("author" 2)("
8550: 6f 77 6e 65 72 22 20 33 29 28 22 64 65 73 63 72 owner" 3)("descr
8560: 69 70 74 69 6f 6e 22 20 34 29 28 22 72 65 76 69 iption" 4)("revi
8570: 65 77 65 64 22 20 35 29 28 22 74 61 67 73 22 20 ewed" 5)("tags"
8580: 39 29 29 29 29 29 0a 0a 3b 3b 20 55 70 64 61 74 9)))))..;; Updat
8590: 65 20 74 65 73 74 5f 6d 65 74 61 20 66 6f 72 20 e test_meta for
85a0: 61 6c 6c 20 74 65 73 74 73 0a 28 64 65 66 69 6e all tests.(defin
85b0: 65 20 28 72 75 6e 73 3a 75 70 64 61 74 65 2d 61 e (runs:update-a
85c0: 6c 6c 2d 74 65 73 74 5f 6d 65 74 61 20 64 62 29 ll-test_meta db)
85d0: 0a 20 20 28 6c 65 74 20 28 28 74 65 73 74 2d 6e . (let ((test-n
85e0: 61 6d 65 73 20 28 67 65 74 2d 61 6c 6c 2d 6c 65 ames (get-all-le
85f0: 67 61 6c 2d 74 65 73 74 73 29 29 29 0a 20 20 20 gal-tests))).
8600: 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 (for-each .
8610: 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 2d 6e (lambda (test-n
8620: 61 6d 65 29 0a 20 20 20 20 20 20 20 28 6c 65 74 ame). (let
8630: 2a 20 28 28 74 65 73 74 2d 70 61 74 68 20 20 20 * ((test-path
8640: 20 28 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a (conc *toppath*
8650: 20 22 2f 74 65 73 74 73 2f 22 20 74 65 73 74 2d "/tests/" test-
8660: 6e 61 6d 65 29 29 0a 09 20 20 20 20 20 20 28 74 name)).. (t
8670: 65 73 74 2d 63 6f 6e 66 69 67 66 20 28 63 6f 6e est-configf (con
8680: 63 20 74 65 73 74 2d 70 61 74 68 20 22 2f 74 65 c test-path "/te
8690: 73 74 63 6f 6e 66 69 67 22 29 29 0a 09 20 20 20 stconfig"))..
86a0: 20 20 20 28 74 65 73 74 65 78 69 73 74 73 20 20 (testexists
86b0: 20 28 61 6e 64 20 28 66 69 6c 65 2d 65 78 69 73 (and (file-exis
86c0: 74 73 3f 20 74 65 73 74 2d 63 6f 6e 66 69 67 66 ts? test-configf
86d0: 29 28 66 69 6c 65 2d 72 65 61 64 2d 61 63 63 65 )(file-read-acce
86e0: 73 73 3f 20 74 65 73 74 2d 63 6f 6e 66 69 67 66 ss? test-configf
86f0: 29 29 29 0a 09 20 20 20 20 20 20 3b 3b 20 72 65 ))).. ;; re
8700: 61 64 20 63 6f 6e 66 69 67 73 20 77 69 74 68 20 ad configs with
8710: 74 72 69 63 6b 73 20 74 75 72 6e 65 64 20 6f 66 tricks turned of
8720: 66 20 28 69 2e 65 2e 20 6e 6f 20 73 79 73 74 65 f (i.e. no syste
8730: 6d 29 0a 09 20 20 20 20 20 20 28 74 65 73 74 2d m).. (test-
8740: 63 6f 6e 66 20 20 20 20 28 69 66 20 74 65 73 74 conf (if test
8750: 65 78 69 73 74 73 20 28 72 65 61 64 2d 63 6f 6e exists (read-con
8760: 66 69 67 20 74 65 73 74 2d 63 6f 6e 66 69 67 66 fig test-configf
8770: 20 23 66 20 23 66 29 28 6d 61 6b 65 2d 68 61 73 #f #f)(make-has
8780: 68 2d 74 61 62 6c 65 29 29 29 29 0a 09 20 3b 3b h-table)))).. ;;
8790: 20 75 73 65 20 74 68 65 20 6f 70 65 6e 2d 72 75 use the open-ru
87a0: 6e 2d 63 6c 6f 73 65 20 69 6e 73 74 65 61 64 20 n-close instead
87b0: 6f 66 20 70 61 73 73 69 6e 67 20 69 6e 20 64 62 of passing in db
87c0: 0a 09 20 28 72 75 6e 73 3a 75 70 64 61 74 65 2d .. (runs:update-
87d0: 74 65 73 74 5f 6d 65 74 61 20 74 65 73 74 2d 6e test_meta test-n
87e0: 61 6d 65 20 74 65 73 74 2d 63 6f 6e 66 29 29 29 ame test-conf)))
87f0: 0a 20 20 20 20 20 74 65 73 74 2d 6e 61 6d 65 73 . test-names
8800: 29 29 29 0a 0a 3b 3b 20 54 68 69 73 20 63 6f 75 )))..;; This cou
8810: 6c 64 20 70 72 6f 62 61 62 6c 79 20 62 65 20 72 ld probably be r
8820: 65 66 61 63 74 6f 72 65 64 20 69 6e 74 6f 20 6f efactored into o
8830: 6e 65 20 63 6f 6d 70 6c 65 78 20 71 75 65 72 79 ne complex query
8840: 20 2e 2e 2e 0a 28 64 65 66 69 6e 65 20 28 72 75 ....(define (ru
8850: 6e 73 3a 72 6f 6c 6c 75 70 2d 72 75 6e 20 6b 65 ns:rollup-run ke
8860: 79 73 20 72 75 6e 6e 61 6d 65 20 75 73 65 72 20 ys runname user
8870: 6b 65 79 76 61 6c 73 29 0a 20 20 28 64 65 62 75 keyvals). (debu
8880: 67 3a 70 72 69 6e 74 20 34 20 22 72 75 6e 73 3a g:print 4 "runs:
8890: 72 6f 6c 6c 75 70 2d 72 75 6e 2c 20 6b 65 79 73 rollup-run, keys
88a0: 3a 20 22 20 6b 65 79 73 20 22 20 3a 72 75 6e 6e : " keys " :runn
88b0: 61 6d 65 20 22 20 72 75 6e 6e 61 6d 65 20 22 20 ame " runname "
88c0: 75 73 65 72 3a 20 22 20 75 73 65 72 29 0a 20 20 user: " user).
88d0: 28 6c 65 74 2a 20 28 28 64 62 20 20 20 20 20 20 (let* ((db
88e0: 20 20 20 20 20 20 20 20 23 66 29 0a 09 20 28 6e #f).. (n
88f0: 65 77 2d 72 75 6e 2d 69 64 20 20 20 20 20 20 28 ew-run-id (
8900: 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 64 cdb:remote-run d
8910: 62 3a 72 65 67 69 73 74 65 72 2d 72 75 6e 20 23 b:register-run #
8920: 66 20 6b 65 79 73 20 6b 65 79 76 61 6c 73 20 72 f keys keyvals r
8930: 75 6e 6e 61 6d 65 20 22 6e 65 77 22 20 22 6e 2f unname "new" "n/
8940: 61 22 20 75 73 65 72 29 29 0a 09 20 28 70 72 65 a" user)).. (pre
8950: 76 2d 74 65 73 74 73 20 20 20 20 20 20 28 6f 70 v-tests (op
8960: 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 74 65 73 en-run-close tes
8970: 74 3a 67 65 74 2d 6d 61 74 63 68 69 6e 67 2d 70 t:get-matching-p
8980: 72 65 76 69 6f 75 73 2d 74 65 73 74 2d 72 75 6e revious-test-run
8990: 2d 72 65 63 6f 72 64 73 20 64 62 20 6e 65 77 2d -records db new-
89a0: 72 75 6e 2d 69 64 20 22 25 22 20 22 25 22 29 29 run-id "%" "%"))
89b0: 0a 09 20 28 63 75 72 72 2d 74 65 73 74 73 20 20 .. (curr-tests
89c0: 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c (open-run-cl
89d0: 6f 73 65 20 64 62 3a 67 65 74 2d 74 65 73 74 73 ose db:get-tests
89e0: 2d 66 6f 72 2d 72 75 6e 20 64 62 20 6e 65 77 2d -for-run db new-
89f0: 72 75 6e 2d 69 64 20 22 25 2f 25 22 20 27 28 29 run-id "%/%" '()
8a00: 20 27 28 29 29 29 0a 09 20 28 63 75 72 72 2d 74 '())).. (curr-t
8a10: 65 73 74 73 2d 68 61 73 68 20 28 6d 61 6b 65 2d ests-hash (make-
8a20: 68 61 73 68 2d 74 61 62 6c 65 29 29 29 0a 20 20 hash-table))).
8a30: 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 (open-run-clos
8a40: 65 20 64 62 3a 75 70 64 61 74 65 2d 72 75 6e 2d e db:update-run-
8a50: 65 76 65 6e 74 5f 74 69 6d 65 20 64 62 20 6e 65 event_time db ne
8a60: 77 2d 72 75 6e 2d 69 64 29 0a 20 20 20 20 3b 3b w-run-id). ;;
8a70: 20 69 6e 64 65 78 20 74 68 65 20 61 6c 72 65 61 index the alrea
8a80: 64 79 20 73 61 76 65 64 20 74 65 73 74 73 20 62 dy saved tests b
8a90: 79 20 74 65 73 74 6e 61 6d 65 20 61 6e 64 20 69 y testname and i
8aa0: 74 65 6d 64 61 74 20 69 6e 20 63 75 72 72 2d 74 temdat in curr-t
8ab0: 65 73 74 73 2d 68 61 73 68 0a 20 20 20 20 28 66 ests-hash. (f
8ac0: 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 6c 61 or-each. (la
8ad0: 6d 62 64 61 20 28 74 65 73 74 64 61 74 29 0a 20 mbda (testdat).
8ae0: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 65 (let* ((te
8af0: 73 74 6e 61 6d 65 20 20 28 64 62 3a 74 65 73 74 stname (db:test
8b00: 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 -get-testname te
8b10: 73 74 64 61 74 29 29 0a 09 20 20 20 20 20 20 28 stdat)).. (
8b20: 69 74 65 6d 2d 70 61 74 68 20 28 64 62 3a 74 65 item-path (db:te
8b30: 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 st-get-item-path
8b40: 20 74 65 73 74 64 61 74 29 29 0a 09 20 20 20 20 testdat))..
8b50: 20 20 28 66 75 6c 6c 2d 6e 61 6d 65 20 28 63 6f (full-name (co
8b60: 6e 63 20 74 65 73 74 6e 61 6d 65 20 22 2f 22 20 nc testname "/"
8b70: 69 74 65 6d 2d 70 61 74 68 29 29 29 0a 09 20 28 item-path))).. (
8b80: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
8b90: 63 75 72 72 2d 74 65 73 74 73 2d 68 61 73 68 20 curr-tests-hash
8ba0: 66 75 6c 6c 2d 6e 61 6d 65 20 74 65 73 74 64 61 full-name testda
8bb0: 74 29 29 29 0a 20 20 20 20 20 63 75 72 72 2d 74 t))). curr-t
8bc0: 65 73 74 73 29 0a 20 20 20 20 3b 3b 20 4e 4f 50 ests). ;; NOP
8bd0: 45 3a 20 4e 6f 6e 2d 6f 70 74 69 6d 61 6c 20 61 E: Non-optimal a
8be0: 70 70 72 6f 61 63 68 2e 20 54 72 79 20 74 68 69 pproach. Try thi
8bf0: 73 20 69 6e 73 74 65 61 64 2e 0a 20 20 20 20 3b s instead.. ;
8c00: 3b 20 20 20 31 2e 20 74 65 73 74 73 20 61 72 65 ; 1. tests are
8c10: 20 72 65 63 65 69 76 65 64 20 69 6e 20 61 20 6c received in a l
8c20: 69 73 74 2c 20 6d 6f 73 74 20 72 65 63 65 6e 74 ist, most recent
8c30: 20 66 69 72 73 74 0a 20 20 20 20 3b 3b 20 20 20 first. ;;
8c40: 32 2e 20 72 65 70 6c 61 63 65 20 74 68 65 20 72 2. replace the r
8c50: 6f 6c 6c 75 70 20 74 65 73 74 20 77 69 74 68 20 ollup test with
8c60: 74 68 65 20 6e 65 77 20 2a 61 6c 77 61 79 73 2a the new *always*
8c70: 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a . (for-each .
8c80: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 74 65 (lambda (te
8c90: 73 74 64 61 74 29 0a 20 20 20 20 20 20 20 28 6c stdat). (l
8ca0: 65 74 2a 20 28 28 74 65 73 74 6e 61 6d 65 20 20 et* ((testname
8cb0: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 (db:test-get-tes
8cc0: 74 6e 61 6d 65 20 74 65 73 74 64 61 74 29 29 0a tname testdat)).
8cd0: 09 20 20 20 20 20 20 28 69 74 65 6d 2d 70 61 74 . (item-pat
8ce0: 68 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 h (db:test-get-i
8cf0: 74 65 6d 2d 70 61 74 68 20 74 65 73 74 64 61 74 tem-path testdat
8d00: 29 29 0a 09 20 20 20 20 20 20 28 66 75 6c 6c 2d )).. (full-
8d10: 6e 61 6d 65 20 28 63 6f 6e 63 20 74 65 73 74 6e name (conc testn
8d20: 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 ame "/" item-pat
8d30: 68 29 29 0a 09 20 20 20 20 20 20 28 70 72 65 76 h)).. (prev
8d40: 2d 74 65 73 74 2d 64 61 74 20 28 68 61 73 68 2d -test-dat (hash-
8d50: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
8d60: 74 20 63 75 72 72 2d 74 65 73 74 73 2d 68 61 73 t curr-tests-has
8d70: 68 20 66 75 6c 6c 2d 6e 61 6d 65 20 23 66 29 29 h full-name #f))
8d80: 0a 09 20 20 20 20 20 20 28 74 65 73 74 2d 73 74 .. (test-st
8d90: 65 70 73 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e eps (open-run
8da0: 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d 73 74 -close db:get-st
8db0: 65 70 73 2d 66 6f 72 2d 74 65 73 74 20 64 62 20 eps-for-test db
8dc0: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 (db:test-get-id
8dd0: 74 65 73 74 64 61 74 29 29 29 0a 09 20 20 20 20 testdat)))..
8de0: 20 20 28 6e 65 77 2d 74 65 73 74 2d 72 65 63 6f (new-test-reco
8df0: 72 64 20 23 66 29 29 0a 09 20 3b 3b 20 72 65 70 rd #f)).. ;; rep
8e00: 6c 61 63 65 20 74 68 65 73 65 20 77 69 74 68 20 lace these with
8e10: 69 6e 73 65 72 74 20 2e 2e 2e 20 73 65 6c 65 63 insert ... selec
8e20: 74 0a 09 20 28 61 70 70 6c 79 20 73 71 6c 69 74 t.. (apply sqlit
8e30: 65 33 3a 65 78 65 63 75 74 65 20 0a 09 09 64 62 e3:execute ...db
8e40: 20 0a 09 09 28 63 6f 6e 63 20 22 49 4e 53 45 52 ...(conc "INSER
8e50: 54 20 4f 52 20 52 45 50 4c 41 43 45 20 49 4e 54 T OR REPLACE INT
8e60: 4f 20 74 65 73 74 73 20 28 72 75 6e 5f 69 64 2c O tests (run_id,
8e70: 74 65 73 74 6e 61 6d 65 2c 73 74 61 74 65 2c 73 testname,state,s
8e80: 74 61 74 75 73 2c 65 76 65 6e 74 5f 74 69 6d 65 tatus,event_time
8e90: 2c 68 6f 73 74 2c 63 70 75 6c 6f 61 64 2c 64 69 ,host,cpuload,di
8ea0: 73 6b 66 72 65 65 2c 75 6e 61 6d 65 2c 72 75 6e skfree,uname,run
8eb0: 64 69 72 2c 69 74 65 6d 5f 70 61 74 68 2c 72 75 dir,item_path,ru
8ec0: 6e 5f 64 75 72 61 74 69 6f 6e 2c 66 69 6e 61 6c n_duration,final
8ed0: 5f 6c 6f 67 66 2c 63 6f 6d 6d 65 6e 74 29 20 22 _logf,comment) "
8ee0: 0a 09 09 20 20 20 20 20 20 22 56 41 4c 55 45 53 ... "VALUES
8ef0: 20 28 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c (?,?,?,?,?,?,?,
8f00: 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 29 3b 22 ?,?,?,?,?,?,?);"
8f10: 29 0a 09 09 6e 65 77 2d 72 75 6e 2d 69 64 20 28 )...new-run-id (
8f20: 63 64 64 72 20 28 76 65 63 74 6f 72 2d 3e 6c 69 cddr (vector->li
8f30: 73 74 20 74 65 73 74 64 61 74 29 29 29 0a 09 20 st testdat)))..
8f40: 28 73 65 74 21 20 6e 65 77 2d 74 65 73 74 64 61 (set! new-testda
8f50: 74 20 28 63 61 72 20 28 6f 70 65 6e 2d 72 75 6e t (car (open-run
8f60: 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d 74 65 -close db:get-te
8f70: 73 74 73 2d 66 6f 72 2d 72 75 6e 20 64 62 20 6e sts-for-run db n
8f80: 65 77 2d 72 75 6e 2d 69 64 20 28 63 6f 6e 63 20 ew-run-id (conc
8f90: 74 65 73 74 6e 61 6d 65 20 22 2f 22 20 69 74 65 testname "/" ite
8fa0: 6d 2d 70 61 74 68 29 20 27 28 29 20 27 28 29 29 m-path) '() '())
8fb0: 29 29 0a 09 20 28 68 61 73 68 2d 74 61 62 6c 65 )).. (hash-table
8fc0: 2d 73 65 74 21 20 63 75 72 72 2d 74 65 73 74 73 -set! curr-tests
8fd0: 2d 68 61 73 68 20 66 75 6c 6c 2d 6e 61 6d 65 20 -hash full-name
8fe0: 6e 65 77 2d 74 65 73 74 64 61 74 29 20 3b 3b 20 new-testdat) ;;
8ff0: 74 68 69 73 20 63 6f 75 6c 64 20 62 65 20 63 6f this could be co
9000: 6e 66 75 73 69 6e 67 2c 20 77 68 69 63 68 20 72 nfusing, which r
9010: 65 63 6f 72 64 20 73 68 6f 75 6c 64 20 67 6f 20 ecord should go
9020: 69 6e 74 6f 20 74 68 65 20 6c 6f 6f 6b 75 70 20 into the lookup
9030: 74 61 62 6c 65 3f 0a 09 20 3b 3b 20 4e 6f 77 20 table?.. ;; Now
9040: 64 75 70 6c 69 63 61 74 65 20 74 68 65 20 74 65 duplicate the te
9050: 73 74 20 73 74 65 70 73 0a 09 20 28 64 65 62 75 st steps.. (debu
9060: 67 3a 70 72 69 6e 74 20 34 20 22 43 6f 70 79 69 g:print 4 "Copyi
9070: 6e 67 20 72 65 63 6f 72 64 73 20 69 6e 20 74 65 ng records in te
9080: 73 74 5f 73 74 65 70 73 20 66 72 6f 6d 20 74 65 st_steps from te
9090: 73 74 5f 69 64 3d 22 20 28 64 62 3a 74 65 73 74 st_id=" (db:test
90a0: 2d 67 65 74 2d 69 64 20 74 65 73 74 64 61 74 29 -get-id testdat)
90b0: 20 22 20 74 6f 20 22 20 28 64 62 3a 74 65 73 74 " to " (db:test
90c0: 2d 67 65 74 2d 69 64 20 6e 65 77 2d 74 65 73 74 -get-id new-test
90d0: 64 61 74 29 29 0a 09 20 28 6f 70 65 6e 2d 72 75 dat)).. (open-ru
90e0: 6e 2d 63 6c 6f 73 65 20 0a 09 20 20 28 6c 61 6d n-close .. (lam
90f0: 62 64 61 20 28 29 0a 09 20 20 20 20 28 73 71 6c bda ().. (sql
9100: 69 74 65 33 3a 65 78 65 63 75 74 65 20 0a 09 20 ite3:execute ..
9110: 20 20 20 20 64 62 20 0a 09 20 20 20 20 20 28 63 db .. (c
9120: 6f 6e 63 20 22 49 4e 53 45 52 54 20 4f 52 20 52 onc "INSERT OR R
9130: 45 50 4c 41 43 45 20 49 4e 54 4f 20 74 65 73 74 EPLACE INTO test
9140: 5f 73 74 65 70 73 20 28 74 65 73 74 5f 69 64 2c _steps (test_id,
9150: 73 74 65 70 6e 61 6d 65 2c 73 74 61 74 65 2c 73 stepname,state,s
9160: 74 61 74 75 73 2c 65 76 65 6e 74 5f 74 69 6d 65 tatus,event_time
9170: 2c 63 6f 6d 6d 65 6e 74 29 20 22 0a 09 09 20 20 ,comment) "...
9180: 20 22 53 45 4c 45 43 54 20 22 20 28 64 62 3a 74 "SELECT " (db:t
9190: 65 73 74 2d 67 65 74 2d 69 64 20 6e 65 77 2d 74 est-get-id new-t
91a0: 65 73 74 64 61 74 29 20 22 2c 73 74 65 70 6e 61 estdat) ",stepna
91b0: 6d 65 2c 73 74 61 74 65 2c 73 74 61 74 75 73 2c me,state,status,
91c0: 65 76 65 6e 74 5f 74 69 6d 65 2c 63 6f 6d 6d 65 event_time,comme
91d0: 6e 74 20 46 52 4f 4d 20 74 65 73 74 5f 73 74 65 nt FROM test_ste
91e0: 70 73 20 57 48 45 52 45 20 74 65 73 74 5f 69 64 ps WHERE test_id
91f0: 3d 3f 3b 22 29 0a 09 20 20 20 20 20 28 64 62 3a =?;").. (db:
9200: 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 test-get-id test
9210: 64 61 74 29 29 0a 09 20 20 20 20 3b 3b 20 4e 6f dat)).. ;; No
9220: 77 20 64 75 70 6c 69 63 61 74 65 20 74 68 65 20 w duplicate the
9230: 74 65 73 74 20 64 61 74 61 0a 09 20 20 20 20 28 test data.. (
9240: 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 43 debug:print 4 "C
9250: 6f 70 79 69 6e 67 20 72 65 63 6f 72 64 73 20 69 opying records i
9260: 6e 20 74 65 73 74 5f 64 61 74 61 20 66 72 6f 6d n test_data from
9270: 20 74 65 73 74 5f 69 64 3d 22 20 28 64 62 3a 74 test_id=" (db:t
9280: 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 64 est-get-id testd
9290: 61 74 29 20 22 20 74 6f 20 22 20 28 64 62 3a 74 at) " to " (db:t
92a0: 65 73 74 2d 67 65 74 2d 69 64 20 6e 65 77 2d 74 est-get-id new-t
92b0: 65 73 74 64 61 74 29 29 0a 09 20 20 20 20 28 73 estdat)).. (s
92c0: 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 0a qlite3:execute .
92d0: 09 20 20 20 20 20 64 62 20 0a 09 20 20 20 20 20 . db ..
92e0: 28 63 6f 6e 63 20 22 49 4e 53 45 52 54 20 4f 52 (conc "INSERT OR
92f0: 20 52 45 50 4c 41 43 45 20 49 4e 54 4f 20 74 65 REPLACE INTO te
9300: 73 74 5f 64 61 74 61 20 28 74 65 73 74 5f 69 64 st_data (test_id
9310: 2c 63 61 74 65 67 6f 72 79 2c 76 61 72 69 61 62 ,category,variab
9320: 6c 65 2c 76 61 6c 75 65 2c 65 78 70 65 63 74 65 le,value,expecte
9330: 64 2c 74 6f 6c 2c 75 6e 69 74 73 2c 63 6f 6d 6d d,tol,units,comm
9340: 65 6e 74 29 20 22 0a 09 09 20 20 20 22 53 45 4c ent) "... "SEL
9350: 45 43 54 20 22 20 28 64 62 3a 74 65 73 74 2d 67 ECT " (db:test-g
9360: 65 74 2d 69 64 20 6e 65 77 2d 74 65 73 74 64 61 et-id new-testda
9370: 74 29 20 22 2c 63 61 74 65 67 6f 72 79 2c 76 61 t) ",category,va
9380: 72 69 61 62 6c 65 2c 76 61 6c 75 65 2c 65 78 70 riable,value,exp
9390: 65 63 74 65 64 2c 74 6f 6c 2c 75 6e 69 74 73 2c ected,tol,units,
93a0: 63 6f 6d 6d 65 6e 74 20 46 52 4f 4d 20 74 65 73 comment FROM tes
93b0: 74 5f 64 61 74 61 20 57 48 45 52 45 20 74 65 73 t_data WHERE tes
93c0: 74 5f 69 64 3d 3f 3b 22 29 0a 09 20 20 20 20 20 t_id=?;")..
93d0: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 (db:test-get-id
93e0: 74 65 73 74 64 61 74 29 29 29 29 0a 09 20 29 29 testdat)))).. ))
93f0: 0a 20 20 20 20 20 70 72 65 76 2d 74 65 73 74 73 . prev-tests
9400: 29 29 29 0a 09 20 0a 20 20 20 20 20 0a ))).. . .