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: 29 20 3b 3b 20 74 65 73 74 2d 6e 61 6d 65 29 0a ) ;; test-name).
0460: 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 76 61 6c (let* ((keyval
0470: 6c 73 74 20 28 6b 65 79 73 2d 3e 76 61 6c 6c 69 lst (keys->valli
0480: 73 74 20 6b 65 79 73 29 29 0a 09 20 28 74 6d 70 st keys)).. (tmp
0490: 20 20 20 20 20 20 28 72 75 6e 73 3a 67 65 74 2d (runs:get-
04a0: 73 74 64 2d 72 75 6e 2d 66 69 65 6c 64 73 20 6b std-run-fields k
04b0: 65 79 73 20 27 28 22 69 64 22 20 22 72 75 6e 6e eys '("id" "runn
04c0: 61 6d 65 22 20 22 73 74 61 74 65 22 20 22 73 74 ame" "state" "st
04d0: 61 74 75 73 22 20 22 6f 77 6e 65 72 22 20 22 65 atus" "owner" "e
04e0: 76 65 6e 74 5f 74 69 6d 65 22 29 29 29 0a 09 20 vent_time")))..
04f0: 28 6b 65 79 73 74 72 20 20 20 28 63 61 72 20 74 (keystr (car t
0500: 6d 70 29 29 0a 09 20 28 68 65 61 64 65 72 20 20 mp)).. (header
0510: 20 28 63 61 64 72 20 74 6d 70 29 29 0a 09 20 28 (cadr tmp)).. (
0520: 72 65 73 20 20 20 20 20 27 28 29 29 0a 09 20 28 res '()).. (
0530: 6b 65 79 2d 70 61 74 74 20 22 22 29 0a 09 20 28 key-patt "").. (
0540: 72 75 6e 77 69 6c 64 74 79 70 65 20 28 69 66 20 runwildtype (if
0550: 28 73 75 62 73 74 72 69 6e 67 2d 69 6e 64 65 78 (substring-index
0560: 20 22 25 22 20 72 75 6e 6e 61 6d 65 70 61 74 74 "%" runnamepatt
0570: 29 20 22 6c 69 6b 65 22 20 22 67 6c 6f 62 22 29 ) "like" "glob")
0580: 29 0a 09 20 28 71 72 79 2d 73 74 72 20 20 23 66 ).. (qry-str #f
0590: 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 )). (for-each
05a0: 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 76 61 6c (lambda (keyval
05b0: 29 0a 09 09 28 6c 65 74 2a 20 28 28 6b 65 79 20 )...(let* ((key
05c0: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 6b (vector-ref k
05d0: 65 79 76 61 6c 20 30 29 29 0a 09 09 20 20 20 20 eyval 0))...
05e0: 20 20 20 28 66 75 6c 6b 65 79 20 28 63 6f 6e 63 (fulkey (conc
05f0: 20 22 3a 22 20 6b 65 79 29 29 0a 09 09 20 20 20 ":" key))...
0600: 20 20 20 20 28 70 61 74 74 20 20 20 28 61 72 67 (patt (arg
0610: 73 3a 67 65 74 2d 61 72 67 20 66 75 6c 6b 65 79 s:get-arg fulkey
0620: 29 29 0a 09 09 20 20 20 20 20 20 20 28 77 69 6c ))... (wil
0630: 64 74 79 70 65 20 28 69 66 20 28 73 75 62 73 74 dtype (if (subst
0640: 72 69 6e 67 2d 69 6e 64 65 78 20 22 25 22 20 70 ring-index "%" p
0650: 61 74 74 29 20 22 6c 69 6b 65 22 20 22 67 6c 6f att) "like" "glo
0660: 62 22 29 29 29 0a 09 09 20 20 28 69 66 20 70 61 b")))... (if pa
0670: 74 74 0a 09 09 20 20 20 20 20 20 28 73 65 74 21 tt... (set!
0680: 20 6b 65 79 2d 70 61 74 74 20 28 63 6f 6e 63 20 key-patt (conc
0690: 6b 65 79 2d 70 61 74 74 20 22 20 41 4e 44 20 22 key-patt " AND "
06a0: 20 6b 65 79 20 22 20 22 20 77 69 6c 64 74 79 70 key " " wildtyp
06b0: 65 20 22 20 27 22 20 70 61 74 74 20 22 27 22 29 e " '" patt "'")
06c0: 29 0a 09 09 20 20 20 20 20 20 28 62 65 67 69 6e )... (begin
06d0: 0a 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 ....(debug:print
06e0: 20 30 20 22 45 52 52 4f 52 3a 20 73 65 61 72 63 0 "ERROR: searc
06f0: 68 69 6e 67 20 66 6f 72 20 72 75 6e 73 20 77 69 hing for runs wi
0700: 74 68 20 6e 6f 20 70 61 74 74 65 72 6e 20 73 65 th no pattern se
0710: 74 20 66 6f 72 20 22 20 66 75 6c 6b 65 79 29 0a t for " fulkey).
0720: 09 09 09 28 65 78 69 74 20 36 29 29 29 29 29 0a ...(exit 6))))).
0730: 09 20 20 20 20 20 20 6b 65 79 73 29 0a 20 20 20 . keys).
0740: 20 28 73 65 74 21 20 71 72 79 2d 73 74 72 20 28 (set! qry-str (
0750: 63 6f 6e 63 20 22 53 45 4c 45 43 54 20 22 20 6b conc "SELECT " k
0760: 65 79 73 74 72 20 22 20 46 52 4f 4d 20 72 75 6e eystr " FROM run
0770: 73 20 57 48 45 52 45 20 72 75 6e 6e 61 6d 65 20 s WHERE runname
0780: 22 20 72 75 6e 77 69 6c 64 74 79 70 65 20 22 20 " runwildtype "
0790: 3f 20 22 20 6b 65 79 2d 70 61 74 74 20 22 3b 22 ? " key-patt ";"
07a0: 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 )). (debug:pr
07b0: 69 6e 74 20 34 20 22 49 4e 46 4f 3a 20 72 75 6e int 4 "INFO: run
07c0: 73 3a 67 65 74 2d 72 75 6e 73 2d 62 79 2d 70 61 s:get-runs-by-pa
07d0: 74 74 20 71 72 79 3d 22 20 71 72 79 2d 73 74 72 tt qry=" qry-str
07e0: 20 22 20 22 20 72 75 6e 6e 61 6d 65 70 61 74 74 " " runnamepatt
07f0: 29 0a 20 20 20 20 28 73 71 6c 69 74 65 33 3a 66 ). (sqlite3:f
0800: 6f 72 2d 65 61 63 68 2d 72 6f 77 20 0a 20 20 20 or-each-row .
0810: 20 20 28 6c 61 6d 62 64 61 20 28 61 20 2e 20 72 (lambda (a . r
0820: 29 0a 20 20 20 20 20 20 20 28 73 65 74 21 20 72 ). (set! r
0830: 65 73 20 28 63 6f 6e 73 20 28 6c 69 73 74 2d 3e es (cons (list->
0840: 76 65 63 74 6f 72 20 28 63 6f 6e 73 20 61 20 72 vector (cons a r
0850: 29 29 20 72 65 73 29 29 29 0a 20 20 20 20 20 64 )) res))). d
0860: 62 20 0a 20 20 20 20 20 71 72 79 2d 73 74 72 0a b . qry-str.
0870: 20 20 20 20 20 72 75 6e 6e 61 6d 65 70 61 74 74 runnamepatt
0880: 29 0a 20 20 20 20 28 76 65 63 74 6f 72 20 68 65 ). (vector he
0890: 61 64 65 72 20 72 65 73 29 29 29 0a 0a 28 64 65 ader res)))..(de
08a0: 66 69 6e 65 20 28 72 75 6e 73 3a 74 65 73 74 2d fine (runs:test-
08b0: 67 65 74 2d 66 75 6c 6c 2d 70 61 74 68 20 74 65 get-full-path te
08c0: 73 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 74 65 st). (let* ((te
08d0: 73 74 6e 61 6d 65 20 28 64 62 3a 74 65 73 74 2d stname (db:test-
08e0: 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 20 20 74 get-testname t
08f0: 65 73 74 29 29 0a 09 20 28 69 74 65 6d 70 61 74 est)).. (itempat
0900: 68 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 h (db:test-get-i
0910: 74 65 6d 2d 70 61 74 68 20 74 65 73 74 29 29 29 tem-path test)))
0920: 0a 20 20 20 20 28 63 6f 6e 63 20 74 65 73 74 6e . (conc testn
0930: 61 6d 65 20 28 69 66 20 28 65 71 75 61 6c 3f 20 ame (if (equal?
0940: 69 74 65 6d 70 61 74 68 20 22 22 29 20 22 22 20 itempath "") ""
0950: 28 63 6f 6e 63 20 22 28 22 20 69 74 65 6d 70 61 (conc "(" itempa
0960: 74 68 20 22 29 22 29 29 29 29 29 0a 0a 3b 3b 20 th ")")))))..;;
0970: 41 77 66 75 6c 2e 20 50 6c 65 61 73 65 20 46 49 Awful. Please FI
0980: 58 4d 45 0a 28 64 65 66 69 6e 65 20 2a 65 6e 76 XME.(define *env
0990: 2d 76 61 72 73 2d 62 79 2d 72 75 6e 2d 69 64 2a -vars-by-run-id*
09a0: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
09b0: 65 29 29 0a 28 64 65 66 69 6e 65 20 2a 63 75 72 e)).(define *cur
09c0: 72 65 6e 74 2d 72 75 6e 2d 6e 61 6d 65 2a 20 20 rent-run-name*
09d0: 20 23 66 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 #f)..(define (s
09e0: 65 74 2d 6d 65 67 61 74 65 73 74 2d 65 6e 76 2d et-megatest-env-
09f0: 76 61 72 73 20 64 62 20 72 75 6e 2d 69 64 29 0a vars db run-id).
0a00: 20 20 28 6c 65 74 20 28 28 6b 65 79 73 20 28 64 (let ((keys (d
0a10: 62 3a 67 65 74 2d 6b 65 79 73 20 64 62 29 29 0a b:get-keys db)).
0a20: 09 28 76 61 6c 73 20 28 68 61 73 68 2d 74 61 62 .(vals (hash-tab
0a30: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a le-ref/default *
0a40: 65 6e 76 2d 76 61 72 73 2d 62 79 2d 72 75 6e 2d env-vars-by-run-
0a50: 69 64 2a 20 72 75 6e 2d 69 64 20 23 66 29 29 29 id* run-id #f)))
0a60: 0a 20 20 20 20 3b 3b 20 67 65 74 20 74 68 65 20 . ;; get the
0a70: 69 6e 66 6f 20 66 72 6f 6d 20 74 68 65 20 64 62 info from the db
0a80: 20 61 6e 64 20 70 75 74 20 69 74 20 69 6e 20 74 and put it in t
0a90: 68 65 20 63 61 63 68 65 0a 20 20 20 20 28 69 66 he cache. (if
0aa0: 20 28 6e 6f 74 20 76 61 6c 73 29 0a 09 28 6c 65 (not vals)..(le
0ab0: 74 20 28 28 68 74 20 28 6d 61 6b 65 2d 68 61 73 t ((ht (make-has
0ac0: 68 2d 74 61 62 6c 65 29 29 29 0a 09 20 20 28 68 h-table))).. (h
0ad0: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a ash-table-set! *
0ae0: 65 6e 76 2d 76 61 72 73 2d 62 79 2d 72 75 6e 2d env-vars-by-run-
0af0: 69 64 2a 20 72 75 6e 2d 69 64 20 68 74 29 0a 09 id* run-id ht)..
0b00: 20 20 28 73 65 74 21 20 76 61 6c 73 20 68 74 29 (set! vals ht)
0b10: 0a 09 20 20 28 66 6f 72 2d 65 61 63 68 0a 09 20 .. (for-each..
0b20: 20 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 29 0a (lambda (key).
0b30: 09 20 20 20 20 20 28 73 71 6c 69 74 65 33 3a 66 . (sqlite3:f
0b40: 6f 72 2d 65 61 63 68 2d 72 6f 77 0a 09 20 20 20 or-each-row..
0b50: 20 20 20 28 6c 61 6d 62 64 61 20 28 76 61 6c 29 (lambda (val)
0b60: 0a 09 09 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 ...(hash-table-s
0b70: 65 74 21 20 76 61 6c 73 20 6b 65 79 20 76 61 6c et! vals key val
0b80: 29 29 0a 09 20 20 20 20 20 20 64 62 20 0a 09 20 )).. db ..
0b90: 20 20 20 20 20 28 63 6f 6e 63 20 22 53 45 4c 45 (conc "SELE
0ba0: 43 54 20 22 20 28 6b 65 79 3a 67 65 74 2d 66 69 CT " (key:get-fi
0bb0: 65 6c 64 6e 61 6d 65 20 6b 65 79 29 20 22 20 46 eldname key) " F
0bc0: 52 4f 4d 20 72 75 6e 73 20 57 48 45 52 45 20 69 ROM runs WHERE i
0bd0: 64 3d 3f 3b 22 29 0a 09 20 20 20 20 20 20 72 75 d=?;").. ru
0be0: 6e 2d 69 64 29 29 0a 09 20 20 20 6b 65 79 73 29 n-id)).. keys)
0bf0: 29 29 0a 20 20 20 20 3b 3b 20 66 72 6f 6d 20 74 )). ;; from t
0c00: 68 65 20 63 61 63 68 65 64 20 64 61 74 61 20 73 he cached data s
0c10: 65 74 20 74 68 65 20 76 61 72 73 0a 20 20 20 20 et the vars.
0c20: 28 68 61 73 68 2d 74 61 62 6c 65 2d 66 6f 72 2d (hash-table-for-
0c30: 65 61 63 68 0a 20 20 20 20 20 76 61 6c 73 0a 20 each. vals.
0c40: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 (lambda (key
0c50: 20 76 61 6c 29 0a 20 20 20 20 20 20 20 28 64 65 val). (de
0c60: 62 75 67 3a 70 72 69 6e 74 20 32 20 22 73 65 74 bug:print 2 "set
0c70: 65 6e 76 20 22 20 28 6b 65 79 3a 67 65 74 2d 66 env " (key:get-f
0c80: 69 65 6c 64 6e 61 6d 65 20 6b 65 79 29 20 22 20 ieldname key) "
0c90: 22 20 76 61 6c 29 0a 20 20 20 20 20 20 20 28 73 " val). (s
0ca0: 65 74 65 6e 76 20 28 6b 65 79 3a 67 65 74 2d 66 etenv (key:get-f
0cb0: 69 65 6c 64 6e 61 6d 65 20 6b 65 79 29 20 76 61 ieldname key) va
0cc0: 6c 29 29 29 0a 20 20 20 20 28 61 6c 69 73 74 2d l))). (alist-
0cd0: 3e 65 6e 76 2d 76 61 72 73 20 28 68 61 73 68 2d >env-vars (hash-
0ce0: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
0cf0: 74 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 65 t *configdat* "e
0d00: 6e 76 2d 6f 76 65 72 72 69 64 65 22 20 27 28 29 nv-override" '()
0d10: 29 29 0a 20 20 20 20 3b 3b 20 4c 65 74 73 20 75 )). ;; Lets u
0d20: 73 65 20 74 68 69 73 20 61 73 20 61 6e 20 6f 70 se this as an op
0d30: 70 6f 72 74 75 6e 69 74 79 20 74 6f 20 70 75 74 portunity to put
0d40: 20 4d 54 5f 52 55 4e 4e 41 4d 45 20 69 6e 20 74 MT_RUNNAME in t
0d50: 68 65 20 65 6e 76 69 72 6f 6e 6d 65 6e 74 0a 20 he environment.
0d60: 20 20 20 28 69 66 20 28 6e 6f 74 20 2a 63 75 72 (if (not *cur
0d70: 72 65 6e 74 2d 72 75 6e 2d 6e 61 6d 65 2a 29 0a rent-run-name*).
0d80: 09 28 73 71 6c 69 74 65 33 3a 66 6f 72 2d 65 61 .(sqlite3:for-ea
0d90: 63 68 2d 72 6f 77 0a 09 20 28 6c 61 6d 62 64 61 ch-row.. (lambda
0da0: 20 28 72 75 6e 6e 61 6d 65 29 0a 09 20 20 20 28 (runname).. (
0db0: 73 65 74 21 20 2a 63 75 72 72 65 6e 74 2d 72 75 set! *current-ru
0dc0: 6e 2d 6e 61 6d 65 2a 20 72 75 6e 6e 61 6d 65 29 n-name* runname)
0dd0: 29 0a 0a 09 20 64 62 0a 09 20 22 53 45 4c 45 43 )... db.. "SELEC
0de0: 54 20 72 75 6e 6e 61 6d 65 20 46 52 4f 4d 20 72 T runname FROM r
0df0: 75 6e 73 20 57 48 45 52 45 20 69 64 3d 3f 3b 22 uns WHERE id=?;"
0e00: 0a 09 20 72 75 6e 2d 69 64 29 29 0a 20 20 20 20 .. run-id)).
0e10: 28 73 65 74 65 6e 76 20 22 4d 54 5f 52 55 4e 4e (setenv "MT_RUNN
0e20: 41 4d 45 22 20 2a 63 75 72 72 65 6e 74 2d 72 75 AME" *current-ru
0e30: 6e 2d 6e 61 6d 65 2a 29 0a 20 20 20 20 28 73 65 n-name*). (se
0e40: 74 65 6e 76 20 22 4d 54 5f 52 55 4e 5f 41 52 45 tenv "MT_RUN_ARE
0e50: 41 5f 48 4f 4d 45 22 20 2a 74 6f 70 70 61 74 68 A_HOME" *toppath
0e60: 2a 29 0a 20 20 20 20 29 29 0a 0a 28 64 65 66 69 *). ))..(defi
0e70: 6e 65 20 28 73 65 74 2d 69 74 65 6d 2d 65 6e 76 ne (set-item-env
0e80: 2d 76 61 72 73 20 69 74 65 6d 64 61 74 29 0a 20 -vars itemdat).
0e90: 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 (for-each (lamb
0ea0: 64 61 20 28 69 74 65 6d 29 0a 09 20 20 20 20 20 da (item)..
0eb0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 (debug:print 2
0ec0: 22 73 65 74 65 6e 76 20 22 20 28 63 61 72 20 69 "setenv " (car i
0ed0: 74 65 6d 29 20 22 20 22 20 28 63 61 64 72 20 69 tem) " " (cadr i
0ee0: 74 65 6d 29 29 0a 09 20 20 20 20 20 20 28 73 65 tem)).. (se
0ef0: 74 65 6e 76 20 28 63 61 72 20 69 74 65 6d 29 20 tenv (car item)
0f00: 28 63 61 64 72 20 69 74 65 6d 29 29 29 0a 09 20 (cadr item)))..
0f10: 20 20 20 69 74 65 6d 64 61 74 29 29 0a 0a 28 64 itemdat))..(d
0f20: 65 66 69 6e 65 20 2a 6c 61 73 74 2d 6e 75 6d 2d efine *last-num-
0f30: 72 75 6e 6e 69 6e 67 2d 74 65 73 74 73 2a 20 30 running-tests* 0
0f40: 29 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a ).(define (runs:
0f50: 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 can-run-more-tes
0f60: 74 73 20 64 62 20 74 65 73 74 2d 72 65 63 6f 72 ts db test-recor
0f70: 64 29 0a 20 20 28 6c 65 74 2a 20 28 28 74 63 6f d). (let* ((tco
0f80: 6e 66 69 67 20 20 20 20 20 20 20 20 20 20 20 20 nfig
0f90: 20 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 (tests:test
0fa0: 71 75 65 75 65 2d 67 65 74 2d 74 65 73 74 63 6f queue-get-testco
0fb0: 6e 66 69 67 20 74 65 73 74 2d 72 65 63 6f 72 64 nfig test-record
0fc0: 29 29 0a 09 20 28 6a 6f 62 67 72 6f 75 70 20 20 )).. (jobgroup
0fd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c
0fe0: 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 74 63 6f onfig-lookup tco
0ff0: 6e 66 69 67 20 22 72 65 71 75 69 72 65 6d 65 6e nfig "requiremen
1000: 74 73 22 20 22 6a 6f 62 67 72 6f 75 70 22 29 29 ts" "jobgroup"))
1010: 0a 09 20 28 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 .. (num-running
1020: 20 20 20 20 20 20 20 20 20 20 20 20 28 64 62 3a (db:
1030: 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d get-count-tests-
1040: 72 75 6e 6e 69 6e 67 20 64 62 29 29 0a 09 20 28 running db)).. (
1050: 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a num-running-in-j
1060: 6f 62 67 72 6f 75 70 20 28 64 62 3a 67 65 74 2d obgroup (db:get-
1070: 63 6f 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e 6e count-tests-runn
1080: 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 ing-in-jobgroup
1090: 64 62 20 6a 6f 62 67 72 6f 75 70 29 29 0a 09 20 db jobgroup))..
10a0: 28 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d (max-concurrent-
10b0: 6a 6f 62 73 20 20 20 20 20 28 6c 65 74 20 28 28 jobs (let ((
10c0: 6d 63 6a 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b mcj (config-look
10d0: 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 up *configdat* "
10e0: 73 65 74 75 70 22 20 20 20 20 20 22 6d 61 78 5f setup" "max_
10f0: 63 6f 6e 63 75 72 72 65 6e 74 5f 6a 6f 62 73 22 concurrent_jobs"
1100: 29 29 29 0a 09 09 09 09 20 20 20 20 28 69 66 20 )))..... (if
1110: 28 61 6e 64 20 6d 63 6a 20 28 73 74 72 69 6e 67 (and mcj (string
1120: 2d 3e 6e 75 6d 62 65 72 20 6d 63 6a 29 29 0a 09 ->number mcj))..
1130: 09 09 09 09 28 73 74 72 69 6e 67 2d 3e 6e 75 6d ....(string->num
1140: 62 65 72 20 6d 63 6a 29 0a 09 09 09 09 09 23 66 ber mcj)......#f
1150: 29 29 29 0a 09 20 28 6a 6f 62 2d 67 72 6f 75 70 ))).. (job-group
1160: 2d 6c 69 6d 69 74 20 20 20 20 20 20 20 20 20 28 -limit (
1170: 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 2a 63 config-lookup *c
1180: 6f 6e 66 69 67 64 61 74 2a 20 22 6a 6f 62 67 72 onfigdat* "jobgr
1190: 6f 75 70 73 22 20 6a 6f 62 67 72 6f 75 70 29 29 oups" jobgroup))
11a0: 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 ). (if (not (
11b0: 65 71 3f 20 2a 6c 61 73 74 2d 6e 75 6d 2d 72 75 eq? *last-num-ru
11c0: 6e 6e 69 6e 67 2d 74 65 73 74 73 2a 20 6e 75 6d nning-tests* num
11d0: 2d 72 75 6e 6e 69 6e 67 29 29 0a 09 28 62 65 67 -running))..(beg
11e0: 69 6e 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 in.. (debug:pri
11f0: 6e 74 20 32 20 22 6d 61 78 2d 63 6f 6e 63 75 72 nt 2 "max-concur
1200: 72 65 6e 74 2d 6a 6f 62 73 3a 20 22 20 6d 61 78 rent-jobs: " max
1210: 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 -concurrent-jobs
1220: 20 22 2c 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 3a ", num-running:
1230: 20 22 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 29 0a " num-running).
1240: 09 20 20 28 73 65 74 21 20 2a 6c 61 73 74 2d 6e . (set! *last-n
1250: 75 6d 2d 72 75 6e 6e 69 6e 67 2d 74 65 73 74 73 um-running-tests
1260: 2a 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 29 29 29 * num-running)))
1270: 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 65 . (if (not (e
1280: 71 3f 20 30 20 2a 67 6c 6f 62 61 6c 65 78 69 74 q? 0 *globalexit
1290: 73 74 61 74 75 73 2a 29 29 0a 09 28 6c 69 73 74 status*))..(list
12a0: 20 23 66 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 #f num-running
12b0: 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a num-running-in-j
12c0: 6f 62 67 72 6f 75 70 20 6d 61 78 2d 63 6f 6e 63 obgroup max-conc
12d0: 75 72 72 65 6e 74 2d 6a 6f 62 73 20 6a 6f 62 2d urrent-jobs job-
12e0: 67 72 6f 75 70 2d 6c 69 6d 69 74 29 0a 09 28 6c group-limit)..(l
12f0: 65 74 20 28 28 63 61 6e 2d 6e 6f 74 2d 72 75 6e et ((can-not-run
1300: 2d 6d 6f 72 65 20 28 63 6f 6e 64 0a 09 09 09 09 -more (cond.....
1310: 20 3b 3b 20 69 66 20 6d 61 78 2d 63 6f 6e 63 75 ;; if max-concu
1320: 72 72 65 6e 74 2d 6a 6f 62 73 20 69 73 20 73 65 rrent-jobs is se
1330: 74 20 61 6e 64 20 74 68 65 20 6e 75 6d 62 65 72 t and the number
1340: 20 72 75 6e 6e 69 6e 67 20 69 73 20 67 72 65 61 running is grea
1350: 74 65 72 20 0a 09 09 09 09 20 3b 3b 20 74 68 61 ter ..... ;; tha
1360: 6e 20 69 74 20 74 68 61 6e 20 63 61 6e 6e 6f 74 n it than cannot
1370: 20 72 75 6e 20 6d 6f 72 65 20 6a 6f 62 73 0a 09 run more jobs..
1380: 09 09 09 20 28 28 61 6e 64 20 6d 61 78 2d 63 6f ... ((and max-co
1390: 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 20 28 3e ncurrent-jobs (>
13a0: 3d 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 6d 61 = num-running ma
13b0: 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 x-concurrent-job
13c0: 73 29 29 0a 09 09 09 09 20 20 28 64 65 62 75 67 s))..... (debug
13d0: 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e :print 0 "WARNIN
13e0: 47 3a 20 4d 61 78 20 72 75 6e 6e 69 6e 67 20 6a G: Max running j
13f0: 6f 62 73 20 65 78 63 65 65 64 65 64 2c 20 63 75 obs exceeded, cu
1400: 72 72 65 6e 74 20 6e 75 6d 62 65 72 20 72 75 6e rrent number run
1410: 6e 69 6e 67 3a 20 22 20 6e 75 6d 2d 72 75 6e 6e ning: " num-runn
1420: 69 6e 67 20 0a 09 09 09 09 09 20 20 20 20 20 20 ing ......
1430: 20 22 2c 20 6d 61 78 5f 63 6f 6e 63 75 72 72 65 ", max_concurre
1440: 6e 74 5f 6a 6f 62 73 3a 20 22 20 6d 61 78 2d 63 nt_jobs: " max-c
1450: 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 29 0a oncurrent-jobs).
1460: 09 09 09 09 20 20 23 74 29 0a 09 09 09 09 20 3b .... #t)..... ;
1470: 3b 20 69 66 20 6a 6f 62 2d 67 72 6f 75 70 2d 6c ; if job-group-l
1480: 69 6d 69 74 20 69 73 20 73 65 74 20 61 6e 64 20 imit is set and
1490: 6e 75 6d 62 65 72 20 6f 66 20 6a 6f 62 73 20 69 number of jobs i
14a0: 6e 20 74 68 65 20 67 72 6f 75 70 20 69 73 20 67 n the group is g
14b0: 72 65 61 74 65 72 0a 09 09 09 09 20 3b 3b 20 74 reater..... ;; t
14c0: 68 61 6e 20 74 68 65 20 6c 69 6d 69 74 20 74 68 han the limit th
14d0: 65 6e 20 63 61 6e 6e 6f 74 20 72 75 6e 20 6d 6f en cannot run mo
14e0: 72 65 20 6a 6f 62 73 20 6f 66 20 74 68 69 73 20 re jobs of this
14f0: 6b 69 6e 64 0a 09 09 09 09 20 28 28 61 6e 64 20 kind..... ((and
1500: 6a 6f 62 2d 67 72 6f 75 70 2d 6c 69 6d 69 74 0a job-group-limit.
1510: 09 09 09 09 20 20 20 20 20 20 20 28 3e 3d 20 6e .... (>= n
1520: 75 6d 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f um-running-in-jo
1530: 62 67 72 6f 75 70 20 6a 6f 62 2d 67 72 6f 75 70 bgroup job-group
1540: 2d 6c 69 6d 69 74 29 29 0a 09 09 09 09 20 20 28 -limit))..... (
1550: 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 57 debug:print 1 "W
1560: 41 52 4e 49 4e 47 3a 20 6e 75 6d 62 65 72 20 6f ARNING: number o
1570: 66 20 6a 6f 62 73 20 22 20 6e 75 6d 2d 72 75 6e f jobs " num-run
1580: 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 ning-in-jobgroup
1590: 20 0a 09 09 09 09 09 20 20 20 20 20 20 20 22 20 ...... "
15a0: 69 6e 20 22 20 6a 6f 62 67 72 6f 75 70 20 22 20 in " jobgroup "
15b0: 65 78 63 65 65 64 65 64 2c 20 77 69 6c 6c 20 6e exceeded, will n
15c0: 6f 74 20 72 75 6e 20 22 20 28 74 65 73 74 73 3a ot run " (tests:
15d0: 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 testqueue-get-te
15e0: 73 74 6e 61 6d 65 20 74 65 73 74 2d 72 65 63 6f stname test-reco
15f0: 72 64 29 29 0a 09 09 09 09 20 20 23 74 29 0a 09 rd))..... #t)..
1600: 09 09 09 20 28 65 6c 73 65 20 23 66 29 29 29 29 ... (else #f))))
1610: 0a 09 20 20 28 6c 69 73 74 20 28 6e 6f 74 20 63 .. (list (not c
1620: 61 6e 2d 6e 6f 74 2d 72 75 6e 2d 6d 6f 72 65 29 an-not-run-more)
1630: 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 6e 75 6d num-running num
1640: 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 -running-in-jobg
1650: 72 6f 75 70 20 6d 61 78 2d 63 6f 6e 63 75 72 72 roup max-concurr
1660: 65 6e 74 2d 6a 6f 62 73 20 6a 6f 62 2d 67 72 6f ent-jobs job-gro
1670: 75 70 2d 6c 69 6d 69 74 29 29 29 29 29 0a 0a 3b up-limit)))))..;
1680: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
1690: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
16a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
16b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
16c0: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4e 65 77 20 6d =======.;; New m
16d0: 65 74 68 6f 64 6f 6c 6f 67 79 2e 20 54 68 65 73 ethodology. Thes
16e0: 65 20 72 6f 75 74 69 6e 65 73 20 77 69 6c 6c 20 e routines will
16f0: 72 65 70 6c 61 63 65 20 74 68 65 20 61 62 6f 76 replace the abov
1700: 65 20 69 6e 20 74 69 6d 65 2e 20 46 6f 72 0a 3b e in time. For.;
1710: 3b 20 6e 6f 77 20 74 68 65 20 63 6f 64 65 20 69 ; now the code i
1720: 73 20 64 75 70 6c 69 63 61 74 65 64 2e 20 54 68 s duplicated. Th
1730: 69 73 20 73 74 75 66 66 20 69 73 20 69 6e 69 74 is stuff is init
1740: 69 61 6c 6c 79 20 75 73 65 64 20 69 6e 20 74 68 ially used in th
1750: 65 20 6d 6f 6e 69 74 6f 72 0a 3b 3b 20 62 61 73 e monitor.;; bas
1760: 65 64 20 63 6f 64 65 2e 0a 3b 3b 3d 3d 3d 3d 3d ed code..;;=====
1770: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1780: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1790: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
17a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
17b0: 3d 0a 0a 3b 3b 20 72 65 67 69 73 74 65 72 20 61 =..;; register a
17c0: 20 74 65 73 74 20 72 75 6e 20 77 69 74 68 20 74 test run with t
17d0: 68 65 20 64 62 0a 28 64 65 66 69 6e 65 20 28 72 he db.(define (r
17e0: 75 6e 73 3a 72 65 67 69 73 74 65 72 2d 72 75 6e uns:register-run
17f0: 20 64 62 20 6b 65 79 73 20 6b 65 79 76 61 6c 6c db keys keyvall
1800: 73 74 20 72 75 6e 6e 61 6d 65 20 73 74 61 74 65 st runname state
1810: 20 73 74 61 74 75 73 20 75 73 65 72 29 0a 20 20 status user).
1820: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 33 20 22 (debug:print 3 "
1830: 72 75 6e 73 3a 72 65 67 69 73 74 65 72 2d 72 75 runs:register-ru
1840: 6e 2c 20 6b 65 79 73 3a 20 22 20 6b 65 79 73 20 n, keys: " keys
1850: 22 20 6b 65 79 76 61 6c 6c 73 74 3a 20 22 20 6b " keyvallst: " k
1860: 65 79 76 61 6c 6c 73 74 20 22 20 72 75 6e 6e 61 eyvallst " runna
1870: 6d 65 3a 20 22 20 72 75 6e 6e 61 6d 65 20 22 20 me: " runname "
1880: 73 74 61 74 65 3a 20 22 20 73 74 61 74 65 20 22 state: " state "
1890: 20 73 74 61 74 75 73 3a 20 22 20 73 74 61 74 75 status: " statu
18a0: 73 20 22 20 75 73 65 72 3a 20 22 20 75 73 65 72 s " user: " user
18b0: 29 0a 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 73 ). (let* ((keys
18c0: 74 72 20 20 20 20 28 6b 65 79 73 2d 3e 6b 65 79 tr (keys->key
18d0: 73 74 72 20 6b 65 79 73 29 29 0a 09 20 28 63 6f str keys)).. (co
18e0: 6d 6d 61 20 20 20 20 20 28 69 66 20 28 3e 20 28 mma (if (> (
18f0: 6c 65 6e 67 74 68 20 6b 65 79 73 29 20 30 29 20 length keys) 0)
1900: 22 2c 22 20 22 22 29 29 0a 09 20 28 61 6e 64 73 "," "")).. (ands
1910: 74 72 20 20 20 20 28 69 66 20 28 3e 20 28 6c 65 tr (if (> (le
1920: 6e 67 74 68 20 6b 65 79 73 29 20 30 29 20 22 20 ngth keys) 0) "
1930: 41 4e 44 20 22 20 22 22 29 29 0a 09 20 28 76 61 AND " "")).. (va
1940: 6c 73 6c 6f 74 73 20 20 28 6b 65 79 73 2d 3e 76 lslots (keys->v
1950: 61 6c 73 6c 6f 74 73 20 6b 65 79 73 29 29 20 3b alslots keys)) ;
1960: 3b 20 3f 2c 3f 2c 3f 20 2e 2e 2e 0a 09 20 28 6b ; ?,?,? ..... (k
1970: 65 79 76 61 6c 73 20 20 20 28 6d 61 70 20 63 61 eyvals (map ca
1980: 64 72 20 6b 65 79 76 61 6c 6c 73 74 29 29 0a 09 dr keyvallst))..
1990: 20 28 61 6c 6c 76 61 6c 73 20 20 20 28 61 70 70 (allvals (app
19a0: 65 6e 64 20 28 6c 69 73 74 20 72 75 6e 6e 61 6d end (list runnam
19b0: 65 20 73 74 61 74 65 20 73 74 61 74 75 73 20 75 e state status u
19c0: 73 65 72 29 20 6b 65 79 76 61 6c 73 29 29 0a 09 ser) keyvals))..
19d0: 20 28 71 72 79 76 61 6c 73 20 20 20 28 61 70 70 (qryvals (app
19e0: 65 6e 64 20 28 6c 69 73 74 20 72 75 6e 6e 61 6d end (list runnam
19f0: 65 29 20 6b 65 79 76 61 6c 73 29 29 0a 09 20 28 e) keyvals)).. (
1a00: 6b 65 79 3d 3f 73 74 72 20 20 28 73 74 72 69 6e key=?str (strin
1a10: 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 6d g-intersperse (m
1a20: 61 70 20 28 6c 61 6d 62 64 61 20 28 6b 29 28 63 ap (lambda (k)(c
1a30: 6f 6e 63 20 28 6b 65 79 3a 67 65 74 2d 66 69 65 onc (key:get-fie
1a40: 6c 64 6e 61 6d 65 20 6b 29 20 22 3d 3f 22 29 29 ldname k) "=?"))
1a50: 20 6b 65 79 73 29 20 22 20 41 4e 44 20 22 29 29 keys) " AND "))
1a60: 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 ). (debug:pri
1a70: 6e 74 20 33 20 22 6b 65 79 73 3a 20 22 20 6b 65 nt 3 "keys: " ke
1a80: 79 73 20 22 20 61 6c 6c 76 61 6c 73 3a 20 22 20 ys " allvals: "
1a90: 61 6c 6c 76 61 6c 73 20 22 20 6b 65 79 76 61 6c allvals " keyval
1aa0: 73 3a 20 22 20 6b 65 79 76 61 6c 73 29 0a 20 20 s: " keyvals).
1ab0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 (debug:print 2
1ac0: 20 22 4e 4f 54 45 3a 20 75 73 69 6e 67 20 74 61 "NOTE: using ta
1ad0: 72 67 65 74 20 22 20 28 73 74 72 69 6e 67 2d 69 rget " (string-i
1ae0: 6e 74 65 72 73 70 65 72 73 65 20 6b 65 79 76 61 ntersperse keyva
1af0: 6c 73 20 22 2f 22 29 20 22 20 66 6f 72 20 74 68 ls "/") " for th
1b00: 69 73 20 72 75 6e 22 29 0a 20 20 20 20 28 69 66 is run"). (if
1b10: 20 28 61 6e 64 20 72 75 6e 6e 61 6d 65 20 28 6e (and runname (n
1b20: 75 6c 6c 3f 20 28 66 69 6c 74 65 72 20 28 6c 61 ull? (filter (la
1b30: 6d 62 64 61 20 28 78 29 28 6e 6f 74 20 78 29 29 mbda (x)(not x))
1b40: 20 6b 65 79 76 61 6c 73 29 29 29 20 3b 3b 20 74 keyvals))) ;; t
1b50: 68 65 72 65 20 6d 75 73 74 20 62 65 20 61 20 62 here must be a b
1b60: 65 74 74 65 72 20 77 61 79 20 74 6f 20 22 61 70 etter way to "ap
1b70: 70 6c 79 20 61 6e 64 22 0a 09 28 6c 65 74 20 28 ply and"..(let (
1b80: 28 72 65 73 20 23 66 29 29 0a 09 20 20 28 61 70 (res #f)).. (ap
1b90: 70 6c 79 20 73 71 6c 69 74 65 33 3a 65 78 65 63 ply sqlite3:exec
1ba0: 75 74 65 20 64 62 20 28 63 6f 6e 63 20 22 49 4e ute db (conc "IN
1bb0: 53 45 52 54 20 4f 52 20 49 47 4e 4f 52 45 20 49 SERT OR IGNORE I
1bc0: 4e 54 4f 20 72 75 6e 73 20 28 72 75 6e 6e 61 6d NTO runs (runnam
1bd0: 65 2c 73 74 61 74 65 2c 73 74 61 74 75 73 2c 6f e,state,status,o
1be0: 77 6e 65 72 2c 65 76 65 6e 74 5f 74 69 6d 65 22 wner,event_time"
1bf0: 20 63 6f 6d 6d 61 20 6b 65 79 73 74 72 20 22 29 comma keystr ")
1c00: 20 56 41 4c 55 45 53 20 28 3f 2c 3f 2c 3f 2c 3f VALUES (?,?,?,?
1c10: 2c 73 74 72 66 74 69 6d 65 28 27 25 73 27 2c 27 ,strftime('%s','
1c20: 6e 6f 77 27 29 22 20 63 6f 6d 6d 61 20 76 61 6c now')" comma val
1c30: 73 6c 6f 74 73 20 22 29 3b 22 29 0a 09 09 20 61 slots ");")... a
1c40: 6c 6c 76 61 6c 73 29 0a 09 20 20 28 61 70 70 6c llvals).. (appl
1c50: 79 20 73 71 6c 69 74 65 33 3a 66 6f 72 2d 65 61 y sqlite3:for-ea
1c60: 63 68 2d 72 6f 77 20 0a 09 20 20 20 28 6c 61 6d ch-row .. (lam
1c70: 62 64 61 20 28 69 64 29 0a 09 20 20 20 20 20 28 bda (id).. (
1c80: 73 65 74 21 20 72 65 73 20 69 64 29 29 0a 09 20 set! res id))..
1c90: 20 20 64 62 0a 09 20 20 20 28 6c 65 74 20 28 28 db.. (let ((
1ca0: 71 72 79 20 28 63 6f 6e 63 20 22 53 45 4c 45 43 qry (conc "SELEC
1cb0: 54 20 69 64 20 46 52 4f 4d 20 72 75 6e 73 20 57 T id FROM runs W
1cc0: 48 45 52 45 20 28 72 75 6e 6e 61 6d 65 3d 3f 20 HERE (runname=?
1cd0: 22 20 61 6e 64 73 74 72 20 6b 65 79 3d 3f 73 74 " andstr key=?st
1ce0: 72 20 22 29 3b 22 29 29 29 0a 09 20 20 20 20 20 r ");")))..
1cf0: 3b 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 ;(debug:print 4
1d00: 22 71 72 79 3a 20 22 20 71 72 79 29 20 0a 09 20 "qry: " qry) ..
1d10: 20 20 20 20 71 72 79 29 0a 09 20 20 20 71 72 79 qry).. qry
1d20: 76 61 6c 73 29 0a 09 20 20 28 73 71 6c 69 74 65 vals).. (sqlite
1d30: 33 3a 65 78 65 63 75 74 65 20 64 62 20 22 55 50 3:execute db "UP
1d40: 44 41 54 45 20 72 75 6e 73 20 53 45 54 20 73 74 DATE runs SET st
1d50: 61 74 65 3d 3f 2c 73 74 61 74 75 73 3d 3f 20 57 ate=?,status=? W
1d60: 48 45 52 45 20 69 64 3d 3f 3b 22 20 73 74 61 74 HERE id=?;" stat
1d70: 65 20 73 74 61 74 75 73 20 72 65 73 29 0a 09 20 e status res)..
1d80: 20 72 65 73 29 20 0a 09 28 62 65 67 69 6e 0a 09 res) ..(begin..
1d90: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
1da0: 20 22 45 52 52 4f 52 3a 20 43 61 6c 6c 65 64 20 "ERROR: Called
1db0: 77 69 74 68 6f 75 74 20 61 6c 6c 20 6e 65 63 65 without all nece
1dc0: 73 73 61 72 79 20 6b 65 79 73 22 29 0a 09 20 20 ssary keys")..
1dd0: 23 66 29 29 29 29 0a 0a 3b 3b 20 54 68 69 73 20 #f))))..;; This
1de0: 69 73 20 61 20 64 75 70 6c 69 63 61 74 65 20 6f is a duplicate o
1df0: 66 20 72 75 6e 2d 74 65 73 74 73 20 28 77 68 69 f run-tests (whi
1e00: 63 68 20 68 61 73 20 62 65 65 6e 20 64 65 70 72 ch has been depr
1e10: 65 63 61 74 65 64 29 2e 20 55 73 65 20 74 68 69 ecated). Use thi
1e20: 73 20 6f 6e 65 20 69 6e 73 74 65 61 64 20 6f 66 s one instead of
1e30: 20 72 75 6e 20 74 65 73 74 73 2e 0a 3b 3b 20 6b run tests..;; k
1e40: 65 79 76 61 6c 73 0a 28 64 65 66 69 6e 65 20 28 eyvals.(define (
1e50: 72 75 6e 73 3a 72 75 6e 2d 74 65 73 74 73 20 74 runs:run-tests t
1e60: 61 72 67 65 74 20 72 75 6e 6e 61 6d 65 20 74 65 arget runname te
1e70: 73 74 2d 70 61 74 74 73 20 75 73 65 72 20 66 6c st-patts user fl
1e80: 61 67 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 ags). (let* ((d
1e90: 62 20 20 20 20 20 20 20 20 20 20 23 66 29 0a 09 b #f)..
1ea0: 20 28 6b 65 79 73 20 20 20 20 20 20 20 20 28 6f (keys (o
1eb0: 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 pen-run-close db
1ec0: 3a 67 65 74 2d 6b 65 79 73 20 64 62 29 29 0a 09 :get-keys db))..
1ed0: 20 28 6b 65 79 76 61 6c 6c 73 74 20 20 20 28 6b (keyvallst (k
1ee0: 65 79 73 3a 74 61 72 67 65 74 2d 3e 6b 65 79 76 eys:target->keyv
1ef0: 61 6c 20 6b 65 79 73 20 74 61 72 67 65 74 29 29 al keys target))
1f00: 0a 09 20 28 72 75 6e 2d 69 64 20 20 20 20 20 20 .. (run-id
1f10: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 (open-run-close
1f20: 72 75 6e 73 3a 72 65 67 69 73 74 65 72 2d 72 75 runs:register-ru
1f30: 6e 20 64 62 20 6b 65 79 73 20 6b 65 79 76 61 6c n db keys keyval
1f40: 6c 73 74 20 72 75 6e 6e 61 6d 65 20 22 6e 65 77 lst runname "new
1f50: 22 20 22 6e 2f 61 22 20 75 73 65 72 29 29 20 20 " "n/a" user))
1f60: 3b 3b 20 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 ;; test-name)))
1f70: 0a 09 20 28 64 65 66 65 72 72 65 64 20 20 20 20 .. (deferred
1f80: 27 28 29 29 20 3b 3b 20 64 65 6c 61 79 20 72 75 '()) ;; delay ru
1f90: 6e 6e 69 6e 67 20 74 68 65 73 65 20 73 69 6e 63 nning these sinc
1fa0: 65 20 74 68 65 79 20 68 61 76 65 20 61 20 77 61 e they have a wa
1fb0: 69 74 6f 6e 20 63 6c 61 75 73 65 0a 09 20 3b 3b iton clause.. ;;
1fc0: 20 6b 65 65 70 67 6f 69 6e 67 20 69 73 20 74 68 keepgoing is th
1fd0: 65 20 64 65 66 61 63 74 6f 20 6d 6f 64 61 6c 69 e defacto modali
1fe0: 74 79 20 6e 6f 77 2c 20 77 69 6c 6c 20 61 64 64 ty now, will add
1ff0: 20 68 69 74 2d 6e 2d 72 75 6e 20 61 20 62 69 74 hit-n-run a bit
2000: 20 6c 61 74 65 72 0a 09 20 3b 3b 20 28 6b 65 65 later.. ;; (kee
2010: 70 67 6f 69 6e 67 20 20 20 28 68 61 73 68 2d 74 pgoing (hash-t
2020: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
2030: 20 66 6c 61 67 73 20 22 2d 6b 65 65 70 67 6f 69 flags "-keepgoi
2040: 6e 67 22 20 23 66 29 29 0a 09 20 28 74 65 73 74 ng" #f)).. (test
2050: 2d 6e 61 6d 65 73 20 20 27 28 29 29 0a 09 20 28 -names '()).. (
2060: 72 75 6e 63 6f 6e 66 69 67 66 20 20 20 28 63 6f runconfigf (co
2070: 6e 63 20 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f nc *toppath* "/
2080: 72 75 6e 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 69 runconfigs.confi
2090: 67 22 29 29 0a 09 20 28 72 65 71 75 69 72 65 64 g")).. (required
20a0: 2d 74 65 73 74 73 20 27 28 29 29 0a 09 20 28 74 -tests '()).. (t
20b0: 65 73 74 2d 72 65 63 6f 72 64 73 20 28 6d 61 6b est-records (mak
20c0: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 0a e-hash-table))).
20d0: 0a 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 . (open-run-c
20e0: 6c 6f 73 65 20 73 65 74 2d 6d 65 67 61 74 65 73 lose set-megates
20f0: 74 2d 65 6e 76 2d 76 61 72 73 20 64 62 20 72 75 t-env-vars db ru
2100: 6e 2d 69 64 29 20 3b 3b 20 74 68 65 73 65 20 6d n-id) ;; these m
2110: 61 79 20 62 65 20 6e 65 65 64 65 64 20 62 79 20 ay be needed by
2120: 74 68 65 20 6c 61 75 6e 63 68 69 6e 67 20 70 72 the launching pr
2130: 6f 63 65 73 73 0a 0a 20 20 20 20 28 69 66 20 28 ocess.. (if (
2140: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 72 75 6e file-exists? run
2150: 63 6f 6e 66 69 67 66 29 0a 09 28 6f 70 65 6e 2d configf)..(open-
2160: 72 75 6e 2d 63 6c 6f 73 65 20 73 65 74 75 70 2d run-close setup-
2170: 65 6e 76 2d 64 65 66 61 75 6c 74 73 20 64 62 20 env-defaults db
2180: 72 75 6e 63 6f 6e 66 69 67 66 20 72 75 6e 2d 69 runconfigf run-i
2190: 64 20 2a 61 6c 72 65 61 64 79 2d 73 65 65 6e 2d d *already-seen-
21a0: 72 75 6e 63 6f 6e 66 69 67 2d 69 6e 66 6f 2a 20 runconfig-info*
21b0: 22 70 72 65 2d 6c 61 75 6e 63 68 2d 65 6e 76 2d "pre-launch-env-
21c0: 76 61 72 73 22 29 0a 09 28 64 65 62 75 67 3a 70 vars")..(debug:p
21d0: 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a rint 0 "WARNING:
21e0: 20 59 6f 75 20 64 6f 20 6e 6f 74 20 68 61 76 65 You do not have
21f0: 20 61 20 72 75 6e 20 63 6f 6e 66 69 67 20 66 69 a run config fi
2200: 6c 65 3a 20 22 20 72 75 6e 63 6f 6e 66 69 67 66 le: " runconfigf
2210: 29 29 0a 20 20 20 20 0a 20 20 20 20 3b 3b 20 6c )). . ;; l
2220: 6f 6f 6b 20 75 70 20 61 6c 6c 20 74 65 73 74 73 ook up all tests
2230: 20 6d 61 74 63 68 69 6e 67 20 74 68 65 20 63 6f matching the co
2240: 6d 6d 61 20 73 65 70 61 72 61 74 65 64 20 6c 69 mma separated li
2250: 73 74 20 6f 66 20 67 6c 6f 62 73 20 69 6e 0a 20 st of globs in.
2260: 20 20 20 3b 3b 20 74 65 73 74 2d 70 61 74 74 73 ;; test-patts
2270: 20 28 75 73 69 6e 67 20 25 20 61 73 20 77 69 6c (using % as wil
2280: 64 63 61 72 64 29 0a 0a 20 20 20 20 28 73 65 74 dcard).. (set
2290: 21 20 74 65 73 74 2d 6e 61 6d 65 73 20 28 74 65 ! test-names (te
22a0: 73 74 73 3a 67 65 74 2d 76 61 6c 69 64 2d 74 65 sts:get-valid-te
22b0: 73 74 73 20 2a 74 6f 70 70 61 74 68 2a 20 74 65 sts *toppath* te
22c0: 73 74 2d 70 61 74 74 73 20 74 65 73 74 2d 6e 61 st-patts test-na
22d0: 6d 65 73 3a 20 74 65 73 74 2d 6e 61 6d 65 73 29 mes: test-names)
22e0: 29 0a 20 20 20 20 28 73 65 74 21 20 74 65 73 74 ). (set! test
22f0: 2d 6e 61 6d 65 73 20 28 64 65 6c 65 74 65 2d 64 -names (delete-d
2300: 75 70 6c 69 63 61 74 65 73 20 74 65 73 74 2d 6e uplicates test-n
2310: 61 6d 65 73 29 29 0a 0a 20 20 20 20 28 64 65 62 ames)).. (deb
2320: 75 67 3a 70 72 69 6e 74 20 30 20 22 49 4e 46 4f ug:print 0 "INFO
2330: 3a 20 74 65 73 74 20 6e 61 6d 65 73 20 22 20 74 : test names " t
2340: 65 73 74 2d 6e 61 6d 65 73 29 0a 0a 20 20 20 20 est-names)..
2350: 3b 3b 20 6f 6e 20 74 68 65 20 66 69 72 73 74 20 ;; on the first
2360: 70 61 73 73 20 6f 72 20 63 61 6c 6c 20 74 6f 20 pass or call to
2370: 72 75 6e 2d 74 65 73 74 73 20 73 65 74 20 46 41 run-tests set FA
2380: 49 4c 53 20 74 6f 20 4e 4f 54 5f 53 54 41 52 54 ILS to NOT_START
2390: 45 44 20 69 66 0a 20 20 20 20 3b 3b 20 2d 6b 65 ED if. ;; -ke
23a0: 65 70 67 6f 69 6e 67 20 69 73 20 73 70 65 63 69 epgoing is speci
23b0: 66 69 65 64 0a 20 20 20 20 28 69 66 20 28 65 71 fied. (if (eq
23c0: 3f 20 2a 70 61 73 73 6e 75 6d 2a 20 30 29 0a 09 ? *passnum* 0)..
23d0: 28 62 65 67 69 6e 0a 09 20 20 3b 3b 20 68 61 76 (begin.. ;; hav
23e0: 65 20 74 6f 20 64 65 6c 65 74 65 20 74 65 73 74 e to delete test
23f0: 20 72 65 63 6f 72 64 73 20 77 68 65 72 65 20 4e records where N
2400: 4f 54 5f 53 54 41 52 54 45 44 20 73 69 6e 63 65 OT_STARTED since
2410: 20 74 68 65 79 20 63 61 6e 20 63 61 75 73 65 20 they can cause
2420: 2d 6b 65 65 70 67 6f 69 6e 67 20 74 6f 20 0a 09 -keepgoing to ..
2430: 20 20 3b 3b 20 67 65 74 20 73 74 75 63 6b 20 64 ;; get stuck d
2440: 75 65 20 74 6f 20 62 65 63 6f 6d 69 6e 67 20 69 ue to becoming i
2450: 6e 61 63 63 65 73 73 69 62 6c 65 20 66 72 6f 6d naccessible from
2460: 20 61 20 66 61 69 6c 65 64 20 74 65 73 74 2e 20 a failed test.
2470: 49 2e 65 2e 20 69 66 20 74 65 73 74 20 42 20 64 I.e. if test B d
2480: 65 70 65 6e 64 73 20 0a 09 20 20 3b 3b 20 6f 6e epends .. ;; on
2490: 20 74 65 73 74 20 41 20 62 75 74 20 74 65 73 74 test A but test
24a0: 20 42 20 72 65 61 63 68 65 64 20 74 68 65 20 70 B reached the p
24b0: 6f 69 6e 74 20 6f 6e 20 62 65 69 6e 67 20 72 65 oint on being re
24c0: 67 69 73 74 65 72 65 64 20 61 73 20 4e 4f 54 5f gistered as NOT_
24d0: 53 54 41 52 54 45 44 20 61 6e 64 20 74 65 73 74 STARTED and test
24e0: 0a 09 20 20 3b 3b 20 41 20 66 61 69 6c 65 64 20 .. ;; A failed
24f0: 66 6f 72 20 73 6f 6d 65 20 72 65 61 73 6f 6e 20 for some reason
2500: 74 68 65 6e 20 6f 6e 20 72 65 2d 72 75 6e 20 75 then on re-run u
2510: 73 69 6e 67 20 2d 6b 65 65 70 67 6f 69 6e 67 20 sing -keepgoing
2520: 74 68 65 20 72 75 6e 20 63 61 6e 20 6e 65 76 65 the run can neve
2530: 72 20 63 6f 6d 70 6c 65 74 65 2e 0a 09 20 20 28 r complete... (
2540: 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 open-run-close d
2550: 62 3a 64 65 6c 65 74 65 2d 74 65 73 74 73 2d 69 b:delete-tests-i
2560: 6e 2d 73 74 61 74 65 20 64 62 20 72 75 6e 2d 69 n-state db run-i
2570: 64 20 22 4e 4f 54 5f 53 54 41 52 54 45 44 22 29 d "NOT_STARTED")
2580: 0a 09 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c .. (open-run-cl
2590: 6f 73 65 20 64 62 3a 73 65 74 2d 74 65 73 74 73 ose db:set-tests
25a0: 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 64 62 -state-status db
25b0: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
25c0: 65 73 20 23 66 20 22 46 41 49 4c 22 20 22 4e 4f es #f "FAIL" "NO
25d0: 54 5f 53 54 41 52 54 45 44 22 20 22 46 41 49 4c T_STARTED" "FAIL
25e0: 22 29 29 29 0a 0a 20 20 20 20 3b 3b 20 66 72 6f "))).. ;; fro
25f0: 6d 20 68 65 72 65 20 6f 6e 20 6f 75 74 20 74 68 m here on out th
2600: 65 20 64 62 20 77 69 6c 6c 20 62 65 20 6f 70 65 e db will be ope
2610: 6e 65 64 20 61 6e 64 20 63 6c 6f 73 65 64 20 6f ned and closed o
2620: 6e 20 65 76 65 72 79 20 63 61 6c 6c 20 72 75 6e n every call run
2630: 73 3a 72 75 6e 2d 74 65 73 74 73 2d 71 75 65 75 s:run-tests-queu
2640: 65 0a 20 20 20 20 3b 3b 20 28 73 71 6c 69 74 65 e. ;; (sqlite
2650: 33 3a 66 69 6e 61 6c 69 7a 65 21 20 64 62 29 20 3:finalize! db)
2660: 0a 20 20 20 20 3b 3b 20 6e 6f 77 20 61 64 64 20 . ;; now add
2670: 6e 6f 6e 2d 64 69 72 65 63 74 6c 79 20 72 65 66 non-directly ref
2680: 65 72 65 6e 63 65 64 20 64 65 70 65 6e 64 65 6e erenced dependen
2690: 63 69 65 73 20 28 69 2e 65 2e 20 77 61 69 74 6f cies (i.e. waito
26a0: 6e 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 n). (if (not
26b0: 28 6e 75 6c 6c 3f 20 74 65 73 74 2d 6e 61 6d 65 (null? test-name
26c0: 73 29 29 0a 09 28 6c 65 74 20 6c 6f 6f 70 20 28 s))..(let loop (
26d0: 28 68 65 64 20 28 63 61 72 20 74 65 73 74 2d 6e (hed (car test-n
26e0: 61 6d 65 73 29 29 0a 09 09 20 20 20 28 74 61 6c ames))... (tal
26f0: 20 28 63 64 72 20 74 65 73 74 2d 6e 61 6d 65 73 (cdr test-names
2700: 29 29 29 20 20 20 20 20 20 20 20 20 3b 3b 20 27 ))) ;; '
2710: 72 65 74 75 72 6e 2d 70 72 6f 63 73 20 74 65 6c return-procs tel
2720: 6c 73 20 74 68 65 20 63 6f 6e 66 69 67 20 72 65 ls the config re
2730: 61 64 65 72 20 74 6f 20 70 72 65 70 20 72 75 6e ader to prep run
2740: 6e 69 6e 67 20 73 79 73 74 65 6d 20 62 75 74 20 ning system but
2750: 72 65 74 75 72 6e 20 61 20 70 72 6f 63 0a 09 20 return a proc..
2760: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 (debug:print 4
2770: 22 49 4e 46 4f 3a 20 68 65 64 3d 22 20 68 65 64 "INFO: hed=" hed
2780: 20 22 20 61 74 20 74 6f 70 20 6f 66 20 6c 6f 6f " at top of loo
2790: 70 22 29 0a 09 20 20 28 6c 65 74 2a 20 28 28 63 p").. (let* ((c
27a0: 6f 6e 66 69 67 20 20 28 74 65 73 74 73 3a 67 65 onfig (tests:ge
27b0: 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 68 65 64 t-testconfig hed
27c0: 20 27 72 65 74 75 72 6e 2d 70 72 6f 63 73 29 29 'return-procs))
27d0: 0a 09 09 20 28 77 61 69 74 6f 6e 73 20 28 69 66 ... (waitons (if
27e0: 20 63 6f 6e 66 69 67 20 28 73 74 72 69 6e 67 2d config (string-
27f0: 73 70 6c 69 74 20 28 6c 65 74 20 28 28 77 20 28 split (let ((w (
2800: 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 63 6f config-lookup co
2810: 6e 66 69 67 20 22 72 65 71 75 69 72 65 6d 65 6e nfig "requiremen
2820: 74 73 22 20 22 77 61 69 74 6f 6e 22 29 29 29 0a ts" "waiton"))).
2830: 09 09 09 09 09 09 20 20 20 20 20 28 69 66 20 77 ...... (if w
2840: 20 77 20 22 22 29 29 29 0a 09 09 09 20 20 20 20 w "")))....
2850: 20 20 28 62 65 67 69 6e 0a 09 09 09 09 28 64 65 (begin.....(de
2860: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 bug:print 0 "ERR
2870: 4f 52 3a 20 6e 6f 6e 2d 65 78 69 73 74 65 6e 74 OR: non-existent
2880: 20 72 65 71 75 69 72 65 64 20 74 65 73 74 20 5c required test \
2890: 22 22 20 68 65 64 20 22 5c 22 22 29 0a 20 20 20 "" hed "\"").
28a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
28b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
28c0: 20 64 62 20 28 73 71 6c 69 74 65 33 3a 66 69 6e db (sqlite3:fin
28d0: 61 6c 69 7a 65 21 20 64 62 29 29 0a 09 09 09 09 alize! db)).....
28e0: 28 65 78 69 74 20 31 29 29 29 29 29 0a 09 20 20 (exit 1)))))..
28f0: 20 20 3b 3b 20 63 68 65 63 6b 20 66 6f 72 20 68 ;; check for h
2900: 65 64 20 69 6e 20 77 61 69 74 6f 6e 73 20 3d 3e ed in waitons =>
2910: 20 74 68 69 73 20 77 6f 75 6c 64 20 62 65 20 63 this would be c
2920: 69 72 63 75 6c 61 72 2c 20 72 65 6d 6f 76 65 20 ircular, remove
2930: 69 74 20 61 6e 64 20 69 73 73 75 65 20 61 6e 0a it and issue an.
2940: 09 20 20 20 20 3b 3b 20 65 72 72 6f 72 0a 09 20 . ;; error..
2950: 20 20 20 28 69 66 20 28 6d 65 6d 62 65 72 20 68 (if (member h
2960: 65 64 20 77 61 69 74 6f 6e 73 29 0a 09 09 28 62 ed waitons)...(b
2970: 65 67 69 6e 0a 09 09 20 20 28 64 65 62 75 67 3a egin... (debug:
2980: 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 print 0 "ERROR:
2990: 74 65 73 74 20 22 20 68 65 64 20 22 20 68 61 73 test " hed " has
29a0: 20 6c 69 73 74 65 64 20 69 74 73 65 6c 66 20 61 listed itself a
29b0: 73 20 61 20 77 61 69 74 6f 6e 2c 20 70 6c 65 61 s a waiton, plea
29c0: 73 65 20 63 6f 72 72 65 63 74 20 74 68 69 73 21 se correct this!
29d0: 22 29 0a 09 09 20 20 28 73 65 74 21 20 77 61 69 ")... (set! wai
29e0: 74 6f 6e 73 20 28 66 69 6c 74 65 72 20 28 6c 61 tons (filter (la
29f0: 6d 62 64 61 20 28 78 29 28 6e 6f 74 20 28 65 71 mbda (x)(not (eq
2a00: 75 61 6c 3f 20 78 20 68 65 64 29 29 29 20 77 61 ual? x hed))) wa
2a10: 69 74 6f 6e 73 29 29 29 29 0a 09 20 20 20 20 0a itons)))).. .
2a20: 09 20 20 20 20 3b 3b 20 28 69 74 65 6d 73 20 20 . ;; (items
2a30: 20 28 69 74 65 6d 73 3a 67 65 74 2d 69 74 65 6d (items:get-item
2a40: 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 20 63 6f s-from-config co
2a50: 6e 66 69 67 29 29 29 0a 09 20 20 20 20 28 69 66 nfig))).. (if
2a60: 20 28 6e 6f 74 20 28 68 61 73 68 2d 74 61 62 6c (not (hash-tabl
2a70: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 65 e-ref/default te
2a80: 73 74 2d 72 65 63 6f 72 64 73 20 68 65 64 20 23 st-records hed #
2a90: 66 29 29 0a 09 09 28 68 61 73 68 2d 74 61 62 6c f))...(hash-tabl
2aa0: 65 2d 73 65 74 21 20 74 65 73 74 2d 72 65 63 6f e-set! test-reco
2ab0: 72 64 73 0a 09 09 09 09 20 68 65 64 20 28 76 65 rds..... hed (ve
2ac0: 63 74 6f 72 20 68 65 64 20 20 20 20 20 3b 3b 20 ctor hed ;;
2ad0: 30 0a 09 09 09 09 09 20 20 20 20 20 63 6f 6e 66 0...... conf
2ae0: 69 67 20 20 3b 3b 20 31 0a 09 09 09 09 09 20 20 ig ;; 1......
2af0: 20 20 20 77 61 69 74 6f 6e 73 20 3b 3b 20 32 0a waitons ;; 2.
2b00: 09 09 09 09 09 20 20 20 20 20 28 63 6f 6e 66 69 ..... (confi
2b10: 67 2d 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 20 g-lookup config
2b20: 22 72 65 71 75 69 72 65 6d 65 6e 74 73 22 20 22 "requirements" "
2b30: 70 72 69 6f 72 69 74 79 22 29 20 20 20 20 20 3b priority") ;
2b40: 3b 20 70 72 69 6f 72 69 74 79 20 33 0a 09 09 09 ; priority 3....
2b50: 09 09 20 20 20 20 20 28 6c 65 74 20 28 28 69 74 .. (let ((it
2b60: 65 6d 73 20 20 20 20 20 20 28 68 61 73 68 2d 74 ems (hash-t
2b70: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
2b80: 20 63 6f 6e 66 69 67 20 22 69 74 65 6d 73 22 20 config "items"
2b90: 23 66 29 29 20 3b 3b 20 69 74 65 6d 73 20 34 0a #f)) ;; items 4.
2ba0: 09 09 09 09 09 09 20 20 20 28 69 74 65 6d 73 74 ...... (itemst
2bb0: 61 62 6c 65 20 28 68 61 73 68 2d 74 61 62 6c 65 able (hash-table
2bc0: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 63 6f 6e -ref/default con
2bd0: 66 69 67 20 22 69 74 65 6d 73 74 61 62 6c 65 22 fig "itemstable"
2be0: 20 23 66 29 29 29 20 0a 09 09 09 09 09 20 20 20 #f))) ......
2bf0: 20 20 20 20 3b 3b 20 69 66 20 65 69 74 68 65 72 ;; if either
2c00: 20 69 74 65 6d 73 20 6f 72 20 69 74 65 6d 73 20 items or items
2c10: 74 61 62 6c 65 20 69 73 20 61 20 70 72 6f 63 20 table is a proc
2c20: 72 65 74 75 72 6e 20 69 74 20 73 6f 20 74 65 73 return it so tes
2c30: 74 20 72 75 6e 6e 69 6e 67 0a 09 09 09 09 09 20 t running......
2c40: 20 20 20 20 20 20 3b 3b 20 70 72 6f 63 65 73 73 ;; process
2c50: 20 63 61 6e 20 6b 6e 6f 77 20 74 6f 20 63 61 6c can know to cal
2c60: 6c 20 69 74 65 6d 73 3a 67 65 74 2d 69 74 65 6d l items:get-item
2c70: 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 0a 09 09 s-from-config...
2c80: 09 09 09 20 20 20 20 20 20 20 3b 3b 20 69 66 20 ... ;; if
2c90: 65 69 74 68 65 72 20 69 73 20 61 20 6c 69 73 74 either is a list
2ca0: 20 61 6e 64 20 6e 6f 6e 65 20 69 73 20 61 20 70 and none is a p
2cb0: 72 6f 63 20 67 6f 20 61 68 65 61 64 20 61 6e 64 roc go ahead and
2cc0: 20 63 61 6c 6c 20 67 65 74 2d 69 74 65 6d 73 0a call get-items.
2cd0: 09 09 09 09 09 20 20 20 20 20 20 20 3b 3b 20 6f ..... ;; o
2ce0: 74 68 65 72 77 69 73 65 20 72 65 74 75 72 6e 20 therwise return
2cf0: 23 66 20 2d 20 74 68 69 73 20 69 73 20 6e 6f 74 #f - this is not
2d00: 20 61 6e 20 69 74 65 72 61 74 65 64 20 74 65 73 an iterated tes
2d10: 74 0a 09 09 09 09 09 20 20 20 20 20 20 20 28 63 t...... (c
2d20: 6f 6e 64 0a 09 09 09 09 09 09 28 28 70 72 6f 63 ond.......((proc
2d30: 65 64 75 72 65 3f 20 69 74 65 6d 73 29 20 20 20 edure? items)
2d40: 20 20 20 0a 09 09 09 09 09 09 20 28 64 65 62 75 ....... (debu
2d50: 67 3a 70 72 69 6e 74 20 34 20 22 49 4e 46 4f 3a g:print 4 "INFO:
2d60: 20 69 74 65 6d 73 20 69 73 20 61 20 70 72 6f 63 items is a proc
2d70: 65 64 75 72 65 2c 20 77 69 6c 6c 20 63 61 6c 63 edure, will calc
2d80: 20 6c 61 74 65 72 22 29 0a 09 09 09 09 09 09 20 later").......
2d90: 69 74 65 6d 73 29 20 20 20 20 20 20 20 20 20 20 items)
2da0: 20 20 3b 3b 20 63 61 6c 63 20 6c 61 74 65 72 0a ;; calc later.
2db0: 09 09 09 09 09 09 28 28 70 72 6f 63 65 64 75 72 ......((procedur
2dc0: 65 3f 20 69 74 65 6d 73 74 61 62 6c 65 29 0a 09 e? itemstable)..
2dd0: 09 09 09 09 09 20 28 64 65 62 75 67 3a 70 72 69 ..... (debug:pri
2de0: 6e 74 20 34 20 22 49 4e 46 4f 3a 20 69 74 65 6d nt 4 "INFO: item
2df0: 73 74 61 62 6c 65 20 69 73 20 61 20 70 72 6f 63 stable is a proc
2e00: 65 64 75 72 65 2c 20 77 69 6c 6c 20 63 61 6c 63 edure, will calc
2e10: 20 6c 61 74 65 72 22 29 0a 09 09 09 09 09 09 20 later").......
2e20: 69 74 65 6d 73 74 61 62 6c 65 29 20 20 20 20 20 itemstable)
2e30: 20 20 3b 3b 20 63 61 6c 63 20 6c 61 74 65 72 0a ;; calc later.
2e40: 09 09 09 09 09 09 28 28 66 69 6c 74 65 72 20 28 ......((filter (
2e50: 6c 61 6d 62 64 61 20 28 78 29 0a 09 09 09 09 09 lambda (x)......
2e60: 09 09 20 20 20 28 6c 65 74 20 28 28 76 61 6c 20 .. (let ((val
2e70: 28 63 61 72 20 78 29 29 29 0a 09 09 09 09 09 09 (car x))).......
2e80: 09 20 20 20 20 20 28 69 66 20 28 70 72 6f 63 65 . (if (proce
2e90: 64 75 72 65 3f 20 76 61 6c 29 20 76 61 6c 20 23 dure? val) val #
2ea0: 66 29 29 29 0a 09 09 09 09 09 09 09 20 28 61 70 f)))........ (ap
2eb0: 70 65 6e 64 20 28 69 66 20 28 6c 69 73 74 3f 20 pend (if (list?
2ec0: 69 74 65 6d 73 29 20 69 74 65 6d 73 20 27 28 29 items) items '()
2ed0: 29 0a 09 09 09 09 09 09 09 09 20 28 69 66 20 28 )......... (if (
2ee0: 6c 69 73 74 3f 20 69 74 65 6d 73 74 61 62 6c 65 list? itemstable
2ef0: 29 20 69 74 65 6d 73 74 61 62 6c 65 20 27 28 29 ) itemstable '()
2f00: 29 29 29 0a 09 09 09 09 09 09 20 27 68 61 76 65 )))....... 'have
2f10: 2d 70 72 6f 63 65 64 75 72 65 29 0a 09 09 09 09 -procedure).....
2f20: 09 09 28 28 6f 72 20 28 6c 69 73 74 3f 20 69 74 ..((or (list? it
2f30: 65 6d 73 29 28 6c 69 73 74 3f 20 69 74 65 6d 73 ems)(list? items
2f40: 74 61 62 6c 65 29 29 20 3b 3b 20 63 61 6c 63 20 table)) ;; calc
2f50: 6e 6f 77 0a 09 09 09 09 09 09 20 28 64 65 62 75 now....... (debu
2f60: 67 3a 70 72 69 6e 74 20 34 20 22 49 4e 46 4f 3a g:print 4 "INFO:
2f70: 20 69 74 65 6d 73 20 61 6e 64 20 69 74 65 6d 73 items and items
2f80: 74 61 62 6c 65 20 61 72 65 20 6c 69 73 74 73 2c table are lists,
2f90: 20 63 61 6c 63 20 6e 6f 77 5c 6e 22 0a 09 09 09 calc now\n"....
2fa0: 09 09 09 09 20 20 20 20 20 20 22 20 20 20 20 69 .... " i
2fb0: 74 65 6d 73 3a 20 22 20 69 74 65 6d 73 20 22 20 tems: " items "
2fc0: 69 74 65 6d 73 74 61 62 6c 65 3a 20 22 20 69 74 itemstable: " it
2fd0: 65 6d 73 74 61 62 6c 65 29 0a 09 09 09 09 09 09 emstable).......
2fe0: 20 28 69 74 65 6d 73 3a 67 65 74 2d 69 74 65 6d (items:get-item
2ff0: 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 20 63 6f s-from-config co
3000: 6e 66 69 67 29 29 0a 09 09 09 09 09 09 28 65 6c nfig)).......(el
3010: 73 65 20 23 66 29 29 29 20 20 20 20 20 20 20 20 se #f)))
3020: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3030: 20 20 20 3b 3b 20 6e 6f 74 20 69 74 65 72 61 74 ;; not iterat
3040: 65 64 0a 09 09 09 09 09 20 20 20 20 20 23 66 20 ed...... #f
3050: 20 20 20 20 20 3b 3b 20 69 74 65 6d 73 64 61 74 ;; itemsdat
3060: 20 35 0a 09 09 09 09 09 20 20 20 20 20 23 66 20 5...... #f
3070: 20 20 20 20 20 3b 3b 20 73 70 61 72 65 20 2d 20 ;; spare -
3080: 75 73 65 64 20 66 6f 72 20 69 74 65 6d 2d 70 61 used for item-pa
3090: 74 68 0a 09 09 09 09 09 20 20 20 20 20 29 29 29 th...... )))
30a0: 0a 09 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 .. (for-each
30b0: 0a 09 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 .. (lambda (
30c0: 77 61 69 74 6f 6e 29 0a 09 20 20 20 20 20 20 20 waiton)..
30d0: 28 69 66 20 28 61 6e 64 20 77 61 69 74 6f 6e 20 (if (and waiton
30e0: 28 6e 6f 74 20 28 6d 65 6d 62 65 72 20 77 61 69 (not (member wai
30f0: 74 6f 6e 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 ton test-names))
3100: 29 0a 09 09 20 20 20 28 62 65 67 69 6e 0a 09 09 )... (begin...
3110: 20 20 20 20 20 28 73 65 74 21 20 72 65 71 75 69 (set! requi
3120: 72 65 64 2d 74 65 73 74 73 20 28 63 6f 6e 73 20 red-tests (cons
3130: 77 61 69 74 6f 6e 20 72 65 71 75 69 72 65 64 2d waiton required-
3140: 74 65 73 74 73 29 29 0a 09 09 20 20 20 20 20 28 tests))... (
3150: 73 65 74 21 20 74 65 73 74 2d 6e 61 6d 65 73 20 set! test-names
3160: 28 63 6f 6e 73 20 77 61 69 74 6f 6e 20 74 65 73 (cons waiton tes
3170: 74 2d 6e 61 6d 65 73 29 29 29 29 29 20 3b 3b 20 t-names))))) ;;
3180: 77 61 73 20 61 6e 20 61 70 70 65 6e 64 2c 20 6e was an append, n
3190: 6f 77 20 61 20 63 6f 6e 73 0a 09 20 20 20 20 20 ow a cons..
31a0: 77 61 69 74 6f 6e 73 29 0a 09 20 20 20 20 28 6c waitons).. (l
31b0: 65 74 20 28 28 72 65 6d 74 65 73 74 73 20 28 64 et ((remtests (d
31c0: 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 74 65 73 elete-duplicates
31d0: 20 28 61 70 70 65 6e 64 20 77 61 69 74 6f 6e 73 (append waitons
31e0: 20 74 61 6c 29 29 29 29 0a 09 20 20 20 20 20 20 tal))))..
31f0: 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 (if (not (null?
3200: 72 65 6d 74 65 73 74 73 29 29 0a 09 09 20 20 28 remtests))... (
3210: 6c 6f 6f 70 20 28 63 61 72 20 72 65 6d 74 65 73 loop (car remtes
3220: 74 73 29 28 63 64 72 20 72 65 6d 74 65 73 74 73 ts)(cdr remtests
3230: 29 29 29 29 29 29 29 0a 0a 20 20 20 20 28 69 66 ))))))).. (if
3240: 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 71 (not (null? req
3250: 75 69 72 65 64 2d 74 65 73 74 73 29 29 0a 09 28 uired-tests))..(
3260: 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 49 debug:print 1 "I
3270: 4e 46 4f 3a 20 41 64 64 69 6e 67 20 22 20 72 65 NFO: Adding " re
3280: 71 75 69 72 65 64 2d 74 65 73 74 73 20 22 20 74 quired-tests " t
3290: 6f 20 74 68 65 20 72 75 6e 20 71 75 65 75 65 22 o the run queue"
32a0: 29 29 0a 20 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 )). ;; NOTE:
32b0: 74 68 65 73 65 20 61 72 65 20 61 6c 6c 20 70 61 these are all pa
32c0: 72 65 6e 74 20 74 65 73 74 73 2c 20 69 74 65 6d rent tests, item
32d0: 73 20 61 72 65 20 6e 6f 74 20 65 78 70 61 6e 64 s are not expand
32e0: 65 64 20 79 65 74 2e 0a 20 20 20 20 28 64 65 62 ed yet.. (deb
32f0: 75 67 3a 70 72 69 6e 74 20 34 20 22 49 4e 46 4f ug:print 4 "INFO
3300: 3a 20 74 65 73 74 2d 72 65 63 6f 72 64 73 3d 22 : test-records="
3310: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 3e 61 6c (hash-table->al
3320: 69 73 74 20 74 65 73 74 2d 72 65 63 6f 72 64 73 ist test-records
3330: 29 29 0a 20 20 20 20 28 72 75 6e 73 3a 72 75 6e )). (runs:run
3340: 2d 74 65 73 74 73 2d 71 75 65 75 65 20 72 75 6e -tests-queue run
3350: 2d 69 64 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 -id runname test
3360: 2d 72 65 63 6f 72 64 73 20 6b 65 79 76 61 6c 6c -records keyvall
3370: 73 74 20 66 6c 61 67 73 20 74 65 73 74 2d 70 61 st flags test-pa
3380: 74 74 73 29 0a 20 20 20 20 28 64 65 62 75 67 3a tts). (debug:
3390: 70 72 69 6e 74 20 34 20 22 49 4e 46 4f 3a 20 41 print 4 "INFO: A
33a0: 6c 6c 20 64 6f 6e 65 20 62 79 20 68 65 72 65 22 ll done by here"
33b0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 )))..(define (ru
33c0: 6e 73 3a 63 61 6c 63 2d 66 61 69 6c 73 20 70 72 ns:calc-fails pr
33d0: 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 0a 20 ereqs-not-met).
33e0: 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 (filter (lambda
33f0: 20 28 74 65 73 74 29 0a 09 20 20 20 20 28 61 6e (test).. (an
3400: 64 20 28 76 65 63 74 6f 72 3f 20 74 65 73 74 29 d (vector? test)
3410: 20 3b 3b 20 6e 6f 74 20 28 73 74 72 69 6e 67 3f ;; not (string?
3420: 20 74 65 73 74 29 29 0a 09 09 20 28 65 71 75 61 test))... (equa
3430: 6c 3f 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d l? (db:test-get-
3440: 73 74 61 74 65 20 74 65 73 74 29 20 22 43 4f 4d state test) "COM
3450: 50 4c 45 54 45 44 22 29 0a 09 09 20 28 6e 6f 74 PLETED")... (not
3460: 20 28 6d 65 6d 62 65 72 20 28 64 62 3a 74 65 73 (member (db:tes
3470: 74 2d 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 t-get-status tes
3480: 74 29 0a 09 09 09 20 20 20 20 20 20 27 28 22 50 t).... '("P
3490: 41 53 53 22 20 22 57 41 52 4e 22 20 22 43 48 45 ASS" "WARN" "CHE
34a0: 43 4b 22 20 22 57 41 49 56 45 44 22 29 29 29 29 CK" "WAIVED"))))
34b0: 29 0a 09 20 20 70 72 65 72 65 71 73 2d 6e 6f 74 ).. prereqs-not
34c0: 2d 6d 65 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 -met))..(define
34d0: 28 72 75 6e 73 3a 63 61 6c 63 2d 6e 6f 74 2d 63 (runs:calc-not-c
34e0: 6f 6d 70 6c 65 74 65 64 20 70 72 65 72 65 71 73 ompleted prereqs
34f0: 2d 6e 6f 74 2d 6d 65 74 29 0a 20 20 28 66 69 6c -not-met). (fil
3500: 74 65 72 0a 20 20 20 28 6c 61 6d 62 64 61 20 28 ter. (lambda (
3510: 74 29 0a 20 20 20 20 20 28 6f 72 20 28 6e 6f 74 t). (or (not
3520: 20 28 76 65 63 74 6f 72 3f 20 74 29 29 0a 09 20 (vector? t))..
3530: 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 22 43 4f (not (equal? "CO
3540: 4d 50 4c 45 54 45 44 22 20 28 64 62 3a 74 65 73 MPLETED" (db:tes
3550: 74 2d 67 65 74 2d 73 74 61 74 65 20 74 29 29 29 t-get-state t)))
3560: 29 29 0a 20 20 20 70 72 65 72 65 71 73 2d 6e 6f )). prereqs-no
3570: 74 2d 6d 65 74 29 29 0a 0a 28 64 65 66 69 6e 65 t-met))..(define
3580: 20 28 72 75 6e 73 3a 70 72 65 74 74 79 2d 73 74 (runs:pretty-st
3590: 72 69 6e 67 20 6c 73 74 29 0a 20 20 28 6d 61 70 ring lst). (map
35a0: 20 28 6c 61 6d 62 64 61 20 28 74 29 0a 09 20 28 (lambda (t).. (
35b0: 69 66 20 28 6e 6f 74 20 28 76 65 63 74 6f 72 3f if (not (vector?
35c0: 20 74 29 29 0a 09 20 20 20 20 20 28 63 6f 6e 63 t)).. (conc
35d0: 20 74 29 0a 09 20 20 20 20 20 28 63 6f 6e 63 20 t).. (conc
35e0: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 (db:test-get-tes
35f0: 74 6e 61 6d 65 20 74 29 20 22 3a 22 20 28 64 62 tname t) ":" (db
3600: 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 :test-get-state
3610: 74 29 20 22 2f 22 20 28 64 62 3a 74 65 73 74 2d t) "/" (db:test-
3620: 67 65 74 2d 73 74 61 74 75 73 20 74 29 29 29 29 get-status t))))
3630: 0a 20 20 20 20 20 20 20 6c 73 74 29 29 0a 0a 28 . lst))..(
3640: 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 6d 61 6b define (runs:mak
3650: 65 2d 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 e-full-test-name
3660: 20 74 65 73 74 6e 61 6d 65 20 69 74 65 6d 70 61 testname itempa
3670: 74 68 29 0a 20 20 28 69 66 20 28 65 71 75 61 6c th). (if (equal
3680: 3f 20 69 74 65 6d 70 61 74 68 20 22 22 29 20 74 ? itempath "") t
3690: 65 73 74 6e 61 6d 65 20 28 63 6f 6e 63 20 74 65 estname (conc te
36a0: 73 74 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 70 stname "/" itemp
36b0: 61 74 68 29 29 29 0a 0a 3b 3b 20 74 65 73 74 2d ath)))..;; test-
36c0: 72 65 63 6f 72 64 73 20 69 73 20 61 20 68 61 73 records is a has
36d0: 68 20 74 61 62 6c 65 20 74 65 73 74 6e 61 6d 65 h table testname
36e0: 3a 69 74 65 6d 5f 70 61 74 68 20 3d 3e 20 76 65 :item_path => ve
36f0: 63 74 6f 72 20 3c 20 74 65 73 74 6e 61 6d 65 20 ctor < testname
3700: 74 65 73 74 63 6f 6e 66 69 67 20 77 61 69 74 6f testconfig waito
3710: 6e 73 20 70 72 69 6f 72 69 74 79 20 69 74 65 6d ns priority item
3720: 73 2d 69 6e 66 6f 20 2e 2e 2e 20 3e 0a 28 64 65 s-info ... >.(de
3730: 66 69 6e 65 20 28 72 75 6e 73 3a 72 75 6e 2d 74 fine (runs:run-t
3740: 65 73 74 73 2d 71 75 65 75 65 20 72 75 6e 2d 69 ests-queue run-i
3750: 64 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 2d 72 d runname test-r
3760: 65 63 6f 72 64 73 20 6b 65 79 76 61 6c 6c 73 74 ecords keyvallst
3770: 20 66 6c 61 67 73 20 74 65 73 74 2d 70 61 74 74 flags test-patt
3780: 73 29 0a 20 20 20 20 3b 3b 20 41 74 20 74 68 69 s). ;; At thi
3790: 73 20 70 6f 69 6e 74 20 74 68 65 20 6c 69 73 74 s point the list
37a0: 20 6f 66 20 70 61 72 65 6e 74 20 74 65 73 74 73 of parent tests
37b0: 20 69 73 20 65 78 70 61 6e 64 65 64 20 0a 20 20 is expanded .
37c0: 20 20 3b 3b 20 4e 42 2f 2f 20 53 68 6f 75 6c 64 ;; NB// Should
37d0: 20 65 78 70 61 6e 64 20 69 74 65 6d 73 20 68 65 expand items he
37e0: 72 65 20 61 6e 64 20 74 68 65 6e 20 69 6e 73 65 re and then inse
37f0: 72 74 20 69 6e 74 6f 20 74 68 65 20 72 75 6e 20 rt into the run
3800: 71 75 65 75 65 2e 0a 20 20 28 64 65 62 75 67 3a queue.. (debug:
3810: 70 72 69 6e 74 20 35 20 22 74 65 73 74 2d 72 65 print 5 "test-re
3820: 63 6f 72 64 73 3a 20 22 20 74 65 73 74 2d 72 65 cords: " test-re
3830: 63 6f 72 64 73 20 22 2c 20 6b 65 79 76 61 6c 6c cords ", keyvall
3840: 73 74 3a 20 22 20 6b 65 79 76 61 6c 6c 73 74 20 st: " keyvallst
3850: 22 20 66 6c 61 67 73 3a 20 22 20 28 68 61 73 68 " flags: " (hash
3860: 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 20 66 6c -table->alist fl
3870: 61 67 73 29 29 0a 20 20 28 6c 65 74 20 28 28 73 ags)). (let ((s
3880: 6f 72 74 65 64 2d 74 65 73 74 2d 6e 61 6d 65 73 orted-test-names
3890: 20 28 74 65 73 74 73 3a 73 6f 72 74 2d 62 79 2d (tests:sort-by-
38a0: 70 72 69 6f 72 69 74 79 2d 61 6e 64 2d 77 61 69 priority-and-wai
38b0: 74 6f 6e 20 74 65 73 74 2d 72 65 63 6f 72 64 73 ton test-records
38c0: 29 29 0a 09 28 74 65 73 74 2d 72 65 67 69 73 74 ))..(test-regist
38d0: 65 72 79 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 ery (make-has
38e0: 68 2d 74 61 62 6c 65 29 29 0a 09 28 6e 75 6d 2d h-table))..(num-
38f0: 72 65 74 72 69 65 73 20 20 20 20 20 20 20 20 30 retries 0
3900: 29 0a 09 28 6d 61 78 2d 72 65 74 72 69 65 73 20 )..(max-retries
3910: 20 20 20 20 20 20 28 63 6f 6e 66 69 67 2d 6c 6f (config-lo
3920: 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a okup *configdat*
3930: 20 22 73 65 74 75 70 22 20 22 6d 61 78 72 65 74 "setup" "maxret
3940: 72 69 65 73 22 29 29 29 0a 20 20 20 20 28 73 65 ries"))). (se
3950: 74 21 20 6d 61 78 2d 72 65 74 72 69 65 73 20 28 t! max-retries (
3960: 69 66 20 28 61 6e 64 20 6d 61 78 2d 72 65 74 72 if (and max-retr
3970: 69 65 73 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d ies (string->num
3980: 62 65 72 20 6d 61 78 2d 72 65 74 72 69 65 73 29 ber max-retries)
3990: 29 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 )(string->number
39a0: 20 6d 61 78 2d 72 65 74 72 69 65 73 29 20 31 30 max-retries) 10
39b0: 30 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 0)). (if (not
39c0: 20 28 6e 75 6c 6c 3f 20 73 6f 72 74 65 64 2d 74 (null? sorted-t
39d0: 65 73 74 2d 6e 61 6d 65 73 29 29 0a 09 28 6c 65 est-names))..(le
39e0: 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 20 20 20 t loop ((hed
39f0: 20 20 20 20 20 28 63 61 72 20 73 6f 72 74 65 64 (car sorted
3a00: 2d 74 65 73 74 2d 6e 61 6d 65 73 29 29 0a 09 09 -test-names))...
3a10: 20 20 20 28 74 61 6c 20 20 20 20 20 20 20 20 20 (tal
3a20: 28 63 64 72 20 73 6f 72 74 65 64 2d 74 65 73 74 (cdr sorted-test
3a30: 2d 6e 61 6d 65 73 29 29 0a 09 09 20 20 20 28 72 -names))... (r
3a40: 65 72 75 6e 73 20 20 20 20 20 20 27 28 29 29 29 eruns '()))
3a50: 0a 09 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 .. (if (not (nu
3a60: 6c 6c 3f 20 72 65 72 75 6e 73 29 29 28 64 65 62 ll? reruns))(deb
3a70: 75 67 3a 70 72 69 6e 74 20 34 20 22 49 4e 46 4f ug:print 4 "INFO
3a80: 3a 20 72 65 72 75 6e 73 3d 22 20 72 65 72 75 6e : reruns=" rerun
3a90: 73 29 29 0a 09 20 20 3b 3b 20 28 70 72 69 6e 74 s)).. ;; (print
3aa0: 20 22 54 6f 70 20 6f 66 20 6c 6f 6f 70 2c 20 68 "Top of loop, h
3ab0: 65 64 3d 22 20 68 65 64 20 22 2c 20 74 61 6c 3d ed=" hed ", tal=
3ac0: 22 20 74 61 6c 20 22 20 2c 72 65 72 75 6e 73 3d " tal " ,reruns=
3ad0: 22 20 72 65 72 75 6e 73 29 0a 09 20 20 28 6c 65 " reruns).. (le
3ae0: 74 2a 20 28 28 74 65 73 74 2d 72 65 63 6f 72 64 t* ((test-record
3af0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
3b00: 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 68 65 test-records he
3b10: 64 29 29 0a 09 09 20 28 74 65 73 74 2d 6e 61 6d d))... (test-nam
3b20: 65 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 e (tests:testq
3b30: 75 65 75 65 2d 67 65 74 2d 74 65 73 74 6e 61 6d ueue-get-testnam
3b40: 65 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a e test-record)).
3b50: 09 09 20 28 74 63 6f 6e 66 69 67 20 20 20 20 20 .. (tconfig
3b60: 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 (tests:testqueue
3b70: 2d 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 -get-testconfig
3b80: 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 09 test-record))...
3b90: 20 28 74 65 73 74 6d 6f 64 65 20 20 20 20 28 6c (testmode (l
3ba0: 65 74 20 28 28 6d 20 28 63 6f 6e 66 69 67 2d 6c et ((m (config-l
3bb0: 6f 6f 6b 75 70 20 74 63 6f 6e 66 69 67 20 22 72 ookup tconfig "r
3bc0: 65 71 75 69 72 65 6d 65 6e 74 73 22 20 22 6d 6f equirements" "mo
3bd0: 64 65 22 29 29 29 0a 09 09 09 09 28 69 66 20 6d de"))).....(if m
3be0: 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c (string->symbol
3bf0: 20 6d 29 20 27 6e 6f 72 6d 61 6c 29 29 29 0a 09 m) 'normal)))..
3c00: 09 20 28 77 61 69 74 6f 6e 73 20 20 20 20 20 28 . (waitons (
3c10: 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d tests:testqueue-
3c20: 67 65 74 2d 77 61 69 74 6f 6e 73 20 20 20 20 74 get-waitons t
3c30: 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 09 20 est-record))...
3c40: 28 70 72 69 6f 72 69 74 79 20 20 20 20 28 74 65 (priority (te
3c50: 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 sts:testqueue-ge
3c60: 74 2d 70 72 69 6f 72 69 74 79 20 20 20 74 65 73 t-priority tes
3c70: 74 2d 72 65 63 6f 72 64 29 29 0a 09 09 20 28 69 t-record))... (i
3c80: 74 65 6d 64 61 74 20 20 20 20 20 28 74 65 73 74 temdat (test
3c90: 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d s:testqueue-get-
3ca0: 69 74 65 6d 64 61 74 20 20 20 20 74 65 73 74 2d itemdat test-
3cb0: 72 65 63 6f 72 64 29 29 20 3b 3b 20 69 74 65 6d record)) ;; item
3cc0: 64 61 74 20 63 61 6e 20 62 65 20 61 20 73 74 72 dat can be a str
3cd0: 69 6e 67 2c 20 6c 69 73 74 20 6f 72 20 23 66 0a ing, list or #f.
3ce0: 09 09 20 28 69 74 65 6d 73 20 20 20 20 20 20 20 .. (items
3cf0: 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 (tests:testqueue
3d00: 2d 67 65 74 2d 69 74 65 6d 73 20 20 20 20 20 20 -get-items
3d10: 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 09 test-record))...
3d20: 20 28 69 74 65 6d 2d 70 61 74 68 20 20 20 28 69 (item-path (i
3d30: 74 65 6d 2d 6c 69 73 74 2d 3e 70 61 74 68 20 69 tem-list->path i
3d40: 74 65 6d 64 61 74 29 29 0a 09 09 20 28 6e 65 77 temdat))... (new
3d50: 74 61 6c 20 20 20 20 20 20 28 61 70 70 65 6e 64 tal (append
3d60: 20 74 61 6c 20 28 6c 69 73 74 20 68 65 64 29 29 tal (list hed))
3d70: 29 29 0a 09 20 20 20 20 0a 09 20 20 20 20 28 64 )).. .. (d
3d80: 65 62 75 67 3a 70 72 69 6e 74 20 36 0a 09 09 09 ebug:print 6....
3d90: 20 22 74 65 73 74 2d 6e 61 6d 65 3a 20 22 20 74 "test-name: " t
3da0: 65 73 74 2d 6e 61 6d 65 0a 09 09 09 20 22 5c 6e est-name.... "\n
3db0: 20 20 68 65 64 3a 20 20 20 20 20 20 20 20 20 22 hed: "
3dc0: 20 68 65 64 0a 09 09 09 20 22 5c 6e 20 20 69 74 hed.... "\n it
3dd0: 65 6d 64 61 74 3a 20 20 20 20 20 22 20 69 74 65 emdat: " ite
3de0: 6d 64 61 74 0a 09 09 09 20 22 5c 6e 20 20 69 74 mdat.... "\n it
3df0: 65 6d 73 3a 20 20 20 20 20 20 20 22 20 69 74 65 ems: " ite
3e00: 6d 73 0a 09 09 09 20 22 5c 6e 20 20 69 74 65 6d ms.... "\n item
3e10: 2d 70 61 74 68 3a 20 20 20 22 20 69 74 65 6d 2d -path: " item-
3e20: 70 61 74 68 0a 09 09 09 20 22 5c 6e 20 20 77 61 path.... "\n wa
3e30: 69 74 6f 6e 73 3a 20 20 20 20 20 22 20 77 61 69 itons: " wai
3e40: 74 6f 6e 73 0a 09 09 09 20 22 5c 6e 20 20 6e 75 tons.... "\n nu
3e50: 6d 2d 72 65 74 72 69 65 73 3a 20 22 20 6e 75 6d m-retries: " num
3e60: 2d 72 65 74 72 69 65 73 0a 09 09 09 20 22 5c 6e -retries.... "\n
3e70: 20 20 74 61 6c 3a 20 20 20 20 20 20 20 20 20 22 tal: "
3e80: 20 74 61 6c 0a 09 09 09 20 22 5c 6e 20 20 72 65 tal.... "\n re
3e90: 72 75 6e 73 3a 20 20 20 20 20 20 22 20 72 65 72 runs: " rer
3ea0: 75 6e 73 29 0a 0a 09 20 20 20 20 3b 3b 20 63 68 uns)... ;; ch
3eb0: 65 63 6b 20 66 6f 72 20 68 65 64 20 69 6e 20 77 eck for hed in w
3ec0: 61 69 74 6f 6e 73 20 3d 3e 20 74 68 69 73 20 77 aitons => this w
3ed0: 6f 75 6c 64 20 62 65 20 63 69 72 63 75 6c 61 72 ould be circular
3ee0: 2c 20 72 65 6d 6f 76 65 20 69 74 20 61 6e 64 20 , remove it and
3ef0: 69 73 73 75 65 20 61 6e 0a 09 20 20 20 20 3b 3b issue an.. ;;
3f00: 20 65 72 72 6f 72 0a 09 20 20 20 20 28 69 66 20 error.. (if
3f10: 28 6d 65 6d 62 65 72 20 74 65 73 74 2d 6e 61 6d (member test-nam
3f20: 65 20 77 61 69 74 6f 6e 73 29 0a 09 09 28 62 65 e waitons)...(be
3f30: 67 69 6e 0a 09 09 20 20 28 64 65 62 75 67 3a 70 gin... (debug:p
3f40: 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 74 rint 0 "ERROR: t
3f50: 65 73 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 est " test-name
3f60: 22 20 68 61 73 20 6c 69 73 74 65 64 20 69 74 73 " has listed its
3f70: 65 6c 66 20 61 73 20 61 20 77 61 69 74 6f 6e 2c elf as a waiton,
3f80: 20 70 6c 65 61 73 65 20 63 6f 72 72 65 63 74 20 please correct
3f90: 74 68 69 73 21 22 29 0a 09 09 20 20 28 73 65 74 this!")... (set
3fa0: 21 20 77 61 69 74 6f 6e 20 28 66 69 6c 74 65 72 ! waiton (filter
3fb0: 20 28 6c 61 6d 62 64 61 20 28 78 29 28 6e 6f 74 (lambda (x)(not
3fc0: 20 28 65 71 75 61 6c 3f 20 78 20 68 65 64 29 29 (equal? x hed))
3fd0: 29 20 77 61 69 74 6f 6e 73 29 29 29 29 0a 0a 09 ) waitons))))...
3fe0: 20 20 20 20 28 63 6f 6e 64 20 3b 3b 20 4f 55 54 (cond ;; OUT
3ff0: 45 52 20 43 4f 4e 44 0a 09 20 20 20 20 20 28 28 ER COND.. ((
4000: 6e 6f 74 20 69 74 65 6d 73 29 20 3b 3b 20 77 68 not items) ;; wh
4010: 65 6e 20 66 61 6c 73 65 20 74 68 65 20 74 65 73 en false the tes
4020: 74 20 69 73 20 6f 6b 20 74 6f 20 62 65 20 68 61 t is ok to be ha
4030: 6e 64 65 64 20 6f 66 66 20 74 6f 20 6c 61 75 6e nded off to laun
4040: 63 68 20 28 62 75 74 20 6e 6f 74 20 62 65 66 6f ch (but not befo
4050: 72 65 29 0a 09 20 20 20 20 20 20 28 6c 65 74 2a re).. (let*
4060: 20 28 28 72 75 6e 2d 6c 69 6d 69 74 73 2d 69 6e ((run-limits-in
4070: 66 6f 20 20 20 20 20 20 20 20 20 28 6f 70 65 6e fo (open
4080: 2d 72 75 6e 2d 63 6c 6f 73 65 20 72 75 6e 73 3a -run-close runs:
4090: 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 can-run-more-tes
40a0: 74 73 20 23 66 20 74 65 73 74 2d 72 65 63 6f 72 ts #f test-recor
40b0: 64 29 29 20 3b 3b 20 6c 6f 6f 6b 20 61 74 20 74 d)) ;; look at t
40c0: 68 65 20 74 65 73 74 20 6a 6f 62 67 72 6f 75 70 he test jobgroup
40d0: 20 61 6e 64 20 74 6f 74 20 6a 6f 62 73 20 72 75 and tot jobs ru
40e0: 6e 6e 69 6e 67 0a 09 09 20 20 20 20 20 28 68 61 nning... (ha
40f0: 76 65 2d 72 65 73 6f 75 72 63 65 73 20 20 20 20 ve-resources
4100: 20 20 20 20 20 20 28 63 61 72 20 72 75 6e 2d 6c (car run-l
4110: 69 6d 69 74 73 2d 69 6e 66 6f 29 29 0a 09 09 20 imits-info))...
4120: 20 20 20 20 28 6e 75 6d 2d 72 75 6e 6e 69 6e 67 (num-running
4130: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 69 (li
4140: 73 74 2d 72 65 66 20 72 75 6e 2d 6c 69 6d 69 74 st-ref run-limit
4150: 73 2d 69 6e 66 6f 20 31 29 29 0a 09 09 20 20 20 s-info 1))...
4160: 20 20 28 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 69 (num-running-i
4170: 6e 2d 6a 6f 62 67 72 6f 75 70 20 28 6c 69 73 74 n-jobgroup (list
4180: 2d 72 65 66 20 72 75 6e 2d 6c 69 6d 69 74 73 2d -ref run-limits-
4190: 69 6e 66 6f 20 32 29 29 0a 09 09 20 20 20 20 20 info 2))...
41a0: 28 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d (max-concurrent-
41b0: 6a 6f 62 73 20 20 20 20 20 28 6c 69 73 74 2d 72 jobs (list-r
41c0: 65 66 20 72 75 6e 2d 6c 69 6d 69 74 73 2d 69 6e ef run-limits-in
41d0: 66 6f 20 33 29 29 0a 09 09 20 20 20 20 20 28 6a fo 3))... (j
41e0: 6f 62 2d 67 72 6f 75 70 2d 6c 69 6d 69 74 20 20 ob-group-limit
41f0: 20 20 20 20 20 20 20 28 6c 69 73 74 2d 72 65 66 (list-ref
4200: 20 72 75 6e 2d 6c 69 6d 69 74 73 2d 69 6e 66 6f run-limits-info
4210: 20 34 29 29 0a 09 09 20 20 20 20 20 28 70 72 65 4))... (pre
4220: 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 20 20 20 reqs-not-met
4230: 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 (open-run-c
4240: 6c 6f 73 65 20 64 62 3a 67 65 74 2d 70 72 65 72 lose db:get-prer
4250: 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 23 66 20 72 eqs-not-met #f r
4260: 75 6e 2d 69 64 20 77 61 69 74 6f 6e 73 20 69 74 un-id waitons it
4270: 65 6d 2d 70 61 74 68 20 6d 6f 64 65 3a 20 74 65 em-path mode: te
4280: 73 74 6d 6f 64 65 29 29 0a 09 09 20 20 20 20 20 stmode))...
4290: 28 66 61 69 6c 73 20 20 20 20 20 20 20 20 20 20 (fails
42a0: 20 20 20 20 20 20 20 20 20 28 72 75 6e 73 3a 63 (runs:c
42b0: 61 6c 63 2d 66 61 69 6c 73 20 70 72 65 72 65 71 alc-fails prereq
42c0: 73 2d 6e 6f 74 2d 6d 65 74 29 29 0a 09 09 20 20 s-not-met))...
42d0: 20 20 20 28 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 (non-complete
42e0: 64 20 20 20 20 20 20 20 20 20 20 20 28 72 75 6e d (run
42f0: 73 3a 63 61 6c 63 2d 6e 6f 74 2d 63 6f 6d 70 6c s:calc-not-compl
4300: 65 74 65 64 20 70 72 65 72 65 71 73 2d 6e 6f 74 eted prereqs-not
4310: 2d 6d 65 74 29 29 29 0a 09 09 28 64 65 62 75 67 -met)))...(debug
4320: 3a 70 72 69 6e 74 20 38 20 22 49 4e 46 4f 3a 20 :print 8 "INFO:
4330: 68 61 76 65 2d 72 65 73 6f 75 72 63 65 73 3a 20 have-resources:
4340: 22 20 68 61 76 65 2d 72 65 73 6f 75 72 63 65 73 " have-resources
4350: 20 22 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d " prereqs-not-m
4360: 65 74 3a 20 22 20 0a 09 09 09 20 20 20 20 20 28 et: " .... (
4370: 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
4380: 73 65 20 0a 09 09 09 20 20 20 20 20 20 28 6d 61 se .... (ma
4390: 70 20 28 6c 61 6d 62 64 61 20 28 74 29 0a 09 09 p (lambda (t)...
43a0: 09 09 20 20 20 20 20 28 69 66 20 28 76 65 63 74 .. (if (vect
43b0: 6f 72 3f 20 74 29 0a 09 09 09 09 09 20 28 63 6f or? t)...... (co
43c0: 6e 63 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d nc (db:test-get-
43d0: 73 74 61 74 65 20 74 29 20 22 2f 22 20 28 64 62 state t) "/" (db
43e0: 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 73 :test-get-status
43f0: 20 74 29 29 0a 09 09 09 09 09 20 28 63 6f 6e 63 t))...... (conc
4400: 20 22 20 57 41 52 4e 49 4e 47 3a 20 74 20 69 73 " WARNING: t is
4410: 20 6e 6f 74 20 61 20 76 65 63 74 6f 72 3d 22 20 not a vector="
4420: 74 20 29 29 29 0a 09 09 09 09 20 20 20 70 72 65 t )))..... pre
4430: 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 20 22 2c reqs-not-met) ",
4440: 20 22 29 20 22 20 66 61 69 6c 73 3a 20 22 20 66 ") " fails: " f
4450: 61 69 6c 73 29 0a 09 09 28 64 65 62 75 67 3a 70 ails)...(debug:p
4460: 72 69 6e 74 20 34 20 22 49 4e 46 4f 3a 20 68 65 rint 4 "INFO: he
4470: 64 3d 22 20 68 65 64 20 22 5c 6e 20 20 74 65 73 d=" hed "\n tes
4480: 74 2d 72 65 63 6f 72 64 3d 22 20 74 65 73 74 2d t-record=" test-
4490: 72 65 63 6f 72 64 20 22 5c 6e 20 20 74 65 73 74 record "\n test
44a0: 2d 6e 61 6d 65 3a 20 22 20 74 65 73 74 2d 6e 61 -name: " test-na
44b0: 6d 65 20 22 5c 6e 20 20 69 74 65 6d 2d 70 61 74 me "\n item-pat
44c0: 68 3a 20 22 20 69 74 65 6d 2d 70 61 74 68 20 22 h: " item-path "
44d0: 5c 6e 20 20 74 65 73 74 2d 70 61 74 74 73 3a 20 \n test-patts:
44e0: 22 20 74 65 73 74 2d 70 61 74 74 73 29 0a 0a 09 " test-patts)...
44f0: 09 3b 3b 20 44 6f 6e 27 74 20 6b 6e 6f 77 20 61 .;; Don't know a
4500: 74 20 74 68 69 73 20 74 69 6d 65 20 69 66 20 74 t this time if t
4510: 68 65 20 74 65 73 74 20 68 61 76 65 20 62 65 65 he test have bee
4520: 6e 20 6c 61 75 6e 63 68 65 64 20 61 74 20 73 6f n launched at so
4530: 6d 65 20 74 69 6d 65 20 69 6e 20 74 68 65 20 70 me time in the p
4540: 61 73 74 0a 09 09 3b 3b 20 69 2e 65 2e 20 69 73 ast...;; i.e. is
4550: 20 74 68 69 73 20 61 20 72 65 2d 6c 61 75 6e 63 this a re-launc
4560: 68 3f 0a 09 09 28 64 65 62 75 67 3a 70 72 69 6e h?...(debug:prin
4570: 74 20 34 20 22 49 4e 46 4f 3a 20 72 75 6e 2d 6c t 4 "INFO: run-l
4580: 69 6d 69 74 73 2d 69 6e 66 6f 20 3d 20 22 20 72 imits-info = " r
4590: 75 6e 2d 6c 69 6d 69 74 73 2d 69 6e 66 6f 29 0a un-limits-info).
45a0: 09 09 28 63 6f 6e 64 20 3b 3b 20 49 4e 4e 45 52 ..(cond ;; INNER
45b0: 20 43 4f 4e 44 20 23 31 20 66 6f 72 20 61 20 6c COND #1 for a l
45c0: 61 75 6e 63 68 61 62 6c 65 20 74 65 73 74 0a 09 aunchable test..
45d0: 09 20 3b 3b 20 43 68 65 63 6b 20 69 74 65 6d 20 . ;; Check item
45e0: 70 61 74 68 20 61 67 61 69 6e 73 74 20 69 74 65 path against ite
45f0: 6d 2d 70 61 74 74 73 0a 09 09 20 28 28 6e 6f 74 m-patts... ((not
4600: 20 28 74 65 73 74 73 3a 6d 61 74 63 68 20 74 65 (tests:match te
4610: 73 74 2d 70 61 74 74 73 20 28 74 65 73 74 73 3a st-patts (tests:
4620: 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 testqueue-get-te
4630: 73 74 6e 61 6d 65 20 74 65 73 74 2d 72 65 63 6f stname test-reco
4640: 72 64 29 20 69 74 65 6d 2d 70 61 74 68 29 29 20 rd) item-path))
4650: 3b 3b 20 54 68 69 73 20 74 65 73 74 2f 69 74 65 ;; This test/ite
4660: 6d 70 61 74 68 20 69 73 20 6e 6f 74 20 74 6f 20 mpath is not to
4670: 62 65 20 72 75 6e 0a 09 09 20 20 3b 3b 20 65 6c be run... ;; el
4680: 73 65 20 74 68 65 20 72 75 6e 20 69 73 20 73 74 se the run is st
4690: 75 63 6b 2c 20 74 65 6d 70 6f 72 61 72 69 6c 79 uck, temporarily
46a0: 20 6f 72 20 70 65 72 6d 61 6e 65 6e 74 6c 79 0a or permanently.
46b0: 09 09 20 20 3b 3b 20 62 75 74 20 73 68 6f 75 6c .. ;; but shoul
46c0: 64 20 63 68 65 63 6b 20 69 66 20 69 74 20 69 73 d check if it is
46d0: 20 64 75 65 20 74 6f 20 6c 61 63 6b 20 6f 66 20 due to lack of
46e0: 72 65 73 6f 75 72 63 65 73 20 76 73 2e 20 70 72 resources vs. pr
46f0: 65 72 65 71 75 69 73 69 74 65 73 0a 09 09 20 20 erequisites...
4700: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 (debug:print 1 "
4710: 49 4e 46 4f 3a 20 53 6b 69 70 70 69 6e 67 20 22 INFO: Skipping "
4720: 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 (tests:testqueu
4730: 65 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 e-get-testname t
4740: 65 73 74 2d 72 65 63 6f 72 64 29 20 22 20 22 20 est-record) " "
4750: 69 74 65 6d 2d 70 61 74 68 20 22 20 61 73 20 69 item-path " as i
4760: 74 20 64 6f 65 73 6e 27 74 20 6d 61 74 63 68 20 t doesn't match
4770: 22 20 74 65 73 74 2d 70 61 74 74 73 29 0a 09 09 " test-patts)...
4780: 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
4790: 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 *global-delta*)
47a0: 0a 09 09 20 20 28 69 66 20 28 6e 6f 74 20 28 6e ... (if (not (n
47b0: 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 09 20 20 20 ull? tal))...
47c0: 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 (loop (car ta
47d0: 6c 29 28 63 64 72 20 74 61 6c 29 20 72 65 72 75 l)(cdr tal) reru
47e0: 6e 73 29 29 29 0a 09 09 20 28 28 61 6e 64 20 28 ns)))... ((and (
47f0: 6e 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d not (hash-table-
4800: 72 65 66 2f 64 65 66 61 75 6c 74 20 74 65 73 74 ref/default test
4810: 2d 72 65 67 69 73 74 65 72 79 20 28 72 75 6e 73 -registery (runs
4820: 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 74 2d :make-full-test-
4830: 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 69 name test-name i
4840: 74 65 6d 2d 70 61 74 68 29 20 23 66 29 29 0a 09 tem-path) #f))..
4850: 09 20 20 20 20 20 20 20 28 61 6e 64 20 6d 61 78 . (and max
4860: 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 -concurrent-jobs
4870: 20 28 3e 20 28 2d 20 6d 61 78 2d 63 6f 6e 63 75 (> (- max-concu
4880: 72 72 65 6e 74 2d 6a 6f 62 73 20 6e 75 6d 2d 72 rrent-jobs num-r
4890: 75 6e 6e 69 6e 67 29 20 35 29 29 29 0a 09 09 20 unning) 5)))...
48a0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 (debug:print 4
48b0: 22 49 4e 46 4f 3a 20 50 72 65 2d 72 65 67 69 73 "INFO: Pre-regis
48c0: 74 65 72 69 6e 67 20 74 65 73 74 20 22 20 74 65 tering test " te
48d0: 73 74 2d 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d st-name "/" item
48e0: 2d 70 61 74 68 20 22 20 74 6f 20 63 72 65 61 74 -path " to creat
48f0: 65 20 70 6c 61 63 65 68 6f 6c 64 65 72 22 20 29 e placeholder" )
4900: 0a 09 09 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 ... (open-run-c
4910: 6c 6f 73 65 20 64 62 3a 74 65 73 74 73 2d 72 65 lose db:tests-re
4920: 67 69 73 74 65 72 2d 74 65 73 74 20 23 66 20 72 gister-test #f r
4930: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 un-id test-name
4940: 69 74 65 6d 2d 70 61 74 68 29 0a 09 09 20 20 28 item-path)... (
4950: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
4960: 74 65 73 74 2d 72 65 67 69 73 74 65 72 79 20 28 test-registery (
4970: 72 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 runs:make-full-t
4980: 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 est-name test-na
4990: 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 20 23 74 me item-path) #t
49a0: 29 0a 09 09 20 20 28 74 68 72 65 61 64 2d 73 6c )... (thread-sl
49b0: 65 65 70 21 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c eep! *global-del
49c0: 74 61 2a 29 0a 09 09 20 20 28 6c 6f 6f 70 20 28 ta*)... (loop (
49d0: 63 61 72 20 6e 65 77 74 61 6c 29 28 63 64 72 20 car newtal)(cdr
49e0: 6e 65 77 74 61 6c 29 20 72 65 72 75 6e 73 29 29 newtal) reruns))
49f0: 0a 09 09 20 28 28 6e 6f 74 20 68 61 76 65 2d 72 ... ((not have-r
4a00: 65 73 6f 75 72 63 65 73 29 20 3b 3b 20 73 69 6d esources) ;; sim
4a10: 70 6c 79 20 74 72 79 20 61 67 61 69 6e 20 61 66 ply try again af
4a20: 74 65 72 20 77 61 69 74 69 6e 67 20 61 20 73 65 ter waiting a se
4a30: 63 6f 6e 64 0a 09 09 20 20 28 64 65 62 75 67 3a cond... (debug:
4a40: 70 72 69 6e 74 20 31 20 22 49 4e 46 4f 3a 20 6e print 1 "INFO: n
4a50: 6f 20 72 65 73 6f 75 72 63 65 73 20 74 6f 20 72 o resources to r
4a60: 75 6e 20 6e 65 77 20 74 65 73 74 73 2c 20 77 61 un new tests, wa
4a70: 69 74 69 6e 67 20 2e 2e 2e 22 29 0a 09 09 20 20 iting ...")...
4a80: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 28 (thread-sleep! (
4a90: 2b 20 30 2e 30 31 20 2a 67 6c 6f 62 61 6c 2d 64 + 0.01 *global-d
4aa0: 65 6c 74 61 2a 29 29 0a 09 09 20 20 3b 3b 20 63 elta*))... ;; c
4ab0: 6f 75 6c 64 20 68 61 76 65 20 64 6f 6e 65 20 68 ould have done h
4ac0: 65 64 20 74 61 6c 20 68 65 72 65 20 62 75 74 20 ed tal here but
4ad0: 64 6f 69 6e 67 20 63 61 72 2f 63 64 72 20 6f 66 doing car/cdr of
4ae0: 20 6e 65 77 74 61 6c 20 74 6f 20 72 6f 74 61 74 newtal to rotat
4af0: 65 20 74 65 73 74 73 0a 09 09 20 20 28 6c 6f 6f e tests... (loo
4b00: 70 20 28 63 61 72 20 6e 65 77 74 61 6c 29 28 63 p (car newtal)(c
4b10: 64 72 20 6e 65 77 74 61 6c 29 20 72 65 72 75 6e dr newtal) rerun
4b20: 73 29 29 0a 09 09 20 28 28 61 6e 64 20 68 61 76 s))... ((and hav
4b30: 65 2d 72 65 73 6f 75 72 63 65 73 0a 09 09 20 20 e-resources...
4b40: 20 20 20 20 20 28 6f 72 20 28 6e 75 6c 6c 3f 20 (or (null?
4b50: 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 prereqs-not-met)
4b60: 0a 09 09 09 20 20 20 28 61 6e 64 20 28 65 71 3f .... (and (eq?
4b70: 20 74 65 73 74 6d 6f 64 65 20 27 74 6f 70 6c 65 testmode 'tople
4b80: 76 65 6c 29 0a 09 09 09 09 28 6e 75 6c 6c 3f 20 vel).....(null?
4b90: 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 29 29 29 non-completed)))
4ba0: 29 0a 09 09 20 20 28 72 75 6e 3a 74 65 73 74 20 )... (run:test
4bb0: 72 75 6e 2d 69 64 20 72 75 6e 6e 61 6d 65 20 6b run-id runname k
4bc0: 65 79 76 61 6c 6c 73 74 20 74 65 73 74 2d 72 65 eyvallst test-re
4bd0: 63 6f 72 64 20 66 6c 61 67 73 20 23 66 29 0a 09 cord flags #f)..
4be0: 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 . (thread-sleep
4bf0: 21 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a ! *global-delta*
4c00: 29 0a 09 09 20 20 28 69 66 20 28 6e 6f 74 20 28 )... (if (not (
4c10: 6e 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 09 20 20 null? tal))...
4c20: 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 (loop (car t
4c30: 61 6c 29 28 63 64 72 20 74 61 6c 29 20 72 65 72 al)(cdr tal) rer
4c40: 75 6e 73 29 29 29 0a 09 09 20 28 65 6c 73 65 20 uns)))... (else
4c50: 3b 3b 20 6d 75 73 74 20 62 65 20 77 65 20 68 61 ;; must be we ha
4c60: 76 65 20 75 6e 6d 65 74 20 70 72 65 72 65 71 75 ve unmet prerequ
4c70: 69 73 69 74 65 73 0a 09 09 20 20 20 20 28 64 65 isites... (de
4c80: 62 75 67 3a 70 72 69 6e 74 20 34 20 22 46 41 49 bug:print 4 "FAI
4c90: 4c 53 3a 20 22 20 66 61 69 6c 73 29 0a 09 09 20 LS: " fails)...
4ca0: 20 20 20 3b 3b 20 49 66 20 6f 6e 65 20 6f 72 20 ;; If one or
4cb0: 6d 6f 72 65 20 6f 66 20 74 68 65 20 70 72 65 72 more of the prer
4cc0: 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 61 72 65 20 eqs-not-met are
4cd0: 46 41 49 4c 20 74 68 65 6e 20 77 65 20 63 61 6e FAIL then we can
4ce0: 20 69 73 73 75 65 0a 09 09 20 20 20 20 3b 3b 20 issue... ;;
4cf0: 61 20 6d 65 73 73 61 67 65 20 61 6e 64 20 64 72 a message and dr
4d00: 6f 70 20 68 65 64 20 66 72 6f 6d 20 74 68 65 20 op hed from the
4d10: 69 74 65 6d 73 20 74 6f 20 62 65 20 70 72 6f 63 items to be proc
4d20: 65 73 73 65 64 2e 0a 09 09 20 20 20 20 28 69 66 essed.... (if
4d30: 20 28 6e 75 6c 6c 3f 20 66 61 69 6c 73 29 0a 09 (null? fails)..
4d40: 09 09 28 62 65 67 69 6e 0a 09 09 09 20 20 3b 3b ..(begin.... ;;
4d50: 20 63 6f 75 6c 64 6e 27 74 20 72 75 6e 2c 20 74 couldn't run, t
4d60: 61 6b 65 20 61 20 62 72 65 61 74 68 65 72 0a 09 ake a breather..
4d70: 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
4d80: 20 34 20 22 49 4e 46 4f 3a 20 53 68 6f 75 6c 64 4 "INFO: Should
4d90: 6e 27 74 20 72 65 61 6c 6c 79 20 67 65 74 20 68 n't really get h
4da0: 65 72 65 2c 20 72 61 63 65 20 63 6f 6e 64 69 74 ere, race condit
4db0: 69 6f 6e 3f 20 55 6e 61 62 6c 65 20 74 6f 20 6c ion? Unable to l
4dc0: 61 75 6e 63 68 20 6d 6f 72 65 20 74 65 73 74 73 aunch more tests
4dd0: 20 61 74 20 74 68 69 73 20 6d 6f 6d 65 6e 74 2c at this moment,
4de0: 20 6b 69 6c 6c 69 6e 67 20 74 69 6d 65 20 2e 2e killing time ..
4df0: 2e 22 29 0a 09 09 09 20 20 28 74 68 72 65 61 64 .").... (thread
4e00: 2d 73 6c 65 65 70 21 20 28 2b 20 30 2e 30 31 20 -sleep! (+ 0.01
4e10: 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 29 *global-delta*))
4e20: 20 3b 3b 20 6c 6f 6e 67 20 73 6c 65 65 70 20 68 ;; long sleep h
4e30: 65 72 65 20 2d 20 6e 6f 20 72 65 73 6f 75 72 63 ere - no resourc
4e40: 65 73 2c 20 6d 61 79 20 61 73 20 77 65 6c 6c 20 es, may as well
4e50: 62 65 20 70 61 74 69 65 6e 74 0a 09 09 09 20 20 be patient....
4e60: 3b 3b 20 77 65 20 6d 61 64 65 20 6e 65 77 20 74 ;; we made new t
4e70: 61 6c 20 62 79 20 73 74 69 63 6b 69 6e 67 20 68 al by sticking h
4e80: 65 64 20 61 74 20 74 68 65 20 62 61 63 6b 20 6f ed at the back o
4e90: 66 20 74 68 65 20 6c 69 73 74 0a 09 09 09 20 20 f the list....
4ea0: 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 77 74 61 (loop (car newta
4eb0: 6c 29 28 63 64 72 20 6e 65 77 74 61 6c 29 20 72 l)(cdr newtal) r
4ec0: 65 72 75 6e 73 29 29 0a 09 09 09 3b 3b 20 74 68 eruns))....;; th
4ed0: 65 20 77 61 69 74 6f 6e 20 69 73 20 46 41 49 4c e waiton is FAIL
4ee0: 20 73 6f 20 6e 6f 20 70 6f 69 6e 74 20 69 6e 20 so no point in
4ef0: 74 72 79 69 6e 67 20 74 6f 20 72 75 6e 20 68 65 trying to run he
4f00: 64 20 65 76 65 72 20 61 67 61 69 6e 0a 09 09 09 d ever again....
4f10: 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 (if (not (null?
4f20: 74 61 6c 29 29 0a 09 09 09 20 20 20 20 28 69 66 tal)).... (if
4f30: 20 28 76 65 63 74 6f 72 3f 20 68 65 64 29 0a 09 (vector? hed)..
4f40: 09 09 09 28 62 65 67 69 6e 20 28 64 65 62 75 67 ...(begin (debug
4f50: 3a 70 72 69 6e 74 20 31 20 22 57 41 52 4e 3a 20 :print 1 "WARN:
4f60: 44 72 6f 70 70 69 6e 67 20 74 65 73 74 20 22 20 Dropping test "
4f70: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 (db:test-get-tes
4f80: 74 6e 61 6d 65 20 68 65 64 29 20 22 2f 22 20 28 tname hed) "/" (
4f90: 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 6d db:test-get-item
4fa0: 2d 70 61 74 68 20 68 65 64 29 0a 09 09 09 09 09 -path hed)......
4fb0: 09 20 20 20 20 22 20 66 72 6f 6d 20 74 68 65 20 . " from the
4fc0: 6c 61 75 6e 63 68 20 6c 69 73 74 20 61 73 20 69 launch list as i
4fd0: 74 20 68 61 73 20 70 72 65 72 65 71 75 69 73 74 t has prerequist
4fe0: 65 73 20 74 68 61 74 20 61 72 65 20 46 41 49 4c es that are FAIL
4ff0: 22 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 74 ")..... (t
5000: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 2a 67 6c hread-sleep! *gl
5010: 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 0a 09 09 09 obal-delta*)....
5020: 09 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 . (loop (c
5030: 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 ar tal)(cdr tal)
5040: 20 28 63 6f 6e 73 20 68 65 64 20 72 65 72 75 6e (cons hed rerun
5050: 73 29 29 29 0a 09 09 09 09 28 62 65 67 69 6e 0a s))).....(begin.
5060: 09 09 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 .... (debug:pri
5070: 6e 74 20 31 20 22 57 41 52 4e 3a 20 54 65 73 74 nt 1 "WARN: Test
5080: 20 6e 6f 74 20 70 72 6f 63 65 73 73 65 64 20 63 not processed c
5090: 6f 72 72 65 63 74 6c 79 2e 20 43 6f 75 6c 64 20 orrectly. Could
50a0: 62 65 20 61 20 72 61 63 65 20 63 6f 6e 64 69 74 be a race condit
50b0: 69 6f 6e 20 69 6e 20 79 6f 75 72 20 74 65 73 74 ion in your test
50c0: 20 69 6d 70 6c 65 6d 65 6e 74 61 74 69 6f 6e 3f implementation?
50d0: 20 22 20 68 65 64 29 20 3b 3b 20 20 22 20 61 73 " hed) ;; " as
50e0: 20 69 74 20 68 61 73 20 70 72 65 72 65 71 75 69 it has prerequi
50f0: 73 74 65 73 20 74 68 61 74 20 61 72 65 20 46 41 stes that are FA
5100: 49 4c 2e 20 28 4e 4f 54 45 3a 20 68 65 64 20 69 IL. (NOTE: hed i
5110: 73 20 6e 6f 74 20 61 20 76 65 63 74 6f 72 29 22 s not a vector)"
5120: 29 0a 09 09 09 09 20 20 28 74 68 72 65 61 64 2d )..... (thread-
5130: 73 6c 65 65 70 21 20 28 2b 20 30 2e 30 31 20 2a sleep! (+ 0.01 *
5140: 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 29 0a global-delta*)).
5150: 09 09 09 09 20 20 28 6c 6f 6f 70 20 68 65 64 20 .... (loop hed
5160: 74 61 6c 20 72 65 72 75 6e 73 29 29 29 29 29 29 tal reruns))))))
5170: 29 29 29 20 3b 3b 20 45 4e 44 20 4f 46 20 49 4e ))) ;; END OF IN
5180: 4e 45 52 20 43 4f 4e 44 0a 09 20 20 20 20 20 0a NER COND.. .
5190: 09 20 20 20 20 20 3b 3b 20 63 61 73 65 20 77 68 . ;; case wh
51a0: 65 72 65 20 61 6e 20 69 74 65 6d 73 20 63 61 6d ere an items cam
51b0: 65 20 69 6e 20 61 73 20 61 20 6c 69 73 74 20 62 e in as a list b
51c0: 65 65 6e 20 70 72 6f 63 65 73 73 65 64 0a 09 20 een processed..
51d0: 20 20 20 20 28 28 61 6e 64 20 28 6c 69 73 74 3f ((and (list?
51e0: 20 69 74 65 6d 73 29 20 20 20 20 20 3b 3b 20 74 items) ;; t
51f0: 68 75 73 20 77 65 20 6b 6e 6f 77 20 6f 75 72 20 hus we know our
5200: 69 74 65 6d 73 20 61 72 65 20 61 6c 72 65 61 64 items are alread
5210: 79 20 63 61 6c 63 75 6c 61 74 65 64 0a 09 09 20 y calculated...
5220: 20 20 28 6e 6f 74 20 20 20 69 74 65 6d 64 61 74 (not itemdat
5230: 29 29 20 3b 3b 20 61 6e 64 20 6e 6f 74 20 79 65 )) ;; and not ye
5240: 74 20 65 78 70 61 6e 64 65 64 20 69 6e 74 6f 20 t expanded into
5250: 74 68 65 20 6c 69 73 74 20 6f 66 20 74 68 69 6e the list of thin
5260: 67 73 20 74 6f 20 62 65 20 64 6f 6e 65 0a 09 20 gs to be done..
5270: 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 3e (if (and (>
5280: 3d 20 2a 76 65 72 62 6f 73 69 74 79 2a 20 31 29 = *verbosity* 1)
5290: 0a 09 09 20 20 20 20 20 20 20 28 3e 20 28 6c 65 ... (> (le
52a0: 6e 67 74 68 20 69 74 65 6d 73 29 20 30 29 0a 09 ngth items) 0)..
52b0: 09 20 20 20 20 20 20 20 28 3e 20 28 6c 65 6e 67 . (> (leng
52c0: 74 68 20 28 63 61 72 20 69 74 65 6d 73 29 29 20 th (car items))
52d0: 30 29 29 0a 09 09 20 20 28 70 70 20 69 74 65 6d 0))... (pp item
52e0: 73 29 29 0a 09 20 20 20 20 20 20 28 66 6f 72 2d s)).. (for-
52f0: 65 61 63 68 0a 09 20 20 20 20 20 20 20 28 6c 61 each.. (la
5300: 6d 62 64 61 20 28 6d 79 2d 69 74 65 6d 64 61 74 mbda (my-itemdat
5310: 29 0a 09 09 20 28 6c 65 74 2a 20 28 28 6e 65 77 )... (let* ((new
5320: 2d 74 65 73 74 2d 72 65 63 6f 72 64 20 28 6c 65 -test-record (le
5330: 74 20 28 28 6e 65 77 72 65 63 20 28 6d 61 6b 65 t ((newrec (make
5340: 2d 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 -tests:testqueue
5350: 29 29 29 0a 09 09 09 09 09 20 20 20 28 76 65 63 )))...... (vec
5360: 74 6f 72 2d 63 6f 70 79 21 20 74 65 73 74 2d 72 tor-copy! test-r
5370: 65 63 6f 72 64 20 6e 65 77 72 65 63 29 0a 09 09 ecord newrec)...
5380: 09 09 09 20 20 20 6e 65 77 72 65 63 29 29 0a 09 ... newrec))..
5390: 09 09 28 6d 79 2d 69 74 65 6d 2d 70 61 74 68 20 ..(my-item-path
53a0: 28 69 74 65 6d 2d 6c 69 73 74 2d 3e 70 61 74 68 (item-list->path
53b0: 20 6d 79 2d 69 74 65 6d 64 61 74 29 29 29 0a 09 my-itemdat)))..
53c0: 09 20 20 20 28 69 66 20 28 74 65 73 74 73 3a 6d . (if (tests:m
53d0: 61 74 63 68 20 74 65 73 74 2d 70 61 74 74 73 20 atch test-patts
53e0: 68 65 64 20 6d 79 2d 69 74 65 6d 2d 70 61 74 68 hed my-item-path
53f0: 29 20 3b 3b 20 28 70 61 74 74 2d 6c 69 73 74 2d ) ;; (patt-list-
5400: 6d 61 74 63 68 20 6d 79 2d 69 74 65 6d 2d 70 61 match my-item-pa
5410: 74 68 20 69 74 65 6d 2d 70 61 74 74 73 29 20 20 th item-patts)
5420: 20 20 20 20 20 20 20 20 20 3b 3b 20 79 65 73 2c ;; yes,
5430: 20 77 65 20 77 61 6e 74 20 74 6f 20 70 72 6f 63 we want to proc
5440: 65 73 73 20 74 68 69 73 20 69 74 65 6d 2c 20 4e ess this item, N
5450: 4f 54 45 3a 20 53 68 6f 75 6c 64 20 6e 6f 74 20 OTE: Should not
5460: 6e 65 65 64 20 74 68 69 73 20 63 68 65 63 6b 20 need this check
5470: 68 65 72 65 21 0a 09 09 20 20 20 20 20 20 20 28 here!... (
5480: 6c 65 74 20 28 28 6e 65 77 74 65 73 74 6e 61 6d let ((newtestnam
5490: 65 20 28 72 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c e (runs:make-ful
54a0: 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 68 65 64 20 l-test-name hed
54b0: 6d 79 2d 69 74 65 6d 2d 70 61 74 68 29 29 29 20 my-item-path)))
54c0: 20 20 20 3b 3b 20 74 65 73 74 20 6e 61 6d 65 73 ;; test names
54d0: 20 61 72 65 20 75 6e 69 71 75 65 20 6f 6e 20 74 are unique on t
54e0: 65 73 74 6e 61 6d 65 2f 69 74 65 6d 2d 70 61 74 estname/item-pat
54f0: 68 0a 09 09 09 20 28 74 65 73 74 73 3a 74 65 73 h.... (tests:tes
5500: 74 71 75 65 75 65 2d 73 65 74 2d 69 74 65 6d 73 tqueue-set-items
5510: 21 20 20 20 20 20 6e 65 77 2d 74 65 73 74 2d 72 ! new-test-r
5520: 65 63 6f 72 64 20 23 66 29 0a 09 09 09 20 28 74 ecord #f).... (t
5530: 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 73 ests:testqueue-s
5540: 65 74 2d 69 74 65 6d 64 61 74 21 20 20 20 6e 65 et-itemdat! ne
5550: 77 2d 74 65 73 74 2d 72 65 63 6f 72 64 20 6d 79 w-test-record my
5560: 2d 69 74 65 6d 64 61 74 29 0a 09 09 09 20 28 74 -itemdat).... (t
5570: 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 73 ests:testqueue-s
5580: 65 74 2d 69 74 65 6d 5f 70 61 74 68 21 20 6e 65 et-item_path! ne
5590: 77 2d 74 65 73 74 2d 72 65 63 6f 72 64 20 6d 79 w-test-record my
55a0: 2d 69 74 65 6d 2d 70 61 74 68 29 0a 09 09 09 20 -item-path)....
55b0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
55c0: 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 6e 65 test-records ne
55d0: 77 74 65 73 74 6e 61 6d 65 20 6e 65 77 2d 74 65 wtestname new-te
55e0: 73 74 2d 72 65 63 6f 72 64 29 0a 09 09 09 20 28 st-record).... (
55f0: 73 65 74 21 20 74 61 6c 20 28 63 6f 6e 73 20 6e set! tal (cons n
5600: 65 77 74 65 73 74 6e 61 6d 65 20 74 61 6c 29 29 ewtestname tal))
5610: 29 29 29 29 20 3b 3b 20 73 69 6e 63 65 20 74 68 )))) ;; since th
5620: 65 73 65 20 61 72 65 20 69 74 65 6d 69 7a 65 64 ese are itemized
5630: 20 63 72 65 61 74 65 20 6e 65 77 20 74 65 73 74 create new test
5640: 20 6e 61 6d 65 73 20 74 65 73 74 6e 61 6d 65 2f names testname/
5650: 69 74 65 6d 70 61 74 68 0a 09 20 20 20 20 20 20 itempath..
5660: 20 69 74 65 6d 73 29 0a 09 20 20 20 20 20 20 28 items).. (
5670: 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 if (not (null? t
5680: 61 6c 29 29 0a 09 09 20 20 28 62 65 67 69 6e 0a al))... (begin.
5690: 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
56a0: 6e 74 20 34 20 22 49 4e 46 4f 3a 20 45 6e 64 20 nt 4 "INFO: End
56b0: 6f 66 20 69 74 65 6d 73 20 6c 69 73 74 2c 20 6c of items list, l
56c0: 6f 6f 70 69 6e 67 20 77 69 74 68 20 6e 65 78 74 ooping with next
56d0: 20 61 66 74 65 72 20 73 68 6f 72 74 20 64 65 6c after short del
56e0: 61 79 22 29 0a 09 09 20 20 20 20 28 74 68 72 65 ay")... (thre
56f0: 61 64 2d 73 6c 65 65 70 21 20 28 2b 20 30 2e 30 ad-sleep! (+ 0.0
5700: 31 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 1 *global-delta*
5710: 29 29 0a 09 09 20 20 20 20 28 6c 6f 6f 70 20 28 ))... (loop (
5720: 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c car tal)(cdr tal
5730: 29 20 72 65 72 75 6e 73 29 29 29 29 0a 0a 09 20 ) reruns))))...
5740: 20 20 20 20 3b 3b 20 69 66 20 69 74 65 6d 73 20 ;; if items
5750: 69 73 20 61 20 70 72 6f 63 20 74 68 65 6e 20 6e is a proc then n
5760: 65 65 64 20 74 6f 20 72 75 6e 20 69 74 65 6d 73 eed to run items
5770: 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d :get-items-from-
5780: 63 6f 6e 66 69 67 2c 20 67 65 74 20 74 68 65 20 config, get the
5790: 6c 69 73 74 20 61 6e 64 20 6c 6f 6f 70 20 0a 09 list and loop ..
57a0: 20 20 20 20 20 3b 3b 20 20 20 20 2d 20 62 75 74 ;; - but
57b0: 20 6f 6e 6c 79 20 64 6f 20 74 68 61 74 20 69 66 only do that if
57c0: 20 72 65 73 6f 75 72 63 65 73 20 65 78 69 73 74 resources exist
57d0: 20 74 6f 20 6b 69 63 6b 20 6f 66 66 20 74 68 65 to kick off the
57e0: 20 6a 6f 62 0a 09 20 20 20 20 20 28 28 6f 72 20 job.. ((or
57f0: 28 70 72 6f 63 65 64 75 72 65 3f 20 69 74 65 6d (procedure? item
5800: 73 29 28 65 71 3f 20 69 74 65 6d 73 20 27 68 61 s)(eq? items 'ha
5810: 76 65 2d 70 72 6f 63 65 64 75 72 65 29 29 0a 09 ve-procedure))..
5820: 20 20 20 20 20 20 28 6c 65 74 20 28 28 63 61 6e (let ((can
5830: 2d 72 75 6e 2d 6d 6f 72 65 20 20 20 20 28 6f 70 -run-more (op
5840: 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 72 75 6e en-run-close run
5850: 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 s:can-run-more-t
5860: 65 73 74 73 20 23 66 20 74 65 73 74 2d 72 65 63 ests #f test-rec
5870: 6f 72 64 29 29 29 0a 09 09 28 69 66 20 63 61 6e ord)))...(if can
5880: 2d 72 75 6e 2d 6d 6f 72 65 0a 09 09 20 20 20 20 -run-more...
5890: 28 6c 65 74 2a 20 28 28 70 72 65 72 65 71 73 2d (let* ((prereqs-
58a0: 6e 6f 74 2d 6d 65 74 20 28 6f 70 65 6e 2d 72 75 not-met (open-ru
58b0: 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d 70 n-close db:get-p
58c0: 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 23 rereqs-not-met #
58d0: 66 20 72 75 6e 2d 69 64 20 77 61 69 74 6f 6e 73 f run-id waitons
58e0: 20 69 74 65 6d 2d 70 61 74 68 20 6d 6f 64 65 3a item-path mode:
58f0: 20 74 65 73 74 6d 6f 64 65 29 29 0a 09 09 09 20 testmode))....
5900: 20 20 28 66 61 69 6c 73 20 20 20 20 20 20 20 20 (fails
5910: 20 20 20 28 72 75 6e 73 3a 63 61 6c 63 2d 66 61 (runs:calc-fa
5920: 69 6c 73 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d ils prereqs-not-
5930: 6d 65 74 29 29 0a 09 09 09 20 20 20 28 6e 6f 6e met)).... (non
5940: 2d 63 6f 6d 70 6c 65 74 65 64 20 20 20 28 72 75 -completed (ru
5950: 6e 73 3a 63 61 6c 63 2d 6e 6f 74 2d 63 6f 6d 70 ns:calc-not-comp
5960: 6c 65 74 65 64 20 70 72 65 72 65 71 73 2d 6e 6f leted prereqs-no
5970: 74 2d 6d 65 74 29 29 29 0a 09 09 20 20 20 20 20 t-met)))...
5980: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 38 20 (debug:print 8
5990: 22 49 4e 46 4f 3a 20 63 61 6e 2d 72 75 6e 2d 6d "INFO: can-run-m
59a0: 6f 72 65 3a 20 22 20 63 61 6e 2d 72 75 6e 2d 6d ore: " can-run-m
59b0: 6f 72 65 0a 09 09 09 09 20 20 20 22 5c 6e 20 74 ore..... "\n t
59c0: 65 73 74 6e 61 6d 65 3a 20 20 20 20 20 20 20 20 estname:
59d0: 22 20 68 65 64 0a 09 09 09 09 20 20 20 22 5c 6e " hed..... "\n
59e0: 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 prereqs-not-met
59f0: 3a 20 22 20 28 72 75 6e 73 3a 70 72 65 74 74 79 : " (runs:pretty
5a00: 2d 73 74 72 69 6e 67 20 70 72 65 72 65 71 73 2d -string prereqs-
5a10: 6e 6f 74 2d 6d 65 74 29 0a 09 09 09 09 20 20 20 not-met).....
5a20: 22 5c 6e 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 "\n non-complete
5a30: 64 3a 20 20 20 22 20 28 72 75 6e 73 3a 70 72 65 d: " (runs:pre
5a40: 74 74 79 2d 73 74 72 69 6e 67 20 6e 6f 6e 2d 63 tty-string non-c
5a50: 6f 6d 70 6c 65 74 65 64 29 20 0a 09 09 09 09 20 ompleted) .....
5a60: 20 20 22 5c 6e 20 66 61 69 6c 73 3a 20 20 20 20 "\n fails:
5a70: 20 20 20 20 20 20 20 22 20 28 72 75 6e 73 3a 70 " (runs:p
5a80: 72 65 74 74 79 2d 73 74 72 69 6e 67 20 66 61 69 retty-string fai
5a90: 6c 73 29 0a 09 09 09 09 20 20 20 22 5c 6e 20 74 ls)..... "\n t
5aa0: 65 73 74 6d 6f 64 65 3a 20 20 20 20 20 20 20 20 estmode:
5ab0: 22 20 74 65 73 74 6d 6f 64 65 0a 09 09 09 09 20 " testmode.....
5ac0: 20 20 22 5c 6e 20 6e 75 6d 2d 72 65 74 72 69 65 "\n num-retrie
5ad0: 73 3a 20 20 20 20 20 22 20 6e 75 6d 2d 72 65 74 s: " num-ret
5ae0: 72 69 65 73 0a 09 09 09 09 20 20 20 22 5c 6e 20 ries..... "\n
5af0: 28 65 71 3f 20 74 65 73 74 6d 6f 64 65 20 27 74 (eq? testmode 't
5b00: 6f 70 6c 65 76 65 6c 29 3a 20 22 20 28 65 71 3f oplevel): " (eq?
5b10: 20 74 65 73 74 6d 6f 64 65 20 27 74 6f 70 6c 65 testmode 'tople
5b20: 76 65 6c 29 0a 09 09 09 09 20 20 20 22 5c 6e 20 vel)..... "\n
5b30: 28 6e 75 6c 6c 3f 20 6e 6f 6e 2d 63 6f 6d 70 6c (null? non-compl
5b40: 65 74 65 64 29 3a 20 20 20 20 22 20 28 6e 75 6c eted): " (nul
5b50: 6c 3f 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 l? non-completed
5b60: 29 0a 09 09 09 09 20 20 20 22 5c 6e 20 72 65 72 )..... "\n rer
5b70: 75 6e 73 3a 20 20 20 20 20 20 20 20 20 20 22 20 uns: "
5b80: 72 65 72 75 6e 73 0a 09 09 09 09 20 20 20 22 5c reruns..... "\
5b90: 6e 20 69 74 65 6d 73 3a 20 20 20 20 20 20 20 20 n items:
5ba0: 20 20 20 22 20 69 74 65 6d 73 0a 09 09 09 09 20 " items.....
5bb0: 20 20 22 5c 6e 20 63 61 6e 2d 72 75 6e 2d 6d 6f "\n can-run-mo
5bc0: 72 65 3a 20 20 20 20 22 20 63 61 6e 2d 72 75 6e re: " can-run
5bd0: 2d 6d 6f 72 65 29 0a 09 09 20 20 20 20 20 20 3b -more)... ;
5be0: 3b 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 ; (thread-sleep!
5bf0: 20 28 2b 20 30 2e 30 31 20 2a 67 6c 6f 62 61 6c (+ 0.01 *global
5c00: 2d 64 65 6c 74 61 2a 29 29 0a 09 09 20 20 20 20 -delta*))...
5c10: 20 20 28 63 6f 6e 64 20 3b 3b 20 49 4e 4e 45 52 (cond ;; INNER
5c20: 20 43 4f 4e 44 20 23 32 0a 09 09 20 20 20 20 20 COND #2...
5c30: 20 20 28 28 6f 72 20 28 6e 75 6c 6c 3f 20 70 72 ((or (null? pr
5c40: 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 20 3b ereqs-not-met) ;
5c50: 3b 20 61 6c 6c 20 70 72 65 72 65 71 73 20 6d 65 ; all prereqs me
5c60: 74 2c 20 66 69 72 65 20 6f 66 66 20 74 68 65 20 t, fire off the
5c70: 74 65 73 74 0a 09 09 09 20 20 20 20 3b 3b 20 6f test.... ;; o
5c80: 72 2c 20 69 66 20 69 74 20 69 73 20 61 20 27 74 r, if it is a 't
5c90: 6f 70 6c 65 76 65 6c 20 74 65 73 74 20 61 6e 64 oplevel test and
5ca0: 20 61 6c 6c 20 70 72 65 72 65 71 73 20 6e 6f 74 all prereqs not
5cb0: 20 6d 65 74 20 61 72 65 20 43 4f 4d 50 4c 45 54 met are COMPLET
5cc0: 45 44 20 74 68 65 6e 20 6c 61 75 6e 63 68 0a 09 ED then launch..
5cd0: 09 09 20 20 20 20 28 61 6e 64 20 28 65 71 3f 20 .. (and (eq?
5ce0: 74 65 73 74 6d 6f 64 65 20 27 74 6f 70 6c 65 76 testmode 'toplev
5cf0: 65 6c 29 0a 09 09 09 09 20 28 6e 75 6c 6c 3f 20 el)..... (null?
5d00: 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 29 29 29 non-completed)))
5d10: 0a 09 09 09 28 6c 65 74 20 28 28 74 65 73 74 2d ....(let ((test-
5d20: 6e 61 6d 65 20 28 74 65 73 74 73 3a 74 65 73 74 name (tests:test
5d30: 71 75 65 75 65 2d 67 65 74 2d 74 65 73 74 6e 61 queue-get-testna
5d40: 6d 65 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 me test-record))
5d50: 29 0a 09 09 09 20 20 28 73 65 74 65 6e 76 20 22 ).... (setenv "
5d60: 4d 54 5f 54 45 53 54 5f 4e 41 4d 45 22 20 74 65 MT_TEST_NAME" te
5d70: 73 74 2d 6e 61 6d 65 29 20 3b 3b 20 0a 09 09 09 st-name) ;; ....
5d80: 20 20 28 73 65 74 65 6e 76 20 22 4d 54 5f 52 55 (setenv "MT_RU
5d90: 4e 4e 41 4d 45 22 20 20 20 72 75 6e 6e 61 6d 65 NNAME" runname
5da0: 29 0a 09 09 09 20 20 28 6f 70 65 6e 2d 72 75 6e ).... (open-run
5db0: 2d 63 6c 6f 73 65 20 73 65 74 2d 6d 65 67 61 74 -close set-megat
5dc0: 65 73 74 2d 65 6e 76 2d 76 61 72 73 20 23 66 20 est-env-vars #f
5dd0: 72 75 6e 2d 69 64 29 20 3b 3b 20 74 68 65 73 65 run-id) ;; these
5de0: 20 6d 61 79 20 62 65 20 6e 65 65 64 65 64 20 62 may be needed b
5df0: 79 20 74 68 65 20 6c 61 75 6e 63 68 69 6e 67 20 y the launching
5e00: 70 72 6f 63 65 73 73 0a 09 09 09 20 20 28 6c 65 process.... (le
5e10: 74 20 28 28 69 74 65 6d 73 2d 6c 69 73 74 20 28 t ((items-list (
5e20: 69 74 65 6d 73 3a 67 65 74 2d 69 74 65 6d 73 2d items:get-items-
5e30: 66 72 6f 6d 2d 63 6f 6e 66 69 67 20 74 63 6f 6e from-config tcon
5e40: 66 69 67 29 29 29 0a 09 09 09 20 20 20 20 28 69 fig))).... (i
5e50: 66 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 2d 6c f (list? items-l
5e60: 69 73 74 29 0a 09 09 09 09 28 62 65 67 69 6e 0a ist).....(begin.
5e70: 09 09 09 09 20 20 28 74 65 73 74 73 3a 74 65 73 .... (tests:tes
5e80: 74 71 75 65 75 65 2d 73 65 74 2d 69 74 65 6d 73 tqueue-set-items
5e90: 21 20 74 65 73 74 2d 72 65 63 6f 72 64 20 69 74 ! test-record it
5ea0: 65 6d 73 2d 6c 69 73 74 29 0a 09 09 09 09 20 20 ems-list).....
5eb0: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 2a (thread-sleep! *
5ec0: 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 0a 09 global-delta*)..
5ed0: 09 09 09 20 20 28 6c 6f 6f 70 20 68 65 64 20 74 ... (loop hed t
5ee0: 61 6c 20 72 65 72 75 6e 73 29 29 0a 09 09 09 09 al reruns)).....
5ef0: 28 62 65 67 69 6e 0a 09 09 09 09 20 20 28 64 65 (begin..... (de
5f00: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 bug:print 0 "ERR
5f10: 4f 52 3a 20 54 68 65 20 70 72 6f 63 20 66 72 6f OR: The proc fro
5f20: 6d 20 72 65 61 64 69 6e 67 20 74 68 65 20 73 65 m reading the se
5f30: 74 75 70 20 64 69 64 20 6e 6f 74 20 79 69 65 6c tup did not yiel
5f40: 64 20 61 20 6c 69 73 74 20 2d 20 70 6c 65 61 73 d a list - pleas
5f50: 65 20 72 65 70 6f 72 74 20 74 68 69 73 22 29 0a e report this").
5f60: 09 09 09 09 20 20 28 65 78 69 74 20 31 29 29 29 .... (exit 1)))
5f70: 29 29 29 0a 09 09 20 20 20 20 20 20 20 28 28 6e )))... ((n
5f80: 75 6c 6c 3f 20 66 61 69 6c 73 29 0a 09 09 09 28 ull? fails)....(
5f90: 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 49 debug:print 4 "I
5fa0: 4e 46 4f 3a 20 66 61 69 6c 73 20 69 73 20 6e 75 NFO: fails is nu
5fb0: 6c 6c 2c 20 6d 6f 76 69 6e 67 20 6f 6e 20 69 6e ll, moving on in
5fc0: 20 74 68 65 20 71 75 65 75 65 20 62 75 74 20 6b the queue but k
5fd0: 65 65 70 69 6e 67 20 22 20 68 65 64 20 22 20 66 eeping " hed " f
5fe0: 6f 72 20 6e 6f 77 22 29 0a 09 09 09 3b 3b 20 6f or now")....;; o
5ff0: 6e 6c 79 20 69 6e 63 72 65 6d 65 6e 74 20 6e 75 nly increment nu
6000: 6d 2d 72 65 74 72 69 65 73 20 77 68 65 6e 20 74 m-retries when t
6010: 68 65 72 65 20 61 72 65 20 6e 6f 20 74 65 73 74 here are no test
6020: 73 20 72 75 6e 69 6e 67 0a 09 09 09 28 69 66 20 s runing....(if
6030: 28 65 71 3f 20 30 20 28 6c 69 73 74 2d 72 65 66 (eq? 0 (list-ref
6040: 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 20 31 29 can-run-more 1)
6050: 29 0a 09 09 09 20 20 20 20 28 62 65 67 69 6e 0a ).... (begin.
6060: 09 09 09 20 20 20 20 20 20 28 69 66 20 28 3e 20 ... (if (>
6070: 6e 75 6d 2d 72 65 74 72 69 65 73 20 31 30 30 29 num-retries 100)
6080: 20 3b 3b 20 66 69 72 73 74 20 31 30 30 20 72 65 ;; first 100 re
6090: 74 72 69 65 73 20 61 72 65 20 6c 6f 77 20 74 69 tries are low ti
60a0: 6d 65 20 63 6f 73 74 0a 09 09 09 09 20 20 28 74 me cost..... (t
60b0: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 28 2b 20 hread-sleep! (+
60c0: 32 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 2 *global-delta*
60d0: 29 29 0a 09 09 09 09 20 20 28 74 68 72 65 61 64 ))..... (thread
60e0: 2d 73 6c 65 65 70 21 20 28 2b 20 30 2e 30 31 20 -sleep! (+ 0.01
60f0: 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 29 *global-delta*))
6100: 29 0a 09 09 09 20 20 20 20 20 20 28 73 65 74 21 ).... (set!
6110: 20 6e 75 6d 2d 72 65 74 72 69 65 73 20 28 2b 20 num-retries (+
6120: 6e 75 6d 2d 72 65 74 72 69 65 73 20 31 29 29 29 num-retries 1)))
6130: 29 0a 09 09 09 28 69 66 20 28 3e 20 6e 75 6d 2d )....(if (> num-
6140: 72 65 74 72 69 65 73 20 20 6d 61 78 2d 72 65 74 retries max-ret
6150: 72 69 65 73 29 0a 09 09 09 20 20 20 20 28 69 66 ries).... (if
6160: 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c (not (null? tal
6170: 29 29 0a 09 09 09 09 28 6c 6f 6f 70 20 28 63 61 )).....(loop (ca
6180: 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 20 r tal)(cdr tal)
6190: 72 65 72 75 6e 73 29 29 0a 09 09 09 20 20 20 20 reruns))....
61a0: 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 77 74 61 (loop (car newta
61b0: 6c 29 28 63 64 72 20 6e 65 77 74 61 6c 29 20 72 l)(cdr newtal) r
61c0: 65 72 75 6e 73 29 29 29 20 3b 3b 20 61 6e 20 69 eruns))) ;; an i
61d0: 73 73 75 65 20 77 69 74 68 20 70 72 65 72 65 71 ssue with prereq
61e0: 73 20 6e 6f 74 20 79 65 74 20 6d 65 74 3f 0a 09 s not yet met?..
61f0: 09 20 20 20 20 20 20 20 28 28 61 6e 64 20 28 6e . ((and (n
6200: 6f 74 20 28 6e 75 6c 6c 3f 20 66 61 69 6c 73 29 ot (null? fails)
6210: 29 28 65 71 3f 20 74 65 73 74 6d 6f 64 65 20 27 )(eq? testmode '
6220: 6e 6f 72 6d 61 6c 29 29 0a 09 09 09 28 64 65 62 normal))....(deb
6230: 75 67 3a 70 72 69 6e 74 20 31 20 22 49 4e 46 4f ug:print 1 "INFO
6240: 3a 20 74 65 73 74 20 22 20 20 68 65 64 20 22 20 : test " hed "
6250: 28 6d 6f 64 65 3d 22 20 74 65 73 74 6d 6f 64 65 (mode=" testmode
6260: 20 22 29 20 68 61 73 20 66 61 69 6c 65 64 20 70 ") has failed p
6270: 72 65 72 65 71 75 69 73 69 74 65 28 73 29 3b 20 rerequisite(s);
6280: 22 0a 09 09 09 09 20 20 20 20 20 28 73 74 72 69 "..... (stri
6290: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 ng-intersperse (
62a0: 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 74 29 28 map (lambda (t)(
62b0: 63 6f 6e 63 20 28 64 62 3a 74 65 73 74 2d 67 65 conc (db:test-ge
62c0: 74 2d 74 65 73 74 6e 61 6d 65 20 74 29 20 22 3a t-testname t) ":
62d0: 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 " (db:test-get-s
62e0: 74 61 74 65 20 74 29 22 2f 22 28 64 62 3a 74 65 tate t)"/"(db:te
62f0: 73 74 2d 67 65 74 2d 73 74 61 74 75 73 20 74 29 st-get-status t)
6300: 29 29 20 66 61 69 6c 73 29 20 22 2c 20 22 29 0a )) fails) ", ").
6310: 09 09 09 09 20 20 20 20 20 22 2c 20 72 65 6d 6f .... ", remo
6320: 76 69 6e 67 20 69 74 20 66 72 6f 6d 20 74 6f 2d ving it from to-
6330: 64 6f 20 6c 69 73 74 22 29 0a 09 09 09 28 69 66 do list")....(if
6340: 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c (not (null? tal
6350: 29 29 0a 09 09 09 20 20 20 20 28 62 65 67 69 6e )).... (begin
6360: 0a 09 09 09 20 20 20 20 20 20 28 74 68 72 65 61 .... (threa
6370: 64 2d 73 6c 65 65 70 21 20 2a 67 6c 6f 62 61 6c d-sleep! *global
6380: 2d 64 65 6c 74 61 2a 29 0a 09 09 09 20 20 20 20 -delta*)....
6390: 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c (loop (car tal
63a0: 29 28 63 64 72 20 74 61 6c 29 28 63 6f 6e 73 20 )(cdr tal)(cons
63b0: 68 65 64 20 72 65 72 75 6e 73 29 29 29 29 29 0a hed reruns))))).
63c0: 09 09 20 20 20 20 20 20 20 28 65 6c 73 65 0a 09 .. (else..
63d0: 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 38 ..(debug:print 8
63e0: 20 22 45 52 52 4f 52 3a 20 4e 6f 20 68 61 6e 64 "ERROR: No hand
63f0: 6c 65 72 20 66 6f 72 20 74 68 69 73 20 63 6f 6e ler for this con
6400: 64 69 74 69 6f 6e 2e 22 29 0a 09 09 09 28 74 68 dition.")....(th
6410: 72 65 61 64 2d 73 6c 65 65 70 21 20 28 2b 20 31 read-sleep! (+ 1
6420: 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 *global-delta*)
6430: 29 0a 09 09 09 28 6c 6f 6f 70 20 28 63 61 72 20 )....(loop (car
6440: 6e 65 77 74 61 6c 29 28 63 64 72 20 6e 65 77 74 newtal)(cdr newt
6450: 61 6c 29 20 72 65 72 75 6e 73 29 29 29 29 20 3b al) reruns)))) ;
6460: 3b 20 45 4e 44 20 4f 46 20 49 46 20 43 41 4e 20 ; END OF IF CAN
6470: 52 55 4e 20 4d 4f 52 45 0a 0a 09 09 20 20 20 20 RUN MORE....
6480: 3b 3b 20 69 66 20 63 61 6e 27 74 20 72 75 6e 20 ;; if can't run
6490: 6d 6f 72 65 20 6a 75 73 74 20 6c 6f 6f 70 20 77 more just loop w
64a0: 69 74 68 20 6e 65 78 74 20 70 6f 73 73 69 62 6c ith next possibl
64b0: 65 20 74 65 73 74 0a 09 09 20 20 20 20 28 62 65 e test... (be
64c0: 67 69 6e 0a 09 09 20 20 20 20 20 20 28 64 65 62 gin... (deb
64d0: 75 67 3a 70 72 69 6e 74 20 34 20 22 49 4e 46 4f ug:print 4 "INFO
64e0: 3a 20 70 72 6f 63 65 73 73 69 6e 67 20 74 68 65 : processing the
64f0: 20 63 61 73 65 20 77 69 74 68 20 61 20 6c 61 6d case with a lam
6500: 62 64 61 20 66 6f 72 20 69 74 65 6d 73 20 6f 72 bda for items or
6510: 20 27 68 61 76 65 2d 70 72 6f 63 65 64 75 72 65 'have-procedure
6520: 2e 20 4d 6f 76 69 6e 67 20 74 68 72 6f 75 67 68 . Moving through
6530: 20 74 68 65 20 71 75 65 75 65 20 77 69 74 68 6f the queue witho
6540: 75 74 20 64 72 6f 70 70 69 6e 67 20 22 20 68 65 ut dropping " he
6550: 64 29 0a 09 09 20 20 20 20 20 20 28 74 68 72 65 d)... (thre
6560: 61 64 2d 73 6c 65 65 70 21 20 28 2b 20 31 20 2a ad-sleep! (+ 1 *
6570: 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 29 0a global-delta*)).
6580: 09 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 .. (loop (c
6590: 61 72 20 6e 65 77 74 61 6c 29 28 63 64 72 20 6e ar newtal)(cdr n
65a0: 65 77 74 61 6c 29 20 72 65 72 75 6e 73 29 29 29 ewtal) reruns)))
65b0: 29 29 20 3b 3b 20 45 4e 44 20 4f 46 20 28 6f 72 )) ;; END OF (or
65c0: 20 28 70 72 6f 63 65 64 75 72 65 3f 20 69 74 65 (procedure? ite
65d0: 6d 73 29 28 65 71 3f 20 69 74 65 6d 73 20 27 68 ms)(eq? items 'h
65e0: 61 76 65 2d 70 72 6f 63 65 64 75 72 65 29 29 0a ave-procedure)).
65f0: 09 20 20 20 20 20 0a 09 20 20 20 20 20 3b 3b 20 . .. ;;
6600: 74 68 69 73 20 63 61 73 65 20 73 68 6f 75 6c 64 this case should
6610: 20 6e 6f 74 20 68 61 70 70 65 6e 2c 20 61 64 64 not happen, add
6620: 65 64 20 74 6f 20 68 65 6c 70 20 63 61 74 63 68 ed to help catch
6630: 20 61 6e 79 20 62 75 67 73 0a 09 20 20 20 20 20 any bugs..
6640: 28 28 61 6e 64 20 28 6c 69 73 74 3f 20 69 74 65 ((and (list? ite
6650: 6d 73 29 20 69 74 65 6d 64 61 74 29 0a 09 20 20 ms) itemdat)..
6660: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
6670: 20 30 20 22 45 52 52 4f 52 3a 20 53 68 6f 75 6c 0 "ERROR: Shoul
6680: 64 20 6e 6f 74 20 68 61 76 65 20 61 20 6c 69 73 d not have a lis
6690: 74 20 6f 66 20 69 74 65 6d 73 20 69 6e 20 61 20 t of items in a
66a0: 74 65 73 74 20 61 6e 64 20 74 68 65 20 69 74 65 test and the ite
66b0: 6d 73 70 61 74 68 20 73 65 74 20 2d 20 70 6c 65 mspath set - ple
66c0: 61 73 65 20 72 65 70 6f 72 74 20 74 68 69 73 22 ase report this"
66d0: 29 0a 09 20 20 20 20 20 20 28 65 78 69 74 20 31 ).. (exit 1
66e0: 29 29 0a 09 20 20 20 20 20 28 28 6e 6f 74 20 28 )).. ((not (
66f0: 6e 75 6c 6c 3f 20 72 65 72 75 6e 73 29 29 0a 09 null? reruns))..
6700: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 6e 65 (let* ((ne
6710: 77 6c 73 74 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 wlst (open-run-c
6720: 6c 6f 73 65 20 74 65 73 74 73 3a 66 69 6c 74 65 lose tests:filte
6730: 72 2d 6e 6f 6e 2d 72 75 6e 6e 61 62 6c 65 20 23 r-non-runnable #
6740: 66 20 72 75 6e 2d 69 64 20 74 61 6c 20 74 65 73 f run-id tal tes
6750: 74 2d 72 65 63 6f 72 64 73 29 29 20 3b 3b 20 69 t-records)) ;; i
6760: 2e 65 2e 20 6e 6f 74 20 46 41 49 4c 2c 20 57 41 .e. not FAIL, WA
6770: 49 56 45 44 2c 20 49 4e 43 4f 4d 50 4c 45 54 45 IVED, INCOMPLETE
6780: 2c 20 50 41 53 53 2c 20 4b 49 4c 4c 45 44 2c 0a , PASS, KILLED,.
6790: 09 09 20 20 20 20 20 28 6a 75 6e 6b 65 64 20 28 .. (junked (
67a0: 6c 73 65 74 2d 64 69 66 66 65 72 65 6e 63 65 20 lset-difference
67b0: 65 71 75 61 6c 3f 20 74 61 6c 20 6e 65 77 6c 73 equal? tal newls
67c0: 74 29 29 29 0a 09 09 28 64 65 62 75 67 3a 70 72 t)))...(debug:pr
67d0: 69 6e 74 20 34 20 22 49 4e 46 4f 3a 20 66 75 6c int 4 "INFO: ful
67e0: 6c 20 64 72 6f 70 20 74 68 72 6f 75 67 68 2c 20 l drop through,
67f0: 69 66 20 72 65 72 75 6e 73 20 69 73 20 6c 65 73 if reruns is les
6800: 73 20 74 68 61 6e 20 31 30 30 20 77 65 20 77 69 s than 100 we wi
6810: 6c 6c 20 66 6f 72 63 65 20 72 65 74 72 79 20 74 ll force retry t
6820: 68 65 6d 2c 20 72 65 72 75 6e 73 3d 22 20 72 65 hem, reruns=" re
6830: 72 75 6e 73 20 22 2c 20 74 61 6c 3d 22 20 74 61 runs ", tal=" ta
6840: 6c 29 0a 09 09 28 69 66 20 28 3c 20 6e 75 6d 2d l)...(if (< num-
6850: 72 65 74 72 69 65 73 20 6d 61 78 2d 72 65 74 72 retries max-retr
6860: 69 65 73 29 0a 09 09 20 20 20 20 28 73 65 74 21 ies)... (set!
6870: 20 6e 65 77 6c 73 74 20 28 61 70 70 65 6e 64 20 newlst (append
6880: 72 65 72 75 6e 73 20 6e 65 77 6c 73 74 29 29 29 reruns newlst)))
6890: 0a 09 09 28 73 65 74 21 20 6e 75 6d 2d 72 65 74 ...(set! num-ret
68a0: 72 69 65 73 20 28 2b 20 6e 75 6d 2d 72 65 74 72 ries (+ num-retr
68b0: 69 65 73 20 31 29 29 0a 09 09 28 74 68 72 65 61 ies 1))...(threa
68c0: 64 2d 73 6c 65 65 70 21 20 28 2b 20 31 20 2a 67 d-sleep! (+ 1 *g
68d0: 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 29 0a 09 lobal-delta*))..
68e0: 09 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f .(if (not (null?
68f0: 20 6e 65 77 6c 73 74 29 29 0a 09 09 20 20 20 20 newlst))...
6900: 3b 3b 20 73 69 6e 63 65 20 72 65 72 75 6e 73 20 ;; since reruns
6910: 68 61 76 65 20 62 65 65 6e 20 74 61 63 6b 65 64 have been tacked
6920: 20 6f 6e 20 74 6f 20 6e 65 77 6c 73 74 20 63 72 on to newlst cr
6930: 65 61 74 65 20 6e 65 77 20 72 65 72 75 6e 73 20 eate new reruns
6940: 66 72 6f 6d 20 6a 75 6e 6b 65 64 0a 09 09 20 20 from junked...
6950: 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 77 (loop (car new
6960: 6c 73 74 29 28 63 64 72 20 6e 65 77 6c 73 74 29 lst)(cdr newlst)
6970: 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 74 (delete-duplicat
6980: 65 73 20 6a 75 6e 6b 65 64 29 29 29 29 29 0a 09 es junked)))))..
6990: 20 20 20 20 20 28 28 6e 6f 74 20 28 6e 75 6c 6c ((not (null
69a0: 3f 20 74 61 6c 29 29 0a 09 20 20 20 20 20 20 28 ? tal)).. (
69b0: 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 49 debug:print 4 "I
69c0: 4e 46 4f 3a 20 49 27 6d 20 70 72 65 74 74 79 20 NFO: I'm pretty
69d0: 73 75 72 65 20 49 20 73 68 6f 75 6c 64 6e 27 74 sure I shouldn't
69e0: 20 67 65 74 20 68 65 72 65 2e 22 29 29 0a 09 20 get here."))..
69f0: 20 20 20 20 28 65 6c 73 65 0a 09 20 20 20 20 20 (else..
6a00: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 (debug:print 4
6a10: 22 49 4e 46 4f 3a 20 45 78 69 74 69 6e 67 20 6c "INFO: Exiting l
6a20: 6f 6f 70 20 77 69 74 68 2e 2e 2e 5c 6e 20 20 68 oop with...\n h
6a30: 65 64 3d 22 20 68 65 64 20 22 5c 6e 20 20 74 61 ed=" hed "\n ta
6a40: 6c 3d 22 20 74 61 6c 20 22 5c 6e 20 20 72 65 72 l=" tal "\n rer
6a50: 75 6e 73 3d 22 20 72 65 72 75 6e 73 29 29 0a 09 uns=" reruns))..
6a60: 20 20 20 20 20 29 29 29 29 20 3b 3b 20 4c 45 54 )))) ;; LET
6a70: 2a 20 28 28 74 65 73 74 2d 72 65 63 6f 72 64 0a * ((test-record.
6a80: 0a 20 20 20 20 3b 3b 20 77 65 20 67 65 74 20 68 . ;; we get h
6a90: 65 72 65 20 6f 6e 20 22 64 72 6f 70 20 74 68 72 ere on "drop thr
6aa0: 6f 75 67 68 22 20 2d 20 6c 6f 6f 70 20 66 6f 72 ough" - loop for
6ab0: 20 6e 65 78 74 20 74 65 73 74 20 69 6e 20 71 75 next test in qu
6ac0: 65 75 65 0a 20 20 20 20 3b 3b 20 46 49 58 4d 45 eue. ;; FIXME
6ad0: 21 21 21 21 20 54 48 49 53 20 53 48 4f 55 4c 44 !!!! THIS SHOULD
6ae0: 20 4e 4f 54 20 52 45 51 55 49 52 45 20 41 4e 20 NOT REQUIRE AN
6af0: 45 58 49 54 21 21 21 21 21 21 21 0a 20 20 20 20 EXIT!!!!!!!.
6b00: 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
6b10: 74 20 31 20 22 49 4e 46 4f 3a 20 41 6c 6c 20 74 t 1 "INFO: All t
6b20: 65 73 74 73 20 6c 61 75 6e 63 68 65 64 22 29 0a ests launched").
6b30: 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 (thread-slee
6b40: 70 21 20 30 2e 35 29 0a 20 20 20 20 3b 3b 20 46 p! 0.5). ;; F
6b50: 49 58 4d 45 21 20 54 68 69 73 20 68 61 72 73 68 IXME! This harsh
6b60: 20 65 78 69 74 20 73 68 6f 75 6c 64 20 6e 6f 74 exit should not
6b70: 20 62 65 20 6e 65 63 65 73 73 61 72 79 2e 2e 2e be necessary...
6b80: 2e 0a 20 20 20 20 3b 3b 20 28 69 66 20 28 6e 6f .. ;; (if (no
6b90: 74 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 29 28 65 t *runremote*)(e
6ba0: 78 69 74 29 29 20 3b 3b 20 0a 20 20 20 20 23 66 xit)) ;; . #f
6bb0: 29 29 20 3b 3b 20 72 65 74 75 72 6e 20 61 20 23 )) ;; return a #
6bc0: 66 20 61 73 20 61 20 68 69 6e 74 20 74 68 61 74 f as a hint that
6bd0: 20 77 65 20 61 72 65 20 64 6f 6e 65 0a 20 20 3b we are done. ;
6be0: 3b 20 48 65 72 65 20 77 65 20 6e 65 65 64 20 74 ; Here we need t
6bf0: 6f 20 63 68 65 63 6b 20 74 68 61 74 20 61 6c 6c o check that all
6c00: 20 74 68 65 20 74 65 73 74 73 20 72 65 6d 61 69 the tests remai
6c10: 6e 69 6e 67 20 74 6f 20 62 65 20 72 75 6e 20 61 ning to be run a
6c20: 72 65 20 65 6c 69 67 69 62 6c 65 20 74 6f 20 72 re eligible to r
6c30: 75 6e 0a 20 20 3b 3b 20 61 6e 64 20 61 72 65 20 un. ;; and are
6c40: 6e 6f 74 20 62 6c 6f 63 6b 65 64 20 62 79 20 66 not blocked by f
6c50: 61 69 6c 65 64 0a 20 20 0a 0a 3b 3b 20 70 61 72 ailed. ..;; par
6c60: 65 6e 74 2d 74 65 73 74 20 69 73 20 74 68 65 72 ent-test is ther
6c70: 65 20 61 73 20 61 20 70 6c 61 63 65 68 6f 6c 64 e as a placehold
6c80: 65 72 20 66 6f 72 20 77 68 65 6e 20 70 61 72 65 er for when pare
6c90: 6e 74 2d 74 65 73 74 73 20 63 61 6e 20 62 65 20 nt-tests can be
6ca0: 72 75 6e 20 61 73 20 61 20 73 65 74 75 70 20 73 run as a setup s
6cb0: 74 65 70 0a 28 64 65 66 69 6e 65 20 28 72 75 6e tep.(define (run
6cc0: 3a 74 65 73 74 20 72 75 6e 2d 69 64 20 72 75 6e :test run-id run
6cd0: 6e 61 6d 65 20 6b 65 79 76 61 6c 6c 73 74 20 74 name keyvallst t
6ce0: 65 73 74 2d 72 65 63 6f 72 64 20 66 6c 61 67 73 est-record flags
6cf0: 20 70 61 72 65 6e 74 2d 74 65 73 74 29 0a 20 20 parent-test).
6d00: 3b 3b 20 41 6c 6c 20 74 68 65 73 65 20 76 61 72 ;; All these var
6d10: 73 20 6d 69 67 68 74 20 62 65 20 72 65 66 65 72 s might be refer
6d20: 65 6e 63 65 64 20 62 79 20 74 68 65 20 74 65 73 enced by the tes
6d30: 74 63 6f 6e 66 69 67 20 66 69 6c 65 20 72 65 61 tconfig file rea
6d40: 64 65 72 0a 20 20 28 6c 65 74 2a 20 28 28 74 65 der. (let* ((te
6d50: 73 74 2d 6e 61 6d 65 20 20 20 20 28 74 65 73 74 st-name (test
6d60: 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d s:testqueue-get-
6d70: 74 65 73 74 6e 61 6d 65 20 20 20 74 65 73 74 2d testname test-
6d80: 72 65 63 6f 72 64 29 29 0a 09 20 28 74 65 73 74 record)).. (test
6d90: 2d 77 61 69 74 6f 6e 73 20 28 74 65 73 74 73 3a -waitons (tests:
6da0: 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 77 61 testqueue-get-wa
6db0: 69 74 6f 6e 73 20 20 20 20 74 65 73 74 2d 72 65 itons test-re
6dc0: 63 6f 72 64 29 29 0a 09 20 28 74 65 73 74 2d 63 cord)).. (test-c
6dd0: 6f 6e 66 20 20 20 20 28 74 65 73 74 73 3a 74 65 onf (tests:te
6de0: 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 73 74 stqueue-get-test
6df0: 63 6f 6e 66 69 67 20 74 65 73 74 2d 72 65 63 6f config test-reco
6e00: 72 64 29 29 0a 09 20 28 69 74 65 6d 64 61 74 20 rd)).. (itemdat
6e10: 20 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 (tests:test
6e20: 71 75 65 75 65 2d 67 65 74 2d 69 74 65 6d 64 61 queue-get-itemda
6e30: 74 20 20 20 20 74 65 73 74 2d 72 65 63 6f 72 64 t test-record
6e40: 29 29 0a 09 20 28 74 65 73 74 2d 70 61 74 68 20 )).. (test-path
6e50: 20 20 20 28 63 6f 6e 63 20 2a 74 6f 70 70 61 74 (conc *toppat
6e60: 68 2a 20 22 2f 74 65 73 74 73 2f 22 20 74 65 73 h* "/tests/" tes
6e70: 74 2d 6e 61 6d 65 29 29 20 3b 3b 20 63 6f 75 6c t-name)) ;; coul
6e80: 64 20 75 73 65 20 74 65 73 74 73 3a 67 65 74 2d d use tests:get-
6e90: 74 65 73 74 63 6f 6e 66 69 67 20 68 65 72 65 20 testconfig here
6ea0: 2e 2e 2e 0a 09 20 28 66 6f 72 63 65 20 20 20 20 ..... (force
6eb0: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
6ec0: 72 65 66 2f 64 65 66 61 75 6c 74 20 66 6c 61 67 ref/default flag
6ed0: 73 20 22 2d 66 6f 72 63 65 22 20 23 66 29 29 0a s "-force" #f)).
6ee0: 09 20 28 72 65 72 75 6e 20 20 20 20 20 20 20 20 . (rerun
6ef0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
6f00: 64 65 66 61 75 6c 74 20 66 6c 61 67 73 20 22 2d default flags "-
6f10: 72 65 72 75 6e 22 20 23 66 29 29 0a 09 20 28 6b rerun" #f)).. (k
6f20: 65 65 70 67 6f 69 6e 67 20 20 20 20 28 68 61 73 eepgoing (has
6f30: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
6f40: 75 6c 74 20 66 6c 61 67 73 20 22 2d 6b 65 65 70 ult flags "-keep
6f50: 67 6f 69 6e 67 22 20 23 66 29 29 0a 09 20 28 69 going" #f)).. (i
6f60: 74 65 6d 2d 70 61 74 68 20 20 20 20 20 22 22 29 tem-path "")
6f70: 0a 09 20 28 64 62 20 20 20 20 20 20 20 20 20 20 .. (db
6f80: 20 23 66 29 29 0a 20 20 20 20 28 64 65 62 75 67 #f)). (debug
6f90: 3a 70 72 69 6e 74 20 34 0a 09 09 20 22 74 65 73 :print 4... "tes
6fa0: 74 2d 63 6f 6e 66 69 67 3a 20 22 20 28 68 61 73 t-config: " (has
6fb0: 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 20 74 h-table->alist t
6fc0: 65 73 74 2d 63 6f 6e 66 29 0a 09 09 20 22 5c 6e est-conf)... "\n
6fd0: 20 20 20 69 74 65 6d 64 61 74 3a 20 22 20 69 74 itemdat: " it
6fe0: 65 6d 64 61 74 0a 09 09 20 29 0a 20 20 20 20 3b emdat... ). ;
6ff0: 3b 20 73 65 74 74 69 6e 67 20 69 74 65 6d 64 61 ; setting itemda
7000: 74 20 74 6f 20 61 20 6c 69 73 74 20 69 66 20 69 t to a list if i
7010: 74 20 69 73 20 23 66 0a 20 20 20 20 28 69 66 20 t is #f. (if
7020: 28 6e 6f 74 20 69 74 65 6d 64 61 74 29 28 73 65 (not itemdat)(se
7030: 74 21 20 69 74 65 6d 64 61 74 20 27 28 29 29 29 t! itemdat '()))
7040: 0a 20 20 20 20 28 73 65 74 21 20 69 74 65 6d 2d . (set! item-
7050: 70 61 74 68 20 28 69 74 65 6d 2d 6c 69 73 74 2d path (item-list-
7060: 3e 70 61 74 68 20 69 74 65 6d 64 61 74 29 29 0a >path itemdat)).
7070: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
7080: 20 32 20 22 41 74 74 65 6d 70 74 69 6e 67 20 74 2 "Attempting t
7090: 6f 20 6c 61 75 6e 63 68 20 74 65 73 74 20 22 20 o launch test "
70a0: 74 65 73 74 2d 6e 61 6d 65 20 28 69 66 20 28 65 test-name (if (e
70b0: 71 75 61 6c 3f 20 69 74 65 6d 2d 70 61 74 68 20 qual? item-path
70c0: 22 2f 22 29 20 22 2f 22 20 69 74 65 6d 2d 70 61 "/") "/" item-pa
70d0: 74 68 29 29 0a 20 20 20 20 28 73 65 74 65 6e 76 th)). (setenv
70e0: 20 22 4d 54 5f 54 45 53 54 5f 4e 41 4d 45 22 20 "MT_TEST_NAME"
70f0: 74 65 73 74 2d 6e 61 6d 65 29 20 3b 3b 20 0a 20 test-name) ;; .
7100: 20 20 20 28 73 65 74 65 6e 76 20 22 4d 54 5f 52 (setenv "MT_R
7110: 55 4e 4e 41 4d 45 22 20 20 20 72 75 6e 6e 61 6d UNNAME" runnam
7120: 65 29 0a 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e e). (open-run
7130: 2d 63 6c 6f 73 65 20 73 65 74 2d 6d 65 67 61 74 -close set-megat
7140: 65 73 74 2d 65 6e 76 2d 76 61 72 73 20 64 62 20 est-env-vars db
7150: 72 75 6e 2d 69 64 29 20 3b 3b 20 74 68 65 73 65 run-id) ;; these
7160: 20 6d 61 79 20 62 65 20 6e 65 65 64 65 64 20 62 may be needed b
7170: 79 20 74 68 65 20 6c 61 75 6e 63 68 69 6e 67 20 y the launching
7180: 70 72 6f 63 65 73 73 0a 20 20 20 20 28 63 68 61 process. (cha
7190: 6e 67 65 2d 64 69 72 65 63 74 6f 72 79 20 2a 74 nge-directory *t
71a0: 6f 70 70 61 74 68 2a 29 0a 0a 20 20 20 20 3b 3b oppath*).. ;;
71b0: 20 48 65 72 65 20 69 73 20 77 68 65 72 65 20 74 Here is where t
71c0: 68 65 20 74 65 73 74 5f 6d 65 74 61 20 74 61 62 he test_meta tab
71d0: 6c 65 20 69 73 20 62 65 73 74 20 75 70 64 61 74 le is best updat
71e0: 65 64 0a 20 20 20 20 3b 3b 20 59 65 73 2c 20 61 ed. ;; Yes, a
71f0: 6e 6f 74 68 65 72 20 75 73 65 20 6f 66 20 61 20 nother use of a
7200: 67 6c 6f 62 61 6c 20 66 6f 72 20 63 61 63 68 69 global for cachi
7210: 6e 67 2e 20 4e 65 65 64 20 61 20 62 65 74 74 65 ng. Need a bette
7220: 72 20 77 61 79 3f 0a 20 20 20 20 28 69 66 20 28 r way?. (if (
7230: 6e 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d not (hash-table-
7240: 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 74 65 73 ref/default *tes
7250: 74 2d 6d 65 74 61 2d 75 70 64 61 74 65 64 2a 20 t-meta-updated*
7260: 74 65 73 74 2d 6e 61 6d 65 20 23 66 29 29 0a 20 test-name #f)).
7270: 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 20 (begin..
7280: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
7290: 74 21 20 2a 74 65 73 74 2d 6d 65 74 61 2d 75 70 t! *test-meta-up
72a0: 64 61 74 65 64 2a 20 74 65 73 74 2d 6e 61 6d 65 dated* test-name
72b0: 20 23 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 #t).
72c0: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 (open-run-close
72d0: 72 75 6e 73 3a 75 70 64 61 74 65 2d 74 65 73 74 runs:update-test
72e0: 5f 6d 65 74 61 20 64 62 20 74 65 73 74 2d 6e 61 _meta db test-na
72f0: 6d 65 20 74 65 73 74 2d 63 6f 6e 66 29 29 29 0a me test-conf))).
7300: 20 20 20 20 0a 20 20 20 20 3b 3b 20 28 6c 61 6d . ;; (lam
7310: 62 64 61 20 28 69 74 65 6d 64 61 74 29 20 3b 3b bda (itemdat) ;;
7320: 3b 20 28 28 72 69 70 65 6e 65 73 73 20 22 6f 76 ; ((ripeness "ov
7330: 65 72 72 69 70 65 22 29 20 28 74 65 6d 70 65 72 erripe") (temper
7340: 61 74 75 72 65 20 22 63 6f 6f 6c 22 29 20 28 73 ature "cool") (s
7350: 65 61 73 6f 6e 20 22 73 75 6d 6d 65 72 22 29 29 eason "summer"))
7360: 0a 20 20 20 20 28 6c 65 74 2a 20 28 28 6e 65 77 . (let* ((new
7370: 2d 74 65 73 74 2d 70 61 74 68 20 28 73 74 72 69 -test-path (stri
7380: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 ng-intersperse (
7390: 63 6f 6e 73 20 74 65 73 74 2d 70 61 74 68 20 28 cons test-path (
73a0: 6d 61 70 20 63 61 64 72 20 69 74 65 6d 64 61 74 map cadr itemdat
73b0: 29 29 20 22 2f 22 29 29 0a 09 20 20 20 28 6e 65 )) "/")).. (ne
73c0: 77 2d 74 65 73 74 2d 6e 61 6d 65 20 28 69 66 20 w-test-name (if
73d0: 28 65 71 75 61 6c 3f 20 69 74 65 6d 2d 70 61 74 (equal? item-pat
73e0: 68 20 22 22 29 20 74 65 73 74 2d 6e 61 6d 65 20 h "") test-name
73f0: 28 63 6f 6e 63 20 74 65 73 74 2d 6e 61 6d 65 20 (conc test-name
7400: 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 29 29 "/" item-path)))
7410: 20 3b 3b 20 6a 75 73 74 20 6e 65 65 64 20 69 74 ;; just need it
7420: 20 74 6f 20 62 65 20 75 6e 69 71 75 65 0a 09 20 to be unique..
7430: 20 20 28 74 65 73 74 2d 69 64 20 20 20 20 20 20 (test-id
7440: 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 (open-run-close
7450: 20 64 62 3a 67 65 74 2d 74 65 73 74 2d 69 64 20 db:get-test-id
7460: 64 62 20 20 72 75 6e 2d 69 64 20 74 65 73 74 2d db run-id test-
7470: 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 name item-path))
7480: 0a 09 20 20 20 28 74 65 73 74 64 61 74 20 20 20 .. (testdat
7490: 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c (open-run-cl
74a0: 6f 73 65 20 64 62 3a 67 65 74 2d 74 65 73 74 2d ose db:get-test-
74b0: 69 6e 66 6f 2d 62 79 2d 69 64 20 64 62 20 74 65 info-by-id db te
74c0: 73 74 2d 69 64 29 29 29 0a 20 20 20 20 20 20 28 st-id))). (
74d0: 69 66 20 28 6e 6f 74 20 74 65 73 74 64 61 74 29 if (not testdat)
74e0: 0a 09 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 .. (begin..
74f0: 3b 3b 20 65 6e 73 75 72 65 20 74 68 61 74 20 74 ;; ensure that t
7500: 68 65 20 70 61 74 68 20 65 78 69 73 74 73 20 62 he path exists b
7510: 65 66 6f 72 65 20 72 65 67 69 73 74 65 72 69 6e efore registerin
7520: 67 20 74 68 65 20 74 65 73 74 0a 09 20 20 20 20 g the test..
7530: 3b 3b 20 4e 4f 50 45 3a 20 43 61 6e 6e 6f 74 21 ;; NOPE: Cannot!
7540: 20 44 6f 6e 27 74 20 6b 6e 6f 77 20 79 65 74 20 Don't know yet
7550: 77 68 69 63 68 20 64 69 73 6b 20 61 72 65 61 20 which disk area
7560: 77 69 6c 6c 20 62 65 20 61 73 73 69 67 6e 65 64 will be assigned
7570: 2e 2e 2e 2e 0a 09 20 20 20 20 3b 3b 20 28 73 79 ...... ;; (sy
7580: 73 74 65 6d 20 28 63 6f 6e 63 20 22 6d 6b 64 69 stem (conc "mkdi
7590: 72 20 2d 70 20 22 20 6e 65 77 2d 74 65 73 74 2d r -p " new-test-
75a0: 70 61 74 68 29 29 0a 09 20 20 20 20 3b 3b 0a 09 path)).. ;;..
75b0: 20 20 20 20 3b 3b 20 28 6f 70 65 6e 2d 72 75 6e ;; (open-run
75c0: 2d 63 6c 6f 73 65 20 74 65 73 74 73 3a 72 65 67 -close tests:reg
75d0: 69 73 74 65 72 2d 74 65 73 74 20 64 62 20 72 75 ister-test db ru
75e0: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 n-id test-name i
75f0: 74 65 6d 2d 70 61 74 68 29 0a 09 20 20 20 20 3b tem-path).. ;
7600: 3b 0a 09 20 20 20 20 3b 3b 20 4e 42 2f 2f 20 66 ;.. ;; NB// f
7610: 6f 72 20 74 68 65 20 61 62 6f 76 65 20 6c 69 6e or the above lin
7620: 65 2e 20 49 20 77 61 6e 74 20 74 68 65 20 74 65 e. I want the te
7630: 73 74 20 74 6f 20 62 65 20 72 65 67 69 73 74 65 st to be registe
7640: 72 65 64 20 6c 6f 6e 67 20 62 65 66 6f 72 65 20 red long before
7650: 74 68 69 73 20 72 6f 75 74 69 6e 65 20 67 65 74 this routine get
7660: 73 20 63 61 6c 6c 65 64 21 0a 09 20 20 20 20 3b s called!.. ;
7670: 3b 0a 09 20 20 20 20 28 73 65 74 21 20 74 65 73 ;.. (set! tes
7680: 74 2d 69 64 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 t-id (open-run-c
7690: 6c 6f 73 65 20 64 62 3a 67 65 74 2d 74 65 73 74 lose db:get-test
76a0: 2d 69 64 20 64 62 20 72 75 6e 2d 69 64 20 74 65 -id db run-id te
76b0: 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 st-name item-pat
76c0: 68 29 29 0a 09 20 20 20 20 28 69 66 20 28 6e 6f h)).. (if (no
76d0: 74 20 74 65 73 74 2d 69 64 29 0a 09 09 28 62 65 t test-id)...(be
76e0: 67 69 6e 0a 09 09 20 20 28 64 65 62 75 67 3a 70 gin... (debug:p
76f0: 72 69 6e 74 20 32 20 22 57 41 52 4e 3a 20 54 65 rint 2 "WARN: Te
7700: 73 74 20 6e 6f 74 20 70 72 65 2d 63 72 65 61 74 st not pre-creat
7710: 65 64 3f 20 74 65 73 74 2d 6e 61 6d 65 3d 22 20 ed? test-name="
7720: 74 65 73 74 2d 6e 61 6d 65 20 22 2c 20 69 74 65 test-name ", ite
7730: 6d 2d 70 61 74 68 3d 22 20 69 74 65 6d 2d 70 61 m-path=" item-pa
7740: 74 68 20 22 2c 20 72 75 6e 2d 69 64 3d 22 20 72 th ", run-id=" r
7750: 75 6e 2d 69 64 29 0a 09 09 20 20 28 6f 70 65 6e un-id)... (open
7760: 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 74 65 -run-close db:te
7770: 73 74 73 2d 72 65 67 69 73 74 65 72 2d 74 65 73 sts-register-tes
7780: 74 20 23 66 20 72 75 6e 2d 69 64 20 74 65 73 74 t #f run-id test
7790: 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 -name item-path)
77a0: 0a 09 09 20 20 28 73 65 74 21 20 74 65 73 74 2d ... (set! test-
77b0: 69 64 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f id (open-run-clo
77c0: 73 65 20 64 62 3a 67 65 74 2d 74 65 73 74 2d 69 se db:get-test-i
77d0: 64 20 64 62 20 72 75 6e 2d 69 64 20 74 65 73 74 d db run-id test
77e0: 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 -name item-path)
77f0: 29 29 29 0a 09 20 20 20 20 28 64 65 62 75 67 3a ))).. (debug:
7800: 70 72 69 6e 74 20 34 20 22 49 4e 46 4f 3a 20 74 print 4 "INFO: t
7810: 65 73 74 2d 69 64 3d 22 20 74 65 73 74 2d 69 64 est-id=" test-id
7820: 20 22 2c 20 72 75 6e 2d 69 64 3d 22 20 72 75 6e ", run-id=" run
7830: 2d 69 64 20 22 2c 20 74 65 73 74 2d 6e 61 6d 65 -id ", test-name
7840: 3d 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 2c 20 =" test-name ",
7850: 69 74 65 6d 2d 70 61 74 68 3d 5c 22 22 20 69 74 item-path=\"" it
7860: 65 6d 2d 70 61 74 68 20 22 5c 22 22 29 0a 09 20 em-path "\"")..
7870: 20 20 20 28 73 65 74 21 20 74 65 73 74 64 61 74 (set! testdat
7880: 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 (open-run-close
7890: 20 64 62 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 db:get-test-inf
78a0: 6f 2d 62 79 2d 69 64 20 64 62 20 74 65 73 74 2d o-by-id db test-
78b0: 69 64 29 29 29 29 0a 20 20 20 20 20 20 28 73 65 id)))). (se
78c0: 74 21 20 74 65 73 74 2d 69 64 20 28 64 62 3a 74 t! test-id (db:t
78d0: 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 64 est-get-id testd
78e0: 61 74 29 29 0a 20 20 20 20 20 20 28 63 68 61 6e at)). (chan
78f0: 67 65 2d 64 69 72 65 63 74 6f 72 79 20 74 65 73 ge-directory tes
7900: 74 2d 70 61 74 68 29 0a 20 20 20 20 20 20 28 63 t-path). (c
7910: 61 73 65 20 28 69 66 20 66 6f 72 63 65 20 3b 3b ase (if force ;;
7920: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
7930: 2d 66 6f 72 63 65 22 29 0a 09 09 27 4e 4f 54 5f -force")...'NOT_
7940: 53 54 41 52 54 45 44 0a 09 09 28 69 66 20 74 65 STARTED...(if te
7950: 73 74 64 61 74 0a 09 09 20 20 20 20 28 73 74 72 stdat... (str
7960: 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 74 65 73 ing->symbol (tes
7970: 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 t:get-state test
7980: 64 61 74 29 29 0a 09 09 20 20 20 20 27 66 61 69 dat))... 'fai
7990: 6c 65 64 2d 74 6f 2d 69 6e 73 65 72 74 29 29 0a led-to-insert)).
79a0: 09 28 28 66 61 69 6c 65 64 2d 74 6f 2d 69 6e 73 .((failed-to-ins
79b0: 65 72 74 29 0a 09 20 28 64 65 62 75 67 3a 70 72 ert).. (debug:pr
79c0: 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 46 61 int 0 "ERROR: Fa
79d0: 69 6c 65 64 20 74 6f 20 69 6e 73 65 72 74 20 74 iled to insert t
79e0: 68 65 20 72 65 63 6f 72 64 20 69 6e 74 6f 20 74 he record into t
79f0: 68 65 20 64 62 22 29 29 0a 09 28 28 4e 4f 54 5f he db"))..((NOT_
7a00: 53 54 41 52 54 45 44 20 43 4f 4d 50 4c 45 54 45 STARTED COMPLETE
7a10: 44 20 44 45 4c 45 54 45 44 29 0a 09 20 28 6c 65 D DELETED).. (le
7a20: 74 20 28 28 72 75 6e 66 6c 61 67 20 23 66 29 29 t ((runflag #f))
7a30: 0a 09 20 20 20 28 63 6f 6e 64 0a 09 20 20 20 20 .. (cond..
7a40: 3b 3b 20 2d 66 6f 72 63 65 2c 20 72 75 6e 20 6e ;; -force, run n
7a50: 6f 20 6d 61 74 74 65 72 20 77 68 61 74 0a 09 20 o matter what..
7a60: 20 20 20 28 66 6f 72 63 65 20 28 73 65 74 21 20 (force (set!
7a70: 72 75 6e 66 6c 61 67 20 23 74 29 29 0a 09 20 20 runflag #t))..
7a80: 20 20 3b 3b 20 4e 4f 54 5f 53 54 41 52 54 45 44 ;; NOT_STARTED
7a90: 2c 20 72 75 6e 20 6e 6f 20 6d 61 74 74 65 72 20 , run no matter
7aa0: 77 68 61 74 0a 09 20 20 20 20 28 28 6d 65 6d 62 what.. ((memb
7ab0: 65 72 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 er (test:get-sta
7ac0: 74 65 20 74 65 73 74 64 61 74 29 20 27 28 22 44 te testdat) '("D
7ad0: 45 4c 45 54 45 44 22 20 22 4e 4f 54 5f 53 54 41 ELETED" "NOT_STA
7ae0: 52 54 45 44 22 29 29 28 73 65 74 21 20 72 75 6e RTED"))(set! run
7af0: 66 6c 61 67 20 23 74 29 29 0a 09 20 20 20 20 3b flag #t)).. ;
7b00: 3b 20 6e 6f 74 20 2d 72 65 72 75 6e 20 61 6e 64 ; not -rerun and
7b10: 20 50 41 53 53 2c 20 57 41 52 4e 20 6f 72 20 43 PASS, WARN or C
7b20: 48 45 43 4b 2c 20 64 6f 20 6e 6f 20 72 75 6e 0a HECK, do no run.
7b30: 09 20 20 20 20 28 28 61 6e 64 20 28 6f 72 20 28 . ((and (or (
7b40: 6e 6f 74 20 72 65 72 75 6e 29 0a 09 09 20 20 20 not rerun)...
7b50: 20 20 20 6b 65 65 70 67 6f 69 6e 67 29 0a 09 09 keepgoing)...
7b60: 20 20 3b 3b 20 52 65 71 75 69 72 65 20 74 6f 20 ;; Require to
7b70: 66 6f 72 63 65 20 72 65 2d 72 75 6e 20 66 6f 72 force re-run for
7b80: 20 43 4f 4d 50 4c 45 54 45 44 20 6f 72 20 2a 61 COMPLETED or *a
7b90: 6e 79 74 68 69 6e 67 2a 20 2b 20 50 41 53 53 2c nything* + PASS,
7ba0: 57 41 52 4e 20 6f 72 20 43 48 45 43 4b 0a 09 09 WARN or CHECK...
7bb0: 20 20 28 6f 72 20 28 6d 65 6d 62 65 72 20 28 74 (or (member (t
7bc0: 65 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 est:get-status t
7bd0: 65 73 74 64 61 74 29 20 27 28 22 50 41 53 53 22 estdat) '("PASS"
7be0: 20 22 57 41 52 4e 22 20 22 43 48 45 43 4b 22 29 "WARN" "CHECK")
7bf0: 29 0a 09 09 20 20 20 20 20 20 28 6d 65 6d 62 65 )... (membe
7c00: 72 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 r (test:get-stat
7c10: 65 20 20 74 65 73 74 64 61 74 29 20 27 28 22 43 e testdat) '("C
7c20: 4f 4d 50 4c 45 54 45 44 22 29 29 29 29 20 0a 09 OMPLETED")))) ..
7c30: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
7c40: 74 20 32 20 22 49 4e 46 4f 3a 20 72 75 6e 6e 69 t 2 "INFO: runni
7c50: 6e 67 20 74 65 73 74 20 22 20 74 65 73 74 2d 6e ng test " test-n
7c60: 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 ame "/" item-pat
7c70: 68 20 22 20 73 75 70 70 72 65 73 73 65 64 20 61 h " suppressed a
7c80: 73 20 69 74 20 69 73 20 22 20 28 74 65 73 74 3a s it is " (test:
7c90: 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 64 61 get-state testda
7ca0: 74 29 20 22 20 61 6e 64 20 22 20 28 74 65 73 74 t) " and " (test
7cb0: 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 :get-status test
7cc0: 64 61 74 29 29 0a 09 20 20 20 20 20 28 73 65 74 dat)).. (set
7cd0: 21 20 72 75 6e 66 6c 61 67 20 23 66 29 29 0a 09 ! runflag #f))..
7ce0: 20 20 20 20 3b 3b 20 2d 72 65 72 75 6e 20 61 6e ;; -rerun an
7cf0: 64 20 73 74 61 74 75 73 20 69 73 20 6f 6e 65 20 d status is one
7d00: 6f 66 20 74 68 65 20 73 70 65 63 69 66 65 64 2c of the specifed,
7d10: 20 72 75 6e 20 69 74 0a 09 20 20 20 20 28 28 61 run it.. ((a
7d20: 6e 64 20 72 65 72 75 6e 0a 09 09 20 20 28 6c 65 nd rerun... (le
7d30: 74 2a 20 28 28 72 65 72 75 6e 6c 73 74 20 20 20 t* ((rerunlst
7d40: 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 72 65 (string-split re
7d50: 72 75 6e 20 22 2c 22 29 29 0a 09 09 09 20 28 6d run ",")).... (m
7d60: 75 73 74 2d 72 65 72 75 6e 20 28 6d 65 6d 62 65 ust-rerun (membe
7d70: 72 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 r (test:get-stat
7d80: 75 73 20 74 65 73 74 64 61 74 29 20 72 65 72 75 us testdat) reru
7d90: 6e 6c 73 74 29 29 29 0a 09 09 20 20 20 20 28 64 nlst)))... (d
7da0: 65 62 75 67 3a 70 72 69 6e 74 20 33 20 22 49 4e ebug:print 3 "IN
7db0: 46 4f 3a 20 2d 72 65 72 75 6e 20 6c 69 73 74 3a FO: -rerun list:
7dc0: 20 22 20 72 65 72 75 6e 20 22 2c 20 74 65 73 74 " rerun ", test
7dd0: 2d 73 74 61 74 75 73 3a 20 22 20 28 74 65 73 74 -status: " (test
7de0: 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 :get-status test
7df0: 64 61 74 29 22 2c 20 6d 75 73 74 2d 72 65 72 75 dat)", must-reru
7e00: 6e 3a 20 22 20 6d 75 73 74 2d 72 65 72 75 6e 29 n: " must-rerun)
7e10: 0a 09 09 20 20 20 20 6d 75 73 74 2d 72 65 72 75 ... must-reru
7e20: 6e 29 29 0a 09 20 20 20 20 20 28 64 65 62 75 67 n)).. (debug
7e30: 3a 70 72 69 6e 74 20 32 20 22 49 4e 46 4f 3a 20 :print 2 "INFO:
7e40: 52 65 72 75 6e 20 66 6f 72 63 65 64 20 66 6f 72 Rerun forced for
7e50: 20 74 65 73 74 20 22 20 74 65 73 74 2d 6e 61 6d test " test-nam
7e60: 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 e "/" item-path)
7e70: 0a 09 20 20 20 20 20 28 73 65 74 21 20 72 75 6e .. (set! run
7e80: 66 6c 61 67 20 23 74 29 29 0a 09 20 20 20 20 3b flag #t)).. ;
7e90: 3b 20 2d 6b 65 65 70 67 6f 69 6e 67 2c 20 64 6f ; -keepgoing, do
7ea0: 20 6e 6f 74 20 72 65 72 75 6e 20 46 41 49 4c 0a not rerun FAIL.
7eb0: 09 20 20 20 20 28 28 61 6e 64 20 6b 65 65 70 67 . ((and keepg
7ec0: 6f 69 6e 67 0a 09 09 20 20 28 6d 65 6d 62 65 72 oing... (member
7ed0: 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 75 (test:get-statu
7ee0: 73 20 74 65 73 74 64 61 74 29 20 27 28 22 46 41 s testdat) '("FA
7ef0: 49 4c 22 29 29 29 0a 09 20 20 20 20 20 28 73 65 IL"))).. (se
7f00: 74 21 20 72 75 6e 66 6c 61 67 20 23 66 29 29 0a t! runflag #f)).
7f10: 09 20 20 20 20 28 28 61 6e 64 20 28 6e 6f 74 20 . ((and (not
7f20: 72 65 72 75 6e 29 0a 09 09 20 20 28 6d 65 6d 62 rerun)... (memb
7f30: 65 72 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 er (test:get-sta
7f40: 74 75 73 20 74 65 73 74 64 61 74 29 20 27 28 22 tus testdat) '("
7f50: 46 41 49 4c 22 20 22 6e 2f 61 22 29 29 29 0a 09 FAIL" "n/a")))..
7f60: 20 20 20 20 20 28 73 65 74 21 20 72 75 6e 66 6c (set! runfl
7f70: 61 67 20 23 74 29 29 0a 09 20 20 20 20 28 65 6c ag #t)).. (el
7f80: 73 65 20 28 73 65 74 21 20 72 75 6e 66 6c 61 67 se (set! runflag
7f90: 20 23 66 29 29 29 0a 09 20 20 20 28 64 65 62 75 #f))).. (debu
7fa0: 67 3a 70 72 69 6e 74 20 36 20 22 52 55 4e 4e 49 g:print 6 "RUNNI
7fb0: 4e 47 20 3d 3e 20 72 75 6e 66 6c 61 67 3a 20 22 NG => runflag: "
7fc0: 20 72 75 6e 66 6c 61 67 20 22 20 53 54 41 54 45 runflag " STATE
7fd0: 3a 20 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 : " (test:get-st
7fe0: 61 74 65 20 74 65 73 74 64 61 74 29 20 22 20 53 ate testdat) " S
7ff0: 54 41 54 55 53 3a 20 22 20 28 74 65 73 74 3a 67 TATUS: " (test:g
8000: 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 et-status testda
8010: 74 29 29 0a 09 20 20 20 28 69 66 20 28 6e 6f 74 t)).. (if (not
8020: 20 72 75 6e 66 6c 61 67 29 0a 09 20 20 20 20 20 runflag)..
8030: 20 20 28 69 66 20 28 6e 6f 74 20 70 61 72 65 6e (if (not paren
8040: 74 2d 74 65 73 74 29 0a 09 09 20 20 20 28 64 65 t-test)... (de
8050: 62 75 67 3a 70 72 69 6e 74 20 31 20 22 4e 4f 54 bug:print 1 "NOT
8060: 45 3a 20 4e 6f 74 20 73 74 61 72 74 69 6e 67 20 E: Not starting
8070: 74 65 73 74 20 22 20 6e 65 77 2d 74 65 73 74 2d test " new-test-
8080: 6e 61 6d 65 20 22 20 61 73 20 69 74 20 69 73 20 name " as it is
8090: 73 74 61 74 65 20 5c 22 22 20 28 74 65 73 74 3a state \"" (test:
80a0: 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 64 61 get-state testda
80b0: 74 29 20 0a 09 09 09 09 22 5c 22 20 61 6e 64 20 t) ....."\" and
80c0: 73 74 61 74 75 73 20 5c 22 22 20 28 74 65 73 74 status \"" (test
80d0: 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 :get-status test
80e0: 64 61 74 29 20 22 5c 22 2c 20 75 73 65 20 2d 72 dat) "\", use -r
80f0: 65 72 75 6e 20 5c 22 22 20 28 74 65 73 74 3a 67 erun \"" (test:g
8100: 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 et-status testda
8110: 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 t).
8120: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8130: 20 20 20 22 5c 22 20 6f 72 20 2d 66 6f 72 63 65 "\" or -force
8140: 20 74 6f 20 6f 76 65 72 72 69 64 65 22 29 29 0a to override")).
8150: 09 20 20 20 20 20 20 20 3b 3b 20 4e 4f 54 45 3a . ;; NOTE:
8160: 20 4e 6f 20 6c 6f 6e 67 65 72 20 62 65 20 63 68 No longer be ch
8170: 65 63 6b 69 6e 67 20 70 72 65 72 65 71 75 69 73 ecking prerequis
8180: 69 74 65 73 20 68 65 72 65 21 20 57 69 6c 6c 20 ites here! Will
8190: 6e 65 76 65 72 20 67 65 74 20 68 65 72 65 20 75 never get here u
81a0: 6e 6c 65 73 73 20 70 72 65 72 65 71 73 20 61 72 nless prereqs ar
81b0: 65 0a 09 20 20 20 20 20 20 20 3b 3b 20 20 20 20 e.. ;;
81c0: 20 20 20 61 6c 72 65 61 64 79 20 6d 65 74 2e 0a already met..
81d0: 09 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 . (if (not
81e0: 20 28 6c 61 75 6e 63 68 2d 74 65 73 74 20 23 66 (launch-test #f
81f0: 20 72 75 6e 2d 69 64 20 72 75 6e 6e 61 6d 65 20 run-id runname
8200: 74 65 73 74 2d 63 6f 6e 66 20 6b 65 79 76 61 6c test-conf keyval
8210: 6c 73 74 20 74 65 73 74 2d 6e 61 6d 65 20 74 65 lst test-name te
8220: 73 74 2d 70 61 74 68 20 69 74 65 6d 64 61 74 20 st-path itemdat
8230: 66 6c 61 67 73 29 29 0a 09 09 20 20 20 28 62 65 flags))... (be
8240: 67 69 6e 0a 09 09 20 20 20 20 20 28 70 72 69 6e gin... (prin
8250: 74 20 22 45 52 52 4f 52 3a 20 46 61 69 6c 65 64 t "ERROR: Failed
8260: 20 74 6f 20 6c 61 75 6e 63 68 20 74 68 65 20 74 to launch the t
8270: 65 73 74 2e 20 45 78 69 74 69 6e 67 20 61 73 20 est. Exiting as
8280: 73 6f 6f 6e 20 61 73 20 70 6f 73 73 69 62 6c 65 soon as possible
8290: 22 29 0a 09 09 20 20 20 20 20 28 73 65 74 21 20 ")... (set!
82a0: 2a 67 6c 6f 62 61 6c 65 78 69 74 73 74 61 74 75 *globalexitstatu
82b0: 73 2a 20 31 29 20 3b 3b 20 0a 09 09 20 20 20 20 s* 1) ;; ...
82c0: 20 28 70 72 6f 63 65 73 73 2d 73 69 67 6e 61 6c (process-signal
82d0: 20 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 (current-proces
82e0: 73 2d 69 64 29 20 73 69 67 6e 61 6c 2f 6b 69 6c s-id) signal/kil
82f0: 6c 29 29 29 29 29 29 0a 09 28 28 4b 49 4c 4c 45 l))))))..((KILLE
8300: 44 29 20 0a 09 20 28 64 65 62 75 67 3a 70 72 69 D) .. (debug:pri
8310: 6e 74 20 31 20 22 4e 4f 54 45 3a 20 22 20 6e 65 nt 1 "NOTE: " ne
8320: 77 2d 74 65 73 74 2d 6e 61 6d 65 20 22 20 69 73 w-test-name " is
8330: 20 61 6c 72 65 61 64 79 20 72 75 6e 6e 69 6e 67 already running
8340: 20 6f 72 20 77 61 73 20 65 78 70 6c 69 63 74 6c or was explictl
8350: 79 20 6b 69 6c 6c 65 64 2c 20 75 73 65 20 2d 66 y killed, use -f
8360: 6f 72 63 65 20 74 6f 20 6c 61 75 6e 63 68 20 69 orce to launch i
8370: 74 2e 22 29 29 0a 09 28 28 4c 41 55 4e 43 48 45 t."))..((LAUNCHE
8380: 44 20 52 45 4d 4f 54 45 48 4f 53 54 53 54 41 52 D REMOTEHOSTSTAR
8390: 54 20 52 55 4e 4e 49 4e 47 29 20 20 0a 09 20 28 T RUNNING) .. (
83a0: 69 66 20 28 3e 20 28 2d 20 28 63 75 72 72 65 6e if (> (- (curren
83b0: 74 2d 73 65 63 6f 6e 64 73 29 28 2b 20 28 64 62 t-seconds)(+ (db
83c0: 3a 74 65 73 74 2d 67 65 74 2d 65 76 65 6e 74 5f :test-get-event_
83d0: 74 69 6d 65 20 74 65 73 74 64 61 74 29 0a 09 09 time testdat)...
83e0: 09 09 20 20 20 20 20 20 20 28 64 62 3a 74 65 73 .. (db:tes
83f0: 74 2d 67 65 74 2d 72 75 6e 5f 64 75 72 61 74 69 t-get-run_durati
8400: 6f 6e 20 74 65 73 74 64 61 74 29 29 29 0a 09 09 on testdat)))...
8410: 36 30 30 29 20 3b 3b 20 69 2e 65 2e 20 6e 6f 20 600) ;; i.e. no
8420: 75 70 64 61 74 65 20 66 6f 72 20 6d 6f 72 65 20 update for more
8430: 74 68 61 6e 20 36 30 30 20 73 65 63 6f 6e 64 73 than 600 seconds
8440: 0a 09 20 20 20 20 20 28 62 65 67 69 6e 0a 09 20 .. (begin..
8450: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
8460: 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 54 nt 0 "WARNING: T
8470: 65 73 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 est " test-name
8480: 22 20 61 70 70 65 61 72 73 20 74 6f 20 62 65 20 " appears to be
8490: 64 65 61 64 2e 20 46 6f 72 63 69 6e 67 20 69 74 dead. Forcing it
84a0: 20 74 6f 20 73 74 61 74 65 20 49 4e 43 4f 4d 50 to state INCOMP
84b0: 4c 45 54 45 20 61 6e 64 20 73 74 61 74 75 73 20 LETE and status
84c0: 53 54 55 43 4b 2f 44 45 41 44 22 29 0a 09 20 20 STUCK/DEAD")..
84d0: 20 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 (tests:test
84e0: 2d 73 65 74 2d 73 74 61 74 75 73 21 20 74 65 73 -set-status! tes
84f0: 74 2d 69 64 20 22 49 4e 43 4f 4d 50 4c 45 54 45 t-id "INCOMPLETE
8500: 22 20 22 53 54 55 43 4b 2f 44 45 41 44 22 20 22 " "STUCK/DEAD" "
8510: 54 65 73 74 20 69 73 20 73 74 75 63 6b 20 6f 72 Test is stuck or
8520: 20 64 65 61 64 22 20 23 66 29 29 0a 09 20 20 20 dead" #f))..
8530: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 (debug:print 2
8540: 20 22 4e 4f 54 45 3a 20 22 20 74 65 73 74 2d 6e "NOTE: " test-n
8550: 61 6d 65 20 22 20 69 73 20 61 6c 72 65 61 64 79 ame " is already
8560: 20 72 75 6e 6e 69 6e 67 22 29 29 29 0a 09 28 65 running")))..(e
8570: 6c 73 65 20 20 20 20 20 20 20 28 64 65 62 75 67 lse (debug
8580: 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a :print 0 "ERROR:
8590: 20 46 61 69 6c 65 64 20 74 6f 20 6c 61 75 6e 63 Failed to launc
85a0: 68 20 74 65 73 74 20 22 20 6e 65 77 2d 74 65 73 h test " new-tes
85b0: 74 2d 6e 61 6d 65 20 22 2e 20 55 6e 72 65 63 6f t-name ". Unreco
85c0: 67 6e 69 73 65 64 20 73 74 61 74 65 20 22 20 28 gnised state " (
85d0: 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 test:get-state t
85e0: 65 73 74 64 61 74 29 29 29 29 29 29 29 0a 0a 3b estdat)))))))..;
85f0: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
8600: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8610: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8620: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8630: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 45 4e 44 20 4f =======.;; END O
8640: 46 20 4e 45 57 20 53 54 55 46 46 0a 3b 3b 3d 3d F NEW STUFF.;;==
8650: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8660: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8670: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8680: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8690: 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 67 ====..(define (g
86a0: 65 74 2d 64 69 72 2d 75 70 2d 6e 20 64 69 72 20 et-dir-up-n dir
86b0: 2e 20 70 61 72 61 6d 73 29 20 0a 20 20 28 6c 65 . params) . (le
86c0: 74 20 28 28 64 70 61 72 74 73 20 20 28 73 74 72 t ((dparts (str
86d0: 69 6e 67 2d 73 70 6c 69 74 20 64 69 72 20 22 2f ing-split dir "/
86e0: 22 29 29 0a 09 28 63 6f 75 6e 74 20 20 20 28 69 "))..(count (i
86f0: 66 20 28 6e 75 6c 6c 3f 20 70 61 72 61 6d 73 29 f (null? params)
8700: 20 31 20 28 63 61 72 20 70 61 72 61 6d 73 29 29 1 (car params))
8710: 29 29 0a 20 20 20 20 28 63 6f 6e 63 20 22 2f 22 )). (conc "/"
8720: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
8730: 65 72 73 65 20 0a 09 20 20 20 20 20 20 20 28 74 erse .. (t
8740: 61 6b 65 20 64 70 61 72 74 73 20 28 2d 20 28 6c ake dparts (- (l
8750: 65 6e 67 74 68 20 64 70 61 72 74 73 29 20 63 6f ength dparts) co
8760: 75 6e 74 29 29 0a 09 20 20 20 20 20 20 20 22 2f unt)).. "/
8770: 22 29 29 29 29 0a 3b 3b 20 52 65 6d 6f 76 65 20 ")))).;; Remove
8780: 72 75 6e 73 0a 3b 3b 20 66 69 65 6c 64 73 20 61 runs.;; fields a
8790: 72 65 20 70 61 73 73 69 6e 67 20 69 6e 20 74 68 re passing in th
87a0: 72 6f 75 67 68 20 0a 3b 3b 20 61 63 74 69 6f 6e rough .;; action
87b0: 3a 0a 3b 3b 20 20 20 20 27 72 65 6d 6f 76 65 2d :.;; 'remove-
87c0: 72 75 6e 73 0a 3b 3b 20 20 20 20 27 73 65 74 2d runs.;; 'set-
87d0: 73 74 61 74 65 2d 73 74 61 74 75 73 0a 3b 3b 0a state-status.;;.
87e0: 3b 3b 20 4e 42 2f 2f 20 73 68 6f 75 6c 64 20 70 ;; NB// should p
87f0: 61 73 73 20 69 6e 20 6b 65 79 73 3f 0a 3b 3b 0a ass in keys?.;;.
8800: 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 6f 70 (define (runs:op
8810: 65 72 61 74 65 2d 6f 6e 20 61 63 74 69 6f 6e 20 erate-on action
8820: 72 75 6e 6e 61 6d 65 70 61 74 74 20 74 65 73 74 runnamepatt test
8830: 70 61 74 74 20 23 21 6b 65 79 20 28 73 74 61 74 patt #!key (stat
8840: 65 20 23 66 29 28 73 74 61 74 75 73 20 23 66 29 e #f)(status #f)
8850: 28 6e 65 77 2d 73 74 61 74 65 2d 73 74 61 74 75 (new-state-statu
8860: 73 20 23 66 29 29 0a 20 20 28 6c 65 74 2a 20 28 s #f)). (let* (
8870: 28 64 62 20 20 20 20 20 20 20 20 20 20 20 23 66 (db #f
8880: 29 0a 09 20 28 6b 65 79 73 20 20 20 20 20 20 20 ).. (keys
8890: 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 (open-run-clos
88a0: 65 20 64 62 3a 67 65 74 2d 6b 65 79 73 20 64 62 e db:get-keys db
88b0: 29 29 0a 09 20 28 72 75 6e 64 61 74 20 20 20 20 )).. (rundat
88c0: 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f (open-run-clo
88d0: 73 65 20 72 75 6e 73 3a 67 65 74 2d 72 75 6e 73 se runs:get-runs
88e0: 2d 62 79 2d 70 61 74 74 20 64 62 20 6b 65 79 73 -by-patt db keys
88f0: 20 72 75 6e 6e 61 6d 65 70 61 74 74 29 29 0a 09 runnamepatt))..
8900: 20 28 68 65 61 64 65 72 20 20 20 20 20 20 20 28 (header (
8910: 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 64 61 vector-ref runda
8920: 74 20 30 29 29 0a 09 20 28 72 75 6e 73 20 20 20 t 0)).. (runs
8930: 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 (vector-re
8940: 66 20 72 75 6e 64 61 74 20 31 29 29 0a 09 20 28 f rundat 1)).. (
8950: 73 74 61 74 65 73 20 20 20 20 20 20 20 28 69 66 states (if
8960: 20 73 74 61 74 65 20 20 28 73 74 72 69 6e 67 2d state (string-
8970: 73 70 6c 69 74 20 73 74 61 74 65 20 20 22 2c 22 split state ","
8980: 29 20 27 28 29 29 29 0a 09 20 28 73 74 61 74 75 ) '())).. (statu
8990: 73 65 73 20 20 20 20 20 28 69 66 20 73 74 61 74 ses (if stat
89a0: 75 73 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 us (string-split
89b0: 20 73 74 61 74 75 73 20 22 2c 22 29 20 27 28 29 status ",") '()
89c0: 29 29 0a 09 20 28 73 74 61 74 65 2d 73 74 61 74 )).. (state-stat
89d0: 75 73 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 us (if (string?
89e0: 6e 65 77 2d 73 74 61 74 65 2d 73 74 61 74 75 73 new-state-status
89f0: 29 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 ) (string-split
8a00: 6e 65 77 2d 73 74 61 74 65 2d 73 74 61 74 75 73 new-state-status
8a10: 20 22 2c 22 29 20 27 28 23 66 20 23 66 29 29 29 ",") '(#f #f)))
8a20: 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 ). (debug:pri
8a30: 6e 74 20 34 20 22 49 4e 46 4f 3a 20 72 75 6e 73 nt 4 "INFO: runs
8a40: 3a 6f 70 65 72 61 74 65 2d 6f 6e 20 3d 3e 20 48 :operate-on => H
8a50: 65 61 64 65 72 3a 20 22 20 68 65 61 64 65 72 20 eader: " header
8a60: 22 20 61 63 74 69 6f 6e 3a 20 22 20 61 63 74 69 " action: " acti
8a70: 6f 6e 20 22 20 6e 65 77 2d 73 74 61 74 65 2d 73 on " new-state-s
8a80: 74 61 74 75 73 3a 20 22 20 6e 65 77 2d 73 74 61 tatus: " new-sta
8a90: 74 65 2d 73 74 61 74 75 73 29 0a 20 20 20 20 28 te-status). (
8aa0: 69 66 20 28 3e 20 32 20 28 6c 65 6e 67 74 68 20 if (> 2 (length
8ab0: 73 74 61 74 65 2d 73 74 61 74 75 73 29 29 0a 09 state-status))..
8ac0: 28 62 65 67 69 6e 0a 09 20 20 28 64 65 62 75 67 (begin.. (debug
8ad0: 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a :print 0 "ERROR:
8ae0: 20 74 68 65 20 70 61 72 61 6d 65 74 65 72 20 74 the parameter t
8af0: 6f 20 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 o -set-state-sta
8b00: 74 75 73 20 69 73 20 61 20 63 6f 6d 6d 61 20 64 tus is a comma d
8b10: 65 6c 69 6d 69 74 65 64 20 73 74 72 69 6e 67 2e elimited string.
8b20: 20 45 2e 67 2e 20 43 4f 4d 50 4c 45 54 45 44 2c E.g. COMPLETED,
8b30: 46 41 49 4c 22 29 0a 09 20 20 28 65 78 69 74 29 FAIL").. (exit)
8b40: 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 )). (for-each
8b50: 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 72 . (lambda (r
8b60: 75 6e 29 0a 20 20 20 20 20 20 20 28 6c 65 74 20 un). (let
8b70: 28 28 72 75 6e 6b 65 79 20 28 73 74 72 69 6e 67 ((runkey (string
8b80: 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 -intersperse (ma
8b90: 70 20 28 6c 61 6d 62 64 61 20 28 6b 29 0a 09 09 p (lambda (k)...
8ba0: 09 09 09 09 28 64 62 3a 67 65 74 2d 76 61 6c 75 ....(db:get-valu
8bb0: 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 e-by-header run
8bc0: 68 65 61 64 65 72 20 28 76 65 63 74 6f 72 2d 72 header (vector-r
8bd0: 65 66 20 6b 20 30 29 29 29 20 6b 65 79 73 29 20 ef k 0))) keys)
8be0: 22 2f 22 29 29 0a 09 20 20 20 20 20 28 64 69 72 "/")).. (dir
8bf0: 73 2d 74 6f 2d 72 65 6d 6f 76 65 20 28 6d 61 6b s-to-remove (mak
8c00: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 0a e-hash-table))).
8c10: 09 20 28 6c 65 74 2a 20 28 28 72 75 6e 2d 69 64 . (let* ((run-id
8c20: 20 20 20 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 (db:get-valu
8c30: 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 e-by-header run
8c40: 68 65 61 64 65 72 20 22 69 64 22 29 29 0a 09 09 header "id"))...
8c50: 28 72 75 6e 2d 73 74 61 74 65 20 28 64 62 3a 67 (run-state (db:g
8c60: 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 et-value-by-head
8c70: 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 73 er run header "s
8c80: 74 61 74 65 22 29 29 0a 09 09 28 74 65 73 74 73 tate"))...(tests
8c90: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 65 (if (not (e
8ca0: 71 75 61 6c 3f 20 72 75 6e 2d 73 74 61 74 65 20 qual? run-state
8cb0: 22 6c 6f 63 6b 65 64 22 29 29 0a 09 09 09 20 20 "locked"))....
8cc0: 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 (open-run-c
8cd0: 6c 6f 73 65 20 64 62 3a 67 65 74 2d 74 65 73 74 lose db:get-test
8ce0: 73 2d 66 6f 72 2d 72 75 6e 20 64 62 20 72 75 6e s-for-run db run
8cf0: 2d 69 64 0a 09 09 09 09 09 09 20 20 20 20 20 20 -id.......
8d00: 74 65 73 74 70 61 74 74 20 73 74 61 74 65 73 20 testpatt states
8d10: 73 74 61 74 75 73 65 73 0a 09 09 09 09 09 09 20 statuses.......
8d20: 20 20 20 20 20 6e 6f 74 2d 69 6e 3a 20 20 23 66 not-in: #f
8d30: 0a 09 09 09 09 09 09 20 20 20 20 20 20 73 6f 72 ....... sor
8d40: 74 2d 62 79 3a 20 28 63 61 73 65 20 61 63 74 69 t-by: (case acti
8d50: 6f 6e 0a 09 09 09 09 09 09 09 09 20 28 28 72 65 on......... ((re
8d60: 6d 6f 76 65 2d 72 75 6e 73 29 20 27 72 75 6e 64 move-runs) 'rund
8d70: 69 72 29 0a 09 09 09 09 09 09 09 09 20 28 65 6c ir)......... (el
8d80: 73 65 20 20 20 20 20 20 20 20 20 20 27 65 76 65 se 'eve
8d90: 6e 74 5f 74 69 6d 65 29 29 29 0a 09 09 09 20 20 nt_time)))....
8da0: 20 20 20 20 20 27 28 29 29 29 0a 09 09 28 6c 61 '()))...(la
8db0: 73 74 74 70 61 74 68 20 22 2f 64 6f 65 73 2f 6e sttpath "/does/n
8dc0: 6f 74 2f 65 78 69 73 74 2f 49 2f 68 6f 70 65 22 ot/exist/I/hope"
8dd0: 29 29 0a 09 20 20 20 28 64 65 62 75 67 3a 70 72 )).. (debug:pr
8de0: 69 6e 74 20 34 20 22 49 4e 46 4f 3a 20 72 75 6e int 4 "INFO: run
8df0: 73 3a 6f 70 65 72 61 74 65 2d 6f 6e 20 72 75 6e s:operate-on run
8e00: 3d 22 20 72 75 6e 20 22 2c 20 68 65 61 64 65 72 =" run ", header
8e10: 3d 22 20 68 65 61 64 65 72 29 0a 09 20 20 20 28 =" header).. (
8e20: 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 if (not (null? t
8e30: 65 73 74 73 29 29 0a 09 20 20 20 20 20 20 20 28 ests)).. (
8e40: 62 65 67 69 6e 0a 09 09 20 28 63 61 73 65 20 61 begin... (case a
8e50: 63 74 69 6f 6e 0a 09 09 20 20 20 28 28 72 65 6d ction... ((rem
8e60: 6f 76 65 2d 72 75 6e 73 29 0a 09 09 20 20 20 20 ove-runs)...
8e70: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 (debug:print 1 "
8e80: 52 65 6d 6f 76 69 6e 67 20 74 65 73 74 73 20 66 Removing tests f
8e90: 6f 72 20 72 75 6e 3a 20 22 20 72 75 6e 6b 65 79 or run: " runkey
8ea0: 20 22 20 22 20 28 64 62 3a 67 65 74 2d 76 61 6c " " (db:get-val
8eb0: 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e ue-by-header run
8ec0: 20 68 65 61 64 65 72 20 22 72 75 6e 6e 61 6d 65 header "runname
8ed0: 22 29 29 29 0a 09 09 20 20 20 28 28 73 65 74 2d ")))... ((set-
8ee0: 73 74 61 74 65 2d 73 74 61 74 75 73 29 0a 09 09 state-status)...
8ef0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
8f00: 20 31 20 22 4d 6f 64 69 66 79 69 6e 67 20 73 74 1 "Modifying st
8f10: 61 74 65 20 61 6e 64 20 73 74 61 75 73 20 66 6f ate and staus fo
8f20: 72 20 74 65 73 74 73 20 66 6f 72 20 72 75 6e 3a r tests for run:
8f30: 20 22 20 72 75 6e 6b 65 79 20 22 20 22 20 28 64 " runkey " " (d
8f40: 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 b:get-value-by-h
8f50: 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 eader run header
8f60: 20 22 72 75 6e 6e 61 6d 65 22 29 29 29 0a 09 09 "runname")))...
8f70: 20 20 20 28 28 70 72 69 6e 74 2d 72 75 6e 29 0a ((print-run).
8f80: 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
8f90: 6e 74 20 31 20 22 50 72 69 6e 74 69 6e 67 20 69 nt 1 "Printing i
8fa0: 6e 66 6f 20 66 6f 72 20 72 75 6e 20 22 20 72 75 nfo for run " ru
8fb0: 6e 6b 65 79 20 22 2c 20 72 75 6e 3d 22 20 72 75 nkey ", run=" ru
8fc0: 6e 20 22 2c 20 74 65 73 74 73 3d 22 20 74 65 73 n ", tests=" tes
8fd0: 74 73 20 22 2c 20 68 65 61 64 65 72 3d 22 20 68 ts ", header=" h
8fe0: 65 61 64 65 72 29 0a 09 09 20 20 20 20 61 63 74 eader)... act
8ff0: 69 6f 6e 29 0a 09 09 20 20 20 28 65 6c 73 65 0a ion)... (else.
9000: 09 09 20 20 20 20 28 70 72 69 6e 74 20 22 49 4e .. (print "IN
9010: 46 4f 3a 20 61 63 74 69 6f 6e 20 6e 6f 74 20 72 FO: action not r
9020: 65 63 6f 67 6e 69 73 65 64 20 22 20 61 63 74 69 ecognised " acti
9030: 6f 6e 29 29 29 0a 09 09 20 28 66 6f 72 2d 65 61 on)))... (for-ea
9040: 63 68 0a 09 09 20 20 28 6c 61 6d 62 64 61 20 28 ch... (lambda (
9050: 74 65 73 74 29 0a 09 09 20 20 20 20 28 6c 65 74 test)... (let
9060: 2a 20 28 28 69 74 65 6d 2d 70 61 74 68 20 28 64 * ((item-path (d
9070: 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d b:test-get-item-
9080: 70 61 74 68 20 74 65 73 74 29 29 0a 09 09 09 20 path test))....
9090: 20 20 28 74 65 73 74 2d 6e 61 6d 65 20 28 64 62 (test-name (db
90a0: 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 :test-get-testna
90b0: 6d 65 20 74 65 73 74 29 29 0a 09 09 09 20 20 20 me test))....
90c0: 28 72 75 6e 2d 64 69 72 20 20 20 28 64 62 3a 74 (run-dir (db:t
90d0: 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 20 74 est-get-rundir t
90e0: 65 73 74 29 29 20 20 20 20 3b 3b 20 72 75 6e 20 est)) ;; run
90f0: 64 69 72 20 69 73 20 66 72 6f 6d 20 74 68 65 20 dir is from the
9100: 6c 69 6e 6b 20 74 72 65 65 0a 09 09 09 20 20 20 link tree....
9110: 28 72 65 61 6c 2d 64 69 72 20 20 28 69 66 20 28 (real-dir (if (
9120: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 72 75 6e file-exists? run
9130: 2d 64 69 72 29 0a 09 09 09 09 09 20 20 28 72 65 -dir)...... (re
9140: 73 6f 6c 76 65 2d 70 61 74 68 6e 61 6d 65 20 72 solve-pathname r
9150: 75 6e 2d 64 69 72 29 0a 09 09 09 09 09 20 20 23 un-dir)...... #
9160: 66 29 29 0a 09 09 09 20 20 20 28 74 65 73 74 2d f)).... (test-
9170: 69 64 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 id (db:test-ge
9180: 74 2d 69 64 20 74 65 73 74 29 29 29 0a 09 09 20 t-id test)))...
9190: 20 20 20 20 20 3b 3b 20 20 20 28 74 64 62 20 20 ;; (tdb
91a0: 20 20 20 20 20 28 64 62 3a 6f 70 65 6e 2d 74 65 (db:open-te
91b0: 73 74 2d 64 62 20 72 75 6e 2d 64 69 72 29 29 29 st-db run-dir)))
91c0: 0a 09 09 20 20 20 20 20 20 28 64 65 62 75 67 3a ... (debug:
91d0: 70 72 69 6e 74 20 34 20 22 49 4e 46 4f 3a 20 74 print 4 "INFO: t
91e0: 65 73 74 3d 22 20 74 65 73 74 29 20 3b 3b 20 20 est=" test) ;;
91f0: 20 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d " (db:test-get-
9200: 74 65 73 74 6e 61 6d 65 20 74 65 73 74 29 20 22 testname test) "
9210: 20 69 64 3a 20 22 20 28 64 62 3a 74 65 73 74 2d id: " (db:test-
9220: 67 65 74 2d 69 64 20 74 65 73 74 29 20 22 20 22 get-id test) " "
9230: 20 69 74 65 6d 2d 70 61 74 68 20 22 20 61 63 74 item-path " act
9240: 69 6f 6e 3a 20 22 20 61 63 74 69 6f 6e 29 0a 09 ion: " action)..
9250: 09 20 20 20 20 20 20 28 63 61 73 65 20 61 63 74 . (case act
9260: 69 6f 6e 0a 09 09 09 28 28 72 65 6d 6f 76 65 2d ion....((remove-
9270: 72 75 6e 73 29 20 3b 3b 20 74 68 65 20 74 64 62 runs) ;; the tdb
9280: 20 69 73 20 66 6f 72 20 66 75 74 75 72 65 20 70 is for future p
9290: 6f 73 73 69 62 6c 65 2e 20 0a 09 09 09 20 28 6f ossible. .... (o
92a0: 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 pen-run-close db
92b0: 3a 64 65 6c 65 74 65 2d 74 65 73 74 2d 72 65 63 :delete-test-rec
92c0: 6f 72 64 73 20 64 62 20 23 66 20 28 64 62 3a 74 ords db #f (db:t
92d0: 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 29 est-get-id test)
92e0: 29 0a 09 09 09 20 28 64 65 62 75 67 3a 70 72 69 ).... (debug:pri
92f0: 6e 74 20 31 20 22 49 4e 46 4f 3a 20 41 74 74 65 nt 1 "INFO: Atte
9300: 6d 70 74 69 6e 67 20 74 6f 20 72 65 6d 6f 76 65 mpting to remove
9310: 20 64 69 72 20 22 20 72 65 61 6c 2d 64 69 72 20 dir " real-dir
9320: 22 20 61 6e 64 20 6c 69 6e 6b 20 22 20 72 75 6e " and link " run
9330: 2d 64 69 72 29 0a 09 09 09 20 28 69 66 20 28 61 -dir).... (if (a
9340: 6e 64 20 72 65 61 6c 2d 64 69 72 20 0a 09 09 09 nd real-dir ....
9350: 09 20 20 28 3e 20 28 73 74 72 69 6e 67 2d 6c 65 . (> (string-le
9360: 6e 67 74 68 20 72 65 61 6c 2d 64 69 72 29 20 35 ngth real-dir) 5
9370: 29 0a 09 09 09 09 20 20 28 66 69 6c 65 2d 65 78 )..... (file-ex
9380: 69 73 74 73 3f 20 72 65 61 6c 2d 64 69 72 29 29 ists? real-dir))
9390: 20 3b 3b 20 62 61 64 20 68 65 75 72 69 73 74 69 ;; bad heuristi
93a0: 63 20 62 75 74 20 73 68 6f 75 6c 64 20 70 72 65 c but should pre
93b0: 76 65 6e 74 20 2f 74 6d 70 20 2f 68 6f 6d 65 20 vent /tmp /home
93c0: 65 74 63 2e 0a 09 09 09 20 20 20 20 20 28 62 65 etc..... (be
93d0: 67 69 6e 20 3b 3b 20 6c 65 74 2a 20 28 28 72 65 gin ;; let* ((re
93e0: 61 6c 70 61 74 68 20 28 72 65 73 6f 6c 76 65 2d alpath (resolve-
93f0: 70 61 74 68 6e 61 6d 65 20 72 75 6e 2d 64 69 72 pathname run-dir
9400: 29 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 64 ))).... (d
9410: 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 49 4e ebug:print 1 "IN
9420: 46 4f 3a 20 52 65 63 75 72 73 69 76 65 6c 79 20 FO: Recursively
9430: 72 65 6d 6f 76 69 6e 67 20 22 20 72 65 61 6c 2d removing " real-
9440: 64 69 72 29 0a 09 09 09 20 20 20 20 20 20 20 28 dir).... (
9450: 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f if (file-exists?
9460: 20 72 65 61 6c 2d 64 69 72 29 0a 09 09 09 09 20 real-dir).....
9470: 20 20 28 69 66 20 28 3e 20 28 73 79 73 74 65 6d (if (> (system
9480: 20 28 63 6f 6e 63 20 22 72 6d 20 2d 72 66 20 22 (conc "rm -rf "
9490: 20 72 65 61 6c 2d 64 69 72 29 29 20 30 29 0a 09 real-dir)) 0)..
94a0: 09 09 09 20 20 20 20 20 20 20 28 64 65 62 75 67 ... (debug
94b0: 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a :print 0 "ERROR:
94c0: 20 54 68 65 72 65 20 77 61 73 20 61 20 70 72 6f There was a pro
94d0: 62 6c 65 6d 20 72 65 6d 6f 76 69 6e 67 20 22 20 blem removing "
94e0: 72 65 61 6c 2d 64 69 72 20 22 20 77 69 74 68 20 real-dir " with
94f0: 72 6d 20 2d 66 22 29 29 0a 09 09 09 09 20 20 20 rm -f")).....
9500: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
9510: 57 41 52 4e 49 4e 47 3a 20 74 65 73 74 20 72 75 WARNING: test ru
9520: 6e 20 64 69 72 20 22 20 72 65 61 6c 2d 64 69 72 n dir " real-dir
9530: 20 22 20 61 70 70 65 61 72 73 20 74 6f 20 6e 6f " appears to no
9540: 74 20 65 78 69 73 74 22 29 29 29 0a 09 09 09 20 t exist")))....
9550: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
9560: 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 64 69 72 0 "WARNING: dir
9570: 65 63 74 6f 72 79 20 22 20 72 65 61 6c 2d 64 69 ectory " real-di
9580: 72 20 22 20 64 6f 65 73 20 6e 6f 74 20 65 78 69 r " does not exi
9590: 73 74 22 29 29 0a 09 09 09 20 28 69 66 20 28 73 st")).... (if (s
95a0: 79 6d 62 6f 6c 69 63 2d 6c 69 6e 6b 3f 20 72 75 ymbolic-link? ru
95b0: 6e 2d 64 69 72 29 0a 09 09 09 20 20 20 20 20 28 n-dir).... (
95c0: 62 65 67 69 6e 0a 09 09 09 20 20 20 20 20 20 20 begin....
95d0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 (debug:print 1 "
95e0: 49 4e 46 4f 3a 20 52 65 6d 6f 76 69 6e 67 20 73 INFO: Removing s
95f0: 79 6d 6c 69 6e 6b 20 22 20 72 75 6e 2d 64 69 72 ymlink " run-dir
9600: 29 0a 09 09 09 20 20 20 20 20 20 20 28 64 65 6c ).... (del
9610: 65 74 65 2d 66 69 6c 65 20 72 75 6e 2d 64 69 72 ete-file run-dir
9620: 29 29 0a 09 09 09 20 20 20 20 20 28 69 66 20 28 )).... (if (
9630: 64 69 72 65 63 74 6f 72 79 3f 20 72 75 6e 2d 64 directory? run-d
9640: 69 72 29 0a 09 09 09 09 20 28 69 66 20 28 3e 20 ir)..... (if (>
9650: 28 64 69 72 65 63 74 6f 72 79 2d 66 6f 6c 64 20 (directory-fold
9660: 28 6c 61 6d 62 64 61 20 28 66 20 78 29 28 2b 20 (lambda (f x)(+
9670: 31 20 78 29 29 20 30 20 72 75 6e 2d 64 69 72 29 1 x)) 0 run-dir)
9680: 20 30 29 0a 09 09 09 09 20 20 20 20 20 28 64 65 0)..... (de
9690: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 bug:print 0 "WAR
96a0: 4e 49 4e 47 3a 20 72 65 66 75 73 69 6e 67 20 74 NING: refusing t
96b0: 6f 20 72 65 6d 6f 76 65 20 22 20 72 75 6e 2d 64 o remove " run-d
96c0: 69 72 20 22 20 61 73 20 69 74 20 69 73 20 6e 6f ir " as it is no
96d0: 74 20 65 6d 70 74 79 22 29 0a 09 09 09 09 20 20 t empty").....
96e0: 20 20 20 28 64 65 6c 65 74 65 2d 64 69 72 65 63 (delete-direc
96f0: 74 6f 72 79 20 72 75 6e 2d 64 69 72 29 29 20 3b tory run-dir)) ;
9700: 3b 20 69 74 20 73 68 6f 75 6c 64 20 62 65 20 65 ; it should be e
9710: 6d 70 74 79 20 62 79 20 68 65 72 65 20 42 55 47 mpty by here BUG
9720: 20 42 55 47 2c 20 61 64 64 20 65 72 72 6f 72 20 BUG, add error
9730: 63 61 74 63 68 0a 09 09 09 09 20 28 64 65 62 75 catch..... (debu
9740: 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 g:print 0 "ERROR
9750: 3a 20 72 65 66 75 73 69 6e 67 20 74 6f 20 72 65 : refusing to re
9760: 6d 6f 76 65 20 22 20 72 75 6e 2d 64 69 72 20 22 move " run-dir "
9770: 20 61 73 20 69 74 20 65 69 74 68 65 72 20 64 6f as it either do
9780: 65 73 6e 27 74 20 65 78 69 73 74 20 6f 72 20 69 esn't exist or i
9790: 73 20 6e 6f 74 20 61 20 73 79 6d 6c 69 6e 6b 20 s not a symlink
97a0: 6f 72 20 64 69 72 65 63 74 6f 72 79 22 29 0a 09 or directory")..
97b0: 09 09 09 20 29 29 29 0a 09 09 09 28 28 73 65 74 ... )))....((set
97c0: 2d 73 74 61 74 65 2d 73 74 61 74 75 73 29 0a 09 -state-status)..
97d0: 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 .. (debug:print
97e0: 32 20 22 49 4e 46 4f 3a 20 6e 65 77 20 73 74 61 2 "INFO: new sta
97f0: 74 65 20 22 20 28 63 61 72 20 73 74 61 74 65 2d te " (car state-
9800: 73 74 61 74 75 73 29 20 22 2c 20 6e 65 77 20 73 status) ", new s
9810: 74 61 74 75 73 20 22 20 28 63 61 64 72 20 73 74 tatus " (cadr st
9820: 61 74 65 2d 73 74 61 74 75 73 29 29 0a 09 09 09 ate-status))....
9830: 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 (open-run-close
9840: 20 64 62 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 db:test-set-sta
9850: 74 65 2d 73 74 61 74 75 73 2d 62 79 2d 69 64 20 te-status-by-id
9860: 64 62 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d db (db:test-get-
9870: 69 64 20 74 65 73 74 29 20 28 63 61 72 20 73 74 id test) (car st
9880: 61 74 65 2d 73 74 61 74 75 73 29 28 63 61 64 72 ate-status)(cadr
9890: 20 73 74 61 74 65 2d 73 74 61 74 75 73 29 20 23 state-status) #
98a0: 66 29 29 29 29 29 0a 09 09 20 20 28 73 6f 72 74 f)))))... (sort
98b0: 20 74 65 73 74 73 20 28 6c 61 6d 62 64 61 20 28 tests (lambda (
98c0: 61 20 62 29 28 6c 65 74 20 28 28 64 69 72 61 20 a b)(let ((dira
98d0: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e (db:test-get-run
98e0: 64 69 72 20 61 29 29 0a 09 09 09 09 09 09 20 28 dir a))....... (
98f0: 64 69 72 62 20 28 64 62 3a 74 65 73 74 2d 67 65 dirb (db:test-ge
9900: 74 2d 72 75 6e 64 69 72 20 62 29 29 29 0a 09 09 t-rundir b)))...
9910: 09 09 09 20 20 20 20 20 28 69 66 20 28 61 6e 64 ... (if (and
9920: 20 28 73 74 72 69 6e 67 3f 20 64 69 72 61 29 28 (string? dira)(
9930: 73 74 72 69 6e 67 3f 20 64 69 72 62 29 29 0a 09 string? dirb))..
9940: 09 09 09 09 09 20 28 3e 20 28 73 74 72 69 6e 67 ..... (> (string
9950: 2d 6c 65 6e 67 74 68 20 64 69 72 61 29 28 73 74 -length dira)(st
9960: 72 69 6e 67 2d 6c 65 6e 67 74 68 20 64 69 72 62 ring-length dirb
9970: 29 29 0a 09 09 09 09 09 09 20 23 66 29 29 29 29 ))....... #f))))
9980: 29 29 29 0a 09 20 20 20 3b 3b 20 72 65 6d 6f 76 ))).. ;; remov
9990: 65 20 74 68 65 20 72 75 6e 20 69 66 20 7a 65 72 e the run if zer
99a0: 6f 20 74 65 73 74 73 20 72 65 6d 61 69 6e 0a 09 o tests remain..
99b0: 20 20 20 28 69 66 20 28 65 71 3f 20 61 63 74 69 (if (eq? acti
99c0: 6f 6e 20 27 72 65 6d 6f 76 65 2d 72 75 6e 73 29 on 'remove-runs)
99d0: 0a 09 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 .. (let ((
99e0: 72 65 6d 74 65 73 74 73 20 28 6f 70 65 6e 2d 72 remtests (open-r
99f0: 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d un-close db:get-
9a00: 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 64 62 tests-for-run db
9a10: 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 (db:get-value-b
9a20: 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 y-header run hea
9a30: 64 65 72 20 22 69 64 22 29 20 23 66 20 27 28 22 der "id") #f '("
9a40: 44 45 4c 45 54 45 44 22 29 20 27 28 22 6e 2f 61 DELETED") '("n/a
9a50: 22 29 20 6e 6f 74 2d 69 6e 3a 20 23 74 29 29 29 ") not-in: #t)))
9a60: 0a 09 09 20 28 69 66 20 28 6e 75 6c 6c 3f 20 72 ... (if (null? r
9a70: 65 6d 74 65 73 74 73 29 20 3b 3b 20 6e 6f 20 6d emtests) ;; no m
9a80: 6f 72 65 20 74 65 73 74 73 20 72 65 6d 61 69 6e ore tests remain
9a90: 69 6e 67 0a 09 09 20 20 20 20 20 28 6c 65 74 2a ing... (let*
9aa0: 20 28 28 64 70 61 72 74 73 20 20 28 73 74 72 69 ((dparts (stri
9ab0: 6e 67 2d 73 70 6c 69 74 20 6c 61 73 74 74 70 61 ng-split lasttpa
9ac0: 74 68 20 22 2f 22 29 29 0a 09 09 09 20 20 20 20 th "/"))....
9ad0: 28 72 75 6e 70 61 74 68 20 28 63 6f 6e 63 20 22 (runpath (conc "
9ae0: 2f 22 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 /" (string-inter
9af0: 73 70 65 72 73 65 20 0a 09 09 09 09 09 09 28 74 sperse .......(t
9b00: 61 6b 65 20 64 70 61 72 74 73 20 28 2d 20 28 6c ake dparts (- (l
9b10: 65 6e 67 74 68 20 64 70 61 72 74 73 29 20 31 29 ength dparts) 1)
9b20: 29 0a 09 09 09 09 09 09 22 2f 22 29 29 29 29 0a )......."/")))).
9b30: 09 09 20 20 20 20 20 20 20 28 64 65 62 75 67 3a .. (debug:
9b40: 70 72 69 6e 74 20 31 20 22 52 65 6d 6f 76 69 6e print 1 "Removin
9b50: 67 20 72 75 6e 3a 20 22 20 72 75 6e 6b 65 79 20 g run: " runkey
9b60: 22 20 22 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 " " (db:get-valu
9b70: 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 e-by-header run
9b80: 68 65 61 64 65 72 20 22 72 75 6e 6e 61 6d 65 22 header "runname"
9b90: 29 20 22 20 61 6e 64 20 72 65 6c 61 74 65 64 20 ) " and related
9ba0: 72 65 63 6f 72 64 22 29 0a 09 09 20 20 20 20 20 record")...
9bb0: 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 (open-run-clos
9bc0: 65 20 64 62 3a 64 65 6c 65 74 65 2d 72 75 6e 20 e db:delete-run
9bd0: 64 62 20 72 75 6e 2d 69 64 29 0a 09 09 20 20 20 db run-id)...
9be0: 20 20 20 20 3b 3b 20 54 68 69 73 20 69 73 20 61 ;; This is a
9bf0: 20 70 72 65 74 74 79 20 67 6f 6f 64 20 70 6c 61 pretty good pla
9c00: 63 65 20 74 6f 20 70 75 72 67 65 20 6f 6c 64 20 ce to purge old
9c10: 44 45 4c 45 54 45 44 20 74 65 73 74 73 0a 09 09 DELETED tests...
9c20: 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e (open-run
9c30: 2d 63 6c 6f 73 65 20 64 62 3a 64 65 6c 65 74 65 -close db:delete
9c40: 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 64 -tests-for-run d
9c50: 62 20 72 75 6e 2d 69 64 29 0a 09 09 20 20 20 20 b run-id)...
9c60: 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f (open-run-clo
9c70: 73 65 20 64 62 3a 64 65 6c 65 74 65 2d 6f 6c 64 se db:delete-old
9c80: 2d 64 65 6c 65 74 65 64 2d 74 65 73 74 2d 72 65 -deleted-test-re
9c90: 63 6f 72 64 73 20 64 62 29 0a 09 09 20 20 20 20 cords db)...
9ca0: 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f (open-run-clo
9cb0: 73 65 20 64 62 3a 73 65 74 2d 76 61 72 20 64 62 se db:set-var db
9cc0: 20 22 44 45 4c 45 54 45 44 5f 54 45 53 54 53 22 "DELETED_TESTS"
9cd0: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
9ce0: 73 29 29 0a 09 09 20 20 20 20 20 20 20 3b 3b 20 s))... ;;
9cf0: 6e 65 65 64 20 74 6f 20 66 69 67 75 72 65 20 6f need to figure o
9d00: 75 74 20 74 68 65 20 70 61 74 68 20 74 6f 20 74 ut the path to t
9d10: 68 65 20 72 75 6e 20 64 69 72 20 61 6e 64 20 72 he run dir and r
9d20: 65 6d 6f 76 65 20 69 74 20 69 66 20 65 6d 70 74 emove it if empt
9d30: 79 0a 09 09 20 20 20 20 20 20 20 3b 3b 20 20 20 y... ;;
9d40: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 28 67 6c 6f (if (null? (glo
9d50: 62 20 28 63 6f 6e 63 20 72 75 6e 70 61 74 68 20 b (conc runpath
9d60: 22 2f 2a 22 29 29 29 0a 09 09 20 20 20 20 20 20 "/*")))...
9d70: 20 3b 3b 20 20 20 20 20 20 20 20 28 62 65 67 69 ;; (begi
9d80: 6e 0a 09 09 20 20 20 20 20 20 20 3b 3b 20 09 20 n... ;; .
9d90: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 (debug:print 1 "
9da0: 52 65 6d 6f 76 69 6e 67 20 72 75 6e 20 64 69 72 Removing run dir
9db0: 20 22 20 72 75 6e 70 61 74 68 29 0a 09 09 20 20 " runpath)...
9dc0: 20 20 20 20 20 3b 3b 20 09 20 28 73 79 73 74 65 ;; . (syste
9dd0: 6d 20 28 63 6f 6e 63 20 22 72 6d 64 69 72 20 2d m (conc "rmdir -
9de0: 70 20 22 20 72 75 6e 70 61 74 68 29 29 29 29 0a p " runpath)))).
9df0: 09 09 20 20 20 20 20 20 20 29 29 29 29 29 0a 09 .. )))))..
9e00: 20 29 29 0a 20 20 20 20 20 72 75 6e 73 29 29 0a )). runs)).
9e10: 20 20 23 74 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d #t)..;;=======
9e20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9e30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9e40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9e50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
9e60: 3b 3b 20 52 6f 75 74 69 6e 65 73 20 66 6f 72 20 ;; Routines for
9e70: 6d 61 6e 69 70 75 6c 61 74 69 6e 67 20 72 75 6e manipulating run
9e80: 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d s.;;============
9e90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9ea0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9eb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9ec0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 53 ==========..;; S
9ed0: 69 6e 63 65 20 6d 61 6e 79 20 63 61 6c 6c 73 20 ince many calls
9ee0: 74 6f 20 61 20 72 75 6e 20 72 65 71 75 69 72 65 to a run require
9ef0: 20 70 72 65 74 74 79 20 6d 75 63 68 20 74 68 65 pretty much the
9f00: 20 73 61 6d 65 20 73 65 74 75 70 20 0a 3b 3b 20 same setup .;;
9f10: 74 68 69 73 20 77 72 61 70 70 65 72 20 69 73 20 this wrapper is
9f20: 75 73 65 64 20 74 6f 20 72 65 64 75 63 65 20 74 used to reduce t
9f30: 68 65 20 72 65 70 6c 69 63 61 74 69 6f 6e 20 6f he replication o
9f40: 66 20 63 6f 64 65 0a 28 64 65 66 69 6e 65 20 28 f code.(define (
9f50: 67 65 6e 65 72 61 6c 2d 72 75 6e 2d 63 61 6c 6c general-run-call
9f60: 20 73 77 69 74 63 68 6e 61 6d 65 20 61 63 74 69 switchname acti
9f70: 6f 6e 2d 64 65 73 63 20 70 72 6f 63 29 0a 20 20 on-desc proc).
9f80: 28 6c 65 74 20 28 28 72 75 6e 6e 61 6d 65 20 28 (let ((runname (
9f90: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 3a 72 args:get-arg ":r
9fa0: 75 6e 6e 61 6d 65 22 29 29 0a 09 28 74 61 72 67 unname"))..(targ
9fb0: 65 74 20 20 28 69 66 20 28 61 72 67 73 3a 67 65 et (if (args:ge
9fc0: 74 2d 61 72 67 20 22 2d 74 61 72 67 65 74 22 29 t-arg "-target")
9fd0: 0a 09 09 20 20 20 20 20 28 61 72 67 73 3a 67 65 ... (args:ge
9fe0: 74 2d 61 72 67 20 22 2d 74 61 72 67 65 74 22 29 t-arg "-target")
9ff0: 0a 09 09 20 20 20 20 20 28 61 72 67 73 3a 67 65 ... (args:ge
a000: 74 2d 61 72 67 20 22 2d 72 65 71 74 61 72 67 22 t-arg "-reqtarg"
a010: 29 29 29 0a 09 28 74 68 31 20 20 20 20 20 23 66 )))..(th1 #f
a020: 29 29 0a 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 )). (cond.
a030: 20 20 28 28 6e 6f 74 20 74 61 72 67 65 74 29 0a ((not target).
a040: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
a050: 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 4d 69 73 nt 0 "ERROR: Mis
a060: 73 69 6e 67 20 72 65 71 75 69 72 65 64 20 70 61 sing required pa
a070: 72 61 6d 65 74 65 72 20 66 6f 72 20 22 20 73 77 rameter for " sw
a080: 69 74 63 68 6e 61 6d 65 20 22 2c 20 79 6f 75 20 itchname ", you
a090: 6d 75 73 74 20 73 70 65 63 69 66 79 20 74 68 65 must specify the
a0a0: 20 74 61 72 67 65 74 20 77 69 74 68 20 2d 74 61 target with -ta
a0b0: 72 67 65 74 22 29 0a 20 20 20 20 20 20 28 65 78 rget"). (ex
a0c0: 69 74 20 33 29 29 0a 20 20 20 20 20 28 28 6e 6f it 3)). ((no
a0d0: 74 20 72 75 6e 6e 61 6d 65 29 0a 20 20 20 20 20 t runname).
a0e0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
a0f0: 22 45 52 52 4f 52 3a 20 4d 69 73 73 69 6e 67 20 "ERROR: Missing
a100: 72 65 71 75 69 72 65 64 20 70 61 72 61 6d 65 74 required paramet
a110: 65 72 20 66 6f 72 20 22 20 73 77 69 74 63 68 6e er for " switchn
a120: 61 6d 65 20 22 2c 20 79 6f 75 20 6d 75 73 74 20 ame ", you must
a130: 73 70 65 63 69 66 79 20 74 68 65 20 72 75 6e 20 specify the run
a140: 6e 61 6d 65 20 77 69 74 68 20 3a 72 75 6e 6e 61 name with :runna
a150: 6d 65 20 72 75 6e 6e 61 6d 65 22 29 0a 20 20 20 me runname").
a160: 20 20 20 28 65 78 69 74 20 33 29 29 0a 20 20 20 (exit 3)).
a170: 20 20 28 65 6c 73 65 0a 20 20 20 20 20 20 28 6c (else. (l
a180: 65 74 20 28 28 64 62 20 20 20 23 66 29 0a 09 20 et ((db #f)..
a190: 20 20 20 28 6b 65 79 73 20 23 66 29 29 0a 09 28 (keys #f))..(
a1a0: 69 66 20 28 6e 6f 74 20 28 73 65 74 75 70 2d 66 if (not (setup-f
a1b0: 6f 72 2d 72 75 6e 29 29 0a 09 20 20 20 20 28 62 or-run)).. (b
a1c0: 65 67 69 6e 20 0a 09 20 20 20 20 20 20 28 64 65 egin .. (de
a1d0: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 46 61 69 bug:print 0 "Fai
a1e0: 6c 65 64 20 74 6f 20 73 65 74 75 70 2c 20 65 78 led to setup, ex
a1f0: 69 74 69 6e 67 22 29 0a 09 20 20 20 20 20 20 28 iting").. (
a200: 65 78 69 74 20 31 29 29 29 0a 09 28 69 66 20 28 exit 1)))..(if (
a210: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 73 args:get-arg "-s
a220: 65 72 76 65 72 22 29 0a 09 20 20 20 20 28 6f 70 erver").. (op
a230: 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 73 65 72 en-run-close ser
a240: 76 65 72 3a 73 74 61 72 74 20 64 62 20 28 61 72 ver:start db (ar
a250: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 73 65 72 gs:get-arg "-ser
a260: 76 65 72 22 29 29 0a 20 09 20 20 20 20 28 69 66 ver")). . (if
a270: 20 28 6e 6f 74 20 28 6f 72 20 28 61 72 67 73 3a (not (or (args:
a280: 67 65 74 2d 61 72 67 20 22 2d 72 75 6e 61 6c 6c get-arg "-runall
a290: 22 29 20 20 20 20 20 3b 3b 20 72 75 6e 61 6c 6c ") ;; runall
a2a0: 20 61 6e 64 20 72 75 6e 74 65 73 74 73 20 61 72 and runtests ar
a2b0: 65 20 61 6c 6c 6f 77 65 64 20 74 6f 20 62 65 20 e allowed to be
a2c0: 73 65 72 76 65 72 73 0a 20 09 09 09 20 28 61 72 servers. ... (ar
a2d0: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 75 6e gs:get-arg "-run
a2e0: 74 65 73 74 73 22 29 29 29 0a 09 09 28 73 65 72 tests")))...(ser
a2f0: 76 65 72 3a 63 6c 69 65 6e 74 2d 73 65 74 75 70 ver:client-setup
a300: 29 29 29 0a 09 28 73 65 74 21 20 6b 65 79 73 20 )))..(set! keys
a310: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 (open-run-close
a320: 64 62 3a 67 65 74 2d 6b 65 79 73 20 64 62 29 29 db:get-keys db))
a330: 0a 09 3b 3b 20 68 61 76 65 20 65 6e 6f 75 67 68 ..;; have enough
a340: 20 74 6f 20 70 72 6f 63 65 73 73 20 2d 74 61 72 to process -tar
a350: 67 65 74 20 6f 72 20 2d 72 65 71 74 61 72 67 20 get or -reqtarg
a360: 68 65 72 65 0a 09 28 69 66 20 28 61 72 67 73 3a here..(if (args:
a370: 67 65 74 2d 61 72 67 20 22 2d 72 65 71 74 61 72 get-arg "-reqtar
a380: 67 22 29 0a 09 20 20 20 20 28 6c 65 74 2a 20 28 g").. (let* (
a390: 28 72 75 6e 63 6f 6e 66 69 67 66 20 28 63 6f 6e (runconfigf (con
a3a0: 63 20 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 72 c *toppath* "/r
a3b0: 75 6e 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 69 67 unconfigs.config
a3c0: 22 29 29 20 3b 3b 20 44 4f 20 4e 4f 54 20 45 56 ")) ;; DO NOT EV
a3d0: 41 4c 55 41 54 45 20 41 4c 4c 20 0a 09 09 20 20 ALUATE ALL ...
a3e0: 20 28 72 75 6e 63 6f 6e 66 69 67 20 20 28 72 65 (runconfig (re
a3f0: 61 64 2d 63 6f 6e 66 69 67 20 72 75 6e 63 6f 6e ad-config runcon
a400: 66 69 67 66 20 23 66 20 23 66 20 65 6e 76 69 72 figf #f #f envir
a410: 6f 6e 2d 70 61 74 74 3a 20 23 66 29 29 29 20 0a on-patt: #f))) .
a420: 09 20 20 20 20 20 20 28 69 66 20 28 68 61 73 68 . (if (hash
a430: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
a440: 6c 74 20 72 75 6e 63 6f 6e 66 69 67 20 28 61 72 lt runconfig (ar
a450: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 71 gs:get-arg "-req
a460: 74 61 72 67 22 29 20 23 66 29 0a 09 09 20 20 28 targ") #f)... (
a470: 6b 65 79 73 3a 74 61 72 67 65 74 2d 73 65 74 2d keys:target-set-
a480: 61 72 67 73 20 6b 65 79 73 20 28 61 72 67 73 3a args keys (args:
a490: 67 65 74 2d 61 72 67 20 22 2d 72 65 71 74 61 72 get-arg "-reqtar
a4a0: 67 22 29 20 61 72 67 73 3a 61 72 67 2d 68 61 73 g") args:arg-has
a4b0: 68 29 0a 09 09 20 20 28 62 65 67 69 6e 0a 09 09 h)... (begin...
a4c0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
a4d0: 20 30 20 22 45 52 52 4f 52 3a 20 5b 22 20 28 61 0 "ERROR: [" (a
a4e0: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 rgs:get-arg "-re
a4f0: 71 74 61 72 67 22 29 20 22 5d 20 6e 6f 74 20 66 qtarg") "] not f
a500: 6f 75 6e 64 20 69 6e 20 22 20 72 75 6e 63 6f 6e ound in " runcon
a510: 66 69 67 66 29 0a 09 09 20 20 20 20 28 69 66 20 figf)... (if
a520: 64 62 20 28 73 71 6c 69 74 65 33 3a 66 69 6e 61 db (sqlite3:fina
a530: 6c 69 7a 65 21 20 64 62 29 29 0a 09 09 20 20 20 lize! db))...
a540: 20 28 65 78 69 74 20 31 29 29 29 29 0a 09 20 20 (exit 1))))..
a550: 20 20 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d (if (args:get-
a560: 61 72 67 20 22 2d 74 61 72 67 65 74 22 29 0a 09 arg "-target")..
a570: 09 28 6b 65 79 73 3a 74 61 72 67 65 74 2d 73 65 .(keys:target-se
a580: 74 2d 61 72 67 73 20 6b 65 79 73 20 28 61 72 67 t-args keys (arg
a590: 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 72 67 s:get-arg "-targ
a5a0: 65 74 22 20 61 72 67 73 3a 61 72 67 2d 68 61 73 et" args:arg-has
a5b0: 68 29 20 61 72 67 73 3a 61 72 67 2d 68 61 73 68 h) args:arg-hash
a5c0: 29 29 29 0a 09 28 69 66 20 28 6e 6f 74 20 28 63 )))..(if (not (c
a5d0: 61 72 20 2a 63 6f 6e 66 69 67 69 6e 66 6f 2a 29 ar *configinfo*)
a5e0: 29 0a 09 20 20 20 20 28 62 65 67 69 6e 0a 09 20 ).. (begin..
a5f0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
a600: 74 20 30 20 22 45 52 52 4f 52 3a 20 41 74 74 65 t 0 "ERROR: Atte
a610: 6d 70 74 65 64 20 74 6f 20 22 20 61 63 74 69 6f mpted to " actio
a620: 6e 2d 64 65 73 63 20 22 20 62 75 74 20 72 75 6e n-desc " but run
a630: 20 61 72 65 61 20 63 6f 6e 66 69 67 20 66 69 6c area config fil
a640: 65 20 6e 6f 74 20 66 6f 75 6e 64 22 29 0a 09 20 e not found")..
a650: 20 20 20 20 20 28 65 78 69 74 20 31 29 29 0a 09 (exit 1))..
a660: 20 20 20 20 3b 3b 20 45 78 74 72 61 63 74 20 6f ;; Extract o
a670: 75 74 20 73 74 75 66 66 20 6e 65 65 64 65 64 20 ut stuff needed
a680: 69 6e 20 6d 6f 73 74 20 6f 72 20 6d 61 6e 79 20 in most or many
a690: 63 61 6c 6c 73 0a 09 20 20 20 20 3b 3b 20 68 65 calls.. ;; he
a6a0: 72 65 20 74 68 65 6e 20 63 61 6c 6c 20 70 72 6f re then call pro
a6b0: 63 0a 09 20 20 20 20 28 6c 65 74 2a 20 28 28 6b c.. (let* ((k
a6c0: 65 79 6e 61 6d 65 73 20 20 20 28 6d 61 70 20 6b eynames (map k
a6d0: 65 79 3a 67 65 74 2d 66 69 65 6c 64 6e 61 6d 65 ey:get-fieldname
a6e0: 20 6b 65 79 73 29 29 0a 09 09 20 20 20 28 6b 65 keys))... (ke
a6f0: 79 76 61 6c 6c 73 74 20 20 28 6b 65 79 73 2d 3e yvallst (keys->
a700: 76 61 6c 6c 69 73 74 20 6b 65 79 73 20 23 74 29 vallist keys #t)
a710: 29 29 0a 09 20 20 20 20 20 20 28 70 72 6f 63 20 )).. (proc
a720: 74 61 72 67 65 74 20 72 75 6e 6e 61 6d 65 20 6b target runname k
a730: 65 79 73 20 6b 65 79 6e 61 6d 65 73 20 6b 65 79 eys keynames key
a740: 76 61 6c 6c 73 74 29 29 29 0a 09 28 69 66 20 74 vallst)))..(if t
a750: 68 31 20 28 74 68 72 65 61 64 2d 6a 6f 69 6e 21 h1 (thread-join!
a760: 20 74 68 31 29 29 0a 09 28 69 66 20 64 62 20 28 th1))..(if db (
a770: 73 71 6c 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 sqlite3:finalize
a780: 21 20 64 62 29 29 0a 09 28 73 65 74 21 20 2a 64 ! db))..(set! *d
a790: 69 64 73 6f 6d 65 74 68 69 6e 67 2a 20 23 74 29 idsomething* #t)
a7a0: 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d )))))..;;=======
a7b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a7c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a7d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a7e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
a7f0: 3b 3b 20 4c 6f 63 6b 2f 75 6e 6c 6f 63 6b 20 72 ;; Lock/unlock r
a800: 75 6e 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d uns.;;==========
a810: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a820: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a830: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a840: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 ============..(d
a850: 65 66 69 6e 65 20 28 72 75 6e 73 3a 68 61 6e 64 efine (runs:hand
a860: 6c 65 2d 6c 6f 63 6b 69 6e 67 20 74 61 72 67 65 le-locking targe
a870: 74 20 6b 65 79 73 20 72 75 6e 6e 61 6d 65 20 6c t keys runname l
a880: 6f 63 6b 20 75 6e 6c 6f 63 6b 20 75 73 65 72 29 ock unlock user)
a890: 0a 20 20 28 6c 65 74 2a 20 28 28 64 62 20 20 20 . (let* ((db
a8a0: 20 20 20 20 23 66 29 0a 09 20 28 72 75 6e 64 61 #f).. (runda
a8b0: 74 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c t (open-run-cl
a8c0: 6f 73 65 20 72 75 6e 73 3a 67 65 74 2d 72 75 6e ose runs:get-run
a8d0: 73 2d 62 79 2d 70 61 74 74 20 64 62 20 6b 65 79 s-by-patt db key
a8e0: 73 20 72 75 6e 6e 61 6d 65 29 29 0a 09 20 28 68 s runname)).. (h
a8f0: 65 61 64 65 72 20 20 20 28 76 65 63 74 6f 72 2d eader (vector-
a900: 72 65 66 20 72 75 6e 64 61 74 20 30 29 29 0a 09 ref rundat 0))..
a910: 20 28 72 75 6e 73 20 20 20 20 20 28 76 65 63 74 (runs (vect
a920: 6f 72 2d 72 65 66 20 72 75 6e 64 61 74 20 31 29 or-ref rundat 1)
a930: 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 )). (for-each
a940: 20 28 6c 61 6d 62 64 61 20 28 72 75 6e 29 0a 09 (lambda (run)..
a950: 09 28 6c 65 74 20 28 28 72 75 6e 2d 69 64 20 28 .(let ((run-id (
a960: 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d db:get-value-by-
a970: 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 header run heade
a980: 72 20 22 69 64 22 29 29 29 0a 09 09 20 20 28 69 r "id")))... (i
a990: 66 20 28 6f 72 20 6c 6f 63 6b 0a 09 09 09 20 20 f (or lock....
a9a0: 28 61 6e 64 20 75 6e 6c 6f 63 6b 0a 09 09 09 20 (and unlock....
a9b0: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 (begin....
a9c0: 09 20 28 70 72 69 6e 74 20 22 44 6f 20 79 6f 75 . (print "Do you
a9d0: 20 72 65 61 6c 6c 79 20 77 69 73 68 20 74 6f 20 really wish to
a9e0: 75 6e 6c 6f 63 6b 20 72 75 6e 20 22 20 72 75 6e unlock run " run
a9f0: 2d 69 64 20 22 3f 5c 6e 20 20 20 79 2f 6e 3a 20 -id "?\n y/n:
aa00: 22 29 0a 09 09 09 09 20 28 65 71 75 61 6c 3f 20 ")..... (equal?
aa10: 22 79 22 20 28 72 65 61 64 2d 6c 69 6e 65 29 29 "y" (read-line))
aa20: 29 29 29 0a 09 09 20 20 20 20 20 20 28 6f 70 65 )))... (ope
aa30: 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 6c n-run-close db:l
aa40: 6f 63 6b 2f 75 6e 6c 6f 63 6b 2d 72 75 6e 20 64 ock/unlock-run d
aa50: 62 20 72 75 6e 2d 69 64 20 6c 6f 63 6b 20 75 6e b run-id lock un
aa60: 6c 6f 63 6b 20 75 73 65 72 29 0a 09 09 20 20 20 lock user)...
aa70: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
aa80: 30 20 22 49 4e 46 4f 3a 20 53 6b 69 70 70 69 6e 0 "INFO: Skippin
aa90: 67 20 6c 6f 63 6b 2f 75 6e 6c 6f 63 6b 20 6f 6e g lock/unlock on
aaa0: 20 22 20 72 75 6e 2d 69 64 29 29 29 29 0a 09 20 " run-id))))..
aab0: 20 20 20 20 20 72 75 6e 73 29 29 29 0a 3b 3b 3d runs))).;;=
aac0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aad0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aae0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aaf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ab00: 3d 3d 3d 3d 3d 0a 3b 3b 20 52 6f 6c 6c 75 70 20 =====.;; Rollup
ab10: 72 75 6e 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d runs.;;=========
ab20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ab30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ab40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ab50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b =============..;
ab60: 3b 20 55 70 64 61 74 65 20 74 68 65 20 74 65 73 ; Update the tes
ab70: 74 5f 6d 65 74 61 20 74 61 62 6c 65 20 66 6f 72 t_meta table for
ab80: 20 74 68 69 73 20 74 65 73 74 0a 28 64 65 66 69 this test.(defi
ab90: 6e 65 20 28 72 75 6e 73 3a 75 70 64 61 74 65 2d ne (runs:update-
aba0: 74 65 73 74 5f 6d 65 74 61 20 64 62 20 74 65 73 test_meta db tes
abb0: 74 2d 6e 61 6d 65 20 74 65 73 74 2d 63 6f 6e 66 t-name test-conf
abc0: 29 0a 20 20 28 6c 65 74 20 28 28 63 75 72 72 72 ). (let ((currr
abd0: 65 63 6f 72 64 20 28 6f 70 65 6e 2d 72 75 6e 2d ecord (open-run-
abe0: 63 6c 6f 73 65 20 64 62 3a 74 65 73 74 6d 65 74 close db:testmet
abf0: 61 2d 67 65 74 2d 72 65 63 6f 72 64 20 64 62 20 a-get-record db
ac00: 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a 20 20 20 test-name))).
ac10: 20 28 69 66 20 28 6e 6f 74 20 63 75 72 72 72 65 (if (not currre
ac20: 63 6f 72 64 29 0a 09 28 62 65 67 69 6e 0a 09 20 cord)..(begin..
ac30: 20 28 73 65 74 21 20 63 75 72 72 72 65 63 6f 72 (set! currrecor
ac40: 64 20 28 6d 61 6b 65 2d 76 65 63 74 6f 72 20 31 d (make-vector 1
ac50: 30 20 23 66 29 29 0a 09 20 20 28 6f 70 65 6e 2d 0 #f)).. (open-
ac60: 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 74 65 73 run-close db:tes
ac70: 74 6d 65 74 61 2d 61 64 64 2d 72 65 63 6f 72 64 tmeta-add-record
ac80: 20 64 62 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 db test-name)))
ac90: 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a . (for-each .
aca0: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 6b 65 (lambda (ke
acb0: 79 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 y). (let*
acc0: 28 28 69 64 78 20 28 63 61 64 72 20 6b 65 79 29 ((idx (cadr key)
acd0: 29 0a 09 20 20 20 20 20 20 28 66 6c 64 20 28 63 ).. (fld (c
ace0: 61 72 20 20 6b 65 79 29 29 0a 09 20 20 20 20 20 ar key))..
acf0: 20 28 76 61 6c 20 28 63 6f 6e 66 69 67 2d 6c 6f (val (config-lo
ad00: 6f 6b 75 70 20 74 65 73 74 2d 63 6f 6e 66 20 22 okup test-conf "
ad10: 74 65 73 74 5f 6d 65 74 61 22 20 66 6c 64 29 29 test_meta" fld))
ad20: 29 0a 09 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 ).. ;; (debug:pr
ad30: 69 6e 74 20 35 20 22 69 64 78 3a 20 22 20 69 64 int 5 "idx: " id
ad40: 78 20 22 20 66 6c 64 3a 20 22 20 66 6c 64 20 22 x " fld: " fld "
ad50: 20 76 61 6c 3a 20 22 20 76 61 6c 29 0a 09 20 28 val: " val).. (
ad60: 69 66 20 28 61 6e 64 20 76 61 6c 20 28 6e 6f 74 if (and val (not
ad70: 20 28 65 71 75 61 6c 3f 20 28 76 65 63 74 6f 72 (equal? (vector
ad80: 2d 72 65 66 20 63 75 72 72 72 65 63 6f 72 64 20 -ref currrecord
ad90: 69 64 78 29 20 76 61 6c 29 29 29 0a 09 20 20 20 idx) val)))..
ada0: 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 (begin..
adb0: 20 28 70 72 69 6e 74 20 22 55 70 64 61 74 69 6e (print "Updatin
adc0: 67 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 g " test-name "
add0: 22 20 66 6c 64 20 22 20 74 6f 20 22 20 76 61 6c " fld " to " val
ade0: 29 0a 09 20 20 20 20 20 20 20 28 6f 70 65 6e 2d ).. (open-
adf0: 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 74 65 73 run-close db:tes
ae00: 74 6d 65 74 61 2d 75 70 64 61 74 65 2d 66 69 65 tmeta-update-fie
ae10: 6c 64 20 64 62 20 74 65 73 74 2d 6e 61 6d 65 20 ld db test-name
ae20: 66 6c 64 20 76 61 6c 29 29 29 29 29 0a 20 20 20 fld val))))).
ae30: 20 20 27 28 28 22 61 75 74 68 6f 72 22 20 32 29 '(("author" 2)
ae40: 28 22 6f 77 6e 65 72 22 20 33 29 28 22 64 65 73 ("owner" 3)("des
ae50: 63 72 69 70 74 69 6f 6e 22 20 34 29 28 22 72 65 cription" 4)("re
ae60: 76 69 65 77 65 64 22 20 35 29 28 22 74 61 67 73 viewed" 5)("tags
ae70: 22 20 39 29 29 29 29 29 0a 0a 3b 3b 20 55 70 64 " 9)))))..;; Upd
ae80: 61 74 65 20 74 65 73 74 5f 6d 65 74 61 20 66 6f ate test_meta fo
ae90: 72 20 61 6c 6c 20 74 65 73 74 73 0a 28 64 65 66 r all tests.(def
aea0: 69 6e 65 20 28 72 75 6e 73 3a 75 70 64 61 74 65 ine (runs:update
aeb0: 2d 61 6c 6c 2d 74 65 73 74 5f 6d 65 74 61 20 64 -all-test_meta d
aec0: 62 29 0a 20 20 28 6c 65 74 20 28 28 74 65 73 74 b). (let ((test
aed0: 2d 6e 61 6d 65 73 20 28 67 65 74 2d 61 6c 6c 2d -names (get-all-
aee0: 6c 65 67 61 6c 2d 74 65 73 74 73 29 29 29 0a 20 legal-tests))).
aef0: 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 (for-each .
af00: 20 20 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 (lambda (test
af10: 2d 6e 61 6d 65 29 0a 20 20 20 20 20 20 20 28 6c -name). (l
af20: 65 74 2a 20 28 28 74 65 73 74 2d 70 61 74 68 20 et* ((test-path
af30: 20 20 20 28 63 6f 6e 63 20 2a 74 6f 70 70 61 74 (conc *toppat
af40: 68 2a 20 22 2f 74 65 73 74 73 2f 22 20 74 65 73 h* "/tests/" tes
af50: 74 2d 6e 61 6d 65 29 29 0a 09 20 20 20 20 20 20 t-name))..
af60: 28 74 65 73 74 2d 63 6f 6e 66 69 67 66 20 28 63 (test-configf (c
af70: 6f 6e 63 20 74 65 73 74 2d 70 61 74 68 20 22 2f onc test-path "/
af80: 74 65 73 74 63 6f 6e 66 69 67 22 29 29 0a 09 20 testconfig"))..
af90: 20 20 20 20 20 28 74 65 73 74 65 78 69 73 74 73 (testexists
afa0: 20 20 20 28 61 6e 64 20 28 66 69 6c 65 2d 65 78 (and (file-ex
afb0: 69 73 74 73 3f 20 74 65 73 74 2d 63 6f 6e 66 69 ists? test-confi
afc0: 67 66 29 28 66 69 6c 65 2d 72 65 61 64 2d 61 63 gf)(file-read-ac
afd0: 63 65 73 73 3f 20 74 65 73 74 2d 63 6f 6e 66 69 cess? test-confi
afe0: 67 66 29 29 29 0a 09 20 20 20 20 20 20 3b 3b 20 gf))).. ;;
aff0: 72 65 61 64 20 63 6f 6e 66 69 67 73 20 77 69 74 read configs wit
b000: 68 20 74 72 69 63 6b 73 20 74 75 72 6e 65 64 20 h tricks turned
b010: 6f 66 66 20 28 69 2e 65 2e 20 6e 6f 20 73 79 73 off (i.e. no sys
b020: 74 65 6d 29 0a 09 20 20 20 20 20 20 28 74 65 73 tem).. (tes
b030: 74 2d 63 6f 6e 66 20 20 20 20 28 69 66 20 74 65 t-conf (if te
b040: 73 74 65 78 69 73 74 73 20 28 72 65 61 64 2d 63 stexists (read-c
b050: 6f 6e 66 69 67 20 74 65 73 74 2d 63 6f 6e 66 69 onfig test-confi
b060: 67 66 20 23 66 20 23 66 29 28 6d 61 6b 65 2d 68 gf #f #f)(make-h
b070: 61 73 68 2d 74 61 62 6c 65 29 29 29 29 0a 09 20 ash-table))))..
b080: 3b 3b 20 75 73 65 20 74 68 65 20 6f 70 65 6e 2d ;; use the open-
b090: 72 75 6e 2d 63 6c 6f 73 65 20 69 6e 73 74 65 61 run-close instea
b0a0: 64 20 6f 66 20 70 61 73 73 69 6e 67 20 69 6e 20 d of passing in
b0b0: 64 62 0a 09 20 28 72 75 6e 73 3a 75 70 64 61 74 db.. (runs:updat
b0c0: 65 2d 74 65 73 74 5f 6d 65 74 61 20 23 66 20 74 e-test_meta #f t
b0d0: 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 63 6f est-name test-co
b0e0: 6e 66 29 29 29 0a 20 20 20 20 20 74 65 73 74 2d nf))). test-
b0f0: 6e 61 6d 65 73 29 29 29 0a 0a 3b 3b 20 54 68 69 names)))..;; Thi
b100: 73 20 63 6f 75 6c 64 20 70 72 6f 62 61 62 6c 79 s could probably
b110: 20 62 65 20 72 65 66 61 63 74 6f 72 65 64 20 69 be refactored i
b120: 6e 74 6f 20 6f 6e 65 20 63 6f 6d 70 6c 65 78 20 nto one complex
b130: 71 75 65 72 79 20 2e 2e 2e 0a 28 64 65 66 69 6e query ....(defin
b140: 65 20 28 72 75 6e 73 3a 72 6f 6c 6c 75 70 2d 72 e (runs:rollup-r
b150: 75 6e 20 6b 65 79 73 20 6b 65 79 76 61 6c 6c 73 un keys keyvalls
b160: 74 20 72 75 6e 6e 61 6d 65 20 75 73 65 72 29 20 t runname user)
b170: 3b 3b 20 77 61 73 20 74 61 72 67 65 74 2c 20 6e ;; was target, n
b180: 6f 77 20 6b 65 79 76 61 6c 6c 73 74 0a 20 20 28 ow keyvallst. (
b190: 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 72 debug:print 4 "r
b1a0: 75 6e 73 3a 72 6f 6c 6c 75 70 2d 72 75 6e 2c 20 uns:rollup-run,
b1b0: 6b 65 79 73 3a 20 22 20 6b 65 79 73 20 22 20 6b keys: " keys " k
b1c0: 65 79 76 61 6c 6c 73 74 3a 20 22 20 6b 65 79 76 eyvallst: " keyv
b1d0: 61 6c 6c 73 74 20 22 20 3a 72 75 6e 6e 61 6d 65 allst " :runname
b1e0: 20 22 20 72 75 6e 6e 61 6d 65 20 22 20 75 73 65 " runname " use
b1f0: 72 3a 20 22 20 75 73 65 72 29 0a 20 20 28 6c 65 r: " user). (le
b200: 74 2a 20 28 28 64 62 20 20 20 20 20 20 20 20 20 t* ((db
b210: 20 20 20 20 20 23 66 29 20 3b 3b 20 28 6b 65 79 #f) ;; (key
b220: 76 61 6c 6c 6c 73 74 20 20 20 20 20 20 28 6b 65 valllst (ke
b230: 79 73 3a 74 61 72 67 65 74 2d 3e 6b 65 79 76 61 ys:target->keyva
b240: 6c 20 6b 65 79 73 20 74 61 72 67 65 74 29 29 0a l keys target)).
b250: 09 20 28 6e 65 77 2d 72 75 6e 2d 69 64 20 20 20 . (new-run-id
b260: 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f (open-run-clo
b270: 73 65 20 72 75 6e 73 3a 72 65 67 69 73 74 65 72 se runs:register
b280: 2d 72 75 6e 20 64 62 20 6b 65 79 73 20 6b 65 79 -run db keys key
b290: 76 61 6c 6c 73 74 20 72 75 6e 6e 61 6d 65 20 22 vallst runname "
b2a0: 6e 65 77 22 20 22 6e 2f 61 22 20 75 73 65 72 29 new" "n/a" user)
b2b0: 29 0a 09 20 28 70 72 65 76 2d 74 65 73 74 73 20 ).. (prev-tests
b2c0: 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 (open-run-c
b2d0: 6c 6f 73 65 20 74 65 73 74 3a 67 65 74 2d 6d 61 lose test:get-ma
b2e0: 74 63 68 69 6e 67 2d 70 72 65 76 69 6f 75 73 2d tching-previous-
b2f0: 74 65 73 74 2d 72 75 6e 2d 72 65 63 6f 72 64 73 test-run-records
b300: 20 64 62 20 6e 65 77 2d 72 75 6e 2d 69 64 20 22 db new-run-id "
b310: 25 22 20 22 25 22 29 29 0a 09 20 28 63 75 72 72 %" "%")).. (curr
b320: 2d 74 65 73 74 73 20 20 20 20 20 20 28 6f 70 65 -tests (ope
b330: 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 n-run-close db:g
b340: 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e et-tests-for-run
b350: 20 64 62 20 6e 65 77 2d 72 75 6e 2d 69 64 20 22 db new-run-id "
b360: 25 2f 25 22 20 27 28 29 20 27 28 29 29 29 0a 09 %/%" '() '()))..
b370: 20 28 63 75 72 72 2d 74 65 73 74 73 2d 68 61 73 (curr-tests-has
b380: 68 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 h (make-hash-tab
b390: 6c 65 29 29 29 0a 20 20 20 20 28 6f 70 65 6e 2d le))). (open-
b3a0: 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 75 70 64 run-close db:upd
b3b0: 61 74 65 2d 72 75 6e 2d 65 76 65 6e 74 5f 74 69 ate-run-event_ti
b3c0: 6d 65 20 64 62 20 6e 65 77 2d 72 75 6e 2d 69 64 me db new-run-id
b3d0: 29 0a 20 20 20 20 3b 3b 20 69 6e 64 65 78 20 74 ). ;; index t
b3e0: 68 65 20 61 6c 72 65 61 64 79 20 73 61 76 65 64 he already saved
b3f0: 20 74 65 73 74 73 20 62 79 20 74 65 73 74 6e 61 tests by testna
b400: 6d 65 20 61 6e 64 20 69 74 65 6d 64 61 74 20 69 me and itemdat i
b410: 6e 20 63 75 72 72 2d 74 65 73 74 73 2d 68 61 73 n curr-tests-has
b420: 68 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a h. (for-each.
b430: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 74 65 (lambda (te
b440: 73 74 64 61 74 29 0a 20 20 20 20 20 20 20 28 6c stdat). (l
b450: 65 74 2a 20 28 28 74 65 73 74 6e 61 6d 65 20 20 et* ((testname
b460: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 (db:test-get-tes
b470: 74 6e 61 6d 65 20 74 65 73 74 64 61 74 29 29 0a tname testdat)).
b480: 09 20 20 20 20 20 20 28 69 74 65 6d 2d 70 61 74 . (item-pat
b490: 68 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 h (db:test-get-i
b4a0: 74 65 6d 2d 70 61 74 68 20 74 65 73 74 64 61 74 tem-path testdat
b4b0: 29 29 0a 09 20 20 20 20 20 20 28 66 75 6c 6c 2d )).. (full-
b4c0: 6e 61 6d 65 20 28 63 6f 6e 63 20 74 65 73 74 6e name (conc testn
b4d0: 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 ame "/" item-pat
b4e0: 68 29 29 29 0a 09 20 28 68 61 73 68 2d 74 61 62 h))).. (hash-tab
b4f0: 6c 65 2d 73 65 74 21 20 63 75 72 72 2d 74 65 73 le-set! curr-tes
b500: 74 73 2d 68 61 73 68 20 66 75 6c 6c 2d 6e 61 6d ts-hash full-nam
b510: 65 20 74 65 73 74 64 61 74 29 29 29 0a 20 20 20 e testdat))).
b520: 20 20 63 75 72 72 2d 74 65 73 74 73 29 0a 20 20 curr-tests).
b530: 20 20 3b 3b 20 4e 4f 50 45 3a 20 4e 6f 6e 2d 6f ;; NOPE: Non-o
b540: 70 74 69 6d 61 6c 20 61 70 70 72 6f 61 63 68 2e ptimal approach.
b550: 20 54 72 79 20 74 68 69 73 20 69 6e 73 74 65 61 Try this instea
b560: 64 2e 0a 20 20 20 20 3b 3b 20 20 20 31 2e 20 74 d.. ;; 1. t
b570: 65 73 74 73 20 61 72 65 20 72 65 63 65 69 76 65 ests are receive
b580: 64 20 69 6e 20 61 20 6c 69 73 74 2c 20 6d 6f 73 d in a list, mos
b590: 74 20 72 65 63 65 6e 74 20 66 69 72 73 74 0a 20 t recent first.
b5a0: 20 20 20 3b 3b 20 20 20 32 2e 20 72 65 70 6c 61 ;; 2. repla
b5b0: 63 65 20 74 68 65 20 72 6f 6c 6c 75 70 20 74 65 ce the rollup te
b5c0: 73 74 20 77 69 74 68 20 74 68 65 20 6e 65 77 20 st with the new
b5d0: 2a 61 6c 77 61 79 73 2a 0a 20 20 20 20 28 66 6f *always*. (fo
b5e0: 72 2d 65 61 63 68 20 0a 20 20 20 20 20 28 6c 61 r-each . (la
b5f0: 6d 62 64 61 20 28 74 65 73 74 64 61 74 29 0a 20 mbda (testdat).
b600: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 65 (let* ((te
b610: 73 74 6e 61 6d 65 20 20 28 64 62 3a 74 65 73 74 stname (db:test
b620: 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 -get-testname te
b630: 73 74 64 61 74 29 29 0a 09 20 20 20 20 20 20 28 stdat)).. (
b640: 69 74 65 6d 2d 70 61 74 68 20 28 64 62 3a 74 65 item-path (db:te
b650: 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 st-get-item-path
b660: 20 74 65 73 74 64 61 74 29 29 0a 09 20 20 20 20 testdat))..
b670: 20 20 28 66 75 6c 6c 2d 6e 61 6d 65 20 28 63 6f (full-name (co
b680: 6e 63 20 74 65 73 74 6e 61 6d 65 20 22 2f 22 20 nc testname "/"
b690: 69 74 65 6d 2d 70 61 74 68 29 29 0a 09 20 20 20 item-path))..
b6a0: 20 20 20 28 70 72 65 76 2d 74 65 73 74 2d 64 61 (prev-test-da
b6b0: 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 t (hash-table-re
b6c0: 66 2f 64 65 66 61 75 6c 74 20 63 75 72 72 2d 74 f/default curr-t
b6d0: 65 73 74 73 2d 68 61 73 68 20 66 75 6c 6c 2d 6e ests-hash full-n
b6e0: 61 6d 65 20 23 66 29 29 0a 09 20 20 20 20 20 20 ame #f))..
b6f0: 28 74 65 73 74 2d 73 74 65 70 73 20 20 20 20 20 (test-steps
b700: 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 (open-run-close
b710: 20 64 62 3a 67 65 74 2d 73 74 65 70 73 2d 66 6f db:get-steps-fo
b720: 72 2d 74 65 73 74 20 64 62 20 28 64 62 3a 74 65 r-test db (db:te
b730: 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 64 61 st-get-id testda
b740: 74 29 29 29 0a 09 20 20 20 20 20 20 28 6e 65 77 t))).. (new
b750: 2d 74 65 73 74 2d 72 65 63 6f 72 64 20 23 66 29 -test-record #f)
b760: 29 0a 09 20 3b 3b 20 72 65 70 6c 61 63 65 20 74 ).. ;; replace t
b770: 68 65 73 65 20 77 69 74 68 20 69 6e 73 65 72 74 hese with insert
b780: 20 2e 2e 2e 20 73 65 6c 65 63 74 0a 09 20 28 61 ... select.. (a
b790: 70 70 6c 79 20 73 71 6c 69 74 65 33 3a 65 78 65 pply sqlite3:exe
b7a0: 63 75 74 65 20 0a 09 09 64 62 20 0a 09 09 28 63 cute ...db ...(c
b7b0: 6f 6e 63 20 22 49 4e 53 45 52 54 20 4f 52 20 52 onc "INSERT OR R
b7c0: 45 50 4c 41 43 45 20 49 4e 54 4f 20 74 65 73 74 EPLACE INTO test
b7d0: 73 20 28 72 75 6e 5f 69 64 2c 74 65 73 74 6e 61 s (run_id,testna
b7e0: 6d 65 2c 73 74 61 74 65 2c 73 74 61 74 75 73 2c me,state,status,
b7f0: 65 76 65 6e 74 5f 74 69 6d 65 2c 68 6f 73 74 2c event_time,host,
b800: 63 70 75 6c 6f 61 64 2c 64 69 73 6b 66 72 65 65 cpuload,diskfree
b810: 2c 75 6e 61 6d 65 2c 72 75 6e 64 69 72 2c 69 74 ,uname,rundir,it
b820: 65 6d 5f 70 61 74 68 2c 72 75 6e 5f 64 75 72 61 em_path,run_dura
b830: 74 69 6f 6e 2c 66 69 6e 61 6c 5f 6c 6f 67 66 2c tion,final_logf,
b840: 63 6f 6d 6d 65 6e 74 29 20 22 0a 09 09 20 20 20 comment) "...
b850: 20 20 20 22 56 41 4c 55 45 53 20 28 3f 2c 3f 2c "VALUES (?,?,
b860: 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c ?,?,?,?,?,?,?,?,
b870: 3f 2c 3f 2c 3f 2c 3f 29 3b 22 29 0a 09 09 6e 65 ?,?,?,?);")...ne
b880: 77 2d 72 75 6e 2d 69 64 20 28 63 64 64 72 20 28 w-run-id (cddr (
b890: 76 65 63 74 6f 72 2d 3e 6c 69 73 74 20 74 65 73 vector->list tes
b8a0: 74 64 61 74 29 29 29 0a 09 20 28 73 65 74 21 20 tdat))).. (set!
b8b0: 6e 65 77 2d 74 65 73 74 64 61 74 20 28 63 61 72 new-testdat (car
b8c0: 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 (open-run-close
b8d0: 20 64 62 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f db:get-tests-fo
b8e0: 72 2d 72 75 6e 20 64 62 20 6e 65 77 2d 72 75 6e r-run db new-run
b8f0: 2d 69 64 20 28 63 6f 6e 63 20 74 65 73 74 6e 61 -id (conc testna
b900: 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 me "/" item-path
b910: 29 20 27 28 29 20 27 28 29 29 29 29 0a 09 20 28 ) '() '()))).. (
b920: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
b930: 63 75 72 72 2d 74 65 73 74 73 2d 68 61 73 68 20 curr-tests-hash
b940: 66 75 6c 6c 2d 6e 61 6d 65 20 6e 65 77 2d 74 65 full-name new-te
b950: 73 74 64 61 74 29 20 3b 3b 20 74 68 69 73 20 63 stdat) ;; this c
b960: 6f 75 6c 64 20 62 65 20 63 6f 6e 66 75 73 69 6e ould be confusin
b970: 67 2c 20 77 68 69 63 68 20 72 65 63 6f 72 64 20 g, which record
b980: 73 68 6f 75 6c 64 20 67 6f 20 69 6e 74 6f 20 74 should go into t
b990: 68 65 20 6c 6f 6f 6b 75 70 20 74 61 62 6c 65 3f he lookup table?
b9a0: 0a 09 20 3b 3b 20 4e 6f 77 20 64 75 70 6c 69 63 .. ;; Now duplic
b9b0: 61 74 65 20 74 68 65 20 74 65 73 74 20 73 74 65 ate the test ste
b9c0: 70 73 0a 09 20 28 64 65 62 75 67 3a 70 72 69 6e ps.. (debug:prin
b9d0: 74 20 34 20 22 43 6f 70 79 69 6e 67 20 72 65 63 t 4 "Copying rec
b9e0: 6f 72 64 73 20 69 6e 20 74 65 73 74 5f 73 74 65 ords in test_ste
b9f0: 70 73 20 66 72 6f 6d 20 74 65 73 74 5f 69 64 3d ps from test_id=
ba00: 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 " (db:test-get-i
ba10: 64 20 74 65 73 74 64 61 74 29 20 22 20 74 6f 20 d testdat) " to
ba20: 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 " (db:test-get-i
ba30: 64 20 6e 65 77 2d 74 65 73 74 64 61 74 29 29 0a d new-testdat)).
ba40: 09 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 . (open-run-clos
ba50: 65 20 0a 09 20 20 28 6c 61 6d 62 64 61 20 28 29 e .. (lambda ()
ba60: 0a 09 20 20 20 20 28 73 71 6c 69 74 65 33 3a 65 .. (sqlite3:e
ba70: 78 65 63 75 74 65 20 0a 09 20 20 20 20 20 64 62 xecute .. db
ba80: 20 0a 09 20 20 20 20 20 28 63 6f 6e 63 20 22 49 .. (conc "I
ba90: 4e 53 45 52 54 20 4f 52 20 52 45 50 4c 41 43 45 NSERT OR REPLACE
baa0: 20 49 4e 54 4f 20 74 65 73 74 5f 73 74 65 70 73 INTO test_steps
bab0: 20 28 74 65 73 74 5f 69 64 2c 73 74 65 70 6e 61 (test_id,stepna
bac0: 6d 65 2c 73 74 61 74 65 2c 73 74 61 74 75 73 2c me,state,status,
bad0: 65 76 65 6e 74 5f 74 69 6d 65 2c 63 6f 6d 6d 65 event_time,comme
bae0: 6e 74 29 20 22 0a 09 09 20 20 20 22 53 45 4c 45 nt) "... "SELE
baf0: 43 54 20 22 20 28 64 62 3a 74 65 73 74 2d 67 65 CT " (db:test-ge
bb00: 74 2d 69 64 20 6e 65 77 2d 74 65 73 74 64 61 74 t-id new-testdat
bb10: 29 20 22 2c 73 74 65 70 6e 61 6d 65 2c 73 74 61 ) ",stepname,sta
bb20: 74 65 2c 73 74 61 74 75 73 2c 65 76 65 6e 74 5f te,status,event_
bb30: 74 69 6d 65 2c 63 6f 6d 6d 65 6e 74 20 46 52 4f time,comment FRO
bb40: 4d 20 74 65 73 74 5f 73 74 65 70 73 20 57 48 45 M test_steps WHE
bb50: 52 45 20 74 65 73 74 5f 69 64 3d 3f 3b 22 29 0a RE test_id=?;").
bb60: 09 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 . (db:test-g
bb70: 65 74 2d 69 64 20 74 65 73 74 64 61 74 29 29 0a et-id testdat)).
bb80: 09 20 20 20 20 3b 3b 20 4e 6f 77 20 64 75 70 6c . ;; Now dupl
bb90: 69 63 61 74 65 20 74 68 65 20 74 65 73 74 20 64 icate the test d
bba0: 61 74 61 0a 09 20 20 20 20 28 64 65 62 75 67 3a ata.. (debug:
bbb0: 70 72 69 6e 74 20 34 20 22 43 6f 70 79 69 6e 67 print 4 "Copying
bbc0: 20 72 65 63 6f 72 64 73 20 69 6e 20 74 65 73 74 records in test
bbd0: 5f 64 61 74 61 20 66 72 6f 6d 20 74 65 73 74 5f _data from test_
bbe0: 69 64 3d 22 20 28 64 62 3a 74 65 73 74 2d 67 65 id=" (db:test-ge
bbf0: 74 2d 69 64 20 74 65 73 74 64 61 74 29 20 22 20 t-id testdat) "
bc00: 74 6f 20 22 20 28 64 62 3a 74 65 73 74 2d 67 65 to " (db:test-ge
bc10: 74 2d 69 64 20 6e 65 77 2d 74 65 73 74 64 61 74 t-id new-testdat
bc20: 29 29 0a 09 20 20 20 20 28 73 71 6c 69 74 65 33 )).. (sqlite3
bc30: 3a 65 78 65 63 75 74 65 20 0a 09 20 20 20 20 20 :execute ..
bc40: 64 62 20 0a 09 20 20 20 20 20 28 63 6f 6e 63 20 db .. (conc
bc50: 22 49 4e 53 45 52 54 20 4f 52 20 52 45 50 4c 41 "INSERT OR REPLA
bc60: 43 45 20 49 4e 54 4f 20 74 65 73 74 5f 64 61 74 CE INTO test_dat
bc70: 61 20 28 74 65 73 74 5f 69 64 2c 63 61 74 65 67 a (test_id,categ
bc80: 6f 72 79 2c 76 61 72 69 61 62 6c 65 2c 76 61 6c ory,variable,val
bc90: 75 65 2c 65 78 70 65 63 74 65 64 2c 74 6f 6c 2c ue,expected,tol,
bca0: 75 6e 69 74 73 2c 63 6f 6d 6d 65 6e 74 29 20 22 units,comment) "
bcb0: 0a 09 09 20 20 20 22 53 45 4c 45 43 54 20 22 20 ... "SELECT "
bcc0: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 (db:test-get-id
bcd0: 6e 65 77 2d 74 65 73 74 64 61 74 29 20 22 2c 63 new-testdat) ",c
bce0: 61 74 65 67 6f 72 79 2c 76 61 72 69 61 62 6c 65 ategory,variable
bcf0: 2c 76 61 6c 75 65 2c 65 78 70 65 63 74 65 64 2c ,value,expected,
bd00: 74 6f 6c 2c 75 6e 69 74 73 2c 63 6f 6d 6d 65 6e tol,units,commen
bd10: 74 20 46 52 4f 4d 20 74 65 73 74 5f 64 61 74 61 t FROM test_data
bd20: 20 57 48 45 52 45 20 74 65 73 74 5f 69 64 3d 3f WHERE test_id=?
bd30: 3b 22 29 0a 09 20 20 20 20 20 28 64 62 3a 74 65 ;").. (db:te
bd40: 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 64 61 st-get-id testda
bd50: 74 29 29 29 29 0a 09 20 29 29 0a 20 20 20 20 20 t)))).. )).
bd60: 70 72 65 76 2d 74 65 73 74 73 29 29 29 0a 09 20 prev-tests)))..
bd70: 0a 20 20 20 20 20 0a . .