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 0a 09 est-names '())..
26a0: 20 28 61 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 73 (all-test-names
26b0: 20 28 74 65 73 74 73 3a 67 65 74 2d 76 61 6c 69 (tests:get-vali
26c0: 64 2d 74 65 73 74 73 20 2a 74 6f 70 70 61 74 68 d-tests *toppath
26d0: 2a 20 22 25 22 29 29 29 20 3b 3b 20 77 65 20 6e * "%"))) ;; we n
26e0: 65 65 64 20 61 20 6c 69 73 74 20 6f 66 20 61 6c eed a list of al
26f0: 6c 20 76 61 6c 69 64 20 74 65 73 74 73 20 74 6f l valid tests to
2700: 20 63 68 65 63 6b 20 77 61 69 74 6f 6e 20 6e 61 check waiton na
2710: 6d 65 73 0a 0a 20 20 20 20 28 73 65 74 2d 6d 65 mes.. (set-me
2720: 67 61 74 65 73 74 2d 65 6e 76 2d 76 61 72 73 20 gatest-env-vars
2730: 72 75 6e 2d 69 64 20 69 6e 6b 65 79 73 3a 20 6b run-id inkeys: k
2740: 65 79 73 29 20 3b 3b 20 74 68 65 73 65 20 6d 61 eys) ;; these ma
2750: 79 20 62 65 20 6e 65 65 64 65 64 20 62 79 20 74 y be needed by t
2760: 68 65 20 6c 61 75 6e 63 68 69 6e 67 20 70 72 6f he launching pro
2770: 63 65 73 73 0a 0a 20 20 20 20 28 69 66 20 28 66 cess.. (if (f
2780: 69 6c 65 2d 65 78 69 73 74 73 3f 20 72 75 6e 63 ile-exists? runc
2790: 6f 6e 66 69 67 66 29 0a 09 28 73 65 74 75 70 2d onfigf)..(setup-
27a0: 65 6e 76 2d 64 65 66 61 75 6c 74 73 20 72 75 6e env-defaults run
27b0: 63 6f 6e 66 69 67 66 20 72 75 6e 2d 69 64 20 2a configf run-id *
27c0: 61 6c 72 65 61 64 79 2d 73 65 65 6e 2d 72 75 6e already-seen-run
27d0: 63 6f 6e 66 69 67 2d 69 6e 66 6f 2a 20 6b 65 79 config-info* key
27e0: 73 20 6b 65 79 76 61 6c 73 20 22 70 72 65 2d 6c s keyvals "pre-l
27f0: 61 75 6e 63 68 2d 65 6e 76 2d 76 61 72 73 22 29 aunch-env-vars")
2800: 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 ..(debug:print 0
2810: 20 22 57 41 52 4e 49 4e 47 3a 20 59 6f 75 20 64 "WARNING: You d
2820: 6f 20 6e 6f 74 20 68 61 76 65 20 61 20 72 75 6e o not have a run
2830: 20 63 6f 6e 66 69 67 20 66 69 6c 65 3a 20 22 20 config file: "
2840: 72 75 6e 63 6f 6e 66 69 67 66 29 29 0a 20 20 20 runconfigf)).
2850: 20 0a 20 20 20 20 3b 3b 20 6c 6f 6f 6b 20 75 70 . ;; look up
2860: 20 61 6c 6c 20 74 65 73 74 73 20 6d 61 74 63 68 all tests match
2870: 69 6e 67 20 74 68 65 20 63 6f 6d 6d 61 20 73 65 ing the comma se
2880: 70 61 72 61 74 65 64 20 6c 69 73 74 20 6f 66 20 parated list of
2890: 67 6c 6f 62 73 20 69 6e 0a 20 20 20 20 3b 3b 20 globs in. ;;
28a0: 74 65 73 74 2d 70 61 74 74 73 20 28 75 73 69 6e test-patts (usin
28b0: 67 20 25 20 61 73 20 77 69 6c 64 63 61 72 64 29 g % as wildcard)
28c0: 0a 0a 20 20 20 20 28 73 65 74 21 20 74 65 73 74 .. (set! test
28d0: 2d 6e 61 6d 65 73 20 28 74 65 73 74 73 3a 67 65 -names (tests:ge
28e0: 74 2d 76 61 6c 69 64 2d 74 65 73 74 73 20 2a 74 t-valid-tests *t
28f0: 6f 70 70 61 74 68 2a 20 74 65 73 74 2d 70 61 74 oppath* test-pat
2900: 74 73 29 29 0a 20 20 20 20 28 73 65 74 21 20 74 ts)). (set! t
2910: 65 73 74 2d 6e 61 6d 65 73 20 28 64 65 6c 65 74 est-names (delet
2920: 65 2d 64 75 70 6c 69 63 61 74 65 73 20 74 65 73 e-duplicates tes
2930: 74 2d 6e 61 6d 65 73 29 29 0a 0a 20 20 20 20 28 t-names)).. (
2940: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
2950: 20 30 20 22 74 65 73 74 20 6e 61 6d 65 73 20 22 0 "test names "
2960: 20 74 65 73 74 2d 6e 61 6d 65 73 29 0a 0a 20 20 test-names)..
2970: 20 20 3b 3b 20 6f 6e 20 74 68 65 20 66 69 72 73 ;; on the firs
2980: 74 20 70 61 73 73 20 6f 72 20 63 61 6c 6c 20 74 t pass or call t
2990: 6f 20 72 75 6e 2d 74 65 73 74 73 20 73 65 74 20 o run-tests set
29a0: 46 41 49 4c 53 20 74 6f 20 4e 4f 54 5f 53 54 41 FAILS to NOT_STA
29b0: 52 54 45 44 20 69 66 0a 20 20 20 20 3b 3b 20 2d RTED if. ;; -
29c0: 6b 65 65 70 67 6f 69 6e 67 20 69 73 20 73 70 65 keepgoing is spe
29d0: 63 69 66 69 65 64 0a 20 20 20 20 28 69 66 20 28 cified. (if (
29e0: 65 71 3f 20 2a 70 61 73 73 6e 75 6d 2a 20 30 29 eq? *passnum* 0)
29f0: 0a 09 28 62 65 67 69 6e 0a 09 20 20 3b 3b 20 68 ..(begin.. ;; h
2a00: 61 76 65 20 74 6f 20 64 65 6c 65 74 65 20 74 65 ave to delete te
2a10: 73 74 20 72 65 63 6f 72 64 73 20 77 68 65 72 65 st records where
2a20: 20 4e 4f 54 5f 53 54 41 52 54 45 44 20 73 69 6e NOT_STARTED sin
2a30: 63 65 20 74 68 65 79 20 63 61 6e 20 63 61 75 73 ce they can caus
2a40: 65 20 2d 6b 65 65 70 67 6f 69 6e 67 20 74 6f 20 e -keepgoing to
2a50: 0a 09 20 20 3b 3b 20 67 65 74 20 73 74 75 63 6b .. ;; get stuck
2a60: 20 64 75 65 20 74 6f 20 62 65 63 6f 6d 69 6e 67 due to becoming
2a70: 20 69 6e 61 63 63 65 73 73 69 62 6c 65 20 66 72 inaccessible fr
2a80: 6f 6d 20 61 20 66 61 69 6c 65 64 20 74 65 73 74 om a failed test
2a90: 2e 20 49 2e 65 2e 20 69 66 20 74 65 73 74 20 42 . I.e. if test B
2aa0: 20 64 65 70 65 6e 64 73 20 0a 09 20 20 3b 3b 20 depends .. ;;
2ab0: 6f 6e 20 74 65 73 74 20 41 20 62 75 74 20 74 65 on test A but te
2ac0: 73 74 20 42 20 72 65 61 63 68 65 64 20 74 68 65 st B reached the
2ad0: 20 70 6f 69 6e 74 20 6f 6e 20 62 65 69 6e 67 20 point on being
2ae0: 72 65 67 69 73 74 65 72 65 64 20 61 73 20 4e 4f registered as NO
2af0: 54 5f 53 54 41 52 54 45 44 20 61 6e 64 20 74 65 T_STARTED and te
2b00: 73 74 0a 09 20 20 3b 3b 20 41 20 66 61 69 6c 65 st.. ;; A faile
2b10: 64 20 66 6f 72 20 73 6f 6d 65 20 72 65 61 73 6f d for some reaso
2b20: 6e 20 74 68 65 6e 20 6f 6e 20 72 65 2d 72 75 6e n then on re-run
2b30: 20 75 73 69 6e 67 20 2d 6b 65 65 70 67 6f 69 6e using -keepgoin
2b40: 67 20 74 68 65 20 72 75 6e 20 63 61 6e 20 6e 65 g the run can ne
2b50: 76 65 72 20 63 6f 6d 70 6c 65 74 65 2e 0a 09 20 ver complete...
2b60: 20 28 63 64 62 3a 64 65 6c 65 74 65 2d 74 65 73 (cdb:delete-tes
2b70: 74 73 2d 69 6e 2d 73 74 61 74 65 20 2a 72 75 6e ts-in-state *run
2b80: 72 65 6d 6f 74 65 2a 20 72 75 6e 2d 69 64 20 22 remote* run-id "
2b90: 4e 4f 54 5f 53 54 41 52 54 45 44 22 29 0a 09 20 NOT_STARTED")..
2ba0: 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e (cdb:remote-run
2bb0: 20 64 62 3a 73 65 74 2d 74 65 73 74 73 2d 73 74 db:set-tests-st
2bc0: 61 74 65 2d 73 74 61 74 75 73 20 23 66 20 72 75 ate-status #f ru
2bd0: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 73 20 n-id test-names
2be0: 23 66 20 22 46 41 49 4c 22 20 22 4e 4f 54 5f 53 #f "FAIL" "NOT_S
2bf0: 54 41 52 54 45 44 22 20 22 46 41 49 4c 22 29 29 TARTED" "FAIL"))
2c00: 29 0a 0a 20 20 20 20 3b 3b 20 66 72 6f 6d 20 68 ).. ;; from h
2c10: 65 72 65 20 6f 6e 20 6f 75 74 20 74 68 65 20 64 ere on out the d
2c20: 62 20 77 69 6c 6c 20 62 65 20 6f 70 65 6e 65 64 b will be opened
2c30: 20 61 6e 64 20 63 6c 6f 73 65 64 20 6f 6e 20 65 and closed on e
2c40: 76 65 72 79 20 63 61 6c 6c 20 72 75 6e 73 3a 72 very call runs:r
2c50: 75 6e 2d 74 65 73 74 73 2d 71 75 65 75 65 0a 20 un-tests-queue.
2c60: 20 20 20 3b 3b 20 28 73 71 6c 69 74 65 33 3a 66 ;; (sqlite3:f
2c70: 69 6e 61 6c 69 7a 65 21 20 64 62 29 20 0a 20 20 inalize! db) .
2c80: 20 20 3b 3b 20 6e 6f 77 20 61 64 64 20 6e 6f 6e ;; now add non
2c90: 2d 64 69 72 65 63 74 6c 79 20 72 65 66 65 72 65 -directly refere
2ca0: 6e 63 65 64 20 64 65 70 65 6e 64 65 6e 63 69 65 nced dependencie
2cb0: 73 20 28 69 2e 65 2e 20 77 61 69 74 6f 6e 29 0a s (i.e. waiton).
2cc0: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 (if (not (nu
2cd0: 6c 6c 3f 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 ll? test-names))
2ce0: 0a 09 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 ..(let loop ((he
2cf0: 64 20 28 63 61 72 20 74 65 73 74 2d 6e 61 6d 65 d (car test-name
2d00: 73 29 29 0a 09 09 20 20 20 28 74 61 6c 20 28 63 s))... (tal (c
2d10: 64 72 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 29 dr test-names)))
2d20: 20 20 20 20 20 20 20 20 20 3b 3b 20 27 72 65 74 ;; 'ret
2d30: 75 72 6e 2d 70 72 6f 63 73 20 74 65 6c 6c 73 20 urn-procs tells
2d40: 74 68 65 20 63 6f 6e 66 69 67 20 72 65 61 64 65 the config reade
2d50: 72 20 74 6f 20 70 72 65 70 20 72 75 6e 6e 69 6e r to prep runnin
2d60: 67 20 73 79 73 74 65 6d 20 62 75 74 20 72 65 74 g system but ret
2d70: 75 72 6e 20 61 20 70 72 6f 63 0a 09 20 20 28 6c urn a proc.. (l
2d80: 65 74 2a 20 28 28 63 6f 6e 66 69 67 20 20 28 74 et* ((config (t
2d90: 65 73 74 73 3a 67 65 74 2d 74 65 73 74 63 6f 6e ests:get-testcon
2da0: 66 69 67 20 68 65 64 20 27 72 65 74 75 72 6e 2d fig hed 'return-
2db0: 70 72 6f 63 73 29 29 0a 09 09 20 28 77 61 69 74 procs))... (wait
2dc0: 6f 6e 73 20 28 6c 65 74 20 28 28 69 6e 73 74 72 ons (let ((instr
2dd0: 20 28 69 66 20 63 6f 6e 66 69 67 20 0a 09 09 09 (if config ....
2de0: 09 09 20 20 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f .. (config-loo
2df0: 6b 75 70 20 63 6f 6e 66 69 67 20 22 72 65 71 75 kup config "requ
2e00: 69 72 65 6d 65 6e 74 73 22 20 22 77 61 69 74 6f irements" "waito
2e10: 6e 22 29 0a 09 09 09 09 09 20 20 20 28 62 65 67 n")...... (beg
2e20: 69 6e 20 3b 3b 20 4e 6f 20 63 6f 6e 66 69 67 20 in ;; No config
2e30: 6d 65 61 6e 73 20 74 68 69 73 20 69 73 20 61 20 means this is a
2e40: 6e 6f 6e 2d 65 78 69 73 74 61 6e 74 20 74 65 73 non-existant tes
2e50: 74 0a 09 09 09 09 09 20 20 20 20 20 28 64 65 62 t...... (deb
2e60: 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO
2e70: 52 3a 20 6e 6f 6e 2d 65 78 69 73 74 65 6e 74 20 R: non-existent
2e80: 72 65 71 75 69 72 65 64 20 74 65 73 74 20 5c 22 required test \"
2e90: 22 20 68 65 64 20 22 5c 22 22 29 0a 09 09 09 09 " hed "\"").....
2ea0: 09 20 20 20 20 20 28 69 66 20 64 62 20 28 73 71 . (if db (sq
2eb0: 6c 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 lite3:finalize!
2ec0: 64 62 29 29 0a 09 09 09 09 09 20 20 20 20 20 28 db))...... (
2ed0: 65 78 69 74 20 31 29 29 29 29 29 0a 09 09 09 20 exit 1)))))....
2ee0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
2ef0: 69 6e 66 6f 20 38 20 22 77 61 69 74 6f 6e 73 20 info 8 "waitons
2f00: 73 74 72 69 6e 67 20 69 73 20 22 20 69 6e 73 74 string is " inst
2f10: 72 29 0a 09 09 09 20 20 20 20 28 6c 65 74 20 28 r).... (let (
2f20: 28 6e 65 77 77 61 69 74 6f 6e 73 0a 09 09 09 09 (newwaitons.....
2f30: 20 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 (string-split
2f40: 20 28 63 6f 6e 64 0a 09 09 09 09 09 09 20 20 28 (cond....... (
2f50: 28 70 72 6f 63 65 64 75 72 65 3f 20 69 6e 73 74 (procedure? inst
2f60: 72 29 0a 09 09 09 09 09 09 20 20 20 28 6c 65 74 r)....... (let
2f70: 20 28 28 72 65 73 20 28 69 6e 73 74 72 29 29 29 ((res (instr)))
2f80: 0a 09 09 09 09 09 09 20 20 20 20 20 28 64 65 62 ....... (deb
2f90: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 38 20 ug:print-info 8
2fa0: 22 77 61 69 74 6f 6e 20 70 72 6f 63 65 64 75 72 "waiton procedur
2fb0: 65 20 72 65 73 75 6c 74 73 20 69 6e 20 73 74 72 e results in str
2fc0: 69 6e 67 20 22 20 72 65 73 20 22 20 66 6f 72 20 ing " res " for
2fd0: 74 65 73 74 20 22 20 68 65 64 29 0a 09 09 09 09 test " hed).....
2fe0: 09 09 20 20 20 20 20 72 65 73 29 29 0a 09 09 09 .. res))....
2ff0: 09 09 09 20 20 28 28 73 74 72 69 6e 67 3f 20 69 ... ((string? i
3000: 6e 73 74 72 29 20 20 20 20 20 69 6e 73 74 72 29 nstr) instr)
3010: 0a 09 09 09 09 09 09 20 20 28 65 6c 73 65 20 0a ....... (else .
3020: 09 09 09 09 09 09 20 20 20 3b 3b 20 4e 4f 54 45 ...... ;; NOTE
3030: 3a 20 54 68 69 73 20 69 73 20 61 63 74 75 61 6c : This is actual
3040: 6c 79 20 74 68 65 20 63 61 73 65 20 6f 66 20 2a ly the case of *
3050: 6e 6f 2a 20 77 61 69 74 6f 6e 73 21 20 3b 3b 20 no* waitons! ;;
3060: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
3070: 45 52 52 4f 52 3a 20 73 6f 6d 65 74 68 69 6e 67 ERROR: something
3080: 20 77 65 6e 74 20 77 72 6f 6e 67 20 69 6e 20 70 went wrong in p
3090: 72 6f 63 65 73 73 69 6e 67 20 77 61 69 74 6f 6e rocessing waiton
30a0: 73 20 66 6f 72 20 74 65 73 74 20 22 20 68 65 64 s for test " hed
30b0: 29 0a 09 09 09 09 09 09 20 20 20 22 22 29 29 29 )....... "")))
30c0: 29 29 0a 09 09 09 20 20 20 20 20 20 28 66 69 6c )).... (fil
30d0: 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 0a ter (lambda (x).
30e0: 09 09 09 09 09 28 69 66 20 28 6d 65 6d 62 65 72 .....(if (member
30f0: 20 78 20 61 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 x all-test-name
3100: 73 29 0a 09 09 09 09 09 20 20 20 20 23 74 0a 09 s)...... #t..
3110: 09 09 09 09 20 20 20 20 28 62 65 67 69 6e 0a 09 .... (begin..
3120: 09 09 09 09 20 20 20 20 20 20 28 64 65 62 75 67 .... (debug
3130: 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a :print 0 "ERROR:
3140: 20 74 65 73 74 20 22 20 68 65 64 20 22 20 68 61 test " hed " ha
3150: 73 20 75 6e 72 65 63 6f 67 6e 69 73 65 64 20 77 s unrecognised w
3160: 61 69 74 6f 6e 20 74 65 73 74 6e 61 6d 65 20 22 aiton testname "
3170: 20 78 29 0a 09 09 09 09 09 20 20 20 20 20 20 23 x)...... #
3180: 66 29 29 29 0a 09 09 09 09 20 20 20 20 20 20 6e f)))..... n
3190: 65 77 77 61 69 74 6f 6e 73 29 29 29 29 29 0a 09 ewwaitons)))))..
31a0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
31b0: 2d 69 6e 66 6f 20 38 20 22 77 61 69 74 6f 6e 73 -info 8 "waitons
31c0: 3a 20 22 20 77 61 69 74 6f 6e 73 29 0a 09 20 20 : " waitons)..
31d0: 20 20 3b 3b 20 63 68 65 63 6b 20 66 6f 72 20 68 ;; check for h
31e0: 65 64 20 69 6e 20 77 61 69 74 6f 6e 73 20 3d 3e ed in waitons =>
31f0: 20 74 68 69 73 20 77 6f 75 6c 64 20 62 65 20 63 this would be c
3200: 69 72 63 75 6c 61 72 2c 20 72 65 6d 6f 76 65 20 ircular, remove
3210: 69 74 20 61 6e 64 20 69 73 73 75 65 20 61 6e 0a it and issue an.
3220: 09 20 20 20 20 3b 3b 20 65 72 72 6f 72 0a 09 20 . ;; error..
3230: 20 20 20 28 69 66 20 28 6d 65 6d 62 65 72 20 68 (if (member h
3240: 65 64 20 77 61 69 74 6f 6e 73 29 0a 09 09 28 62 ed waitons)...(b
3250: 65 67 69 6e 0a 09 09 20 20 28 64 65 62 75 67 3a egin... (debug:
3260: 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 print 0 "ERROR:
3270: 74 65 73 74 20 22 20 68 65 64 20 22 20 68 61 73 test " hed " has
3280: 20 6c 69 73 74 65 64 20 69 74 73 65 6c 66 20 61 listed itself a
3290: 73 20 61 20 77 61 69 74 6f 6e 2c 20 70 6c 65 61 s a waiton, plea
32a0: 73 65 20 63 6f 72 72 65 63 74 20 74 68 69 73 21 se correct this!
32b0: 22 29 0a 09 09 20 20 28 73 65 74 21 20 77 61 69 ")... (set! wai
32c0: 74 6f 6e 73 20 28 66 69 6c 74 65 72 20 28 6c 61 tons (filter (la
32d0: 6d 62 64 61 20 28 78 29 28 6e 6f 74 20 28 65 71 mbda (x)(not (eq
32e0: 75 61 6c 3f 20 78 20 68 65 64 29 29 29 20 77 61 ual? x hed))) wa
32f0: 69 74 6f 6e 73 29 29 29 29 0a 09 20 20 20 20 0a itons)))).. .
3300: 09 20 20 20 20 3b 3b 20 28 69 74 65 6d 73 20 20 . ;; (items
3310: 20 28 69 74 65 6d 73 3a 67 65 74 2d 69 74 65 6d (items:get-item
3320: 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 20 63 6f s-from-config co
3330: 6e 66 69 67 29 29 29 0a 09 20 20 20 20 28 69 66 nfig))).. (if
3340: 20 28 6e 6f 74 20 28 68 61 73 68 2d 74 61 62 6c (not (hash-tabl
3350: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 65 e-ref/default te
3360: 73 74 2d 72 65 63 6f 72 64 73 20 68 65 64 20 23 st-records hed #
3370: 66 29 29 0a 09 09 28 68 61 73 68 2d 74 61 62 6c f))...(hash-tabl
3380: 65 2d 73 65 74 21 20 74 65 73 74 2d 72 65 63 6f e-set! test-reco
3390: 72 64 73 0a 09 09 09 09 20 68 65 64 20 28 76 65 rds..... hed (ve
33a0: 63 74 6f 72 20 68 65 64 20 20 20 20 20 3b 3b 20 ctor hed ;;
33b0: 30 0a 09 09 09 09 09 20 20 20 20 20 63 6f 6e 66 0...... conf
33c0: 69 67 20 20 3b 3b 20 31 0a 09 09 09 09 09 20 20 ig ;; 1......
33d0: 20 20 20 77 61 69 74 6f 6e 73 20 3b 3b 20 32 0a waitons ;; 2.
33e0: 09 09 09 09 09 20 20 20 20 20 28 63 6f 6e 66 69 ..... (confi
33f0: 67 2d 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 20 g-lookup config
3400: 22 72 65 71 75 69 72 65 6d 65 6e 74 73 22 20 22 "requirements" "
3410: 70 72 69 6f 72 69 74 79 22 29 20 20 20 20 20 3b priority") ;
3420: 3b 20 70 72 69 6f 72 69 74 79 20 33 0a 09 09 09 ; priority 3....
3430: 09 09 20 20 20 20 20 28 6c 65 74 20 28 28 69 74 .. (let ((it
3440: 65 6d 73 20 20 20 20 20 20 28 68 61 73 68 2d 74 ems (hash-t
3450: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
3460: 20 63 6f 6e 66 69 67 20 22 69 74 65 6d 73 22 20 config "items"
3470: 23 66 29 29 20 3b 3b 20 69 74 65 6d 73 20 34 0a #f)) ;; items 4.
3480: 09 09 09 09 09 09 20 20 20 28 69 74 65 6d 73 74 ...... (itemst
3490: 61 62 6c 65 20 28 68 61 73 68 2d 74 61 62 6c 65 able (hash-table
34a0: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 63 6f 6e -ref/default con
34b0: 66 69 67 20 22 69 74 65 6d 73 74 61 62 6c 65 22 fig "itemstable"
34c0: 20 23 66 29 29 29 20 0a 09 09 09 09 09 20 20 20 #f))) ......
34d0: 20 20 20 20 3b 3b 20 69 66 20 65 69 74 68 65 72 ;; if either
34e0: 20 69 74 65 6d 73 20 6f 72 20 69 74 65 6d 73 20 items or items
34f0: 74 61 62 6c 65 20 69 73 20 61 20 70 72 6f 63 20 table is a proc
3500: 72 65 74 75 72 6e 20 69 74 20 73 6f 20 74 65 73 return it so tes
3510: 74 20 72 75 6e 6e 69 6e 67 0a 09 09 09 09 09 20 t running......
3520: 20 20 20 20 20 20 3b 3b 20 70 72 6f 63 65 73 73 ;; process
3530: 20 63 61 6e 20 6b 6e 6f 77 20 74 6f 20 63 61 6c can know to cal
3540: 6c 20 69 74 65 6d 73 3a 67 65 74 2d 69 74 65 6d l items:get-item
3550: 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 0a 09 09 s-from-config...
3560: 09 09 09 20 20 20 20 20 20 20 3b 3b 20 69 66 20 ... ;; if
3570: 65 69 74 68 65 72 20 69 73 20 61 20 6c 69 73 74 either is a list
3580: 20 61 6e 64 20 6e 6f 6e 65 20 69 73 20 61 20 70 and none is a p
3590: 72 6f 63 20 67 6f 20 61 68 65 61 64 20 61 6e 64 roc go ahead and
35a0: 20 63 61 6c 6c 20 67 65 74 2d 69 74 65 6d 73 0a call get-items.
35b0: 09 09 09 09 09 20 20 20 20 20 20 20 3b 3b 20 6f ..... ;; o
35c0: 74 68 65 72 77 69 73 65 20 72 65 74 75 72 6e 20 therwise return
35d0: 23 66 20 2d 20 74 68 69 73 20 69 73 20 6e 6f 74 #f - this is not
35e0: 20 61 6e 20 69 74 65 72 61 74 65 64 20 74 65 73 an iterated tes
35f0: 74 0a 09 09 09 09 09 20 20 20 20 20 20 20 28 63 t...... (c
3600: 6f 6e 64 0a 09 09 09 09 09 09 28 28 70 72 6f 63 ond.......((proc
3610: 65 64 75 72 65 3f 20 69 74 65 6d 73 29 20 20 20 edure? items)
3620: 20 20 20 0a 09 09 09 09 09 09 20 28 64 65 62 75 ....... (debu
3630: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 g:print-info 4 "
3640: 69 74 65 6d 73 20 69 73 20 61 20 70 72 6f 63 65 items is a proce
3650: 64 75 72 65 2c 20 77 69 6c 6c 20 63 61 6c 63 20 dure, will calc
3660: 6c 61 74 65 72 22 29 0a 09 09 09 09 09 09 20 69 later")....... i
3670: 74 65 6d 73 29 20 20 20 20 20 20 20 20 20 20 20 tems)
3680: 20 3b 3b 20 63 61 6c 63 20 6c 61 74 65 72 0a 09 ;; calc later..
3690: 09 09 09 09 09 28 28 70 72 6f 63 65 64 75 72 65 .....((procedure
36a0: 3f 20 69 74 65 6d 73 74 61 62 6c 65 29 0a 09 09 ? itemstable)...
36b0: 09 09 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e .... (debug:prin
36c0: 74 2d 69 6e 66 6f 20 34 20 22 69 74 65 6d 73 74 t-info 4 "itemst
36d0: 61 62 6c 65 20 69 73 20 61 20 70 72 6f 63 65 64 able is a proced
36e0: 75 72 65 2c 20 77 69 6c 6c 20 63 61 6c 63 20 6c ure, will calc l
36f0: 61 74 65 72 22 29 0a 09 09 09 09 09 09 20 69 74 ater")....... it
3700: 65 6d 73 74 61 62 6c 65 29 20 20 20 20 20 20 20 emstable)
3710: 3b 3b 20 63 61 6c 63 20 6c 61 74 65 72 0a 09 09 ;; calc later...
3720: 09 09 09 09 28 28 66 69 6c 74 65 72 20 28 6c 61 ....((filter (la
3730: 6d 62 64 61 20 28 78 29 0a 09 09 09 09 09 09 09 mbda (x)........
3740: 20 20 20 28 6c 65 74 20 28 28 76 61 6c 20 28 63 (let ((val (c
3750: 61 72 20 78 29 29 29 0a 09 09 09 09 09 09 09 20 ar x)))........
3760: 20 20 20 20 28 69 66 20 28 70 72 6f 63 65 64 75 (if (procedu
3770: 72 65 3f 20 76 61 6c 29 20 76 61 6c 20 23 66 29 re? val) val #f)
3780: 29 29 0a 09 09 09 09 09 09 09 20 28 61 70 70 65 ))........ (appe
3790: 6e 64 20 28 69 66 20 28 6c 69 73 74 3f 20 69 74 nd (if (list? it
37a0: 65 6d 73 29 20 69 74 65 6d 73 20 27 28 29 29 0a ems) items '()).
37b0: 09 09 09 09 09 09 09 09 20 28 69 66 20 28 6c 69 ........ (if (li
37c0: 73 74 3f 20 69 74 65 6d 73 74 61 62 6c 65 29 20 st? itemstable)
37d0: 69 74 65 6d 73 74 61 62 6c 65 20 27 28 29 29 29 itemstable '()))
37e0: 29 0a 09 09 09 09 09 09 20 27 68 61 76 65 2d 70 )....... 'have-p
37f0: 72 6f 63 65 64 75 72 65 29 0a 09 09 09 09 09 09 rocedure).......
3800: 28 28 6f 72 20 28 6c 69 73 74 3f 20 69 74 65 6d ((or (list? item
3810: 73 29 28 6c 69 73 74 3f 20 69 74 65 6d 73 74 61 s)(list? itemsta
3820: 62 6c 65 29 29 20 3b 3b 20 63 61 6c 63 20 6e 6f ble)) ;; calc no
3830: 77 0a 09 09 09 09 09 09 20 28 64 65 62 75 67 3a w....... (debug:
3840: 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 69 74 print-info 4 "it
3850: 65 6d 73 20 61 6e 64 20 69 74 65 6d 73 74 61 62 ems and itemstab
3860: 6c 65 20 61 72 65 20 6c 69 73 74 73 2c 20 63 61 le are lists, ca
3870: 6c 63 20 6e 6f 77 5c 6e 22 0a 09 09 09 09 09 09 lc now\n".......
3880: 09 20 20 20 20 20 20 22 20 20 20 20 69 74 65 6d . " item
3890: 73 3a 20 22 20 69 74 65 6d 73 20 22 20 69 74 65 s: " items " ite
38a0: 6d 73 74 61 62 6c 65 3a 20 22 20 69 74 65 6d 73 mstable: " items
38b0: 74 61 62 6c 65 29 0a 09 09 09 09 09 09 20 28 69 table)....... (i
38c0: 74 65 6d 73 3a 67 65 74 2d 69 74 65 6d 73 2d 66 tems:get-items-f
38d0: 72 6f 6d 2d 63 6f 6e 66 69 67 20 63 6f 6e 66 69 rom-config confi
38e0: 67 29 29 0a 09 09 09 09 09 09 28 65 6c 73 65 20 g)).......(else
38f0: 23 66 29 29 29 20 20 20 20 20 20 20 20 20 20 20 #f)))
3900: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3910: 3b 3b 20 6e 6f 74 20 69 74 65 72 61 74 65 64 0a ;; not iterated.
3920: 09 09 09 09 09 20 20 20 20 20 23 66 20 20 20 20 ..... #f
3930: 20 20 3b 3b 20 69 74 65 6d 73 64 61 74 20 35 0a ;; itemsdat 5.
3940: 09 09 09 09 09 20 20 20 20 20 23 66 20 20 20 20 ..... #f
3950: 20 20 3b 3b 20 73 70 61 72 65 20 2d 20 75 73 65 ;; spare - use
3960: 64 20 66 6f 72 20 69 74 65 6d 2d 70 61 74 68 0a d for item-path.
3970: 09 09 09 09 09 20 20 20 20 20 29 29 29 0a 09 20 ..... )))..
3980: 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 09 20 (for-each ..
3990: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 77 61 69 (lambda (wai
39a0: 74 6f 6e 29 0a 09 20 20 20 20 20 20 20 28 69 66 ton).. (if
39b0: 20 28 61 6e 64 20 77 61 69 74 6f 6e 20 28 6e 6f (and waiton (no
39c0: 74 20 28 6d 65 6d 62 65 72 20 77 61 69 74 6f 6e t (member waiton
39d0: 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 29 0a 09 test-names)))..
39e0: 09 20 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 . (begin...
39f0: 20 20 28 73 65 74 21 20 72 65 71 75 69 72 65 64 (set! required
3a00: 2d 74 65 73 74 73 20 28 63 6f 6e 73 20 77 61 69 -tests (cons wai
3a10: 74 6f 6e 20 72 65 71 75 69 72 65 64 2d 74 65 73 ton required-tes
3a20: 74 73 29 29 0a 09 09 20 20 20 20 20 28 73 65 74 ts))... (set
3a30: 21 20 74 65 73 74 2d 6e 61 6d 65 73 20 28 63 6f ! test-names (co
3a40: 6e 73 20 77 61 69 74 6f 6e 20 74 65 73 74 2d 6e ns waiton test-n
3a50: 61 6d 65 73 29 29 29 29 29 20 3b 3b 20 77 61 73 ames))))) ;; was
3a60: 20 61 6e 20 61 70 70 65 6e 64 2c 20 6e 6f 77 20 an append, now
3a70: 61 20 63 6f 6e 73 0a 09 20 20 20 20 20 77 61 69 a cons.. wai
3a80: 74 6f 6e 73 29 0a 09 20 20 20 20 28 6c 65 74 20 tons).. (let
3a90: 28 28 72 65 6d 74 65 73 74 73 20 28 64 65 6c 65 ((remtests (dele
3aa0: 74 65 2d 64 75 70 6c 69 63 61 74 65 73 20 28 61 te-duplicates (a
3ab0: 70 70 65 6e 64 20 77 61 69 74 6f 6e 73 20 74 61 ppend waitons ta
3ac0: 6c 29 29 29 29 0a 09 20 20 20 20 20 20 28 69 66 l)))).. (if
3ad0: 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 6d (not (null? rem
3ae0: 74 65 73 74 73 29 29 0a 09 09 20 20 28 6c 6f 6f tests))... (loo
3af0: 70 20 28 63 61 72 20 72 65 6d 74 65 73 74 73 29 p (car remtests)
3b00: 28 63 64 72 20 72 65 6d 74 65 73 74 73 29 29 29 (cdr remtests)))
3b10: 29 29 29 29 0a 0a 20 20 20 20 28 69 66 20 28 6e )))).. (if (n
3b20: 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 71 75 69 72 ot (null? requir
3b30: 65 64 2d 74 65 73 74 73 29 29 0a 09 28 64 65 62 ed-tests))..(deb
3b40: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 ug:print-info 1
3b50: 22 41 64 64 69 6e 67 20 22 20 72 65 71 75 69 72 "Adding " requir
3b60: 65 64 2d 74 65 73 74 73 20 22 20 74 6f 20 74 68 ed-tests " to th
3b70: 65 20 72 75 6e 20 71 75 65 75 65 22 29 29 0a 20 e run queue")).
3b80: 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 74 68 65 73 ;; NOTE: thes
3b90: 65 20 61 72 65 20 61 6c 6c 20 70 61 72 65 6e 74 e are all parent
3ba0: 20 74 65 73 74 73 2c 20 69 74 65 6d 73 20 61 72 tests, items ar
3bb0: 65 20 6e 6f 74 20 65 78 70 61 6e 64 65 64 20 79 e not expanded y
3bc0: 65 74 2e 0a 20 20 20 20 28 64 65 62 75 67 3a 70 et.. (debug:p
3bd0: 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 74 65 73 rint-info 4 "tes
3be0: 74 2d 72 65 63 6f 72 64 73 3d 22 20 28 68 61 73 t-records=" (has
3bf0: 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 20 74 h-table->alist t
3c00: 65 73 74 2d 72 65 63 6f 72 64 73 29 29 0a 20 20 est-records)).
3c10: 20 20 28 6c 65 74 20 28 28 72 65 67 6c 65 6e 20 (let ((reglen
3c20: 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 20 20 28 63 (any->number (c
3c30: 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 onfigf:lookup *c
3c40: 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 70 onfigdat* "setup
3c50: 22 20 22 72 75 6e 71 75 65 75 65 22 29 29 29 29 " "runqueue"))))
3c60: 0a 20 20 20 20 20 20 28 69 66 20 72 65 67 6c 65 . (if regle
3c70: 6e 0a 09 20 20 28 72 75 6e 73 3a 72 75 6e 2d 74 n.. (runs:run-t
3c80: 65 73 74 73 2d 71 75 65 75 65 2d 6e 65 77 20 72 ests-queue-new r
3c90: 75 6e 2d 69 64 20 72 75 6e 6e 61 6d 65 20 74 65 un-id runname te
3ca0: 73 74 2d 72 65 63 6f 72 64 73 20 66 6c 61 67 73 st-records flags
3cb0: 20 74 65 73 74 2d 70 61 74 74 73 20 72 65 67 6c test-patts regl
3cc0: 65 6e 29 0a 09 20 20 28 72 75 6e 73 3a 72 75 6e en).. (runs:run
3cd0: 2d 74 65 73 74 73 2d 71 75 65 75 65 2d 63 6c 61 -tests-queue-cla
3ce0: 73 73 69 63 20 72 75 6e 2d 69 64 20 72 75 6e 6e ssic run-id runn
3cf0: 61 6d 65 20 74 65 73 74 2d 72 65 63 6f 72 64 73 ame test-records
3d00: 20 66 6c 61 67 73 20 74 65 73 74 2d 70 61 74 74 flags test-patt
3d10: 73 29 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a s))). (debug:
3d20: 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 41 6c print-info 4 "Al
3d30: 6c 20 64 6f 6e 65 20 62 79 20 68 65 72 65 22 29 l done by here")
3d40: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 6e ))..(define (run
3d50: 73 3a 63 61 6c 63 2d 66 61 69 6c 73 20 70 72 65 s:calc-fails pre
3d60: 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 0a 20 20 reqs-not-met).
3d70: 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 (filter (lambda
3d80: 28 74 65 73 74 29 0a 09 20 20 20 20 28 61 6e 64 (test).. (and
3d90: 20 28 76 65 63 74 6f 72 3f 20 74 65 73 74 29 20 (vector? test)
3da0: 3b 3b 20 6e 6f 74 20 28 73 74 72 69 6e 67 3f 20 ;; not (string?
3db0: 74 65 73 74 29 29 0a 09 09 20 28 65 71 75 61 6c test))... (equal
3dc0: 3f 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 ? (db:test-get-s
3dd0: 74 61 74 65 20 74 65 73 74 29 20 22 43 4f 4d 50 tate test) "COMP
3de0: 4c 45 54 45 44 22 29 0a 09 09 20 28 6e 6f 74 20 LETED")... (not
3df0: 28 6d 65 6d 62 65 72 20 28 64 62 3a 74 65 73 74 (member (db:test
3e00: 2d 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 -get-status test
3e10: 29 0a 09 09 09 20 20 20 20 20 20 27 28 22 50 41 ).... '("PA
3e20: 53 53 22 20 22 57 41 52 4e 22 20 22 43 48 45 43 SS" "WARN" "CHEC
3e30: 4b 22 20 22 57 41 49 56 45 44 22 20 22 53 4b 49 K" "WAIVED" "SKI
3e40: 50 22 29 29 29 29 29 0a 09 20 20 70 72 65 72 65 P"))))).. prere
3e50: 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 0a 0a 28 64 qs-not-met))..(d
3e60: 65 66 69 6e 65 20 28 72 75 6e 73 3a 63 61 6c 63 efine (runs:calc
3e70: 2d 6e 6f 74 2d 63 6f 6d 70 6c 65 74 65 64 20 70 -not-completed p
3e80: 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 0a rereqs-not-met).
3e90: 20 20 28 66 69 6c 74 65 72 0a 20 20 20 28 6c 61 (filter. (la
3ea0: 6d 62 64 61 20 28 74 29 0a 20 20 20 20 20 28 6f mbda (t). (o
3eb0: 72 20 28 6e 6f 74 20 28 76 65 63 74 6f 72 3f 20 r (not (vector?
3ec0: 74 29 29 0a 09 20 28 6e 6f 74 20 28 65 71 75 61 t)).. (not (equa
3ed0: 6c 3f 20 22 43 4f 4d 50 4c 45 54 45 44 22 20 28 l? "COMPLETED" (
3ee0: 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 db:test-get-stat
3ef0: 65 20 74 29 29 29 29 29 0a 20 20 20 70 72 65 72 e t))))). prer
3f00: 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 0a 0a 28 eqs-not-met))..(
3f10: 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 70 72 65 define (runs:pre
3f20: 74 74 79 2d 73 74 72 69 6e 67 20 6c 73 74 29 0a tty-string lst).
3f30: 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 (map (lambda (
3f40: 74 29 0a 09 20 28 69 66 20 28 6e 6f 74 20 28 76 t).. (if (not (v
3f50: 65 63 74 6f 72 3f 20 74 29 29 0a 09 20 20 20 20 ector? t))..
3f60: 20 28 63 6f 6e 63 20 74 29 0a 09 20 20 20 20 20 (conc t)..
3f70: 28 63 6f 6e 63 20 28 64 62 3a 74 65 73 74 2d 67 (conc (db:test-g
3f80: 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 29 20 22 et-testname t) "
3f90: 3a 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d :" (db:test-get-
3fa0: 73 74 61 74 65 20 74 29 20 22 2f 22 20 28 64 62 state t) "/" (db
3fb0: 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 73 :test-get-status
3fc0: 20 74 29 29 29 29 0a 20 20 20 20 20 20 20 6c 73 t)))). ls
3fd0: 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 t))..(define (ru
3fe0: 6e 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 ns:make-full-tes
3ff0: 74 2d 6e 61 6d 65 20 74 65 73 74 6e 61 6d 65 20 t-name testname
4000: 69 74 65 6d 70 61 74 68 29 0a 20 20 28 69 66 20 itempath). (if
4010: 28 65 71 75 61 6c 3f 20 69 74 65 6d 70 61 74 68 (equal? itempath
4020: 20 22 22 29 20 74 65 73 74 6e 61 6d 65 20 28 63 "") testname (c
4030: 6f 6e 63 20 74 65 73 74 6e 61 6d 65 20 22 2f 22 onc testname "/"
4040: 20 69 74 65 6d 70 61 74 68 29 29 29 0a 0a 28 64 itempath)))..(d
4050: 65 66 69 6e 65 20 28 72 75 6e 73 3a 71 75 65 75 efine (runs:queu
4060: 65 2d 6e 65 78 74 2d 68 65 64 20 74 61 6c 20 72 e-next-hed tal r
4070: 65 67 20 6e 20 72 65 67 66 75 6c 29 0a 20 20 28 eg n regful). (
4080: 69 66 20 72 65 67 66 75 6c 0a 20 20 20 20 20 20 if regful.
4090: 28 69 66 20 28 6e 75 6c 6c 3f 20 72 65 67 29 20 (if (null? reg)
40a0: 3b 3b 20 64 6f 65 73 6e 27 74 20 6d 61 6b 65 20 ;; doesn't make
40b0: 73 65 6e 73 65 2c 20 74 68 69 73 20 69 73 20 70 sense, this is p
40c0: 72 6f 62 61 62 6c 79 20 4e 4f 54 20 74 68 65 20 robably NOT the
40d0: 70 72 6f 62 6c 65 6d 20 6f 66 20 74 68 65 20 63 problem of the c
40e0: 61 72 0a 09 20 20 28 63 61 72 20 74 61 6c 29 0a ar.. (car tal).
40f0: 09 20 20 28 63 61 72 20 72 65 67 29 29 0a 20 20 . (car reg)).
4100: 20 20 20 20 28 63 61 72 20 74 61 6c 29 29 29 0a (car tal))).
4110: 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 71 .(define (runs:q
4120: 75 65 75 65 2d 6e 65 78 74 2d 74 61 6c 20 74 61 ueue-next-tal ta
4130: 6c 20 72 65 67 20 6e 20 72 65 67 66 75 6c 29 0a l reg n regful).
4140: 20 20 28 69 66 20 72 65 67 66 75 6c 0a 20 20 20 (if regful.
4150: 20 20 20 74 61 6c 0a 20 20 20 20 20 20 28 6c 65 tal. (le
4160: 74 20 28 28 6e 65 77 74 61 6c 20 28 63 64 72 20 t ((newtal (cdr
4170: 74 61 6c 29 29 29 0a 09 28 69 66 20 28 6e 75 6c tal)))..(if (nul
4180: 6c 3f 20 6e 65 77 74 61 6c 29 0a 09 20 20 20 20 l? newtal)..
4190: 72 65 67 0a 09 20 20 20 20 6e 65 77 74 61 6c 0a reg.. newtal.
41a0: 09 20 20 20 20 29 29 29 29 0a 0a 28 64 65 66 69 . ))))..(defi
41b0: 6e 65 20 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e ne (runs:queue-n
41c0: 65 78 74 2d 72 65 67 20 74 61 6c 20 72 65 67 20 ext-reg tal reg
41d0: 6e 20 72 65 67 66 75 6c 29 0a 20 20 28 69 66 20 n regful). (if
41e0: 72 65 67 66 75 6c 0a 20 20 20 20 20 20 28 63 64 regful. (cd
41f0: 72 20 72 65 67 29 0a 20 20 20 20 20 20 28 69 66 r reg). (if
4200: 20 28 65 71 3f 20 28 6c 65 6e 67 74 68 20 74 61 (eq? (length ta
4210: 6c 29 20 31 29 0a 09 20 20 27 28 29 0a 09 20 20 l) 1).. '()..
4220: 72 65 67 29 29 29 0a 0a 28 69 6e 63 6c 75 64 65 reg)))..(include
4230: 20 22 72 75 6e 2d 74 65 73 74 73 2d 71 75 65 75 "run-tests-queu
4240: 65 2d 63 6c 61 73 73 69 63 2e 73 63 6d 22 29 0a e-classic.scm").
4250: 28 69 6e 63 6c 75 64 65 20 22 72 75 6e 2d 74 65 (include "run-te
4260: 73 74 73 2d 71 75 65 75 65 2d 6e 65 77 2e 73 63 sts-queue-new.sc
4270: 6d 22 29 0a 0a 3b 3b 20 70 61 72 65 6e 74 2d 74 m")..;; parent-t
4280: 65 73 74 20 69 73 20 74 68 65 72 65 20 61 73 20 est is there as
4290: 61 20 70 6c 61 63 65 68 6f 6c 64 65 72 20 66 6f a placeholder fo
42a0: 72 20 77 68 65 6e 20 70 61 72 65 6e 74 2d 74 65 r when parent-te
42b0: 73 74 73 20 63 61 6e 20 62 65 20 72 75 6e 20 61 sts can be run a
42c0: 73 20 61 20 73 65 74 75 70 20 73 74 65 70 0a 28 s a setup step.(
42d0: 64 65 66 69 6e 65 20 28 72 75 6e 3a 74 65 73 74 define (run:test
42e0: 20 72 75 6e 2d 69 64 20 72 75 6e 2d 69 6e 66 6f run-id run-info
42f0: 20 6b 65 79 2d 76 61 6c 73 20 72 75 6e 6e 61 6d key-vals runnam
4300: 65 20 74 65 73 74 2d 72 65 63 6f 72 64 20 66 6c e test-record fl
4310: 61 67 73 20 70 61 72 65 6e 74 2d 74 65 73 74 29 ags parent-test)
4320: 0a 20 20 3b 3b 20 41 6c 6c 20 74 68 65 73 65 20 . ;; All these
4330: 76 61 72 73 20 6d 69 67 68 74 20 62 65 20 72 65 vars might be re
4340: 66 65 72 65 6e 63 65 64 20 62 79 20 74 68 65 20 ferenced by the
4350: 74 65 73 74 63 6f 6e 66 69 67 20 66 69 6c 65 20 testconfig file
4360: 72 65 61 64 65 72 0a 20 20 28 6c 65 74 2a 20 28 reader. (let* (
4370: 28 74 65 73 74 2d 6e 61 6d 65 20 20 20 20 28 74 (test-name (t
4380: 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 ests:testqueue-g
4390: 65 74 2d 74 65 73 74 6e 61 6d 65 20 20 20 74 65 et-testname te
43a0: 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 28 74 st-record)).. (t
43b0: 65 73 74 2d 77 61 69 74 6f 6e 73 20 28 74 65 73 est-waitons (tes
43c0: 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 ts:testqueue-get
43d0: 2d 77 61 69 74 6f 6e 73 20 20 20 20 74 65 73 74 -waitons test
43e0: 2d 72 65 63 6f 72 64 29 29 0a 09 20 28 74 65 73 -record)).. (tes
43f0: 74 2d 63 6f 6e 66 20 20 20 20 28 74 65 73 74 73 t-conf (tests
4400: 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 74 :testqueue-get-t
4410: 65 73 74 63 6f 6e 66 69 67 20 74 65 73 74 2d 72 estconfig test-r
4420: 65 63 6f 72 64 29 29 0a 09 20 28 69 74 65 6d 64 ecord)).. (itemd
4430: 61 74 20 20 20 20 20 20 28 74 65 73 74 73 3a 74 at (tests:t
4440: 65 73 74 71 75 65 75 65 2d 67 65 74 2d 69 74 65 estqueue-get-ite
4450: 6d 64 61 74 20 20 20 20 74 65 73 74 2d 72 65 63 mdat test-rec
4460: 6f 72 64 29 29 0a 09 20 28 74 65 73 74 2d 70 61 ord)).. (test-pa
4470: 74 68 20 20 20 20 28 63 6f 6e 63 20 2a 74 6f 70 th (conc *top
4480: 70 61 74 68 2a 20 22 2f 74 65 73 74 73 2f 22 20 path* "/tests/"
4490: 74 65 73 74 2d 6e 61 6d 65 29 29 20 3b 3b 20 63 test-name)) ;; c
44a0: 6f 75 6c 64 20 75 73 65 20 74 65 73 74 73 3a 67 ould use tests:g
44b0: 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 68 65 et-testconfig he
44c0: 72 65 20 2e 2e 2e 0a 09 20 28 66 6f 72 63 65 20 re ..... (force
44d0: 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 (hash-tab
44e0: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 66 le-ref/default f
44f0: 6c 61 67 73 20 22 2d 66 6f 72 63 65 22 20 23 66 lags "-force" #f
4500: 29 29 0a 09 20 28 72 65 72 75 6e 20 20 20 20 20 )).. (rerun
4510: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 (hash-table-r
4520: 65 66 2f 64 65 66 61 75 6c 74 20 66 6c 61 67 73 ef/default flags
4530: 20 22 2d 72 65 72 75 6e 22 20 23 66 29 29 0a 09 "-rerun" #f))..
4540: 20 28 6b 65 65 70 67 6f 69 6e 67 20 20 20 20 28 (keepgoing (
4550: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
4560: 65 66 61 75 6c 74 20 66 6c 61 67 73 20 22 2d 6b efault flags "-k
4570: 65 65 70 67 6f 69 6e 67 22 20 23 66 29 29 0a 09 eepgoing" #f))..
4580: 20 28 69 74 65 6d 2d 70 61 74 68 20 20 20 20 20 (item-path
4590: 22 22 29 0a 09 20 28 64 62 20 20 20 20 20 20 20 "").. (db
45a0: 20 20 20 20 23 66 29 29 0a 20 20 20 20 28 64 65 #f)). (de
45b0: 62 75 67 3a 70 72 69 6e 74 20 34 0a 09 09 20 22 bug:print 4... "
45c0: 74 65 73 74 2d 63 6f 6e 66 69 67 3a 20 22 20 28 test-config: " (
45d0: 68 61 73 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 hash-table->alis
45e0: 74 20 74 65 73 74 2d 63 6f 6e 66 29 0a 09 09 20 t test-conf)...
45f0: 22 5c 6e 20 20 20 69 74 65 6d 64 61 74 3a 20 22 "\n itemdat: "
4600: 20 69 74 65 6d 64 61 74 0a 09 09 20 29 0a 20 20 itemdat... ).
4610: 20 20 3b 3b 20 73 65 74 74 69 6e 67 20 69 74 65 ;; setting ite
4620: 6d 64 61 74 20 74 6f 20 61 20 6c 69 73 74 20 69 mdat to a list i
4630: 66 20 69 74 20 69 73 20 23 66 0a 20 20 20 20 28 f it is #f. (
4640: 69 66 20 28 6e 6f 74 20 69 74 65 6d 64 61 74 29 if (not itemdat)
4650: 28 73 65 74 21 20 69 74 65 6d 64 61 74 20 27 28 (set! itemdat '(
4660: 29 29 29 0a 20 20 20 20 28 73 65 74 21 20 69 74 ))). (set! it
4670: 65 6d 2d 70 61 74 68 20 28 69 74 65 6d 2d 6c 69 em-path (item-li
4680: 73 74 2d 3e 70 61 74 68 20 69 74 65 6d 64 61 74 st->path itemdat
4690: 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 )). (debug:pr
46a0: 69 6e 74 20 32 20 22 41 74 74 65 6d 70 74 69 6e int 2 "Attemptin
46b0: 67 20 74 6f 20 6c 61 75 6e 63 68 20 74 65 73 74 g to launch test
46c0: 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 28 69 66 " test-name (if
46d0: 20 28 65 71 75 61 6c 3f 20 69 74 65 6d 2d 70 61 (equal? item-pa
46e0: 74 68 20 22 2f 22 29 20 22 2f 22 20 69 74 65 6d th "/") "/" item
46f0: 2d 70 61 74 68 29 29 0a 20 20 20 20 28 73 65 74 -path)). (set
4700: 65 6e 76 20 22 4d 54 5f 54 45 53 54 5f 4e 41 4d env "MT_TEST_NAM
4710: 45 22 20 74 65 73 74 2d 6e 61 6d 65 29 20 3b 3b E" test-name) ;;
4720: 20 0a 20 20 20 20 28 73 65 74 65 6e 76 20 22 4d . (setenv "M
4730: 54 5f 52 55 4e 4e 41 4d 45 22 20 20 20 72 75 6e T_RUNNAME" run
4740: 6e 61 6d 65 29 0a 20 20 20 20 28 73 65 74 2d 6d name). (set-m
4750: 65 67 61 74 65 73 74 2d 65 6e 76 2d 76 61 72 73 egatest-env-vars
4760: 20 72 75 6e 2d 69 64 20 69 6e 72 75 6e 6e 61 6d run-id inrunnam
4770: 65 3a 20 72 75 6e 6e 61 6d 65 29 20 3b 3b 20 74 e: runname) ;; t
4780: 68 65 73 65 20 6d 61 79 20 62 65 20 6e 65 65 64 hese may be need
4790: 65 64 20 62 79 20 74 68 65 20 6c 61 75 6e 63 68 ed by the launch
47a0: 69 6e 67 20 70 72 6f 63 65 73 73 0a 20 20 20 20 ing process.
47b0: 28 63 68 61 6e 67 65 2d 64 69 72 65 63 74 6f 72 (change-director
47c0: 79 20 2a 74 6f 70 70 61 74 68 2a 29 0a 0a 20 20 y *toppath*)..
47d0: 20 20 3b 3b 20 48 65 72 65 20 69 73 20 77 68 65 ;; Here is whe
47e0: 72 65 20 74 68 65 20 74 65 73 74 5f 6d 65 74 61 re the test_meta
47f0: 20 74 61 62 6c 65 20 69 73 20 62 65 73 74 20 75 table is best u
4800: 70 64 61 74 65 64 0a 20 20 20 20 3b 3b 20 59 65 pdated. ;; Ye
4810: 73 2c 20 61 6e 6f 74 68 65 72 20 75 73 65 20 6f s, another use o
4820: 66 20 61 20 67 6c 6f 62 61 6c 20 66 6f 72 20 63 f a global for c
4830: 61 63 68 69 6e 67 2e 20 4e 65 65 64 20 61 20 62 aching. Need a b
4840: 65 74 74 65 72 20 77 61 79 3f 0a 20 20 20 20 28 etter way?. (
4850: 69 66 20 28 6e 6f 74 20 28 68 61 73 68 2d 74 61 if (not (hash-ta
4860: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
4870: 2a 74 65 73 74 2d 6d 65 74 61 2d 75 70 64 61 74 *test-meta-updat
4880: 65 64 2a 20 74 65 73 74 2d 6e 61 6d 65 20 23 66 ed* test-name #f
4890: 29 29 0a 20 20 20 20 20 20 20 20 28 62 65 67 69 )). (begi
48a0: 6e 0a 09 20 20 20 28 68 61 73 68 2d 74 61 62 6c n.. (hash-tabl
48b0: 65 2d 73 65 74 21 20 2a 74 65 73 74 2d 6d 65 74 e-set! *test-met
48c0: 61 2d 75 70 64 61 74 65 64 2a 20 74 65 73 74 2d a-updated* test-
48d0: 6e 61 6d 65 20 23 74 29 0a 20 20 20 20 20 20 20 name #t).
48e0: 20 20 20 20 28 72 75 6e 73 3a 75 70 64 61 74 65 (runs:update
48f0: 2d 74 65 73 74 5f 6d 65 74 61 20 74 65 73 74 2d -test_meta test-
4900: 6e 61 6d 65 20 74 65 73 74 2d 63 6f 6e 66 29 29 name test-conf))
4910: 29 0a 20 20 20 20 0a 20 20 20 20 3b 3b 20 28 6c ). . ;; (l
4920: 61 6d 62 64 61 20 28 69 74 65 6d 64 61 74 29 20 ambda (itemdat)
4930: 3b 3b 3b 20 28 28 72 69 70 65 6e 65 73 73 20 22 ;;; ((ripeness "
4940: 6f 76 65 72 72 69 70 65 22 29 20 28 74 65 6d 70 overripe") (temp
4950: 65 72 61 74 75 72 65 20 22 63 6f 6f 6c 22 29 20 erature "cool")
4960: 28 73 65 61 73 6f 6e 20 22 73 75 6d 6d 65 72 22 (season "summer"
4970: 29 29 0a 20 20 20 20 28 6c 65 74 2a 20 28 28 6e )). (let* ((n
4980: 65 77 2d 74 65 73 74 2d 70 61 74 68 20 28 73 74 ew-test-path (st
4990: 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
49a0: 20 28 63 6f 6e 73 20 74 65 73 74 2d 70 61 74 68 (cons test-path
49b0: 20 28 6d 61 70 20 63 61 64 72 20 69 74 65 6d 64 (map cadr itemd
49c0: 61 74 29 29 20 22 2f 22 29 29 0a 09 20 20 20 28 at)) "/")).. (
49d0: 6e 65 77 2d 74 65 73 74 2d 6e 61 6d 65 20 28 69 new-test-name (i
49e0: 66 20 28 65 71 75 61 6c 3f 20 69 74 65 6d 2d 70 f (equal? item-p
49f0: 61 74 68 20 22 22 29 20 74 65 73 74 2d 6e 61 6d ath "") test-nam
4a00: 65 20 28 63 6f 6e 63 20 74 65 73 74 2d 6e 61 6d e (conc test-nam
4a10: 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 e "/" item-path)
4a20: 29 29 20 3b 3b 20 6a 75 73 74 20 6e 65 65 64 20 )) ;; just need
4a30: 69 74 20 74 6f 20 62 65 20 75 6e 69 71 75 65 0a it to be unique.
4a40: 09 20 20 20 28 74 65 73 74 2d 69 64 20 20 20 20 . (test-id
4a50: 20 20 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 (cdb:remote-r
4a60: 75 6e 20 64 62 3a 67 65 74 2d 74 65 73 74 2d 69 un db:get-test-i
4a70: 64 20 23 66 20 20 72 75 6e 2d 69 64 20 74 65 73 d #f run-id tes
4a80: 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 t-name item-path
4a90: 29 29 0a 09 20 20 20 28 74 65 73 74 64 61 74 20 )).. (testdat
4aa0: 20 20 20 20 20 20 28 63 64 62 3a 67 65 74 2d 74 (cdb:get-t
4ab0: 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 2a est-info-by-id *
4ac0: 72 75 6e 72 65 6d 6f 74 65 2a 20 74 65 73 74 2d runremote* test-
4ad0: 69 64 29 29 29 0a 20 20 20 20 20 20 28 69 66 20 id))). (if
4ae0: 28 6e 6f 74 20 74 65 73 74 64 61 74 29 0a 09 20 (not testdat)..
4af0: 20 28 62 65 67 69 6e 0a 09 20 20 20 20 3b 3b 20 (begin.. ;;
4b00: 65 6e 73 75 72 65 20 74 68 61 74 20 74 68 65 20 ensure that the
4b10: 70 61 74 68 20 65 78 69 73 74 73 20 62 65 66 6f path exists befo
4b20: 72 65 20 72 65 67 69 73 74 65 72 69 6e 67 20 74 re registering t
4b30: 68 65 20 74 65 73 74 0a 09 20 20 20 20 3b 3b 20 he test.. ;;
4b40: 4e 4f 50 45 3a 20 43 61 6e 6e 6f 74 21 20 44 6f NOPE: Cannot! Do
4b50: 6e 27 74 20 6b 6e 6f 77 20 79 65 74 20 77 68 69 n't know yet whi
4b60: 63 68 20 64 69 73 6b 20 61 72 65 61 20 77 69 6c ch disk area wil
4b70: 6c 20 62 65 20 61 73 73 69 67 6e 65 64 2e 2e 2e l be assigned...
4b80: 2e 0a 09 20 20 20 20 3b 3b 20 28 73 79 73 74 65 ... ;; (syste
4b90: 6d 20 28 63 6f 6e 63 20 22 6d 6b 64 69 72 20 2d m (conc "mkdir -
4ba0: 70 20 22 20 6e 65 77 2d 74 65 73 74 2d 70 61 74 p " new-test-pat
4bb0: 68 29 29 0a 09 20 20 20 20 3b 3b 0a 09 20 20 20 h)).. ;;..
4bc0: 20 3b 3b 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c ;; (open-run-cl
4bd0: 6f 73 65 20 74 65 73 74 73 3a 72 65 67 69 73 74 ose tests:regist
4be0: 65 72 2d 74 65 73 74 20 64 62 20 72 75 6e 2d 69 er-test db run-i
4bf0: 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d d test-name item
4c00: 2d 70 61 74 68 29 0a 09 20 20 20 20 3b 3b 0a 09 -path).. ;;..
4c10: 20 20 20 20 3b 3b 20 4e 42 2f 2f 20 66 6f 72 20 ;; NB// for
4c20: 74 68 65 20 61 62 6f 76 65 20 6c 69 6e 65 2e 20 the above line.
4c30: 49 20 77 61 6e 74 20 74 68 65 20 74 65 73 74 20 I want the test
4c40: 74 6f 20 62 65 20 72 65 67 69 73 74 65 72 65 64 to be registered
4c50: 20 6c 6f 6e 67 20 62 65 66 6f 72 65 20 74 68 69 long before thi
4c60: 73 20 72 6f 75 74 69 6e 65 20 67 65 74 73 20 63 s routine gets c
4c70: 61 6c 6c 65 64 21 0a 09 20 20 20 20 3b 3b 0a 09 alled!.. ;;..
4c80: 20 20 20 20 28 73 65 74 21 20 74 65 73 74 2d 69 (set! test-i
4c90: 64 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 d (open-run-clos
4ca0: 65 20 64 62 3a 67 65 74 2d 74 65 73 74 2d 69 64 e db:get-test-id
4cb0: 20 64 62 20 72 75 6e 2d 69 64 20 74 65 73 74 2d db run-id test-
4cc0: 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 name item-path))
4cd0: 0a 09 20 20 20 20 28 69 66 20 28 6e 6f 74 20 74 .. (if (not t
4ce0: 65 73 74 2d 69 64 29 0a 09 09 28 62 65 67 69 6e est-id)...(begin
4cf0: 0a 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e ... (debug:prin
4d00: 74 20 32 20 22 57 41 52 4e 3a 20 54 65 73 74 20 t 2 "WARN: Test
4d10: 6e 6f 74 20 70 72 65 2d 63 72 65 61 74 65 64 3f not pre-created?
4d20: 20 74 65 73 74 2d 6e 61 6d 65 3d 22 20 74 65 73 test-name=" tes
4d30: 74 2d 6e 61 6d 65 20 22 2c 20 69 74 65 6d 2d 70 t-name ", item-p
4d40: 61 74 68 3d 22 20 69 74 65 6d 2d 70 61 74 68 20 ath=" item-path
4d50: 22 2c 20 72 75 6e 2d 69 64 3d 22 20 72 75 6e 2d ", run-id=" run-
4d60: 69 64 29 0a 09 09 20 20 28 63 64 62 3a 74 65 73 id)... (cdb:tes
4d70: 74 73 2d 72 65 67 69 73 74 65 72 2d 74 65 73 74 ts-register-test
4d80: 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 72 75 6e *runremote* run
4d90: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 -id test-name it
4da0: 65 6d 2d 70 61 74 68 29 0a 09 09 20 20 28 73 65 em-path)... (se
4db0: 74 21 20 74 65 73 74 2d 69 64 20 28 6f 70 65 6e t! test-id (open
4dc0: 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 65 -run-close db:ge
4dd0: 74 2d 74 65 73 74 2d 69 64 20 64 62 20 72 75 6e t-test-id db run
4de0: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 -id test-name it
4df0: 65 6d 2d 70 61 74 68 29 29 29 29 0a 09 20 20 20 em-path))))..
4e00: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
4e10: 66 6f 20 34 20 22 74 65 73 74 2d 69 64 3d 22 20 fo 4 "test-id="
4e20: 74 65 73 74 2d 69 64 20 22 2c 20 72 75 6e 2d 69 test-id ", run-i
4e30: 64 3d 22 20 72 75 6e 2d 69 64 20 22 2c 20 74 65 d=" run-id ", te
4e40: 73 74 2d 6e 61 6d 65 3d 22 20 74 65 73 74 2d 6e st-name=" test-n
4e50: 61 6d 65 20 22 2c 20 69 74 65 6d 2d 70 61 74 68 ame ", item-path
4e60: 3d 5c 22 22 20 69 74 65 6d 2d 70 61 74 68 20 22 =\"" item-path "
4e70: 5c 22 22 29 0a 09 20 20 20 20 28 73 65 74 21 20 \"").. (set!
4e80: 74 65 73 74 64 61 74 20 28 63 64 62 3a 67 65 74 testdat (cdb:get
4e90: 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 -test-info-by-id
4ea0: 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 74 65 73 *runremote* tes
4eb0: 74 2d 69 64 29 29 29 29 0a 20 20 20 20 20 20 28 t-id)))). (
4ec0: 69 66 20 28 6e 6f 74 20 74 65 73 74 64 61 74 29 if (not testdat)
4ed0: 20 3b 3b 20 73 68 6f 75 6c 64 20 4e 4f 54 20 68 ;; should NOT h
4ee0: 61 70 70 65 6e 0a 09 20 20 28 64 65 62 75 67 3a appen.. (debug:
4ef0: 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 print 0 "ERROR:
4f00: 66 61 69 6c 65 64 20 74 6f 20 67 65 74 20 74 65 failed to get te
4f10: 73 74 20 72 65 63 6f 72 64 20 66 6f 72 20 74 65 st record for te
4f20: 73 74 2d 69 64 20 22 20 74 65 73 74 2d 69 64 29 st-id " test-id)
4f30: 29 0a 20 20 20 20 20 20 28 73 65 74 21 20 74 65 ). (set! te
4f40: 73 74 2d 69 64 20 28 64 62 3a 74 65 73 74 2d 67 st-id (db:test-g
4f50: 65 74 2d 69 64 20 74 65 73 74 64 61 74 29 29 0a et-id testdat)).
4f60: 20 20 20 20 20 20 28 63 68 61 6e 67 65 2d 64 69 (change-di
4f70: 72 65 63 74 6f 72 79 20 74 65 73 74 2d 70 61 74 rectory test-pat
4f80: 68 29 0a 20 20 20 20 20 20 28 63 61 73 65 20 28 h). (case (
4f90: 69 66 20 66 6f 72 63 65 20 3b 3b 20 28 61 72 67 if force ;; (arg
4fa0: 73 3a 67 65 74 2d 61 72 67 20 22 2d 66 6f 72 63 s:get-arg "-forc
4fb0: 65 22 29 0a 09 09 27 4e 4f 54 5f 53 54 41 52 54 e")...'NOT_START
4fc0: 45 44 0a 09 09 28 69 66 20 74 65 73 74 64 61 74 ED...(if testdat
4fd0: 0a 09 09 20 20 20 20 28 73 74 72 69 6e 67 2d 3e ... (string->
4fe0: 73 79 6d 62 6f 6c 20 28 74 65 73 74 3a 67 65 74 symbol (test:get
4ff0: 2d 73 74 61 74 65 20 74 65 73 74 64 61 74 29 29 -state testdat))
5000: 0a 09 09 20 20 20 20 27 66 61 69 6c 65 64 2d 74 ... 'failed-t
5010: 6f 2d 69 6e 73 65 72 74 29 29 0a 09 28 28 66 61 o-insert))..((fa
5020: 69 6c 65 64 2d 74 6f 2d 69 6e 73 65 72 74 29 0a iled-to-insert).
5030: 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 . (debug:print 0
5040: 20 22 45 52 52 4f 52 3a 20 46 61 69 6c 65 64 20 "ERROR: Failed
5050: 74 6f 20 69 6e 73 65 72 74 20 74 68 65 20 72 65 to insert the re
5060: 63 6f 72 64 20 69 6e 74 6f 20 74 68 65 20 64 62 cord into the db
5070: 22 29 29 0a 09 28 28 4e 4f 54 5f 53 54 41 52 54 "))..((NOT_START
5080: 45 44 20 43 4f 4d 50 4c 45 54 45 44 20 44 45 4c ED COMPLETED DEL
5090: 45 54 45 44 29 0a 09 20 28 6c 65 74 20 28 28 72 ETED).. (let ((r
50a0: 75 6e 66 6c 61 67 20 23 66 29 29 0a 09 20 20 20 unflag #f))..
50b0: 28 63 6f 6e 64 0a 09 20 20 20 20 3b 3b 20 2d 66 (cond.. ;; -f
50c0: 6f 72 63 65 2c 20 72 75 6e 20 6e 6f 20 6d 61 74 orce, run no mat
50d0: 74 65 72 20 77 68 61 74 0a 09 20 20 20 20 28 66 ter what.. (f
50e0: 6f 72 63 65 20 28 73 65 74 21 20 72 75 6e 66 6c orce (set! runfl
50f0: 61 67 20 23 74 29 29 0a 09 20 20 20 20 3b 3b 20 ag #t)).. ;;
5100: 4e 4f 54 5f 53 54 41 52 54 45 44 2c 20 72 75 6e NOT_STARTED, run
5110: 20 6e 6f 20 6d 61 74 74 65 72 20 77 68 61 74 0a no matter what.
5120: 09 20 20 20 20 28 28 6d 65 6d 62 65 72 20 28 74 . ((member (t
5130: 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 est:get-state te
5140: 73 74 64 61 74 29 20 27 28 22 44 45 4c 45 54 45 stdat) '("DELETE
5150: 44 22 20 22 4e 4f 54 5f 53 54 41 52 54 45 44 22 D" "NOT_STARTED"
5160: 29 29 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 ))(set! runflag
5170: 23 74 29 29 0a 09 20 20 20 20 3b 3b 20 6e 6f 74 #t)).. ;; not
5180: 20 2d 72 65 72 75 6e 20 61 6e 64 20 50 41 53 53 -rerun and PASS
5190: 2c 20 57 41 52 4e 20 6f 72 20 43 48 45 43 4b 2c , WARN or CHECK,
51a0: 20 64 6f 20 6e 6f 20 72 75 6e 0a 09 20 20 20 20 do no run..
51b0: 28 28 61 6e 64 20 28 6f 72 20 28 6e 6f 74 20 72 ((and (or (not r
51c0: 65 72 75 6e 29 0a 09 09 20 20 20 20 20 20 6b 65 erun)... ke
51d0: 65 70 67 6f 69 6e 67 29 0a 09 09 20 20 3b 3b 20 epgoing)... ;;
51e0: 52 65 71 75 69 72 65 20 74 6f 20 66 6f 72 63 65 Require to force
51f0: 20 72 65 2d 72 75 6e 20 66 6f 72 20 43 4f 4d 50 re-run for COMP
5200: 4c 45 54 45 44 20 6f 72 20 2a 61 6e 79 74 68 69 LETED or *anythi
5210: 6e 67 2a 20 2b 20 50 41 53 53 2c 57 41 52 4e 20 ng* + PASS,WARN
5220: 6f 72 20 43 48 45 43 4b 0a 09 09 20 20 28 6f 72 or CHECK... (or
5230: 20 28 6d 65 6d 62 65 72 20 28 74 65 73 74 3a 67 (member (test:g
5240: 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 et-status testda
5250: 74 29 20 27 28 22 50 41 53 53 22 20 22 57 41 52 t) '("PASS" "WAR
5260: 4e 22 20 22 43 48 45 43 4b 22 20 22 53 4b 49 50 N" "CHECK" "SKIP
5270: 22 29 29 0a 09 09 20 20 20 20 20 20 28 6d 65 6d "))... (mem
5280: 62 65 72 20 28 74 65 73 74 3a 67 65 74 2d 73 74 ber (test:get-st
5290: 61 74 65 20 20 74 65 73 74 64 61 74 29 20 27 28 ate testdat) '(
52a0: 22 43 4f 4d 50 4c 45 54 45 44 22 29 29 29 29 20 "COMPLETED"))))
52b0: 0a 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 .. (debug:pr
52c0: 69 6e 74 2d 69 6e 66 6f 20 32 20 22 72 75 6e 6e int-info 2 "runn
52d0: 69 6e 67 20 74 65 73 74 20 22 20 74 65 73 74 2d ing test " test-
52e0: 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 name "/" item-pa
52f0: 74 68 20 22 20 73 75 70 70 72 65 73 73 65 64 20 th " suppressed
5300: 61 73 20 69 74 20 69 73 20 22 20 28 74 65 73 74 as it is " (test
5310: 3a 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 64 :get-state testd
5320: 61 74 29 20 22 20 61 6e 64 20 22 20 28 74 65 73 at) " and " (tes
5330: 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 t:get-status tes
5340: 74 64 61 74 29 29 0a 09 20 20 20 20 20 28 73 65 tdat)).. (se
5350: 74 21 20 72 75 6e 66 6c 61 67 20 23 66 29 29 0a t! runflag #f)).
5360: 09 20 20 20 20 3b 3b 20 2d 72 65 72 75 6e 20 61 . ;; -rerun a
5370: 6e 64 20 73 74 61 74 75 73 20 69 73 20 6f 6e 65 nd status is one
5380: 20 6f 66 20 74 68 65 20 73 70 65 63 69 66 65 64 of the specifed
5390: 2c 20 72 75 6e 20 69 74 0a 09 20 20 20 20 28 28 , run it.. ((
53a0: 61 6e 64 20 72 65 72 75 6e 0a 09 09 20 20 28 6c and rerun... (l
53b0: 65 74 2a 20 28 28 72 65 72 75 6e 6c 73 74 20 20 et* ((rerunlst
53c0: 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 72 (string-split r
53d0: 65 72 75 6e 20 22 2c 22 29 29 0a 09 09 09 20 28 erun ",")).... (
53e0: 6d 75 73 74 2d 72 65 72 75 6e 20 28 6d 65 6d 62 must-rerun (memb
53f0: 65 72 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 er (test:get-sta
5400: 74 75 73 20 74 65 73 74 64 61 74 29 20 72 65 72 tus testdat) rer
5410: 75 6e 6c 73 74 29 29 29 0a 09 09 20 20 20 20 28 unlst)))... (
5420: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
5430: 20 33 20 22 2d 72 65 72 75 6e 20 6c 69 73 74 3a 3 "-rerun list:
5440: 20 22 20 72 65 72 75 6e 20 22 2c 20 74 65 73 74 " rerun ", test
5450: 2d 73 74 61 74 75 73 3a 20 22 20 28 74 65 73 74 -status: " (test
5460: 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 :get-status test
5470: 64 61 74 29 22 2c 20 6d 75 73 74 2d 72 65 72 75 dat)", must-reru
5480: 6e 3a 20 22 20 6d 75 73 74 2d 72 65 72 75 6e 29 n: " must-rerun)
5490: 0a 09 09 20 20 20 20 6d 75 73 74 2d 72 65 72 75 ... must-reru
54a0: 6e 29 29 0a 09 20 20 20 20 20 28 64 65 62 75 67 n)).. (debug
54b0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 22 52 :print-info 2 "R
54c0: 65 72 75 6e 20 66 6f 72 63 65 64 20 66 6f 72 20 erun forced for
54d0: 74 65 73 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 test " test-name
54e0: 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 0a "/" item-path).
54f0: 09 20 20 20 20 20 28 73 65 74 21 20 72 75 6e 66 . (set! runf
5500: 6c 61 67 20 23 74 29 29 0a 09 20 20 20 20 3b 3b lag #t)).. ;;
5510: 20 2d 6b 65 65 70 67 6f 69 6e 67 2c 20 64 6f 20 -keepgoing, do
5520: 6e 6f 74 20 72 65 72 75 6e 20 46 41 49 4c 0a 09 not rerun FAIL..
5530: 20 20 20 20 28 28 61 6e 64 20 6b 65 65 70 67 6f ((and keepgo
5540: 69 6e 67 0a 09 09 20 20 28 6d 65 6d 62 65 72 20 ing... (member
5550: 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 75 73 (test:get-status
5560: 20 74 65 73 74 64 61 74 29 20 27 28 22 46 41 49 testdat) '("FAI
5570: 4c 22 29 29 29 0a 09 20 20 20 20 20 28 73 65 74 L"))).. (set
5580: 21 20 72 75 6e 66 6c 61 67 20 23 66 29 29 0a 09 ! runflag #f))..
5590: 20 20 20 20 28 28 61 6e 64 20 28 6e 6f 74 20 72 ((and (not r
55a0: 65 72 75 6e 29 0a 09 09 20 20 28 6d 65 6d 62 65 erun)... (membe
55b0: 72 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 r (test:get-stat
55c0: 75 73 20 74 65 73 74 64 61 74 29 20 27 28 22 46 us testdat) '("F
55d0: 41 49 4c 22 20 22 6e 2f 61 22 29 29 29 0a 09 20 AIL" "n/a")))..
55e0: 20 20 20 20 28 73 65 74 21 20 72 75 6e 66 6c 61 (set! runfla
55f0: 67 20 23 74 29 29 0a 09 20 20 20 20 28 65 6c 73 g #t)).. (els
5600: 65 20 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 e (set! runflag
5610: 23 66 29 29 29 0a 09 20 20 20 28 64 65 62 75 67 #f))).. (debug
5620: 3a 70 72 69 6e 74 20 36 20 22 52 55 4e 4e 49 4e :print 6 "RUNNIN
5630: 47 20 3d 3e 20 72 75 6e 66 6c 61 67 3a 20 22 20 G => runflag: "
5640: 72 75 6e 66 6c 61 67 20 22 20 53 54 41 54 45 3a runflag " STATE:
5650: 20 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 " (test:get-sta
5660: 74 65 20 74 65 73 74 64 61 74 29 20 22 20 53 54 te testdat) " ST
5670: 41 54 55 53 3a 20 22 20 28 74 65 73 74 3a 67 65 ATUS: " (test:ge
5680: 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 74 t-status testdat
5690: 29 29 0a 09 20 20 20 28 69 66 20 28 6e 6f 74 20 )).. (if (not
56a0: 72 75 6e 66 6c 61 67 29 0a 09 20 20 20 20 20 20 runflag)..
56b0: 20 28 69 66 20 28 6e 6f 74 20 70 61 72 65 6e 74 (if (not parent
56c0: 2d 74 65 73 74 29 0a 09 09 20 20 20 28 64 65 62 -test)... (deb
56d0: 75 67 3a 70 72 69 6e 74 20 31 20 22 4e 4f 54 45 ug:print 1 "NOTE
56e0: 3a 20 4e 6f 74 20 73 74 61 72 74 69 6e 67 20 74 : Not starting t
56f0: 65 73 74 20 22 20 6e 65 77 2d 74 65 73 74 2d 6e est " new-test-n
5700: 61 6d 65 20 22 20 61 73 20 69 74 20 69 73 20 73 ame " as it is s
5710: 74 61 74 65 20 5c 22 22 20 28 74 65 73 74 3a 67 tate \"" (test:g
5720: 65 74 2d 73 74 61 74 65 20 74 65 73 74 64 61 74 et-state testdat
5730: 29 20 0a 09 09 09 09 22 5c 22 20 61 6e 64 20 73 ) ....."\" and s
5740: 74 61 74 75 73 20 5c 22 22 20 28 74 65 73 74 3a tatus \"" (test:
5750: 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 get-status testd
5760: 61 74 29 20 22 5c 22 2c 20 75 73 65 20 2d 72 65 at) "\", use -re
5770: 72 75 6e 20 5c 22 22 20 28 74 65 73 74 3a 67 65 run \"" (test:ge
5780: 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 74 t-status testdat
5790: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
57a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
57b0: 20 20 22 5c 22 20 6f 72 20 2d 66 6f 72 63 65 20 "\" or -force
57c0: 74 6f 20 6f 76 65 72 72 69 64 65 22 29 29 0a 09 to override"))..
57d0: 20 20 20 20 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 ;; NOTE:
57e0: 4e 6f 20 6c 6f 6e 67 65 72 20 62 65 20 63 68 65 No longer be che
57f0: 63 6b 69 6e 67 20 70 72 65 72 65 71 75 69 73 69 cking prerequisi
5800: 74 65 73 20 68 65 72 65 21 20 57 69 6c 6c 20 6e tes here! Will n
5810: 65 76 65 72 20 67 65 74 20 68 65 72 65 20 75 6e ever get here un
5820: 6c 65 73 73 20 70 72 65 72 65 71 73 20 61 72 65 less prereqs are
5830: 0a 09 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 .. ;;
5840: 20 20 61 6c 72 65 61 64 79 20 6d 65 74 2e 0a 09 already met...
5850: 20 20 20 20 20 20 20 3b 3b 20 54 68 69 73 20 77 ;; This w
5860: 6f 75 6c 64 20 62 65 20 61 20 67 72 65 61 74 20 ould be a great
5870: 70 6c 61 63 65 20 74 6f 20 64 6f 20 74 68 65 20 place to do the
5880: 70 72 6f 63 65 73 73 2d 66 6f 72 6b 0a 09 20 20 process-fork..
5890: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6c (if (not (l
58a0: 61 75 6e 63 68 2d 74 65 73 74 20 74 65 73 74 2d aunch-test test-
58b0: 69 64 20 72 75 6e 2d 69 64 20 72 75 6e 2d 69 6e id run-id run-in
58c0: 66 6f 20 6b 65 79 2d 76 61 6c 73 20 72 75 6e 6e fo key-vals runn
58d0: 61 6d 65 20 74 65 73 74 2d 63 6f 6e 66 20 74 65 ame test-conf te
58e0: 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 70 61 74 st-name test-pat
58f0: 68 20 69 74 65 6d 64 61 74 20 66 6c 61 67 73 29 h itemdat flags)
5900: 29 0a 09 09 20 20 20 28 62 65 67 69 6e 0a 09 09 )... (begin...
5910: 20 20 20 20 20 28 70 72 69 6e 74 20 22 45 52 52 (print "ERR
5920: 4f 52 3a 20 46 61 69 6c 65 64 20 74 6f 20 6c 61 OR: Failed to la
5930: 75 6e 63 68 20 74 68 65 20 74 65 73 74 2e 20 45 unch the test. E
5940: 78 69 74 69 6e 67 20 61 73 20 73 6f 6f 6e 20 61 xiting as soon a
5950: 73 20 70 6f 73 73 69 62 6c 65 22 29 0a 09 09 20 s possible")...
5960: 20 20 20 20 28 73 65 74 21 20 2a 67 6c 6f 62 61 (set! *globa
5970: 6c 65 78 69 74 73 74 61 74 75 73 2a 20 31 29 20 lexitstatus* 1)
5980: 3b 3b 20 0a 09 09 20 20 20 20 20 28 70 72 6f 63 ;; ... (proc
5990: 65 73 73 2d 73 69 67 6e 61 6c 20 28 63 75 72 72 ess-signal (curr
59a0: 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 20 ent-process-id)
59b0: 73 69 67 6e 61 6c 2f 6b 69 6c 6c 29 29 29 29 29 signal/kill)))))
59c0: 29 0a 09 28 28 4b 49 4c 4c 45 44 29 20 0a 09 20 )..((KILLED) ..
59d0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 (debug:print 1 "
59e0: 4e 4f 54 45 3a 20 22 20 6e 65 77 2d 74 65 73 74 NOTE: " new-test
59f0: 2d 6e 61 6d 65 20 22 20 69 73 20 61 6c 72 65 61 -name " is alrea
5a00: 64 79 20 72 75 6e 6e 69 6e 67 20 6f 72 20 77 61 dy running or wa
5a10: 73 20 65 78 70 6c 69 63 74 6c 79 20 6b 69 6c 6c s explictly kill
5a20: 65 64 2c 20 75 73 65 20 2d 66 6f 72 63 65 20 74 ed, use -force t
5a30: 6f 20 6c 61 75 6e 63 68 20 69 74 2e 22 29 29 0a o launch it.")).
5a40: 09 28 28 4c 41 55 4e 43 48 45 44 20 52 45 4d 4f .((LAUNCHED REMO
5a50: 54 45 48 4f 53 54 53 54 41 52 54 20 52 55 4e 4e TEHOSTSTART RUNN
5a60: 49 4e 47 29 20 20 0a 09 20 28 69 66 20 28 3e 20 ING) .. (if (>
5a70: 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f (- (current-seco
5a80: 6e 64 73 29 28 2b 20 28 64 62 3a 74 65 73 74 2d nds)(+ (db:test-
5a90: 67 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 74 get-event_time t
5aa0: 65 73 74 64 61 74 29 0a 09 09 09 09 20 20 20 20 estdat).....
5ab0: 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d (db:test-get-
5ac0: 72 75 6e 5f 64 75 72 61 74 69 6f 6e 20 74 65 73 run_duration tes
5ad0: 74 64 61 74 29 29 29 0a 09 09 36 30 30 29 20 3b tdat)))...600) ;
5ae0: 3b 20 69 2e 65 2e 20 6e 6f 20 75 70 64 61 74 65 ; i.e. no update
5af0: 20 66 6f 72 20 6d 6f 72 65 20 74 68 61 6e 20 36 for more than 6
5b00: 30 30 20 73 65 63 6f 6e 64 73 0a 09 20 20 20 20 00 seconds..
5b10: 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 20 (begin..
5b20: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
5b30: 57 41 52 4e 49 4e 47 3a 20 54 65 73 74 20 22 20 WARNING: Test "
5b40: 74 65 73 74 2d 6e 61 6d 65 20 22 20 61 70 70 65 test-name " appe
5b50: 61 72 73 20 74 6f 20 62 65 20 64 65 61 64 2e 20 ars to be dead.
5b60: 46 6f 72 63 69 6e 67 20 69 74 20 74 6f 20 73 74 Forcing it to st
5b70: 61 74 65 20 49 4e 43 4f 4d 50 4c 45 54 45 20 61 ate INCOMPLETE a
5b80: 6e 64 20 73 74 61 74 75 73 20 53 54 55 43 4b 2f nd status STUCK/
5b90: 44 45 41 44 22 29 0a 09 20 20 20 20 20 20 20 28 DEAD").. (
5ba0: 74 65 73 74 73 3a 74 65 73 74 2d 73 65 74 2d 73 tests:test-set-s
5bb0: 74 61 74 75 73 21 20 74 65 73 74 2d 69 64 20 22 tatus! test-id "
5bc0: 49 4e 43 4f 4d 50 4c 45 54 45 22 20 22 53 54 55 INCOMPLETE" "STU
5bd0: 43 4b 2f 44 45 41 44 22 20 22 54 65 73 74 20 69 CK/DEAD" "Test i
5be0: 73 20 73 74 75 63 6b 20 6f 72 20 64 65 61 64 22 s stuck or dead"
5bf0: 20 23 66 29 29 0a 09 20 20 20 20 20 28 64 65 62 #f)).. (deb
5c00: 75 67 3a 70 72 69 6e 74 20 32 20 22 4e 4f 54 45 ug:print 2 "NOTE
5c10: 3a 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 : " test-name "
5c20: 69 73 20 61 6c 72 65 61 64 79 20 72 75 6e 6e 69 is already runni
5c30: 6e 67 22 29 29 29 0a 09 28 65 6c 73 65 20 20 20 ng")))..(else
5c40: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
5c50: 20 30 20 22 45 52 52 4f 52 3a 20 46 61 69 6c 65 0 "ERROR: Faile
5c60: 64 20 74 6f 20 6c 61 75 6e 63 68 20 74 65 73 74 d to launch test
5c70: 20 22 20 6e 65 77 2d 74 65 73 74 2d 6e 61 6d 65 " new-test-name
5c80: 20 22 2e 20 55 6e 72 65 63 6f 67 6e 69 73 65 64 ". Unrecognised
5c90: 20 73 74 61 74 65 20 22 20 28 74 65 73 74 3a 67 state " (test:g
5ca0: 65 74 2d 73 74 61 74 65 20 74 65 73 74 64 61 74 et-state testdat
5cb0: 29 29 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d )))))))..;;=====
5cc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5cd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5ce0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5cf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5d00: 3d 0a 3b 3b 20 45 4e 44 20 4f 46 20 4e 45 57 20 =.;; END OF NEW
5d10: 53 54 55 46 46 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d STUFF.;;========
5d20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5d30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5d40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5d50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
5d60: 28 64 65 66 69 6e 65 20 28 67 65 74 2d 64 69 72 (define (get-dir
5d70: 2d 75 70 2d 6e 20 64 69 72 20 2e 20 70 61 72 61 -up-n dir . para
5d80: 6d 73 29 20 0a 20 20 28 6c 65 74 20 28 28 64 70 ms) . (let ((dp
5d90: 61 72 74 73 20 20 28 73 74 72 69 6e 67 2d 73 70 arts (string-sp
5da0: 6c 69 74 20 64 69 72 20 22 2f 22 29 29 0a 09 28 lit dir "/"))..(
5db0: 63 6f 75 6e 74 20 20 20 28 69 66 20 28 6e 75 6c count (if (nul
5dc0: 6c 3f 20 70 61 72 61 6d 73 29 20 31 20 28 63 61 l? params) 1 (ca
5dd0: 72 20 70 61 72 61 6d 73 29 29 29 29 0a 20 20 20 r params)))).
5de0: 20 28 63 6f 6e 63 20 22 2f 22 20 28 73 74 72 69 (conc "/" (stri
5df0: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 0a ng-intersperse .
5e00: 09 20 20 20 20 20 20 20 28 74 61 6b 65 20 64 70 . (take dp
5e10: 61 72 74 73 20 28 2d 20 28 6c 65 6e 67 74 68 20 arts (- (length
5e20: 64 70 61 72 74 73 29 20 63 6f 75 6e 74 29 29 0a dparts) count)).
5e30: 09 20 20 20 20 20 20 20 22 2f 22 29 29 29 29 0a . "/")))).
5e40: 3b 3b 20 52 65 6d 6f 76 65 20 72 75 6e 73 0a 3b ;; Remove runs.;
5e50: 3b 20 66 69 65 6c 64 73 20 61 72 65 20 70 61 73 ; fields are pas
5e60: 73 69 6e 67 20 69 6e 20 74 68 72 6f 75 67 68 20 sing in through
5e70: 0a 3b 3b 20 61 63 74 69 6f 6e 3a 0a 3b 3b 20 20 .;; action:.;;
5e80: 20 20 27 72 65 6d 6f 76 65 2d 72 75 6e 73 0a 3b 'remove-runs.;
5e90: 3b 20 20 20 20 27 73 65 74 2d 73 74 61 74 65 2d ; 'set-state-
5ea0: 73 74 61 74 75 73 0a 3b 3b 0a 3b 3b 20 4e 42 2f status.;;.;; NB/
5eb0: 2f 20 73 68 6f 75 6c 64 20 70 61 73 73 20 69 6e / should pass in
5ec0: 20 6b 65 79 73 3f 0a 3b 3b 0a 28 64 65 66 69 6e keys?.;;.(defin
5ed0: 65 20 28 72 75 6e 73 3a 6f 70 65 72 61 74 65 2d e (runs:operate-
5ee0: 6f 6e 20 61 63 74 69 6f 6e 20 74 61 72 67 65 74 on action target
5ef0: 20 72 75 6e 6e 61 6d 65 70 61 74 74 20 74 65 73 runnamepatt tes
5f00: 74 70 61 74 74 20 23 21 6b 65 79 20 28 73 74 61 tpatt #!key (sta
5f10: 74 65 20 23 66 29 28 73 74 61 74 75 73 20 23 66 te #f)(status #f
5f20: 29 28 6e 65 77 2d 73 74 61 74 65 2d 73 74 61 74 )(new-state-stat
5f30: 75 73 20 23 66 29 29 0a 20 20 28 63 6f 6d 6d 6f us #f)). (commo
5f40: 6e 3a 63 6c 65 61 72 2d 63 61 63 68 65 73 29 20 n:clear-caches)
5f50: 3b 3b 20 63 6c 65 61 72 20 61 6c 6c 20 63 61 63 ;; clear all cac
5f60: 68 65 73 0a 20 20 28 6c 65 74 2a 20 28 28 64 62 hes. (let* ((db
5f70: 20 20 20 20 20 20 20 20 20 20 20 23 66 29 0a 09 #f)..
5f80: 20 28 6b 65 79 73 20 20 20 20 20 20 20 20 20 28 (keys (
5f90: 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 open-run-close d
5fa0: 62 3a 67 65 74 2d 6b 65 79 73 20 64 62 29 29 0a b:get-keys db)).
5fb0: 09 20 28 72 75 6e 64 61 74 20 20 20 20 20 20 20 . (rundat
5fc0: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 (open-run-close
5fd0: 72 75 6e 73 3a 67 65 74 2d 72 75 6e 73 2d 62 79 runs:get-runs-by
5fe0: 2d 70 61 74 74 20 64 62 20 6b 65 79 73 20 72 75 -patt db keys ru
5ff0: 6e 6e 61 6d 65 70 61 74 74 20 74 61 72 67 65 74 nnamepatt target
6000: 29 29 0a 09 20 28 68 65 61 64 65 72 20 20 20 20 )).. (header
6010: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 (vector-ref r
6020: 75 6e 64 61 74 20 30 29 29 0a 09 20 28 72 75 6e undat 0)).. (run
6030: 73 20 20 20 20 20 20 20 20 20 28 76 65 63 74 6f s (vecto
6040: 72 2d 72 65 66 20 72 75 6e 64 61 74 20 31 29 29 r-ref rundat 1))
6050: 0a 09 20 28 73 74 61 74 65 73 20 20 20 20 20 20 .. (states
6060: 20 28 69 66 20 73 74 61 74 65 20 20 28 73 74 72 (if state (str
6070: 69 6e 67 2d 73 70 6c 69 74 20 73 74 61 74 65 20 ing-split state
6080: 20 22 2c 22 29 20 27 28 29 29 29 0a 09 20 28 73 ",") '())).. (s
6090: 74 61 74 75 73 65 73 20 20 20 20 20 28 69 66 20 tatuses (if
60a0: 73 74 61 74 75 73 20 28 73 74 72 69 6e 67 2d 73 status (string-s
60b0: 70 6c 69 74 20 73 74 61 74 75 73 20 22 2c 22 29 plit status ",")
60c0: 20 27 28 29 29 29 0a 09 20 28 73 74 61 74 65 2d '())).. (state-
60d0: 73 74 61 74 75 73 20 28 69 66 20 28 73 74 72 69 status (if (stri
60e0: 6e 67 3f 20 6e 65 77 2d 73 74 61 74 65 2d 73 74 ng? new-state-st
60f0: 61 74 75 73 29 20 28 73 74 72 69 6e 67 2d 73 70 atus) (string-sp
6100: 6c 69 74 20 6e 65 77 2d 73 74 61 74 65 2d 73 74 lit new-state-st
6110: 61 74 75 73 20 22 2c 22 29 20 27 28 23 66 20 23 atus ",") '(#f #
6120: 66 29 29 29 29 0a 20 20 20 20 28 64 65 62 75 67 f)))). (debug
6130: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 72 :print-info 4 "r
6140: 75 6e 73 3a 6f 70 65 72 61 74 65 2d 6f 6e 20 3d uns:operate-on =
6150: 3e 20 48 65 61 64 65 72 3a 20 22 20 68 65 61 64 > Header: " head
6160: 65 72 20 22 20 61 63 74 69 6f 6e 3a 20 22 20 61 er " action: " a
6170: 63 74 69 6f 6e 20 22 20 6e 65 77 2d 73 74 61 74 ction " new-stat
6180: 65 2d 73 74 61 74 75 73 3a 20 22 20 6e 65 77 2d e-status: " new-
6190: 73 74 61 74 65 2d 73 74 61 74 75 73 29 0a 20 20 state-status).
61a0: 20 20 28 69 66 20 28 3e 20 32 20 28 6c 65 6e 67 (if (> 2 (leng
61b0: 74 68 20 73 74 61 74 65 2d 73 74 61 74 75 73 29 th state-status)
61c0: 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 64 65 )..(begin.. (de
61d0: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 bug:print 0 "ERR
61e0: 4f 52 3a 20 74 68 65 20 70 61 72 61 6d 65 74 65 OR: the paramete
61f0: 72 20 74 6f 20 2d 73 65 74 2d 73 74 61 74 65 2d r to -set-state-
6200: 73 74 61 74 75 73 20 69 73 20 61 20 63 6f 6d 6d status is a comm
6210: 61 20 64 65 6c 69 6d 69 74 65 64 20 73 74 72 69 a delimited stri
6220: 6e 67 2e 20 45 2e 67 2e 20 43 4f 4d 50 4c 45 54 ng. E.g. COMPLET
6230: 45 44 2c 46 41 49 4c 22 29 0a 09 20 20 28 65 78 ED,FAIL").. (ex
6240: 69 74 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 it))). (for-e
6250: 61 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 ach. (lambda
6260: 20 28 72 75 6e 29 0a 20 20 20 20 20 20 20 28 6c (run). (l
6270: 65 74 20 28 28 72 75 6e 6b 65 79 20 28 73 74 72 et ((runkey (str
6280: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
6290: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 6b 29 (map (lambda (k)
62a0: 0a 09 09 09 09 09 09 28 64 62 3a 67 65 74 2d 76 .......(db:get-v
62b0: 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 alue-by-header r
62c0: 75 6e 20 68 65 61 64 65 72 20 6b 29 29 20 6b 65 un header k)) ke
62d0: 79 73 29 20 22 2f 22 29 29 0a 09 20 20 20 20 20 ys) "/"))..
62e0: 28 64 69 72 73 2d 74 6f 2d 72 65 6d 6f 76 65 20 (dirs-to-remove
62f0: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
6300: 29 29 29 0a 09 20 28 6c 65 74 2a 20 28 28 72 75 ))).. (let* ((ru
6310: 6e 2d 69 64 20 20 20 20 28 64 62 3a 67 65 74 2d n-id (db:get-
6320: 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 value-by-header
6330: 72 75 6e 20 68 65 61 64 65 72 20 22 69 64 22 29 run header "id")
6340: 29 0a 09 09 28 72 75 6e 2d 73 74 61 74 65 20 28 )...(run-state (
6350: 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d db:get-value-by-
6360: 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 header run heade
6370: 72 20 22 73 74 61 74 65 22 29 29 0a 09 09 28 74 r "state"))...(t
6380: 65 73 74 73 20 20 20 20 20 28 69 66 20 28 6e 6f ests (if (no
6390: 74 20 28 65 71 75 61 6c 3f 20 72 75 6e 2d 73 74 t (equal? run-st
63a0: 61 74 65 20 22 6c 6f 63 6b 65 64 22 29 29 0a 09 ate "locked"))..
63b0: 09 09 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 .. (open-r
63c0: 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d un-close db:get-
63d0: 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 64 62 tests-for-run db
63e0: 20 72 75 6e 2d 69 64 0a 09 09 09 09 09 09 20 20 run-id.......
63f0: 20 20 20 20 74 65 73 74 70 61 74 74 20 73 74 61 testpatt sta
6400: 74 65 73 20 73 74 61 74 75 73 65 73 0a 09 09 09 tes statuses....
6410: 09 09 09 20 20 20 20 20 20 6e 6f 74 2d 69 6e 3a ... not-in:
6420: 20 20 23 66 0a 09 09 09 09 09 09 20 20 20 20 20 #f.......
6430: 20 73 6f 72 74 2d 62 79 3a 20 28 63 61 73 65 20 sort-by: (case
6440: 61 63 74 69 6f 6e 0a 09 09 09 09 09 09 09 09 20 action.........
6450: 28 28 72 65 6d 6f 76 65 2d 72 75 6e 73 29 20 27 ((remove-runs) '
6460: 72 75 6e 64 69 72 29 0a 09 09 09 09 09 09 09 09 rundir).........
6470: 20 28 65 6c 73 65 20 20 20 20 20 20 20 20 20 20 (else
6480: 27 65 76 65 6e 74 5f 74 69 6d 65 29 29 29 0a 09 'event_time)))..
6490: 09 09 20 20 20 20 20 20 20 27 28 29 29 29 0a 09 .. '()))..
64a0: 09 28 6c 61 73 74 74 70 61 74 68 20 22 2f 64 6f .(lasttpath "/do
64b0: 65 73 2f 6e 6f 74 2f 65 78 69 73 74 2f 49 2f 68 es/not/exist/I/h
64c0: 6f 70 65 22 29 29 0a 09 20 20 20 28 64 65 62 75 ope")).. (debu
64d0: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 g:print-info 4 "
64e0: 72 75 6e 73 3a 6f 70 65 72 61 74 65 2d 6f 6e 20 runs:operate-on
64f0: 72 75 6e 3d 22 20 72 75 6e 20 22 2c 20 68 65 61 run=" run ", hea
6500: 64 65 72 3d 22 20 68 65 61 64 65 72 29 0a 09 20 der=" header)..
6510: 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c (if (not (null
6520: 3f 20 74 65 73 74 73 29 29 0a 09 20 20 20 20 20 ? tests))..
6530: 20 20 28 62 65 67 69 6e 0a 09 09 20 28 63 61 73 (begin... (cas
6540: 65 20 61 63 74 69 6f 6e 0a 09 09 20 20 20 28 28 e action... ((
6550: 72 65 6d 6f 76 65 2d 72 75 6e 73 29 0a 09 09 20 remove-runs)...
6560: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
6570: 31 20 22 52 65 6d 6f 76 69 6e 67 20 74 65 73 74 1 "Removing test
6580: 73 20 66 6f 72 20 72 75 6e 3a 20 22 20 72 75 6e s for run: " run
6590: 6b 65 79 20 22 20 22 20 28 64 62 3a 67 65 74 2d key " " (db:get-
65a0: 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 value-by-header
65b0: 72 75 6e 20 68 65 61 64 65 72 20 22 72 75 6e 6e run header "runn
65c0: 61 6d 65 22 29 29 29 0a 09 09 20 20 20 28 28 73 ame")))... ((s
65d0: 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 29 et-state-status)
65e0: 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 ... (debug:pr
65f0: 69 6e 74 20 31 20 22 4d 6f 64 69 66 79 69 6e 67 int 1 "Modifying
6600: 20 73 74 61 74 65 20 61 6e 64 20 73 74 61 75 73 state and staus
6610: 20 66 6f 72 20 74 65 73 74 73 20 66 6f 72 20 72 for tests for r
6620: 75 6e 3a 20 22 20 72 75 6e 6b 65 79 20 22 20 22 un: " runkey " "
6630: 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 (db:get-value-b
6640: 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 y-header run hea
6650: 64 65 72 20 22 72 75 6e 6e 61 6d 65 22 29 29 29 der "runname")))
6660: 0a 09 09 20 20 20 28 28 70 72 69 6e 74 2d 72 75 ... ((print-ru
6670: 6e 29 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a n)... (debug:
6680: 70 72 69 6e 74 20 31 20 22 50 72 69 6e 74 69 6e print 1 "Printin
6690: 67 20 69 6e 66 6f 20 66 6f 72 20 72 75 6e 20 22 g info for run "
66a0: 20 72 75 6e 6b 65 79 20 22 2c 20 72 75 6e 3d 22 runkey ", run="
66b0: 20 72 75 6e 20 22 2c 20 74 65 73 74 73 3d 22 20 run ", tests="
66c0: 74 65 73 74 73 20 22 2c 20 68 65 61 64 65 72 3d tests ", header=
66d0: 22 20 68 65 61 64 65 72 29 0a 09 09 20 20 20 20 " header)...
66e0: 61 63 74 69 6f 6e 29 0a 09 09 20 20 20 28 65 6c action)... (el
66f0: 73 65 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a se... (debug:
6700: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 61 63 print-info 0 "ac
6710: 74 69 6f 6e 20 6e 6f 74 20 72 65 63 6f 67 6e 69 tion not recogni
6720: 73 65 64 20 22 20 61 63 74 69 6f 6e 29 29 29 0a sed " action))).
6730: 09 09 20 28 66 6f 72 2d 65 61 63 68 0a 09 09 20 .. (for-each...
6740: 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 29 0a (lambda (test).
6750: 09 09 20 20 20 20 28 6c 65 74 2a 20 28 28 69 74 .. (let* ((it
6760: 65 6d 2d 70 61 74 68 20 28 64 62 3a 74 65 73 74 em-path (db:test
6770: 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 -get-item-path t
6780: 65 73 74 29 29 0a 09 09 09 20 20 20 28 74 65 73 est)).... (tes
6790: 74 2d 6e 61 6d 65 20 28 64 62 3a 74 65 73 74 2d t-name (db:test-
67a0: 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 get-testname tes
67b0: 74 29 29 0a 09 09 09 20 20 20 28 72 75 6e 2d 64 t)).... (run-d
67c0: 69 72 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 ir (db:test-ge
67d0: 74 2d 72 75 6e 64 69 72 20 74 65 73 74 29 29 20 t-rundir test))
67e0: 20 20 20 3b 3b 20 72 75 6e 20 64 69 72 20 69 73 ;; run dir is
67f0: 20 66 72 6f 6d 20 74 68 65 20 6c 69 6e 6b 20 74 from the link t
6800: 72 65 65 0a 09 09 09 20 20 20 28 72 65 61 6c 2d ree.... (real-
6810: 64 69 72 20 20 28 69 66 20 28 66 69 6c 65 2d 65 dir (if (file-e
6820: 78 69 73 74 73 3f 20 72 75 6e 2d 64 69 72 29 0a xists? run-dir).
6830: 09 09 09 09 09 20 20 28 72 65 73 6f 6c 76 65 2d ..... (resolve-
6840: 70 61 74 68 6e 61 6d 65 20 72 75 6e 2d 64 69 72 pathname run-dir
6850: 29 0a 09 09 09 09 09 20 20 23 66 29 29 0a 09 09 )...... #f))...
6860: 09 20 20 20 28 74 65 73 74 2d 69 64 20 20 20 28 . (test-id (
6870: 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 db:test-get-id t
6880: 65 73 74 29 29 29 0a 09 09 20 20 20 20 20 20 3b est)))... ;
6890: 3b 20 20 20 28 74 64 62 20 20 20 20 20 20 20 28 ; (tdb (
68a0: 64 62 3a 6f 70 65 6e 2d 74 65 73 74 2d 64 62 20 db:open-test-db
68b0: 72 75 6e 2d 64 69 72 29 29 29 0a 09 09 20 20 20 run-dir)))...
68c0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
68d0: 69 6e 66 6f 20 34 20 22 74 65 73 74 3d 22 20 74 info 4 "test=" t
68e0: 65 73 74 29 20 3b 3b 20 20 20 22 20 28 64 62 3a est) ;; " (db:
68f0: 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d test-get-testnam
6900: 65 20 74 65 73 74 29 20 22 20 69 64 3a 20 22 20 e test) " id: "
6910: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 (db:test-get-id
6920: 74 65 73 74 29 20 22 20 22 20 69 74 65 6d 2d 70 test) " " item-p
6930: 61 74 68 20 22 20 61 63 74 69 6f 6e 3a 20 22 20 ath " action: "
6940: 61 63 74 69 6f 6e 29 0a 09 09 20 20 20 20 20 20 action)...
6950: 28 63 61 73 65 20 61 63 74 69 6f 6e 0a 09 09 09 (case action....
6960: 28 28 72 65 6d 6f 76 65 2d 72 75 6e 73 29 20 3b ((remove-runs) ;
6970: 3b 20 74 68 65 20 74 64 62 20 69 73 20 66 6f 72 ; the tdb is for
6980: 20 66 75 74 75 72 65 20 70 6f 73 73 69 62 6c 65 future possible
6990: 2e 20 0a 09 09 09 20 28 6f 70 65 6e 2d 72 75 6e . .... (open-run
69a0: 2d 63 6c 6f 73 65 20 64 62 3a 64 65 6c 65 74 65 -close db:delete
69b0: 2d 74 65 73 74 2d 72 65 63 6f 72 64 73 20 64 62 -test-records db
69c0: 20 23 66 20 28 64 62 3a 74 65 73 74 2d 67 65 74 #f (db:test-get
69d0: 2d 69 64 20 74 65 73 74 29 29 0a 09 09 09 20 28 -id test)).... (
69e0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
69f0: 20 31 20 22 41 74 74 65 6d 70 74 69 6e 67 20 74 1 "Attempting t
6a00: 6f 20 72 65 6d 6f 76 65 20 22 20 28 69 66 20 72 o remove " (if r
6a10: 65 61 6c 2d 64 69 72 20 28 63 6f 6e 63 20 22 20 eal-dir (conc "
6a20: 64 69 72 20 22 20 72 65 61 6c 2d 64 69 72 20 22 dir " real-dir "
6a30: 20 61 6e 64 20 22 29 20 22 22 29 20 22 20 6c 69 and ") "") " li
6a40: 6e 6b 20 22 20 72 75 6e 2d 64 69 72 29 0a 09 09 nk " run-dir)...
6a50: 09 20 28 69 66 20 28 61 6e 64 20 72 65 61 6c 2d . (if (and real-
6a60: 64 69 72 20 0a 09 09 09 09 20 20 28 3e 20 28 73 dir ..... (> (s
6a70: 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 72 65 61 tring-length rea
6a80: 6c 2d 64 69 72 29 20 35 29 0a 09 09 09 09 20 20 l-dir) 5).....
6a90: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 72 65 (file-exists? re
6aa0: 61 6c 2d 64 69 72 29 29 20 3b 3b 20 62 61 64 20 al-dir)) ;; bad
6ab0: 68 65 75 72 69 73 74 69 63 20 62 75 74 20 73 68 heuristic but sh
6ac0: 6f 75 6c 64 20 70 72 65 76 65 6e 74 20 2f 74 6d ould prevent /tm
6ad0: 70 20 2f 68 6f 6d 65 20 65 74 63 2e 0a 09 09 09 p /home etc.....
6ae0: 20 20 20 20 20 28 62 65 67 69 6e 20 3b 3b 20 6c (begin ;; l
6af0: 65 74 2a 20 28 28 72 65 61 6c 70 61 74 68 20 28 et* ((realpath (
6b00: 72 65 73 6f 6c 76 65 2d 70 61 74 68 6e 61 6d 65 resolve-pathname
6b10: 20 72 75 6e 2d 64 69 72 29 29 29 0a 09 09 09 20 run-dir)))....
6b20: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
6b30: 6e 74 2d 69 6e 66 6f 20 31 20 22 52 65 63 75 72 nt-info 1 "Recur
6b40: 73 69 76 65 6c 79 20 72 65 6d 6f 76 69 6e 67 20 sively removing
6b50: 22 20 72 65 61 6c 2d 64 69 72 29 0a 09 09 09 20 " real-dir)....
6b60: 20 20 20 20 20 20 28 69 66 20 28 66 69 6c 65 2d (if (file-
6b70: 65 78 69 73 74 73 3f 20 72 65 61 6c 2d 64 69 72 exists? real-dir
6b80: 29 0a 09 09 09 09 20 20 20 28 69 66 20 28 3e 20 )..... (if (>
6b90: 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 72 (system (conc "r
6ba0: 6d 20 2d 72 66 20 22 20 72 65 61 6c 2d 64 69 72 m -rf " real-dir
6bb0: 29 29 20 30 29 0a 09 09 09 09 20 20 20 20 20 20 )) 0).....
6bc0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
6bd0: 22 45 52 52 4f 52 3a 20 54 68 65 72 65 20 77 61 "ERROR: There wa
6be0: 73 20 61 20 70 72 6f 62 6c 65 6d 20 72 65 6d 6f s a problem remo
6bf0: 76 69 6e 67 20 22 20 72 65 61 6c 2d 64 69 72 20 ving " real-dir
6c00: 22 20 77 69 74 68 20 72 6d 20 2d 66 22 29 29 0a " with rm -f")).
6c10: 09 09 09 09 20 20 20 28 64 65 62 75 67 3a 70 72 .... (debug:pr
6c20: 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 int 0 "WARNING:
6c30: 74 65 73 74 20 64 69 72 20 22 20 72 65 61 6c 2d test dir " real-
6c40: 64 69 72 20 22 20 61 70 70 65 61 72 73 20 74 6f dir " appears to
6c50: 20 6e 6f 74 20 65 78 69 73 74 20 6f 72 20 69 73 not exist or is
6c60: 20 6e 6f 74 20 72 65 61 64 61 62 6c 65 22 29 29 not readable"))
6c70: 29 0a 09 09 09 20 20 20 20 20 28 69 66 20 72 65 ).... (if re
6c80: 61 6c 2d 64 69 72 20 0a 09 09 09 09 20 28 64 65 al-dir ..... (de
6c90: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 bug:print 0 "WAR
6ca0: 4e 49 4e 47 3a 20 64 69 72 65 63 74 6f 72 79 20 NING: directory
6cb0: 22 20 72 65 61 6c 2d 64 69 72 20 22 20 64 6f 65 " real-dir " doe
6cc0: 73 20 6e 6f 74 20 65 78 69 73 74 22 29 0a 09 09 s not exist")...
6cd0: 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 .. (debug:print
6ce0: 30 20 22 57 41 52 4e 49 4e 47 3a 20 6e 6f 20 72 0 "WARNING: no r
6cf0: 65 61 6c 20 64 69 72 65 63 74 6f 72 79 20 63 6f eal directory co
6d00: 72 72 6f 73 70 6f 6e 64 69 6e 67 20 74 6f 20 6c rrosponding to l
6d10: 69 6e 6b 20 22 20 72 75 6e 2d 64 69 72 20 22 2c ink " run-dir ",
6d20: 20 6e 6f 74 68 69 6e 67 20 64 6f 6e 65 22 29 29 nothing done"))
6d30: 29 0a 09 09 09 20 28 69 66 20 28 73 79 6d 62 6f ).... (if (symbo
6d40: 6c 69 63 2d 6c 69 6e 6b 3f 20 72 75 6e 2d 64 69 lic-link? run-di
6d50: 72 29 0a 09 09 09 20 20 20 20 20 28 62 65 67 69 r).... (begi
6d60: 6e 0a 09 09 09 20 20 20 20 20 20 20 28 64 65 62 n.... (deb
6d70: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 ug:print-info 1
6d80: 22 52 65 6d 6f 76 69 6e 67 20 73 79 6d 6c 69 6e "Removing symlin
6d90: 6b 20 22 20 72 75 6e 2d 64 69 72 29 0a 09 09 09 k " run-dir)....
6da0: 20 20 20 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 (handle-e
6db0: 78 63 65 70 74 69 6f 6e 73 0a 09 09 09 09 65 78 xceptions.....ex
6dc0: 6e 0a 09 09 09 09 28 64 65 62 75 67 3a 70 72 69 n.....(debug:pri
6dd0: 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 20 46 61 nt 0 "ERROR: Fa
6de0: 69 6c 65 64 20 74 6f 20 72 65 6d 6f 76 65 20 73 iled to remove s
6df0: 79 6d 6c 69 6e 6b 20 22 20 72 75 6e 2d 64 69 72 ymlink " run-dir
6e00: 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f ((condition-pro
6e10: 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 perty-accessor '
6e20: 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 exn 'message) ex
6e30: 6e 29 20 22 2c 20 61 74 74 65 6d 70 74 69 6e 67 n) ", attempting
6e40: 20 74 6f 20 63 6f 6e 74 69 6e 75 65 22 29 0a 09 to continue")..
6e50: 09 09 09 28 64 65 6c 65 74 65 2d 66 69 6c 65 20 ...(delete-file
6e60: 72 75 6e 2d 64 69 72 29 29 29 0a 09 09 09 20 20 run-dir)))....
6e70: 20 20 20 28 69 66 20 28 64 69 72 65 63 74 6f 72 (if (director
6e80: 79 3f 20 72 75 6e 2d 64 69 72 29 0a 09 09 09 09 y? run-dir).....
6e90: 20 28 69 66 20 28 3e 20 28 64 69 72 65 63 74 6f (if (> (directo
6ea0: 72 79 2d 66 6f 6c 64 20 28 6c 61 6d 62 64 61 20 ry-fold (lambda
6eb0: 28 66 20 78 29 28 2b 20 31 20 78 29 29 20 30 20 (f x)(+ 1 x)) 0
6ec0: 72 75 6e 2d 64 69 72 29 20 30 29 0a 09 09 09 09 run-dir) 0).....
6ed0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
6ee0: 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 72 65 t 0 "WARNING: re
6ef0: 66 75 73 69 6e 67 20 74 6f 20 72 65 6d 6f 76 65 fusing to remove
6f00: 20 22 20 72 75 6e 2d 64 69 72 20 22 20 61 73 20 " run-dir " as
6f10: 69 74 20 69 73 20 6e 6f 74 20 65 6d 70 74 79 22 it is not empty"
6f20: 29 0a 09 09 09 09 20 20 20 20 20 20 28 68 61 6e )..... (han
6f30: 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 dle-exceptions..
6f40: 09 09 09 20 20 20 20 20 20 20 65 78 6e 0a 09 09 ... exn...
6f50: 09 09 20 20 20 20 20 20 20 28 64 65 62 75 67 3a .. (debug:
6f60: 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 print 0 "ERROR:
6f70: 20 46 61 69 6c 65 64 20 74 6f 20 72 65 6d 6f 76 Failed to remov
6f80: 65 20 64 69 72 65 63 74 6f 72 79 20 22 20 72 75 e directory " ru
6f90: 6e 2d 64 69 72 20 28 28 63 6f 6e 64 69 74 69 6f n-dir ((conditio
6fa0: 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 n-property-acces
6fb0: 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 sor 'exn 'messag
6fc0: 65 29 20 65 78 6e 29 20 22 2c 20 61 74 74 65 6d e) exn) ", attem
6fd0: 70 74 69 6e 67 20 74 6f 20 63 6f 6e 74 69 6e 75 pting to continu
6fe0: 65 22 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 e")..... (
6ff0: 64 65 6c 65 74 65 2d 64 69 72 65 63 74 6f 72 79 delete-directory
7000: 20 72 75 6e 2d 64 69 72 29 29 29 0a 09 09 09 09 run-dir))).....
7010: 20 28 69 66 20 72 75 6e 2d 64 69 72 0a 09 09 09 (if run-dir....
7020: 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 . (debug:pri
7030: 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 6e nt 0 "WARNING: n
7040: 6f 74 20 72 65 6d 6f 76 69 6e 67 20 22 20 72 75 ot removing " ru
7050: 6e 2d 64 69 72 20 22 20 61 73 20 69 74 20 65 69 n-dir " as it ei
7060: 74 68 65 72 20 64 6f 65 73 6e 27 74 20 65 78 69 ther doesn't exi
7070: 73 74 20 6f 72 20 69 73 20 6e 6f 74 20 61 20 73 st or is not a s
7080: 79 6d 6c 69 6e 6b 22 29 0a 09 09 09 09 20 20 20 ymlink").....
7090: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
70a0: 20 22 4e 4f 54 45 3a 20 74 68 65 20 72 75 6e 20 "NOTE: the run
70b0: 64 69 72 20 66 6f 72 20 74 68 69 73 20 74 65 73 dir for this tes
70c0: 74 20 69 73 20 75 6e 64 65 66 69 6e 65 64 2e 20 t is undefined.
70d0: 54 65 73 74 20 6d 61 79 20 68 61 76 65 20 61 6c Test may have al
70e0: 72 65 61 64 79 20 62 65 65 6e 20 64 65 6c 65 74 ready been delet
70f0: 65 64 2e 22 29 29 0a 09 09 09 09 20 29 29 29 0a ed."))..... ))).
7100: 09 09 09 28 28 73 65 74 2d 73 74 61 74 65 2d 73 ...((set-state-s
7110: 74 61 74 75 73 29 0a 09 09 09 20 28 64 65 62 75 tatus).... (debu
7120: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 22 g:print-info 2 "
7130: 6e 65 77 20 73 74 61 74 65 20 22 20 28 63 61 72 new state " (car
7140: 20 73 74 61 74 65 2d 73 74 61 74 75 73 29 20 22 state-status) "
7150: 2c 20 6e 65 77 20 73 74 61 74 75 73 20 22 20 28 , new status " (
7160: 63 61 64 72 20 73 74 61 74 65 2d 73 74 61 74 75 cadr state-statu
7170: 73 29 29 0a 09 09 09 20 28 6f 70 65 6e 2d 72 75 s)).... (open-ru
7180: 6e 2d 63 6c 6f 73 65 20 64 62 3a 74 65 73 74 2d n-close db:test-
7190: 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 set-state-status
71a0: 2d 62 79 2d 69 64 20 64 62 20 28 64 62 3a 74 65 -by-id db (db:te
71b0: 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 29 20 st-get-id test)
71c0: 28 63 61 72 20 73 74 61 74 65 2d 73 74 61 74 75 (car state-statu
71d0: 73 29 28 63 61 64 72 20 73 74 61 74 65 2d 73 74 s)(cadr state-st
71e0: 61 74 75 73 29 20 23 66 29 29 29 29 29 0a 09 09 atus) #f)))))...
71f0: 20 20 28 73 6f 72 74 20 74 65 73 74 73 20 28 6c (sort tests (l
7200: 61 6d 62 64 61 20 28 61 20 62 29 28 6c 65 74 20 ambda (a b)(let
7210: 28 28 64 69 72 61 20 28 64 62 3a 74 65 73 74 2d ((dira (db:test-
7220: 67 65 74 2d 72 75 6e 64 69 72 20 61 29 29 0a 09 get-rundir a))..
7230: 09 09 09 09 09 20 28 64 69 72 62 20 28 64 62 3a ..... (dirb (db:
7240: 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 20 test-get-rundir
7250: 62 29 29 29 0a 09 09 09 09 09 20 20 20 20 20 28 b)))...... (
7260: 69 66 20 28 61 6e 64 20 28 73 74 72 69 6e 67 3f if (and (string?
7270: 20 64 69 72 61 29 28 73 74 72 69 6e 67 3f 20 64 dira)(string? d
7280: 69 72 62 29 29 0a 09 09 09 09 09 09 20 28 3e 20 irb))....... (>
7290: 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 64 (string-length d
72a0: 69 72 61 29 28 73 74 72 69 6e 67 2d 6c 65 6e 67 ira)(string-leng
72b0: 74 68 20 64 69 72 62 29 29 0a 09 09 09 09 09 09 th dirb)).......
72c0: 20 23 66 29 29 29 29 29 29 29 0a 09 20 20 20 3b #f))))))).. ;
72d0: 3b 20 72 65 6d 6f 76 65 20 74 68 65 20 72 75 6e ; remove the run
72e0: 20 69 66 20 7a 65 72 6f 20 74 65 73 74 73 20 72 if zero tests r
72f0: 65 6d 61 69 6e 0a 09 20 20 20 28 69 66 20 28 65 emain.. (if (e
7300: 71 3f 20 61 63 74 69 6f 6e 20 27 72 65 6d 6f 76 q? action 'remov
7310: 65 2d 72 75 6e 73 29 0a 09 20 20 20 20 20 20 20 e-runs)..
7320: 28 6c 65 74 20 28 28 72 65 6d 74 65 73 74 73 20 (let ((remtests
7330: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 (open-run-close
7340: 64 62 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 db:get-tests-for
7350: 2d 72 75 6e 20 64 62 20 28 64 62 3a 67 65 74 2d -run db (db:get-
7360: 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 value-by-header
7370: 72 75 6e 20 68 65 61 64 65 72 20 22 69 64 22 29 run header "id")
7380: 20 23 66 20 27 28 22 44 45 4c 45 54 45 44 22 29 #f '("DELETED")
7390: 20 27 28 22 6e 2f 61 22 29 20 6e 6f 74 2d 69 6e '("n/a") not-in
73a0: 3a 20 23 74 29 29 29 0a 09 09 20 28 69 66 20 28 : #t)))... (if (
73b0: 6e 75 6c 6c 3f 20 72 65 6d 74 65 73 74 73 29 20 null? remtests)
73c0: 3b 3b 20 6e 6f 20 6d 6f 72 65 20 74 65 73 74 73 ;; no more tests
73d0: 20 72 65 6d 61 69 6e 69 6e 67 0a 09 09 20 20 20 remaining...
73e0: 20 20 28 6c 65 74 2a 20 28 28 64 70 61 72 74 73 (let* ((dparts
73f0: 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 (string-split
7400: 6c 61 73 74 74 70 61 74 68 20 22 2f 22 29 29 0a lasttpath "/")).
7410: 09 09 09 20 20 20 20 28 72 75 6e 70 61 74 68 20 ... (runpath
7420: 28 63 6f 6e 63 20 22 2f 22 20 28 73 74 72 69 6e (conc "/" (strin
7430: 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 0a 09 g-intersperse ..
7440: 09 09 09 09 09 28 74 61 6b 65 20 64 70 61 72 74 .....(take dpart
7450: 73 20 28 2d 20 28 6c 65 6e 67 74 68 20 64 70 61 s (- (length dpa
7460: 72 74 73 29 20 31 29 29 0a 09 09 09 09 09 09 22 rts) 1))......."
7470: 2f 22 29 29 29 29 0a 09 09 20 20 20 20 20 20 20 /"))))...
7480: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 (debug:print 1 "
7490: 52 65 6d 6f 76 69 6e 67 20 72 75 6e 3a 20 22 20 Removing run: "
74a0: 72 75 6e 6b 65 79 20 22 20 22 20 28 64 62 3a 67 runkey " " (db:g
74b0: 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 et-value-by-head
74c0: 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 72 er run header "r
74d0: 75 6e 6e 61 6d 65 22 29 20 22 20 61 6e 64 20 72 unname") " and r
74e0: 65 6c 61 74 65 64 20 72 65 63 6f 72 64 22 29 0a elated record").
74f0: 09 09 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 .. (open-r
7500: 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 64 65 6c 65 un-close db:dele
7510: 74 65 2d 72 75 6e 20 64 62 20 72 75 6e 2d 69 64 te-run db run-id
7520: 29 0a 09 09 20 20 20 20 20 20 20 3b 3b 20 54 68 )... ;; Th
7530: 69 73 20 69 73 20 61 20 70 72 65 74 74 79 20 67 is is a pretty g
7540: 6f 6f 64 20 70 6c 61 63 65 20 74 6f 20 70 75 72 ood place to pur
7550: 67 65 20 6f 6c 64 20 44 45 4c 45 54 45 44 20 74 ge old DELETED t
7560: 65 73 74 73 0a 09 09 20 20 20 20 20 20 20 28 6f ests... (o
7570: 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 pen-run-close db
7580: 3a 64 65 6c 65 74 65 2d 74 65 73 74 73 2d 66 6f :delete-tests-fo
7590: 72 2d 72 75 6e 20 64 62 20 72 75 6e 2d 69 64 29 r-run db run-id)
75a0: 0a 09 09 20 20 20 20 20 20 20 28 6f 70 65 6e 2d ... (open-
75b0: 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 64 65 6c run-close db:del
75c0: 65 74 65 2d 6f 6c 64 2d 64 65 6c 65 74 65 64 2d ete-old-deleted-
75d0: 74 65 73 74 2d 72 65 63 6f 72 64 73 20 64 62 29 test-records db)
75e0: 0a 09 09 20 20 20 20 20 20 20 28 6f 70 65 6e 2d ... (open-
75f0: 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 73 65 74 run-close db:set
7600: 2d 76 61 72 20 64 62 20 22 44 45 4c 45 54 45 44 -var db "DELETED
7610: 5f 54 45 53 54 53 22 20 28 63 75 72 72 65 6e 74 _TESTS" (current
7620: 2d 73 65 63 6f 6e 64 73 29 29 0a 09 09 20 20 20 -seconds))...
7630: 20 20 20 20 3b 3b 20 6e 65 65 64 20 74 6f 20 66 ;; need to f
7640: 69 67 75 72 65 20 6f 75 74 20 74 68 65 20 70 61 igure out the pa
7650: 74 68 20 74 6f 20 74 68 65 20 72 75 6e 20 64 69 th to the run di
7660: 72 20 61 6e 64 20 72 65 6d 6f 76 65 20 69 74 20 r and remove it
7670: 69 66 20 65 6d 70 74 79 0a 09 09 20 20 20 20 20 if empty...
7680: 20 20 3b 3b 20 20 20 20 28 69 66 20 28 6e 75 6c ;; (if (nul
7690: 6c 3f 20 28 67 6c 6f 62 20 28 63 6f 6e 63 20 72 l? (glob (conc r
76a0: 75 6e 70 61 74 68 20 22 2f 2a 22 29 29 29 0a 09 unpath "/*")))..
76b0: 09 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 . ;;
76c0: 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 20 (begin...
76d0: 20 20 3b 3b 20 09 20 28 64 65 62 75 67 3a 70 72 ;; . (debug:pr
76e0: 69 6e 74 20 31 20 22 52 65 6d 6f 76 69 6e 67 20 int 1 "Removing
76f0: 72 75 6e 20 64 69 72 20 22 20 72 75 6e 70 61 74 run dir " runpat
7700: 68 29 0a 09 09 20 20 20 20 20 20 20 3b 3b 20 09 h)... ;; .
7710: 20 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 (system (conc "
7720: 72 6d 64 69 72 20 2d 70 20 22 20 72 75 6e 70 61 rmdir -p " runpa
7730: 74 68 29 29 29 29 0a 09 09 20 20 20 20 20 20 20 th))))...
7740: 29 29 29 29 29 0a 09 20 29 29 0a 20 20 20 20 20 ))))).. )).
7750: 72 75 6e 73 29 29 0a 20 20 23 74 29 0a 0a 3b 3b runs)). #t)..;;
7760: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7770: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7780: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7790: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
77a0: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 52 6f 75 74 69 6e ======.;; Routin
77b0: 65 73 20 66 6f 72 20 6d 61 6e 69 70 75 6c 61 74 es for manipulat
77c0: 69 6e 67 20 72 75 6e 73 0a 3b 3b 3d 3d 3d 3d 3d ing runs.;;=====
77d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
77e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
77f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7800: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7810: 3d 0a 0a 3b 3b 20 53 69 6e 63 65 20 6d 61 6e 79 =..;; Since many
7820: 20 63 61 6c 6c 73 20 74 6f 20 61 20 72 75 6e 20 calls to a run
7830: 72 65 71 75 69 72 65 20 70 72 65 74 74 79 20 6d require pretty m
7840: 75 63 68 20 74 68 65 20 73 61 6d 65 20 73 65 74 uch the same set
7850: 75 70 20 0a 3b 3b 20 74 68 69 73 20 77 72 61 70 up .;; this wrap
7860: 70 65 72 20 69 73 20 75 73 65 64 20 74 6f 20 72 per is used to r
7870: 65 64 75 63 65 20 74 68 65 20 72 65 70 6c 69 63 educe the replic
7880: 61 74 69 6f 6e 20 6f 66 20 63 6f 64 65 0a 28 64 ation of code.(d
7890: 65 66 69 6e 65 20 28 67 65 6e 65 72 61 6c 2d 72 efine (general-r
78a0: 75 6e 2d 63 61 6c 6c 20 73 77 69 74 63 68 6e 61 un-call switchna
78b0: 6d 65 20 61 63 74 69 6f 6e 2d 64 65 73 63 20 70 me action-desc p
78c0: 72 6f 63 29 0a 20 20 28 6c 65 74 20 28 28 72 75 roc). (let ((ru
78d0: 6e 6e 61 6d 65 20 28 61 72 67 73 3a 67 65 74 2d nname (args:get-
78e0: 61 72 67 20 22 3a 72 75 6e 6e 61 6d 65 22 29 29 arg ":runname"))
78f0: 0a 09 28 74 61 72 67 65 74 20 20 28 69 66 20 28 ..(target (if (
7900: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 args:get-arg "-t
7910: 61 72 67 65 74 22 29 0a 09 09 20 20 20 20 20 28 arget")... (
7920: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 args:get-arg "-t
7930: 61 72 67 65 74 22 29 0a 09 09 20 20 20 20 20 28 arget")... (
7940: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 args:get-arg "-r
7950: 65 71 74 61 72 67 22 29 29 29 29 0a 09 3b 3b 20 eqtarg"))))..;;
7960: 28 74 68 31 20 20 20 20 20 23 66 29 29 0a 20 20 (th1 #f)).
7970: 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 28 28 6e (cond. ((n
7980: 6f 74 20 74 61 72 67 65 74 29 0a 20 20 20 20 20 ot target).
7990: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
79a0: 22 45 52 52 4f 52 3a 20 4d 69 73 73 69 6e 67 20 "ERROR: Missing
79b0: 72 65 71 75 69 72 65 64 20 70 61 72 61 6d 65 74 required paramet
79c0: 65 72 20 66 6f 72 20 22 20 73 77 69 74 63 68 6e er for " switchn
79d0: 61 6d 65 20 22 2c 20 79 6f 75 20 6d 75 73 74 20 ame ", you must
79e0: 73 70 65 63 69 66 79 20 74 68 65 20 74 61 72 67 specify the targ
79f0: 65 74 20 77 69 74 68 20 2d 74 61 72 67 65 74 22 et with -target"
7a00: 29 0a 20 20 20 20 20 20 28 65 78 69 74 20 33 29 ). (exit 3)
7a10: 29 0a 20 20 20 20 20 28 28 6e 6f 74 20 72 75 6e ). ((not run
7a20: 6e 61 6d 65 29 0a 20 20 20 20 20 20 28 64 65 62 name). (deb
7a30: 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO
7a40: 52 3a 20 4d 69 73 73 69 6e 67 20 72 65 71 75 69 R: Missing requi
7a50: 72 65 64 20 70 61 72 61 6d 65 74 65 72 20 66 6f red parameter fo
7a60: 72 20 22 20 73 77 69 74 63 68 6e 61 6d 65 20 22 r " switchname "
7a70: 2c 20 79 6f 75 20 6d 75 73 74 20 73 70 65 63 69 , you must speci
7a80: 66 79 20 74 68 65 20 72 75 6e 20 6e 61 6d 65 20 fy the run name
7a90: 77 69 74 68 20 3a 72 75 6e 6e 61 6d 65 20 72 75 with :runname ru
7aa0: 6e 6e 61 6d 65 22 29 0a 20 20 20 20 20 20 28 65 nname"). (e
7ab0: 78 69 74 20 33 29 29 0a 20 20 20 20 20 28 65 6c xit 3)). (el
7ac0: 73 65 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 se. (let ((
7ad0: 64 62 20 20 20 23 66 29 0a 09 20 20 20 20 28 6b db #f).. (k
7ae0: 65 79 73 20 23 66 29 0a 09 20 20 20 20 28 74 61 eys #f).. (ta
7af0: 72 67 65 74 20 28 6f 72 20 28 61 72 67 73 3a 67 rget (or (args:g
7b00: 65 74 2d 61 72 67 20 22 2d 72 65 71 74 61 72 67 et-arg "-reqtarg
7b10: 22 29 0a 09 09 09 28 61 72 67 73 3a 67 65 74 2d ")....(args:get-
7b20: 61 72 67 20 22 2d 74 61 72 67 65 74 22 29 29 29 arg "-target")))
7b30: 29 0a 09 28 69 66 20 28 6e 6f 74 20 28 73 65 74 )..(if (not (set
7b40: 75 70 2d 66 6f 72 2d 72 75 6e 29 29 0a 09 20 20 up-for-run))..
7b50: 20 20 28 62 65 67 69 6e 20 0a 09 20 20 20 20 20 (begin ..
7b60: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
7b70: 22 46 61 69 6c 65 64 20 74 6f 20 73 65 74 75 70 "Failed to setup
7b80: 2c 20 65 78 69 74 69 6e 67 22 29 0a 09 20 20 20 , exiting")..
7b90: 20 20 20 28 65 78 69 74 20 31 29 29 29 0a 09 3b (exit 1)))..;
7ba0: 3b 20 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d ; (if (args:get-
7bb0: 61 72 67 20 22 2d 73 65 72 76 65 72 22 29 0a 09 arg "-server")..
7bc0: 3b 3b 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e ;; (open-run
7bd0: 2d 63 6c 6f 73 65 20 73 65 72 76 65 72 3a 73 74 -close server:st
7be0: 61 72 74 20 64 62 20 28 61 72 67 73 3a 67 65 74 art db (args:get
7bf0: 2d 61 72 67 20 22 2d 73 65 72 76 65 72 22 29 29 -arg "-server"))
7c00: 29 0a 09 28 73 65 74 21 20 6b 65 79 73 20 28 6b )..(set! keys (k
7c10: 65 79 73 3a 63 6f 6e 66 69 67 2d 67 65 74 2d 66 eys:config-get-f
7c20: 69 65 6c 64 73 20 2a 63 6f 6e 66 69 67 64 61 74 ields *configdat
7c30: 2a 29 29 0a 09 3b 3b 20 68 61 76 65 20 65 6e 6f *))..;; have eno
7c40: 75 67 68 20 74 6f 20 70 72 6f 63 65 73 73 20 2d ugh to process -
7c50: 74 61 72 67 65 74 20 6f 72 20 2d 72 65 71 74 61 target or -reqta
7c60: 72 67 20 68 65 72 65 0a 09 28 69 66 20 28 61 72 rg here..(if (ar
7c70: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 71 gs:get-arg "-req
7c80: 74 61 72 67 22 29 0a 09 20 20 20 20 28 6c 65 74 targ").. (let
7c90: 2a 20 28 28 72 75 6e 63 6f 6e 66 69 67 66 20 28 * ((runconfigf (
7ca0: 63 6f 6e 63 20 20 2a 74 6f 70 70 61 74 68 2a 20 conc *toppath*
7cb0: 22 2f 72 75 6e 63 6f 6e 66 69 67 73 2e 63 6f 6e "/runconfigs.con
7cc0: 66 69 67 22 29 29 20 3b 3b 20 44 4f 20 4e 4f 54 fig")) ;; DO NOT
7cd0: 20 45 56 41 4c 55 41 54 45 20 41 4c 4c 20 0a 09 EVALUATE ALL ..
7ce0: 09 20 20 20 28 72 75 6e 63 6f 6e 66 69 67 20 20 . (runconfig
7cf0: 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 72 75 6e (read-config run
7d00: 63 6f 6e 66 69 67 66 20 23 66 20 23 74 20 65 6e configf #f #t en
7d10: 76 69 72 6f 6e 2d 70 61 74 74 3a 20 23 66 29 29 viron-patt: #f))
7d20: 29 20 0a 09 20 20 20 20 20 20 28 69 66 20 28 68 ) .. (if (h
7d30: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
7d40: 66 61 75 6c 74 20 72 75 6e 63 6f 6e 66 69 67 20 fault runconfig
7d50: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
7d60: 72 65 71 74 61 72 67 22 29 20 23 66 29 0a 09 09 reqtarg") #f)...
7d70: 20 20 28 6b 65 79 73 3a 74 61 72 67 65 74 2d 73 (keys:target-s
7d80: 65 74 2d 61 72 67 73 20 6b 65 79 73 20 28 61 72 et-args keys (ar
7d90: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 71 gs:get-arg "-req
7da0: 74 61 72 67 22 29 20 61 72 67 73 3a 61 72 67 2d targ") args:arg-
7db0: 68 61 73 68 29 0a 09 09 20 20 20 20 0a 09 09 20 hash)... ...
7dc0: 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 28 64 (begin... (d
7dd0: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 ebug:print 0 "ER
7de0: 52 4f 52 3a 20 5b 22 20 28 61 72 67 73 3a 67 65 ROR: [" (args:ge
7df0: 74 2d 61 72 67 20 22 2d 72 65 71 74 61 72 67 22 t-arg "-reqtarg"
7e00: 29 20 22 5d 20 6e 6f 74 20 66 6f 75 6e 64 20 69 ) "] not found i
7e10: 6e 20 22 20 72 75 6e 63 6f 6e 66 69 67 66 29 0a n " runconfigf).
7e20: 09 09 20 20 20 20 28 69 66 20 64 62 20 28 73 71 .. (if db (sq
7e30: 6c 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 lite3:finalize!
7e40: 64 62 29 29 0a 09 09 20 20 20 20 28 65 78 69 74 db))... (exit
7e50: 20 31 29 29 29 29 0a 09 20 20 20 20 28 69 66 20 1)))).. (if
7e60: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
7e70: 74 61 72 67 65 74 22 29 0a 09 09 28 6b 65 79 73 target")...(keys
7e80: 3a 74 61 72 67 65 74 2d 73 65 74 2d 61 72 67 73 :target-set-args
7e90: 20 6b 65 79 73 20 28 61 72 67 73 3a 67 65 74 2d keys (args:get-
7ea0: 61 72 67 20 22 2d 74 61 72 67 65 74 22 20 61 72 arg "-target" ar
7eb0: 67 73 3a 61 72 67 2d 68 61 73 68 29 20 61 72 67 gs:arg-hash) arg
7ec0: 73 3a 61 72 67 2d 68 61 73 68 29 29 29 0a 09 28 s:arg-hash)))..(
7ed0: 69 66 20 28 6e 6f 74 20 28 63 61 72 20 2a 63 6f if (not (car *co
7ee0: 6e 66 69 67 69 6e 66 6f 2a 29 29 0a 09 20 20 20 nfiginfo*))..
7ef0: 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 (begin.. (
7f00: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 debug:print 0 "E
7f10: 52 52 4f 52 3a 20 41 74 74 65 6d 70 74 65 64 20 RROR: Attempted
7f20: 74 6f 20 22 20 61 63 74 69 6f 6e 2d 64 65 73 63 to " action-desc
7f30: 20 22 20 62 75 74 20 72 75 6e 20 61 72 65 61 20 " but run area
7f40: 63 6f 6e 66 69 67 20 66 69 6c 65 20 6e 6f 74 20 config file not
7f50: 66 6f 75 6e 64 22 29 0a 09 20 20 20 20 20 20 28 found").. (
7f60: 65 78 69 74 20 31 29 29 0a 09 20 20 20 20 3b 3b exit 1)).. ;;
7f70: 20 45 78 74 72 61 63 74 20 6f 75 74 20 73 74 75 Extract out stu
7f80: 66 66 20 6e 65 65 64 65 64 20 69 6e 20 6d 6f 73 ff needed in mos
7f90: 74 20 6f 72 20 6d 61 6e 79 20 63 61 6c 6c 73 0a t or many calls.
7fa0: 09 20 20 20 20 3b 3b 20 68 65 72 65 20 74 68 65 . ;; here the
7fb0: 6e 20 63 61 6c 6c 20 70 72 6f 63 0a 09 20 20 20 n call proc..
7fc0: 20 28 6c 65 74 2a 20 28 28 6b 65 79 76 61 6c 73 (let* ((keyvals
7fd0: 20 20 20 20 28 6b 65 79 73 3a 74 61 72 67 65 74 (keys:target
7fe0: 2d 3e 6b 65 79 76 61 6c 20 6b 65 79 73 20 74 61 ->keyval keys ta
7ff0: 72 67 65 74 29 29 29 0a 09 20 20 20 20 20 20 28 rget))).. (
8000: 70 72 6f 63 20 74 61 72 67 65 74 20 72 75 6e 6e proc target runn
8010: 61 6d 65 20 6b 65 79 73 20 6b 65 79 76 61 6c 73 ame keys keyvals
8020: 29 29 29 0a 09 28 69 66 20 64 62 20 28 73 71 6c )))..(if db (sql
8030: 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 64 ite3:finalize! d
8040: 62 29 29 0a 09 28 73 65 74 21 20 2a 64 69 64 73 b))..(set! *dids
8050: 6f 6d 65 74 68 69 6e 67 2a 20 23 74 29 29 29 29 omething* #t))))
8060: 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ))..;;==========
8070: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8080: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8090: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
80a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
80b0: 4c 6f 63 6b 2f 75 6e 6c 6f 63 6b 20 72 75 6e 73 Lock/unlock runs
80c0: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
80d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
80e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
80f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8100: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 =========..(defi
8110: 6e 65 20 28 72 75 6e 73 3a 68 61 6e 64 6c 65 2d ne (runs:handle-
8120: 6c 6f 63 6b 69 6e 67 20 74 61 72 67 65 74 20 6b locking target k
8130: 65 79 73 20 72 75 6e 6e 61 6d 65 20 6c 6f 63 6b eys runname lock
8140: 20 75 6e 6c 6f 63 6b 20 75 73 65 72 29 0a 20 20 unlock user).
8150: 28 6c 65 74 2a 20 28 28 64 62 20 20 20 20 20 20 (let* ((db
8160: 20 23 66 29 0a 09 20 28 72 75 6e 64 61 74 20 20 #f).. (rundat
8170: 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 (open-run-close
8180: 20 72 75 6e 73 3a 67 65 74 2d 72 75 6e 73 2d 62 runs:get-runs-b
8190: 79 2d 70 61 74 74 20 64 62 20 6b 65 79 73 20 72 y-patt db keys r
81a0: 75 6e 6e 61 6d 65 20 74 61 72 67 65 74 29 29 0a unname target)).
81b0: 09 20 28 68 65 61 64 65 72 20 20 20 28 76 65 63 . (header (vec
81c0: 74 6f 72 2d 72 65 66 20 72 75 6e 64 61 74 20 30 tor-ref rundat 0
81d0: 29 29 0a 09 20 28 72 75 6e 73 20 20 20 20 20 28 )).. (runs (
81e0: 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 64 61 vector-ref runda
81f0: 74 20 31 29 29 29 0a 20 20 20 20 28 66 6f 72 2d t 1))). (for-
8200: 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 72 75 each (lambda (ru
8210: 6e 29 0a 09 09 28 6c 65 74 20 28 28 72 75 6e 2d n)...(let ((run-
8220: 69 64 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 id (db:get-value
8230: 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 -by-header run h
8240: 65 61 64 65 72 20 22 69 64 22 29 29 29 0a 09 09 eader "id")))...
8250: 20 20 28 69 66 20 28 6f 72 20 6c 6f 63 6b 0a 09 (if (or lock..
8260: 09 09 20 20 28 61 6e 64 20 75 6e 6c 6f 63 6b 0a .. (and unlock.
8270: 09 09 09 20 20 20 20 20 20 20 28 62 65 67 69 6e ... (begin
8280: 0a 09 09 09 09 20 28 70 72 69 6e 74 20 22 44 6f ..... (print "Do
8290: 20 79 6f 75 20 72 65 61 6c 6c 79 20 77 69 73 68 you really wish
82a0: 20 74 6f 20 75 6e 6c 6f 63 6b 20 72 75 6e 20 22 to unlock run "
82b0: 20 72 75 6e 2d 69 64 20 22 3f 5c 6e 20 20 20 79 run-id "?\n y
82c0: 2f 6e 3a 20 22 29 0a 09 09 09 09 20 28 65 71 75 /n: ")..... (equ
82d0: 61 6c 3f 20 22 79 22 20 28 72 65 61 64 2d 6c 69 al? "y" (read-li
82e0: 6e 65 29 29 29 29 29 0a 09 09 20 20 20 20 20 20 ne)))))...
82f0: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 (open-run-close
8300: 64 62 3a 6c 6f 63 6b 2f 75 6e 6c 6f 63 6b 2d 72 db:lock/unlock-r
8310: 75 6e 20 64 62 20 72 75 6e 2d 69 64 20 6c 6f 63 un db run-id loc
8320: 6b 20 75 6e 6c 6f 63 6b 20 75 73 65 72 29 0a 09 k unlock user)..
8330: 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
8340: 69 6e 74 2d 69 6e 66 6f 20 30 20 22 53 6b 69 70 int-info 0 "Skip
8350: 70 69 6e 67 20 6c 6f 63 6b 2f 75 6e 6c 6f 63 6b ping lock/unlock
8360: 20 6f 6e 20 22 20 72 75 6e 2d 69 64 29 29 29 29 on " run-id))))
8370: 0a 09 20 20 20 20 20 20 72 75 6e 73 29 29 29 0a .. runs))).
8380: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
8390: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
83a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
83b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
83c0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 52 6f 6c 6c ========.;; Roll
83d0: 75 70 20 72 75 6e 73 0a 3b 3b 3d 3d 3d 3d 3d 3d up runs.;;======
83e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
83f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8400: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8410: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8420: 0a 0a 3b 3b 20 55 70 64 61 74 65 20 74 68 65 20 ..;; Update the
8430: 74 65 73 74 5f 6d 65 74 61 20 74 61 62 6c 65 20 test_meta table
8440: 66 6f 72 20 74 68 69 73 20 74 65 73 74 0a 28 64 for this test.(d
8450: 65 66 69 6e 65 20 28 72 75 6e 73 3a 75 70 64 61 efine (runs:upda
8460: 74 65 2d 74 65 73 74 5f 6d 65 74 61 20 74 65 73 te-test_meta tes
8470: 74 2d 6e 61 6d 65 20 74 65 73 74 2d 63 6f 6e 66 t-name test-conf
8480: 29 0a 20 20 28 6c 65 74 20 28 28 63 75 72 72 72 ). (let ((currr
8490: 65 63 6f 72 64 20 28 63 64 62 3a 72 65 6d 6f 74 ecord (cdb:remot
84a0: 65 2d 72 75 6e 20 64 62 3a 74 65 73 74 6d 65 74 e-run db:testmet
84b0: 61 2d 67 65 74 2d 72 65 63 6f 72 64 20 23 66 20 a-get-record #f
84c0: 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a 20 20 20 test-name))).
84d0: 20 28 69 66 20 28 6e 6f 74 20 63 75 72 72 72 65 (if (not currre
84e0: 63 6f 72 64 29 0a 09 28 62 65 67 69 6e 0a 09 20 cord)..(begin..
84f0: 20 28 73 65 74 21 20 63 75 72 72 72 65 63 6f 72 (set! currrecor
8500: 64 20 28 6d 61 6b 65 2d 76 65 63 74 6f 72 20 31 d (make-vector 1
8510: 30 20 23 66 29 29 0a 09 20 20 28 63 64 62 3a 72 0 #f)).. (cdb:r
8520: 65 6d 6f 74 65 2d 72 75 6e 20 64 62 3a 74 65 73 emote-run db:tes
8530: 74 6d 65 74 61 2d 61 64 64 2d 72 65 63 6f 72 64 tmeta-add-record
8540: 20 23 66 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 #f test-name)))
8550: 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a . (for-each .
8560: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 6b 65 (lambda (ke
8570: 79 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 y). (let*
8580: 28 28 69 64 78 20 28 63 61 64 72 20 6b 65 79 29 ((idx (cadr key)
8590: 29 0a 09 20 20 20 20 20 20 28 66 6c 64 20 28 63 ).. (fld (c
85a0: 61 72 20 20 6b 65 79 29 29 0a 09 20 20 20 20 20 ar key))..
85b0: 20 28 76 61 6c 20 28 63 6f 6e 66 69 67 2d 6c 6f (val (config-lo
85c0: 6f 6b 75 70 20 74 65 73 74 2d 63 6f 6e 66 20 22 okup test-conf "
85d0: 74 65 73 74 5f 6d 65 74 61 22 20 66 6c 64 29 29 test_meta" fld))
85e0: 29 0a 09 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 ).. ;; (debug:pr
85f0: 69 6e 74 20 35 20 22 69 64 78 3a 20 22 20 69 64 int 5 "idx: " id
8600: 78 20 22 20 66 6c 64 3a 20 22 20 66 6c 64 20 22 x " fld: " fld "
8610: 20 76 61 6c 3a 20 22 20 76 61 6c 29 0a 09 20 28 val: " val).. (
8620: 69 66 20 28 61 6e 64 20 76 61 6c 20 28 6e 6f 74 if (and val (not
8630: 20 28 65 71 75 61 6c 3f 20 28 76 65 63 74 6f 72 (equal? (vector
8640: 2d 72 65 66 20 63 75 72 72 72 65 63 6f 72 64 20 -ref currrecord
8650: 69 64 78 29 20 76 61 6c 29 29 29 0a 09 20 20 20 idx) val)))..
8660: 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 (begin..
8670: 20 28 70 72 69 6e 74 20 22 55 70 64 61 74 69 6e (print "Updatin
8680: 67 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 g " test-name "
8690: 22 20 66 6c 64 20 22 20 74 6f 20 22 20 76 61 6c " fld " to " val
86a0: 29 0a 09 20 20 20 20 20 20 20 28 63 64 62 3a 72 ).. (cdb:r
86b0: 65 6d 6f 74 65 2d 72 75 6e 20 64 62 3a 74 65 73 emote-run db:tes
86c0: 74 6d 65 74 61 2d 75 70 64 61 74 65 2d 66 69 65 tmeta-update-fie
86d0: 6c 64 20 23 66 20 74 65 73 74 2d 6e 61 6d 65 20 ld #f test-name
86e0: 66 6c 64 20 76 61 6c 29 29 29 29 29 0a 20 20 20 fld val))))).
86f0: 20 20 27 28 28 22 61 75 74 68 6f 72 22 20 32 29 '(("author" 2)
8700: 28 22 6f 77 6e 65 72 22 20 33 29 28 22 64 65 73 ("owner" 3)("des
8710: 63 72 69 70 74 69 6f 6e 22 20 34 29 28 22 72 65 cription" 4)("re
8720: 76 69 65 77 65 64 22 20 35 29 28 22 74 61 67 73 viewed" 5)("tags
8730: 22 20 39 29 29 29 29 29 0a 0a 3b 3b 20 55 70 64 " 9)))))..;; Upd
8740: 61 74 65 20 74 65 73 74 5f 6d 65 74 61 20 66 6f ate test_meta fo
8750: 72 20 61 6c 6c 20 74 65 73 74 73 0a 28 64 65 66 r all tests.(def
8760: 69 6e 65 20 28 72 75 6e 73 3a 75 70 64 61 74 65 ine (runs:update
8770: 2d 61 6c 6c 2d 74 65 73 74 5f 6d 65 74 61 20 64 -all-test_meta d
8780: 62 29 0a 20 20 28 6c 65 74 20 28 28 74 65 73 74 b). (let ((test
8790: 2d 6e 61 6d 65 73 20 28 67 65 74 2d 61 6c 6c 2d -names (get-all-
87a0: 6c 65 67 61 6c 2d 74 65 73 74 73 29 29 29 0a 20 legal-tests))).
87b0: 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 (for-each .
87c0: 20 20 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 (lambda (test
87d0: 2d 6e 61 6d 65 29 0a 20 20 20 20 20 20 20 28 6c -name). (l
87e0: 65 74 2a 20 28 28 74 65 73 74 2d 70 61 74 68 20 et* ((test-path
87f0: 20 20 20 28 63 6f 6e 63 20 2a 74 6f 70 70 61 74 (conc *toppat
8800: 68 2a 20 22 2f 74 65 73 74 73 2f 22 20 74 65 73 h* "/tests/" tes
8810: 74 2d 6e 61 6d 65 29 29 0a 09 20 20 20 20 20 20 t-name))..
8820: 28 74 65 73 74 2d 63 6f 6e 66 69 67 66 20 28 63 (test-configf (c
8830: 6f 6e 63 20 74 65 73 74 2d 70 61 74 68 20 22 2f onc test-path "/
8840: 74 65 73 74 63 6f 6e 66 69 67 22 29 29 0a 09 20 testconfig"))..
8850: 20 20 20 20 20 28 74 65 73 74 65 78 69 73 74 73 (testexists
8860: 20 20 20 28 61 6e 64 20 28 66 69 6c 65 2d 65 78 (and (file-ex
8870: 69 73 74 73 3f 20 74 65 73 74 2d 63 6f 6e 66 69 ists? test-confi
8880: 67 66 29 28 66 69 6c 65 2d 72 65 61 64 2d 61 63 gf)(file-read-ac
8890: 63 65 73 73 3f 20 74 65 73 74 2d 63 6f 6e 66 69 cess? test-confi
88a0: 67 66 29 29 29 0a 09 20 20 20 20 20 20 3b 3b 20 gf))).. ;;
88b0: 72 65 61 64 20 63 6f 6e 66 69 67 73 20 77 69 74 read configs wit
88c0: 68 20 74 72 69 63 6b 73 20 74 75 72 6e 65 64 20 h tricks turned
88d0: 6f 66 66 20 28 69 2e 65 2e 20 6e 6f 20 73 79 73 off (i.e. no sys
88e0: 74 65 6d 29 0a 09 20 20 20 20 20 20 28 74 65 73 tem).. (tes
88f0: 74 2d 63 6f 6e 66 20 20 20 20 28 69 66 20 74 65 t-conf (if te
8900: 73 74 65 78 69 73 74 73 20 28 72 65 61 64 2d 63 stexists (read-c
8910: 6f 6e 66 69 67 20 74 65 73 74 2d 63 6f 6e 66 69 onfig test-confi
8920: 67 66 20 23 66 20 23 66 29 28 6d 61 6b 65 2d 68 gf #f #f)(make-h
8930: 61 73 68 2d 74 61 62 6c 65 29 29 29 29 0a 09 20 ash-table))))..
8940: 3b 3b 20 75 73 65 20 74 68 65 20 6f 70 65 6e 2d ;; use the open-
8950: 72 75 6e 2d 63 6c 6f 73 65 20 69 6e 73 74 65 61 run-close instea
8960: 64 20 6f 66 20 70 61 73 73 69 6e 67 20 69 6e 20 d of passing in
8970: 64 62 0a 09 20 28 72 75 6e 73 3a 75 70 64 61 74 db.. (runs:updat
8980: 65 2d 74 65 73 74 5f 6d 65 74 61 20 74 65 73 74 e-test_meta test
8990: 2d 6e 61 6d 65 20 74 65 73 74 2d 63 6f 6e 66 29 -name test-conf)
89a0: 29 29 0a 20 20 20 20 20 74 65 73 74 2d 6e 61 6d )). test-nam
89b0: 65 73 29 29 29 0a 0a 3b 3b 20 54 68 69 73 20 63 es)))..;; This c
89c0: 6f 75 6c 64 20 70 72 6f 62 61 62 6c 79 20 62 65 ould probably be
89d0: 20 72 65 66 61 63 74 6f 72 65 64 20 69 6e 74 6f refactored into
89e0: 20 6f 6e 65 20 63 6f 6d 70 6c 65 78 20 71 75 65 one complex que
89f0: 72 79 20 2e 2e 2e 0a 28 64 65 66 69 6e 65 20 28 ry ....(define (
8a00: 72 75 6e 73 3a 72 6f 6c 6c 75 70 2d 72 75 6e 20 runs:rollup-run
8a10: 6b 65 79 73 20 72 75 6e 6e 61 6d 65 20 75 73 65 keys runname use
8a20: 72 20 6b 65 79 76 61 6c 73 29 0a 20 20 28 64 65 r keyvals). (de
8a30: 62 75 67 3a 70 72 69 6e 74 20 34 20 22 72 75 6e bug:print 4 "run
8a40: 73 3a 72 6f 6c 6c 75 70 2d 72 75 6e 2c 20 6b 65 s:rollup-run, ke
8a50: 79 73 3a 20 22 20 6b 65 79 73 20 22 20 3a 72 75 ys: " keys " :ru
8a60: 6e 6e 61 6d 65 20 22 20 72 75 6e 6e 61 6d 65 20 nname " runname
8a70: 22 20 75 73 65 72 3a 20 22 20 75 73 65 72 29 0a " user: " user).
8a80: 20 20 28 6c 65 74 2a 20 28 28 64 62 20 20 20 20 (let* ((db
8a90: 20 20 20 20 20 20 20 20 20 20 23 66 29 0a 09 20 #f)..
8aa0: 28 6e 65 77 2d 72 75 6e 2d 69 64 20 20 20 20 20 (new-run-id
8ab0: 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e (cdb:remote-run
8ac0: 20 64 62 3a 72 65 67 69 73 74 65 72 2d 72 75 6e db:register-run
8ad0: 20 23 66 20 6b 65 79 73 20 6b 65 79 76 61 6c 73 #f keys keyvals
8ae0: 20 72 75 6e 6e 61 6d 65 20 22 6e 65 77 22 20 22 runname "new" "
8af0: 6e 2f 61 22 20 75 73 65 72 29 29 0a 09 20 28 70 n/a" user)).. (p
8b00: 72 65 76 2d 74 65 73 74 73 20 20 20 20 20 20 28 rev-tests (
8b10: 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 74 open-run-close t
8b20: 65 73 74 3a 67 65 74 2d 6d 61 74 63 68 69 6e 67 est:get-matching
8b30: 2d 70 72 65 76 69 6f 75 73 2d 74 65 73 74 2d 72 -previous-test-r
8b40: 75 6e 2d 72 65 63 6f 72 64 73 20 64 62 20 6e 65 un-records db ne
8b50: 77 2d 72 75 6e 2d 69 64 20 22 25 22 20 22 25 22 w-run-id "%" "%"
8b60: 29 29 0a 09 20 28 63 75 72 72 2d 74 65 73 74 73 )).. (curr-tests
8b70: 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d (open-run-
8b80: 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d 74 65 73 close db:get-tes
8b90: 74 73 2d 66 6f 72 2d 72 75 6e 20 64 62 20 6e 65 ts-for-run db ne
8ba0: 77 2d 72 75 6e 2d 69 64 20 22 25 2f 25 22 20 27 w-run-id "%/%" '
8bb0: 28 29 20 27 28 29 29 29 0a 09 20 28 63 75 72 72 () '())).. (curr
8bc0: 2d 74 65 73 74 73 2d 68 61 73 68 20 28 6d 61 6b -tests-hash (mak
8bd0: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 0a e-hash-table))).
8be0: 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c (open-run-cl
8bf0: 6f 73 65 20 64 62 3a 75 70 64 61 74 65 2d 72 75 ose db:update-ru
8c00: 6e 2d 65 76 65 6e 74 5f 74 69 6d 65 20 64 62 20 n-event_time db
8c10: 6e 65 77 2d 72 75 6e 2d 69 64 29 0a 20 20 20 20 new-run-id).
8c20: 3b 3b 20 69 6e 64 65 78 20 74 68 65 20 61 6c 72 ;; index the alr
8c30: 65 61 64 79 20 73 61 76 65 64 20 74 65 73 74 73 eady saved tests
8c40: 20 62 79 20 74 65 73 74 6e 61 6d 65 20 61 6e 64 by testname and
8c50: 20 69 74 65 6d 64 61 74 20 69 6e 20 63 75 72 72 itemdat in curr
8c60: 2d 74 65 73 74 73 2d 68 61 73 68 0a 20 20 20 20 -tests-hash.
8c70: 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 (for-each. (
8c80: 6c 61 6d 62 64 61 20 28 74 65 73 74 64 61 74 29 lambda (testdat)
8c90: 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 . (let* ((
8ca0: 74 65 73 74 6e 61 6d 65 20 20 28 64 62 3a 74 65 testname (db:te
8cb0: 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 st-get-testname
8cc0: 74 65 73 74 64 61 74 29 29 0a 09 20 20 20 20 20 testdat))..
8cd0: 20 28 69 74 65 6d 2d 70 61 74 68 20 28 64 62 3a (item-path (db:
8ce0: 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 test-get-item-pa
8cf0: 74 68 20 74 65 73 74 64 61 74 29 29 0a 09 20 20 th testdat))..
8d00: 20 20 20 20 28 66 75 6c 6c 2d 6e 61 6d 65 20 28 (full-name (
8d10: 63 6f 6e 63 20 74 65 73 74 6e 61 6d 65 20 22 2f conc testname "/
8d20: 22 20 69 74 65 6d 2d 70 61 74 68 29 29 29 0a 09 " item-path)))..
8d30: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
8d40: 21 20 63 75 72 72 2d 74 65 73 74 73 2d 68 61 73 ! curr-tests-has
8d50: 68 20 66 75 6c 6c 2d 6e 61 6d 65 20 74 65 73 74 h full-name test
8d60: 64 61 74 29 29 29 0a 20 20 20 20 20 63 75 72 72 dat))). curr
8d70: 2d 74 65 73 74 73 29 0a 20 20 20 20 3b 3b 20 4e -tests). ;; N
8d80: 4f 50 45 3a 20 4e 6f 6e 2d 6f 70 74 69 6d 61 6c OPE: Non-optimal
8d90: 20 61 70 70 72 6f 61 63 68 2e 20 54 72 79 20 74 approach. Try t
8da0: 68 69 73 20 69 6e 73 74 65 61 64 2e 0a 20 20 20 his instead..
8db0: 20 3b 3b 20 20 20 31 2e 20 74 65 73 74 73 20 61 ;; 1. tests a
8dc0: 72 65 20 72 65 63 65 69 76 65 64 20 69 6e 20 61 re received in a
8dd0: 20 6c 69 73 74 2c 20 6d 6f 73 74 20 72 65 63 65 list, most rece
8de0: 6e 74 20 66 69 72 73 74 0a 20 20 20 20 3b 3b 20 nt first. ;;
8df0: 20 20 32 2e 20 72 65 70 6c 61 63 65 20 74 68 65 2. replace the
8e00: 20 72 6f 6c 6c 75 70 20 74 65 73 74 20 77 69 74 rollup test wit
8e10: 68 20 74 68 65 20 6e 65 77 20 2a 61 6c 77 61 79 h the new *alway
8e20: 73 2a 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 s*. (for-each
8e30: 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 . (lambda (
8e40: 74 65 73 74 64 61 74 29 0a 20 20 20 20 20 20 20 testdat).
8e50: 28 6c 65 74 2a 20 28 28 74 65 73 74 6e 61 6d 65 (let* ((testname
8e60: 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 (db:test-get-t
8e70: 65 73 74 6e 61 6d 65 20 74 65 73 74 64 61 74 29 estname testdat)
8e80: 29 0a 09 20 20 20 20 20 20 28 69 74 65 6d 2d 70 ).. (item-p
8e90: 61 74 68 20 28 64 62 3a 74 65 73 74 2d 67 65 74 ath (db:test-get
8ea0: 2d 69 74 65 6d 2d 70 61 74 68 20 74 65 73 74 64 -item-path testd
8eb0: 61 74 29 29 0a 09 20 20 20 20 20 20 28 66 75 6c at)).. (ful
8ec0: 6c 2d 6e 61 6d 65 20 28 63 6f 6e 63 20 74 65 73 l-name (conc tes
8ed0: 74 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 tname "/" item-p
8ee0: 61 74 68 29 29 0a 09 20 20 20 20 20 20 28 70 72 ath)).. (pr
8ef0: 65 76 2d 74 65 73 74 2d 64 61 74 20 28 68 61 73 ev-test-dat (has
8f00: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
8f10: 75 6c 74 20 63 75 72 72 2d 74 65 73 74 73 2d 68 ult curr-tests-h
8f20: 61 73 68 20 66 75 6c 6c 2d 6e 61 6d 65 20 23 66 ash full-name #f
8f30: 29 29 0a 09 20 20 20 20 20 20 28 74 65 73 74 2d )).. (test-
8f40: 73 74 65 70 73 20 20 20 20 28 6f 70 65 6e 2d 72 steps (open-r
8f50: 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d un-close db:get-
8f60: 73 74 65 70 73 2d 66 6f 72 2d 74 65 73 74 20 64 steps-for-test d
8f70: 62 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 b (db:test-get-i
8f80: 64 20 74 65 73 74 64 61 74 29 29 29 0a 09 20 20 d testdat)))..
8f90: 20 20 20 20 28 6e 65 77 2d 74 65 73 74 2d 72 65 (new-test-re
8fa0: 63 6f 72 64 20 23 66 29 29 0a 09 20 3b 3b 20 72 cord #f)).. ;; r
8fb0: 65 70 6c 61 63 65 20 74 68 65 73 65 20 77 69 74 eplace these wit
8fc0: 68 20 69 6e 73 65 72 74 20 2e 2e 2e 20 73 65 6c h insert ... sel
8fd0: 65 63 74 0a 09 20 28 61 70 70 6c 79 20 73 71 6c ect.. (apply sql
8fe0: 69 74 65 33 3a 65 78 65 63 75 74 65 20 0a 09 09 ite3:execute ...
8ff0: 64 62 20 0a 09 09 28 63 6f 6e 63 20 22 49 4e 53 db ...(conc "INS
9000: 45 52 54 20 4f 52 20 52 45 50 4c 41 43 45 20 49 ERT OR REPLACE I
9010: 4e 54 4f 20 74 65 73 74 73 20 28 72 75 6e 5f 69 NTO tests (run_i
9020: 64 2c 74 65 73 74 6e 61 6d 65 2c 73 74 61 74 65 d,testname,state
9030: 2c 73 74 61 74 75 73 2c 65 76 65 6e 74 5f 74 69 ,status,event_ti
9040: 6d 65 2c 68 6f 73 74 2c 63 70 75 6c 6f 61 64 2c me,host,cpuload,
9050: 64 69 73 6b 66 72 65 65 2c 75 6e 61 6d 65 2c 72 diskfree,uname,r
9060: 75 6e 64 69 72 2c 69 74 65 6d 5f 70 61 74 68 2c undir,item_path,
9070: 72 75 6e 5f 64 75 72 61 74 69 6f 6e 2c 66 69 6e run_duration,fin
9080: 61 6c 5f 6c 6f 67 66 2c 63 6f 6d 6d 65 6e 74 29 al_logf,comment)
9090: 20 22 0a 09 09 20 20 20 20 20 20 22 56 41 4c 55 "... "VALU
90a0: 45 53 20 28 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c ES (?,?,?,?,?,?,
90b0: 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 29 ?,?,?,?,?,?,?,?)
90c0: 3b 22 29 0a 09 09 6e 65 77 2d 72 75 6e 2d 69 64 ;")...new-run-id
90d0: 20 28 63 64 64 72 20 28 76 65 63 74 6f 72 2d 3e (cddr (vector->
90e0: 6c 69 73 74 20 74 65 73 74 64 61 74 29 29 29 0a list testdat))).
90f0: 09 20 28 73 65 74 21 20 6e 65 77 2d 74 65 73 74 . (set! new-test
9100: 64 61 74 20 28 63 61 72 20 28 6f 70 65 6e 2d 72 dat (car (open-r
9110: 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d un-close db:get-
9120: 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 64 62 tests-for-run db
9130: 20 6e 65 77 2d 72 75 6e 2d 69 64 20 28 63 6f 6e new-run-id (con
9140: 63 20 74 65 73 74 6e 61 6d 65 20 22 2f 22 20 69 c testname "/" i
9150: 74 65 6d 2d 70 61 74 68 29 20 27 28 29 20 27 28 tem-path) '() '(
9160: 29 29 29 29 0a 09 20 28 68 61 73 68 2d 74 61 62 )))).. (hash-tab
9170: 6c 65 2d 73 65 74 21 20 63 75 72 72 2d 74 65 73 le-set! curr-tes
9180: 74 73 2d 68 61 73 68 20 66 75 6c 6c 2d 6e 61 6d ts-hash full-nam
9190: 65 20 6e 65 77 2d 74 65 73 74 64 61 74 29 20 3b e new-testdat) ;
91a0: 3b 20 74 68 69 73 20 63 6f 75 6c 64 20 62 65 20 ; this could be
91b0: 63 6f 6e 66 75 73 69 6e 67 2c 20 77 68 69 63 68 confusing, which
91c0: 20 72 65 63 6f 72 64 20 73 68 6f 75 6c 64 20 67 record should g
91d0: 6f 20 69 6e 74 6f 20 74 68 65 20 6c 6f 6f 6b 75 o into the looku
91e0: 70 20 74 61 62 6c 65 3f 0a 09 20 3b 3b 20 4e 6f p table?.. ;; No
91f0: 77 20 64 75 70 6c 69 63 61 74 65 20 74 68 65 20 w duplicate the
9200: 74 65 73 74 20 73 74 65 70 73 0a 09 20 28 64 65 test steps.. (de
9210: 62 75 67 3a 70 72 69 6e 74 20 34 20 22 43 6f 70 bug:print 4 "Cop
9220: 79 69 6e 67 20 72 65 63 6f 72 64 73 20 69 6e 20 ying records in
9230: 74 65 73 74 5f 73 74 65 70 73 20 66 72 6f 6d 20 test_steps from
9240: 74 65 73 74 5f 69 64 3d 22 20 28 64 62 3a 74 65 test_id=" (db:te
9250: 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 64 61 st-get-id testda
9260: 74 29 20 22 20 74 6f 20 22 20 28 64 62 3a 74 65 t) " to " (db:te
9270: 73 74 2d 67 65 74 2d 69 64 20 6e 65 77 2d 74 65 st-get-id new-te
9280: 73 74 64 61 74 29 29 0a 09 20 28 6f 70 65 6e 2d stdat)).. (open-
9290: 72 75 6e 2d 63 6c 6f 73 65 20 0a 09 20 20 28 6c run-close .. (l
92a0: 61 6d 62 64 61 20 28 29 0a 09 20 20 20 20 28 73 ambda ().. (s
92b0: 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 0a qlite3:execute .
92c0: 09 20 20 20 20 20 64 62 20 0a 09 20 20 20 20 20 . db ..
92d0: 28 63 6f 6e 63 20 22 49 4e 53 45 52 54 20 4f 52 (conc "INSERT OR
92e0: 20 52 45 50 4c 41 43 45 20 49 4e 54 4f 20 74 65 REPLACE INTO te
92f0: 73 74 5f 73 74 65 70 73 20 28 74 65 73 74 5f 69 st_steps (test_i
9300: 64 2c 73 74 65 70 6e 61 6d 65 2c 73 74 61 74 65 d,stepname,state
9310: 2c 73 74 61 74 75 73 2c 65 76 65 6e 74 5f 74 69 ,status,event_ti
9320: 6d 65 2c 63 6f 6d 6d 65 6e 74 29 20 22 0a 09 09 me,comment) "...
9330: 20 20 20 22 53 45 4c 45 43 54 20 22 20 28 64 62 "SELECT " (db
9340: 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 6e 65 77 :test-get-id new
9350: 2d 74 65 73 74 64 61 74 29 20 22 2c 73 74 65 70 -testdat) ",step
9360: 6e 61 6d 65 2c 73 74 61 74 65 2c 73 74 61 74 75 name,state,statu
9370: 73 2c 65 76 65 6e 74 5f 74 69 6d 65 2c 63 6f 6d s,event_time,com
9380: 6d 65 6e 74 20 46 52 4f 4d 20 74 65 73 74 5f 73 ment FROM test_s
9390: 74 65 70 73 20 57 48 45 52 45 20 74 65 73 74 5f teps WHERE test_
93a0: 69 64 3d 3f 3b 22 29 0a 09 20 20 20 20 20 28 64 id=?;").. (d
93b0: 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 b:test-get-id te
93c0: 73 74 64 61 74 29 29 0a 09 20 20 20 20 3b 3b 20 stdat)).. ;;
93d0: 4e 6f 77 20 64 75 70 6c 69 63 61 74 65 20 74 68 Now duplicate th
93e0: 65 20 74 65 73 74 20 64 61 74 61 0a 09 20 20 20 e test data..
93f0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 (debug:print 4
9400: 22 43 6f 70 79 69 6e 67 20 72 65 63 6f 72 64 73 "Copying records
9410: 20 69 6e 20 74 65 73 74 5f 64 61 74 61 20 66 72 in test_data fr
9420: 6f 6d 20 74 65 73 74 5f 69 64 3d 22 20 28 64 62 om test_id=" (db
9430: 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 :test-get-id tes
9440: 74 64 61 74 29 20 22 20 74 6f 20 22 20 28 64 62 tdat) " to " (db
9450: 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 6e 65 77 :test-get-id new
9460: 2d 74 65 73 74 64 61 74 29 29 0a 09 20 20 20 20 -testdat))..
9470: 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 (sqlite3:execute
9480: 20 0a 09 20 20 20 20 20 64 62 20 0a 09 20 20 20 .. db ..
9490: 20 20 28 63 6f 6e 63 20 22 49 4e 53 45 52 54 20 (conc "INSERT
94a0: 4f 52 20 52 45 50 4c 41 43 45 20 49 4e 54 4f 20 OR REPLACE INTO
94b0: 74 65 73 74 5f 64 61 74 61 20 28 74 65 73 74 5f test_data (test_
94c0: 69 64 2c 63 61 74 65 67 6f 72 79 2c 76 61 72 69 id,category,vari
94d0: 61 62 6c 65 2c 76 61 6c 75 65 2c 65 78 70 65 63 able,value,expec
94e0: 74 65 64 2c 74 6f 6c 2c 75 6e 69 74 73 2c 63 6f ted,tol,units,co
94f0: 6d 6d 65 6e 74 29 20 22 0a 09 09 20 20 20 22 53 mment) "... "S
9500: 45 4c 45 43 54 20 22 20 28 64 62 3a 74 65 73 74 ELECT " (db:test
9510: 2d 67 65 74 2d 69 64 20 6e 65 77 2d 74 65 73 74 -get-id new-test
9520: 64 61 74 29 20 22 2c 63 61 74 65 67 6f 72 79 2c dat) ",category,
9530: 76 61 72 69 61 62 6c 65 2c 76 61 6c 75 65 2c 65 variable,value,e
9540: 78 70 65 63 74 65 64 2c 74 6f 6c 2c 75 6e 69 74 xpected,tol,unit
9550: 73 2c 63 6f 6d 6d 65 6e 74 20 46 52 4f 4d 20 74 s,comment FROM t
9560: 65 73 74 5f 64 61 74 61 20 57 48 45 52 45 20 74 est_data WHERE t
9570: 65 73 74 5f 69 64 3d 3f 3b 22 29 0a 09 20 20 20 est_id=?;")..
9580: 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 (db:test-get-i
9590: 64 20 74 65 73 74 64 61 74 29 29 29 29 0a 09 20 d testdat))))..
95a0: 29 29 0a 20 20 20 20 20 70 72 65 76 2d 74 65 73 )). prev-tes
95b0: 74 73 29 29 29 0a 09 20 0a 20 20 20 20 20 0a ts))).. . .