0000: 0a 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 32 30 .;; Copyright 20
0010: 30 36 2d 32 30 31 31 2c 20 4d 61 74 74 68 65 77 06-2011, Matthew
0020: 20 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 0a 3b 3b Welland..;; .;;
0030: 20 20 54 68 69 73 20 70 72 6f 67 72 61 6d 20 69 This program i
0040: 73 20 6d 61 64 65 20 61 76 61 69 6c 61 62 6c 65 s made available
0050: 20 75 6e 64 65 72 20 74 68 65 20 47 4e 55 20 47 under the GNU G
0060: 50 4c 20 76 65 72 73 69 6f 6e 20 32 2e 30 20 6f PL version 2.0 o
0070: 72 0a 3b 3b 20 20 67 72 65 61 74 65 72 2e 20 53 r.;; greater. S
0080: 65 65 20 74 68 65 20 61 63 63 6f 6d 70 61 6e 79 ee the accompany
0090: 69 6e 67 20 66 69 6c 65 20 43 4f 50 59 49 4e 47 ing file COPYING
00a0: 20 66 6f 72 20 64 65 74 61 69 6c 73 2e 0a 3b 3b for details..;;
00b0: 20 0a 3b 3b 20 20 54 68 69 73 20 70 72 6f 67 72 .;; This progr
00c0: 61 6d 20 69 73 20 64 69 73 74 72 69 62 75 74 65 am is distribute
00d0: 64 20 57 49 54 48 4f 55 54 20 41 4e 59 20 57 41 d WITHOUT ANY WA
00e0: 52 52 41 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 RRANTY; without
00f0: 65 76 65 6e 20 74 68 65 0a 3b 3b 20 20 69 6d 70 even the.;; imp
0100: 6c 69 65 64 20 77 61 72 72 61 6e 74 79 20 6f 66 lied warranty of
0110: 20 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 MERCHANTABILITY
0120: 20 6f 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 or FITNESS FOR
0130: 41 20 50 41 52 54 49 43 55 4c 41 52 0a 3b 3b 20 A PARTICULAR.;;
0140: 20 50 55 52 50 4f 53 45 2e 0a 0a 3b 3b 20 20 73 PURPOSE...;; s
0150: 74 72 66 74 69 6d 65 28 27 25 6d 2f 25 64 2f 25 trftime('%m/%d/%
0160: 59 20 25 48 3a 25 4d 3a 25 53 27 2c 27 6e 6f 77 Y %H:%M:%S','now
0170: 27 2c 27 6c 6f 63 61 6c 74 69 6d 65 27 29 0a 0a ','localtime')..
0180: 28 75 73 65 20 73 71 6c 69 74 65 33 20 73 72 66 (use sqlite3 srf
0190: 69 2d 31 20 70 6f 73 69 78 20 72 65 67 65 78 20 i-1 posix regex
01a0: 72 65 67 65 78 2d 63 61 73 65 20 73 72 66 69 2d regex-case srfi-
01b0: 36 39 20 64 6f 74 2d 6c 6f 63 6b 69 6e 67 29 0a 69 dot-locking).
01c0: 28 69 6d 70 6f 72 74 20 28 70 72 65 66 69 78 20 (import (prefix
01d0: 73 71 6c 69 74 65 33 20 73 71 6c 69 74 65 33 3a sqlite3 sqlite3:
01e0: 29 29 0a 0a 28 64 65 63 6c 61 72 65 20 28 75 6e ))..(declare (un
01f0: 69 74 20 72 75 6e 73 29 29 0a 28 64 65 63 6c 61 it runs)).(decla
0200: 72 65 20 28 75 73 65 73 20 64 62 29 29 0a 28 64 re (uses db)).(d
0210: 65 63 6c 61 72 65 20 28 75 73 65 73 20 63 6f 6d eclare (uses com
0220: 6d 6f 6e 29 29 0a 28 64 65 63 6c 61 72 65 20 28 mon)).(declare (
0230: 75 73 65 73 20 69 74 65 6d 73 29 29 0a 28 64 65 uses items)).(de
0240: 63 6c 61 72 65 20 28 75 73 65 73 20 72 75 6e 63 clare (uses runc
0250: 6f 6e 66 69 67 29 29 0a 0a 28 69 6e 63 6c 75 64 onfig))..(includ
0260: 65 20 22 63 6f 6d 6d 6f 6e 5f 72 65 63 6f 72 64 e "common_record
0270: 73 2e 73 63 6d 22 29 0a 28 69 6e 63 6c 75 64 65 s.scm").(include
0280: 20 22 6b 65 79 5f 72 65 63 6f 72 64 73 2e 73 63 "key_records.sc
0290: 6d 22 29 0a 28 69 6e 63 6c 75 64 65 20 22 64 62 m").(include "db
02a0: 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a 28 _records.scm").(
02b0: 69 6e 63 6c 75 64 65 20 22 72 75 6e 5f 72 65 63 include "run_rec
02c0: 6f 72 64 73 2e 73 63 6d 22 29 0a 0a 3b 3b 20 72 ords.scm")..;; r
02d0: 65 67 69 73 74 65 72 20 61 20 74 65 73 74 20 72 egister a test r
02e0: 75 6e 20 77 69 74 68 20 74 68 65 20 64 62 0a 28 un with the db.(
02f0: 64 65 66 69 6e 65 20 28 72 65 67 69 73 74 65 72 define (register
0300: 2d 72 75 6e 20 64 62 20 6b 65 79 73 29 20 3b 3b -run db keys) ;;
0310: 20 74 65 73 74 2d 6e 61 6d 65 29 0a 20 20 28 6c test-name). (l
0320: 65 74 2a 20 28 28 6b 65 79 73 74 72 20 20 20 20 et* ((keystr
0330: 28 6b 65 79 73 2d 3e 6b 65 79 73 74 72 20 6b 65 (keys->keystr ke
0340: 79 73 29 29 0a 09 20 28 63 6f 6d 6d 61 20 20 20 ys)).. (comma
0350: 20 20 28 69 66 20 28 3e 20 28 6c 65 6e 67 74 68 (if (> (length
0360: 20 6b 65 79 73 29 20 30 29 20 22 2c 22 20 22 22 keys) 0) "," ""
0370: 29 29 0a 09 20 28 61 6e 64 73 74 72 20 20 20 20 )).. (andstr
0380: 28 69 66 20 28 3e 20 28 6c 65 6e 67 74 68 20 6b (if (> (length k
0390: 65 79 73 29 20 30 29 20 22 20 41 4e 44 20 22 20 eys) 0) " AND "
03a0: 22 22 29 29 0a 09 20 28 76 61 6c 73 6c 6f 74 73 "")).. (valslots
03b0: 20 20 28 6b 65 79 73 2d 3e 76 61 6c 73 6c 6f 74 (keys->valslot
03c0: 73 20 6b 65 79 73 29 29 20 3b 3b 20 3f 2c 3f 2c s keys)) ;; ?,?,
03d0: 3f 20 2e 2e 2e 0a 09 20 28 6b 65 79 76 61 6c 6c ? ..... (keyvall
03e0: 73 74 20 28 6b 65 79 73 2d 3e 76 61 6c 6c 69 73 st (keys->vallis
03f0: 74 20 6b 65 79 73 29 29 20 3b 3b 20 65 78 74 72 t keys)) ;; extr
0400: 61 63 74 73 20 74 68 65 20 76 61 6c 75 65 73 20 acts the values
0410: 66 72 6f 6d 20 72 65 6d 61 69 6e 64 65 72 20 6f from remainder o
0420: 66 20 28 61 72 67 76 29 0a 09 20 28 72 75 6e 6e f (argv).. (runn
0430: 61 6d 65 20 20 20 28 67 65 74 2d 77 69 74 68 2d ame (get-with-
0440: 64 65 66 61 75 6c 74 20 22 3a 72 75 6e 6e 61 6d default ":runnam
0450: 65 22 20 23 66 29 29 0a 09 20 28 73 74 61 74 65 e" #f)).. (state
0460: 20 20 20 20 20 28 67 65 74 2d 77 69 74 68 2d 64 (get-with-d
0470: 65 66 61 75 6c 74 20 22 3a 73 74 61 74 65 22 20 efault ":state"
0480: 22 6e 6f 22 29 29 0a 09 20 28 73 74 61 74 75 73 "no")).. (status
0490: 20 20 20 20 28 67 65 74 2d 77 69 74 68 2d 64 65 (get-with-de
04a0: 66 61 75 6c 74 20 22 3a 73 74 61 74 75 73 22 20 fault ":status"
04b0: 22 6e 2f 61 22 29 29 0a 09 20 28 61 6c 6c 76 61 "n/a")).. (allva
04c0: 6c 73 20 20 20 28 61 70 70 65 6e 64 20 28 6c 69 ls (append (li
04d0: 73 74 20 72 75 6e 6e 61 6d 65 20 73 74 61 74 65 st runname state
04e0: 20 73 74 61 74 75 73 20 75 73 65 72 29 20 6b 65 status user) ke
04f0: 79 76 61 6c 6c 73 74 29 29 0a 09 20 28 71 72 79 yvallst)).. (qry
0500: 76 61 6c 73 20 20 20 28 61 70 70 65 6e 64 20 28 vals (append (
0510: 6c 69 73 74 20 72 75 6e 6e 61 6d 65 29 20 6b 65 list runname) ke
0520: 79 76 61 6c 6c 73 74 29 29 0a 09 20 28 6b 65 79 yvallst)).. (key
0530: 3d 3f 73 74 72 20 20 28 73 74 72 69 6e 67 2d 69 =?str (string-i
0540: 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 20 ntersperse (map
0550: 28 6c 61 6d 62 64 61 20 28 6b 29 28 63 6f 6e 63 (lambda (k)(conc
0560: 20 28 6b 65 79 3a 67 65 74 2d 66 69 65 6c 64 6e (key:get-fieldn
0570: 61 6d 65 20 6b 29 20 22 3d 3f 22 29 29 20 6b 65 ame k) "=?")) ke
0580: 79 73 29 20 22 20 41 4e 44 20 22 29 29 29 0a 20 ys) " AND "))).
0590: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
05a0: 33 20 22 6b 65 79 73 3a 20 22 20 6b 65 79 73 20 3 "keys: " keys
05b0: 22 20 61 6c 6c 76 61 6c 73 3a 20 22 20 61 6c 6c " allvals: " all
05c0: 76 61 6c 73 20 22 20 6b 65 79 76 61 6c 6c 73 74 vals " keyvallst
05d0: 3a 20 22 20 6b 65 79 76 61 6c 6c 73 74 29 0a 20 : " keyvallst).
05e0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
05f0: 32 20 22 4e 4f 54 45 3a 20 75 73 69 6e 67 20 6b 2 "NOTE: using k
0600: 65 79 20 22 20 28 73 74 72 69 6e 67 2d 69 6e 74 ey " (string-int
0610: 65 72 73 70 65 72 73 65 20 6b 65 79 76 61 6c 6c ersperse keyvall
0620: 73 74 20 22 2f 22 29 20 22 20 66 6f 72 20 74 68 st "/") " for th
0630: 69 73 20 72 75 6e 22 29 0a 20 20 20 20 28 69 66 is run"). (if
0640: 20 28 61 6e 64 20 72 75 6e 6e 61 6d 65 20 28 6e (and runname (n
0650: 75 6c 6c 3f 20 28 66 69 6c 74 65 72 20 28 6c 61 ull? (filter (la
0660: 6d 62 64 61 20 28 78 29 28 6e 6f 74 20 78 29 29 mbda (x)(not x))
0670: 20 6b 65 79 76 61 6c 6c 73 74 29 29 29 20 3b 3b keyvallst))) ;;
0680: 20 74 68 65 72 65 20 6d 75 73 74 20 62 65 20 61 there must be a
0690: 20 62 65 74 74 65 72 20 77 61 79 20 74 6f 20 22 better way to "
06a0: 61 70 70 6c 79 20 61 6e 64 22 0a 09 28 6c 65 74 apply and"..(let
06b0: 20 28 28 72 65 73 20 23 66 29 29 0a 09 20 20 28 ((res #f)).. (
06c0: 61 70 70 6c 79 20 73 71 6c 69 74 65 33 3a 65 78 apply sqlite3:ex
06d0: 65 63 75 74 65 20 64 62 20 28 63 6f 6e 63 20 22 ecute db (conc "
06e0: 49 4e 53 45 52 54 20 4f 52 20 49 47 4e 4f 52 45 INSERT OR IGNORE
06f0: 20 49 4e 54 4f 20 72 75 6e 73 20 28 72 75 6e 6e INTO runs (runn
0700: 61 6d 65 2c 73 74 61 74 65 2c 73 74 61 74 75 73 ame,state,status
0710: 2c 6f 77 6e 65 72 2c 65 76 65 6e 74 5f 74 69 6d ,owner,event_tim
0720: 65 22 20 63 6f 6d 6d 61 20 6b 65 79 73 74 72 20 e" comma keystr
0730: 22 29 20 56 41 4c 55 45 53 20 28 3f 2c 3f 2c 3f ") VALUES (?,?,?
0740: 2c 3f 2c 73 74 72 66 74 69 6d 65 28 27 25 73 27 ,?,strftime('%s'
0750: 2c 27 6e 6f 77 27 29 22 20 63 6f 6d 6d 61 20 76 ,'now')" comma v
0760: 61 6c 73 6c 6f 74 73 20 22 29 3b 22 29 0a 09 09 alslots ");")...
0770: 20 61 6c 6c 76 61 6c 73 29 0a 09 20 20 28 61 70 allvals).. (ap
0780: 70 6c 79 20 73 71 6c 69 74 65 33 3a 66 6f 72 2d ply sqlite3:for-
0790: 65 61 63 68 2d 72 6f 77 20 0a 09 20 20 20 28 6c each-row .. (l
07a0: 61 6d 62 64 61 20 28 69 64 29 0a 09 20 20 20 20 ambda (id)..
07b0: 20 28 73 65 74 21 20 72 65 73 20 69 64 29 29 0a (set! res id)).
07c0: 09 20 20 20 64 62 0a 09 20 20 20 28 6c 65 74 20 . db.. (let
07d0: 28 28 71 72 79 20 28 63 6f 6e 63 20 22 53 45 4c ((qry (conc "SEL
07e0: 45 43 54 20 69 64 20 46 52 4f 4d 20 72 75 6e 73 ECT id FROM runs
07f0: 20 57 48 45 52 45 20 28 72 75 6e 6e 61 6d 65 3d WHERE (runname=
0800: 3f 20 22 20 61 6e 64 73 74 72 20 6b 65 79 3d 3f ? " andstr key=?
0810: 73 74 72 20 22 29 3b 22 29 29 29 0a 09 20 20 20 str ");")))..
0820: 20 20 3b 28 64 65 62 75 67 3a 70 72 69 6e 74 20 ;(debug:print
0830: 34 20 22 71 72 79 3a 20 22 20 71 72 79 29 20 0a 4 "qry: " qry) .
0840: 09 20 20 20 20 20 71 72 79 29 0a 09 20 20 20 71 . qry).. q
0850: 72 79 76 61 6c 73 29 0a 09 20 20 28 73 71 6c 69 ryvals).. (sqli
0860: 74 65 33 3a 65 78 65 63 75 74 65 20 64 62 20 22 te3:execute db "
0870: 55 50 44 41 54 45 20 72 75 6e 73 20 53 45 54 20 UPDATE runs SET
0880: 73 74 61 74 65 3d 3f 2c 73 74 61 74 75 73 3d 3f state=?,status=?
0890: 20 57 48 45 52 45 20 69 64 3d 3f 3b 22 20 73 74 WHERE id=?;" st
08a0: 61 74 65 20 73 74 61 74 75 73 20 72 65 73 29 0a ate status res).
08b0: 09 20 20 72 65 73 29 20 0a 09 28 62 65 67 69 6e . res) ..(begin
08c0: 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
08d0: 20 30 20 22 45 52 52 4f 52 3a 20 43 61 6c 6c 65 0 "ERROR: Calle
08e0: 64 20 77 69 74 68 6f 75 74 20 61 6c 6c 20 6e 65 d without all ne
08f0: 63 65 73 73 61 72 79 20 6b 65 79 73 22 29 0a 09 cessary keys")..
0900: 20 20 23 66 29 29 29 29 0a 0a 3b 3b 20 72 75 6e #f))))..;; run
0910: 73 3a 67 65 74 2d 72 75 6e 73 2d 62 79 2d 70 61 s:get-runs-by-pa
0920: 74 74 0a 3b 3b 20 67 65 74 20 72 75 6e 73 20 62 tt.;; get runs b
0930: 79 20 6c 69 73 74 20 6f 66 20 63 72 69 74 65 72 y list of criter
0940: 69 61 0a 3b 3b 20 72 65 67 69 73 74 65 72 20 61 ia.;; register a
0950: 20 74 65 73 74 20 72 75 6e 20 77 69 74 68 20 74 test run with t
0960: 68 65 20 64 62 0a 3b 3b 0a 3b 3b 20 55 73 65 3a he db.;;.;; Use:
0970: 20 28 64 62 2d 67 65 74 2d 76 61 6c 75 65 2d 62 (db-get-value-b
0980: 79 2d 68 65 61 64 65 72 20 28 64 62 3a 67 65 74 y-header (db:get
0990: 2d 68 65 61 64 65 72 20 72 75 6e 69 6e 66 6f 29 -header runinfo)
09a0: 28 64 62 3a 67 65 74 2d 72 6f 77 20 72 75 6e 69 (db:get-row runi
09b0: 6e 66 6f 29 29 0a 3b 3b 20 20 74 6f 20 65 78 74 nfo)).;; to ext
09c0: 72 61 63 74 20 69 6e 66 6f 20 66 72 6f 6d 20 74 ract info from t
09d0: 68 65 20 73 74 72 75 63 74 75 72 65 20 72 65 74 he structure ret
09e0: 75 72 6e 65 64 0a 3b 3b 0a 28 64 65 66 69 6e 65 urned.;;.(define
09f0: 20 28 72 75 6e 73 3a 67 65 74 2d 72 75 6e 73 2d (runs:get-runs-
0a00: 62 79 2d 70 61 74 74 20 64 62 20 6b 65 79 73 20 by-patt db keys
0a10: 72 75 6e 6e 61 6d 65 70 61 74 74 20 2e 20 70 61 runnamepatt . pa
0a20: 72 61 6d 73 29 20 3b 3b 20 74 65 73 74 2d 6e 61 rams) ;; test-na
0a30: 6d 65 29 0a 20 20 28 6c 65 74 2a 20 28 28 6b 65 me). (let* ((ke
0a40: 79 76 61 6c 6c 73 74 20 28 6b 65 79 73 2d 3e 76 yvallst (keys->v
0a50: 61 6c 6c 69 73 74 20 6b 65 79 73 29 29 0a 09 20 allist keys))..
0a60: 28 74 6d 70 20 20 20 20 20 20 28 72 75 6e 73 3a (tmp (runs:
0a70: 67 65 74 2d 73 74 64 2d 72 75 6e 2d 66 69 65 6c get-std-run-fiel
0a80: 64 73 20 6b 65 79 73 20 27 28 22 69 64 22 20 22 ds keys '("id" "
0a90: 72 75 6e 6e 61 6d 65 22 20 22 73 74 61 74 65 22 runname" "state"
0aa0: 20 22 73 74 61 74 75 73 22 20 22 6f 77 6e 65 72 "status" "owner
0ab0: 22 20 22 65 76 65 6e 74 5f 74 69 6d 65 22 29 29 " "event_time"))
0ac0: 29 0a 09 20 28 6b 65 79 73 74 72 20 20 20 28 63 ).. (keystr (c
0ad0: 61 72 20 74 6d 70 29 29 0a 09 20 28 68 65 61 64 ar tmp)).. (head
0ae0: 65 72 20 20 20 28 63 61 64 72 20 74 6d 70 29 29 er (cadr tmp))
0af0: 0a 09 20 28 72 65 73 20 20 20 20 20 27 28 29 29 .. (res '())
0b00: 0a 09 20 28 6b 65 79 2d 70 61 74 74 20 22 22 29 .. (key-patt "")
0b10: 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 ). (for-each
0b20: 28 6c 61 6d 62 64 61 20 28 6b 65 79 76 61 6c 29 (lambda (keyval)
0b30: 0a 09 09 28 6c 65 74 2a 20 28 28 6b 65 79 20 20 ...(let* ((key
0b40: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 6b 65 (vector-ref ke
0b50: 79 76 61 6c 20 30 29 29 0a 09 09 20 20 20 20 20 yval 0))...
0b60: 20 20 28 66 75 6c 6b 65 79 20 28 63 6f 6e 63 20 (fulkey (conc
0b70: 22 3a 22 20 6b 65 79 29 29 0a 09 09 20 20 20 20 ":" key))...
0b80: 20 20 20 28 70 61 74 74 20 20 20 28 61 72 67 73 (patt (args
0b90: 3a 67 65 74 2d 61 72 67 20 66 75 6c 6b 65 79 29 :get-arg fulkey)
0ba0: 29 29 0a 09 09 20 20 28 69 66 20 70 61 74 74 0a ))... (if patt.
0bb0: 09 09 20 20 20 20 20 20 28 73 65 74 21 20 6b 65 .. (set! ke
0bc0: 79 2d 70 61 74 74 20 28 63 6f 6e 63 20 6b 65 79 y-patt (conc key
0bd0: 2d 70 61 74 74 20 22 20 41 4e 44 20 22 20 6b 65 -patt " AND " ke
0be0: 79 20 22 20 6c 69 6b 65 20 27 22 20 70 61 74 74 y " like '" patt
0bf0: 20 22 27 22 29 29 0a 09 09 20 20 20 20 20 20 28 "'"))... (
0c00: 62 65 67 69 6e 0a 09 09 09 28 64 65 62 75 67 3a begin....(debug:
0c10: 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 print 0 "ERROR:
0c20: 73 65 61 72 63 68 69 6e 67 20 66 6f 72 20 72 75 searching for ru
0c30: 6e 73 20 77 69 74 68 20 6e 6f 20 70 61 74 74 65 ns with no patte
0c40: 72 6e 20 73 65 74 20 66 6f 72 20 22 20 66 75 6c rn set for " ful
0c50: 6b 65 79 29 0a 09 09 09 28 65 78 69 74 20 36 29 key)....(exit 6)
0c60: 29 29 29 29 0a 09 20 20 20 20 20 20 6b 65 79 73 )))).. keys
0c70: 29 0a 20 20 20 20 28 73 71 6c 69 74 65 33 3a 66 ). (sqlite3:f
0c80: 6f 72 2d 65 61 63 68 2d 72 6f 77 20 0a 20 20 20 or-each-row .
0c90: 20 20 28 6c 61 6d 62 64 61 20 28 61 20 2e 20 72 (lambda (a . r
0ca0: 29 0a 20 20 20 20 20 20 20 28 73 65 74 21 20 72 ). (set! r
0cb0: 65 73 20 28 63 6f 6e 73 20 28 6c 69 73 74 2d 3e es (cons (list->
0cc0: 76 65 63 74 6f 72 20 28 63 6f 6e 73 20 61 20 72 vector (cons a r
0cd0: 29 29 20 72 65 73 29 29 29 0a 20 20 20 20 20 64 )) res))). d
0ce0: 62 20 0a 20 20 20 20 20 28 63 6f 6e 63 20 22 53 b . (conc "S
0cf0: 45 4c 45 43 54 20 22 20 6b 65 79 73 74 72 20 22 ELECT " keystr "
0d00: 20 46 52 4f 4d 20 72 75 6e 73 20 57 48 45 52 45 FROM runs WHERE
0d10: 20 72 75 6e 6e 61 6d 65 20 6c 69 6b 65 20 3f 20 runname like ?
0d20: 22 20 6b 65 79 2d 70 61 74 74 20 22 3b 22 29 0a " key-patt ";").
0d30: 20 20 20 20 20 72 75 6e 6e 61 6d 65 70 61 74 74 runnamepatt
0d40: 29 0a 20 20 20 20 28 76 65 63 74 6f 72 20 68 65 ). (vector he
0d50: 61 64 65 72 20 72 65 73 29 29 29 0a 0a 28 64 65 ader res)))..(de
0d60: 66 69 6e 65 20 28 72 65 67 69 73 74 65 72 2d 74 fine (register-t
0d70: 65 73 74 20 64 62 20 72 75 6e 2d 69 64 20 74 65 est db run-id te
0d80: 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 st-name item-pat
0d90: 68 29 0a 20 20 28 6c 65 74 20 28 28 69 74 65 6d h). (let ((item
0da0: 2d 70 61 74 68 73 20 28 69 66 20 28 65 71 75 61 -paths (if (equa
0db0: 6c 3f 20 69 74 65 6d 2d 70 61 74 68 20 22 22 29 l? item-path "")
0dc0: 0a 09 09 09 28 6c 69 73 74 20 69 74 65 6d 2d 70 ....(list item-p
0dd0: 61 74 68 29 0a 09 09 09 28 6c 69 73 74 20 69 74 ath)....(list it
0de0: 65 6d 2d 70 61 74 68 20 22 22 29 29 29 29 0a 20 em-path "")))).
0df0: 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 (for-each .
0e00: 20 20 20 28 6c 61 6d 62 64 61 20 28 70 74 68 29 (lambda (pth)
0e10: 0a 20 20 20 20 20 20 20 28 73 71 6c 69 74 65 33 . (sqlite3
0e20: 3a 65 78 65 63 75 74 65 20 64 62 20 22 49 4e 53 :execute db "INS
0e30: 45 52 54 20 4f 52 20 49 47 4e 4f 52 45 20 49 4e ERT OR IGNORE IN
0e40: 54 4f 20 74 65 73 74 73 20 28 72 75 6e 5f 69 64 TO tests (run_id
0e50: 2c 74 65 73 74 6e 61 6d 65 2c 65 76 65 6e 74 5f ,testname,event_
0e60: 74 69 6d 65 2c 69 74 65 6d 5f 70 61 74 68 2c 73 time,item_path,s
0e70: 74 61 74 65 2c 73 74 61 74 75 73 29 20 56 41 4c tate,status) VAL
0e80: 55 45 53 20 28 3f 2c 3f 2c 73 74 72 66 74 69 6d UES (?,?,strftim
0e90: 65 28 27 25 73 27 2c 27 6e 6f 77 27 29 2c 3f 2c e('%s','now'),?,
0ea0: 27 4e 4f 54 5f 53 54 41 52 54 45 44 27 2c 27 6e 'NOT_STARTED','n
0eb0: 2f 61 27 29 3b 22 20 0a 09 09 09 72 75 6e 2d 69 /a');" ....run-i
0ec0: 64 20 0a 09 09 09 74 65 73 74 2d 6e 61 6d 65 0a d ....test-name.
0ed0: 09 09 09 70 74 68 20 0a 09 09 09 3b 3b 20 28 63 ...pth ....;; (c
0ee0: 6f 6e 63 20 22 2c 22 20 28 73 74 72 69 6e 67 2d onc "," (string-
0ef0: 69 6e 74 65 72 73 70 65 72 73 65 20 74 61 67 73 intersperse tags
0f00: 20 22 2c 22 29 20 22 2c 22 29 0a 09 09 09 29 29 ",") ",")....))
0f10: 0a 20 20 20 20 20 69 74 65 6d 2d 70 61 74 68 73 . item-paths
0f20: 20 29 29 29 0a 0a 3b 3b 20 67 65 74 20 74 68 65 )))..;; get the
0f30: 20 70 72 65 76 69 6f 75 73 20 72 65 63 6f 72 64 previous record
0f40: 20 66 6f 72 20 77 68 65 6e 20 74 68 69 73 20 74 for when this t
0f50: 65 73 74 20 77 61 73 20 72 75 6e 20 77 68 65 72 est was run wher
0f60: 65 20 61 6c 6c 20 6b 65 79 73 20 6d 61 74 63 68 e all keys match
0f70: 20 62 75 74 20 72 75 6e 6e 61 6d 65 0a 3b 3b 20 but runname.;;
0f80: 72 65 74 75 72 6e 73 20 23 66 20 69 66 20 6e 6f returns #f if no
0f90: 20 73 75 63 68 20 74 65 73 74 20 66 6f 75 6e 64 such test found
0fa0: 2c 20 72 65 74 75 72 6e 73 20 61 20 73 69 6e 67 , returns a sing
0fb0: 6c 65 20 74 65 73 74 20 72 65 63 6f 72 64 20 69 le test record i
0fc0: 66 20 66 6f 75 6e 64 0a 28 64 65 66 69 6e 65 20 f found.(define
0fd0: 28 74 65 73 74 3a 67 65 74 2d 70 72 65 76 69 6f (test:get-previo
0fe0: 75 73 2d 74 65 73 74 2d 72 75 6e 2d 72 65 63 6f us-test-run-reco
0ff0: 72 64 20 64 62 20 72 75 6e 2d 69 64 20 74 65 73 rd db run-id tes
1000: 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 t-name item-path
1010: 29 0a 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 73 ). (let* ((keys
1020: 20 20 20 20 28 64 62 3a 67 65 74 2d 6b 65 79 73 (db:get-keys
1030: 20 64 62 29 29 0a 09 20 28 73 65 6c 73 74 72 20 db)).. (selstr
1040: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
1050: 65 72 73 65 20 28 6d 61 70 20 28 6c 61 6d 62 64 erse (map (lambd
1060: 61 20 28 78 29 28 76 65 63 74 6f 72 2d 72 65 66 a (x)(vector-ref
1070: 20 78 20 30 29 29 20 6b 65 79 73 29 20 22 2c 22 x 0)) keys) ","
1080: 29 29 0a 09 20 28 71 72 79 73 74 72 20 20 28 73 )).. (qrystr (s
1090: 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 tring-interspers
10a0: 65 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 e (map (lambda (
10b0: 78 29 28 63 6f 6e 63 20 28 76 65 63 74 6f 72 2d x)(conc (vector-
10c0: 72 65 66 20 78 20 30 29 20 22 3d 3f 22 29 29 20 ref x 0) "=?"))
10d0: 6b 65 79 73 29 20 22 20 41 4e 44 20 22 29 29 0a keys) " AND ")).
10e0: 09 20 28 6b 65 79 76 61 6c 73 20 23 66 29 29 0a . (keyvals #f)).
10f0: 20 20 20 20 3b 3b 20 66 69 72 73 74 20 6c 6f 6f ;; first loo
1100: 6b 20 75 70 20 74 68 65 20 6b 65 79 20 76 61 6c k up the key val
1110: 75 65 73 20 66 72 6f 6d 20 74 68 65 20 72 75 6e ues from the run
1120: 20 73 65 6c 65 63 74 65 64 20 62 79 20 72 75 6e selected by run
1130: 2d 69 64 0a 20 20 20 20 28 73 71 6c 69 74 65 33 -id. (sqlite3
1140: 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 0a 20 :for-each-row .
1150: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 61 20 2e (lambda (a .
1160: 20 62 29 0a 20 20 20 20 20 20 20 28 73 65 74 21 b). (set!
1170: 20 6b 65 79 76 61 6c 73 20 28 63 6f 6e 73 20 61 keyvals (cons a
1180: 20 62 29 29 29 0a 20 20 20 20 20 64 62 0a 20 20 b))). db.
1190: 20 20 20 28 63 6f 6e 63 20 22 53 45 4c 45 43 54 (conc "SELECT
11a0: 20 22 20 73 65 6c 73 74 72 20 22 20 46 52 4f 4d " selstr " FROM
11b0: 20 72 75 6e 73 20 57 48 45 52 45 20 69 64 3d 3f runs WHERE id=?
11c0: 20 4f 52 44 45 52 20 42 59 20 65 76 65 6e 74 5f ORDER BY event_
11d0: 74 69 6d 65 20 44 45 53 43 3b 22 29 20 72 75 6e time DESC;") run
11e0: 2d 69 64 29 0a 20 20 20 20 28 69 66 20 28 6e 6f -id). (if (no
11f0: 74 20 6b 65 79 76 61 6c 73 29 0a 09 23 66 0a 09 t keyvals)..#f..
1200: 28 6c 65 74 20 28 28 70 72 65 76 2d 72 75 6e 2d (let ((prev-run-
1210: 69 64 73 20 27 28 29 29 29 0a 09 20 20 28 61 70 ids '())).. (ap
1220: 70 6c 79 20 73 71 6c 69 74 65 33 3a 66 6f 72 2d ply sqlite3:for-
1230: 65 61 63 68 2d 72 6f 77 0a 09 09 20 28 6c 61 6d each-row... (lam
1240: 62 64 61 20 28 69 64 29 0a 09 09 20 20 20 28 73 bda (id)... (s
1250: 65 74 21 20 70 72 65 76 2d 72 75 6e 2d 69 64 73 et! prev-run-ids
1260: 20 28 63 6f 6e 73 20 69 64 20 70 72 65 76 2d 72 (cons id prev-r
1270: 75 6e 2d 69 64 73 29 29 29 0a 09 09 20 64 62 0a un-ids)))... db.
1280: 09 09 20 28 63 6f 6e 63 20 22 53 45 4c 45 43 54 .. (conc "SELECT
1290: 20 69 64 20 46 52 4f 4d 20 72 75 6e 73 20 57 48 id FROM runs WH
12a0: 45 52 45 20 22 20 71 72 79 73 74 72 20 22 20 41 ERE " qrystr " A
12b0: 4e 44 20 69 64 20 21 3d 20 3f 3b 22 29 20 28 61 ND id != ?;") (a
12c0: 70 70 65 6e 64 20 6b 65 79 76 61 6c 73 20 28 6c ppend keyvals (l
12d0: 69 73 74 20 72 75 6e 2d 69 64 29 29 29 0a 09 20 ist run-id)))..
12e0: 20 3b 3b 20 66 6f 72 20 65 61 63 68 20 72 75 6e ;; for each run
12f0: 20 73 74 61 72 74 69 6e 67 20 77 69 74 68 20 74 starting with t
1300: 68 65 20 6d 6f 73 74 20 72 65 63 65 6e 74 20 6c he most recent l
1310: 6f 6f 6b 20 74 6f 20 73 65 65 20 69 66 20 74 68 ook to see if th
1320: 65 72 65 20 69 73 20 61 20 6d 61 74 63 68 69 6e ere is a matchin
1330: 67 20 74 65 73 74 0a 09 20 20 3b 3b 20 69 66 20 g test.. ;; if
1340: 66 6f 75 6e 64 20 74 68 65 6e 20 72 65 74 75 72 found then retur
1350: 6e 20 74 68 61 74 20 6d 61 74 63 68 69 6e 67 20 n that matching
1360: 74 65 73 74 20 72 65 63 6f 72 64 0a 09 20 20 28 test record.. (
1370: 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 73 debug:print 4 "s
1380: 65 6c 73 74 72 3a 20 22 20 73 65 6c 73 74 72 20 elstr: " selstr
1390: 22 2c 20 71 72 79 73 74 72 3a 20 22 20 71 72 79 ", qrystr: " qry
13a0: 73 74 72 20 22 2c 20 6b 65 79 76 61 6c 73 3a 20 str ", keyvals:
13b0: 22 20 6b 65 79 76 61 6c 73 20 22 2c 20 70 72 65 " keyvals ", pre
13c0: 76 69 6f 75 73 20 72 75 6e 20 69 64 73 20 66 6f vious run ids fo
13d0: 75 6e 64 3a 20 22 20 70 72 65 76 2d 72 75 6e 2d und: " prev-run-
13e0: 69 64 73 29 0a 09 20 20 28 69 66 20 28 6e 75 6c ids).. (if (nul
13f0: 6c 3f 20 70 72 65 76 2d 72 75 6e 2d 69 64 73 29 l? prev-run-ids)
1400: 20 23 66 0a 09 20 20 20 20 20 20 28 6c 65 74 20 #f.. (let
1410: 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 61 72 20 loop ((hed (car
1420: 70 72 65 76 2d 72 75 6e 2d 69 64 73 29 29 0a 09 prev-run-ids))..
1430: 09 09 20 28 74 61 6c 20 28 63 64 72 20 70 72 65 .. (tal (cdr pre
1440: 76 2d 72 75 6e 2d 69 64 73 29 29 29 0a 09 09 28 v-run-ids)))...(
1450: 6c 65 74 20 28 28 72 65 73 75 6c 74 73 20 28 64 let ((results (d
1460: 62 2d 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d b-get-tests-for-
1470: 72 75 6e 20 64 62 20 68 65 64 20 74 65 73 74 2d run db hed test-
1480: 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 27 name item-path '
1490: 28 29 20 27 28 29 29 29 29 0a 09 09 20 20 28 64 () '())))... (d
14a0: 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 47 6f ebug:print 4 "Go
14b0: 74 20 74 65 73 74 73 20 66 6f 72 20 72 75 6e 2d t tests for run-
14c0: 69 64 20 22 20 72 75 6e 2d 69 64 20 22 2c 20 74 id " run-id ", t
14d0: 65 73 74 2d 6e 61 6d 65 20 22 20 74 65 73 74 2d est-name " test-
14e0: 6e 61 6d 65 20 22 2c 20 69 74 65 6d 2d 70 61 74 name ", item-pat
14f0: 68 20 22 20 69 74 65 6d 2d 70 61 74 68 20 22 3a h " item-path ":
1500: 20 22 20 72 65 73 75 6c 74 73 29 0a 09 09 20 20 " results)...
1510: 28 69 66 20 28 61 6e 64 20 28 6e 75 6c 6c 3f 20 (if (and (null?
1520: 72 65 73 75 6c 74 73 29 0a 09 09 09 20 20 20 28 results).... (
1530: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 not (null? tal))
1540: 29 0a 09 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 )... (loop
1550: 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 (car tal)(cdr ta
1560: 6c 29 29 0a 09 09 20 20 20 20 20 20 28 69 66 20 l))... (if
1570: 28 6e 75 6c 6c 3f 20 72 65 73 75 6c 74 73 29 20 (null? results)
1580: 23 66 0a 09 09 09 20 20 28 63 61 72 20 72 65 73 #f.... (car res
1590: 75 6c 74 73 29 29 29 29 29 29 29 29 29 29 0a 20 ults)))))))))).
15a0: 20 20 20 0a 3b 3b 20 67 65 74 20 74 68 65 20 70 .;; get the p
15b0: 72 65 76 69 6f 75 73 20 72 65 63 6f 72 64 73 20 revious records
15c0: 66 6f 72 20 77 68 65 6e 20 74 68 65 73 65 20 74 for when these t
15d0: 65 73 74 73 20 77 65 72 65 20 72 75 6e 20 77 68 ests were run wh
15e0: 65 72 65 20 61 6c 6c 20 6b 65 79 73 20 6d 61 74 ere all keys mat
15f0: 63 68 20 62 75 74 20 72 75 6e 6e 61 6d 65 0a 3b ch but runname.;
1600: 3b 20 4e 42 2f 2f 20 4d 65 72 67 65 20 74 68 69 ; NB// Merge thi
1610: 73 20 77 69 74 68 20 74 65 73 74 3a 67 65 74 2d s with test:get-
1620: 70 72 65 76 69 6f 75 73 2d 74 65 73 74 2d 72 75 previous-test-ru
1630: 6e 2d 72 65 63 6f 72 64 73 3f 20 54 68 69 73 20 n-records? This
1640: 6f 6e 65 20 6c 6f 6f 6b 73 20 66 6f 72 20 61 6c one looks for al
1650: 6c 20 6d 61 74 63 68 69 6e 67 20 74 65 73 74 73 l matching tests
1660: 0a 3b 3b 20 63 61 6e 20 75 73 65 20 77 69 6c 64 .;; can use wild
1670: 63 61 72 64 73 2e 20 0a 28 64 65 66 69 6e 65 20 cards. .(define
1680: 28 74 65 73 74 3a 67 65 74 2d 6d 61 74 63 68 69 (test:get-matchi
1690: 6e 67 2d 70 72 65 76 69 6f 75 73 2d 74 65 73 74 ng-previous-test
16a0: 2d 72 75 6e 2d 72 65 63 6f 72 64 73 20 64 62 20 -run-records db
16b0: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
16c0: 20 69 74 65 6d 2d 70 61 74 68 29 0a 20 20 28 6c item-path). (l
16d0: 65 74 2a 20 28 28 6b 65 79 73 20 20 20 20 28 64 et* ((keys (d
16e0: 62 3a 67 65 74 2d 6b 65 79 73 20 64 62 29 29 0a b:get-keys db)).
16f0: 09 20 28 73 65 6c 73 74 72 20 20 28 73 74 72 69 . (selstr (stri
1700: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 ng-intersperse (
1710: 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 78 29 28 map (lambda (x)(
1720: 76 65 63 74 6f 72 2d 72 65 66 20 78 20 30 29 29 vector-ref x 0))
1730: 20 6b 65 79 73 29 20 22 2c 22 29 29 0a 09 20 28 keys) ",")).. (
1740: 71 72 79 73 74 72 20 20 28 73 74 72 69 6e 67 2d qrystr (string-
1750: 69 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 intersperse (map
1760: 20 28 6c 61 6d 62 64 61 20 28 78 29 28 63 6f 6e (lambda (x)(con
1770: 63 20 28 76 65 63 74 6f 72 2d 72 65 66 20 78 20 c (vector-ref x
1780: 30 29 20 22 3d 3f 22 29 29 20 6b 65 79 73 29 20 0) "=?")) keys)
1790: 22 20 41 4e 44 20 22 29 29 0a 09 20 28 6b 65 79 " AND ")).. (key
17a0: 76 61 6c 73 20 23 66 29 0a 09 20 28 74 65 73 74 vals #f).. (test
17b0: 73 2d 68 61 73 68 20 28 6d 61 6b 65 2d 68 61 73 s-hash (make-has
17c0: 68 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 20 3b h-table))). ;
17d0: 3b 20 66 69 72 73 74 20 6c 6f 6f 6b 20 75 70 20 ; first look up
17e0: 74 68 65 20 6b 65 79 20 76 61 6c 75 65 73 20 66 the key values f
17f0: 72 6f 6d 20 74 68 65 20 72 75 6e 20 73 65 6c 65 rom the run sele
1800: 63 74 65 64 20 62 79 20 72 75 6e 2d 69 64 0a 20 cted by run-id.
1810: 20 20 20 28 73 71 6c 69 74 65 33 3a 66 6f 72 2d (sqlite3:for-
1820: 65 61 63 68 2d 72 6f 77 20 0a 20 20 20 20 20 28 each-row . (
1830: 6c 61 6d 62 64 61 20 28 61 20 2e 20 62 29 0a 20 lambda (a . b).
1840: 20 20 20 20 20 20 28 73 65 74 21 20 6b 65 79 76 (set! keyv
1850: 61 6c 73 20 28 63 6f 6e 73 20 61 20 62 29 29 29 als (cons a b)))
1860: 0a 20 20 20 20 20 64 62 0a 20 20 20 20 20 28 63 . db. (c
1870: 6f 6e 63 20 22 53 45 4c 45 43 54 20 22 20 73 65 onc "SELECT " se
1880: 6c 73 74 72 20 22 20 46 52 4f 4d 20 72 75 6e 73 lstr " FROM runs
1890: 20 57 48 45 52 45 20 69 64 3d 3f 20 4f 52 44 45 WHERE id=? ORDE
18a0: 52 20 42 59 20 65 76 65 6e 74 5f 74 69 6d 65 20 R BY event_time
18b0: 44 45 53 43 3b 22 29 20 72 75 6e 2d 69 64 29 0a DESC;") run-id).
18c0: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 6b 65 79 (if (not key
18d0: 76 61 6c 73 29 0a 09 27 28 29 0a 09 28 6c 65 74 vals)..'()..(let
18e0: 20 28 28 70 72 65 76 2d 72 75 6e 2d 69 64 73 20 ((prev-run-ids
18f0: 27 28 29 29 29 0a 09 20 20 28 61 70 70 6c 79 20 '())).. (apply
1900: 73 71 6c 69 74 65 33 3a 66 6f 72 2d 65 61 63 68 sqlite3:for-each
1910: 2d 72 6f 77 0a 09 09 20 28 6c 61 6d 62 64 61 20 -row... (lambda
1920: 28 69 64 29 0a 09 09 20 20 20 28 73 65 74 21 20 (id)... (set!
1930: 70 72 65 76 2d 72 75 6e 2d 69 64 73 20 28 63 6f prev-run-ids (co
1940: 6e 73 20 69 64 20 70 72 65 76 2d 72 75 6e 2d 69 ns id prev-run-i
1950: 64 73 29 29 29 0a 09 09 20 64 62 0a 09 09 20 28 ds)))... db... (
1960: 63 6f 6e 63 20 22 53 45 4c 45 43 54 20 69 64 20 conc "SELECT id
1970: 46 52 4f 4d 20 72 75 6e 73 20 57 48 45 52 45 20 FROM runs WHERE
1980: 22 20 71 72 79 73 74 72 20 22 20 41 4e 44 20 69 " qrystr " AND i
1990: 64 20 21 3d 20 3f 3b 22 29 20 28 61 70 70 65 6e d != ?;") (appen
19a0: 64 20 6b 65 79 76 61 6c 73 20 28 6c 69 73 74 20 d keyvals (list
19b0: 72 75 6e 2d 69 64 29 29 29 0a 09 20 20 3b 3b 20 run-id))).. ;;
19c0: 63 6f 6c 6c 65 63 74 20 61 6c 6c 20 6d 61 74 63 collect all matc
19d0: 68 69 6e 67 20 74 65 73 74 73 20 66 6f 72 20 74 hing tests for t
19e0: 68 65 20 72 75 6e 73 20 74 68 65 6e 0a 09 20 20 he runs then..
19f0: 3b 3b 20 65 78 74 72 61 63 74 20 74 68 65 20 6d ;; extract the m
1a00: 6f 73 74 20 72 65 63 65 6e 74 20 74 65 73 74 20 ost recent test
1a10: 61 6e 64 20 72 65 74 75 72 6e 20 74 68 61 74 2e and return that.
1a20: 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
1a30: 20 34 20 22 73 65 6c 73 74 72 3a 20 22 20 73 65 4 "selstr: " se
1a40: 6c 73 74 72 20 22 2c 20 71 72 79 73 74 72 3a 20 lstr ", qrystr:
1a50: 22 20 71 72 79 73 74 72 20 22 2c 20 6b 65 79 76 " qrystr ", keyv
1a60: 61 6c 73 3a 20 22 20 6b 65 79 76 61 6c 73 20 0a als: " keyvals .
1a70: 09 09 20 20 20 20 20 20 20 22 2c 20 70 72 65 76 .. ", prev
1a80: 69 6f 75 73 20 72 75 6e 20 69 64 73 20 66 6f 75 ious run ids fou
1a90: 6e 64 3a 20 22 20 70 72 65 76 2d 72 75 6e 2d 69 nd: " prev-run-i
1aa0: 64 73 29 0a 09 20 20 28 69 66 20 28 6e 75 6c 6c ds).. (if (null
1ab0: 3f 20 70 72 65 76 2d 72 75 6e 2d 69 64 73 29 20 ? prev-run-ids)
1ac0: 27 28 29 20 20 3b 3b 20 6e 6f 20 70 72 65 76 69 '() ;; no previ
1ad0: 6f 75 73 20 72 75 6e 73 3f 20 72 65 74 75 72 6e ous runs? return
1ae0: 20 6e 75 6c 6c 0a 09 20 20 20 20 20 20 28 6c 65 null.. (le
1af0: 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 61 t loop ((hed (ca
1b00: 72 20 70 72 65 76 2d 72 75 6e 2d 69 64 73 29 29 r prev-run-ids))
1b10: 0a 09 09 09 20 28 74 61 6c 20 28 63 64 72 20 70 .... (tal (cdr p
1b20: 72 65 76 2d 72 75 6e 2d 69 64 73 29 29 29 0a 09 rev-run-ids)))..
1b30: 09 28 6c 65 74 20 28 28 72 65 73 75 6c 74 73 20 .(let ((results
1b40: 28 64 62 2d 67 65 74 2d 74 65 73 74 73 2d 66 6f (db-get-tests-fo
1b50: 72 2d 72 75 6e 20 64 62 20 68 65 64 20 74 65 73 r-run db hed tes
1b60: 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 t-name item-path
1b70: 20 27 28 29 20 27 28 29 29 29 29 0a 09 09 20 20 '() '())))...
1b80: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 (debug:print 4 "
1b90: 47 6f 74 20 74 65 73 74 73 20 66 6f 72 20 72 75 Got tests for ru
1ba0: 6e 2d 69 64 20 22 20 72 75 6e 2d 69 64 20 22 2c n-id " run-id ",
1bb0: 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 74 65 73 test-name " tes
1bc0: 74 2d 6e 61 6d 65 20 0a 09 09 09 20 20 20 20 20 t-name ....
1bd0: 20 20 22 2c 20 69 74 65 6d 2d 70 61 74 68 20 22 ", item-path "
1be0: 20 69 74 65 6d 2d 70 61 74 68 20 22 20 72 65 73 item-path " res
1bf0: 75 6c 74 73 3a 20 22 20 28 69 6e 74 65 72 73 70 ults: " (intersp
1c00: 65 72 73 65 20 72 65 73 75 6c 74 73 20 22 5c 6e erse results "\n
1c10: 22 29 29 0a 09 09 20 20 3b 3b 20 4b 65 65 70 20 "))... ;; Keep
1c20: 6f 6e 6c 79 20 74 68 65 20 79 6f 75 6e 67 65 73 only the younges
1c30: 74 20 6f 66 20 61 6e 79 20 74 65 73 74 2f 69 74 t of any test/it
1c40: 65 6d 20 63 6f 6d 62 69 6e 61 74 69 6f 6e 0a 09 em combination..
1c50: 09 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 09 09 . (for-each ...
1c60: 20 20 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 (lambda (test
1c70: 64 61 74 29 0a 09 09 20 20 20 20 20 28 6c 65 74 dat)... (let
1c80: 2a 20 28 28 66 75 6c 6c 2d 74 65 73 74 6e 61 6d * ((full-testnam
1c90: 65 20 28 63 6f 6e 63 20 28 64 62 3a 74 65 73 74 e (conc (db:test
1ca0: 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 -get-testname te
1cb0: 73 74 64 61 74 29 20 22 2f 22 20 28 64 62 3a 74 stdat) "/" (db:t
1cc0: 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 est-get-item-pat
1cd0: 68 20 74 65 73 74 64 61 74 29 29 29 0a 09 09 09 h testdat)))....
1ce0: 20 20 20 20 28 73 74 6f 72 65 64 2d 74 65 73 74 (stored-test
1cf0: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 (hash-table-r
1d00: 65 66 2f 64 65 66 61 75 6c 74 20 74 65 73 74 73 ef/default tests
1d10: 2d 68 61 73 68 20 66 75 6c 6c 2d 74 65 73 74 6e -hash full-testn
1d20: 61 6d 65 20 23 66 29 29 29 0a 09 09 20 20 20 20 ame #f)))...
1d30: 20 20 20 28 69 66 20 28 6f 72 20 28 6e 6f 74 20 (if (or (not
1d40: 73 74 6f 72 65 64 2d 74 65 73 74 29 0a 09 09 09 stored-test)....
1d50: 20 20 20 20 20 20 20 28 61 6e 64 20 73 74 6f 72 (and stor
1d60: 65 64 2d 74 65 73 74 0a 09 09 09 09 20 20 20 20 ed-test.....
1d70: 28 3e 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d (> (db:test-get-
1d80: 65 76 65 6e 74 5f 74 69 6d 65 20 74 65 73 74 64 event_time testd
1d90: 61 74 29 28 64 62 3a 74 65 73 74 2d 67 65 74 2d at)(db:test-get-
1da0: 65 76 65 6e 74 5f 74 69 6d 65 20 73 74 6f 72 65 event_time store
1db0: 64 2d 74 65 73 74 29 29 29 29 0a 09 09 09 20 20 d-test))))....
1dc0: 20 3b 3b 20 74 68 69 73 20 74 65 73 74 20 69 73 ;; this test is
1dd0: 20 79 6f 75 6e 67 65 72 2c 20 73 74 6f 72 65 20 younger, store
1de0: 69 74 20 69 6e 20 74 68 65 20 68 61 73 68 0a 09 it in the hash..
1df0: 09 09 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 .. (hash-table
1e00: 2d 73 65 74 21 20 74 65 73 74 73 2d 68 61 73 68 -set! tests-hash
1e10: 20 66 75 6c 6c 2d 74 65 73 74 6e 61 6d 65 20 74 full-testname t
1e20: 65 73 74 64 61 74 29 29 29 29 0a 09 09 20 20 20 estdat))))...
1e30: 72 65 73 75 6c 74 73 29 0a 09 09 20 20 28 69 66 results)... (if
1e40: 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 20 (null? tal)...
1e50: 20 20 20 20 20 28 6d 61 70 20 63 64 72 20 28 68 (map cdr (h
1e60: 61 73 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 ash-table->alist
1e70: 20 74 65 73 74 73 2d 68 61 73 68 29 29 20 3b 3b tests-hash)) ;;
1e80: 20 72 65 74 75 72 6e 20 61 20 6c 69 73 74 20 6f return a list o
1e90: 66 20 74 68 65 20 6d 6f 73 74 20 72 65 63 65 6e f the most recen
1ea0: 74 20 74 65 73 74 73 0a 09 09 20 20 20 20 20 20 t tests...
1eb0: 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 (loop (car tal)(
1ec0: 63 64 72 20 74 61 6c 29 29 29 29 29 29 29 29 29 cdr tal)))))))))
1ed0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 )..(define (test
1ee0: 2d 73 65 74 2d 73 74 61 74 75 73 21 20 64 62 20 -set-status! db
1ef0: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
1f00: 20 73 74 61 74 65 20 73 74 61 74 75 73 20 69 74 state status it
1f10: 65 6d 64 61 74 2d 6f 72 2d 70 61 74 68 20 63 6f emdat-or-path co
1f20: 6d 6d 65 6e 74 20 64 61 74 29 0a 20 20 28 6c 65 mment dat). (le
1f30: 74 2a 20 28 28 72 65 61 6c 2d 73 74 61 74 75 73 t* ((real-status
1f40: 20 73 74 61 74 75 73 29 0a 09 20 28 69 74 65 6d status).. (item
1f50: 2d 70 61 74 68 20 20 20 28 69 66 20 28 73 74 72 -path (if (str
1f60: 69 6e 67 3f 20 69 74 65 6d 64 61 74 2d 6f 72 2d ing? itemdat-or-
1f70: 70 61 74 68 29 20 69 74 65 6d 64 61 74 2d 6f 72 path) itemdat-or
1f80: 2d 70 61 74 68 20 28 69 74 65 6d 2d 6c 69 73 74 -path (item-list
1f90: 2d 3e 70 61 74 68 20 69 74 65 6d 64 61 74 2d 6f ->path itemdat-o
1fa0: 72 2d 70 61 74 68 29 29 29 0a 09 20 28 74 65 73 r-path))).. (tes
1fb0: 74 64 61 74 20 20 20 20 20 28 64 62 3a 67 65 74 tdat (db:get
1fc0: 2d 74 65 73 74 2d 69 6e 66 6f 20 64 62 20 72 75 -test-info db ru
1fd0: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 n-id test-name i
1fe0: 74 65 6d 2d 70 61 74 68 29 29 0a 09 20 28 74 65 tem-path)).. (te
1ff0: 73 74 2d 69 64 20 20 20 20 20 28 69 66 20 74 65 st-id (if te
2000: 73 74 64 61 74 20 28 64 62 3a 74 65 73 74 2d 67 stdat (db:test-g
2010: 65 74 2d 69 64 20 74 65 73 74 64 61 74 29 20 23 et-id testdat) #
2020: 66 29 29 0a 09 20 28 6f 74 68 65 72 64 61 74 20 f)).. (otherdat
2030: 20 20 20 28 69 66 20 64 61 74 20 64 61 74 20 28 (if dat dat (
2040: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
2050: 29 29 0a 09 20 3b 3b 20 62 65 66 6f 72 65 20 70 )).. ;; before p
2060: 72 6f 63 65 65 64 69 6e 67 20 77 65 20 6d 75 73 roceeding we mus
2070: 74 20 66 69 6e 64 20 6f 75 74 20 69 66 20 74 68 t find out if th
2080: 65 20 70 72 65 76 69 6f 75 73 20 74 65 73 74 20 e previous test
2090: 28 77 68 65 72 65 20 61 6c 6c 20 6b 65 79 73 20 (where all keys
20a0: 6d 61 74 63 68 65 64 20 65 78 63 65 70 74 20 72 matched except r
20b0: 75 6e 6e 61 6d 65 29 0a 09 20 3b 3b 20 77 61 73 unname).. ;; was
20c0: 20 57 41 49 56 45 44 20 69 66 20 74 68 69 73 20 WAIVED if this
20d0: 74 65 73 74 20 69 73 20 46 41 49 4c 0a 09 20 28 test is FAIL.. (
20e0: 77 61 69 76 65 64 20 20 20 28 69 66 20 28 65 71 waived (if (eq
20f0: 75 61 6c 3f 20 73 74 61 74 75 73 20 22 46 41 49 ual? status "FAI
2100: 4c 22 29 0a 09 09 20 20 20 20 20 20 20 28 6c 65 L")... (le
2110: 74 20 28 28 70 72 65 76 2d 74 65 73 74 20 28 74 t ((prev-test (t
2120: 65 73 74 3a 67 65 74 2d 70 72 65 76 69 6f 75 73 est:get-previous
2130: 2d 74 65 73 74 2d 72 75 6e 2d 72 65 63 6f 72 64 -test-run-record
2140: 20 64 62 20 72 75 6e 2d 69 64 20 74 65 73 74 2d db run-id test-
2150: 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 name item-path))
2160: 29 0a 09 09 09 20 28 69 66 20 70 72 65 76 2d 74 ).... (if prev-t
2170: 65 73 74 20 3b 3b 20 74 72 75 65 20 69 66 20 77 est ;; true if w
2180: 65 20 66 6f 75 6e 64 20 61 20 70 72 65 76 69 6f e found a previo
2190: 75 73 20 74 65 73 74 20 69 6e 20 74 68 69 73 20 us test in this
21a0: 72 75 6e 20 73 65 72 69 65 73 0a 09 09 09 20 20 run series....
21b0: 20 20 20 28 6c 65 74 20 28 28 70 72 65 76 2d 73 (let ((prev-s
21c0: 74 61 74 75 73 20 28 64 62 3a 74 65 73 74 2d 67 tatus (db:test-g
21d0: 65 74 2d 73 74 61 74 75 73 20 20 20 70 72 65 76 et-status prev
21e0: 2d 74 65 73 74 29 29 0a 09 09 09 09 20 20 20 28 -test))..... (
21f0: 70 72 65 76 2d 73 74 61 74 65 20 20 28 64 62 3a prev-state (db:
2200: 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 20 test-get-state
2210: 20 20 70 72 65 76 2d 74 65 73 74 29 29 0a 09 09 prev-test))...
2220: 09 09 20 20 20 28 70 72 65 76 2d 63 6f 6d 6d 65 .. (prev-comme
2230: 6e 74 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d nt (db:test-get-
2240: 63 6f 6d 6d 65 6e 74 20 70 72 65 76 2d 74 65 73 comment prev-tes
2250: 74 29 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 t))).... (
2260: 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 70 debug:print 4 "p
2270: 72 65 76 2d 73 74 61 74 75 73 20 22 20 70 72 65 rev-status " pre
2280: 76 2d 73 74 61 74 75 73 20 22 2c 20 70 72 65 76 v-status ", prev
2290: 2d 73 74 61 74 65 20 22 20 70 72 65 76 2d 73 74 -state " prev-st
22a0: 61 74 65 20 22 2c 20 70 72 65 76 2d 63 6f 6d 6d ate ", prev-comm
22b0: 65 6e 74 20 22 20 70 72 65 76 2d 63 6f 6d 6d 65 ent " prev-comme
22c0: 6e 74 29 0a 09 09 09 20 20 20 20 20 20 20 28 69 nt).... (i
22d0: 66 20 28 61 6e 64 20 28 65 71 75 61 6c 3f 20 70 f (and (equal? p
22e0: 72 65 76 2d 73 74 61 74 65 20 20 22 43 4f 4d 50 rev-state "COMP
22f0: 4c 45 54 45 44 22 29 0a 09 09 09 09 09 28 65 71 LETED")......(eq
2300: 75 61 6c 3f 20 70 72 65 76 2d 73 74 61 74 75 73 ual? prev-status
2310: 20 22 57 41 49 56 45 44 22 29 29 0a 09 09 09 09 "WAIVED")).....
2320: 20 20 20 70 72 65 76 2d 63 6f 6d 6d 65 6e 74 20 prev-comment
2330: 3b 3b 20 77 61 69 76 65 64 20 69 73 20 65 69 74 ;; waived is eit
2340: 68 65 72 20 74 68 65 20 63 6f 6d 6d 65 6e 74 20 her the comment
2350: 6f 72 20 23 66 0a 09 09 09 09 20 20 20 23 66 29 or #f..... #f)
2360: 29 0a 09 09 09 20 20 20 20 20 23 66 29 29 0a 09 ).... #f))..
2370: 09 20 20 20 20 20 20 20 23 66 29 29 29 0a 20 20 . #f))).
2380: 20 20 28 69 66 20 77 61 69 76 65 64 20 28 73 65 (if waived (se
2390: 74 21 20 72 65 61 6c 2d 73 74 61 74 75 73 20 22 t! real-status "
23a0: 57 41 49 56 45 44 22 29 29 0a 20 20 20 20 28 64 WAIVED")). (d
23b0: 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 72 65 ebug:print 4 "re
23c0: 61 6c 2d 73 74 61 74 75 73 20 22 20 72 65 61 6c al-status " real
23d0: 2d 73 74 61 74 75 73 20 22 2c 20 77 61 69 76 65 -status ", waive
23e0: 64 20 22 20 77 61 69 76 65 64 20 22 2c 20 73 74 d " waived ", st
23f0: 61 74 75 73 20 22 20 73 74 61 74 75 73 29 0a 0a atus " status)..
2400: 20 20 20 20 3b 3b 20 75 70 64 61 74 65 20 74 68 ;; update th
2410: 65 20 70 72 69 6d 61 72 79 20 72 65 63 6f 72 64 e primary record
2420: 20 49 46 20 73 74 61 74 65 20 41 4e 44 20 73 74 IF state AND st
2430: 61 74 75 73 20 61 72 65 20 64 65 66 69 6e 65 64 atus are defined
2440: 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 73 74 . (if (and st
2450: 61 74 65 20 73 74 61 74 75 73 29 0a 09 28 73 71 ate status)..(sq
2460: 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 64 62 lite3:execute db
2470: 20 22 55 50 44 41 54 45 20 74 65 73 74 73 20 53 "UPDATE tests S
2480: 45 54 20 73 74 61 74 65 3d 3f 2c 73 74 61 74 75 ET state=?,statu
2490: 73 3d 3f 2c 65 76 65 6e 74 5f 74 69 6d 65 3d 73 s=?,event_time=s
24a0: 74 72 66 74 69 6d 65 28 27 25 73 27 2c 27 6e 6f trftime('%s','no
24b0: 77 27 29 20 57 48 45 52 45 20 72 75 6e 5f 69 64 w') WHERE run_id
24c0: 3d 3f 20 41 4e 44 20 74 65 73 74 6e 61 6d 65 3d =? AND testname=
24d0: 3f 20 41 4e 44 20 69 74 65 6d 5f 70 61 74 68 3d ? AND item_path=
24e0: 3f 3b 22 20 0a 09 09 09 20 73 74 61 74 65 20 72 ?;" .... state r
24f0: 65 61 6c 2d 73 74 61 74 75 73 20 72 75 6e 2d 69 eal-status run-i
2500: 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d d test-name item
2510: 2d 70 61 74 68 29 29 0a 0a 20 20 20 20 3b 3b 20 -path)).. ;;
2520: 69 66 20 73 74 61 74 75 73 20 69 73 20 22 41 55 if status is "AU
2530: 54 4f 22 20 74 68 65 6e 20 63 61 6c 6c 20 72 6f TO" then call ro
2540: 6c 6c 75 70 0a 20 20 20 20 28 69 66 20 28 61 6e llup. (if (an
2550: 64 20 74 65 73 74 2d 69 64 20 73 74 61 74 65 20 d test-id state
2560: 73 74 61 74 75 73 20 28 6f 72 20 28 65 71 75 61 status (or (equa
2570: 6c 3f 20 73 74 61 74 75 73 20 22 41 55 54 4f 22 l? status "AUTO"
2580: 29 28 65 71 75 61 6c 3f 20 73 74 61 74 75 73 20 )(equal? status
2590: 22 41 55 54 4f 2d 57 41 52 4e 22 29 29 29 20 0a "AUTO-WARN"))) .
25a0: 09 28 64 62 3a 74 65 73 74 2d 64 61 74 61 2d 72 .(db:test-data-r
25b0: 6f 6c 6c 75 70 20 64 62 20 74 65 73 74 2d 69 64 ollup db test-id
25c0: 20 73 74 61 74 75 73 29 29 0a 0a 20 20 20 20 3b status)).. ;
25d0: 3b 20 61 64 64 20 6d 65 74 61 64 61 74 61 20 28 ; add metadata (
25e0: 6e 65 65 64 20 74 6f 20 64 6f 20 74 68 69 73 20 need to do this
25f0: 77 61 79 20 74 6f 20 61 76 6f 69 64 20 53 51 4c way to avoid SQL
2600: 20 69 6e 6a 65 63 74 69 6f 6e 20 69 73 73 75 65 injection issue
2610: 73 29 0a 0a 20 20 20 20 3b 3b 20 3a 66 69 72 73 s).. ;; :firs
2620: 74 5f 65 72 72 0a 20 20 20 20 3b 3b 20 28 6c 65 t_err. ;; (le
2630: 74 20 28 28 76 61 6c 20 28 68 61 73 68 2d 74 61 t ((val (hash-ta
2640: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
2650: 6f 74 68 65 72 64 61 74 20 22 3a 66 69 72 73 74 otherdat ":first
2660: 5f 65 72 72 22 20 23 66 29 29 29 0a 20 20 20 20 _err" #f))).
2670: 3b 3b 20 20 20 28 69 66 20 76 61 6c 0a 20 20 20 ;; (if val.
2680: 20 3b 3b 20 20 20 20 20 20 20 28 73 71 6c 69 74 ;; (sqlit
2690: 65 33 3a 65 78 65 63 75 74 65 20 64 62 20 22 55 e3:execute db "U
26a0: 50 44 41 54 45 20 74 65 73 74 73 20 53 45 54 20 PDATE tests SET
26b0: 66 69 72 73 74 5f 65 72 72 3d 3f 20 57 48 45 52 first_err=? WHER
26c0: 45 20 72 75 6e 5f 69 64 3d 3f 20 41 4e 44 20 74 E run_id=? AND t
26d0: 65 73 74 6e 61 6d 65 3d 3f 20 41 4e 44 20 69 74 estname=? AND it
26e0: 65 6d 5f 70 61 74 68 3d 3f 3b 22 20 76 61 6c 20 em_path=?;" val
26f0: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
2700: 20 69 74 65 6d 2d 70 61 74 68 29 29 29 0a 20 20 item-path))).
2710: 20 20 3b 3b 20 0a 20 20 20 20 3b 3b 20 3b 3b 20 ;; . ;; ;;
2720: 3a 66 69 72 73 74 5f 77 61 72 6e 0a 20 20 20 20 :first_warn.
2730: 3b 3b 20 28 6c 65 74 20 28 28 76 61 6c 20 28 68 ;; (let ((val (h
2740: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
2750: 66 61 75 6c 74 20 6f 74 68 65 72 64 61 74 20 22 fault otherdat "
2760: 3a 66 69 72 73 74 5f 77 61 72 6e 22 20 23 66 29 :first_warn" #f)
2770: 29 29 0a 20 20 20 20 3b 3b 20 20 20 28 69 66 20 )). ;; (if
2780: 76 61 6c 0a 20 20 20 20 3b 3b 20 20 20 20 20 20 val. ;;
2790: 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 (sqlite3:execut
27a0: 65 20 64 62 20 22 55 50 44 41 54 45 20 74 65 73 e db "UPDATE tes
27b0: 74 73 20 53 45 54 20 66 69 72 73 74 5f 77 61 72 ts SET first_war
27c0: 6e 3d 3f 20 57 48 45 52 45 20 72 75 6e 5f 69 64 n=? WHERE run_id
27d0: 3d 3f 20 41 4e 44 20 74 65 73 74 6e 61 6d 65 3d =? AND testname=
27e0: 3f 20 41 4e 44 20 69 74 65 6d 5f 70 61 74 68 3d ? AND item_path=
27f0: 3f 3b 22 20 76 61 6c 20 72 75 6e 2d 69 64 20 74 ?;" val run-id t
2800: 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 est-name item-pa
2810: 74 68 29 29 29 0a 0a 20 20 20 20 28 6c 65 74 20 th))).. (let
2820: 28 28 63 61 74 65 67 6f 72 79 20 28 68 61 73 68 ((category (hash
2830: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
2840: 6c 74 20 6f 74 68 65 72 64 61 74 20 22 3a 63 61 lt otherdat ":ca
2850: 74 65 67 6f 72 79 22 20 22 22 29 29 0a 09 20 20 tegory" ""))..
2860: 28 76 61 72 69 61 62 6c 65 20 28 68 61 73 68 2d (variable (hash-
2870: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
2880: 74 20 6f 74 68 65 72 64 61 74 20 22 3a 76 61 72 t otherdat ":var
2890: 69 61 62 6c 65 22 20 22 22 29 29 0a 09 20 20 28 iable" "")).. (
28a0: 76 61 6c 75 65 20 20 20 20 28 68 61 73 68 2d 74 value (hash-t
28b0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
28c0: 20 6f 74 68 65 72 64 61 74 20 22 3a 76 61 6c 75 otherdat ":valu
28d0: 65 22 20 20 20 20 23 66 29 29 0a 09 20 20 28 65 e" #f)).. (e
28e0: 78 70 65 63 74 65 64 20 28 68 61 73 68 2d 74 61 xpected (hash-ta
28f0: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
2900: 6f 74 68 65 72 64 61 74 20 22 3a 65 78 70 65 63 otherdat ":expec
2910: 74 65 64 22 20 23 66 29 29 0a 09 20 20 28 74 6f ted" #f)).. (to
2920: 6c 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 l (hash-tab
2930: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 6f le-ref/default o
2940: 74 68 65 72 64 61 74 20 22 3a 74 6f 6c 22 20 20 therdat ":tol"
2950: 20 20 20 20 23 66 29 29 0a 09 20 20 28 75 6e 69 #f)).. (uni
2960: 74 73 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c ts (hash-tabl
2970: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 6f 74 e-ref/default ot
2980: 68 65 72 64 61 74 20 22 3a 75 6e 69 74 73 22 20 herdat ":units"
2990: 20 20 20 22 22 29 29 0a 09 20 20 28 64 63 6f 6d "")).. (dcom
29a0: 6d 65 6e 74 20 28 68 61 73 68 2d 74 61 62 6c 65 ment (hash-table
29b0: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 6f 74 68 -ref/default oth
29c0: 65 72 64 61 74 20 22 3a 63 6f 6d 6d 65 6e 74 22 erdat ":comment"
29d0: 20 20 22 22 29 29 29 0a 20 20 20 20 20 20 28 64 ""))). (d
29e0: 65 62 75 67 3a 70 72 69 6e 74 20 34 20 0a 09 09 ebug:print 4 ...
29f0: 20 20 20 22 63 61 74 65 67 6f 72 79 3a 20 22 20 "category: "
2a00: 63 61 74 65 67 6f 72 79 20 22 2c 20 76 61 72 69 category ", vari
2a10: 61 62 6c 65 3a 20 22 20 76 61 72 69 61 62 6c 65 able: " variable
2a20: 20 22 2c 20 76 61 6c 75 65 3a 20 22 20 76 61 6c ", value: " val
2a30: 75 65 0a 09 09 20 20 20 22 2c 20 65 78 70 65 63 ue... ", expec
2a40: 74 65 64 3a 20 22 20 65 78 70 65 63 74 65 64 20 ted: " expected
2a50: 22 2c 20 74 6f 6c 3a 20 22 20 74 6f 6c 20 22 2c ", tol: " tol ",
2a60: 20 75 6e 69 74 73 3a 20 22 20 75 6e 69 74 73 29 units: " units)
2a70: 0a 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 . (if (and
2a80: 76 61 6c 75 65 20 65 78 70 65 63 74 65 64 20 74 value expected t
2a90: 6f 6c 29 20 3b 3b 20 61 6c 6c 20 74 68 72 65 65 ol) ;; all three
2aa0: 20 72 65 71 75 69 72 65 64 0a 09 20 20 28 64 62 required.. (db
2ab0: 3a 63 73 76 2d 3e 74 65 73 74 2d 64 61 74 61 20 :csv->test-data
2ac0: 64 62 20 74 65 73 74 2d 69 64 20 0a 09 09 09 20 db test-id ....
2ad0: 20 20 20 20 28 63 6f 6e 63 20 63 61 74 65 67 6f (conc catego
2ae0: 72 79 20 22 2c 22 0a 09 09 09 09 20 20 20 76 61 ry ","..... va
2af0: 72 69 61 62 6c 65 20 22 2c 22 0a 09 09 09 09 20 riable ",".....
2b00: 20 20 76 61 6c 75 65 20 20 20 20 22 2c 22 0a 09 value ","..
2b10: 09 09 09 20 20 20 65 78 70 65 63 74 65 64 20 22 ... expected "
2b20: 2c 22 0a 09 09 09 09 20 20 20 74 6f 6c 20 20 20 ,"..... tol
2b30: 20 20 20 22 2c 22 0a 09 09 09 09 20 20 20 75 6e ","..... un
2b40: 69 74 73 20 20 20 20 22 2c 22 0a 09 09 09 09 20 its ",".....
2b50: 20 20 64 63 6f 6d 6d 65 6e 74 20 22 2c 22 29 29 dcomment ","))
2b60: 29 29 0a 09 09 09 09 20 20 20 0a 20 20 20 20 3b ))..... . ;
2b70: 3b 20 6e 65 65 64 20 74 6f 20 75 70 64 61 74 65 ; need to update
2b80: 20 74 68 65 20 74 6f 70 20 74 65 73 74 20 72 65 the top test re
2b90: 63 6f 72 64 20 69 66 20 50 41 53 53 20 6f 72 20 cord if PASS or
2ba0: 46 41 49 4c 20 61 6e 64 20 74 68 69 73 20 69 73 FAIL and this is
2bb0: 20 61 20 73 75 62 74 65 73 74 0a 20 20 20 20 28 a subtest. (
2bc0: 69 66 20 28 61 6e 64 20 28 6e 6f 74 20 28 65 71 if (and (not (eq
2bd0: 75 61 6c 3f 20 69 74 65 6d 2d 70 61 74 68 20 22 ual? item-path "
2be0: 22 29 29 0a 09 20 20 20 20 20 28 6f 72 20 28 65 ")).. (or (e
2bf0: 71 75 61 6c 3f 20 73 74 61 74 75 73 20 22 50 41 qual? status "PA
2c00: 53 53 22 29 0a 09 09 20 28 65 71 75 61 6c 3f 20 SS")... (equal?
2c10: 73 74 61 74 75 73 20 22 57 41 52 4e 22 29 0a 09 status "WARN")..
2c20: 09 20 28 65 71 75 61 6c 3f 20 73 74 61 74 75 73 . (equal? status
2c30: 20 22 46 41 49 4c 22 29 0a 09 09 20 28 65 71 75 "FAIL")... (equ
2c40: 61 6c 3f 20 73 74 61 74 75 73 20 22 57 41 49 56 al? status "WAIV
2c50: 45 44 22 29 0a 09 09 20 28 65 71 75 61 6c 3f 20 ED")... (equal?
2c60: 73 74 61 74 75 73 20 22 52 55 4e 4e 49 4e 47 22 status "RUNNING"
2c70: 29 29 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 )))..(begin.. (
2c80: 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 sqlite3:execute
2c90: 0a 09 20 20 20 64 62 0a 09 20 20 20 22 55 50 44 .. db.. "UPD
2ca0: 41 54 45 20 74 65 73 74 73 20 0a 20 20 20 20 20 ATE tests .
2cb0: 20 20 20 20 20 20 20 20 53 45 54 20 66 61 69 6c SET fail
2cc0: 5f 63 6f 75 6e 74 3d 28 53 45 4c 45 43 54 20 63 _count=(SELECT c
2cd0: 6f 75 6e 74 28 69 64 29 20 46 52 4f 4d 20 74 65 ount(id) FROM te
2ce0: 73 74 73 20 57 48 45 52 45 20 72 75 6e 5f 69 64 sts WHERE run_id
2cf0: 3d 3f 20 41 4e 44 20 74 65 73 74 6e 61 6d 65 3d =? AND testname=
2d00: 3f 20 41 4e 44 20 69 74 65 6d 5f 70 61 74 68 20 ? AND item_path
2d10: 21 3d 20 27 27 20 41 4e 44 20 73 74 61 74 75 73 != '' AND status
2d20: 3d 27 46 41 49 4c 27 29 2c 0a 20 20 20 20 20 20 ='FAIL'),.
2d30: 20 20 20 20 20 20 20 20 20 20 20 70 61 73 73 5f pass_
2d40: 63 6f 75 6e 74 3d 28 53 45 4c 45 43 54 20 63 6f count=(SELECT co
2d50: 75 6e 74 28 69 64 29 20 46 52 4f 4d 20 74 65 73 unt(id) FROM tes
2d60: 74 73 20 57 48 45 52 45 20 72 75 6e 5f 69 64 3d ts WHERE run_id=
2d70: 3f 20 41 4e 44 20 74 65 73 74 6e 61 6d 65 3d 3f ? AND testname=?
2d80: 20 41 4e 44 20 69 74 65 6d 5f 70 61 74 68 20 21 AND item_path !
2d90: 3d 20 27 27 20 41 4e 44 20 28 73 74 61 74 75 73 = '' AND (status
2da0: 3d 27 50 41 53 53 27 20 4f 52 20 73 74 61 74 75 ='PASS' OR statu
2db0: 73 3d 27 57 41 52 4e 27 20 4f 52 20 73 74 61 74 s='WARN' OR stat
2dc0: 75 73 3d 27 57 41 49 56 45 44 27 29 29 0a 20 20 us='WAIVED')).
2dd0: 20 20 20 20 20 20 20 20 20 20 20 57 48 45 52 45 WHERE
2de0: 20 72 75 6e 5f 69 64 3d 3f 20 41 4e 44 20 74 65 run_id=? AND te
2df0: 73 74 6e 61 6d 65 3d 3f 20 41 4e 44 20 69 74 65 stname=? AND ite
2e00: 6d 5f 70 61 74 68 3d 27 27 3b 22 0a 09 20 20 20 m_path='';"..
2e10: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
2e20: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
2e30: 65 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 e run-id test-na
2e40: 6d 65 29 0a 09 20 20 28 69 66 20 28 65 71 75 61 me).. (if (equa
2e50: 6c 3f 20 73 74 61 74 75 73 20 22 52 55 4e 4e 49 l? status "RUNNI
2e60: 4e 47 22 29 20 3b 3b 20 72 75 6e 6e 69 6e 67 20 NG") ;; running
2e70: 74 61 6b 65 73 20 70 72 69 6f 72 69 74 79 20 6f takes priority o
2e80: 76 65 72 20 61 6c 6c 20 6f 74 68 65 72 20 73 74 ver all other st
2e90: 61 74 65 73 2c 20 66 6f 72 63 65 20 74 68 65 20 ates, force the
2ea0: 74 65 73 74 20 73 74 61 74 65 20 74 6f 20 52 55 test state to RU
2eb0: 4e 4e 49 4e 47 0a 09 20 20 20 20 20 20 28 73 71 NNING.. (sq
2ec0: 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 64 62 lite3:execute db
2ed0: 20 22 55 50 44 41 54 45 20 74 65 73 74 73 20 53 "UPDATE tests S
2ee0: 45 54 20 73 74 61 74 65 3d 3f 20 57 48 45 52 45 ET state=? WHERE
2ef0: 20 72 75 6e 5f 69 64 3d 3f 20 41 4e 44 20 74 65 run_id=? AND te
2f00: 73 74 6e 61 6d 65 3d 3f 20 41 4e 44 20 69 74 65 stname=? AND ite
2f10: 6d 5f 70 61 74 68 3d 27 27 3b 22 20 72 75 6e 2d m_path='';" run-
2f20: 69 64 20 74 65 73 74 2d 6e 61 6d 65 29 0a 09 20 id test-name)..
2f30: 20 20 20 20 20 28 73 71 6c 69 74 65 33 3a 65 78 (sqlite3:ex
2f40: 65 63 75 74 65 0a 09 20 20 20 20 20 20 20 64 62 ecute.. db
2f50: 0a 09 20 20 20 20 20 20 20 22 55 50 44 41 54 45 .. "UPDATE
2f60: 20 74 65 73 74 73 0a 20 20 20 20 20 20 20 20 20 tests.
2f70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 53 45 SE
2f80: 54 20 73 74 61 74 65 3d 43 41 53 45 20 57 48 45 T state=CASE WHE
2f90: 4e 20 28 53 45 4c 45 43 54 20 63 6f 75 6e 74 28 N (SELECT count(
2fa0: 69 64 29 20 46 52 4f 4d 20 74 65 73 74 73 20 57 id) FROM tests W
2fb0: 48 45 52 45 20 72 75 6e 5f 69 64 3d 3f 20 41 4e HERE run_id=? AN
2fc0: 44 20 74 65 73 74 6e 61 6d 65 3d 3f 20 41 4e 44 D testname=? AND
2fd0: 20 69 74 65 6d 5f 70 61 74 68 20 21 3d 20 27 27 item_path != ''
2fe0: 20 41 4e 44 20 73 74 61 74 65 20 69 6e 20 28 27 AND state in ('
2ff0: 52 55 4e 4e 49 4e 47 27 2c 27 4e 4f 54 5f 53 54 RUNNING','NOT_ST
3000: 41 52 54 45 44 27 29 29 20 3e 20 30 20 54 48 45 ARTED')) > 0 THE
3010: 4e 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 N .
3020: 20 20 20 20 20 20 20 20 20 20 20 20 20 27 52 55 'RU
3030: 4e 4e 49 4e 47 27 0a 20 20 20 20 20 20 20 20 20 NNING'.
3040: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 45 4c EL
3050: 53 45 20 27 43 4f 4d 50 4c 45 54 45 44 27 20 45 SE 'COMPLETED' E
3060: 4e 44 2c 0a 20 20 20 20 20 20 20 20 20 20 20 20 ND,.
3070: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 73 74 st
3080: 61 74 75 73 3d 43 41 53 45 20 57 48 45 4e 20 66 atus=CASE WHEN f
3090: 61 69 6c 5f 63 6f 75 6e 74 20 3e 20 30 20 54 48 ail_count > 0 TH
30a0: 45 4e 20 27 46 41 49 4c 27 20 57 48 45 4e 20 70 EN 'FAIL' WHEN p
30b0: 61 73 73 5f 63 6f 75 6e 74 20 3e 20 30 20 41 4e ass_count > 0 AN
30c0: 44 20 66 61 69 6c 5f 63 6f 75 6e 74 3d 30 20 54 D fail_count=0 T
30d0: 48 45 4e 20 27 50 41 53 53 27 20 45 4c 53 45 20 HEN 'PASS' ELSE
30e0: 27 55 4e 4b 4e 4f 57 4e 27 20 45 4e 44 0a 20 20 'UNKNOWN' END.
30f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3100: 20 20 20 20 20 57 48 45 52 45 20 72 75 6e 5f 69 WHERE run_i
3110: 64 3d 3f 20 41 4e 44 20 74 65 73 74 6e 61 6d 65 d=? AND testname
3120: 3d 3f 20 41 4e 44 20 69 74 65 6d 5f 70 61 74 68 =? AND item_path
3130: 3d 27 27 3b 22 0a 09 20 20 20 20 20 20 20 72 75 ='';".. ru
3140: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 72 n-id test-name r
3150: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 29 un-id test-name)
3160: 29 29 29 0a 20 20 20 20 28 69 66 20 28 6f 72 20 ))). (if (or
3170: 28 61 6e 64 20 28 73 74 72 69 6e 67 3f 20 63 6f (and (string? co
3180: 6d 6d 65 6e 74 29 0a 09 09 20 28 73 74 72 69 6e mment)... (strin
3190: 67 2d 6d 61 74 63 68 20 28 72 65 67 65 78 70 20 g-match (regexp
31a0: 22 5c 5c 53 2b 22 29 20 63 6f 6d 6d 65 6e 74 29 "\\S+") comment)
31b0: 29 0a 09 20 20 20 20 77 61 69 76 65 64 29 0a 09 ).. waived)..
31c0: 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 (sqlite3:execute
31d0: 20 64 62 20 22 55 50 44 41 54 45 20 74 65 73 74 db "UPDATE test
31e0: 73 20 53 45 54 20 63 6f 6d 6d 65 6e 74 3d 3f 20 s SET comment=?
31f0: 57 48 45 52 45 20 72 75 6e 5f 69 64 3d 3f 20 41 WHERE run_id=? A
3200: 4e 44 20 74 65 73 74 6e 61 6d 65 3d 3f 20 41 4e ND testname=? AN
3210: 44 20 69 74 65 6d 5f 70 61 74 68 3d 3f 3b 22 0a D item_path=?;".
3220: 09 09 09 20 28 69 66 20 77 61 69 76 65 64 20 77 ... (if waived w
3230: 61 69 76 65 64 20 63 6f 6d 6d 65 6e 74 29 20 72 aived comment) r
3240: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 un-id test-name
3250: 69 74 65 6d 2d 70 61 74 68 29 29 0a 20 20 20 20 item-path)).
3260: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 ))..(define (tes
3270: 74 2d 73 65 74 2d 6c 6f 67 21 20 64 62 20 72 75 t-set-log! db ru
3280: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 n-id test-name i
3290: 74 65 6d 64 61 74 20 6c 6f 67 66 29 20 0a 20 20 temdat logf) .
32a0: 28 6c 65 74 20 28 28 69 74 65 6d 2d 70 61 74 68 (let ((item-path
32b0: 20 28 69 74 65 6d 2d 6c 69 73 74 2d 3e 70 61 74 (item-list->pat
32c0: 68 20 69 74 65 6d 64 61 74 29 29 29 0a 20 20 20 h itemdat))).
32d0: 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 (sqlite3:execut
32e0: 65 20 64 62 20 22 55 50 44 41 54 45 20 74 65 73 e db "UPDATE tes
32f0: 74 73 20 53 45 54 20 66 69 6e 61 6c 5f 6c 6f 67 ts SET final_log
3300: 66 3d 3f 20 57 48 45 52 45 20 72 75 6e 5f 69 64 f=? WHERE run_id
3310: 3d 3f 20 41 4e 44 20 74 65 73 74 6e 61 6d 65 3d =? AND testname=
3320: 3f 20 41 4e 44 20 69 74 65 6d 5f 70 61 74 68 3d ? AND item_path=
3330: 3f 3b 22 20 0a 09 09 20 20 20 20 20 6c 6f 67 66 ?;" ... logf
3340: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
3350: 65 20 69 74 65 6d 2d 70 61 74 68 29 29 29 0a 0a e item-path)))..
3360: 28 64 65 66 69 6e 65 20 28 74 65 73 74 2d 73 65 (define (test-se
3370: 74 2d 74 6f 70 6c 6f 67 21 20 64 62 20 72 75 6e t-toplog! db run
3380: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 6c 6f -id test-name lo
3390: 67 66 29 20 0a 20 20 28 73 71 6c 69 74 65 33 3a gf) . (sqlite3:
33a0: 65 78 65 63 75 74 65 20 64 62 20 22 55 50 44 41 execute db "UPDA
33b0: 54 45 20 74 65 73 74 73 20 53 45 54 20 66 69 6e TE tests SET fin
33c0: 61 6c 5f 6c 6f 67 66 3d 3f 20 57 48 45 52 45 20 al_logf=? WHERE
33d0: 72 75 6e 5f 69 64 3d 3f 20 41 4e 44 20 74 65 73 run_id=? AND tes
33e0: 74 6e 61 6d 65 3d 3f 20 41 4e 44 20 69 74 65 6d tname=? AND item
33f0: 5f 70 61 74 68 3d 27 27 3b 22 20 0a 09 09 20 20 _path='';" ...
3400: 20 6c 6f 67 66 20 72 75 6e 2d 69 64 20 74 65 73 logf run-id tes
3410: 74 2d 6e 61 6d 65 29 29 0a 0a 28 64 65 66 69 6e t-name))..(defin
3420: 65 20 28 74 65 73 74 73 3a 73 75 6d 6d 61 72 69 e (tests:summari
3430: 7a 65 2d 69 74 65 6d 73 20 64 62 20 72 75 6e 2d ze-items db run-
3440: 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 66 6f 72 id test-name for
3450: 63 65 29 0a 20 20 3b 3b 20 69 66 20 6e 6f 74 20 ce). ;; if not
3460: 66 6f 72 63 65 20 74 68 65 6e 20 6f 6e 6c 79 20 force then only
3470: 75 70 64 61 74 65 20 74 68 65 20 72 65 63 6f 72 update the recor
3480: 64 20 69 66 20 6f 6e 65 20 6f 66 20 74 68 65 73 d if one of thes
3490: 65 20 69 73 20 74 72 75 65 3a 0a 20 20 3b 3b 20 e is true:. ;;
34a0: 20 20 31 2e 20 6c 6f 67 66 20 69 73 20 22 6c 6f 1. logf is "lo
34b0: 67 2f 66 69 6e 61 6c 2e 6c 6f 67 0a 20 20 3b 3b g/final.log. ;;
34c0: 20 20 20 32 2e 20 6c 6f 67 66 20 69 73 20 73 61 2. logf is sa
34d0: 6d 65 20 61 73 20 6f 75 74 70 75 74 66 69 6c 65 me as outputfile
34e0: 6e 61 6d 65 0a 20 20 28 6c 65 74 20 28 28 6f 75 name. (let ((ou
34f0: 74 70 75 74 66 69 6c 65 6e 61 6d 65 20 28 63 6f tputfilename (co
3500: 6e 63 20 22 6d 65 67 61 74 65 73 74 2d 72 6f 6c nc "megatest-rol
3510: 6c 75 70 2d 22 20 74 65 73 74 2d 6e 61 6d 65 20 lup-" test-name
3520: 22 2e 68 74 6d 6c 22 29 29 0a 09 28 6f 72 69 67 ".html"))..(orig
3530: 2d 64 69 72 20 20 20 20 20 20 20 28 63 75 72 72 -dir (curr
3540: 65 6e 74 2d 64 69 72 65 63 74 6f 72 79 29 29 0a ent-directory)).
3550: 09 28 6c 6f 67 66 20 20 20 20 20 20 20 20 20 20 .(logf
3560: 20 23 66 29 29 0a 20 20 20 20 28 73 71 6c 69 74 #f)). (sqlit
3570: 65 33 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 e3:for-each-row
3580: 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 70 . (lambda (p
3590: 61 74 68 20 66 69 6e 61 6c 5f 6c 6f 67 66 29 0a ath final_logf).
35a0: 20 20 20 20 20 20 20 28 73 65 74 21 20 6c 6f 67 (set! log
35b0: 66 20 66 69 6e 61 6c 5f 6c 6f 67 66 29 0a 20 20 f final_logf).
35c0: 20 20 20 20 20 28 69 66 20 28 64 69 72 65 63 74 (if (direct
35d0: 6f 72 79 3f 20 70 61 74 68 29 0a 09 20 20 20 28 ory? path).. (
35e0: 62 65 67 69 6e 0a 09 20 20 20 20 20 28 70 72 69 begin.. (pri
35f0: 6e 74 20 22 46 6f 75 6e 64 20 70 61 74 68 3a 20 nt "Found path:
3600: 22 20 70 61 74 68 29 0a 09 20 20 20 20 20 28 63 " path).. (c
3610: 68 61 6e 67 65 2d 64 69 72 65 63 74 6f 72 79 20 hange-directory
3620: 70 61 74 68 29 29 0a 09 20 20 20 20 20 3b 3b 20 path)).. ;;
3630: 28 73 65 74 21 20 6f 75 74 70 75 74 66 69 6c 65 (set! outputfile
3640: 6e 61 6d 65 20 28 63 6f 6e 63 20 70 61 74 68 20 name (conc path
3650: 22 2f 22 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 "/" outputfilena
3660: 6d 65 29 29 29 0a 09 20 20 20 28 70 72 69 6e 74 me))).. (print
3670: 20 22 4e 6f 20 73 75 63 68 20 70 61 74 68 3a 20 "No such path:
3680: 22 20 70 61 74 68 29 29 29 0a 20 20 20 20 20 64 " path))). d
3690: 62 20 0a 20 20 20 20 20 22 53 45 4c 45 43 54 20 b . "SELECT
36a0: 72 75 6e 64 69 72 2c 66 69 6e 61 6c 5f 6c 6f 67 rundir,final_log
36b0: 66 20 46 52 4f 4d 20 74 65 73 74 73 20 57 48 45 f FROM tests WHE
36c0: 52 45 20 72 75 6e 5f 69 64 3d 3f 20 41 4e 44 20 RE run_id=? AND
36d0: 74 65 73 74 6e 61 6d 65 3d 3f 20 41 4e 44 20 69 testname=? AND i
36e0: 74 65 6d 5f 70 61 74 68 3d 27 27 3b 22 0a 20 20 tem_path='';".
36f0: 20 20 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e run-id test-n
3700: 61 6d 65 29 0a 20 20 20 20 28 70 72 69 6e 74 20 ame). (print
3710: 22 73 75 6d 6d 61 72 69 7a 65 2d 69 74 65 6d 73 "summarize-items
3720: 20 77 69 74 68 20 6c 6f 67 66 20 22 20 6c 6f 67 with logf " log
3730: 66 29 0a 20 20 20 20 28 69 66 20 28 6f 72 20 28 f). (if (or (
3740: 65 71 75 61 6c 3f 20 6c 6f 67 66 20 22 6c 6f 67 equal? logf "log
3750: 73 2f 66 69 6e 61 6c 2e 6c 6f 67 22 29 0a 09 20 s/final.log")..
3760: 20 20 20 28 65 71 75 61 6c 3f 20 6c 6f 67 66 20 (equal? logf
3770: 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 29 0a outputfilename).
3780: 09 20 20 20 20 66 6f 72 63 65 29 0a 09 28 62 65 . force)..(be
3790: 67 69 6e 0a 09 20 20 28 69 66 20 28 6f 62 74 61 gin.. (if (obta
37a0: 69 6e 2d 64 6f 74 2d 6c 6f 63 6b 20 6f 75 74 70 in-dot-lock outp
37b0: 75 74 66 69 6c 65 6e 61 6d 65 20 31 20 32 30 20 utfilename 1 20
37c0: 33 30 29 20 3b 3b 20 72 65 74 72 79 20 65 76 65 30) ;; retry eve
37d0: 72 79 20 73 65 63 6f 6e 64 20 66 6f 72 20 32 30 ry second for 20
37e0: 20 73 65 63 6f 6e 64 73 2c 20 63 61 6c 6c 20 69 seconds, call i
37f0: 74 20 64 65 61 64 20 61 66 74 65 72 20 33 30 20 t dead after 30
3800: 73 65 63 6f 6e 64 73 20 61 6e 64 20 73 74 65 61 seconds and stea
3810: 6c 20 74 68 65 20 6c 6f 63 6b 0a 09 20 20 20 20 l the lock..
3820: 20 20 28 70 72 69 6e 74 20 22 4f 62 74 61 69 6e (print "Obtain
3830: 65 64 20 6c 6f 63 6b 20 66 6f 72 20 22 20 6f 75 ed lock for " ou
3840: 74 70 75 74 66 69 6c 65 6e 61 6d 65 29 0a 09 20 tputfilename)..
3850: 20 20 20 20 20 28 70 72 69 6e 74 20 22 46 61 69 (print "Fai
3860: 6c 65 64 20 74 6f 20 6f 62 74 61 69 6e 20 6c 6f led to obtain lo
3870: 63 6b 20 66 6f 72 20 22 20 6f 75 74 70 75 74 66 ck for " outputf
3880: 69 6c 65 6e 61 6d 65 29 29 0a 09 20 20 28 6c 65 ilename)).. (le
3890: 74 20 28 28 6f 75 70 20 20 20 20 28 6f 70 65 6e t ((oup (open
38a0: 2d 6f 75 74 70 75 74 2d 66 69 6c 65 20 6f 75 74 -output-file out
38b0: 70 75 74 66 69 6c 65 6e 61 6d 65 29 29 0a 09 09 putfilename))...
38c0: 28 63 6f 75 6e 74 73 20 28 6d 61 6b 65 2d 68 61 (counts (make-ha
38d0: 73 68 2d 74 61 62 6c 65 29 29 0a 09 09 28 73 74 sh-table))...(st
38e0: 61 74 65 63 6f 75 6e 74 73 20 28 6d 61 6b 65 2d atecounts (make-
38f0: 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 09 09 28 hash-table))...(
3900: 6f 75 74 74 78 74 20 22 22 29 0a 09 09 28 74 6f outtxt "")...(to
3910: 74 20 20 20 20 30 29 29 0a 09 20 20 20 20 28 77 t 0)).. (w
3920: 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 70 6f ith-output-to-po
3930: 72 74 0a 09 09 6f 75 70 0a 09 20 20 20 20 20 20 rt...oup..
3940: 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 28 73 65 (lambda ()...(se
3950: 74 21 20 6f 75 74 74 78 74 20 28 63 6f 6e 63 20 t! outtxt (conc
3960: 6f 75 74 74 78 74 20 22 3c 68 74 6d 6c 3e 3c 74 outtxt "<html><t
3970: 69 74 6c 65 3e 53 75 6d 6d 61 72 79 3a 20 22 20 itle>Summary: "
3980: 74 65 73 74 2d 6e 61 6d 65 20 0a 09 09 09 09 20 test-name .....
3990: 20 20 22 3c 2f 74 69 74 6c 65 3e 3c 62 6f 64 79 "</title><body
39a0: 3e 3c 68 32 3e 53 75 6d 6d 61 72 79 20 66 6f 72 ><h2>Summary for
39b0: 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 3c 2f " test-name "</
39c0: 68 32 3e 22 29 29 0a 09 09 28 73 71 6c 69 74 65 h2>"))...(sqlite
39d0: 33 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 0a 3:for-each-row .
39e0: 09 09 20 28 6c 61 6d 62 64 61 20 28 69 64 20 69 .. (lambda (id i
39f0: 74 65 6d 70 61 74 68 20 73 74 61 74 65 20 73 74 tempath state st
3a00: 61 74 75 73 20 72 75 6e 5f 64 75 72 61 74 69 6f atus run_duratio
3a10: 6e 20 6c 6f 67 66 20 63 6f 6d 6d 65 6e 74 29 0a n logf comment).
3a20: 09 09 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 .. (hash-table
3a30: 2d 73 65 74 21 20 63 6f 75 6e 74 73 20 73 74 61 -set! counts sta
3a40: 74 75 73 20 28 2b 20 31 20 28 68 61 73 68 2d 74 tus (+ 1 (hash-t
3a50: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
3a60: 20 63 6f 75 6e 74 73 20 73 74 61 74 75 73 20 30 counts status 0
3a70: 29 29 29 0a 09 09 20 20 20 28 68 61 73 68 2d 74 )))... (hash-t
3a80: 61 62 6c 65 2d 73 65 74 21 20 73 74 61 74 65 63 able-set! statec
3a90: 6f 75 6e 74 73 20 73 74 61 74 65 20 28 2b 20 31 ounts state (+ 1
3aa0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
3ab0: 2f 64 65 66 61 75 6c 74 20 73 74 61 74 65 63 6f /default stateco
3ac0: 75 6e 74 73 20 73 74 61 74 65 20 30 29 29 29 0a unts state 0))).
3ad0: 09 09 20 20 20 28 73 65 74 21 20 6f 75 74 74 78 .. (set! outtx
3ae0: 74 20 28 63 6f 6e 63 20 6f 75 74 74 78 74 20 22 t (conc outtxt "
3af0: 3c 74 72 3e 22 0a 09 09 09 09 20 20 20 20 20 20 <tr>".....
3b00: 22 3c 74 64 3e 3c 61 20 68 72 65 66 3d 5c 22 22 "<td><a href=\""
3b10: 20 69 74 65 6d 70 61 74 68 20 22 2f 22 20 6c 6f itempath "/" lo
3b20: 67 66 20 22 5c 22 3e 20 22 20 69 74 65 6d 70 61 gf "\"> " itempa
3b30: 74 68 20 22 3c 2f 61 3e 3c 2f 74 64 3e 22 20 0a th "</a></td>" .
3b40: 09 09 09 09 20 20 20 20 20 20 22 3c 74 64 3e 22 .... "<td>"
3b50: 20 73 74 61 74 65 20 20 20 20 22 3c 2f 74 64 3e state "</td>
3b60: 22 20 0a 09 09 09 09 20 20 20 20 20 20 22 3c 74 " ..... "<t
3b70: 64 3e 3c 66 6f 6e 74 20 63 6f 6c 6f 72 3d 22 20 d><font color="
3b80: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 6f 6c 6f (common:get-colo
3b90: 72 2d 66 72 6f 6d 2d 73 74 61 74 75 73 20 73 74 r-from-status st
3ba0: 61 74 75 73 29 0a 09 09 09 09 20 20 20 20 20 20 atus).....
3bb0: 22 3e 22 20 20 20 73 74 61 74 75 73 20 20 20 22 ">" status "
3bc0: 3c 2f 66 6f 6e 74 3e 3c 2f 74 64 3e 22 0a 09 09 </font></td>"...
3bd0: 09 09 20 20 20 20 20 20 22 3c 74 64 3e 22 20 28 .. "<td>" (
3be0: 69 66 20 28 65 71 75 61 6c 3f 20 63 6f 6d 6d 65 if (equal? comme
3bf0: 6e 74 20 22 22 29 0a 09 09 09 09 09 09 20 22 26 nt "")....... "&
3c00: 6e 62 73 70 3b 22 0a 09 09 09 09 09 09 20 63 6f nbsp;"....... co
3c10: 6d 6d 65 6e 74 29 20 22 3c 2f 74 64 3e 22 0a 09 mment) "</td>"..
3c20: 09 09 09 09 09 20 22 3c 2f 74 72 3e 22 29 29 29 ..... "</tr>")))
3c30: 0a 09 09 20 64 62 0a 09 09 20 22 53 45 4c 45 43 ... db... "SELEC
3c40: 54 20 69 64 2c 69 74 65 6d 5f 70 61 74 68 2c 73 T id,item_path,s
3c50: 74 61 74 65 2c 73 74 61 74 75 73 2c 72 75 6e 5f tate,status,run_
3c60: 64 75 72 61 74 69 6f 6e 2c 66 69 6e 61 6c 5f 6c duration,final_l
3c70: 6f 67 66 2c 63 6f 6d 6d 65 6e 74 20 46 52 4f 4d ogf,comment FROM
3c80: 20 74 65 73 74 73 20 57 48 45 52 45 20 72 75 6e tests WHERE run
3c90: 5f 69 64 3d 3f 20 41 4e 44 20 74 65 73 74 6e 61 _id=? AND testna
3ca0: 6d 65 3d 3f 20 41 4e 44 20 69 74 65 6d 5f 70 61 me=? AND item_pa
3cb0: 74 68 20 21 3d 20 27 27 3b 22 0a 09 09 20 72 75 th != '';"... ru
3cc0: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 29 0a n-id test-name).
3cd0: 0a 09 09 28 70 72 69 6e 74 20 22 3c 74 61 62 6c ...(print "<tabl
3ce0: 65 3e 3c 74 72 3e 3c 74 64 20 76 61 6c 69 67 6e e><tr><td valign
3cf0: 3d 5c 22 74 6f 70 5c 22 3e 22 29 0a 09 09 3b 3b =\"top\">")...;;
3d00: 20 50 72 69 6e 74 20 6f 75 74 20 73 74 61 74 73 Print out stats
3d10: 20 66 6f 72 20 73 74 61 74 75 73 0a 09 09 28 73 for status...(s
3d20: 65 74 21 20 74 6f 74 20 30 29 0a 09 09 28 70 72 et! tot 0)...(pr
3d30: 69 6e 74 20 22 3c 74 61 62 6c 65 20 63 65 6c 6c int "<table cell
3d40: 73 70 61 63 69 6e 67 3d 5c 22 30 5c 22 20 62 6f spacing=\"0\" bo
3d50: 72 64 65 72 3d 5c 22 31 5c 22 3e 3c 74 72 3e 3c rder=\"1\"><tr><
3d60: 74 64 20 63 6f 6c 73 70 61 6e 3d 5c 22 32 5c 22 td colspan=\"2\"
3d70: 3e 3c 68 32 3e 53 74 61 74 65 20 73 74 61 74 73 ><h2>State stats
3d80: 3c 2f 68 32 3e 3c 2f 74 64 3e 3c 2f 74 72 3e 22 </h2></td></tr>"
3d90: 29 0a 09 09 28 66 6f 72 2d 65 61 63 68 20 28 6c )...(for-each (l
3da0: 61 6d 62 64 61 20 28 73 74 61 74 65 29 0a 09 09 ambda (state)...
3db0: 09 20 20 20 20 28 73 65 74 21 20 74 6f 74 20 28 . (set! tot (
3dc0: 2b 20 74 6f 74 20 28 68 61 73 68 2d 74 61 62 6c + tot (hash-tabl
3dd0: 65 2d 72 65 66 20 73 74 61 74 65 63 6f 75 6e 74 e-ref statecount
3de0: 73 20 73 74 61 74 65 29 29 29 0a 09 09 09 20 20 s state)))....
3df0: 20 20 28 70 72 69 6e 74 20 22 3c 74 72 3e 3c 74 (print "<tr><t
3e00: 64 3e 22 20 73 74 61 74 65 20 22 3c 2f 74 64 3e d>" state "</td>
3e10: 3c 74 64 3e 22 20 28 68 61 73 68 2d 74 61 62 6c <td>" (hash-tabl
3e20: 65 2d 72 65 66 20 73 74 61 74 65 63 6f 75 6e 74 e-ref statecount
3e30: 73 20 73 74 61 74 65 29 20 22 3c 2f 74 64 3e 3c s state) "</td><
3e40: 2f 74 72 3e 22 29 29 0a 09 09 09 20 20 28 68 61 /tr>")).... (ha
3e50: 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 73 74 sh-table-keys st
3e60: 61 74 65 63 6f 75 6e 74 73 29 29 0a 09 09 28 70 atecounts))...(p
3e70: 72 69 6e 74 20 22 3c 74 72 3e 3c 74 64 3e 54 6f rint "<tr><td>To
3e80: 74 61 6c 3c 2f 74 64 3e 3c 74 64 3e 22 20 74 6f tal</td><td>" to
3e90: 74 20 22 3c 2f 74 64 3e 3c 2f 74 72 3e 3c 2f 74 t "</td></tr></t
3ea0: 61 62 6c 65 3e 22 29 0a 09 09 28 70 72 69 6e 74 able>")...(print
3eb0: 20 22 3c 2f 74 64 3e 3c 74 64 20 76 61 6c 69 67 "</td><td valig
3ec0: 6e 3d 5c 22 74 6f 70 5c 22 3e 22 29 0a 09 09 3b n=\"top\">")...;
3ed0: 3b 20 50 72 69 6e 74 20 6f 75 74 20 73 74 61 74 ; Print out stat
3ee0: 73 20 66 6f 72 20 73 74 61 74 65 0a 09 09 28 73 s for state...(s
3ef0: 65 74 21 20 74 6f 74 20 30 29 0a 09 09 28 70 72 et! tot 0)...(pr
3f00: 69 6e 74 20 22 3c 74 61 62 6c 65 20 63 65 6c 6c int "<table cell
3f10: 73 70 61 63 69 6e 67 3d 5c 22 30 5c 22 20 62 6f spacing=\"0\" bo
3f20: 72 64 65 72 3d 5c 22 31 5c 22 3e 3c 74 72 3e 3c rder=\"1\"><tr><
3f30: 74 64 20 63 6f 6c 73 70 61 6e 3d 5c 22 32 5c 22 td colspan=\"2\"
3f40: 3e 3c 68 32 3e 53 74 61 74 75 73 20 73 74 61 74 ><h2>Status stat
3f50: 73 3c 2f 68 32 3e 3c 2f 74 64 3e 3c 2f 74 72 3e s</h2></td></tr>
3f60: 22 29 0a 09 09 28 66 6f 72 2d 65 61 63 68 20 28 ")...(for-each (
3f70: 6c 61 6d 62 64 61 20 28 73 74 61 74 75 73 29 0a lambda (status).
3f80: 09 09 09 20 20 20 20 28 73 65 74 21 20 74 6f 74 ... (set! tot
3f90: 20 28 2b 20 74 6f 74 20 28 68 61 73 68 2d 74 61 (+ tot (hash-ta
3fa0: 62 6c 65 2d 72 65 66 20 63 6f 75 6e 74 73 20 73 ble-ref counts s
3fb0: 74 61 74 75 73 29 29 29 0a 09 09 09 20 20 20 20 tatus)))....
3fc0: 28 70 72 69 6e 74 20 22 3c 74 72 3e 3c 74 64 3e (print "<tr><td>
3fd0: 3c 66 6f 6e 74 20 63 6f 6c 6f 72 3d 5c 22 22 20 <font color=\""
3fe0: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 6f 6c 6f (common:get-colo
3ff0: 72 2d 66 72 6f 6d 2d 73 74 61 74 75 73 20 73 74 r-from-status st
4000: 61 74 75 73 29 20 22 5c 22 3e 22 20 73 74 61 74 atus) "\">" stat
4010: 75 73 0a 09 09 09 09 20 20 20 22 3c 2f 66 6f 6e us..... "</fon
4020: 74 3e 3c 2f 74 64 3e 3c 74 64 3e 22 20 28 68 61 t></td><td>" (ha
4030: 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 63 6f 75 sh-table-ref cou
4040: 6e 74 73 20 73 74 61 74 75 73 29 20 22 3c 2f 74 nts status) "</t
4050: 64 3e 3c 2f 74 72 3e 22 29 29 0a 09 09 09 20 20 d></tr>"))....
4060: 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 (hash-table-keys
4070: 20 63 6f 75 6e 74 73 29 29 0a 09 09 28 70 72 69 counts))...(pri
4080: 6e 74 20 22 3c 74 72 3e 3c 74 64 3e 54 6f 74 61 nt "<tr><td>Tota
4090: 6c 3c 2f 74 64 3e 3c 74 64 3e 22 20 74 6f 74 20 l</td><td>" tot
40a0: 22 3c 2f 74 64 3e 3c 2f 74 72 3e 3c 2f 74 61 62 "</td></tr></tab
40b0: 6c 65 3e 22 29 0a 09 09 28 70 72 69 6e 74 20 22 le>")...(print "
40c0: 3c 2f 74 64 3e 3c 2f 74 64 3e 3c 2f 74 72 3e 3c </td></td></tr><
40d0: 2f 74 61 62 6c 65 3e 22 29 0a 0a 09 09 28 70 72 /table>")....(pr
40e0: 69 6e 74 20 22 3c 74 61 62 6c 65 20 63 65 6c 6c int "<table cell
40f0: 73 70 61 63 69 6e 67 3d 5c 22 30 5c 22 20 62 6f spacing=\"0\" bo
4100: 72 64 65 72 3d 5c 22 31 5c 22 3e 22 20 0a 09 09 rder=\"1\">" ...
4110: 20 20 20 20 20 20 20 22 3c 74 72 3e 3c 74 64 3e "<tr><td>
4120: 49 74 65 6d 3c 2f 74 64 3e 3c 74 64 3e 53 74 61 Item</td><td>Sta
4130: 74 65 3c 2f 74 64 3e 3c 74 64 3e 53 74 61 74 75 te</td><td>Statu
4140: 73 3c 2f 74 64 3e 3c 74 64 3e 43 6f 6d 6d 65 6e s</td><td>Commen
4150: 74 3c 2f 74 64 3e 22 0a 09 09 20 20 20 20 20 20 t</td>"...
4160: 20 6f 75 74 74 78 74 20 22 3c 2f 74 61 62 6c 65 outtxt "</table
4170: 3e 3c 2f 62 6f 64 79 3e 3c 2f 68 74 6d 6c 3e 22 ></body></html>"
4180: 29 0a 09 09 28 72 65 6c 65 61 73 65 2d 64 6f 74 )...(release-dot
4190: 2d 6c 6f 63 6b 20 6f 75 74 70 75 74 66 69 6c 65 -lock outputfile
41a0: 6e 61 6d 65 29 29 29 0a 09 20 20 20 20 28 63 6c name))).. (cl
41b0: 6f 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 ose-output-port
41c0: 6f 75 70 29 0a 09 20 20 20 20 28 63 68 61 6e 67 oup).. (chang
41d0: 65 2d 64 69 72 65 63 74 6f 72 79 20 6f 72 69 67 e-directory orig
41e0: 2d 64 69 72 29 0a 09 20 20 20 20 28 74 65 73 74 -dir).. (test
41f0: 2d 73 65 74 2d 74 6f 70 6c 6f 67 21 20 64 62 20 -set-toplog! db
4200: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
4210: 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 29 outputfilename)
4220: 0a 09 20 20 20 20 29 29 29 29 29 0a 0a 3b 3b 20 .. )))))..;;
4230: 3b 3b 20 54 4f 44 4f 3a 20 43 6f 6e 76 65 72 67 ;; TODO: Converg
4240: 65 20 74 68 69 73 20 77 69 74 68 20 64 62 3a 67 e this with db:g
4250: 65 74 2d 74 65 73 74 2d 69 6e 66 6f 0a 3b 3b 20 et-test-info.;;
4260: 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 67 65 (define (runs:ge
4270: 74 2d 74 65 73 74 2d 69 6e 66 6f 20 64 62 20 72 t-test-info db r
4280: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 un-id test-name
4290: 69 74 65 6d 2d 70 61 74 68 29 0a 3b 3b 20 20 20 item-path).;;
42a0: 28 6c 65 74 20 28 28 72 65 73 20 23 66 29 29 20 (let ((res #f))
42b0: 3b 3b 20 28 76 65 63 74 6f 72 20 23 66 20 23 66 ;; (vector #f #f
42c0: 20 23 66 20 23 66 20 23 66 20 23 66 29 29 29 0a #f #f #f #f))).
42d0: 3b 3b 20 20 20 20 20 28 73 71 6c 69 74 65 33 3a ;; (sqlite3:
42e0: 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 0a 3b 3b for-each-row .;;
42f0: 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 69 (lambda (i
4300: 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 d run-id test-na
4310: 6d 65 20 73 74 61 74 65 20 73 74 61 74 75 73 29 me state status)
4320: 0a 3b 3b 20 20 20 20 20 20 20 20 28 73 65 74 21 .;; (set!
4330: 20 72 65 73 20 28 76 65 63 74 6f 72 20 69 64 20 res (vector id
4340: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
4350: 20 73 74 61 74 65 20 73 74 61 74 75 73 20 69 74 state status it
4360: 65 6d 2d 70 61 74 68 29 29 29 0a 3b 3b 20 20 20 em-path))).;;
4370: 20 20 20 64 62 20 22 53 45 4c 45 43 54 20 69 64 db "SELECT id
4380: 2c 72 75 6e 5f 69 64 2c 74 65 73 74 6e 61 6d 65 ,run_id,testname
4390: 2c 73 74 61 74 65 2c 73 74 61 74 75 73 20 46 52 ,state,status FR
43a0: 4f 4d 20 74 65 73 74 73 20 57 48 45 52 45 20 72 OM tests WHERE r
43b0: 75 6e 5f 69 64 3d 3f 20 41 4e 44 20 74 65 73 74 un_id=? AND test
43c0: 6e 61 6d 65 3d 3f 20 41 4e 44 20 69 74 65 6d 5f name=? AND item_
43d0: 70 61 74 68 3d 3f 3b 22 0a 3b 3b 20 20 20 20 20 path=?;".;;
43e0: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
43f0: 65 20 69 74 65 6d 2d 70 61 74 68 29 0a 3b 3b 20 e item-path).;;
4400: 20 20 20 20 72 65 73 29 29 0a 0a 28 64 65 66 69 res))..(defi
4410: 6e 65 20 28 72 75 6e 73 3a 74 65 73 74 2d 67 65 ne (runs:test-ge
4420: 74 2d 66 75 6c 6c 2d 70 61 74 68 20 74 65 73 74 t-full-path test
4430: 29 0a 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 ). (let* ((test
4440: 6e 61 6d 65 20 28 64 62 3a 74 65 73 74 2d 67 65 name (db:test-ge
4450: 74 2d 74 65 73 74 6e 61 6d 65 20 20 20 74 65 73 t-testname tes
4460: 74 29 29 0a 09 20 28 69 74 65 6d 70 61 74 68 20 t)).. (itempath
4470: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 (db:test-get-ite
4480: 6d 2d 70 61 74 68 20 74 65 73 74 29 29 29 0a 20 m-path test))).
4490: 20 20 20 28 63 6f 6e 63 20 74 65 73 74 6e 61 6d (conc testnam
44a0: 65 20 28 69 66 20 28 65 71 75 61 6c 3f 20 69 74 e (if (equal? it
44b0: 65 6d 70 61 74 68 20 22 22 29 20 22 22 20 28 63 empath "") "" (c
44c0: 6f 6e 63 20 22 28 22 20 69 74 65 6d 70 61 74 68 onc "(" itempath
44d0: 20 22 29 22 29 29 29 29 29 0a 0a 28 64 65 66 69 ")")))))..(defi
44e0: 6e 65 20 28 63 68 65 63 6b 2d 76 61 6c 69 64 2d ne (check-valid-
44f0: 69 74 65 6d 73 20 63 6c 61 73 73 20 69 74 65 6d items class item
4500: 29 0a 20 20 28 6c 65 74 20 28 28 76 61 6c 69 64 ). (let ((valid
4510: 2d 76 61 6c 75 65 73 20 28 6c 65 74 20 28 28 73 -values (let ((s
4520: 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 (config-lookup
4530: 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 76 61 6c *configdat* "val
4540: 69 64 76 61 6c 75 65 73 22 20 63 6c 61 73 73 29 idvalues" class)
4550: 29 29 0a 09 09 09 28 69 66 20 73 20 28 73 74 72 ))....(if s (str
4560: 69 6e 67 2d 73 70 6c 69 74 20 73 29 20 23 66 29 ing-split s) #f)
4570: 29 29 29 0a 20 20 20 20 28 69 66 20 76 61 6c 69 ))). (if vali
4580: 64 2d 76 61 6c 75 65 73 0a 09 28 69 66 20 28 6d d-values..(if (m
4590: 65 6d 62 65 72 20 69 74 65 6d 20 76 61 6c 69 64 ember item valid
45a0: 2d 76 61 6c 75 65 73 29 0a 09 20 20 20 20 69 74 -values).. it
45b0: 65 6d 20 23 66 29 0a 09 69 74 65 6d 29 29 29 0a em #f)..item))).
45c0: 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 74 .(define (testst
45d0: 65 70 2d 73 65 74 2d 73 74 61 74 75 73 21 20 64 ep-set-status! d
45e0: 62 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 b run-id test-na
45f0: 6d 65 20 74 65 73 74 73 74 65 70 2d 6e 61 6d 65 me teststep-name
4600: 20 73 74 61 74 65 2d 69 6e 20 73 74 61 74 75 73 state-in status
4610: 2d 69 6e 20 69 74 65 6d 64 61 74 20 63 6f 6d 6d -in itemdat comm
4620: 65 6e 74 20 6c 6f 67 66 69 6c 65 29 0a 20 20 28 ent logfile). (
4630: 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 72 debug:print 4 "r
4640: 75 6e 2d 69 64 3a 20 22 20 72 75 6e 2d 69 64 20 un-id: " run-id
4650: 22 20 74 65 73 74 2d 6e 61 6d 65 3a 20 22 20 74 " test-name: " t
4660: 65 73 74 2d 6e 61 6d 65 29 0a 20 20 28 6c 65 74 est-name). (let
4670: 2a 20 28 28 73 74 61 74 65 20 20 20 20 20 28 63 * ((state (c
4680: 68 65 63 6b 2d 76 61 6c 69 64 2d 69 74 65 6d 73 heck-valid-items
4690: 20 22 73 74 61 74 65 22 20 73 74 61 74 65 2d 69 "state" state-i
46a0: 6e 29 29 0a 09 20 28 73 74 61 74 75 73 20 20 20 n)).. (status
46b0: 20 28 63 68 65 63 6b 2d 76 61 6c 69 64 2d 69 74 (check-valid-it
46c0: 65 6d 73 20 22 73 74 61 74 75 73 22 20 73 74 61 ems "status" sta
46d0: 74 75 73 2d 69 6e 29 29 0a 09 20 28 69 74 65 6d tus-in)).. (item
46e0: 2d 70 61 74 68 20 28 69 74 65 6d 2d 6c 69 73 74 -path (item-list
46f0: 2d 3e 70 61 74 68 20 69 74 65 6d 64 61 74 29 29 ->path itemdat))
4700: 0a 09 20 28 74 65 73 74 64 61 74 20 20 20 28 64 .. (testdat (d
4710: 62 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 20 b:get-test-info
4720: 64 62 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e db run-id test-n
4730: 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 29 ame item-path)))
4740: 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
4750: 74 20 35 20 22 74 65 73 74 64 61 74 3a 20 22 20 t 5 "testdat: "
4760: 74 65 73 74 64 61 74 29 0a 20 20 20 20 28 69 66 testdat). (if
4770: 20 28 61 6e 64 20 74 65 73 74 64 61 74 20 3b 3b (and testdat ;;
4780: 20 69 66 20 74 68 65 20 73 65 63 74 69 6f 6e 20 if the section
4790: 65 78 69 73 74 73 20 74 68 65 6e 20 66 6f 72 63 exists then forc
47a0: 65 20 73 70 65 63 69 66 69 63 61 74 69 6f 6e 20 e specification
47b0: 42 55 47 2c 20 49 20 64 6f 6e 27 74 20 6c 69 6b BUG, I don't lik
47c0: 65 20 68 6f 77 20 74 68 69 73 20 77 6f 72 6b 73 e how this works
47d0: 2e 0a 09 20 20 20 20 20 28 6f 72 20 28 6e 6f 74 ... (or (not
47e0: 20 73 74 61 74 65 29 28 6e 6f 74 20 73 74 61 74 state)(not stat
47f0: 75 73 29 29 29 0a 09 28 64 65 62 75 67 3a 70 72 us)))..(debug:pr
4800: 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 int 0 "WARNING:
4810: 49 6e 76 61 6c 69 64 20 22 20 28 69 66 20 73 74 Invalid " (if st
4820: 61 74 75 73 20 22 73 74 61 74 75 73 22 20 22 73 atus "status" "s
4830: 74 61 74 65 22 29 0a 09 20 20 20 20 20 20 20 22 tate").. "
4840: 20 76 61 6c 75 65 20 5c 22 22 20 28 69 66 20 73 value \"" (if s
4850: 74 61 74 75 73 20 73 74 61 74 65 2d 69 6e 20 73 tatus state-in s
4860: 74 61 74 75 73 2d 69 6e 29 20 22 5c 22 2c 20 75 tatus-in) "\", u
4870: 70 64 61 74 65 20 79 6f 75 72 20 76 61 6c 69 64 pdate your valid
4880: 76 61 6c 75 65 73 20 73 65 63 74 69 6f 6e 20 69 values section i
4890: 6e 20 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 n megatest.confi
48a0: 67 22 29 29 0a 20 20 20 20 28 69 66 20 74 65 73 g")). (if tes
48b0: 74 64 61 74 0a 09 28 6c 65 74 20 28 28 74 65 73 tdat..(let ((tes
48c0: 74 2d 69 64 20 28 74 65 73 74 3a 67 65 74 2d 69 t-id (test:get-i
48d0: 64 20 74 65 73 74 64 61 74 29 29 29 0a 09 20 20 d testdat)))..
48e0: 3b 3b 20 46 49 58 4d 45 20 2d 20 74 68 69 73 20 ;; FIXME - this
48f0: 73 68 6f 75 6c 64 20 6e 6f 74 20 75 70 64 61 74 should not updat
4900: 65 20 74 68 65 20 6c 6f 67 66 69 6c 65 20 75 6e e the logfile un
4910: 6c 65 73 73 20 69 74 20 69 73 20 73 70 65 63 69 less it is speci
4920: 66 69 65 64 2e 0a 09 20 20 28 73 71 6c 69 74 65 fied... (sqlite
4930: 33 3a 65 78 65 63 75 74 65 20 64 62 20 0a 09 09 3:execute db ...
4940: 09 22 49 4e 53 45 52 54 20 4f 52 20 52 45 50 4c ."INSERT OR REPL
4950: 41 43 45 20 69 6e 74 6f 20 74 65 73 74 5f 73 74 ACE into test_st
4960: 65 70 73 20 28 74 65 73 74 5f 69 64 2c 73 74 65 eps (test_id,ste
4970: 70 6e 61 6d 65 2c 73 74 61 74 65 2c 73 74 61 74 pname,state,stat
4980: 75 73 2c 65 76 65 6e 74 5f 74 69 6d 65 2c 63 6f us,event_time,co
4990: 6d 6d 65 6e 74 2c 6c 6f 67 66 69 6c 65 29 20 56 mment,logfile) V
49a0: 41 4c 55 45 53 28 3f 2c 3f 2c 3f 2c 3f 2c 73 74 ALUES(?,?,?,?,st
49b0: 72 66 74 69 6d 65 28 27 25 73 27 2c 27 6e 6f 77 rftime('%s','now
49c0: 27 29 2c 3f 2c 3f 29 3b 22 0a 09 09 09 74 65 73 '),?,?);"....tes
49d0: 74 2d 69 64 20 74 65 73 74 73 74 65 70 2d 6e 61 t-id teststep-na
49e0: 6d 65 20 73 74 61 74 65 2d 69 6e 20 73 74 61 74 me state-in stat
49f0: 75 73 2d 69 6e 20 28 69 66 20 63 6f 6d 6d 65 6e us-in (if commen
4a00: 74 20 63 6f 6d 6d 65 6e 74 20 22 22 29 20 28 69 t comment "") (i
4a10: 66 20 6c 6f 67 66 69 6c 65 20 6c 6f 67 66 69 6c f logfile logfil
4a20: 65 20 22 22 29 29 29 0a 09 28 64 65 62 75 67 3a e "")))..(debug:
4a30: 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 print 0 "ERROR:
4a40: 43 61 6e 27 74 20 75 70 64 61 74 65 20 22 20 74 Can't update " t
4a50: 65 73 74 2d 6e 61 6d 65 20 22 20 66 6f 72 20 72 est-name " for r
4a60: 75 6e 20 22 20 72 75 6e 2d 69 64 20 22 20 2d 3e un " run-id " ->
4a70: 20 6e 6f 20 73 75 63 68 20 74 65 73 74 20 69 6e no such test in
4a80: 20 64 62 22 29 29 29 29 0a 0a 28 64 65 66 69 6e db"))))..(defin
4a90: 65 20 28 74 65 73 74 2d 67 65 74 2d 6b 69 6c 6c e (test-get-kill
4aa0: 2d 72 65 71 75 65 73 74 20 64 62 20 72 75 6e 2d -request db run-
4ab0: 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 id test-name ite
4ac0: 6d 64 61 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 mdat). (let* ((
4ad0: 69 74 65 6d 2d 70 61 74 68 20 28 69 74 65 6d 2d item-path (item-
4ae0: 6c 69 73 74 2d 3e 70 61 74 68 20 69 74 65 6d 64 list->path itemd
4af0: 61 74 29 29 0a 09 20 28 74 65 73 74 64 61 74 20 at)).. (testdat
4b00: 20 20 28 64 62 3a 67 65 74 2d 74 65 73 74 2d 69 (db:get-test-i
4b10: 6e 66 6f 20 64 62 20 72 75 6e 2d 69 64 20 74 65 nfo db run-id te
4b20: 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 st-name item-pat
4b30: 68 29 29 29 0a 20 20 20 20 28 65 71 75 61 6c 3f h))). (equal?
4b40: 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 (test:get-state
4b50: 20 74 65 73 74 64 61 74 29 20 22 4b 49 4c 4c 52 testdat) "KILLR
4b60: 45 51 22 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 EQ")))..(define
4b70: 28 74 65 73 74 2d 73 65 74 2d 6d 65 74 61 2d 69 (test-set-meta-i
4b80: 6e 66 6f 20 64 62 20 72 75 6e 2d 69 64 20 74 65 nfo db run-id te
4b90: 73 74 6e 61 6d 65 20 69 74 65 6d 64 61 74 29 0a stname itemdat).
4ba0: 20 20 28 6c 65 74 20 28 28 69 74 65 6d 2d 70 61 (let ((item-pa
4bb0: 74 68 20 28 69 74 65 6d 2d 6c 69 73 74 2d 3e 70 th (item-list->p
4bc0: 61 74 68 20 69 74 65 6d 64 61 74 29 29 0a 09 28 ath itemdat))..(
4bd0: 63 70 75 6c 6f 61 64 20 20 28 67 65 74 2d 63 70 cpuload (get-cp
4be0: 75 2d 6c 6f 61 64 29 29 0a 09 28 68 6f 73 74 6e u-load))..(hostn
4bf0: 61 6d 65 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 ame (get-host-na
4c00: 6d 65 29 29 0a 09 28 64 69 73 6b 66 72 65 65 20 me))..(diskfree
4c10: 28 67 65 74 2d 64 66 20 28 63 75 72 72 65 6e 74 (get-df (current
4c20: 2d 64 69 72 65 63 74 6f 72 79 29 29 29 0a 09 28 -directory)))..(
4c30: 75 6e 61 6d 65 20 20 20 20 28 67 65 74 2d 75 6e uname (get-un
4c40: 61 6d 65 20 22 2d 73 72 76 70 69 6f 22 29 29 0a ame "-srvpio")).
4c50: 09 28 72 75 6e 70 61 74 68 20 20 28 63 75 72 72 .(runpath (curr
4c60: 65 6e 74 2d 64 69 72 65 63 74 6f 72 79 29 29 29 ent-directory)))
4c70: 0a 20 20 20 20 28 73 71 6c 69 74 65 33 3a 65 78 . (sqlite3:ex
4c80: 65 63 75 74 65 20 64 62 20 22 55 50 44 41 54 45 ecute db "UPDATE
4c90: 20 74 65 73 74 73 20 53 45 54 20 68 6f 73 74 3d tests SET host=
4ca0: 3f 2c 63 70 75 6c 6f 61 64 3d 3f 2c 64 69 73 6b ?,cpuload=?,disk
4cb0: 66 72 65 65 3d 3f 2c 75 6e 61 6d 65 3d 3f 2c 72 free=?,uname=?,r
4cc0: 75 6e 64 69 72 3d 3f 20 57 48 45 52 45 20 72 75 undir=? WHERE ru
4cd0: 6e 5f 69 64 3d 3f 20 41 4e 44 20 74 65 73 74 6e n_id=? AND testn
4ce0: 61 6d 65 3d 3f 20 41 4e 44 20 69 74 65 6d 5f 70 ame=? AND item_p
4cf0: 61 74 68 3d 3f 3b 22 0a 09 09 20 20 68 6f 73 74 ath=?;"... host
4d00: 6e 61 6d 65 0a 09 09 20 20 63 70 75 6c 6f 61 64 name... cpuload
4d10: 0a 09 09 20 20 64 69 73 6b 66 72 65 65 0a 09 09 ... diskfree...
4d20: 20 20 75 6e 61 6d 65 0a 09 09 20 20 72 75 6e 70 uname... runp
4d30: 61 74 68 0a 09 09 20 20 72 75 6e 2d 69 64 0a 09 ath... run-id..
4d40: 09 20 20 74 65 73 74 6e 61 6d 65 0a 09 09 20 20 . testname...
4d50: 69 74 65 6d 2d 70 61 74 68 29 29 29 0a 0a 28 64 item-path)))..(d
4d60: 65 66 69 6e 65 20 28 74 65 73 74 2d 75 70 64 61 efine (test-upda
4d70: 74 65 2d 6d 65 74 61 2d 69 6e 66 6f 20 64 62 20 te-meta-info db
4d80: 72 75 6e 2d 69 64 20 74 65 73 74 6e 61 6d 65 20 run-id testname
4d90: 69 74 65 6d 64 61 74 20 6d 69 6e 75 74 65 73 20 itemdat minutes
4da0: 63 70 75 6c 6f 61 64 20 64 69 73 6b 66 72 65 65 cpuload diskfree
4db0: 20 74 6d 70 66 72 65 65 29 0a 20 20 28 6c 65 74 tmpfree). (let
4dc0: 20 28 28 69 74 65 6d 2d 70 61 74 68 20 28 69 74 ((item-path (it
4dd0: 65 6d 2d 6c 69 73 74 2d 3e 70 61 74 68 20 69 74 em-list->path it
4de0: 65 6d 64 61 74 29 29 29 0a 20 20 20 20 28 69 66 emdat))). (if
4df0: 20 28 6e 6f 74 20 69 74 65 6d 2d 70 61 74 68 29 (not item-path)
4e00: 28 62 65 67 69 6e 20 28 64 65 62 75 67 3a 70 72 (begin (debug:pr
4e10: 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 int 0 "WARNING:
4e20: 49 54 45 4d 50 41 54 48 20 6e 6f 74 20 73 65 74 ITEMPATH not set
4e30: 2e 22 29 20 20 20 28 73 65 74 21 20 69 74 65 6d .") (set! item
4e40: 2d 70 61 74 68 20 22 22 29 29 29 0a 20 20 20 20 -path ""))).
4e50: 3b 3b 20 28 6c 65 74 20 28 28 74 65 73 74 69 6e ;; (let ((testin
4e60: 66 6f 20 28 64 62 3a 67 65 74 2d 74 65 73 74 2d fo (db:get-test-
4e70: 69 6e 66 6f 20 64 62 20 72 75 6e 2d 69 64 20 74 info db run-id t
4e80: 65 73 74 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 estname item-pat
4e90: 68 29 29 29 0a 20 20 20 20 3b 3b 20 20 20 28 69 h))). ;; (i
4ea0: 66 20 28 61 6e 64 20 28 6e 6f 74 20 28 65 71 75 f (and (not (equ
4eb0: 61 6c 3f 20 28 64 62 3a 74 65 73 74 2d 67 65 74 al? (db:test-get
4ec0: 2d 73 74 61 74 75 73 20 74 65 73 74 69 6e 66 6f -status testinfo
4ed0: 29 20 22 43 4f 4d 50 4c 45 54 45 44 22 29 29 0a ) "COMPLETED")).
4ee0: 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 ;;
4ef0: 20 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 28 (not (equal? (
4f00: 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 db:test-get-stat
4f10: 75 73 20 74 65 73 74 69 6e 66 6f 29 20 22 4b 49 us testinfo) "KI
4f20: 4c 4c 52 45 51 22 29 29 0a 20 20 20 20 28 73 71 LLREQ")). (sq
4f30: 6c 69 74 65 33 3a 65 78 65 63 75 74 65 0a 20 20 lite3:execute.
4f40: 20 20 20 64 62 0a 20 20 20 20 20 22 55 50 44 41 db. "UPDA
4f50: 54 45 20 74 65 73 74 73 20 53 45 54 20 63 70 75 TE tests SET cpu
4f60: 6c 6f 61 64 3d 3f 2c 64 69 73 6b 66 72 65 65 3d load=?,diskfree=
4f70: 3f 2c 72 75 6e 5f 64 75 72 61 74 69 6f 6e 3d 3f ?,run_duration=?
4f80: 2c 73 74 61 74 65 3d 27 52 55 4e 4e 49 4e 47 27 ,state='RUNNING'
4f90: 20 57 48 45 52 45 20 72 75 6e 5f 69 64 3d 3f 20 WHERE run_id=?
4fa0: 41 4e 44 20 74 65 73 74 6e 61 6d 65 3d 3f 20 41 AND testname=? A
4fb0: 4e 44 20 69 74 65 6d 5f 70 61 74 68 3d 3f 20 41 ND item_path=? A
4fc0: 4e 44 20 73 74 61 74 65 20 4e 4f 54 20 49 4e 20 ND state NOT IN
4fd0: 28 27 43 4f 4d 50 4c 45 54 45 44 27 2c 27 4b 49 ('COMPLETED','KI
4fe0: 4c 4c 52 45 51 27 2c 27 4b 49 4c 4c 45 44 27 29 LLREQ','KILLED')
4ff0: 3b 22 0a 20 20 20 20 20 63 70 75 6c 6f 61 64 0a ;". cpuload.
5000: 20 20 20 20 20 64 69 73 6b 66 72 65 65 0a 20 20 diskfree.
5010: 20 20 20 6d 69 6e 75 74 65 73 0a 20 20 20 20 20 minutes.
5020: 72 75 6e 2d 69 64 0a 20 20 20 20 20 74 65 73 74 run-id. test
5030: 6e 61 6d 65 0a 20 20 20 20 20 69 74 65 6d 2d 70 name. item-p
5040: 61 74 68 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ath)))..(define
5050: 28 73 65 74 2d 6d 65 67 61 74 65 73 74 2d 65 6e (set-megatest-en
5060: 76 2d 76 61 72 73 20 64 62 20 72 75 6e 2d 69 64 v-vars db run-id
5070: 29 0a 20 20 28 6c 65 74 20 28 28 6b 65 79 73 20 ). (let ((keys
5080: 28 64 62 2d 67 65 74 2d 6b 65 79 73 20 64 62 29 (db-get-keys db)
5090: 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 )). (for-each
50a0: 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 29 0a 09 (lambda (key)..
50b0: 09 28 73 71 6c 69 74 65 33 3a 66 6f 72 2d 65 61 .(sqlite3:for-ea
50c0: 63 68 2d 72 6f 77 0a 09 09 20 28 6c 61 6d 62 64 ch-row... (lambd
50d0: 61 20 28 76 61 6c 29 0a 09 09 20 20 20 28 64 65 a (val)... (de
50e0: 62 75 67 3a 70 72 69 6e 74 20 32 20 22 73 65 74 bug:print 2 "set
50f0: 65 6e 76 20 22 20 28 6b 65 79 3a 67 65 74 2d 66 env " (key:get-f
5100: 69 65 6c 64 6e 61 6d 65 20 6b 65 79 29 20 22 20 ieldname key) "
5110: 22 20 76 61 6c 29 0a 09 09 20 20 20 28 73 65 74 " val)... (set
5120: 65 6e 76 20 28 6b 65 79 3a 67 65 74 2d 66 69 65 env (key:get-fie
5130: 6c 64 6e 61 6d 65 20 6b 65 79 29 20 76 61 6c 29 ldname key) val)
5140: 29 0a 09 09 20 64 62 20 0a 09 09 20 28 63 6f 6e )... db ... (con
5150: 63 20 22 53 45 4c 45 43 54 20 22 20 28 6b 65 79 c "SELECT " (key
5160: 3a 67 65 74 2d 66 69 65 6c 64 6e 61 6d 65 20 6b :get-fieldname k
5170: 65 79 29 20 22 20 46 52 4f 4d 20 72 75 6e 73 20 ey) " FROM runs
5180: 57 48 45 52 45 20 69 64 3d 3f 3b 22 29 0a 09 09 WHERE id=?;")...
5190: 20 72 75 6e 2d 69 64 29 29 0a 09 20 20 20 20 20 run-id))..
51a0: 20 6b 65 79 73 29 29 29 0a 0a 28 64 65 66 69 6e keys)))..(defin
51b0: 65 20 28 73 65 74 2d 69 74 65 6d 2d 65 6e 76 2d e (set-item-env-
51c0: 76 61 72 73 20 69 74 65 6d 64 61 74 29 0a 20 20 vars itemdat).
51d0: 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 (for-each (lambd
51e0: 61 20 28 69 74 65 6d 29 0a 09 20 20 20 20 20 20 a (item)..
51f0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 (debug:print 2 "
5200: 73 65 74 65 6e 76 20 22 20 28 63 61 72 20 69 74 setenv " (car it
5210: 65 6d 29 20 22 20 22 20 28 63 61 64 72 20 69 74 em) " " (cadr it
5220: 65 6d 29 29 0a 09 20 20 20 20 20 20 28 73 65 74 em)).. (set
5230: 65 6e 76 20 28 63 61 72 20 69 74 65 6d 29 20 28 env (car item) (
5240: 63 61 64 72 20 69 74 65 6d 29 29 29 0a 09 20 20 cadr item)))..
5250: 20 20 69 74 65 6d 64 61 74 29 29 0a 0a 28 64 65 itemdat))..(de
5260: 66 69 6e 65 20 28 67 65 74 2d 61 6c 6c 2d 6c 65 fine (get-all-le
5270: 67 61 6c 2d 74 65 73 74 73 29 0a 20 20 28 6c 65 gal-tests). (le
5280: 74 2a 20 28 28 74 65 73 74 73 20 20 28 67 6c 6f t* ((tests (glo
5290: 62 20 28 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 b (conc *toppath
52a0: 2a 20 22 2f 74 65 73 74 73 2f 2a 22 29 29 29 0a * "/tests/*"))).
52b0: 09 20 28 72 65 73 20 20 20 20 27 28 29 29 29 0a . (res '())).
52c0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
52d0: 20 34 20 22 49 4e 46 4f 3a 20 4c 6f 6f 6b 69 6e 4 "INFO: Lookin
52e0: 67 20 61 74 20 74 65 73 74 73 20 22 20 28 73 74 g at tests " (st
52f0: 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
5300: 20 74 65 73 74 73 20 22 2c 22 29 29 0a 20 20 20 tests ",")).
5310: 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 (for-each (lamb
5320: 64 61 20 28 74 65 73 74 70 61 74 68 29 0a 09 09 da (testpath)...
5330: 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 (if (file-exists
5340: 3f 20 28 63 6f 6e 63 20 74 65 73 74 70 61 74 68 ? (conc testpath
5350: 20 22 2f 74 65 73 74 63 6f 6e 66 69 67 22 29 29 "/testconfig"))
5360: 0a 09 09 20 20 20 20 28 73 65 74 21 20 72 65 73 ... (set! res
5370: 20 28 63 6f 6e 73 20 28 6c 61 73 74 20 28 73 74 (cons (last (st
5380: 72 69 6e 67 2d 73 70 6c 69 74 20 74 65 73 74 70 ring-split testp
5390: 61 74 68 20 22 2f 22 29 29 20 72 65 73 29 29 29 ath "/")) res)))
53a0: 29 0a 09 20 20 20 20 20 20 74 65 73 74 73 29 0a ).. tests).
53b0: 20 20 20 20 72 65 73 29 29 0a 0a 28 64 65 66 69 res))..(defi
53c0: 6e 65 20 28 72 75 6e 73 3a 63 61 6e 2d 72 75 6e ne (runs:can-run
53d0: 2d 6d 6f 72 65 2d 74 65 73 74 73 20 64 62 29 0a -more-tests db).
53e0: 20 20 28 6c 65 74 20 28 28 6e 75 6d 2d 72 75 6e (let ((num-run
53f0: 6e 69 6e 67 20 28 64 62 3a 67 65 74 2d 63 6f 75 ning (db:get-cou
5400: 6e 74 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 nt-tests-running
5410: 20 64 62 29 29 0a 09 28 6d 61 78 2d 63 6f 6e 63 db))..(max-conc
5420: 75 72 72 65 6e 74 2d 6a 6f 62 73 20 28 63 6f 6e urrent-jobs (con
5430: 66 69 67 2d 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 fig-lookup *conf
5440: 69 67 64 61 74 2a 20 22 73 65 74 75 70 22 20 22 igdat* "setup" "
5450: 6d 61 78 5f 63 6f 6e 63 75 72 72 65 6e 74 5f 6a max_concurrent_j
5460: 6f 62 73 22 29 29 29 0a 20 20 20 20 28 64 65 62 obs"))). (deb
5470: 75 67 3a 70 72 69 6e 74 20 32 20 22 6d 61 78 2d ug:print 2 "max-
5480: 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 3a concurrent-jobs:
5490: 20 22 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e " max-concurren
54a0: 74 2d 6a 6f 62 73 20 22 2c 20 6e 75 6d 2d 72 75 t-jobs ", num-ru
54b0: 6e 6e 69 6e 67 3a 20 22 20 6e 75 6d 2d 72 75 6e nning: " num-run
54c0: 6e 69 6e 67 29 0a 20 20 20 20 28 69 66 20 28 6e ning). (if (n
54d0: 6f 74 20 28 65 71 3f 20 30 20 2a 67 6c 6f 62 61 ot (eq? 0 *globa
54e0: 6c 65 78 69 74 73 74 61 74 75 73 2a 29 29 0a 09 lexitstatus*))..
54f0: 23 66 0a 09 28 69 66 20 28 6f 72 20 28 6e 6f 74 #f..(if (or (not
5500: 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d max-concurrent-
5510: 6a 6f 62 73 29 0a 09 09 28 61 6e 64 20 6d 61 78 jobs)...(and max
5520: 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 -concurrent-jobs
5530: 0a 09 09 20 20 20 20 20 28 73 74 72 69 6e 67 2d ... (string-
5540: 3e 6e 75 6d 62 65 72 20 6d 61 78 2d 63 6f 6e 63 >number max-conc
5550: 75 72 72 65 6e 74 2d 6a 6f 62 73 29 0a 09 09 20 urrent-jobs)...
5560: 20 20 20 20 28 6e 6f 74 20 28 3e 3d 20 6e 75 6d (not (>= num
5570: 2d 72 75 6e 6e 69 6e 67 20 28 73 74 72 69 6e 67 -running (string
5580: 2d 3e 6e 75 6d 62 65 72 20 6d 61 78 2d 63 6f 6e ->number max-con
5590: 63 75 72 72 65 6e 74 2d 6a 6f 62 73 29 29 29 29 current-jobs))))
55a0: 29 0a 09 20 20 20 20 23 74 0a 09 20 20 20 20 28 ).. #t.. (
55b0: 62 65 67 69 6e 20 0a 09 20 20 20 20 20 20 28 64 begin .. (d
55c0: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 ebug:print 0 "WA
55d0: 52 4e 49 4e 47 3a 20 4d 61 78 20 72 75 6e 6e 69 RNING: Max runni
55e0: 6e 67 20 6a 6f 62 73 20 65 78 63 65 65 64 65 64 ng jobs exceeded
55f0: 2c 20 63 75 72 72 65 6e 74 20 6e 75 6d 62 65 72 , current number
5600: 20 72 75 6e 6e 69 6e 67 3a 20 22 20 6e 75 6d 2d running: " num-
5610: 72 75 6e 6e 69 6e 67 20 0a 09 09 09 20 20 20 22 running .... "
5620: 2c 20 6d 61 78 5f 63 6f 6e 63 75 72 72 65 6e 74 , max_concurrent
5630: 5f 6a 6f 62 73 3a 20 22 20 6d 61 78 2d 63 6f 6e _jobs: " max-con
5640: 63 75 72 72 65 6e 74 2d 6a 6f 62 73 29 0a 09 20 current-jobs)..
5650: 20 20 20 20 20 23 66 29 29 29 29 29 0a 0a 28 64 #f)))))..(d
5660: 65 66 69 6e 65 20 28 74 65 73 74 3a 67 65 74 2d efine (test:get-
5670: 74 65 73 74 63 6f 6e 66 69 67 20 74 65 73 74 2d testconfig test-
5680: 6e 61 6d 65 20 73 79 73 74 65 6d 2d 61 6c 6c 6f name system-allo
5690: 77 65 64 29 0a 20 20 28 6c 65 74 2a 20 28 28 74 wed). (let* ((t
56a0: 65 73 74 2d 70 61 74 68 20 20 20 20 28 63 6f 6e est-path (con
56b0: 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 74 65 c *toppath* "/te
56c0: 73 74 73 2f 22 20 74 65 73 74 2d 6e 61 6d 65 29 sts/" test-name)
56d0: 29 0a 09 20 28 74 65 73 74 2d 63 6f 6e 66 69 67 ).. (test-config
56e0: 66 20 28 63 6f 6e 63 20 74 65 73 74 2d 70 61 74 f (conc test-pat
56f0: 68 20 22 2f 74 65 73 74 63 6f 6e 66 69 67 22 29 h "/testconfig")
5700: 29 0a 09 20 28 74 65 73 74 65 78 69 73 74 73 20 ).. (testexists
5710: 20 20 28 61 6e 64 20 28 66 69 6c 65 2d 65 78 69 (and (file-exi
5720: 73 74 73 3f 20 74 65 73 74 2d 63 6f 6e 66 69 67 sts? test-config
5730: 66 29 28 66 69 6c 65 2d 72 65 61 64 2d 61 63 63 f)(file-read-acc
5740: 65 73 73 3f 20 74 65 73 74 2d 63 6f 6e 66 69 67 ess? test-config
5750: 66 29 29 29 29 0a 20 20 20 20 28 69 66 20 74 65 f)))). (if te
5760: 73 74 65 78 69 73 74 73 0a 09 28 72 65 61 64 2d stexists..(read-
5770: 63 6f 6e 66 69 67 20 74 65 73 74 2d 63 6f 6e 66 config test-conf
5780: 69 67 66 20 23 66 20 73 79 73 74 65 6d 2d 61 6c igf #f system-al
5790: 6c 6f 77 65 64 20 65 6e 76 69 72 6f 6e 2d 70 61 lowed environ-pa
57a0: 74 74 3a 20 28 69 66 20 73 79 73 74 65 6d 2d 61 tt: (if system-a
57b0: 6c 6c 6f 77 65 64 0a 09 09 09 09 09 09 09 09 20 llowed.........
57c0: 20 20 20 20 20 22 70 72 65 2d 6c 61 75 6e 63 68 "pre-launch
57d0: 2d 65 6e 76 2d 76 61 72 73 22 0a 09 09 09 09 09 -env-vars"......
57e0: 09 09 09 20 20 20 20 20 20 23 66 29 29 0a 09 23 ... #f))..#
57f0: 66 29 29 29 0a 20 20 0a 3b 3b 20 73 6f 72 74 20 f))). .;; sort
5800: 74 65 73 74 73 20 62 79 20 70 72 69 6f 72 69 74 tests by priorit
5810: 79 20 61 6e 64 20 77 61 69 74 6f 6e 0a 3b 3b 20 y and waiton.;;
5820: 4d 6f 76 65 20 74 65 73 74 20 73 70 65 63 69 66 Move test specif
5830: 69 63 20 73 74 75 66 66 20 74 6f 20 61 20 74 65 ic stuff to a te
5840: 73 74 20 75 6e 69 74 20 46 49 58 4d 45 20 6f 6e st unit FIXME on
5850: 65 20 6f 66 20 74 68 65 73 65 20 64 61 79 73 0a e of these days.
5860: 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 73 (define (tests:s
5870: 6f 72 74 2d 62 79 2d 70 72 69 6f 72 69 74 79 2d ort-by-priority-
5880: 61 6e 64 2d 77 61 69 74 6f 6e 20 74 65 73 74 2d and-waiton test-
5890: 6e 61 6d 65 73 29 0a 20 20 28 6c 65 74 20 28 28 names). (let ((
58a0: 74 65 73 74 64 65 74 61 69 6c 73 20 20 20 28 6d testdetails (m
58b0: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
58c0: 0a 09 28 6d 75 6e 67 65 70 72 69 6f 72 69 74 79 ..(mungepriority
58d0: 20 28 6c 61 6d 62 64 61 20 28 70 72 69 6f 72 69 (lambda (priori
58e0: 74 79 29 0a 09 09 09 20 28 69 66 20 70 72 69 6f ty).... (if prio
58f0: 72 69 74 79 0a 09 09 09 20 20 20 20 20 28 6c 65 rity.... (le
5900: 74 20 28 28 74 6d 70 20 28 61 6e 79 2d 3e 6e 75 t ((tmp (any->nu
5910: 6d 62 65 72 20 70 72 69 6f 72 69 74 79 29 29 29 mber priority)))
5920: 0a 09 09 09 20 20 20 20 20 20 20 28 69 66 20 74 .... (if t
5930: 6d 70 20 74 6d 70 20 28 62 65 67 69 6e 20 28 64 mp tmp (begin (d
5940: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 ebug:print 0 "ER
5950: 52 4f 52 3a 20 62 61 64 20 70 72 69 6f 72 69 74 ROR: bad priorit
5960: 79 20 76 61 6c 75 65 20 22 20 70 72 69 6f 72 69 y value " priori
5970: 74 79 20 22 2c 20 75 73 69 6e 67 20 30 22 29 20 ty ", using 0")
5980: 30 29 29 29 0a 09 09 09 20 20 20 20 20 30 29 29 0))).... 0))
5990: 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 )). (for-each
59a0: 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 2d 6e (lambda (test-n
59b0: 61 6d 65 29 0a 09 09 28 6c 65 74 20 28 28 74 65 ame)...(let ((te
59c0: 73 74 2d 63 6f 6e 66 69 67 20 28 74 65 73 74 3a st-config (test:
59d0: 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 74 get-testconfig t
59e0: 65 73 74 2d 6e 61 6d 65 20 23 66 29 29 29 0a 09 est-name #f)))..
59f0: 09 20 20 28 69 66 20 74 65 73 74 2d 63 6f 6e 66 . (if test-conf
5a00: 69 67 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 ig (hash-table-s
5a10: 65 74 21 20 74 65 73 74 64 65 74 61 69 6c 73 20 et! testdetails
5a20: 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 63 test-name test-c
5a30: 6f 6e 66 69 67 29 29 29 29 0a 09 20 20 20 20 20 onfig))))..
5a40: 20 74 65 73 74 2d 6e 61 6d 65 73 29 0a 20 20 20 test-names).
5a50: 20 28 73 6f 72 74 20 0a 20 20 20 20 20 28 68 61 (sort . (ha
5a60: 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 74 65 sh-table-keys te
5a70: 73 74 64 65 74 61 69 6c 73 29 20 3b 3b 20 61 76 stdetails) ;; av
5a80: 6f 69 64 20 64 65 61 6c 69 6e 67 20 77 69 74 68 oid dealing with
5a90: 20 64 65 6c 65 74 65 64 20 74 65 73 74 73 2c 20 deleted tests,
5aa0: 6c 6f 6f 6b 20 61 74 20 74 68 65 20 68 61 73 68 look at the hash
5ab0: 20 74 61 62 6c 65 0a 20 20 20 20 20 28 6c 61 6d table. (lam
5ac0: 62 64 61 20 28 61 20 62 29 0a 20 20 20 20 20 20 bda (a b).
5ad0: 20 28 6c 65 74 2a 20 28 28 74 63 6f 6e 66 2d 61 (let* ((tconf-a
5ae0: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 (hash-table-r
5af0: 65 66 20 74 65 73 74 64 65 74 61 69 6c 73 20 61 ef testdetails a
5b00: 29 29 0a 09 20 20 20 20 20 20 28 74 63 6f 6e 66 )).. (tconf
5b10: 2d 62 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 -b (hash-table
5b20: 2d 72 65 66 20 74 65 73 74 64 65 74 61 69 6c 73 -ref testdetails
5b30: 20 62 29 29 0a 09 20 20 20 20 20 20 28 61 2d 77 b)).. (a-w
5b40: 61 69 74 6f 6e 20 20 20 28 63 6f 6e 66 69 67 2d aiton (config-
5b50: 6c 6f 6f 6b 75 70 20 74 63 6f 6e 66 2d 61 20 22 lookup tconf-a "
5b60: 72 65 71 75 69 72 65 6d 65 6e 74 73 22 20 22 77 requirements" "w
5b70: 61 69 74 6f 6e 22 29 29 0a 09 20 20 20 20 20 20 aiton"))..
5b80: 28 62 2d 77 61 69 74 6f 6e 20 20 20 28 63 6f 6e (b-waiton (con
5b90: 66 69 67 2d 6c 6f 6f 6b 75 70 20 74 63 6f 6e 66 fig-lookup tconf
5ba0: 2d 62 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 -b "requirements
5bb0: 22 20 22 77 61 69 74 6f 6e 22 29 29 0a 09 20 20 " "waiton"))..
5bc0: 20 20 20 20 28 61 2d 70 72 69 6f 72 69 74 79 20 (a-priority
5bd0: 28 6d 75 6e 67 65 70 72 69 6f 72 69 74 79 20 28 (mungepriority (
5be0: 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 74 63 config-lookup tc
5bf0: 6f 6e 66 2d 61 20 22 72 65 71 75 69 72 65 6d 65 onf-a "requireme
5c00: 6e 74 73 22 20 22 70 72 69 6f 72 69 74 79 22 29 nts" "priority")
5c10: 29 29 0a 09 20 20 20 20 20 20 28 62 2d 70 72 69 )).. (b-pri
5c20: 6f 72 69 74 79 20 28 6d 75 6e 67 65 70 72 69 6f ority (mungeprio
5c30: 72 69 74 79 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f rity (config-loo
5c40: 6b 75 70 20 74 63 6f 6e 66 2d 62 20 22 72 65 71 kup tconf-b "req
5c50: 75 69 72 65 6d 65 6e 74 73 22 20 22 70 72 69 6f uirements" "prio
5c60: 72 69 74 79 22 29 29 29 29 0a 09 20 28 69 66 20 rity")))).. (if
5c70: 28 61 6e 64 20 61 2d 77 61 69 74 6f 6e 20 28 65 (and a-waiton (e
5c80: 71 75 61 6c 3f 20 61 2d 77 61 69 74 6f 6e 20 62 qual? a-waiton b
5c90: 29 29 0a 09 20 20 20 20 20 23 66 20 3b 3b 20 63 )).. #f ;; c
5ca0: 61 6e 6e 6f 74 20 68 61 76 65 20 61 20 77 68 69 annot have a whi
5cb0: 63 68 20 69 73 20 77 61 69 74 69 6e 67 20 6f 6e ch is waiting on
5cc0: 20 62 20 68 61 70 70 65 6e 69 6e 67 20 62 65 66 b happening bef
5cd0: 6f 72 65 20 62 0a 09 20 20 20 20 20 28 69 66 20 ore b.. (if
5ce0: 28 61 6e 64 20 62 2d 77 61 69 74 6f 6e 20 28 65 (and b-waiton (e
5cf0: 71 75 61 6c 3f 20 62 2d 77 61 69 74 6f 6e 20 61 qual? b-waiton a
5d00: 29 29 0a 09 09 20 23 74 20 3b 3b 20 74 68 69 73 ))... #t ;; this
5d10: 20 69 73 20 74 68 65 20 63 6f 72 72 65 63 74 20 is the correct
5d20: 6f 72 64 65 72 2c 20 62 20 69 73 20 77 61 69 74 order, b is wait
5d30: 69 6e 67 20 6f 6e 20 61 20 61 6e 64 20 62 20 69 ing on a and b i
5d40: 73 20 62 65 66 6f 72 65 20 61 0a 09 09 20 28 69 s before a... (i
5d50: 66 20 28 3e 20 61 2d 70 72 69 6f 72 69 74 79 20 f (> a-priority
5d60: 62 2d 70 72 69 6f 72 69 74 79 29 0a 09 09 20 20 b-priority)...
5d70: 20 20 20 23 74 20 3b 3b 20 69 66 20 61 20 69 73 #t ;; if a is
5d80: 20 61 20 68 69 67 68 65 72 20 70 72 69 6f 72 69 a higher priori
5d90: 74 79 20 74 68 61 6e 20 62 20 74 68 65 6e 20 77 ty than b then w
5da0: 65 20 61 72 65 20 67 6f 6f 64 20 74 6f 20 67 6f e are good to go
5db0: 0a 09 09 20 20 20 20 20 23 66 29 29 29 29 29 29 ... #f))))))
5dc0: 29 29 0a 0a 3b 3b 20 54 68 69 73 20 69 73 20 6f ))..;; This is o
5dd0: 72 69 67 69 6e 61 6c 20 72 75 6e 2d 74 65 73 74 riginal run-test
5de0: 73 2c 20 74 68 69 73 20 72 6f 75 74 69 6e 65 20 s, this routine
5df0: 69 73 20 64 65 70 72 65 63 61 74 65 64 20 61 6e is deprecated an
5e00: 64 20 77 65 20 77 69 6c 6c 20 74 72 61 6e 73 69 d we will transi
5e10: 74 69 6f 6e 20 74 6f 20 75 73 69 6e 67 20 72 75 tion to using ru
5e20: 6e 73 3a 72 75 6e 2d 74 65 73 74 73 20 28 73 65 ns:run-tests (se
5e30: 65 20 62 65 6c 6f 77 29 0a 3b 3b 0a 28 64 65 66 e below).;;.(def
5e40: 69 6e 65 20 28 72 75 6e 2d 74 65 73 74 73 20 64 ine (run-tests d
5e50: 62 20 74 65 73 74 2d 6e 61 6d 65 73 29 0a 20 20 b test-names).
5e60: 28 6c 65 74 2a 20 28 28 6b 65 79 73 20 20 20 20 (let* ((keys
5e70: 20 20 20 20 28 64 62 2d 67 65 74 2d 6b 65 79 73 (db-get-keys
5e80: 20 64 62 29 29 0a 09 20 28 6b 65 79 76 61 6c 6c db)).. (keyvall
5e90: 73 74 20 20 20 28 6b 65 79 73 2d 3e 76 61 6c 6c st (keys->vall
5ea0: 69 73 74 20 6b 65 79 73 20 23 74 29 29 0a 09 20 ist keys #t))..
5eb0: 28 72 75 6e 2d 69 64 20 20 20 20 20 20 28 72 65 (run-id (re
5ec0: 67 69 73 74 65 72 2d 72 75 6e 20 64 62 20 6b 65 gister-run db ke
5ed0: 79 73 29 29 20 20 3b 3b 20 20 74 65 73 74 2d 6e ys)) ;; test-n
5ee0: 61 6d 65 29 29 29 0a 09 20 28 64 65 66 65 72 72 ame))).. (deferr
5ef0: 65 64 20 20 20 20 27 28 29 29 20 3b 3b 20 64 65 ed '()) ;; de
5f00: 6c 61 79 20 72 75 6e 6e 69 6e 67 20 74 68 65 73 lay running thes
5f10: 65 20 73 69 6e 63 65 20 74 68 65 79 20 68 61 76 e since they hav
5f20: 65 20 61 20 77 61 69 74 6f 6e 20 63 6c 61 75 73 e a waiton claus
5f30: 65 0a 09 20 28 72 75 6e 63 6f 6e 66 69 67 66 20 e.. (runconfigf
5f40: 20 20 28 63 6f 6e 63 20 20 2a 74 6f 70 70 61 74 (conc *toppat
5f50: 68 2a 20 22 2f 72 75 6e 63 6f 6e 66 69 67 73 2e h* "/runconfigs.
5f60: 63 6f 6e 66 69 67 22 29 29 0a 09 20 28 72 65 71 config")).. (req
5f70: 75 69 72 65 64 2d 74 65 73 74 73 20 27 28 29 29 uired-tests '())
5f80: 29 0a 0a 20 20 20 20 3b 3b 20 6e 6f 77 20 61 64 ).. ;; now ad
5f90: 64 20 6e 6f 6e 2d 64 69 72 65 63 74 6c 79 20 72 d non-directly r
5fa0: 65 66 65 72 65 6e 63 65 64 20 64 65 70 65 6e 64 eferenced depend
5fb0: 65 6e 63 69 65 73 20 28 69 2e 65 2e 20 77 61 69 encies (i.e. wai
5fc0: 74 6f 6e 29 0a 20 20 20 20 3b 3b 20 63 6f 75 6c ton). ;; coul
5fd0: 64 20 63 61 63 68 65 20 61 6c 6c 20 74 68 65 73 d cache all thes
5fe0: 65 20 73 69 6e 63 65 20 74 68 65 79 20 6e 65 65 e since they nee
5ff0: 64 20 74 6f 20 62 65 20 72 65 61 64 20 61 67 61 d to be read aga
6000: 69 6e 20 2e 2e 2e 0a 20 20 20 20 3b 3b 20 46 49 in .... ;; FI
6010: 58 4d 45 20 53 4f 4d 45 44 41 59 0a 20 20 20 20 XME SOMEDAY.
6020: 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 (if (not (null?
6030: 74 65 73 74 2d 6e 61 6d 65 73 29 29 0a 09 28 6c test-names))..(l
6040: 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 et loop ((hed (c
6050: 61 72 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 0a ar test-names)).
6060: 09 09 20 20 20 28 74 61 6c 20 28 63 64 72 20 74 .. (tal (cdr t
6070: 65 73 74 2d 6e 61 6d 65 73 29 29 29 0a 09 20 20 est-names)))..
6080: 28 6c 65 74 2a 20 28 28 63 6f 6e 66 69 67 20 20 (let* ((config
6090: 28 74 65 73 74 3a 67 65 74 2d 74 65 73 74 63 6f (test:get-testco
60a0: 6e 66 69 67 20 68 65 64 20 23 66 29 29 0a 09 09 nfig hed #f))...
60b0: 20 28 77 61 69 74 6f 6e 73 20 28 73 74 72 69 6e (waitons (strin
60c0: 67 2d 73 70 6c 69 74 20 28 6c 65 74 20 28 28 77 g-split (let ((w
60d0: 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 (config-lookup
60e0: 63 6f 6e 66 69 67 20 22 72 65 71 75 69 72 65 6d config "requirem
60f0: 65 6e 74 73 22 20 22 77 61 69 74 6f 6e 22 29 29 ents" "waiton"))
6100: 29 0a 09 09 09 09 09 20 20 28 69 66 20 77 20 77 )...... (if w w
6110: 20 22 22 29 29 29 29 29 0a 09 20 20 20 20 28 66 ""))))).. (f
6120: 6f 72 2d 65 61 63 68 20 0a 09 20 20 20 20 20 28 or-each .. (
6130: 6c 61 6d 62 64 61 20 28 77 61 69 74 6f 6e 29 0a lambda (waiton).
6140: 09 20 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 . (if (and
6150: 20 77 61 69 74 6f 6e 20 28 6e 6f 74 20 28 6d 65 waiton (not (me
6160: 6d 62 65 72 20 77 61 69 74 6f 6e 20 74 65 73 74 mber waiton test
6170: 2d 6e 61 6d 65 73 29 29 29 0a 09 09 20 20 20 28 -names)))... (
6180: 62 65 67 69 6e 0a 09 09 20 20 20 20 20 28 73 65 begin... (se
6190: 74 21 20 72 65 71 75 69 72 65 64 2d 74 65 73 74 t! required-test
61a0: 73 20 28 63 6f 6e 73 20 77 61 69 74 6f 6e 20 72 s (cons waiton r
61b0: 65 71 75 69 72 65 64 2d 74 65 73 74 73 29 29 0a equired-tests)).
61c0: 09 09 20 20 20 20 20 28 73 65 74 21 20 74 65 73 .. (set! tes
61d0: 74 2d 6e 61 6d 65 73 20 28 61 70 70 65 6e 64 20 t-names (append
61e0: 74 65 73 74 2d 6e 61 6d 65 73 20 28 6c 69 73 74 test-names (list
61f0: 20 77 61 69 74 6f 6e 29 29 29 29 29 29 0a 09 20 waiton))))))..
6200: 20 20 20 20 77 61 69 74 6f 6e 73 29 0a 09 20 20 waitons)..
6210: 20 20 28 6c 65 74 20 28 28 72 65 6d 74 65 73 74 (let ((remtest
6220: 73 20 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 s (delete-duplic
6230: 61 74 65 73 20 28 61 70 70 65 6e 64 20 77 61 69 ates (append wai
6240: 74 6f 6e 73 20 74 61 6c 29 29 29 29 0a 09 20 20 tons tal))))..
6250: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 (if (not (nu
6260: 6c 6c 3f 20 72 65 6d 74 65 73 74 73 29 29 0a 09 ll? remtests))..
6270: 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 72 65 . (loop (car re
6280: 6d 74 65 73 74 73 29 28 63 64 72 20 72 65 6d 74 mtests)(cdr remt
6290: 65 73 74 73 29 29 29 29 29 29 29 0a 0a 20 20 20 ests)))))))..
62a0: 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f (if (not (null?
62b0: 20 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 29 required-tests)
62c0: 29 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 )..(debug:print
62d0: 31 20 22 49 4e 46 4f 3a 20 41 64 64 69 6e 67 20 1 "INFO: Adding
62e0: 22 20 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 " required-tests
62f0: 20 22 20 74 6f 20 74 68 65 20 72 75 6e 20 71 75 " to the run qu
6300: 65 75 65 22 29 0a 09 28 64 65 62 75 67 3a 70 72 eue")..(debug:pr
6310: 69 6e 74 20 31 20 22 49 4e 46 4f 3a 20 4e 6f 20 int 1 "INFO: No
6320: 70 72 65 72 65 71 75 69 73 69 74 65 73 20 61 64 prerequisites ad
6330: 64 65 64 22 29 29 0a 0a 20 20 20 20 3b 3b 20 6f ded")).. ;; o
6340: 6e 20 74 68 65 20 66 69 72 73 74 20 70 61 73 73 n the first pass
6350: 20 6f 72 20 63 61 6c 6c 20 74 6f 20 72 75 6e 2d or call to run-
6360: 74 65 73 74 73 20 73 65 74 20 46 41 49 4c 53 20 tests set FAILS
6370: 74 6f 20 4e 4f 54 5f 53 54 41 52 54 45 44 20 69 to NOT_STARTED i
6380: 66 0a 20 20 20 20 3b 3b 20 2d 6b 65 65 70 67 6f f. ;; -keepgo
6390: 69 6e 67 20 69 73 20 73 70 65 63 69 66 69 65 64 ing is specified
63a0: 0a 0a 20 20 20 20 28 73 65 74 2d 6d 65 67 61 74 .. (set-megat
63b0: 65 73 74 2d 65 6e 76 2d 76 61 72 73 20 64 62 20 est-env-vars db
63c0: 72 75 6e 2d 69 64 29 20 3b 3b 20 74 68 65 73 65 run-id) ;; these
63d0: 20 6d 61 79 20 62 65 20 6e 65 65 64 65 64 20 62 may be needed b
63e0: 79 20 74 68 65 20 6c 61 75 6e 63 68 69 6e 67 20 y the launching
63f0: 70 72 6f 63 65 73 73 0a 20 20 20 20 0a 20 20 20 process. .
6400: 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 (if (file-exist
6410: 73 3f 20 72 75 6e 63 6f 6e 66 69 67 66 29 0a 09 s? runconfigf)..
6420: 28 73 65 74 75 70 2d 65 6e 76 2d 64 65 66 61 75 (setup-env-defau
6430: 6c 74 73 20 64 62 20 72 75 6e 63 6f 6e 66 69 67 lts db runconfig
6440: 66 20 72 75 6e 2d 69 64 20 2a 61 6c 72 65 61 64 f run-id *alread
6450: 79 2d 73 65 65 6e 2d 72 75 6e 63 6f 6e 66 69 67 y-seen-runconfig
6460: 2d 69 6e 66 6f 2a 20 65 6e 76 69 72 6f 6e 2d 70 -info* environ-p
6470: 61 74 74 3a 20 22 2e 2a 22 29 0a 09 28 64 65 62 att: ".*")..(deb
6480: 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e ug:print 0 "WARN
6490: 49 4e 47 3a 20 59 6f 75 20 64 6f 20 6e 6f 74 20 ING: You do not
64a0: 68 61 76 65 20 61 20 72 75 6e 20 63 6f 6e 66 69 have a run confi
64b0: 67 20 66 69 6c 65 3a 20 22 20 72 75 6e 63 6f 6e g file: " runcon
64c0: 66 69 67 66 29 29 0a 0a 20 20 20 20 28 69 66 20 figf)).. (if
64d0: 28 61 6e 64 20 28 65 71 3f 20 2a 70 61 73 73 6e (and (eq? *passn
64e0: 75 6d 2a 20 30 29 0a 09 20 20 20 20 20 28 61 72 um* 0).. (ar
64f0: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 6b 65 65 gs:get-arg "-kee
6500: 70 67 6f 69 6e 67 22 29 29 0a 09 28 62 65 67 69 pgoing"))..(begi
6510: 6e 0a 09 20 20 3b 3b 20 68 61 76 65 20 74 6f 20 n.. ;; have to
6520: 64 65 6c 65 74 65 20 74 65 73 74 20 72 65 63 6f delete test reco
6530: 72 64 73 20 77 68 65 72 65 20 4e 4f 54 5f 53 54 rds where NOT_ST
6540: 41 52 54 45 44 20 73 69 6e 63 65 20 74 68 65 79 ARTED since they
6550: 20 63 61 6e 20 63 61 75 73 65 20 2d 6b 65 65 70 can cause -keep
6560: 67 6f 69 6e 67 20 74 6f 20 0a 09 20 20 3b 3b 20 going to .. ;;
6570: 67 65 74 20 73 74 75 63 6b 20 64 75 65 20 74 6f get stuck due to
6580: 20 62 65 63 6f 6d 69 6e 67 20 69 6e 61 63 63 65 becoming inacce
6590: 73 73 69 62 6c 65 20 66 72 6f 6d 20 61 20 66 61 ssible from a fa
65a0: 69 6c 65 64 20 74 65 73 74 2e 20 49 2e 65 2e 20 iled test. I.e.
65b0: 69 66 20 74 65 73 74 20 42 20 64 65 70 65 6e 64 if test B depend
65c0: 73 20 0a 09 20 20 3b 3b 20 6f 6e 20 74 65 73 74 s .. ;; on test
65d0: 20 41 20 62 75 74 20 74 65 73 74 20 42 20 72 65 A but test B re
65e0: 61 63 68 65 64 20 74 68 65 20 70 6f 69 6e 74 20 ached the point
65f0: 6f 6e 20 62 65 69 6e 67 20 72 65 67 69 73 74 65 on being registe
6600: 72 65 64 20 61 73 20 4e 4f 54 5f 53 54 41 52 54 red as NOT_START
6610: 45 44 20 61 6e 64 20 74 65 73 74 0a 09 20 20 3b ED and test.. ;
6620: 3b 20 41 20 66 61 69 6c 65 64 20 66 6f 72 20 73 ; A failed for s
6630: 6f 6d 65 20 72 65 61 73 6f 6e 20 74 68 65 6e 20 ome reason then
6640: 6f 6e 20 72 65 2d 72 75 6e 20 75 73 69 6e 67 20 on re-run using
6650: 2d 6b 65 65 70 67 6f 69 6e 67 20 74 68 65 20 72 -keepgoing the r
6660: 75 6e 20 63 61 6e 20 6e 65 76 65 72 20 63 6f 6d un can never com
6670: 70 6c 65 74 65 2e 0a 09 20 20 28 64 62 3a 64 65 plete... (db:de
6680: 6c 65 74 65 2d 74 65 73 74 73 2d 69 6e 2d 73 74 lete-tests-in-st
6690: 61 74 65 20 64 62 20 72 75 6e 2d 69 64 20 22 4e ate db run-id "N
66a0: 4f 54 5f 53 54 41 52 54 45 44 22 29 0a 09 20 20 OT_STARTED")..
66b0: 28 64 62 3a 73 65 74 2d 74 65 73 74 73 2d 73 74 (db:set-tests-st
66c0: 61 74 65 2d 73 74 61 74 75 73 20 64 62 20 72 75 ate-status db ru
66d0: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 73 20 n-id test-names
66e0: 23 66 20 22 46 41 49 4c 22 20 22 4e 4f 54 5f 53 #f "FAIL" "NOT_S
66f0: 54 41 52 54 45 44 22 20 22 46 41 49 4c 22 29 29 TARTED" "FAIL"))
6700: 29 0a 20 20 20 20 28 73 65 74 21 20 2a 70 61 73 ). (set! *pas
6710: 73 6e 75 6d 2a 20 28 2b 20 2a 70 61 73 73 6e 75 snum* (+ *passnu
6720: 6d 2a 20 31 29 29 0a 20 20 20 20 28 6c 65 74 20 m* 1)). (let
6730: 6c 6f 6f 70 20 28 28 6e 75 6d 74 69 6d 65 73 20 loop ((numtimes
6740: 30 29 29 0a 20 20 20 20 20 20 28 66 6f 72 2d 65 0)). (for-e
6750: 61 63 68 20 0a 20 20 20 20 20 20 20 28 6c 61 6d ach . (lam
6760: 62 64 61 20 28 74 65 73 74 2d 6e 61 6d 65 29 0a bda (test-name).
6770: 09 20 28 69 66 20 28 72 75 6e 73 3a 63 61 6e 2d . (if (runs:can-
6780: 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 20 64 run-more-tests d
6790: 62 29 0a 09 20 20 20 20 20 28 72 75 6e 2d 6f 6e b).. (run-on
67a0: 65 2d 74 65 73 74 20 64 62 20 72 75 6e 2d 69 64 e-test db run-id
67b0: 20 74 65 73 74 2d 6e 61 6d 65 20 6b 65 79 76 61 test-name keyva
67c0: 6c 6c 73 74 29 0a 09 20 20 20 20 20 3b 3b 20 61 llst).. ;; a
67d0: 64 64 20 73 6f 6d 65 20 64 65 6c 61 79 20 0a 09 dd some delay ..
67e0: 20 20 20 20 20 3b 28 73 6c 65 65 70 20 32 29 0a ;(sleep 2).
67f0: 09 20 20 20 20 20 29 29 0a 20 20 20 20 20 20 20 . )).
6800: 28 74 65 73 74 73 3a 73 6f 72 74 2d 62 79 2d 70 (tests:sort-by-p
6810: 72 69 6f 72 69 74 79 2d 61 6e 64 2d 77 61 69 74 riority-and-wait
6820: 6f 6e 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 0a on test-names)).
6830: 20 20 20 20 20 20 3b 3b 20 28 72 75 6e 2d 77 61 ;; (run-wa
6840: 69 74 69 6e 67 2d 74 65 73 74 73 20 64 62 29 0a iting-tests db).
6850: 20 20 20 20 20 20 28 69 66 20 28 61 72 67 73 3a (if (args:
6860: 67 65 74 2d 61 72 67 20 22 2d 6b 65 65 70 67 6f get-arg "-keepgo
6870: 69 6e 67 22 29 0a 09 20 20 28 6c 65 74 20 28 28 ing").. (let ((
6880: 65 73 74 72 65 6d 20 28 64 62 3a 65 73 74 69 6d estrem (db:estim
6890: 61 74 65 64 2d 74 65 73 74 73 2d 72 65 6d 61 69 ated-tests-remai
68a0: 6e 69 6e 67 20 64 62 20 72 75 6e 2d 69 64 29 29 ning db run-id))
68b0: 29 0a 09 20 20 20 20 28 69 66 20 28 61 6e 64 20 ).. (if (and
68c0: 28 3e 20 65 73 74 72 65 6d 20 30 29 0a 09 09 20 (> estrem 0)...
68d0: 20 20 20 20 28 65 71 3f 20 2a 67 6c 6f 62 61 6c (eq? *global
68e0: 65 78 69 74 73 74 61 74 75 73 2a 20 30 29 29 0a exitstatus* 0)).
68f0: 09 09 28 62 65 67 69 6e 0a 09 09 20 20 28 64 65 ..(begin... (de
6900: 62 75 67 3a 70 72 69 6e 74 20 31 20 22 4b 65 65 bug:print 1 "Kee
6910: 70 20 67 6f 69 6e 67 2c 20 65 73 74 69 6d 61 74 p going, estimat
6920: 65 64 20 22 20 65 73 74 72 65 6d 20 22 20 74 65 ed " estrem " te
6930: 73 74 73 20 72 65 6d 61 69 6e 69 6e 67 20 74 6f sts remaining to
6940: 20 72 75 6e 2c 20 77 69 6c 6c 20 63 6f 6e 74 69 run, will conti
6950: 6e 75 65 20 69 6e 20 33 20 73 65 63 6f 6e 64 73 nue in 3 seconds
6960: 20 2e 2e 2e 22 29 0a 09 09 20 20 28 74 68 72 65 ...")... (thre
6970: 61 64 2d 73 6c 65 65 70 21 20 33 29 0a 09 09 20 ad-sleep! 3)...
6980: 20 28 72 75 6e 2d 77 61 69 74 69 6e 67 2d 74 65 (run-waiting-te
6990: 73 74 73 20 64 62 29 0a 09 09 20 20 28 6c 6f 6f sts db)... (loo
69a0: 70 20 28 2b 20 6e 75 6d 74 69 6d 65 73 20 31 29 p (+ numtimes 1)
69b0: 29 29 29 29 29 29 29 29 0a 09 20 20 0a 3b 3b 20 )))))))).. .;;
69c0: 56 45 52 59 20 49 4e 45 46 46 49 43 49 45 4e 54 VERY INEFFICIENT
69d0: 21 20 4d 6f 76 65 20 73 74 75 66 66 20 74 68 61 ! Move stuff tha
69e0: 74 20 73 68 6f 75 6c 64 20 62 65 20 64 6f 6e 65 t should be done
69f0: 20 6f 6e 63 65 20 75 70 20 74 6f 20 63 61 6c 6c once up to call
6a00: 69 6e 67 20 70 72 6f 63 0a 28 64 65 66 69 6e 65 ing proc.(define
6a10: 20 28 72 75 6e 2d 6f 6e 65 2d 74 65 73 74 20 64 (run-one-test d
6a20: 62 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 b run-id test-na
6a30: 6d 65 20 6b 65 79 76 61 6c 6c 73 74 29 0a 20 20 me keyvallst).
6a40: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 (debug:print 1 "
6a50: 4c 61 75 6e 63 68 69 6e 67 20 74 65 73 74 20 22 Launching test "
6a60: 20 74 65 73 74 2d 6e 61 6d 65 29 0a 20 20 3b 3b test-name). ;;
6a70: 20 41 6c 6c 20 74 68 65 73 65 20 76 61 72 73 20 All these vars
6a80: 6d 69 67 68 74 20 62 65 20 72 65 66 65 72 65 6e might be referen
6a90: 63 65 64 20 62 79 20 74 68 65 20 74 65 73 74 63 ced by the testc
6aa0: 6f 6e 66 69 67 20 66 69 6c 65 20 72 65 61 64 65 onfig file reade
6ab0: 72 0a 20 20 28 73 65 74 65 6e 76 20 22 4d 54 5f r. (setenv "MT_
6ac0: 54 45 53 54 5f 4e 41 4d 45 22 20 74 65 73 74 2d TEST_NAME" test-
6ad0: 6e 61 6d 65 29 20 3b 3b 20 0a 20 20 28 73 65 74 name) ;; . (set
6ae0: 65 6e 76 20 22 4d 54 5f 52 55 4e 4e 41 4d 45 22 env "MT_RUNNAME"
6af0: 20 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 (args:get-arg
6b00: 20 22 3a 72 75 6e 6e 61 6d 65 22 29 29 0a 0a 20 ":runname"))..
6b10: 20 3b 3b 20 28 73 65 74 2d 6d 65 67 61 74 65 73 ;; (set-megates
6b20: 74 2d 65 6e 76 2d 76 61 72 73 20 64 62 20 72 75 t-env-vars db ru
6b30: 6e 2d 69 64 29 20 3b 3b 20 74 68 65 73 65 20 6d n-id) ;; these m
6b40: 61 79 20 62 65 20 6e 65 65 64 65 64 20 62 79 20 ay be needed by
6b50: 74 68 65 20 6c 61 75 6e 63 68 69 6e 67 20 70 72 the launching pr
6b60: 6f 63 65 73 73 0a 0a 20 20 28 63 68 61 6e 67 65 ocess.. (change
6b70: 2d 64 69 72 65 63 74 6f 72 79 20 2a 74 6f 70 70 -directory *topp
6b80: 61 74 68 2a 29 0a 20 20 28 6c 65 74 2a 20 28 28 ath*). (let* ((
6b90: 74 65 73 74 2d 70 61 74 68 20 20 20 20 28 63 6f test-path (co
6ba0: 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 74 nc *toppath* "/t
6bb0: 65 73 74 73 2f 22 20 74 65 73 74 2d 6e 61 6d 65 ests/" test-name
6bc0: 29 29 20 3b 3b 20 63 6f 75 6c 64 20 75 73 65 20 )) ;; could use
6bd0: 74 65 73 74 3a 67 65 74 2d 74 65 73 74 63 6f 6e test:get-testcon
6be0: 66 69 67 20 68 65 72 65 20 2e 2e 2e 0a 09 20 28 fig here ..... (
6bf0: 74 65 73 74 2d 63 6f 6e 66 69 67 66 20 28 63 6f test-configf (co
6c00: 6e 63 20 74 65 73 74 2d 70 61 74 68 20 22 2f 74 nc test-path "/t
6c10: 65 73 74 63 6f 6e 66 69 67 22 29 29 0a 09 20 28 estconfig")).. (
6c20: 74 65 73 74 65 78 69 73 74 73 20 20 20 28 61 6e testexists (an
6c30: 64 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 d (file-exists?
6c40: 74 65 73 74 2d 63 6f 6e 66 69 67 66 29 28 66 69 test-configf)(fi
6c50: 6c 65 2d 72 65 61 64 2d 61 63 63 65 73 73 3f 20 le-read-access?
6c60: 74 65 73 74 2d 63 6f 6e 66 69 67 66 29 29 29 0a test-configf))).
6c70: 09 20 28 74 65 73 74 2d 63 6f 6e 66 20 20 20 20 . (test-conf
6c80: 28 69 66 20 74 65 73 74 65 78 69 73 74 73 20 28 (if testexists (
6c90: 72 65 61 64 2d 63 6f 6e 66 69 67 20 74 65 73 74 read-config test
6ca0: 2d 63 6f 6e 66 69 67 66 20 23 66 20 23 74 29 20 -configf #f #t)
6cb0: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
6cc0: 29 29 29 0a 09 20 28 77 61 69 74 6f 6e 20 20 20 ))).. (waiton
6cd0: 20 20 20 20 28 6c 65 74 20 28 28 77 20 28 63 6f (let ((w (co
6ce0: 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 74 65 73 74 nfig-lookup test
6cf0: 2d 63 6f 6e 66 20 22 72 65 71 75 69 72 65 6d 65 -conf "requireme
6d00: 6e 74 73 22 20 22 77 61 69 74 6f 6e 22 29 29 29 nts" "waiton")))
6d10: 0a 09 09 09 20 28 69 66 20 28 73 74 72 69 6e 67 .... (if (string
6d20: 3f 20 77 29 28 73 74 72 69 6e 67 2d 73 70 6c 69 ? w)(string-spli
6d30: 74 20 77 29 27 28 29 29 29 29 0a 09 20 28 74 61 t w)'()))).. (ta
6d40: 67 73 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 gs (let
6d50: 28 28 74 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b ((t (config-look
6d60: 75 70 20 74 65 73 74 2d 63 6f 6e 66 20 22 73 65 up test-conf "se
6d70: 74 75 70 22 20 22 74 61 67 73 22 29 29 29 0a 09 tup" "tags")))..
6d80: 09 09 20 3b 3b 20 77 65 20 77 61 6e 74 20 6f 75 .. ;; we want ou
6d90: 72 20 74 61 67 73 20 74 6f 20 62 65 20 73 65 70 r tags to be sep
6da0: 61 72 61 74 65 64 20 62 79 20 63 6f 6d 6d 61 73 arated by commas
6db0: 20 61 6e 64 20 66 75 6c 6c 79 20 64 65 6c 69 6d and fully delim
6dc0: 69 74 65 64 20 62 79 20 63 6f 6d 6d 61 73 0a 09 ited by commas..
6dd0: 09 09 20 3b 3b 20 73 6f 20 74 68 61 74 20 71 75 .. ;; so that qu
6de0: 65 72 69 65 73 20 77 69 74 68 20 22 6c 69 6b 65 eries with "like
6df0: 22 20 63 61 6e 20 74 69 65 20 74 6f 20 74 68 65 " can tie to the
6e00: 20 63 6f 6d 6d 61 73 20 61 74 20 65 69 74 68 65 commas at eithe
6e10: 72 20 65 6e 64 20 6f 66 20 65 61 63 68 20 74 61 r end of each ta
6e20: 67 0a 09 09 09 20 3b 3b 20 77 68 69 6c 65 20 61 g.... ;; while a
6e30: 6c 73 6f 20 61 6c 6c 6f 77 69 6e 67 20 74 68 65 lso allowing the
6e40: 20 65 6e 64 20 75 73 65 72 20 74 6f 20 66 72 65 end user to fre
6e50: 65 6c 79 20 75 73 65 20 73 70 61 63 65 73 20 61 ely use spaces a
6e60: 6e 64 20 63 6f 6d 6d 61 73 20 74 6f 20 73 65 70 nd commas to sep
6e70: 61 72 61 74 65 20 74 61 67 73 0a 09 09 09 20 28 arate tags.... (
6e80: 69 66 20 28 73 74 72 69 6e 67 3f 20 74 29 28 73 if (string? t)(s
6e90: 74 72 69 6e 67 2d 73 75 62 73 74 69 74 75 74 65 tring-substitute
6ea0: 20 28 72 65 67 65 78 70 20 22 5b 2c 5c 5c 73 5d (regexp "[,\\s]
6eb0: 2b 22 29 20 22 2c 22 20 28 63 6f 6e 63 20 22 2c +") "," (conc ",
6ec0: 22 20 74 20 22 2c 22 29 20 23 74 29 0a 09 09 09 " t ",") #t)....
6ed0: 20 20 20 20 20 27 28 29 29 29 29 29 0a 20 20 20 '())))).
6ee0: 20 28 69 66 20 28 6e 6f 74 20 74 65 73 74 65 78 (if (not testex
6ef0: 69 73 74 73 29 0a 09 28 62 65 67 69 6e 0a 09 20 ists)..(begin..
6f00: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
6f10: 22 45 52 52 4f 52 3a 20 43 61 6e 27 74 20 66 69 "ERROR: Can't fi
6f20: 6e 64 20 63 6f 6e 66 69 67 20 66 69 6c 65 20 22 nd config file "
6f30: 20 74 65 73 74 2d 63 6f 6e 66 69 67 66 29 0a 09 test-configf)..
6f40: 20 20 28 65 78 69 74 20 32 29 29 0a 09 3b 3b 20 (exit 2))..;;
6f50: 70 75 74 20 74 6f 70 20 76 61 72 73 20 69 6e 74 put top vars int
6f60: 6f 20 63 6f 6e 76 65 6e 69 65 6e 74 20 76 61 72 o convenient var
6f70: 69 61 62 6c 65 73 20 61 6e 64 20 6f 70 65 6e 20 iables and open
6f80: 74 68 65 20 64 62 0a 09 28 6c 65 74 2a 20 28 3b the db..(let* (;
6f90: 3b 20 64 62 20 69 73 20 61 6c 77 61 79 73 20 61 ; db is always a
6fa0: 74 20 2a 74 6f 70 70 61 74 68 2a 2f 64 62 2f 6d t *toppath*/db/m
6fb0: 65 67 61 74 65 73 74 2e 64 62 0a 09 20 20 20 20 egatest.db..
6fc0: 20 20 20 28 69 74 65 6d 73 20 20 20 20 20 20 20 (items
6fd0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
6fe0: 64 65 66 61 75 6c 74 20 74 65 73 74 2d 63 6f 6e default test-con
6ff0: 66 20 22 69 74 65 6d 73 22 20 27 28 29 29 29 0a f "items" '())).
7000: 09 20 20 20 20 20 20 20 28 69 74 65 6d 73 74 61 . (itemsta
7010: 62 6c 65 20 20 28 68 61 73 68 2d 74 61 62 6c 65 ble (hash-table
7020: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 65 73 -ref/default tes
7030: 74 2d 63 6f 6e 66 20 22 69 74 65 6d 73 74 61 62 t-conf "itemstab
7040: 6c 65 22 20 27 28 29 29 29 0a 09 20 20 20 20 20 le" '()))..
7050: 20 20 28 61 6c 6c 69 74 65 6d 73 20 20 20 20 28 (allitems (
7060: 69 66 20 28 6f 72 20 28 6e 6f 74 20 28 6e 75 6c if (or (not (nul
7070: 6c 3f 20 69 74 65 6d 73 29 29 28 6e 6f 74 20 28 l? items))(not (
7080: 6e 75 6c 6c 3f 20 69 74 65 6d 73 74 61 62 6c 65 null? itemstable
7090: 29 29 29 0a 09 09 09 09 28 61 70 70 65 6e 64 20 ))).....(append
70a0: 28 69 74 65 6d 2d 61 73 73 6f 63 2d 3e 69 74 65 (item-assoc->ite
70b0: 6d 2d 6c 69 73 74 20 69 74 65 6d 73 29 0a 09 09 m-list items)...
70c0: 09 09 09 28 69 74 65 6d 2d 74 61 62 6c 65 2d 3e ...(item-table->
70d0: 69 74 65 6d 2d 6c 69 73 74 20 69 74 65 6d 73 74 item-list itemst
70e0: 61 62 6c 65 29 29 0a 09 09 09 09 27 28 28 29 29 able)).....'(())
70f0: 29 29 29 20 3b 3b 20 61 20 6c 69 73 74 20 77 69 ))) ;; a list wi
7100: 74 68 20 6f 6e 65 20 6e 75 6c 6c 20 6c 69 73 74 th one null list
7110: 20 69 73 20 61 20 74 65 73 74 20 77 69 74 68 20 is a test with
7120: 6e 6f 20 69 74 65 6d 73 0a 3b 3b 20 09 20 20 28 no items.;; . (
7130: 72 75 6e 63 6f 6e 66 69 67 66 20 20 28 63 6f 6e runconfigf (con
7140: 63 20 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 72 c *toppath* "/r
7150: 75 6e 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 69 67 unconfigs.config
7160: 22 29 29 29 0a 09 20 20 28 64 65 62 75 67 3a 70 "))).. (debug:p
7170: 72 69 6e 74 20 31 20 22 69 74 65 6d 73 3a 20 22 rint 1 "items: "
7180: 29 0a 09 20 20 28 69 66 20 28 3e 3d 20 2a 76 65 ).. (if (>= *ve
7190: 72 62 6f 73 69 74 79 2a 20 31 29 28 70 70 20 61 rbosity* 1)(pp a
71a0: 6c 6c 69 74 65 6d 73 29 29 0a 09 20 20 28 69 66 llitems)).. (if
71b0: 20 28 3e 3d 20 2a 76 65 72 62 6f 73 69 74 79 2a (>= *verbosity*
71c0: 20 35 29 0a 09 20 20 20 20 20 20 28 62 65 67 69 5).. (begi
71d0: 6e 0a 09 09 28 70 72 69 6e 74 20 22 69 74 65 6d n...(print "item
71e0: 73 3a 20 22 29 28 70 70 20 28 69 74 65 6d 2d 61 s: ")(pp (item-a
71f0: 73 73 6f 63 2d 3e 69 74 65 6d 2d 6c 69 73 74 20 ssoc->item-list
7200: 69 74 65 6d 73 29 29 0a 09 09 28 70 72 69 6e 74 items))...(print
7210: 20 22 69 74 65 73 74 61 62 6c 65 3a 20 22 29 28 "itestable: ")(
7220: 70 70 20 28 69 74 65 6d 2d 74 61 62 6c 65 2d 3e pp (item-table->
7230: 69 74 65 6d 2d 6c 69 73 74 20 69 74 65 6d 73 74 item-list itemst
7240: 61 62 6c 65 29 29 29 29 0a 09 20 20 28 69 66 20 able)))).. (if
7250: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
7260: 6d 22 29 0a 09 20 20 20 20 20 20 28 64 62 3a 73 m").. (db:s
7270: 65 74 2d 63 6f 6d 6d 65 6e 74 2d 66 6f 72 2d 72 et-comment-for-r
7280: 75 6e 20 64 62 20 72 75 6e 2d 69 64 20 28 61 72 un db run-id (ar
7290: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 6d 22 29 gs:get-arg "-m")
72a0: 29 29 0a 0a 09 20 20 3b 3b 20 48 65 72 65 20 69 ))... ;; Here i
72b0: 73 20 77 68 65 72 65 20 74 68 65 20 74 65 73 74 s where the test
72c0: 5f 6d 65 74 61 20 74 61 62 6c 65 20 69 73 20 62 _meta table is b
72d0: 65 73 74 20 75 70 64 61 74 65 64 0a 09 20 20 28 est updated.. (
72e0: 72 75 6e 73 3a 75 70 64 61 74 65 2d 74 65 73 74 runs:update-test
72f0: 5f 6d 65 74 61 20 64 62 20 74 65 73 74 2d 6e 61 _meta db test-na
7300: 6d 65 20 74 65 73 74 2d 63 6f 6e 66 29 0a 0a 09 me test-conf)...
7310: 20 20 3b 3b 20 62 72 61 69 6e 64 65 61 64 20 77 ;; braindead w
7320: 6f 72 6b 2d 61 72 6f 75 6e 64 20 66 6f 72 20 70 ork-around for p
7330: 6f 6f 72 6c 79 20 73 70 65 63 69 66 69 65 64 20 oorly specified
7340: 61 6c 6c 69 74 65 6d 73 20 6c 69 73 74 20 42 55 allitems list BU
7350: 47 21 21 21 20 46 49 58 4d 45 0a 09 20 20 28 69 G!!! FIXME.. (i
7360: 66 20 28 6e 75 6c 6c 3f 20 61 6c 6c 69 74 65 6d f (null? allitem
7370: 73 29 28 73 65 74 21 20 61 6c 6c 69 74 65 6d 73 s)(set! allitems
7380: 20 27 28 28 29 29 29 29 0a 09 20 20 28 6c 65 74 '(()))).. (let
7390: 20 6c 6f 6f 70 20 28 28 69 74 65 6d 64 61 74 20 loop ((itemdat
73a0: 28 63 61 72 20 61 6c 6c 69 74 65 6d 73 29 29 0a (car allitems)).
73b0: 09 09 20 20 20 20 20 28 74 61 6c 20 20 20 20 20 .. (tal
73c0: 28 63 64 72 20 61 6c 6c 69 74 65 6d 73 29 29 29 (cdr allitems)))
73d0: 0a 09 20 20 20 20 3b 3b 20 28 6c 61 6d 62 64 61 .. ;; (lambda
73e0: 20 28 69 74 65 6d 64 61 74 29 20 3b 3b 3b 20 28 (itemdat) ;;; (
73f0: 28 72 69 70 65 6e 65 73 73 20 22 6f 76 65 72 72 (ripeness "overr
7400: 69 70 65 22 29 20 28 74 65 6d 70 65 72 61 74 75 ipe") (temperatu
7410: 72 65 20 22 63 6f 6f 6c 22 29 20 28 73 65 61 73 re "cool") (seas
7420: 6f 6e 20 22 73 75 6d 6d 65 72 22 29 29 0a 09 20 on "summer"))..
7430: 20 20 20 3b 3b 20 48 61 6e 64 6c 65 20 6c 69 73 ;; Handle lis
7440: 74 73 20 6f 66 20 69 74 65 6d 73 0a 09 20 20 20 ts of items..
7450: 20 28 6c 65 74 2a 20 28 28 69 74 65 6d 2d 70 61 (let* ((item-pa
7460: 74 68 20 20 20 20 20 28 69 74 65 6d 2d 6c 69 73 th (item-lis
7470: 74 2d 3e 70 61 74 68 20 69 74 65 6d 64 61 74 29 t->path itemdat)
7480: 29 20 3b 3b 20 28 73 74 72 69 6e 67 2d 69 6e 74 ) ;; (string-int
7490: 65 72 73 70 65 72 73 65 20 28 6d 61 70 20 63 61 ersperse (map ca
74a0: 64 72 20 69 74 65 6d 64 61 74 29 20 22 2f 22 29 dr itemdat) "/")
74b0: 29 0a 09 09 20 20 20 28 6e 65 77 2d 74 65 73 74 )... (new-test
74c0: 2d 70 61 74 68 20 28 73 74 72 69 6e 67 2d 69 6e -path (string-in
74d0: 74 65 72 73 70 65 72 73 65 20 28 63 6f 6e 73 20 tersperse (cons
74e0: 74 65 73 74 2d 70 61 74 68 20 28 6d 61 70 20 63 test-path (map c
74f0: 61 64 72 20 69 74 65 6d 64 61 74 29 29 20 22 2f adr itemdat)) "/
7500: 22 29 29 0a 09 09 20 20 20 28 6e 65 77 2d 74 65 "))... (new-te
7510: 73 74 2d 6e 61 6d 65 20 28 69 66 20 28 65 71 75 st-name (if (equ
7520: 61 6c 3f 20 69 74 65 6d 2d 70 61 74 68 20 22 22 al? item-path ""
7530: 29 20 74 65 73 74 2d 6e 61 6d 65 20 28 63 6f 6e ) test-name (con
7540: 63 20 74 65 73 74 2d 6e 61 6d 65 20 22 2f 22 20 c test-name "/"
7550: 69 74 65 6d 2d 70 61 74 68 29 29 29 20 3b 3b 20 item-path))) ;;
7560: 6a 75 73 74 20 6e 65 65 64 20 69 74 20 74 6f 20 just need it to
7570: 62 65 20 75 6e 69 71 75 65 0a 09 09 20 20 20 28 be unique... (
7580: 74 65 73 74 64 61 74 20 20 20 23 66 29 0a 09 09 testdat #f)...
7590: 20 20 20 28 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 (num-running
75a0: 28 64 62 3a 67 65 74 2d 63 6f 75 6e 74 2d 74 65 (db:get-count-te
75b0: 73 74 73 2d 72 75 6e 6e 69 6e 67 20 64 62 29 29 sts-running db))
75c0: 0a 09 09 20 20 20 28 6d 61 78 2d 63 6f 6e 63 75 ... (max-concu
75d0: 72 72 65 6e 74 2d 6a 6f 62 73 20 28 63 6f 6e 66 rrent-jobs (conf
75e0: 69 67 2d 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 ig-lookup *confi
75f0: 67 64 61 74 2a 20 22 73 65 74 75 70 22 20 22 6d gdat* "setup" "m
7600: 61 78 5f 63 6f 6e 63 75 72 72 65 6e 74 5f 6a 6f ax_concurrent_jo
7610: 62 73 22 29 29 0a 09 09 20 20 20 28 70 61 72 65 bs"))... (pare
7620: 6e 74 2d 74 65 73 74 20 28 61 6e 64 20 28 6e 6f nt-test (and (no
7630: 74 20 28 6e 75 6c 6c 3f 20 69 74 65 6d 73 29 29 t (null? items))
7640: 28 65 71 75 61 6c 3f 20 69 74 65 6d 2d 70 61 74 (equal? item-pat
7650: 68 20 22 22 29 29 29 0a 09 09 20 20 20 28 73 69 h "")))... (si
7660: 6e 67 6c 65 2d 74 65 73 74 20 28 61 6e 64 20 28 ngle-test (and (
7670: 6e 75 6c 6c 3f 20 69 74 65 6d 73 29 20 28 65 71 null? items) (eq
7680: 75 61 6c 3f 20 69 74 65 6d 2d 70 61 74 68 20 22 ual? item-path "
7690: 22 29 29 29 0a 09 09 20 20 20 28 69 74 65 6d 2d ")))... (item-
76a0: 74 65 73 74 20 20 20 28 6e 6f 74 20 28 65 71 75 test (not (equ
76b0: 61 6c 3f 20 69 74 65 6d 2d 70 61 74 68 20 22 22 al? item-path ""
76c0: 29 29 29 0a 09 09 20 20 20 28 69 74 65 6d 2d 70 )))... (item-p
76d0: 61 74 74 20 20 20 28 61 72 67 73 3a 67 65 74 2d att (args:get-
76e0: 61 72 67 20 22 2d 69 74 65 6d 70 61 74 74 22 29 arg "-itempatt")
76f0: 29 0a 09 09 20 20 20 28 70 61 74 74 2d 6d 61 74 )... (patt-mat
7700: 63 68 20 20 28 69 66 20 69 74 65 6d 2d 70 61 74 ch (if item-pat
7710: 74 0a 09 09 09 09 20 20 20 20 28 73 74 72 69 6e t..... (strin
7720: 67 2d 73 65 61 72 63 68 20 28 67 6c 6f 62 2d 3e g-search (glob->
7730: 72 65 67 65 78 70 0a 09 09 09 09 09 09 20 20 20 regexp.......
7740: 28 73 74 72 69 6e 67 2d 74 72 61 6e 73 6c 61 74 (string-translat
7750: 65 20 69 74 65 6d 2d 70 61 74 74 20 22 25 22 20 e item-patt "%"
7760: 22 2a 22 29 29 0a 09 09 09 09 09 09 20 20 69 74 "*"))....... it
7770: 65 6d 2d 70 61 74 68 29 0a 09 09 09 09 20 20 20 em-path).....
7780: 20 23 74 29 29 29 0a 09 20 20 20 20 20 20 28 64 #t))).. (d
7790: 65 62 75 67 3a 70 72 69 6e 74 20 33 20 22 6d 61 ebug:print 3 "ma
77a0: 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 x-concurrent-job
77b0: 73 3a 20 22 20 6d 61 78 2d 63 6f 6e 63 75 72 72 s: " max-concurr
77c0: 65 6e 74 2d 6a 6f 62 73 20 22 2c 20 6e 75 6d 2d ent-jobs ", num-
77d0: 72 75 6e 6e 69 6e 67 3a 20 22 20 6e 75 6d 2d 72 running: " num-r
77e0: 75 6e 6e 69 6e 67 29 0a 09 20 20 20 20 20 20 28 unning).. (
77f0: 69 66 20 28 61 6e 64 20 70 61 74 74 2d 6d 61 74 if (and patt-mat
7800: 63 68 20 28 72 75 6e 73 3a 63 61 6e 2d 72 75 6e ch (runs:can-run
7810: 2d 6d 6f 72 65 2d 74 65 73 74 73 20 64 62 29 29 -more-tests db))
7820: 0a 09 09 20 20 28 62 65 67 69 6e 0a 09 09 20 20 ... (begin...
7830: 20 20 28 6c 65 74 20 6c 6f 6f 70 32 20 28 28 74 (let loop2 ((t
7840: 73 20 28 64 62 3a 67 65 74 2d 74 65 73 74 2d 69 s (db:get-test-i
7850: 6e 66 6f 20 64 62 20 72 75 6e 2d 69 64 20 74 65 nfo db run-id te
7860: 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 st-name item-pat
7870: 68 29 29 20 3b 3b 20 23 66 29 0a 09 09 09 09 28 h)) ;; #f).....(
7880: 63 74 20 30 29 29 0a 09 09 20 20 20 20 20 20 28 ct 0))... (
7890: 69 66 20 28 61 6e 64 20 28 6e 6f 74 20 74 73 29 if (and (not ts)
78a0: 0a 09 09 09 20 20 20 20 20 20 20 28 3c 20 63 74 .... (< ct
78b0: 20 31 30 29 29 0a 09 09 09 20 20 28 62 65 67 69 10)).... (begi
78c0: 6e 0a 09 09 09 20 20 20 20 28 72 65 67 69 73 74 n.... (regist
78d0: 65 72 2d 74 65 73 74 20 64 62 20 72 75 6e 2d 69 er-test db run-i
78e0: 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d d test-name item
78f0: 2d 70 61 74 68 29 0a 09 09 09 20 20 20 20 28 64 -path).... (d
7900: 62 3a 74 65 73 74 2d 73 65 74 2d 63 6f 6d 6d 65 b:test-set-comme
7910: 6e 74 20 64 62 20 72 75 6e 2d 69 64 20 74 65 73 nt db run-id tes
7920: 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 t-name item-path
7930: 20 22 22 29 0a 09 09 09 20 20 20 20 28 6c 6f 6f "").... (loo
7940: 70 32 20 28 64 62 3a 67 65 74 2d 74 65 73 74 2d p2 (db:get-test-
7950: 69 6e 66 6f 20 64 62 20 72 75 6e 2d 69 64 20 74 info db run-id t
7960: 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 est-name item-pa
7970: 74 68 29 0a 09 09 09 09 20 20 20 28 2b 20 63 74 th)..... (+ ct
7980: 20 31 29 29 29 0a 09 09 09 20 20 28 69 66 20 74 1))).... (if t
7990: 73 0a 09 09 09 20 20 20 20 20 20 28 73 65 74 21 s.... (set!
79a0: 20 74 65 73 74 64 61 74 20 74 73 29 0a 09 09 09 testdat ts)....
79b0: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 (begin....
79c0: 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 .(debug:print 0
79d0: 22 57 41 52 4e 49 4e 47 3a 20 43 6f 75 6c 64 6e "WARNING: Couldn
79e0: 27 74 20 72 65 67 69 73 74 65 72 20 74 65 73 74 't register test
79f0: 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 77 " test-name " w
7a00: 69 74 68 20 69 74 65 6d 20 70 61 74 68 20 22 20 ith item path "
7a10: 69 74 65 6d 2d 70 61 74 68 20 22 2c 20 73 6b 69 item-path ", ski
7a20: 70 70 69 6e 67 22 29 0a 09 09 09 09 28 69 66 20 pping").....(if
7a30: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 (not (null? tal)
7a40: 29 0a 09 09 09 09 20 20 20 20 28 6c 6f 6f 70 20 )..... (loop
7a50: 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 (car tal)(cdr ta
7a60: 6c 29 29 29 29 29 29 29 0a 09 09 20 20 20 20 28 l)))))))... (
7a70: 63 68 61 6e 67 65 2d 64 69 72 65 63 74 6f 72 79 change-directory
7a80: 20 74 65 73 74 2d 70 61 74 68 29 0a 09 09 20 20 test-path)...
7a90: 20 20 3b 3b 20 74 68 69 73 20 62 6c 6f 63 6b 20 ;; this block
7aa0: 69 73 20 68 65 72 65 20 6f 6e 6c 79 20 74 6f 20 is here only to
7ab0: 69 6e 66 6f 72 6d 20 74 68 65 20 75 73 65 72 20 inform the user
7ac0: 65 61 72 6c 79 20 6f 6e 0a 09 09 20 20 20 20 0a early on... .
7ad0: 09 09 20 20 20 20 3b 3b 20 4e 42 2f 2f 20 4d 6f .. ;; NB// Mo
7ae0: 76 69 6e 67 20 74 68 65 20 73 65 74 74 69 6e 67 ving the setting
7af0: 20 6f 66 20 72 75 6e 63 6f 6e 66 69 67 2e 63 6f of runconfig.co
7b00: 6e 66 69 67 20 76 61 72 73 20 74 6f 20 2a 62 65 nfig vars to *be
7b10: 66 6f 72 65 2a 20 74 68 65 20 0a 09 09 20 20 20 fore* the ...
7b20: 20 3b 3b 20 74 68 65 20 63 61 6c 6c 69 6e 67 20 ;; the calling
7b30: 6f 66 20 65 61 63 68 20 74 65 73 74 2e 0a 09 09 of each test....
7b40: 20 20 20 20 3b 3b 20 28 69 66 20 28 66 69 6c 65 ;; (if (file
7b50: 2d 65 78 69 73 74 73 3f 20 72 75 6e 63 6f 6e 66 -exists? runconf
7b60: 69 67 66 29 0a 09 09 20 20 20 20 3b 3b 20 20 20 igf)... ;;
7b70: 20 20 28 73 65 74 75 70 2d 65 6e 76 2d 64 65 66 (setup-env-def
7b80: 61 75 6c 74 73 20 64 62 20 72 75 6e 63 6f 6e 66 aults db runconf
7b90: 69 67 66 20 72 75 6e 2d 69 64 20 2a 61 6c 72 65 igf run-id *alre
7ba0: 61 64 79 2d 73 65 65 6e 2d 72 75 6e 63 6f 6e 66 ady-seen-runconf
7bb0: 69 67 2d 69 6e 66 6f 2a 29 0a 09 09 20 20 20 20 ig-info*)...
7bc0: 3b 3b 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 ;; (debug:pr
7bd0: 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 int 0 "WARNING:
7be0: 59 6f 75 20 64 6f 20 6e 6f 74 20 68 61 76 65 20 You do not have
7bf0: 61 20 72 75 6e 20 63 6f 6e 66 69 67 20 66 69 6c a run config fil
7c00: 65 3a 20 22 20 72 75 6e 63 6f 6e 66 69 67 66 29 e: " runconfigf)
7c10: 29 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 )... (debug:p
7c20: 72 69 6e 74 20 34 20 22 72 75 6e 2d 69 64 3a 20 rint 4 "run-id:
7c30: 22 20 72 75 6e 2d 69 64 20 22 20 74 65 73 74 2d " run-id " test-
7c40: 6e 61 6d 65 3a 20 22 20 74 65 73 74 2d 6e 61 6d name: " test-nam
7c50: 65 20 22 20 69 74 65 6d 2d 70 61 74 68 3a 20 22 e " item-path: "
7c60: 20 69 74 65 6d 2d 70 61 74 68 20 22 20 74 65 73 item-path " tes
7c70: 74 64 61 74 3a 20 22 20 28 74 65 73 74 3a 67 65 tdat: " (test:ge
7c80: 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 74 t-status testdat
7c90: 29 20 22 20 74 65 73 74 2d 73 74 61 74 65 3a 20 ) " test-state:
7ca0: 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 " (test:get-stat
7cb0: 65 20 74 65 73 74 64 61 74 29 29 0a 09 09 20 20 e testdat))...
7cc0: 20 20 28 63 61 73 65 20 28 69 66 20 28 61 72 67 (case (if (arg
7cd0: 73 3a 67 65 74 2d 61 72 67 20 22 2d 66 6f 72 63 s:get-arg "-forc
7ce0: 65 22 29 0a 09 09 09 20 20 20 20 20 20 27 4e 4f e").... 'NO
7cf0: 54 5f 53 54 41 52 54 45 44 0a 09 09 09 20 20 20 T_STARTED....
7d00: 20 20 20 28 69 66 20 74 65 73 74 64 61 74 0a 09 (if testdat..
7d10: 09 09 09 20 20 28 73 74 72 69 6e 67 2d 3e 73 79 ... (string->sy
7d20: 6d 62 6f 6c 20 28 74 65 73 74 3a 67 65 74 2d 73 mbol (test:get-s
7d30: 74 61 74 65 20 74 65 73 74 64 61 74 29 29 0a 09 tate testdat))..
7d40: 09 09 09 20 20 27 66 61 69 6c 65 64 2d 74 6f 2d ... 'failed-to-
7d50: 69 6e 73 65 72 74 29 29 0a 09 09 20 20 20 20 20 insert))...
7d60: 20 28 28 66 61 69 6c 65 64 2d 74 6f 2d 69 6e 73 ((failed-to-ins
7d70: 65 72 74 29 0a 09 09 20 20 20 20 20 20 20 28 64 ert)... (d
7d80: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 ebug:print 0 "ER
7d90: 52 4f 52 3a 20 46 61 69 6c 65 64 20 74 6f 20 69 ROR: Failed to i
7da0: 6e 73 65 72 74 20 74 68 65 20 72 65 63 6f 72 64 nsert the record
7db0: 20 69 6e 74 6f 20 74 68 65 20 64 62 22 29 29 0a into the db")).
7dc0: 09 09 20 20 20 20 20 20 28 28 4e 4f 54 5f 53 54 .. ((NOT_ST
7dd0: 41 52 54 45 44 20 43 4f 4d 50 4c 45 54 45 44 29 ARTED COMPLETED)
7de0: 0a 09 09 20 20 20 20 20 20 20 28 64 65 62 75 67 ... (debug
7df0: 3a 70 72 69 6e 74 20 36 20 22 47 6f 74 20 68 65 :print 6 "Got he
7e00: 72 65 2c 20 22 20 28 74 65 73 74 3a 67 65 74 2d re, " (test:get-
7e10: 73 74 61 74 65 20 74 65 73 74 64 61 74 29 29 0a state testdat)).
7e20: 09 09 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 .. (let ((
7e30: 72 75 6e 66 6c 61 67 20 23 66 29 29 0a 09 09 09 runflag #f))....
7e40: 20 28 63 6f 6e 64 0a 09 09 09 20 20 3b 3b 20 69 (cond.... ;; i
7e50: 2e 65 2e 20 74 68 69 73 20 69 73 20 74 68 65 20 .e. this is the
7e60: 70 61 72 65 6e 74 20 74 65 73 74 20 74 6f 20 61 parent test to a
7e70: 20 73 75 69 74 65 20 6f 66 20 69 74 65 6d 73 2c suite of items,
7e80: 20 6e 65 76 65 72 20 22 72 75 6e 22 20 69 74 0a never "run" it.
7e90: 09 09 09 20 20 28 70 61 72 65 6e 74 2d 74 65 73 ... (parent-tes
7ea0: 74 0a 09 09 09 20 20 20 28 73 65 74 21 20 72 75 t.... (set! ru
7eb0: 6e 66 6c 61 67 20 23 66 29 29 0a 09 09 09 20 20 nflag #f))....
7ec0: 3b 3b 20 2d 66 6f 72 63 65 2c 20 72 75 6e 20 6e ;; -force, run n
7ed0: 6f 20 6d 61 74 74 65 72 20 77 68 61 74 0a 09 09 o matter what...
7ee0: 09 20 20 28 28 61 72 67 73 3a 67 65 74 2d 61 72 . ((args:get-ar
7ef0: 67 20 22 2d 66 6f 72 63 65 22 29 28 73 65 74 21 g "-force")(set!
7f00: 20 72 75 6e 66 6c 61 67 20 23 74 29 29 0a 09 09 runflag #t))...
7f10: 09 20 20 3b 3b 20 4e 4f 54 5f 53 54 41 52 54 45 . ;; NOT_STARTE
7f20: 44 2c 20 72 75 6e 20 6e 6f 20 6d 61 74 74 65 72 D, run no matter
7f30: 20 77 68 61 74 0a 09 09 09 20 20 28 28 65 71 75 what.... ((equ
7f40: 61 6c 3f 20 28 74 65 73 74 3a 67 65 74 2d 73 74 al? (test:get-st
7f50: 61 74 65 20 74 65 73 74 64 61 74 29 20 22 4e 4f ate testdat) "NO
7f60: 54 5f 53 54 41 52 54 45 44 22 29 28 73 65 74 21 T_STARTED")(set!
7f70: 20 72 75 6e 66 6c 61 67 20 23 74 29 29 0a 09 09 runflag #t))...
7f80: 09 20 20 3b 3b 20 6e 6f 74 20 2d 72 65 72 75 6e . ;; not -rerun
7f90: 20 61 6e 64 20 50 41 53 53 2c 20 57 41 52 4e 20 and PASS, WARN
7fa0: 6f 72 20 43 48 45 43 4b 2c 20 64 6f 20 6e 6f 20 or CHECK, do no
7fb0: 72 75 6e 0a 09 09 09 20 20 28 28 61 6e 64 20 28 run.... ((and (
7fc0: 6f 72 20 28 6e 6f 74 20 28 61 72 67 73 3a 67 65 or (not (args:ge
7fd0: 74 2d 61 72 67 20 22 2d 72 65 72 75 6e 22 29 29 t-arg "-rerun"))
7fe0: 0a 09 09 09 09 20 20 20 20 28 61 72 67 73 3a 67 ..... (args:g
7ff0: 65 74 2d 61 72 67 20 22 2d 6b 65 65 70 67 6f 69 et-arg "-keepgoi
8000: 6e 67 22 29 29 0a 09 09 09 09 28 6d 65 6d 62 65 ng")).....(membe
8010: 72 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 r (test:get-stat
8020: 75 73 20 74 65 73 74 64 61 74 29 20 27 28 22 50 us testdat) '("P
8030: 41 53 53 22 20 22 57 41 52 4e 22 20 22 43 48 45 ASS" "WARN" "CHE
8040: 43 4b 22 29 29 29 0a 09 09 09 20 20 20 28 73 65 CK"))).... (se
8050: 74 21 20 72 75 6e 66 6c 61 67 20 23 66 29 29 0a t! runflag #f)).
8060: 09 09 09 20 20 3b 3b 20 2d 72 65 72 75 6e 20 61 ... ;; -rerun a
8070: 6e 64 20 73 74 61 74 75 73 20 69 73 20 6f 6e 65 nd status is one
8080: 20 6f 66 20 74 68 65 20 73 70 65 63 69 66 65 64 of the specifed
8090: 2c 20 72 75 6e 20 69 74 0a 09 09 09 20 20 28 28 , run it.... ((
80a0: 61 6e 64 20 28 61 72 67 73 3a 67 65 74 2d 61 72 and (args:get-ar
80b0: 67 20 22 2d 72 65 72 75 6e 22 29 0a 09 09 09 09 g "-rerun").....
80c0: 28 6c 65 74 20 28 28 72 65 72 75 6e 6c 73 74 20 (let ((rerunlst
80d0: 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 28 61 (string-split (a
80e0: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 rgs:get-arg "-re
80f0: 72 75 6e 22 29 20 22 2c 22 29 29 29 20 3b 3b 20 run") ","))) ;;
8100: 46 41 49 4c 2c 0a 09 09 09 09 20 20 28 6d 65 6d FAIL,..... (mem
8110: 62 65 72 20 28 74 65 73 74 3a 67 65 74 2d 73 74 ber (test:get-st
8120: 61 74 75 73 20 74 65 73 74 64 61 74 29 20 72 65 atus testdat) re
8130: 72 75 6e 6c 73 74 29 29 29 0a 09 09 09 20 20 20 runlst)))....
8140: 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 74 (set! runflag #t
8150: 29 29 0a 09 09 09 20 20 3b 3b 20 2d 6b 65 65 70 )).... ;; -keep
8160: 67 6f 69 6e 67 2c 20 64 6f 20 6e 6f 74 20 72 65 going, do not re
8170: 72 75 6e 20 46 41 49 4c 0a 09 09 09 20 20 28 28 run FAIL.... ((
8180: 61 6e 64 20 28 61 72 67 73 3a 67 65 74 2d 61 72 and (args:get-ar
8190: 67 20 22 2d 6b 65 65 70 67 6f 69 6e 67 22 29 0a g "-keepgoing").
81a0: 09 09 09 09 28 6d 65 6d 62 65 72 20 28 74 65 73 ....(member (tes
81b0: 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 t:get-status tes
81c0: 74 64 61 74 29 20 27 28 22 46 41 49 4c 22 29 29 tdat) '("FAIL"))
81d0: 29 0a 09 09 09 20 20 20 28 73 65 74 21 20 72 75 ).... (set! ru
81e0: 6e 66 6c 61 67 20 23 66 29 29 0a 09 09 09 20 20 nflag #f))....
81f0: 28 28 61 6e 64 20 28 6e 6f 74 20 28 61 72 67 73 ((and (not (args
8200: 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 72 75 6e :get-arg "-rerun
8210: 22 29 29 0a 09 09 09 09 28 6d 65 6d 62 65 72 20 ")).....(member
8220: 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 75 73 (test:get-status
8230: 20 74 65 73 74 64 61 74 29 20 27 28 22 46 41 49 testdat) '("FAI
8240: 4c 22 20 22 6e 2f 61 22 29 29 29 0a 09 09 09 20 L" "n/a")))....
8250: 20 20 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 (set! runflag
8260: 23 74 29 29 0a 09 09 09 20 20 28 65 6c 73 65 20 #t)).... (else
8270: 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 66 (set! runflag #f
8280: 29 29 29 0a 09 09 09 20 28 64 65 62 75 67 3a 70 ))).... (debug:p
8290: 72 69 6e 74 20 36 20 22 52 55 4e 4e 49 4e 47 20 rint 6 "RUNNING
82a0: 3d 3e 20 72 75 6e 66 6c 61 67 3a 20 22 20 72 75 => runflag: " ru
82b0: 6e 66 6c 61 67 20 22 20 53 54 41 54 45 3a 20 22 nflag " STATE: "
82c0: 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 (test:get-state
82d0: 20 74 65 73 74 64 61 74 29 20 22 20 53 54 41 54 testdat) " STAT
82e0: 55 53 3a 20 22 20 28 74 65 73 74 3a 67 65 74 2d US: " (test:get-
82f0: 73 74 61 74 75 73 20 74 65 73 74 64 61 74 29 29 status testdat))
8300: 0a 09 09 09 20 28 69 66 20 28 6e 6f 74 20 72 75 .... (if (not ru
8310: 6e 66 6c 61 67 29 0a 09 09 09 20 20 20 20 20 28 nflag).... (
8320: 69 66 20 28 6e 6f 74 20 70 61 72 65 6e 74 2d 74 if (not parent-t
8330: 65 73 74 29 0a 09 09 09 09 20 28 64 65 62 75 67 est)..... (debug
8340: 3a 70 72 69 6e 74 20 31 20 22 4e 4f 54 45 3a 20 :print 1 "NOTE:
8350: 4e 6f 74 20 73 74 61 72 74 69 6e 67 20 74 65 73 Not starting tes
8360: 74 20 22 20 6e 65 77 2d 74 65 73 74 2d 6e 61 6d t " new-test-nam
8370: 65 20 22 20 61 73 20 69 74 20 69 73 20 73 74 61 e " as it is sta
8380: 74 65 20 5c 22 43 4f 4d 50 4c 45 54 45 44 5c 22 te \"COMPLETED\"
8390: 20 61 6e 64 20 73 74 61 74 75 73 20 5c 22 22 20 and status \""
83a0: 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 75 73 (test:get-status
83b0: 20 74 65 73 74 64 61 74 29 20 22 5c 22 2c 20 75 testdat) "\", u
83c0: 73 65 20 2d 66 6f 72 63 65 20 74 6f 20 6f 76 65 se -force to ove
83d0: 72 72 69 64 65 22 29 29 0a 09 09 09 20 20 20 20 rride"))....
83e0: 20 28 6c 65 74 2a 20 28 28 67 65 74 2d 70 72 65 (let* ((get-pre
83f0: 72 65 71 73 2d 63 6d 64 20 28 6c 61 6d 62 64 61 reqs-cmd (lambda
8400: 20 28 29 0a 09 09 09 09 09 09 20 20 20 20 20 20 ().......
8410: 20 28 64 62 2d 67 65 74 2d 70 72 65 72 65 71 73 (db-get-prereqs
8420: 2d 6e 6f 74 2d 6d 65 74 20 64 62 20 72 75 6e 2d -not-met db run-
8430: 69 64 20 77 61 69 74 6f 6e 29 29 29 20 3b 3b 20 id waiton))) ;;
8440: 63 68 65 63 6b 20 62 65 66 6f 72 65 20 72 75 6e check before run
8450: 6e 69 6e 67 20 2e 2e 2e 2e 0a 09 09 09 09 20 20 ning .........
8460: 20 20 28 6c 61 75 6e 63 68 2d 63 6d 64 20 20 20 (launch-cmd
8470: 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 (lambda ()...
8480: 09 09 09 09 20 20 20 20 20 20 20 28 6c 61 75 6e .... (laun
8490: 63 68 2d 74 65 73 74 20 64 62 20 72 75 6e 2d 69 ch-test db run-i
84a0: 64 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 d (args:get-arg
84b0: 22 3a 72 75 6e 6e 61 6d 65 22 29 20 74 65 73 74 ":runname") test
84c0: 2d 63 6f 6e 66 20 6b 65 79 76 61 6c 6c 73 74 20 -conf keyvallst
84d0: 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 70 test-name test-p
84e0: 61 74 68 20 69 74 65 6d 64 61 74 20 61 72 67 73 ath itemdat args
84f0: 3a 61 72 67 2d 68 61 73 68 29 29 29 0a 09 09 09 :arg-hash)))....
8500: 09 20 20 20 20 28 74 65 73 74 72 75 6e 64 61 74 . (testrundat
8510: 20 20 20 20 20 20 28 6c 69 73 74 20 67 65 74 2d (list get-
8520: 70 72 65 72 65 71 73 2d 63 6d 64 20 6c 61 75 6e prereqs-cmd laun
8530: 63 68 2d 63 6d 64 29 29 29 0a 09 09 09 20 20 20 ch-cmd)))....
8540: 20 20 20 20 28 69 66 20 28 6f 72 20 28 61 72 67 (if (or (arg
8550: 73 3a 67 65 74 2d 61 72 67 20 22 2d 66 6f 72 63 s:get-arg "-forc
8560: 65 22 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 e")..... (
8570: 6c 65 74 20 28 28 70 72 65 71 73 2d 6e 6f 74 2d let ((preqs-not-
8580: 79 65 74 2d 6d 65 74 20 28 28 63 61 72 20 74 65 yet-met ((car te
8590: 73 74 72 75 6e 64 61 74 29 29 29 29 0a 09 09 09 strundat))))....
85a0: 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 .. (debug:print
85b0: 32 20 22 50 72 65 71 72 65 71 75 65 73 69 74 65 2 "Preqrequesite
85c0: 73 20 66 6f 72 20 22 20 74 65 73 74 2d 6e 61 6d s for " test-nam
85d0: 65 20 22 3a 20 22 20 70 72 65 71 73 2d 6e 6f 74 e ": " preqs-not
85e0: 2d 79 65 74 2d 6d 65 74 29 0a 09 09 09 09 09 20 -yet-met)......
85f0: 28 6e 75 6c 6c 3f 20 70 72 65 71 73 2d 6e 6f 74 (null? preqs-not
8600: 2d 79 65 74 2d 6d 65 74 29 29 29 20 3b 3b 20 61 -yet-met))) ;; a
8610: 72 65 20 74 68 65 72 65 20 61 6e 79 20 74 65 73 re there any tes
8620: 74 73 20 74 68 61 74 20 6d 75 73 74 20 62 65 20 ts that must be
8630: 72 75 6e 20 62 65 66 6f 72 65 20 74 68 69 73 20 run before this
8640: 6f 6e 65 2e 2e 2e 0a 09 09 09 09 20 20 20 28 69 one........ (i
8650: 66 20 28 6e 6f 74 20 28 28 63 61 64 72 20 74 65 f (not ((cadr te
8660: 73 74 72 75 6e 64 61 74 29 29 29 20 3b 3b 20 74 strundat))) ;; t
8670: 68 69 73 20 69 73 20 74 68 65 20 6c 69 6e 65 20 his is the line
8680: 74 68 61 74 20 6c 61 75 6e 63 68 65 73 20 74 68 that launches th
8690: 65 20 74 65 73 74 20 74 6f 20 74 68 65 20 72 65 e test to the re
86a0: 6d 6f 74 65 20 68 6f 73 74 0a 09 09 09 09 20 20 mote host.....
86b0: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 09 (begin.....
86c0: 09 20 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a . (print "ERROR:
86d0: 20 46 61 69 6c 65 64 20 74 6f 20 6c 61 75 6e 63 Failed to launc
86e0: 68 20 74 68 65 20 74 65 73 74 2e 20 45 78 69 74 h the test. Exit
86f0: 69 6e 67 20 61 73 20 73 6f 6f 6e 20 61 73 20 70 ing as soon as p
8700: 6f 73 73 69 62 6c 65 22 29 0a 09 09 09 09 09 20 ossible")......
8710: 28 73 65 74 21 20 2a 67 6c 6f 62 61 6c 65 78 69 (set! *globalexi
8720: 74 73 74 61 74 75 73 2a 20 31 29 20 3b 3b 20 0a tstatus* 1) ;; .
8730: 09 09 09 09 09 20 28 70 72 6f 63 65 73 73 2d 73 ..... (process-s
8740: 69 67 6e 61 6c 20 28 63 75 72 72 65 6e 74 2d 70 ignal (current-p
8750: 72 6f 63 65 73 73 2d 69 64 29 20 73 69 67 6e 61 rocess-id) signa
8760: 6c 2f 6b 69 6c 6c 29 0a 09 09 09 09 09 20 3b 28 l/kill)...... ;(
8770: 65 78 69 74 20 31 29 0a 09 09 09 09 09 20 29 29 exit 1)...... ))
8780: 0a 09 09 09 09 20 20 20 28 69 66 20 28 6e 6f 74 ..... (if (not
8790: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
87a0: 2d 6b 65 65 70 67 6f 69 6e 67 22 29 29 0a 09 09 -keepgoing"))...
87b0: 09 09 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 .. (hash-t
87c0: 61 62 6c 65 2d 73 65 74 21 20 2a 77 61 69 74 69 able-set! *waiti
87d0: 6e 67 2d 71 75 65 75 65 2a 20 6e 65 77 2d 74 65 ng-queue* new-te
87e0: 73 74 2d 6e 61 6d 65 20 74 65 73 74 72 75 6e 64 st-name testrund
87f0: 61 74 29 29 29 29 29 29 29 0a 09 09 20 20 20 20 at)))))))...
8800: 20 20 28 28 4b 49 4c 4c 45 44 29 20 0a 09 09 20 ((KILLED) ...
8810: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
8820: 6e 74 20 31 20 22 4e 4f 54 45 3a 20 22 20 6e 65 nt 1 "NOTE: " ne
8830: 77 2d 74 65 73 74 2d 6e 61 6d 65 20 22 20 69 73 w-test-name " is
8840: 20 61 6c 72 65 61 64 79 20 72 75 6e 6e 69 6e 67 already running
8850: 20 6f 72 20 77 61 73 20 65 78 70 6c 69 63 74 6c or was explictl
8860: 79 20 6b 69 6c 6c 65 64 2c 20 75 73 65 20 2d 66 y killed, use -f
8870: 6f 72 63 65 20 74 6f 20 6c 61 75 6e 63 68 20 69 orce to launch i
8880: 74 2e 22 29 29 0a 09 09 20 20 20 20 20 20 28 28 t."))... ((
8890: 4c 41 55 4e 43 48 45 44 20 52 45 4d 4f 54 45 48 LAUNCHED REMOTEH
88a0: 4f 53 54 53 54 41 52 54 20 52 55 4e 4e 49 4e 47 OSTSTART RUNNING
88b0: 29 20 20 0a 09 09 20 20 20 20 20 20 20 28 69 66 ) ... (if
88c0: 20 28 3e 20 28 2d 20 28 63 75 72 72 65 6e 74 2d (> (- (current-
88d0: 73 65 63 6f 6e 64 73 29 28 2b 20 28 64 62 3a 74 seconds)(+ (db:t
88e0: 65 73 74 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 est-get-event_ti
88f0: 6d 65 20 74 65 73 74 64 61 74 29 0a 09 09 09 09 me testdat).....
8900: 09 09 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d .. (db:test-
8910: 67 65 74 2d 72 75 6e 5f 64 75 72 61 74 69 6f 6e get-run_duration
8920: 20 74 65 73 74 64 61 74 29 29 29 0a 09 09 09 20 testdat)))....
8930: 20 20 20 20 20 31 30 30 29 20 3b 3b 20 69 2e 65 100) ;; i.e
8940: 2e 20 6e 6f 20 75 70 64 61 74 65 20 66 6f 72 20 . no update for
8950: 6d 6f 72 65 20 74 68 61 6e 20 31 30 30 20 73 65 more than 100 se
8960: 63 6f 6e 64 73 0a 09 09 09 20 20 20 28 62 65 67 conds.... (beg
8970: 69 6e 0a 09 09 09 20 20 20 20 20 28 64 65 62 75 in.... (debu
8980: 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 g:print 0 "WARNI
8990: 4e 47 3a 20 54 65 73 74 20 22 20 74 65 73 74 2d NG: Test " test-
89a0: 6e 61 6d 65 20 22 20 61 70 70 65 61 72 73 20 74 name " appears t
89b0: 6f 20 62 65 20 64 65 61 64 2e 20 46 6f 72 63 69 o be dead. Forci
89c0: 6e 67 20 69 74 20 74 6f 20 73 74 61 74 65 20 49 ng it to state I
89d0: 4e 43 4f 4d 50 4c 45 54 45 20 61 6e 64 20 73 74 NCOMPLETE and st
89e0: 61 74 75 73 20 53 54 55 43 4b 2f 44 45 41 44 22 atus STUCK/DEAD"
89f0: 29 0a 09 09 09 20 20 20 20 20 28 74 65 73 74 2d ).... (test-
8a00: 73 65 74 2d 73 74 61 74 75 73 21 20 64 62 20 72 set-status! db r
8a10: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 un-id test-name
8a20: 22 49 4e 43 4f 4d 50 4c 45 54 45 22 20 22 53 54 "INCOMPLETE" "ST
8a30: 55 43 4b 2f 44 45 41 44 22 20 69 74 65 6d 64 61 UCK/DEAD" itemda
8a40: 74 20 22 54 65 73 74 20 69 73 20 73 74 75 63 6b t "Test is stuck
8a50: 20 6f 72 20 64 65 61 64 22 20 23 66 29 29 0a 09 or dead" #f))..
8a60: 09 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e .. (debug:prin
8a70: 74 20 32 20 22 4e 4f 54 45 3a 20 22 20 74 65 73 t 2 "NOTE: " tes
8a80: 74 2d 6e 61 6d 65 20 22 20 69 73 20 61 6c 72 65 t-name " is alre
8a90: 61 64 79 20 72 75 6e 6e 69 6e 67 22 29 29 29 0a ady running"))).
8aa0: 09 09 20 20 20 20 20 20 28 65 6c 73 65 20 20 20 .. (else
8ab0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
8ac0: 20 30 20 22 45 52 52 4f 52 3a 20 46 61 69 6c 65 0 "ERROR: Faile
8ad0: 64 20 74 6f 20 6c 61 75 6e 63 68 20 74 65 73 74 d to launch test
8ae0: 20 22 20 6e 65 77 2d 74 65 73 74 2d 6e 61 6d 65 " new-test-name
8af0: 20 22 2e 20 55 6e 72 65 63 6f 67 6e 69 73 65 64 ". Unrecognised
8b00: 20 73 74 61 74 65 20 22 20 28 74 65 73 74 3a 67 state " (test:g
8b10: 65 74 2d 73 74 61 74 65 20 74 65 73 74 64 61 74 et-state testdat
8b20: 29 29 29 29 29 29 0a 09 20 20 20 20 20 20 28 69 )))))).. (i
8b30: 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 f (not (null? ta
8b40: 6c 29 29 0a 09 09 20 20 28 6c 6f 6f 70 20 28 63 l))... (loop (c
8b50: 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 ar tal)(cdr tal)
8b60: 29 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e ))))))))..(defin
8b70: 65 20 28 72 75 6e 2d 77 61 69 74 69 6e 67 2d 74 e (run-waiting-t
8b80: 65 73 74 73 20 64 62 29 0a 20 20 28 6c 65 74 20 ests db). (let
8b90: 28 28 6e 75 6d 74 72 69 65 73 20 20 20 20 20 20 ((numtries
8ba0: 20 20 20 20 20 30 29 0a 09 28 6c 61 73 74 2d 74 0)..(last-t
8bb0: 72 79 2d 74 69 6d 65 20 20 20 20 20 20 28 63 75 ry-time (cu
8bc0: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a rrent-seconds)).
8bd0: 09 28 74 69 6d 65 73 20 20 20 20 20 20 20 20 20 .(times
8be0: 20 20 20 20 20 28 6c 69 73 74 20 31 29 29 29 20 (list 1)))
8bf0: 3b 3b 20 6d 69 6e 75 74 65 73 20 74 6f 20 77 61 ;; minutes to wa
8c00: 69 74 20 62 65 66 6f 72 65 20 74 72 79 69 6e 67 it before trying
8c10: 20 61 67 61 69 6e 20 74 6f 20 6b 69 63 6b 20 6f again to kick o
8c20: 66 66 20 72 75 6e 73 0a 20 20 20 20 3b 3b 20 42 ff runs. ;; B
8c30: 55 47 20 74 68 69 73 20 68 61 63 6b 20 6f 66 20 UG this hack of
8c40: 62 72 75 74 65 20 66 6f 72 63 65 20 72 65 74 72 brute force retr
8c50: 79 69 6e 67 20 77 6f 72 6b 73 20 71 75 69 74 65 ying works quite
8c60: 20 77 65 6c 6c 20 66 6f 72 20 6d 61 6e 79 20 63 well for many c
8c70: 61 73 65 73 20 62 75 74 20 0a 20 20 20 20 3b 3b ases but . ;;
8c80: 20 20 20 20 20 77 68 61 74 20 69 73 20 6e 65 65 what is nee
8c90: 64 65 64 20 69 73 20 74 6f 20 63 68 65 63 6b 20 ded is to check
8ca0: 74 68 65 20 64 62 20 66 6f 72 20 74 65 73 74 73 the db for tests
8cb0: 20 74 68 61 74 20 68 61 76 65 20 66 61 69 6c 65 that have faile
8cc0: 64 20 6c 65 73 73 20 74 68 61 6e 0a 20 20 20 20 d less than.
8cd0: 3b 3b 20 20 20 20 20 4e 20 74 69 6d 65 73 20 6f ;; N times o
8ce0: 72 20 6e 65 76 65 72 20 62 65 65 6e 20 73 74 61 r never been sta
8cf0: 72 74 65 64 20 61 6e 64 20 6b 69 63 6b 20 74 68 rted and kick th
8d00: 65 6d 20 6f 66 66 20 61 67 61 69 6e 0a 20 20 20 em off again.
8d10: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 77 61 69 (let loop ((wai
8d20: 74 69 6e 67 2d 74 65 73 74 2d 6e 61 6d 65 73 20 ting-test-names
8d30: 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 (hash-table-keys
8d40: 20 2a 77 61 69 74 69 6e 67 2d 71 75 65 75 65 2a *waiting-queue*
8d50: 29 29 29 0a 20 20 20 20 20 20 28 63 6f 6e 64 0a ))). (cond.
8d60: 20 20 20 20 20 20 20 28 28 6e 6f 74 20 28 72 75 ((not (ru
8d70: 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d ns:can-run-more-
8d80: 74 65 73 74 73 20 64 62 29 29 0a 09 28 74 68 72 tests db))..(thr
8d90: 65 61 64 2d 73 6c 65 65 70 21 20 32 29 0a 09 28 ead-sleep! 2)..(
8da0: 6c 6f 6f 70 20 77 61 69 74 69 6e 67 2d 74 65 73 loop waiting-tes
8db0: 74 2d 6e 61 6d 65 73 29 29 0a 20 20 20 20 20 20 t-names)).
8dc0: 20 28 28 6e 75 6c 6c 3f 20 77 61 69 74 69 6e 67 ((null? waiting
8dd0: 2d 74 65 73 74 2d 6e 61 6d 65 73 29 0a 09 28 64 -test-names)..(d
8de0: 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 41 6c ebug:print 1 "Al
8df0: 6c 20 74 65 73 74 73 20 6c 61 75 6e 63 68 65 64 l tests launched
8e00: 22 29 29 0a 20 20 20 20 20 20 20 28 65 6c 73 65 ")). (else
8e10: 0a 09 28 73 65 74 21 20 6e 75 6d 74 72 69 65 73 ..(set! numtries
8e20: 20 28 2b 20 6e 75 6d 74 72 69 65 73 20 31 29 29 (+ numtries 1))
8e30: 0a 09 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d ..(for-each (lam
8e40: 62 64 61 20 28 74 65 73 74 6e 61 6d 65 29 0a 09 bda (testname)..
8e50: 09 20 20 20 20 28 69 66 20 28 72 75 6e 73 3a 63 . (if (runs:c
8e60: 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 an-run-more-test
8e70: 73 20 64 62 29 0a 09 09 09 28 6c 65 74 2a 20 28 s db)....(let* (
8e80: 28 74 65 73 74 64 61 74 20 28 68 61 73 68 2d 74 (testdat (hash-t
8e90: 61 62 6c 65 2d 72 65 66 20 2a 77 61 69 74 69 6e able-ref *waitin
8ea0: 67 2d 71 75 65 75 65 2a 20 74 65 73 74 6e 61 6d g-queue* testnam
8eb0: 65 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 70 e)).... (p
8ec0: 72 65 72 65 71 73 20 28 28 63 61 72 20 74 65 73 rereqs ((car tes
8ed0: 74 64 61 74 29 29 29 0a 09 09 09 20 20 20 20 20 tdat)))....
8ee0: 20 20 28 6c 64 62 20 20 20 20 20 28 69 66 20 64 (ldb (if d
8ef0: 62 20 64 62 20 28 6f 70 65 6e 2d 64 62 29 29 29 b db (open-db)))
8f00: 29 0a 09 09 09 20 20 28 64 65 62 75 67 3a 70 72 ).... (debug:pr
8f10: 69 6e 74 20 32 20 22 70 72 65 72 65 71 73 20 72 int 2 "prereqs r
8f20: 65 6d 61 69 6e 69 6e 67 3a 20 22 20 70 72 65 72 emaining: " prer
8f30: 65 71 73 29 0a 09 09 09 20 20 28 69 66 20 28 6e eqs).... (if (n
8f40: 75 6c 6c 3f 20 70 72 65 72 65 71 73 29 0a 09 09 ull? prereqs)...
8f50: 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 . (begin...
8f60: 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 ..(debug:print 2
8f70: 20 22 50 72 65 72 65 71 75 69 73 69 74 65 73 20 "Prerequisites
8f80: 6d 65 74 2c 20 6c 61 75 6e 63 68 69 6e 67 20 22 met, launching "
8f90: 20 74 65 73 74 6e 61 6d 65 29 0a 09 09 09 09 28 testname).....(
8fa0: 28 63 61 64 72 20 74 65 73 74 64 61 74 29 29 0a (cadr testdat)).
8fb0: 09 09 09 09 28 68 61 73 68 2d 74 61 62 6c 65 2d ....(hash-table-
8fc0: 64 65 6c 65 74 65 21 20 2a 77 61 69 74 69 6e 67 delete! *waiting
8fd0: 2d 71 75 65 75 65 2a 20 74 65 73 74 6e 61 6d 65 -queue* testname
8fe0: 29 29 29 0a 09 09 09 20 20 28 69 66 20 28 6e 6f ))).... (if (no
8ff0: 74 20 64 62 29 0a 09 09 09 20 20 20 20 20 20 28 t db).... (
9000: 73 71 6c 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 sqlite3:finalize
9010: 21 20 6c 64 62 29 29 29 29 29 0a 09 09 20 20 77 ! ldb)))))... w
9020: 61 69 74 69 6e 67 2d 74 65 73 74 2d 6e 61 6d 65 aiting-test-name
9030: 73 29 0a 09 3b 3b 20 28 73 6c 65 65 70 20 31 30 s)..;; (sleep 10
9040: 29 20 3b 3b 20 6e 6f 20 70 6f 69 6e 74 20 69 6e ) ;; no point in
9050: 20 72 75 73 68 69 6e 67 20 74 68 69 6e 67 73 20 rushing things
9060: 61 74 20 74 68 69 73 20 73 74 61 67 65 3f 0a 09 at this stage?..
9070: 28 6c 6f 6f 70 20 28 68 61 73 68 2d 74 61 62 6c (loop (hash-tabl
9080: 65 2d 6b 65 79 73 20 2a 77 61 69 74 69 6e 67 2d e-keys *waiting-
9090: 71 75 65 75 65 2a 29 29 29 29 29 29 29 0a 0a 3b queue*)))))))..;
90a0: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
90b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
90c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
90d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
90e0: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4e 65 77 20 6d =======.;; New m
90f0: 65 74 68 6f 64 6f 6c 6f 67 79 2e 20 54 68 65 73 ethodology. Thes
9100: 65 20 72 6f 75 74 69 6e 65 73 20 77 69 6c 6c 20 e routines will
9110: 72 65 70 6c 61 63 65 20 74 68 65 20 61 62 6f 76 replace the abov
9120: 65 20 69 6e 20 74 69 6d 65 2e 20 46 6f 72 0a 3b e in time. For.;
9130: 3b 20 6e 6f 77 20 74 68 65 20 63 6f 64 65 20 69 ; now the code i
9140: 73 20 64 75 70 6c 69 63 61 74 65 64 2e 20 54 68 s duplicated. Th
9150: 69 73 20 73 74 75 66 66 20 69 73 20 69 6e 69 74 is stuff is init
9160: 69 61 6c 6c 79 20 75 73 65 64 20 69 6e 20 74 68 ially used in th
9170: 65 20 6d 6f 6e 69 74 6f 72 0a 3b 3b 20 62 61 73 e monitor.;; bas
9180: 65 64 20 63 6f 64 65 2e 0a 3b 3b 3d 3d 3d 3d 3d ed code..;;=====
9190: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
91a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
91b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
91c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
91d0: 3d 0a 0a 3b 3b 20 72 65 67 69 73 74 65 72 20 61 =..;; register a
91e0: 20 74 65 73 74 20 72 75 6e 20 77 69 74 68 20 74 test run with t
91f0: 68 65 20 64 62 0a 28 64 65 66 69 6e 65 20 28 72 he db.(define (r
9200: 75 6e 73 3a 72 65 67 69 73 74 65 72 2d 72 75 6e uns:register-run
9210: 20 64 62 20 6b 65 79 73 20 6b 65 79 76 61 6c 6c db keys keyvall
9220: 73 74 20 72 75 6e 6e 61 6d 65 20 73 74 61 74 65 st runname state
9230: 20 73 74 61 74 75 73 20 75 73 65 72 29 0a 20 20 status user).
9240: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 33 20 22 (debug:print 3 "
9250: 72 75 6e 73 3a 72 65 67 69 73 74 65 72 2d 72 75 runs:register-ru
9260: 6e 2c 20 6b 65 79 73 3a 20 22 20 6b 65 79 73 20 n, keys: " keys
9270: 22 20 6b 65 79 76 61 6c 6c 73 74 3a 20 22 20 6b " keyvallst: " k
9280: 65 79 76 61 6c 6c 73 74 20 22 20 72 75 6e 6e 61 eyvallst " runna
9290: 6d 65 3a 20 22 20 72 75 6e 6e 61 6d 65 20 22 20 me: " runname "
92a0: 73 74 61 74 65 3a 20 22 20 73 74 61 74 65 20 22 state: " state "
92b0: 20 73 74 61 74 75 73 3a 20 22 20 73 74 61 74 75 status: " statu
92c0: 73 20 22 20 75 73 65 72 3a 20 22 20 75 73 65 72 s " user: " user
92d0: 29 0a 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 73 ). (let* ((keys
92e0: 74 72 20 20 20 20 28 6b 65 79 73 2d 3e 6b 65 79 tr (keys->key
92f0: 73 74 72 20 6b 65 79 73 29 29 0a 09 20 28 63 6f str keys)).. (co
9300: 6d 6d 61 20 20 20 20 20 28 69 66 20 28 3e 20 28 mma (if (> (
9310: 6c 65 6e 67 74 68 20 6b 65 79 73 29 20 30 29 20 length keys) 0)
9320: 22 2c 22 20 22 22 29 29 0a 09 20 28 61 6e 64 73 "," "")).. (ands
9330: 74 72 20 20 20 20 28 69 66 20 28 3e 20 28 6c 65 tr (if (> (le
9340: 6e 67 74 68 20 6b 65 79 73 29 20 30 29 20 22 20 ngth keys) 0) "
9350: 41 4e 44 20 22 20 22 22 29 29 0a 09 20 28 76 61 AND " "")).. (va
9360: 6c 73 6c 6f 74 73 20 20 28 6b 65 79 73 2d 3e 76 lslots (keys->v
9370: 61 6c 73 6c 6f 74 73 20 6b 65 79 73 29 29 20 3b alslots keys)) ;
9380: 3b 20 3f 2c 3f 2c 3f 20 2e 2e 2e 0a 09 20 28 6b ; ?,?,? ..... (k
9390: 65 79 76 61 6c 73 20 20 20 28 6d 61 70 20 63 61 eyvals (map ca
93a0: 64 72 20 6b 65 79 76 61 6c 6c 73 74 29 29 0a 09 dr keyvallst))..
93b0: 20 28 61 6c 6c 76 61 6c 73 20 20 20 28 61 70 70 (allvals (app
93c0: 65 6e 64 20 28 6c 69 73 74 20 72 75 6e 6e 61 6d end (list runnam
93d0: 65 20 73 74 61 74 65 20 73 74 61 74 75 73 20 75 e state status u
93e0: 73 65 72 29 20 6b 65 79 76 61 6c 73 29 29 0a 09 ser) keyvals))..
93f0: 20 28 71 72 79 76 61 6c 73 20 20 20 28 61 70 70 (qryvals (app
9400: 65 6e 64 20 28 6c 69 73 74 20 72 75 6e 6e 61 6d end (list runnam
9410: 65 29 20 6b 65 79 76 61 6c 73 29 29 0a 09 20 28 e) keyvals)).. (
9420: 6b 65 79 3d 3f 73 74 72 20 20 28 73 74 72 69 6e key=?str (strin
9430: 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 6d g-intersperse (m
9440: 61 70 20 28 6c 61 6d 62 64 61 20 28 6b 29 28 63 ap (lambda (k)(c
9450: 6f 6e 63 20 28 6b 65 79 3a 67 65 74 2d 66 69 65 onc (key:get-fie
9460: 6c 64 6e 61 6d 65 20 6b 29 20 22 3d 3f 22 29 29 ldname k) "=?"))
9470: 20 6b 65 79 73 29 20 22 20 41 4e 44 20 22 29 29 keys) " AND "))
9480: 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 ). (debug:pri
9490: 6e 74 20 33 20 22 6b 65 79 73 3a 20 22 20 6b 65 nt 3 "keys: " ke
94a0: 79 73 20 22 20 61 6c 6c 76 61 6c 73 3a 20 22 20 ys " allvals: "
94b0: 61 6c 6c 76 61 6c 73 20 22 20 6b 65 79 76 61 6c allvals " keyval
94c0: 73 3a 20 22 20 6b 65 79 76 61 6c 73 29 0a 20 20 s: " keyvals).
94d0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 (debug:print 2
94e0: 20 22 4e 4f 54 45 3a 20 75 73 69 6e 67 20 74 61 "NOTE: using ta
94f0: 72 67 65 74 20 22 20 28 73 74 72 69 6e 67 2d 69 rget " (string-i
9500: 6e 74 65 72 73 70 65 72 73 65 20 6b 65 79 76 61 ntersperse keyva
9510: 6c 73 20 22 2f 22 29 20 22 20 66 6f 72 20 74 68 ls "/") " for th
9520: 69 73 20 72 75 6e 22 29 0a 20 20 20 20 28 69 66 is run"). (if
9530: 20 28 61 6e 64 20 72 75 6e 6e 61 6d 65 20 28 6e (and runname (n
9540: 75 6c 6c 3f 20 28 66 69 6c 74 65 72 20 28 6c 61 ull? (filter (la
9550: 6d 62 64 61 20 28 78 29 28 6e 6f 74 20 78 29 29 mbda (x)(not x))
9560: 20 6b 65 79 76 61 6c 73 29 29 29 20 3b 3b 20 74 keyvals))) ;; t
9570: 68 65 72 65 20 6d 75 73 74 20 62 65 20 61 20 62 here must be a b
9580: 65 74 74 65 72 20 77 61 79 20 74 6f 20 22 61 70 etter way to "ap
9590: 70 6c 79 20 61 6e 64 22 0a 09 28 6c 65 74 20 28 ply and"..(let (
95a0: 28 72 65 73 20 23 66 29 29 0a 09 20 20 28 61 70 (res #f)).. (ap
95b0: 70 6c 79 20 73 71 6c 69 74 65 33 3a 65 78 65 63 ply sqlite3:exec
95c0: 75 74 65 20 64 62 20 28 63 6f 6e 63 20 22 49 4e ute db (conc "IN
95d0: 53 45 52 54 20 4f 52 20 49 47 4e 4f 52 45 20 49 SERT OR IGNORE I
95e0: 4e 54 4f 20 72 75 6e 73 20 28 72 75 6e 6e 61 6d NTO runs (runnam
95f0: 65 2c 73 74 61 74 65 2c 73 74 61 74 75 73 2c 6f e,state,status,o
9600: 77 6e 65 72 2c 65 76 65 6e 74 5f 74 69 6d 65 22 wner,event_time"
9610: 20 63 6f 6d 6d 61 20 6b 65 79 73 74 72 20 22 29 comma keystr ")
9620: 20 56 41 4c 55 45 53 20 28 3f 2c 3f 2c 3f 2c 3f VALUES (?,?,?,?
9630: 2c 73 74 72 66 74 69 6d 65 28 27 25 73 27 2c 27 ,strftime('%s','
9640: 6e 6f 77 27 29 22 20 63 6f 6d 6d 61 20 76 61 6c now')" comma val
9650: 73 6c 6f 74 73 20 22 29 3b 22 29 0a 09 09 20 61 slots ");")... a
9660: 6c 6c 76 61 6c 73 29 0a 09 20 20 28 61 70 70 6c llvals).. (appl
9670: 79 20 73 71 6c 69 74 65 33 3a 66 6f 72 2d 65 61 y sqlite3:for-ea
9680: 63 68 2d 72 6f 77 20 0a 09 20 20 20 28 6c 61 6d ch-row .. (lam
9690: 62 64 61 20 28 69 64 29 0a 09 20 20 20 20 20 28 bda (id).. (
96a0: 73 65 74 21 20 72 65 73 20 69 64 29 29 0a 09 20 set! res id))..
96b0: 20 20 64 62 0a 09 20 20 20 28 6c 65 74 20 28 28 db.. (let ((
96c0: 71 72 79 20 28 63 6f 6e 63 20 22 53 45 4c 45 43 qry (conc "SELEC
96d0: 54 20 69 64 20 46 52 4f 4d 20 72 75 6e 73 20 57 T id FROM runs W
96e0: 48 45 52 45 20 28 72 75 6e 6e 61 6d 65 3d 3f 20 HERE (runname=?
96f0: 22 20 61 6e 64 73 74 72 20 6b 65 79 3d 3f 73 74 " andstr key=?st
9700: 72 20 22 29 3b 22 29 29 29 0a 09 20 20 20 20 20 r ");")))..
9710: 3b 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 ;(debug:print 4
9720: 22 71 72 79 3a 20 22 20 71 72 79 29 20 0a 09 20 "qry: " qry) ..
9730: 20 20 20 20 71 72 79 29 0a 09 20 20 20 71 72 79 qry).. qry
9740: 76 61 6c 73 29 0a 09 20 20 28 73 71 6c 69 74 65 vals).. (sqlite
9750: 33 3a 65 78 65 63 75 74 65 20 64 62 20 22 55 50 3:execute db "UP
9760: 44 41 54 45 20 72 75 6e 73 20 53 45 54 20 73 74 DATE runs SET st
9770: 61 74 65 3d 3f 2c 73 74 61 74 75 73 3d 3f 20 57 ate=?,status=? W
9780: 48 45 52 45 20 69 64 3d 3f 3b 22 20 73 74 61 74 HERE id=?;" stat
9790: 65 20 73 74 61 74 75 73 20 72 65 73 29 0a 09 20 e status res)..
97a0: 20 72 65 73 29 20 0a 09 28 62 65 67 69 6e 0a 09 res) ..(begin..
97b0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
97c0: 20 22 45 52 52 4f 52 3a 20 43 61 6c 6c 65 64 20 "ERROR: Called
97d0: 77 69 74 68 6f 75 74 20 61 6c 6c 20 6e 65 63 65 without all nece
97e0: 73 73 61 72 79 20 6b 65 79 73 22 29 0a 09 20 20 ssary keys")..
97f0: 23 66 29 29 29 29 0a 0a 3b 3b 20 54 68 69 73 20 #f))))..;; This
9800: 69 73 20 61 20 64 75 70 6c 69 63 61 74 65 20 6f is a duplicate o
9810: 66 20 72 75 6e 2d 74 65 73 74 73 20 28 77 68 69 f run-tests (whi
9820: 63 68 20 68 61 73 20 62 65 65 6e 20 64 65 70 72 ch has been depr
9830: 65 63 61 74 65 64 29 2e 20 55 73 65 20 74 68 69 ecated). Use thi
9840: 73 20 6f 6e 65 20 69 6e 73 74 65 61 64 20 6f 66 s one instead of
9850: 20 72 75 6e 20 74 65 73 74 73 2e 0a 3b 3b 20 6b run tests..;; k
9860: 65 79 76 61 6c 73 0a 28 64 65 66 69 6e 65 20 28 eyvals.(define (
9870: 72 75 6e 73 3a 72 75 6e 2d 74 65 73 74 73 20 64 runs:run-tests d
9880: 62 20 74 61 72 67 65 74 20 72 75 6e 6e 61 6d 65 b target runname
9890: 20 74 65 73 74 2d 70 61 74 74 73 20 69 74 65 6d test-patts item
98a0: 2d 70 61 74 74 73 20 75 73 65 72 20 66 6c 61 67 -patts user flag
98b0: 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 s). (let* ((key
98c0: 73 20 20 20 20 20 20 20 20 28 64 62 2d 67 65 74 s (db-get
98d0: 2d 6b 65 79 73 20 64 62 29 29 0a 09 20 28 6b 65 -keys db)).. (ke
98e0: 79 76 61 6c 6c 73 74 20 20 20 28 6b 65 79 73 3a yvallst (keys:
98f0: 74 61 72 67 65 74 2d 3e 6b 65 79 76 61 6c 20 6b target->keyval k
9900: 65 79 73 20 74 61 72 67 65 74 29 29 0a 09 20 28 eys target)).. (
9910: 72 75 6e 2d 69 64 20 20 20 20 20 20 28 72 75 6e run-id (run
9920: 73 3a 72 65 67 69 73 74 65 72 2d 72 75 6e 20 64 s:register-run d
9930: 62 20 6b 65 79 73 20 6b 65 79 76 61 6c 6c 73 74 b keys keyvallst
9940: 20 72 75 6e 6e 61 6d 65 20 22 6e 65 77 22 20 22 runname "new" "
9950: 6e 2f 61 22 20 75 73 65 72 29 29 20 20 3b 3b 20 n/a" user)) ;;
9960: 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a 09 20 test-name)))..
9970: 28 64 65 66 65 72 72 65 64 20 20 20 20 27 28 29 (deferred '()
9980: 29 20 3b 3b 20 64 65 6c 61 79 20 72 75 6e 6e 69 ) ;; delay runni
9990: 6e 67 20 74 68 65 73 65 20 73 69 6e 63 65 20 74 ng these since t
99a0: 68 65 79 20 68 61 76 65 20 61 20 77 61 69 74 6f hey have a waito
99b0: 6e 20 63 6c 61 75 73 65 0a 09 20 28 6b 65 65 70 n clause.. (keep
99c0: 67 6f 69 6e 67 20 20 20 28 68 61 73 68 2d 74 61 going (hash-ta
99d0: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
99e0: 66 6c 61 67 73 20 22 2d 6b 65 65 70 67 6f 69 6e flags "-keepgoin
99f0: 67 22 20 23 66 29 29 0a 09 20 28 74 65 73 74 2d g" #f)).. (test-
9a00: 6e 61 6d 65 73 20 20 27 28 29 29 0a 09 20 28 72 names '()).. (r
9a10: 75 6e 63 6f 6e 66 69 67 66 20 20 20 28 63 6f 6e unconfigf (con
9a20: 63 20 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 72 c *toppath* "/r
9a30: 75 6e 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 69 67 unconfigs.config
9a40: 22 29 29 0a 09 20 28 72 65 71 75 69 72 65 64 2d ")).. (required-
9a50: 74 65 73 74 73 20 27 28 29 29 29 0a 0a 20 20 20 tests '()))..
9a60: 20 28 73 65 74 2d 6d 65 67 61 74 65 73 74 2d 65 (set-megatest-e
9a70: 6e 76 2d 76 61 72 73 20 64 62 20 72 75 6e 2d 69 nv-vars db run-i
9a80: 64 29 20 3b 3b 20 74 68 65 73 65 20 6d 61 79 20 d) ;; these may
9a90: 62 65 20 6e 65 65 64 65 64 20 62 79 20 74 68 65 be needed by the
9aa0: 20 6c 61 75 6e 63 68 69 6e 67 20 70 72 6f 63 65 launching proce
9ab0: 73 73 0a 0a 20 20 20 20 28 69 66 20 28 66 69 6c ss.. (if (fil
9ac0: 65 2d 65 78 69 73 74 73 3f 20 72 75 6e 63 6f 6e e-exists? runcon
9ad0: 66 69 67 66 29 0a 09 28 73 65 74 75 70 2d 65 6e figf)..(setup-en
9ae0: 76 2d 64 65 66 61 75 6c 74 73 20 64 62 20 72 75 v-defaults db ru
9af0: 6e 63 6f 6e 66 69 67 66 20 72 75 6e 2d 69 64 20 nconfigf run-id
9b00: 2a 61 6c 72 65 61 64 79 2d 73 65 65 6e 2d 72 75 *already-seen-ru
9b10: 6e 63 6f 6e 66 69 67 2d 69 6e 66 6f 2a 20 22 70 nconfig-info* "p
9b20: 72 65 2d 6c 61 75 6e 63 68 2d 65 6e 76 2d 76 61 re-launch-env-va
9b30: 72 73 22 29 0a 09 28 64 65 62 75 67 3a 70 72 69 rs")..(debug:pri
9b40: 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 59 nt 0 "WARNING: Y
9b50: 6f 75 20 64 6f 20 6e 6f 74 20 68 61 76 65 20 61 ou do not have a
9b60: 20 72 75 6e 20 63 6f 6e 66 69 67 20 66 69 6c 65 run config file
9b70: 3a 20 22 20 72 75 6e 63 6f 6e 66 69 67 66 29 29 : " runconfigf))
9b80: 0a 20 20 20 20 0a 20 20 20 20 3b 3b 20 6c 6f 6f . . ;; loo
9b90: 6b 20 75 70 20 61 6c 6c 20 74 65 73 74 73 20 6d k up all tests m
9ba0: 61 74 63 68 69 6e 67 20 74 68 65 20 63 6f 6d 6d atching the comm
9bb0: 61 20 73 65 70 61 72 61 74 65 64 20 6c 69 73 74 a separated list
9bc0: 20 6f 66 20 67 6c 6f 62 73 20 69 6e 0a 20 20 20 of globs in.
9bd0: 20 3b 3b 20 74 65 73 74 2d 70 61 74 74 73 20 28 ;; test-patts (
9be0: 75 73 69 6e 67 20 25 20 61 73 20 77 69 6c 64 63 using % as wildc
9bf0: 61 72 64 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 ard). (for-ea
9c00: 63 68 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 ch . (lambda
9c10: 20 28 70 61 74 74 29 0a 20 20 20 20 20 20 20 28 (patt). (
9c20: 6c 65 74 20 28 28 74 65 73 74 73 20 28 67 6c 6f let ((tests (glo
9c30: 62 20 28 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 b (conc *toppath
9c40: 2a 20 22 2f 74 65 73 74 73 2f 22 20 28 73 74 72 * "/tests/" (str
9c50: 69 6e 67 2d 74 72 61 6e 73 6c 61 74 65 20 70 61 ing-translate pa
9c60: 74 74 20 22 25 22 20 22 2a 22 29 29 29 29 29 0a tt "%" "*"))))).
9c70: 09 20 28 73 65 74 21 20 74 65 73 74 73 20 28 66 . (set! tests (f
9c80: 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 74 ilter (lambda (t
9c90: 65 73 74 29 28 66 69 6c 65 2d 65 78 69 73 74 73 est)(file-exists
9ca0: 3f 20 28 63 6f 6e 63 20 74 65 73 74 20 22 2f 74 ? (conc test "/t
9cb0: 65 73 74 63 6f 6e 66 69 67 22 29 29 29 20 74 65 estconfig"))) te
9cc0: 73 74 73 29 29 0a 09 20 28 73 65 74 21 20 74 65 sts)).. (set! te
9cd0: 73 74 2d 6e 61 6d 65 73 20 28 61 70 70 65 6e 64 st-names (append
9ce0: 20 74 65 73 74 2d 6e 61 6d 65 73 20 0a 09 09 09 test-names ....
9cf0: 09 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 . (map (lambda
9d00: 28 74 65 73 74 70 29 0a 09 09 09 09 09 20 28 6c (testp)...... (l
9d10: 61 73 74 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 ast (string-spli
9d20: 74 20 74 65 73 74 70 20 22 2f 22 29 29 29 0a 09 t testp "/")))..
9d30: 09 09 09 20 20 20 20 20 20 20 74 65 73 74 73 29 ... tests)
9d40: 29 29 29 29 0a 20 20 20 20 20 28 73 74 72 69 6e )))). (strin
9d50: 67 2d 73 70 6c 69 74 20 74 65 73 74 2d 70 61 74 g-split test-pat
9d60: 74 73 20 22 2c 22 29 29 0a 0a 20 20 20 20 20 3b ts ",")).. ;
9d70: 3b 20 6e 6f 77 20 72 65 6d 6f 76 65 20 64 75 70 ; now remove dup
9d80: 6c 69 63 61 74 65 73 0a 20 20 20 20 28 73 65 74 licates. (set
9d90: 21 20 74 65 73 74 2d 6e 61 6d 65 73 20 28 64 65 ! test-names (de
9da0: 6c 65 74 65 2d 64 75 70 6c 69 63 61 74 65 73 20 lete-duplicates
9db0: 74 65 73 74 2d 6e 61 6d 65 73 29 29 0a 0a 20 20 test-names))..
9dc0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
9dd0: 20 22 49 4e 46 4f 3a 20 74 65 73 74 20 6e 61 6d "INFO: test nam
9de0: 65 73 20 22 20 74 65 73 74 2d 6e 61 6d 65 73 29 es " test-names)
9df0: 0a 0a 20 20 20 20 3b 3b 20 6e 6f 77 20 61 64 64 .. ;; now add
9e00: 20 6e 6f 6e 2d 64 69 72 65 63 74 6c 79 20 72 65 non-directly re
9e10: 66 65 72 65 6e 63 65 64 20 64 65 70 65 6e 64 65 ferenced depende
9e20: 6e 63 69 65 73 20 28 69 2e 65 2e 20 77 61 69 74 ncies (i.e. wait
9e30: 6f 6e 29 0a 20 20 20 20 3b 3b 20 63 6f 75 6c 64 on). ;; could
9e40: 20 63 61 63 68 65 20 61 6c 6c 20 74 68 65 73 65 cache all these
9e50: 20 73 69 6e 63 65 20 74 68 65 79 20 6e 65 65 64 since they need
9e60: 20 74 6f 20 62 65 20 72 65 61 64 20 61 67 61 69 to be read agai
9e70: 6e 20 2e 2e 2e 0a 20 20 20 20 3b 3b 20 46 49 58 n .... ;; FIX
9e80: 4d 45 20 53 4f 4d 45 44 41 59 0a 20 20 20 20 28 ME SOMEDAY. (
9e90: 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 if (not (null? t
9ea0: 65 73 74 2d 6e 61 6d 65 73 29 29 0a 09 28 6c 65 est-names))..(le
9eb0: 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 61 t loop ((hed (ca
9ec0: 72 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 0a 09 r test-names))..
9ed0: 09 20 20 20 28 74 61 6c 20 28 63 64 72 20 74 65 . (tal (cdr te
9ee0: 73 74 2d 6e 61 6d 65 73 29 29 29 0a 09 20 20 28 st-names))).. (
9ef0: 6c 65 74 2a 20 28 28 63 6f 6e 66 69 67 20 20 28 let* ((config (
9f00: 74 65 73 74 3a 67 65 74 2d 74 65 73 74 63 6f 6e test:get-testcon
9f10: 66 69 67 20 68 65 64 20 23 66 29 29 0a 09 09 20 fig hed #f))...
9f20: 28 77 61 69 74 6f 6e 73 20 28 73 74 72 69 6e 67 (waitons (string
9f30: 2d 73 70 6c 69 74 20 28 6c 65 74 20 28 28 77 20 -split (let ((w
9f40: 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 63 (config-lookup c
9f50: 6f 6e 66 69 67 20 22 72 65 71 75 69 72 65 6d 65 onfig "requireme
9f60: 6e 74 73 22 20 22 77 61 69 74 6f 6e 22 29 29 29 nts" "waiton")))
9f70: 0a 09 09 09 09 09 20 20 28 69 66 20 77 20 77 20 ...... (if w w
9f80: 22 22 29 29 29 29 29 0a 09 20 20 20 20 28 66 6f ""))))).. (fo
9f90: 72 2d 65 61 63 68 20 0a 09 20 20 20 20 20 28 6c r-each .. (l
9fa0: 61 6d 62 64 61 20 28 77 61 69 74 6f 6e 29 0a 09 ambda (waiton)..
9fb0: 20 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 (if (and
9fc0: 77 61 69 74 6f 6e 20 28 6e 6f 74 20 28 6d 65 6d waiton (not (mem
9fd0: 62 65 72 20 77 61 69 74 6f 6e 20 74 65 73 74 2d ber waiton test-
9fe0: 6e 61 6d 65 73 29 29 29 0a 09 09 20 20 20 28 62 names)))... (b
9ff0: 65 67 69 6e 0a 09 09 20 20 20 20 20 28 73 65 74 egin... (set
a000: 21 20 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 ! required-tests
a010: 20 28 63 6f 6e 73 20 77 61 69 74 6f 6e 20 72 65 (cons waiton re
a020: 71 75 69 72 65 64 2d 74 65 73 74 73 29 29 0a 09 quired-tests))..
a030: 09 20 20 20 20 20 28 73 65 74 21 20 74 65 73 74 . (set! test
a040: 2d 6e 61 6d 65 73 20 28 61 70 70 65 6e 64 20 74 -names (append t
a050: 65 73 74 2d 6e 61 6d 65 73 20 28 6c 69 73 74 20 est-names (list
a060: 77 61 69 74 6f 6e 29 29 29 29 29 29 0a 09 20 20 waiton))))))..
a070: 20 20 20 77 61 69 74 6f 6e 73 29 0a 09 20 20 20 waitons)..
a080: 20 28 6c 65 74 20 28 28 72 65 6d 74 65 73 74 73 (let ((remtests
a090: 20 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 (delete-duplica
a0a0: 74 65 73 20 28 61 70 70 65 6e 64 20 77 61 69 74 tes (append wait
a0b0: 6f 6e 73 20 74 61 6c 29 29 29 29 0a 09 20 20 20 ons tal))))..
a0c0: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c (if (not (nul
a0d0: 6c 3f 20 72 65 6d 74 65 73 74 73 29 29 0a 09 09 l? remtests))...
a0e0: 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 72 65 6d (loop (car rem
a0f0: 74 65 73 74 73 29 28 63 64 72 20 72 65 6d 74 65 tests)(cdr remte
a100: 73 74 73 29 29 29 29 29 29 29 0a 0a 20 20 20 20 sts)))))))..
a110: 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 (if (not (null?
a120: 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 29 29 required-tests))
a130: 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 ..(debug:print 1
a140: 20 22 49 4e 46 4f 3a 20 41 64 64 69 6e 67 20 22 "INFO: Adding "
a150: 20 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 20 required-tests
a160: 22 20 74 6f 20 74 68 65 20 72 75 6e 20 71 75 65 " to the run que
a170: 75 65 22 29 29 0a 0a 20 20 20 20 3b 3b 20 6f 6e ue")).. ;; on
a180: 20 74 68 65 20 66 69 72 73 74 20 70 61 73 73 20 the first pass
a190: 6f 72 20 63 61 6c 6c 20 74 6f 20 72 75 6e 2d 74 or call to run-t
a1a0: 65 73 74 73 20 73 65 74 20 46 41 49 4c 53 20 74 ests set FAILS t
a1b0: 6f 20 4e 4f 54 5f 53 54 41 52 54 45 44 20 69 66 o NOT_STARTED if
a1c0: 0a 20 20 20 20 3b 3b 20 2d 6b 65 65 70 67 6f 69 . ;; -keepgoi
a1d0: 6e 67 20 69 73 20 73 70 65 63 69 66 69 65 64 0a ng is specified.
a1e0: 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 65 71 (if (and (eq
a1f0: 3f 20 2a 70 61 73 73 6e 75 6d 2a 20 30 29 0a 09 ? *passnum* 0)..
a200: 20 20 20 20 20 6b 65 65 70 67 6f 69 6e 67 29 0a keepgoing).
a210: 09 28 62 65 67 69 6e 0a 09 20 20 3b 3b 20 68 61 .(begin.. ;; ha
a220: 76 65 20 74 6f 20 64 65 6c 65 74 65 20 74 65 73 ve to delete tes
a230: 74 20 72 65 63 6f 72 64 73 20 77 68 65 72 65 20 t records where
a240: 4e 4f 54 5f 53 54 41 52 54 45 44 20 73 69 6e 63 NOT_STARTED sinc
a250: 65 20 74 68 65 79 20 63 61 6e 20 63 61 75 73 65 e they can cause
a260: 20 2d 6b 65 65 70 67 6f 69 6e 67 20 74 6f 20 0a -keepgoing to .
a270: 09 20 20 3b 3b 20 67 65 74 20 73 74 75 63 6b 20 . ;; get stuck
a280: 64 75 65 20 74 6f 20 62 65 63 6f 6d 69 6e 67 20 due to becoming
a290: 69 6e 61 63 63 65 73 73 69 62 6c 65 20 66 72 6f inaccessible fro
a2a0: 6d 20 61 20 66 61 69 6c 65 64 20 74 65 73 74 2e m a failed test.
a2b0: 20 49 2e 65 2e 20 69 66 20 74 65 73 74 20 42 20 I.e. if test B
a2c0: 64 65 70 65 6e 64 73 20 0a 09 20 20 3b 3b 20 6f depends .. ;; o
a2d0: 6e 20 74 65 73 74 20 41 20 62 75 74 20 74 65 73 n test A but tes
a2e0: 74 20 42 20 72 65 61 63 68 65 64 20 74 68 65 20 t B reached the
a2f0: 70 6f 69 6e 74 20 6f 6e 20 62 65 69 6e 67 20 72 point on being r
a300: 65 67 69 73 74 65 72 65 64 20 61 73 20 4e 4f 54 egistered as NOT
a310: 5f 53 54 41 52 54 45 44 20 61 6e 64 20 74 65 73 _STARTED and tes
a320: 74 0a 09 20 20 3b 3b 20 41 20 66 61 69 6c 65 64 t.. ;; A failed
a330: 20 66 6f 72 20 73 6f 6d 65 20 72 65 61 73 6f 6e for some reason
a340: 20 74 68 65 6e 20 6f 6e 20 72 65 2d 72 75 6e 20 then on re-run
a350: 75 73 69 6e 67 20 2d 6b 65 65 70 67 6f 69 6e 67 using -keepgoing
a360: 20 74 68 65 20 72 75 6e 20 63 61 6e 20 6e 65 76 the run can nev
a370: 65 72 20 63 6f 6d 70 6c 65 74 65 2e 0a 09 20 20 er complete...
a380: 28 64 62 3a 64 65 6c 65 74 65 2d 74 65 73 74 73 (db:delete-tests
a390: 2d 69 6e 2d 73 74 61 74 65 20 64 62 20 72 75 6e -in-state db run
a3a0: 2d 69 64 20 22 4e 4f 54 5f 53 54 41 52 54 45 44 -id "NOT_STARTED
a3b0: 22 29 0a 09 20 20 28 64 62 3a 73 65 74 2d 74 65 ").. (db:set-te
a3c0: 73 74 73 2d 73 74 61 74 65 2d 73 74 61 74 75 73 sts-state-status
a3d0: 20 64 62 20 72 75 6e 2d 69 64 20 74 65 73 74 2d db run-id test-
a3e0: 6e 61 6d 65 73 20 23 66 20 22 46 41 49 4c 22 20 names #f "FAIL"
a3f0: 22 4e 4f 54 5f 53 54 41 52 54 45 44 22 20 22 46 "NOT_STARTED" "F
a400: 41 49 4c 22 29 29 29 0a 20 20 20 20 28 73 65 74 AIL"))). (set
a410: 21 20 2a 70 61 73 73 6e 75 6d 2a 20 28 2b 20 2a ! *passnum* (+ *
a420: 70 61 73 73 6e 75 6d 2a 20 31 29 29 0a 20 20 20 passnum* 1)).
a430: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 6e 75 6d (let loop ((num
a440: 74 69 6d 65 73 20 30 29 29 0a 20 20 20 20 20 20 times 0)).
a450: 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 20 (for-each .
a460: 20 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 2d (lambda (test-
a470: 6e 61 6d 65 29 0a 09 20 28 69 66 20 28 72 75 6e name).. (if (run
a480: 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 s:can-run-more-t
a490: 65 73 74 73 20 64 62 29 0a 09 20 20 20 20 20 28 ests db).. (
a4a0: 72 75 6e 3a 74 65 73 74 20 64 62 20 72 75 6e 2d run:test db run-
a4b0: 69 64 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 2d id runname test-
a4c0: 6e 61 6d 65 20 6b 65 79 76 61 6c 6c 73 74 20 69 name keyvallst i
a4d0: 74 65 6d 2d 70 61 74 74 73 20 66 6c 61 67 73 29 tem-patts flags)
a4e0: 0a 09 20 20 20 20 20 29 29 0a 20 20 20 20 20 20 .. )).
a4f0: 20 28 74 65 73 74 73 3a 73 6f 72 74 2d 62 79 2d (tests:sort-by-
a500: 70 72 69 6f 72 69 74 79 2d 61 6e 64 2d 77 61 69 priority-and-wai
a510: 74 6f 6e 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 ton test-names))
a520: 0a 20 20 20 20 20 20 3b 3b 20 28 72 75 6e 2d 77 . ;; (run-w
a530: 61 69 74 69 6e 67 2d 74 65 73 74 73 20 64 62 29 aiting-tests db)
a540: 0a 20 20 20 20 20 20 28 69 66 20 6b 65 65 70 67 . (if keepg
a550: 6f 69 6e 67 0a 09 20 20 28 6c 65 74 20 28 28 65 oing.. (let ((e
a560: 73 74 72 65 6d 20 28 64 62 3a 65 73 74 69 6d 61 strem (db:estima
a570: 74 65 64 2d 74 65 73 74 73 2d 72 65 6d 61 69 6e ted-tests-remain
a580: 69 6e 67 20 64 62 20 72 75 6e 2d 69 64 29 29 29 ing db run-id)))
a590: 0a 09 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 .. (if (and (
a5a0: 3e 20 65 73 74 72 65 6d 20 30 29 0a 09 09 20 20 > estrem 0)...
a5b0: 20 20 20 28 65 71 3f 20 2a 67 6c 6f 62 61 6c 65 (eq? *globale
a5c0: 78 69 74 73 74 61 74 75 73 2a 20 30 29 29 0a 09 xitstatus* 0))..
a5d0: 09 28 62 65 67 69 6e 0a 09 09 20 20 28 64 65 62 .(begin... (deb
a5e0: 75 67 3a 70 72 69 6e 74 20 31 20 22 4b 65 65 70 ug:print 1 "Keep
a5f0: 20 67 6f 69 6e 67 2c 20 65 73 74 69 6d 61 74 65 going, estimate
a600: 64 20 22 20 65 73 74 72 65 6d 20 22 20 74 65 73 d " estrem " tes
a610: 74 73 20 72 65 6d 61 69 6e 69 6e 67 20 74 6f 20 ts remaining to
a620: 72 75 6e 2c 20 77 69 6c 6c 20 63 6f 6e 74 69 6e run, will contin
a630: 75 65 20 69 6e 20 33 20 73 65 63 6f 6e 64 73 20 ue in 3 seconds
a640: 2e 2e 2e 22 29 0a 09 09 20 20 28 74 68 72 65 61 ...")... (threa
a650: 64 2d 73 6c 65 65 70 21 20 33 29 0a 09 09 20 20 d-sleep! 3)...
a660: 28 72 75 6e 2d 77 61 69 74 69 6e 67 2d 74 65 73 (run-waiting-tes
a670: 74 73 20 64 62 29 0a 09 09 20 20 28 6c 6f 6f 70 ts db)... (loop
a680: 20 28 2b 20 6e 75 6d 74 69 6d 65 73 20 31 29 29 (+ numtimes 1))
a690: 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 )))))))..(define
a6a0: 20 28 72 75 6e 3a 74 65 73 74 20 64 62 20 72 75 (run:test db ru
a6b0: 6e 2d 69 64 20 72 75 6e 6e 61 6d 65 20 74 65 73 n-id runname tes
a6c0: 74 2d 6e 61 6d 65 20 6b 65 79 76 61 6c 6c 73 74 t-name keyvallst
a6d0: 20 69 74 65 6d 2d 70 61 74 74 73 20 66 6c 61 67 item-patts flag
a6e0: 73 29 0a 20 20 28 64 65 62 75 67 3a 70 72 69 6e s). (debug:prin
a6f0: 74 20 31 20 22 4c 61 75 6e 63 68 69 6e 67 20 74 t 1 "Launching t
a700: 65 73 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 29 est " test-name)
a710: 0a 20 20 3b 3b 20 41 6c 6c 20 74 68 65 73 65 20 . ;; All these
a720: 76 61 72 73 20 6d 69 67 68 74 20 62 65 20 72 65 vars might be re
a730: 66 65 72 65 6e 63 65 64 20 62 79 20 74 68 65 20 ferenced by the
a740: 74 65 73 74 63 6f 6e 66 69 67 20 66 69 6c 65 20 testconfig file
a750: 72 65 61 64 65 72 0a 20 20 28 73 65 74 65 6e 76 reader. (setenv
a760: 20 22 4d 54 5f 54 45 53 54 5f 4e 41 4d 45 22 20 "MT_TEST_NAME"
a770: 74 65 73 74 2d 6e 61 6d 65 29 20 3b 3b 20 0a 20 test-name) ;; .
a780: 20 28 73 65 74 65 6e 76 20 22 4d 54 5f 52 55 4e (setenv "MT_RUN
a790: 4e 41 4d 45 22 20 20 20 72 75 6e 6e 61 6d 65 29 NAME" runname)
a7a0: 0a 20 20 28 73 65 74 2d 6d 65 67 61 74 65 73 74 . (set-megatest
a7b0: 2d 65 6e 76 2d 76 61 72 73 20 64 62 20 72 75 6e -env-vars db run
a7c0: 2d 69 64 29 20 3b 3b 20 74 68 65 73 65 20 6d 61 -id) ;; these ma
a7d0: 79 20 62 65 20 6e 65 65 64 65 64 20 62 79 20 74 y be needed by t
a7e0: 68 65 20 6c 61 75 6e 63 68 69 6e 67 20 70 72 6f he launching pro
a7f0: 63 65 73 73 0a 20 20 28 63 68 61 6e 67 65 2d 64 cess. (change-d
a800: 69 72 65 63 74 6f 72 79 20 2a 74 6f 70 70 61 74 irectory *toppat
a810: 68 2a 29 0a 20 20 28 6c 65 74 2a 20 28 28 74 65 h*). (let* ((te
a820: 73 74 2d 70 61 74 68 20 20 20 20 28 63 6f 6e 63 st-path (conc
a830: 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 74 65 73 *toppath* "/tes
a840: 74 73 2f 22 20 74 65 73 74 2d 6e 61 6d 65 29 29 ts/" test-name))
a850: 20 3b 3b 20 63 6f 75 6c 64 20 75 73 65 20 74 65 ;; could use te
a860: 73 74 3a 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 st:get-testconfi
a870: 67 20 68 65 72 65 20 2e 2e 2e 0a 09 20 28 74 65 g here ..... (te
a880: 73 74 2d 63 6f 6e 66 69 67 66 20 28 63 6f 6e 63 st-configf (conc
a890: 20 74 65 73 74 2d 70 61 74 68 20 22 2f 74 65 73 test-path "/tes
a8a0: 74 63 6f 6e 66 69 67 22 29 29 0a 09 20 28 74 65 tconfig")).. (te
a8b0: 73 74 65 78 69 73 74 73 20 20 20 28 61 6e 64 20 stexists (and
a8c0: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 74 65 (file-exists? te
a8d0: 73 74 2d 63 6f 6e 66 69 67 66 29 28 66 69 6c 65 st-configf)(file
a8e0: 2d 72 65 61 64 2d 61 63 63 65 73 73 3f 20 74 65 -read-access? te
a8f0: 73 74 2d 63 6f 6e 66 69 67 66 29 29 29 0a 09 20 st-configf)))..
a900: 28 74 65 73 74 2d 63 6f 6e 66 20 20 20 20 28 69 (test-conf (i
a910: 66 20 74 65 73 74 65 78 69 73 74 73 20 28 72 65 f testexists (re
a920: 61 64 2d 63 6f 6e 66 69 67 20 74 65 73 74 2d 63 ad-config test-c
a930: 6f 6e 66 69 67 66 20 23 66 20 23 74 29 20 28 6d onfigf #f #t) (m
a940: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
a950: 29 0a 09 20 28 77 61 69 74 6f 6e 20 20 20 20 20 ).. (waiton
a960: 20 20 28 6c 65 74 20 28 28 77 20 28 63 6f 6e 66 (let ((w (conf
a970: 69 67 2d 6c 6f 6f 6b 75 70 20 74 65 73 74 2d 63 ig-lookup test-c
a980: 6f 6e 66 20 22 72 65 71 75 69 72 65 6d 65 6e 74 onf "requirement
a990: 73 22 20 22 77 61 69 74 6f 6e 22 29 29 29 0a 09 s" "waiton")))..
a9a0: 09 09 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 .. (if (string?
a9b0: 77 29 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 w)(string-split
a9c0: 77 29 27 28 29 29 29 29 0a 09 20 28 66 6f 72 63 w)'()))).. (forc
a9d0: 65 20 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 e (hash-t
a9e0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
a9f0: 20 66 6c 61 67 73 20 22 2d 66 6f 72 63 65 22 20 flags "-force"
aa00: 23 66 29 29 0a 09 20 28 72 65 72 75 6e 20 20 20 #f)).. (rerun
aa10: 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
aa20: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 66 6c 61 -ref/default fla
aa30: 67 73 20 22 2d 72 65 72 75 6e 22 20 23 66 29 29 gs "-rerun" #f))
aa40: 0a 09 20 28 6b 65 65 70 67 6f 69 6e 67 20 20 20 .. (keepgoing
aa50: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
aa60: 2f 64 65 66 61 75 6c 74 20 66 6c 61 67 73 20 22 /default flags "
aa70: 2d 6b 65 65 70 67 6f 69 6e 67 22 20 23 66 29 29 -keepgoing" #f))
aa80: 0a 09 20 3b 3b 20 41 72 65 20 74 68 65 73 65 20 .. ;; Are these
aa90: 74 61 67 73 20 73 74 69 6c 6c 20 75 73 65 64 3f tags still used?
aaa0: 20 49 20 64 6f 6e 27 74 20 74 68 69 6e 6b 20 73 I don't think s
aab0: 6f 2e 2e 2e 0a 09 20 3b 3b 28 74 61 67 73 20 20 o..... ;;(tags
aac0: 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 74 20 (let ((t
aad0: 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 74 (config-lookup t
aae0: 65 73 74 2d 63 6f 6e 66 20 22 73 65 74 75 70 22 est-conf "setup"
aaf0: 20 22 74 61 67 73 22 29 29 29 0a 09 20 3b 3b 20 "tags"))).. ;;
ab00: 20 20 20 20 20 20 09 20 3b 3b 20 77 65 20 77 61 . ;; we wa
ab10: 6e 74 20 6f 75 72 20 74 61 67 73 20 74 6f 20 62 nt our tags to b
ab20: 65 20 73 65 70 61 72 61 74 65 64 20 62 79 20 63 e separated by c
ab30: 6f 6d 6d 61 73 20 61 6e 64 20 66 75 6c 6c 79 20 ommas and fully
ab40: 64 65 6c 69 6d 69 74 65 64 20 62 79 20 63 6f 6d delimited by com
ab50: 6d 61 73 0a 09 20 3b 3b 20 20 20 20 20 20 20 09 mas.. ;; .
ab60: 20 3b 3b 20 73 6f 20 74 68 61 74 20 71 75 65 72 ;; so that quer
ab70: 69 65 73 20 77 69 74 68 20 22 6c 69 6b 65 22 20 ies with "like"
ab80: 63 61 6e 20 74 69 65 20 74 6f 20 74 68 65 20 63 can tie to the c
ab90: 6f 6d 6d 61 73 20 61 74 20 65 69 74 68 65 72 20 ommas at either
aba0: 65 6e 64 20 6f 66 20 65 61 63 68 20 74 61 67 0a end of each tag.
abb0: 09 20 3b 3b 20 20 20 20 20 20 20 09 20 3b 3b 20 . ;; . ;;
abc0: 77 68 69 6c 65 20 61 6c 73 6f 20 61 6c 6c 6f 77 while also allow
abd0: 69 6e 67 20 74 68 65 20 65 6e 64 20 75 73 65 72 ing the end user
abe0: 20 74 6f 20 66 72 65 65 6c 79 20 75 73 65 20 73 to freely use s
abf0: 70 61 63 65 73 20 61 6e 64 20 63 6f 6d 6d 61 73 paces and commas
ac00: 20 74 6f 20 73 65 70 61 72 61 74 65 20 74 61 67 to separate tag
ac10: 73 0a 09 20 3b 3b 20 20 20 20 20 20 20 09 20 28 s.. ;; . (
ac20: 69 66 20 28 73 74 72 69 6e 67 3f 20 74 29 28 73 if (string? t)(s
ac30: 74 72 69 6e 67 2d 73 75 62 73 74 69 74 75 74 65 tring-substitute
ac40: 20 28 72 65 67 65 78 70 20 22 5b 2c 5c 5c 73 5d (regexp "[,\\s]
ac50: 2b 22 29 20 22 2c 22 20 28 63 6f 6e 63 20 22 2c +") "," (conc ",
ac60: 22 20 74 20 22 2c 22 29 20 23 74 29 0a 09 20 3b " t ",") #t).. ;
ac70: 3b 20 20 20 20 20 20 20 09 20 20 20 20 20 27 28 ; . '(
ac80: 29 29 29 29 29 0a 09 20 29 0a 20 20 20 20 28 69 ))))).. ). (i
ac90: 66 20 28 6e 6f 74 20 74 65 73 74 65 78 69 73 74 f (not testexist
aca0: 73 29 0a 09 3b 3b 20 69 66 20 74 68 65 20 74 65 s)..;; if the te
acb0: 73 74 20 69 73 20 69 6c 6c 20 64 65 66 69 6e 65 st is ill define
acc0: 64 20 73 70 69 74 20 6f 75 74 20 61 6e 20 65 72 d spit out an er
acd0: 72 6f 72 20 62 75 74 20 6b 65 65 70 20 67 6f 69 ror but keep goi
ace0: 6e 67 20 28 64 69 66 66 65 72 65 6e 74 20 66 72 ng (different fr
acf0: 6f 6d 20 68 6f 77 20 64 6f 6e 65 20 70 72 65 76 om how done prev
ad00: 69 6f 75 73 6c 79 0a 09 28 64 65 62 75 67 3a 70 iously..(debug:p
ad10: 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 43 rint 0 "ERROR: C
ad20: 61 6e 27 74 20 66 69 6e 64 20 63 6f 6e 66 69 67 an't find config
ad30: 20 66 69 6c 65 20 22 20 74 65 73 74 2d 63 6f 6e file " test-con
ad40: 66 69 67 66 29 0a 09 3b 3b 20 70 75 74 20 74 6f figf)..;; put to
ad50: 70 20 76 61 72 73 20 69 6e 74 6f 20 63 6f 6e 76 p vars into conv
ad60: 65 6e 69 65 6e 74 20 76 61 72 69 61 62 6c 65 73 enient variables
ad70: 20 61 6e 64 20 6f 70 65 6e 20 74 68 65 20 64 62 and open the db
ad80: 0a 09 28 6c 65 74 2a 20 28 3b 3b 20 64 62 20 69 ..(let* (;; db i
ad90: 73 20 61 6c 77 61 79 73 20 61 74 20 2a 74 6f 70 s always at *top
ada0: 70 61 74 68 2a 2f 64 62 2f 6d 65 67 61 74 65 73 path*/db/megates
adb0: 74 2e 64 62 0a 09 20 20 20 20 20 20 20 28 69 74 t.db.. (it
adc0: 65 6d 73 20 20 20 20 20 20 20 28 68 61 73 68 2d ems (hash-
add0: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
ade0: 74 20 74 65 73 74 2d 63 6f 6e 66 20 22 69 74 65 t test-conf "ite
adf0: 6d 73 22 20 27 28 29 29 29 0a 09 20 20 20 20 20 ms" '()))..
ae00: 20 20 28 69 74 65 6d 73 74 61 62 6c 65 20 20 28 (itemstable (
ae10: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
ae20: 65 66 61 75 6c 74 20 74 65 73 74 2d 63 6f 6e 66 efault test-conf
ae30: 20 22 69 74 65 6d 73 74 61 62 6c 65 22 20 27 28 "itemstable" '(
ae40: 29 29 29 0a 09 20 20 20 20 20 20 20 28 61 6c 6c ))).. (all
ae50: 69 74 65 6d 73 20 20 20 20 28 69 66 20 28 6f 72 items (if (or
ae60: 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 69 74 65 (not (null? ite
ae70: 6d 73 29 29 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 ms))(not (null?
ae80: 69 74 65 6d 73 74 61 62 6c 65 29 29 29 0a 09 09 itemstable)))...
ae90: 09 09 28 61 70 70 65 6e 64 20 28 69 74 65 6d 2d ..(append (item-
aea0: 61 73 73 6f 63 2d 3e 69 74 65 6d 2d 6c 69 73 74 assoc->item-list
aeb0: 20 69 74 65 6d 73 29 0a 09 09 09 09 09 28 69 74 items)......(it
aec0: 65 6d 2d 74 61 62 6c 65 2d 3e 69 74 65 6d 2d 6c em-table->item-l
aed0: 69 73 74 20 69 74 65 6d 73 74 61 62 6c 65 29 29 ist itemstable))
aee0: 0a 09 09 09 09 27 28 28 29 29 29 29 29 20 3b 3b .....'(())))) ;;
aef0: 20 61 20 6c 69 73 74 20 77 69 74 68 20 6f 6e 65 a list with one
af00: 20 6e 75 6c 6c 20 6c 69 73 74 20 69 73 20 61 20 null list is a
af10: 74 65 73 74 20 77 69 74 68 20 6e 6f 20 69 74 65 test with no ite
af20: 6d 73 0a 09 20 20 3b 3b 20 28 72 75 6e 63 6f 6e ms.. ;; (runcon
af30: 66 69 67 66 20 20 28 63 6f 6e 63 20 20 2a 74 6f figf (conc *to
af40: 70 70 61 74 68 2a 20 22 2f 72 75 6e 63 6f 6e 66 ppath* "/runconf
af50: 69 67 73 2e 63 6f 6e 66 69 67 22 29 29 29 0a 09 igs.config")))..
af60: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 (debug:print 1
af70: 20 22 69 74 65 6d 73 3a 20 22 29 0a 09 20 20 28 "items: ").. (
af80: 69 66 20 28 3e 3d 20 2a 76 65 72 62 6f 73 69 74 if (>= *verbosit
af90: 79 2a 20 31 29 28 70 70 20 61 6c 6c 69 74 65 6d y* 1)(pp allitem
afa0: 73 29 29 0a 09 20 20 28 69 66 20 28 3e 3d 20 2a s)).. (if (>= *
afb0: 76 65 72 62 6f 73 69 74 79 2a 20 35 29 0a 09 20 verbosity* 5)..
afc0: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 28 70 (begin...(p
afd0: 72 69 6e 74 20 22 69 74 65 6d 73 3a 20 22 29 28 rint "items: ")(
afe0: 70 70 20 28 69 74 65 6d 2d 61 73 73 6f 63 2d 3e pp (item-assoc->
aff0: 69 74 65 6d 2d 6c 69 73 74 20 69 74 65 6d 73 29 item-list items)
b000: 29 0a 09 09 28 70 72 69 6e 74 20 22 69 74 65 6d )...(print "item
b010: 73 74 61 62 6c 65 3a 20 22 29 28 70 70 20 28 69 stable: ")(pp (i
b020: 74 65 6d 2d 74 61 62 6c 65 2d 3e 69 74 65 6d 2d tem-table->item-
b030: 6c 69 73 74 20 69 74 65 6d 73 74 61 62 6c 65 29 list itemstable)
b040: 29 29 29 0a 0a 09 20 20 3b 3b 20 43 6f 6d 6d 65 )))... ;; Comme
b050: 6e 74 73 20 61 72 65 20 6c 6f 61 64 65 64 20 62 nts are loaded b
b060: 79 20 74 68 65 20 74 65 73 74 20 72 75 6e 2c 20 y the test run,
b070: 6e 6f 74 20 61 74 20 6c 61 75 6e 63 68 20 74 69 not at launch ti
b080: 6d 65 20 28 69 6e 20 67 65 6e 65 72 61 6c 29 0a me (in general).
b090: 09 20 20 3b 3b 28 69 66 20 28 61 72 67 73 3a 67 . ;;(if (args:g
b0a0: 65 74 2d 61 72 67 20 22 2d 6d 22 29 0a 09 20 20 et-arg "-m")..
b0b0: 3b 3b 20 20 20 20 28 64 62 3a 73 65 74 2d 63 6f ;; (db:set-co
b0c0: 6d 6d 65 6e 74 2d 66 6f 72 2d 72 75 6e 20 64 62 mment-for-run db
b0d0: 20 72 75 6e 2d 69 64 20 28 61 72 67 73 3a 67 65 run-id (args:ge
b0e0: 74 2d 61 72 67 20 22 2d 6d 22 29 29 29 0a 0a 09 t-arg "-m")))...
b0f0: 20 20 3b 3b 20 48 65 72 65 20 69 73 20 77 68 65 ;; Here is whe
b100: 72 65 20 74 68 65 20 74 65 73 74 5f 6d 65 74 61 re the test_meta
b110: 20 74 61 62 6c 65 20 69 73 20 62 65 73 74 20 75 table is best u
b120: 70 64 61 74 65 64 0a 09 20 20 28 72 75 6e 73 3a pdated.. (runs:
b130: 75 70 64 61 74 65 2d 74 65 73 74 5f 6d 65 74 61 update-test_meta
b140: 20 64 62 20 74 65 73 74 2d 6e 61 6d 65 20 74 65 db test-name te
b150: 73 74 2d 63 6f 6e 66 29 0a 0a 09 20 20 3b 3b 20 st-conf)... ;;
b160: 62 72 61 69 6e 64 65 61 64 20 77 6f 72 6b 2d 61 braindead work-a
b170: 72 6f 75 6e 64 20 66 6f 72 20 70 6f 6f 72 6c 79 round for poorly
b180: 20 73 70 65 63 69 66 69 65 64 20 61 6c 6c 69 74 specified allit
b190: 65 6d 73 20 6c 69 73 74 20 42 55 47 21 21 21 20 ems list BUG!!!
b1a0: 46 49 58 4d 45 0a 09 20 20 28 69 66 20 28 6e 75 FIXME.. (if (nu
b1b0: 6c 6c 3f 20 61 6c 6c 69 74 65 6d 73 29 28 73 65 ll? allitems)(se
b1c0: 74 21 20 61 6c 6c 69 74 65 6d 73 20 27 28 28 29 t! allitems '(()
b1d0: 29 29 29 0a 09 20 20 28 6c 65 74 20 6c 6f 6f 70 ))).. (let loop
b1e0: 20 28 28 69 74 65 6d 64 61 74 20 28 63 61 72 20 ((itemdat (car
b1f0: 61 6c 6c 69 74 65 6d 73 29 29 0a 09 09 20 20 20 allitems))...
b200: 20 20 28 74 61 6c 20 20 20 20 20 28 63 64 72 20 (tal (cdr
b210: 61 6c 6c 69 74 65 6d 73 29 29 29 0a 09 20 20 20 allitems)))..
b220: 20 3b 3b 20 28 6c 61 6d 62 64 61 20 28 69 74 65 ;; (lambda (ite
b230: 6d 64 61 74 29 20 3b 3b 3b 20 28 28 72 69 70 65 mdat) ;;; ((ripe
b240: 6e 65 73 73 20 22 6f 76 65 72 72 69 70 65 22 29 ness "overripe")
b250: 20 28 74 65 6d 70 65 72 61 74 75 72 65 20 22 63 (temperature "c
b260: 6f 6f 6c 22 29 20 28 73 65 61 73 6f 6e 20 22 73 ool") (season "s
b270: 75 6d 6d 65 72 22 29 29 0a 09 20 20 20 20 3b 3b ummer")).. ;;
b280: 20 48 61 6e 64 6c 65 20 6c 69 73 74 73 20 6f 66 Handle lists of
b290: 20 69 74 65 6d 73 0a 09 20 20 20 20 28 6c 65 74 items.. (let
b2a0: 2a 20 28 28 69 74 65 6d 2d 70 61 74 68 20 20 20 * ((item-path
b2b0: 20 20 28 69 74 65 6d 2d 6c 69 73 74 2d 3e 70 61 (item-list->pa
b2c0: 74 68 20 69 74 65 6d 64 61 74 29 29 20 3b 3b 20 th itemdat)) ;;
b2d0: 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 (string-interspe
b2e0: 72 73 65 20 28 6d 61 70 20 63 61 64 72 20 69 74 rse (map cadr it
b2f0: 65 6d 64 61 74 29 20 22 2f 22 29 29 0a 09 09 20 emdat) "/"))...
b300: 20 20 28 6e 65 77 2d 74 65 73 74 2d 70 61 74 68 (new-test-path
b310: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
b320: 65 72 73 65 20 28 63 6f 6e 73 20 74 65 73 74 2d erse (cons test-
b330: 70 61 74 68 20 28 6d 61 70 20 63 61 64 72 20 69 path (map cadr i
b340: 74 65 6d 64 61 74 29 29 20 22 2f 22 29 29 0a 09 temdat)) "/"))..
b350: 09 20 20 20 28 6e 65 77 2d 74 65 73 74 2d 6e 61 . (new-test-na
b360: 6d 65 20 28 69 66 20 28 65 71 75 61 6c 3f 20 69 me (if (equal? i
b370: 74 65 6d 2d 70 61 74 68 20 22 22 29 20 74 65 73 tem-path "") tes
b380: 74 2d 6e 61 6d 65 20 28 63 6f 6e 63 20 74 65 73 t-name (conc tes
b390: 74 2d 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d t-name "/" item-
b3a0: 70 61 74 68 29 29 29 20 3b 3b 20 6a 75 73 74 20 path))) ;; just
b3b0: 6e 65 65 64 20 69 74 20 74 6f 20 62 65 20 75 6e need it to be un
b3c0: 69 71 75 65 0a 09 09 20 20 20 28 74 65 73 74 64 ique... (testd
b3d0: 61 74 20 20 20 23 66 29 0a 09 09 20 20 20 28 6e at #f)... (n
b3e0: 75 6d 2d 72 75 6e 6e 69 6e 67 20 28 64 62 3a 67 um-running (db:g
b3f0: 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d 72 et-count-tests-r
b400: 75 6e 6e 69 6e 67 20 64 62 29 29 0a 09 09 20 20 unning db))...
b410: 20 28 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 (max-concurrent
b420: 2d 6a 6f 62 73 20 28 63 6f 6e 66 69 67 2d 6c 6f -jobs (config-lo
b430: 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a okup *configdat*
b440: 20 22 73 65 74 75 70 22 20 22 6d 61 78 5f 63 6f "setup" "max_co
b450: 6e 63 75 72 72 65 6e 74 5f 6a 6f 62 73 22 29 29 ncurrent_jobs"))
b460: 0a 09 09 20 20 20 28 70 61 72 65 6e 74 2d 74 65 ... (parent-te
b470: 73 74 20 28 61 6e 64 20 28 6e 6f 74 20 28 6e 75 st (and (not (nu
b480: 6c 6c 3f 20 69 74 65 6d 73 29 29 28 65 71 75 61 ll? items))(equa
b490: 6c 3f 20 69 74 65 6d 2d 70 61 74 68 20 22 22 29 l? item-path "")
b4a0: 29 29 0a 09 09 20 20 20 28 73 69 6e 67 6c 65 2d ))... (single-
b4b0: 74 65 73 74 20 28 61 6e 64 20 28 6e 75 6c 6c 3f test (and (null?
b4c0: 20 69 74 65 6d 73 29 20 28 65 71 75 61 6c 3f 20 items) (equal?
b4d0: 69 74 65 6d 2d 70 61 74 68 20 22 22 29 29 29 0a item-path ""))).
b4e0: 09 09 20 20 20 28 69 74 65 6d 2d 74 65 73 74 20 .. (item-test
b4f0: 20 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 69 (not (equal? i
b500: 74 65 6d 2d 70 61 74 68 20 22 22 29 29 29 0a 09 tem-path "")))..
b510: 09 20 20 20 3b 3b 20 6c 6f 6f 6b 20 74 68 72 6f . ;; look thro
b520: 75 67 68 20 61 6c 6c 20 74 68 65 20 69 74 65 6d ugh all the item
b530: 2d 70 61 74 74 73 20 69 66 20 64 65 66 69 6e 65 -patts if define
b540: 64 2c 20 66 6f 72 6d 61 74 20 69 73 20 70 61 74 d, format is pat
b550: 74 31 2c 70 61 74 74 32 2c 70 61 74 74 33 20 2e t1,patt2,patt3 .
b560: 2e 2e 20 77 69 6c 64 63 61 72 64 20 69 73 20 25 .. wildcard is %
b570: 0a 09 09 20 20 20 28 69 74 65 6d 2d 6d 61 74 63 ... (item-matc
b580: 68 65 73 20 28 69 66 20 69 74 65 6d 2d 70 61 74 hes (if item-pat
b590: 74 73 0a 09 09 09 09 20 20 20 20 20 28 6c 65 74 ts..... (let
b5a0: 20 28 28 72 65 73 20 23 66 29 29 0a 09 09 09 09 ((res #f)).....
b5b0: 20 20 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 (for-each
b5c0: 20 0a 09 09 09 09 09 28 6c 61 6d 62 64 61 20 28 ......(lambda (
b5d0: 70 61 74 74 29 0a 09 09 09 09 09 20 20 28 69 66 patt)...... (if
b5e0: 20 28 73 74 72 69 6e 67 2d 73 65 61 72 63 68 20 (string-search
b5f0: 28 67 6c 6f 62 2d 3e 72 65 67 65 78 70 0a 09 09 (glob->regexp...
b600: 09 09 09 09 09 20 20 20 20 20 20 28 73 74 72 69 ..... (stri
b610: 6e 67 2d 74 72 61 6e 73 6c 61 74 65 20 70 61 74 ng-translate pat
b620: 74 20 22 25 22 20 22 2a 22 29 29 0a 09 09 09 09 t "%" "*")).....
b630: 09 09 09 20 20 20 20 20 69 74 65 6d 2d 70 61 74 ... item-pat
b640: 68 29 0a 09 09 09 09 09 20 20 20 20 20 20 28 73 h)...... (s
b650: 65 74 21 20 72 65 73 20 23 74 29 29 29 0a 09 09 et! res #t)))...
b660: 09 09 09 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 ...(string-split
b670: 20 69 74 65 6d 2d 70 61 74 74 73 20 22 2c 22 29 item-patts ",")
b680: 29 0a 09 09 09 09 20 20 20 20 20 20 20 72 65 73 )..... res
b690: 29 0a 09 09 09 09 20 20 20 20 20 23 74 29 29 29 )..... #t)))
b6a0: 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 .. (debug:p
b6b0: 72 69 6e 74 20 33 20 22 6d 61 78 2d 63 6f 6e 63 rint 3 "max-conc
b6c0: 75 72 72 65 6e 74 2d 6a 6f 62 73 3a 20 22 20 6d urrent-jobs: " m
b6d0: 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f ax-concurrent-jo
b6e0: 62 73 20 22 2c 20 6e 75 6d 2d 72 75 6e 6e 69 6e bs ", num-runnin
b6f0: 67 3a 20 22 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 g: " num-running
b700: 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 61 6e ).. (if (an
b710: 64 20 69 74 65 6d 2d 6d 61 74 63 68 65 73 20 28 d item-matches (
b720: 72 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 runs:can-run-mor
b730: 65 2d 74 65 73 74 73 20 64 62 29 29 0a 09 09 20 e-tests db))...
b740: 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 28 6c (begin... (l
b750: 65 74 20 6c 6f 6f 70 32 20 28 28 74 73 20 28 64 et loop2 ((ts (d
b760: 62 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 20 b:get-test-info
b770: 64 62 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e db run-id test-n
b780: 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 20 ame item-path))
b790: 3b 3b 20 23 66 29 0a 09 09 09 09 28 63 74 20 30 ;; #f).....(ct 0
b7a0: 29 29 0a 09 09 20 20 20 20 20 20 28 69 66 20 28 ))... (if (
b7b0: 61 6e 64 20 28 6e 6f 74 20 74 73 29 0a 09 09 09 and (not ts)....
b7c0: 20 20 20 20 20 20 20 28 3c 20 63 74 20 31 30 29 (< ct 10)
b7d0: 29 0a 09 09 09 20 20 28 62 65 67 69 6e 0a 09 09 ).... (begin...
b7e0: 09 20 20 20 20 28 72 65 67 69 73 74 65 72 2d 74 . (register-t
b7f0: 65 73 74 20 64 62 20 72 75 6e 2d 69 64 20 74 65 est db run-id te
b800: 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 st-name item-pat
b810: 68 29 0a 09 09 09 20 20 20 20 3b 3b 20 57 68 79 h).... ;; Why
b820: 20 64 69 64 20 49 20 73 65 74 20 74 68 65 20 63 did I set the c
b830: 6f 6d 6d 65 6e 74 20 68 65 72 65 3f 21 3f 20 50 omment here?!? P
b840: 4f 53 53 49 42 4c 45 20 42 55 47 20 42 55 54 20 OSSIBLE BUG BUT
b850: 49 27 4d 20 52 45 4d 4f 56 49 4e 47 20 49 54 20 I'M REMOVING IT
b860: 46 4f 52 20 4e 4f 57 20 31 30 2f 32 33 2f 32 30 FOR NOW 10/23/20
b870: 31 31 0a 09 09 09 20 20 20 20 3b 3b 20 28 64 62 11.... ;; (db
b880: 3a 74 65 73 74 2d 73 65 74 2d 63 6f 6d 6d 65 6e :test-set-commen
b890: 74 20 64 62 20 72 75 6e 2d 69 64 20 74 65 73 74 t db run-id test
b8a0: 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 -name item-path
b8b0: 22 22 29 0a 09 09 09 20 20 20 20 28 6c 6f 6f 70 "").... (loop
b8c0: 32 20 28 64 62 3a 67 65 74 2d 74 65 73 74 2d 69 2 (db:get-test-i
b8d0: 6e 66 6f 20 64 62 20 72 75 6e 2d 69 64 20 74 65 nfo db run-id te
b8e0: 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 st-name item-pat
b8f0: 68 29 0a 09 09 09 09 20 20 20 28 2b 20 63 74 20 h)..... (+ ct
b900: 31 29 29 29 0a 09 09 09 20 20 28 69 66 20 74 73 1))).... (if ts
b910: 0a 09 09 09 20 20 20 20 20 20 28 73 65 74 21 20 .... (set!
b920: 74 65 73 74 64 61 74 20 74 73 29 0a 09 09 09 20 testdat ts)....
b930: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 09 (begin.....
b940: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
b950: 57 41 52 4e 49 4e 47 3a 20 43 6f 75 6c 64 6e 27 WARNING: Couldn'
b960: 74 20 72 65 67 69 73 74 65 72 20 74 65 73 74 20 t register test
b970: 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 77 69 " test-name " wi
b980: 74 68 20 69 74 65 6d 20 70 61 74 68 20 22 20 69 th item path " i
b990: 74 65 6d 2d 70 61 74 68 20 22 2c 20 73 6b 69 70 tem-path ", skip
b9a0: 70 69 6e 67 22 29 0a 09 09 09 09 28 69 66 20 28 ping").....(if (
b9b0: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 not (null? tal))
b9c0: 0a 09 09 09 09 20 20 20 20 28 6c 6f 6f 70 20 28 ..... (loop (
b9d0: 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c car tal)(cdr tal
b9e0: 29 29 29 29 29 29 29 0a 09 09 20 20 20 20 28 63 )))))))... (c
b9f0: 68 61 6e 67 65 2d 64 69 72 65 63 74 6f 72 79 20 hange-directory
ba00: 74 65 73 74 2d 70 61 74 68 29 0a 09 09 20 20 20 test-path)...
ba10: 20 3b 3b 20 74 68 69 73 20 62 6c 6f 63 6b 20 69 ;; this block i
ba20: 73 20 68 65 72 65 20 6f 6e 6c 79 20 74 6f 20 69 s here only to i
ba30: 6e 66 6f 72 6d 20 74 68 65 20 75 73 65 72 20 65 nform the user e
ba40: 61 72 6c 79 20 6f 6e 0a 09 09 20 20 20 20 0a 09 arly on... ..
ba50: 09 20 20 20 20 3b 3b 20 4d 6f 76 69 6e 67 20 74 . ;; Moving t
ba60: 68 69 73 20 74 6f 20 74 68 65 20 72 75 6e 20 63 his to the run c
ba70: 61 6c 6c 69 6e 67 20 62 6c 6f 63 6b 0a 0a 09 09 alling block....
ba80: 20 20 20 20 3b 3b 20 28 69 66 20 28 66 69 6c 65 ;; (if (file
ba90: 2d 65 78 69 73 74 73 3f 20 72 75 6e 63 6f 6e 66 -exists? runconf
baa0: 69 67 66 29 0a 09 09 20 20 20 20 3b 3b 20 20 20 igf)... ;;
bab0: 20 20 28 73 65 74 75 70 2d 65 6e 76 2d 64 65 66 (setup-env-def
bac0: 61 75 6c 74 73 20 64 62 20 72 75 6e 63 6f 6e 66 aults db runconf
bad0: 69 67 66 20 72 75 6e 2d 69 64 20 2a 61 6c 72 65 igf run-id *alre
bae0: 61 64 79 2d 73 65 65 6e 2d 72 75 6e 63 6f 6e 66 ady-seen-runconf
baf0: 69 67 2d 69 6e 66 6f 2a 29 0a 09 09 20 20 20 20 ig-info*)...
bb00: 3b 3b 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 ;; (debug:pr
bb10: 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 int 0 "WARNING:
bb20: 59 6f 75 20 64 6f 20 6e 6f 74 20 68 61 76 65 20 You do not have
bb30: 61 20 72 75 6e 20 63 6f 6e 66 69 67 20 66 69 6c a run config fil
bb40: 65 3a 20 22 20 72 75 6e 63 6f 6e 66 69 67 66 29 e: " runconfigf)
bb50: 29 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 )... (debug:p
bb60: 72 69 6e 74 20 34 20 22 72 75 6e 2d 69 64 3a 20 rint 4 "run-id:
bb70: 22 20 72 75 6e 2d 69 64 20 22 20 74 65 73 74 2d " run-id " test-
bb80: 6e 61 6d 65 3a 20 22 20 74 65 73 74 2d 6e 61 6d name: " test-nam
bb90: 65 20 22 20 69 74 65 6d 2d 70 61 74 68 3a 20 22 e " item-path: "
bba0: 20 69 74 65 6d 2d 70 61 74 68 20 22 20 74 65 73 item-path " tes
bbb0: 74 64 61 74 3a 20 22 20 28 74 65 73 74 3a 67 65 tdat: " (test:ge
bbc0: 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 74 t-status testdat
bbd0: 29 20 22 20 74 65 73 74 2d 73 74 61 74 65 3a 20 ) " test-state:
bbe0: 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 " (test:get-stat
bbf0: 65 20 74 65 73 74 64 61 74 29 29 0a 09 09 20 20 e testdat))...
bc00: 20 20 28 63 61 73 65 20 28 69 66 20 66 6f 72 63 (case (if forc
bc10: 65 20 3b 3b 20 28 61 72 67 73 3a 67 65 74 2d 61 e ;; (args:get-a
bc20: 72 67 20 22 2d 66 6f 72 63 65 22 29 0a 09 09 09 rg "-force")....
bc30: 20 20 20 20 20 20 27 4e 4f 54 5f 53 54 41 52 54 'NOT_START
bc40: 45 44 0a 09 09 09 20 20 20 20 20 20 28 69 66 20 ED.... (if
bc50: 74 65 73 74 64 61 74 0a 09 09 09 09 20 20 28 73 testdat..... (s
bc60: 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 74 tring->symbol (t
bc70: 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 est:get-state te
bc80: 73 74 64 61 74 29 29 0a 09 09 09 09 20 20 27 66 stdat))..... 'f
bc90: 61 69 6c 65 64 2d 74 6f 2d 69 6e 73 65 72 74 29 ailed-to-insert)
bca0: 29 0a 09 09 20 20 20 20 20 20 28 28 66 61 69 6c )... ((fail
bcb0: 65 64 2d 74 6f 2d 69 6e 73 65 72 74 29 0a 09 09 ed-to-insert)...
bcc0: 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 (debug:pr
bcd0: 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 46 61 int 0 "ERROR: Fa
bce0: 69 6c 65 64 20 74 6f 20 69 6e 73 65 72 74 20 74 iled to insert t
bcf0: 68 65 20 72 65 63 6f 72 64 20 69 6e 74 6f 20 74 he record into t
bd00: 68 65 20 64 62 22 29 29 0a 09 09 20 20 20 20 20 he db"))...
bd10: 20 28 28 4e 4f 54 5f 53 54 41 52 54 45 44 20 43 ((NOT_STARTED C
bd20: 4f 4d 50 4c 45 54 45 44 29 0a 09 09 20 20 20 20 OMPLETED)...
bd30: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
bd40: 36 20 22 47 6f 74 20 68 65 72 65 2c 20 22 20 28 6 "Got here, " (
bd50: 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 test:get-state t
bd60: 65 73 74 64 61 74 29 29 0a 09 09 20 20 20 20 20 estdat))...
bd70: 20 20 28 6c 65 74 20 28 28 72 75 6e 66 6c 61 67 (let ((runflag
bd80: 20 23 66 29 29 0a 09 09 09 20 28 63 6f 6e 64 0a #f)).... (cond.
bd90: 09 09 09 20 20 3b 3b 20 69 2e 65 2e 20 74 68 69 ... ;; i.e. thi
bda0: 73 20 69 73 20 74 68 65 20 70 61 72 65 6e 74 20 s is the parent
bdb0: 74 65 73 74 20 74 6f 20 61 20 73 75 69 74 65 20 test to a suite
bdc0: 6f 66 20 69 74 65 6d 73 2c 20 6e 65 76 65 72 20 of items, never
bdd0: 22 72 75 6e 22 20 69 74 0a 09 09 09 20 20 28 70 "run" it.... (p
bde0: 61 72 65 6e 74 2d 74 65 73 74 0a 09 09 09 20 20 arent-test....
bdf0: 20 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 (set! runflag #
be00: 66 29 29 0a 09 09 09 20 20 3b 3b 20 2d 66 6f 72 f)).... ;; -for
be10: 63 65 2c 20 72 75 6e 20 6e 6f 20 6d 61 74 74 65 ce, run no matte
be20: 72 20 77 68 61 74 0a 09 09 09 20 20 28 66 6f 72 r what.... (for
be30: 63 65 20 28 73 65 74 21 20 72 75 6e 66 6c 61 67 ce (set! runflag
be40: 20 23 74 29 29 0a 09 09 09 20 20 3b 3b 20 4e 4f #t)).... ;; NO
be50: 54 5f 53 54 41 52 54 45 44 2c 20 72 75 6e 20 6e T_STARTED, run n
be60: 6f 20 6d 61 74 74 65 72 20 77 68 61 74 0a 09 09 o matter what...
be70: 09 20 20 28 28 65 71 75 61 6c 3f 20 28 74 65 73 . ((equal? (tes
be80: 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 t:get-state test
be90: 64 61 74 29 20 22 4e 4f 54 5f 53 54 41 52 54 45 dat) "NOT_STARTE
bea0: 44 22 29 28 73 65 74 21 20 72 75 6e 66 6c 61 67 D")(set! runflag
beb0: 20 23 74 29 29 0a 09 09 09 20 20 3b 3b 20 6e 6f #t)).... ;; no
bec0: 74 20 2d 72 65 72 75 6e 20 61 6e 64 20 50 41 53 t -rerun and PAS
bed0: 53 2c 20 57 41 52 4e 20 6f 72 20 43 48 45 43 4b S, WARN or CHECK
bee0: 2c 20 64 6f 20 6e 6f 20 72 75 6e 0a 09 09 09 20 , do no run....
bef0: 20 28 28 61 6e 64 20 28 6f 72 20 28 6e 6f 74 20 ((and (or (not
bf00: 72 65 72 75 6e 29 0a 09 09 09 09 20 20 20 20 6b rerun)..... k
bf10: 65 65 70 67 6f 69 6e 67 29 0a 09 09 09 09 28 6d eepgoing).....(m
bf20: 65 6d 62 65 72 20 28 74 65 73 74 3a 67 65 74 2d ember (test:get-
bf30: 73 74 61 74 75 73 20 74 65 73 74 64 61 74 29 20 status testdat)
bf40: 27 28 22 50 41 53 53 22 20 22 57 41 52 4e 22 20 '("PASS" "WARN"
bf50: 22 43 48 45 43 4b 22 29 29 29 0a 09 09 09 20 20 "CHECK")))....
bf60: 20 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 (set! runflag #
bf70: 66 29 29 0a 09 09 09 20 20 3b 3b 20 2d 72 65 72 f)).... ;; -rer
bf80: 75 6e 20 61 6e 64 20 73 74 61 74 75 73 20 69 73 un and status is
bf90: 20 6f 6e 65 20 6f 66 20 74 68 65 20 73 70 65 63 one of the spec
bfa0: 69 66 65 64 2c 20 72 75 6e 20 69 74 0a 09 09 09 ifed, run it....
bfb0: 20 20 28 28 61 6e 64 20 72 65 72 75 6e 0a 09 09 ((and rerun...
bfc0: 09 09 28 6c 65 74 20 28 28 72 65 72 75 6e 6c 73 ..(let ((rerunls
bfd0: 74 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 t (string-split
bfe0: 72 65 72 75 6e 20 22 2c 22 29 29 29 20 3b 3b 20 rerun ","))) ;;
bff0: 46 41 49 4c 2c 0a 09 09 09 09 20 20 28 6d 65 6d FAIL,..... (mem
c000: 62 65 72 20 28 74 65 73 74 3a 67 65 74 2d 73 74 ber (test:get-st
c010: 61 74 75 73 20 74 65 73 74 64 61 74 29 20 72 65 atus testdat) re
c020: 72 75 6e 6c 73 74 29 29 29 0a 09 09 09 20 20 20 runlst)))....
c030: 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 74 (set! runflag #t
c040: 29 29 0a 09 09 09 20 20 3b 3b 20 2d 6b 65 65 70 )).... ;; -keep
c050: 67 6f 69 6e 67 2c 20 64 6f 20 6e 6f 74 20 72 65 going, do not re
c060: 72 75 6e 20 46 41 49 4c 0a 09 09 09 20 20 28 28 run FAIL.... ((
c070: 61 6e 64 20 6b 65 65 70 67 6f 69 6e 67 0a 09 09 and keepgoing...
c080: 09 09 28 6d 65 6d 62 65 72 20 28 74 65 73 74 3a ..(member (test:
c090: 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 get-status testd
c0a0: 61 74 29 20 27 28 22 46 41 49 4c 22 29 29 29 0a at) '("FAIL"))).
c0b0: 09 09 09 20 20 20 28 73 65 74 21 20 72 75 6e 66 ... (set! runf
c0c0: 6c 61 67 20 23 66 29 29 0a 09 09 09 20 20 28 28 lag #f)).... ((
c0d0: 61 6e 64 20 28 6e 6f 74 20 72 65 72 75 6e 29 0a and (not rerun).
c0e0: 09 09 09 09 28 6d 65 6d 62 65 72 20 28 74 65 73 ....(member (tes
c0f0: 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 t:get-status tes
c100: 74 64 61 74 29 20 27 28 22 46 41 49 4c 22 20 22 tdat) '("FAIL" "
c110: 6e 2f 61 22 29 29 29 0a 09 09 09 20 20 20 28 73 n/a"))).... (s
c120: 65 74 21 20 72 75 6e 66 6c 61 67 20 23 74 29 29 et! runflag #t))
c130: 0a 09 09 09 20 20 28 65 6c 73 65 20 28 73 65 74 .... (else (set
c140: 21 20 72 75 6e 66 6c 61 67 20 23 66 29 29 29 0a ! runflag #f))).
c150: 09 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ... (debug:print
c160: 20 36 20 22 52 55 4e 4e 49 4e 47 20 3d 3e 20 72 6 "RUNNING => r
c170: 75 6e 66 6c 61 67 3a 20 22 20 72 75 6e 66 6c 61 unflag: " runfla
c180: 67 20 22 20 53 54 41 54 45 3a 20 22 20 28 74 65 g " STATE: " (te
c190: 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 73 st:get-state tes
c1a0: 74 64 61 74 29 20 22 20 53 54 41 54 55 53 3a 20 tdat) " STATUS:
c1b0: 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 " (test:get-stat
c1c0: 75 73 20 74 65 73 74 64 61 74 29 29 0a 09 09 09 us testdat))....
c1d0: 20 28 69 66 20 28 6e 6f 74 20 72 75 6e 66 6c 61 (if (not runfla
c1e0: 67 29 0a 09 09 09 20 20 20 20 20 28 69 66 20 28 g).... (if (
c1f0: 6e 6f 74 20 70 61 72 65 6e 74 2d 74 65 73 74 29 not parent-test)
c200: 0a 09 09 09 09 20 28 64 65 62 75 67 3a 70 72 69 ..... (debug:pri
c210: 6e 74 20 31 20 22 4e 4f 54 45 3a 20 4e 6f 74 20 nt 1 "NOTE: Not
c220: 73 74 61 72 74 69 6e 67 20 74 65 73 74 20 22 20 starting test "
c230: 6e 65 77 2d 74 65 73 74 2d 6e 61 6d 65 20 22 20 new-test-name "
c240: 61 73 20 69 74 20 69 73 20 73 74 61 74 65 20 5c as it is state \
c250: 22 43 4f 4d 50 4c 45 54 45 44 5c 22 20 61 6e 64 "COMPLETED\" and
c260: 20 73 74 61 74 75 73 20 5c 22 22 20 28 74 65 73 status \"" (tes
c270: 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 t:get-status tes
c280: 74 64 61 74 29 20 22 5c 22 2c 20 75 73 65 20 2d tdat) "\", use -
c290: 66 6f 72 63 65 20 74 6f 20 6f 76 65 72 72 69 64 force to overrid
c2a0: 65 22 29 29 0a 09 09 09 20 20 20 20 20 28 6c 65 e")).... (le
c2b0: 74 2a 20 28 28 67 65 74 2d 70 72 65 72 65 71 73 t* ((get-prereqs
c2c0: 2d 63 6d 64 20 28 6c 61 6d 62 64 61 20 28 29 0a -cmd (lambda ().
c2d0: 09 09 09 09 09 09 20 20 20 20 20 20 20 28 64 62 ...... (db
c2e0: 2d 67 65 74 2d 70 72 65 72 65 71 73 2d 6e 6f 74 -get-prereqs-not
c2f0: 2d 6d 65 74 20 64 62 20 72 75 6e 2d 69 64 20 77 -met db run-id w
c300: 61 69 74 6f 6e 29 29 29 20 3b 3b 20 63 68 65 63 aiton))) ;; chec
c310: 6b 20 62 65 66 6f 72 65 20 72 75 6e 6e 69 6e 67 k before running
c320: 20 2e 2e 2e 2e 0a 09 09 09 09 20 20 20 20 28 6c ......... (l
c330: 61 75 6e 63 68 2d 63 6d 64 20 20 20 20 20 20 28 aunch-cmd (
c340: 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 09 09 09 lambda ().......
c350: 20 20 20 20 20 20 20 28 6c 61 75 6e 63 68 2d 74 (launch-t
c360: 65 73 74 20 64 62 20 72 75 6e 2d 69 64 20 72 75 est db run-id ru
c370: 6e 6e 61 6d 65 20 74 65 73 74 2d 63 6f 6e 66 20 nname test-conf
c380: 6b 65 79 76 61 6c 6c 73 74 20 74 65 73 74 2d 6e keyvallst test-n
c390: 61 6d 65 20 74 65 73 74 2d 70 61 74 68 20 69 74 ame test-path it
c3a0: 65 6d 64 61 74 20 66 6c 61 67 73 29 29 29 0a 09 emdat flags)))..
c3b0: 09 09 09 20 20 20 20 28 74 65 73 74 72 75 6e 64 ... (testrund
c3c0: 61 74 20 20 20 20 20 20 28 6c 69 73 74 20 67 65 at (list ge
c3d0: 74 2d 70 72 65 72 65 71 73 2d 63 6d 64 20 6c 61 t-prereqs-cmd la
c3e0: 75 6e 63 68 2d 63 6d 64 29 29 29 0a 09 09 09 20 unch-cmd)))....
c3f0: 20 20 20 20 20 20 28 69 66 20 28 6f 72 20 66 6f (if (or fo
c400: 72 63 65 0a 09 09 09 09 20 20 20 20 20 20 20 28 rce..... (
c410: 6c 65 74 20 28 28 70 72 65 71 73 2d 6e 6f 74 2d let ((preqs-not-
c420: 79 65 74 2d 6d 65 74 20 28 28 63 61 72 20 74 65 yet-met ((car te
c430: 73 74 72 75 6e 64 61 74 29 29 29 29 0a 09 09 09 strundat))))....
c440: 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 .. (debug:print
c450: 32 20 22 50 72 65 71 72 65 71 75 65 73 69 74 65 2 "Preqrequesite
c460: 73 20 66 6f 72 20 22 20 74 65 73 74 2d 6e 61 6d s for " test-nam
c470: 65 20 22 3a 20 22 20 70 72 65 71 73 2d 6e 6f 74 e ": " preqs-not
c480: 2d 79 65 74 2d 6d 65 74 29 0a 09 09 09 09 09 20 -yet-met)......
c490: 28 6e 75 6c 6c 3f 20 70 72 65 71 73 2d 6e 6f 74 (null? preqs-not
c4a0: 2d 79 65 74 2d 6d 65 74 29 29 29 20 3b 3b 20 61 -yet-met))) ;; a
c4b0: 72 65 20 74 68 65 72 65 20 61 6e 79 20 74 65 73 re there any tes
c4c0: 74 73 20 74 68 61 74 20 6d 75 73 74 20 62 65 20 ts that must be
c4d0: 72 75 6e 20 62 65 66 6f 72 65 20 74 68 69 73 20 run before this
c4e0: 6f 6e 65 2e 2e 2e 0a 09 09 09 09 20 20 20 28 69 one........ (i
c4f0: 66 20 28 6e 6f 74 20 28 28 63 61 64 72 20 74 65 f (not ((cadr te
c500: 73 74 72 75 6e 64 61 74 29 29 29 20 3b 3b 20 74 strundat))) ;; t
c510: 68 69 73 20 69 73 20 74 68 65 20 6c 69 6e 65 20 his is the line
c520: 74 68 61 74 20 6c 61 75 6e 63 68 65 73 20 74 68 that launches th
c530: 65 20 74 65 73 74 20 74 6f 20 74 68 65 20 72 65 e test to the re
c540: 6d 6f 74 65 20 68 6f 73 74 0a 09 09 09 09 20 20 mote host.....
c550: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 09 (begin.....
c560: 09 20 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a . (print "ERROR:
c570: 20 46 61 69 6c 65 64 20 74 6f 20 6c 61 75 6e 63 Failed to launc
c580: 68 20 74 68 65 20 74 65 73 74 2e 20 45 78 69 74 h the test. Exit
c590: 69 6e 67 20 61 73 20 73 6f 6f 6e 20 61 73 20 70 ing as soon as p
c5a0: 6f 73 73 69 62 6c 65 22 29 0a 09 09 09 09 09 20 ossible")......
c5b0: 28 73 65 74 21 20 2a 67 6c 6f 62 61 6c 65 78 69 (set! *globalexi
c5c0: 74 73 74 61 74 75 73 2a 20 31 29 20 3b 3b 20 0a tstatus* 1) ;; .
c5d0: 09 09 09 09 09 20 28 70 72 6f 63 65 73 73 2d 73 ..... (process-s
c5e0: 69 67 6e 61 6c 20 28 63 75 72 72 65 6e 74 2d 70 ignal (current-p
c5f0: 72 6f 63 65 73 73 2d 69 64 29 20 73 69 67 6e 61 rocess-id) signa
c600: 6c 2f 6b 69 6c 6c 29 0a 09 09 09 09 09 20 3b 28 l/kill)...... ;(
c610: 65 78 69 74 20 31 29 0a 09 09 09 09 09 20 29 29 exit 1)...... ))
c620: 0a 09 09 09 09 20 20 20 28 69 66 20 28 6e 6f 74 ..... (if (not
c630: 20 6b 65 65 70 67 6f 69 6e 67 29 0a 09 09 09 09 keepgoing).....
c640: 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 (hash-tab
c650: 6c 65 2d 73 65 74 21 20 2a 77 61 69 74 69 6e 67 le-set! *waiting
c660: 2d 71 75 65 75 65 2a 20 6e 65 77 2d 74 65 73 74 -queue* new-test
c670: 2d 6e 61 6d 65 20 74 65 73 74 72 75 6e 64 61 74 -name testrundat
c680: 29 29 29 29 29 29 29 0a 09 09 20 20 20 20 20 20 )))))))...
c690: 28 28 4b 49 4c 4c 45 44 29 20 0a 09 09 20 20 20 ((KILLED) ...
c6a0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
c6b0: 20 31 20 22 4e 4f 54 45 3a 20 22 20 6e 65 77 2d 1 "NOTE: " new-
c6c0: 74 65 73 74 2d 6e 61 6d 65 20 22 20 69 73 20 61 test-name " is a
c6d0: 6c 72 65 61 64 79 20 72 75 6e 6e 69 6e 67 20 6f lready running o
c6e0: 72 20 77 61 73 20 65 78 70 6c 69 63 74 6c 79 20 r was explictly
c6f0: 6b 69 6c 6c 65 64 2c 20 75 73 65 20 2d 66 6f 72 killed, use -for
c700: 63 65 20 74 6f 20 6c 61 75 6e 63 68 20 69 74 2e ce to launch it.
c710: 22 29 29 0a 09 09 20 20 20 20 20 20 28 28 4c 41 "))... ((LA
c720: 55 4e 43 48 45 44 20 52 45 4d 4f 54 45 48 4f 53 UNCHED REMOTEHOS
c730: 54 53 54 41 52 54 20 52 55 4e 4e 49 4e 47 29 20 TSTART RUNNING)
c740: 20 0a 09 09 20 20 20 20 20 20 20 28 69 66 20 28 ... (if (
c750: 3e 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 > (- (current-se
c760: 63 6f 6e 64 73 29 28 2b 20 28 64 62 3a 74 65 73 conds)(+ (db:tes
c770: 74 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 t-get-event_time
c780: 20 74 65 73 74 64 61 74 29 0a 09 09 09 09 09 09 testdat).......
c790: 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 (db:test-ge
c7a0: 74 2d 72 75 6e 5f 64 75 72 61 74 69 6f 6e 20 74 t-run_duration t
c7b0: 65 73 74 64 61 74 29 29 29 0a 09 09 09 20 20 20 estdat)))....
c7c0: 20 20 20 31 30 30 29 20 3b 3b 20 69 2e 65 2e 20 100) ;; i.e.
c7d0: 6e 6f 20 75 70 64 61 74 65 20 66 6f 72 20 6d 6f no update for mo
c7e0: 72 65 20 74 68 61 6e 20 31 30 30 20 73 65 63 6f re than 100 seco
c7f0: 6e 64 73 0a 09 09 09 20 20 20 28 62 65 67 69 6e nds.... (begin
c800: 0a 09 09 09 20 20 20 20 20 28 64 65 62 75 67 3a .... (debug:
c810: 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 print 0 "WARNING
c820: 3a 20 54 65 73 74 20 22 20 74 65 73 74 2d 6e 61 : Test " test-na
c830: 6d 65 20 22 20 61 70 70 65 61 72 73 20 74 6f 20 me " appears to
c840: 62 65 20 64 65 61 64 2e 20 46 6f 72 63 69 6e 67 be dead. Forcing
c850: 20 69 74 20 74 6f 20 73 74 61 74 65 20 49 4e 43 it to state INC
c860: 4f 4d 50 4c 45 54 45 20 61 6e 64 20 73 74 61 74 OMPLETE and stat
c870: 75 73 20 53 54 55 43 4b 2f 44 45 41 44 22 29 0a us STUCK/DEAD").
c880: 09 09 09 20 20 20 20 20 28 74 65 73 74 2d 73 65 ... (test-se
c890: 74 2d 73 74 61 74 75 73 21 20 64 62 20 72 75 6e t-status! db run
c8a0: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 22 49 -id test-name "I
c8b0: 4e 43 4f 4d 50 4c 45 54 45 22 20 22 53 54 55 43 NCOMPLETE" "STUC
c8c0: 4b 2f 44 45 41 44 22 20 69 74 65 6d 64 61 74 20 K/DEAD" itemdat
c8d0: 22 54 65 73 74 20 69 73 20 73 74 75 63 6b 20 6f "Test is stuck o
c8e0: 72 20 64 65 61 64 22 20 23 66 29 29 0a 09 09 09 r dead" #f))....
c8f0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
c900: 32 20 22 4e 4f 54 45 3a 20 22 20 74 65 73 74 2d 2 "NOTE: " test-
c910: 6e 61 6d 65 20 22 20 69 73 20 61 6c 72 65 61 64 name " is alread
c920: 79 20 72 75 6e 6e 69 6e 67 22 29 29 29 0a 09 09 y running")))...
c930: 20 20 20 20 20 20 28 65 6c 73 65 20 20 20 20 20 (else
c940: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
c950: 20 22 45 52 52 4f 52 3a 20 46 61 69 6c 65 64 20 "ERROR: Failed
c960: 74 6f 20 6c 61 75 6e 63 68 20 74 65 73 74 20 22 to launch test "
c970: 20 6e 65 77 2d 74 65 73 74 2d 6e 61 6d 65 20 22 new-test-name "
c980: 2e 20 55 6e 72 65 63 6f 67 6e 69 73 65 64 20 73 . Unrecognised s
c990: 74 61 74 65 20 22 20 28 74 65 73 74 3a 67 65 74 tate " (test:get
c9a0: 2d 73 74 61 74 65 20 74 65 73 74 64 61 74 29 29 -state testdat))
c9b0: 29 29 29 29 0a 09 20 20 20 20 20 20 28 69 66 20 )))).. (if
c9c0: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 (not (null? tal)
c9d0: 29 0a 09 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 )... (loop (car
c9e0: 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 29 29 tal)(cdr tal)))
c9f0: 29 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d ))))))..;;======
ca00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ca10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ca20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ca30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ca40: 0a 3b 3b 20 45 4e 44 20 4f 46 20 4e 45 57 20 53 .;; END OF NEW S
ca50: 54 55 46 46 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d TUFF.;;=========
ca60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ca70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ca80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ca90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 =============..(
caa0: 64 65 66 69 6e 65 20 28 67 65 74 2d 64 69 72 2d define (get-dir-
cab0: 75 70 2d 6e 20 64 69 72 20 2e 20 70 61 72 61 6d up-n dir . param
cac0: 73 29 20 0a 20 20 28 6c 65 74 20 28 28 64 70 61 s) . (let ((dpa
cad0: 72 74 73 20 20 28 73 74 72 69 6e 67 2d 73 70 6c rts (string-spl
cae0: 69 74 20 64 69 72 20 22 2f 22 29 29 0a 09 28 63 it dir "/"))..(c
caf0: 6f 75 6e 74 20 20 20 28 69 66 20 28 6e 75 6c 6c ount (if (null
cb00: 3f 20 70 61 72 61 6d 73 29 20 31 20 28 63 61 72 ? params) 1 (car
cb10: 20 70 61 72 61 6d 73 29 29 29 29 0a 20 20 20 20 params)))).
cb20: 28 63 6f 6e 63 20 22 2f 22 20 28 73 74 72 69 6e (conc "/" (strin
cb30: 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 0a 09 g-intersperse ..
cb40: 20 20 20 20 20 20 20 28 74 61 6b 65 20 64 70 61 (take dpa
cb50: 72 74 73 20 28 2d 20 28 6c 65 6e 67 74 68 20 64 rts (- (length d
cb60: 70 61 72 74 73 29 20 63 6f 75 6e 74 29 29 0a 09 parts) count))..
cb70: 20 20 20 20 20 20 20 22 2f 22 29 29 29 29 0a 3b "/")))).;
cb80: 3b 20 52 65 6d 6f 76 65 20 72 75 6e 73 0a 3b 3b ; Remove runs.;;
cb90: 20 66 69 65 6c 64 73 20 61 72 65 20 70 61 73 73 fields are pass
cba0: 69 6e 67 20 69 6e 20 74 68 72 6f 75 67 68 20 0a ing in through .
cbb0: 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 72 65 (define (runs:re
cbc0: 6d 6f 76 65 2d 72 75 6e 73 20 64 62 20 72 75 6e move-runs db run
cbd0: 6e 61 6d 65 70 61 74 74 20 74 65 73 74 70 61 74 namepatt testpat
cbe0: 74 20 69 74 65 6d 70 61 74 74 29 0a 20 20 28 6c t itempatt). (l
cbf0: 65 74 2a 20 28 28 6b 65 79 73 20 20 20 20 20 20 et* ((keys
cc00: 20 20 28 64 62 2d 67 65 74 2d 6b 65 79 73 20 64 (db-get-keys d
cc10: 62 29 29 0a 09 20 28 72 75 6e 64 61 74 20 20 20 b)).. (rundat
cc20: 20 20 20 28 72 75 6e 73 3a 67 65 74 2d 72 75 6e (runs:get-run
cc30: 73 2d 62 79 2d 70 61 74 74 20 64 62 20 6b 65 79 s-by-patt db key
cc40: 73 20 72 75 6e 6e 61 6d 65 70 61 74 74 29 29 0a s runnamepatt)).
cc50: 09 20 28 68 65 61 64 65 72 20 20 20 20 20 20 28 . (header (
cc60: 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 64 61 vector-ref runda
cc70: 74 20 30 29 29 0a 09 20 28 72 75 6e 73 20 20 20 t 0)).. (runs
cc80: 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 (vector-ref
cc90: 20 72 75 6e 64 61 74 20 31 29 29 29 0a 20 20 20 rundat 1))).
cca0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 (debug:print 1
ccb0: 22 48 65 61 64 65 72 3a 20 22 20 68 65 61 64 65 "Header: " heade
ccc0: 72 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 r). (for-each
ccd0: 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 72 . (lambda (r
cce0: 75 6e 29 0a 20 20 20 20 20 20 20 28 6c 65 74 20 un). (let
ccf0: 28 28 72 75 6e 6b 65 79 20 28 73 74 72 69 6e 67 ((runkey (string
cd00: 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 -intersperse (ma
cd10: 70 20 28 6c 61 6d 62 64 61 20 28 6b 29 0a 09 09 p (lambda (k)...
cd20: 09 09 09 09 28 64 62 3a 67 65 74 2d 76 61 6c 75 ....(db:get-valu
cd30: 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 e-by-header run
cd40: 68 65 61 64 65 72 20 28 76 65 63 74 6f 72 2d 72 header (vector-r
cd50: 65 66 20 6b 20 30 29 29 29 20 6b 65 79 73 29 20 ef k 0))) keys)
cd60: 22 2f 22 29 29 0a 09 20 20 20 20 20 28 64 69 72 "/")).. (dir
cd70: 73 2d 74 6f 2d 72 65 6d 6f 76 65 20 28 6d 61 6b s-to-remove (mak
cd80: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 0a e-hash-table))).
cd90: 09 20 28 6c 65 74 2a 20 28 28 72 75 6e 2d 69 64 . (let* ((run-id
cda0: 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 (db:get-value-b
cdb0: 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 y-header run hea
cdc0: 64 65 72 20 22 69 64 22 29 20 29 0a 09 09 28 74 der "id") )...(t
cdd0: 65 73 74 73 20 20 28 64 62 2d 67 65 74 2d 74 65 ests (db-get-te
cde0: 73 74 73 2d 66 6f 72 2d 72 75 6e 20 64 62 20 28 sts-for-run db (
cdf0: 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d db:get-value-by-
ce00: 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 header run heade
ce10: 72 20 22 69 64 22 29 20 74 65 73 74 70 61 74 74 r "id") testpatt
ce20: 20 69 74 65 6d 70 61 74 74 20 27 28 29 20 27 28 itempatt '() '(
ce30: 29 29 29 0a 09 09 28 6c 61 73 74 74 70 61 74 68 )))...(lasttpath
ce40: 20 22 2f 64 6f 65 73 2f 6e 6f 74 2f 65 78 69 73 "/does/not/exis
ce50: 74 2f 49 2f 68 6f 70 65 22 29 29 0a 0a 09 20 20 t/I/hope"))...
ce60: 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f (if (not (null?
ce70: 20 74 65 73 74 73 29 29 0a 09 20 20 20 20 20 20 tests))..
ce80: 20 28 62 65 67 69 6e 0a 09 09 20 28 64 65 62 75 (begin... (debu
ce90: 67 3a 70 72 69 6e 74 20 31 20 22 52 65 6d 6f 76 g:print 1 "Remov
cea0: 69 6e 67 20 74 65 73 74 73 20 66 6f 72 20 72 75 ing tests for ru
ceb0: 6e 3a 20 22 20 72 75 6e 6b 65 79 20 22 20 22 20 n: " runkey " "
cec0: 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 (db:get-value-by
ced0: 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 -header run head
cee0: 65 72 20 22 72 75 6e 6e 61 6d 65 22 29 29 0a 09 er "runname"))..
cef0: 09 20 28 66 6f 72 2d 65 61 63 68 0a 09 09 20 20 . (for-each...
cf00: 28 6c 61 6d 62 64 61 20 28 74 65 73 74 29 0a 09 (lambda (test)..
cf10: 09 20 20 20 20 28 6c 65 74 2a 20 28 28 69 74 65 . (let* ((ite
cf20: 6d 2d 70 61 74 68 20 28 64 62 3a 74 65 73 74 2d m-path (db:test-
cf30: 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 65 get-item-path te
cf40: 73 74 29 29 0a 09 09 09 20 20 20 28 74 65 73 74 st)).... (test
cf50: 2d 6e 61 6d 65 20 28 64 62 3a 74 65 73 74 2d 67 -name (db:test-g
cf60: 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 et-testname test
cf70: 29 29 0a 09 09 09 20 20 20 28 72 75 6e 2d 64 69 )).... (run-di
cf80: 72 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 r (db:test-get
cf90: 2d 72 75 6e 64 69 72 20 74 65 73 74 29 29 29 0a -rundir test))).
cfa0: 09 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 .. (debug:p
cfb0: 72 69 6e 74 20 31 20 22 20 20 22 20 28 64 62 3a rint 1 " " (db:
cfc0: 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d test-get-testnam
cfd0: 65 20 74 65 73 74 29 20 22 20 69 64 3a 20 22 20 e test) " id: "
cfe0: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 (db:test-get-id
cff0: 74 65 73 74 29 20 22 20 22 20 69 74 65 6d 2d 70 test) " " item-p
d000: 61 74 68 29 0a 09 09 20 20 20 20 20 20 28 64 62 ath)... (db
d010: 3a 64 65 6c 65 74 65 2d 74 65 73 74 2d 72 65 63 :delete-test-rec
d020: 6f 72 64 73 20 64 62 20 28 64 62 3a 74 65 73 74 ords db (db:test
d030: 2d 67 65 74 2d 69 64 20 74 65 73 74 29 29 0a 09 -get-id test))..
d040: 09 20 20 20 20 20 20 28 69 66 20 28 3e 20 28 73 . (if (> (s
d050: 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 72 75 6e tring-length run
d060: 2d 64 69 72 29 20 35 29 20 3b 3b 20 62 61 64 20 -dir) 5) ;; bad
d070: 68 65 75 72 69 73 74 69 63 20 62 75 74 20 73 68 heuristic but sh
d080: 6f 75 6c 64 20 70 72 65 76 65 6e 74 20 2f 74 6d ould prevent /tm
d090: 70 20 2f 68 6f 6d 65 20 65 74 63 2e 0a 09 09 09 p /home etc.....
d0a0: 20 20 28 6c 65 74 20 28 28 66 75 6c 6c 70 61 74 (let ((fullpat
d0b0: 68 20 72 75 6e 2d 64 69 72 29 29 20 3b 3b 20 22 h run-dir)) ;; "
d0c0: 2f 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d /" (db:test-get-
d0d0: 69 74 65 6d 2d 70 61 74 68 20 74 65 73 74 29 29 item-path test))
d0e0: 29 29 0a 09 09 09 20 20 20 20 28 73 65 74 21 20 )).... (set!
d0f0: 6c 61 73 74 74 70 61 74 68 20 66 75 6c 6c 70 61 lasttpath fullpa
d100: 74 68 29 0a 09 09 09 20 20 20 20 28 68 61 73 68 th).... (hash
d110: 2d 74 61 62 6c 65 2d 73 65 74 21 20 64 69 72 73 -table-set! dirs
d120: 2d 74 6f 2d 72 65 6d 6f 76 65 20 66 75 6c 6c 70 -to-remove fullp
d130: 61 74 68 20 23 74 29 0a 09 09 09 20 20 20 20 3b ath #t).... ;
d140: 3b 20 54 68 65 20 66 6f 6c 6c 6f 77 69 6e 67 20 ; The following
d150: 77 61 73 20 74 68 65 20 73 61 66 65 20 64 65 6c was the safe del
d160: 65 74 65 20 63 6f 64 65 20 62 75 74 20 69 74 20 ete code but it
d170: 77 61 73 20 6e 6f 74 20 62 65 69 6e 67 20 65 78 was not being ex
d180: 65 63 74 75 74 65 64 2e 0a 09 09 09 20 20 20 20 ectuted.....
d190: 3b 3b 20 28 6c 65 74 2a 20 28 28 64 69 72 73 2d ;; (let* ((dirs-
d1a0: 63 6f 75 6e 74 20 28 2b 20 31 20 28 6c 65 6e 67 count (+ 1 (leng
d1b0: 74 68 20 6b 65 79 73 29 28 6c 65 6e 67 74 68 20 th keys)(length
d1c0: 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 69 74 (string-split it
d1d0: 65 6d 2d 70 61 74 68 20 22 2f 22 29 29 29 29 0a em-path "/")))).
d1e0: 09 09 09 20 20 20 20 3b 3b 20 20 20 20 20 20 20 ... ;;
d1f0: 20 28 64 69 72 2d 74 6f 2d 72 65 6d 20 28 67 65 (dir-to-rem (ge
d200: 74 2d 64 69 72 2d 75 70 2d 6e 20 66 75 6c 6c 70 t-dir-up-n fullp
d210: 61 74 68 20 64 69 72 73 2d 63 6f 75 6e 74 29 29 ath dirs-count))
d220: 0a 09 09 09 20 20 20 20 3b 3b 20 20 20 20 20 20 .... ;;
d230: 20 20 28 72 65 6d 61 69 6e 69 6e 67 64 20 28 73 (remainingd (s
d240: 74 72 69 6e 67 2d 73 75 62 73 74 69 74 75 74 65 tring-substitute
d250: 20 28 72 65 67 65 78 70 20 28 63 6f 6e 63 20 22 (regexp (conc "
d260: 5e 22 20 64 69 72 2d 74 6f 2d 72 65 6d 20 22 2f ^" dir-to-rem "/
d270: 22 29 29 20 22 22 20 66 75 6c 6c 70 61 74 68 29 ")) "" fullpath)
d280: 29 0a 09 09 09 20 20 20 20 3b 3b 20 20 20 20 20 ).... ;;
d290: 20 20 20 28 63 6d 64 20 28 63 6f 6e 63 20 22 63 (cmd (conc "c
d2a0: 64 20 22 20 64 69 72 2d 74 6f 2d 72 65 6d 20 22 d " dir-to-rem "
d2b0: 3b 20 72 6d 64 69 72 20 2d 70 20 22 20 72 65 6d ; rmdir -p " rem
d2c0: 61 69 6e 69 6e 67 64 20 29 29 29 0a 09 09 09 20 ainingd )))....
d2d0: 20 20 20 3b 3b 20 20 20 28 69 66 20 28 66 69 6c ;; (if (fil
d2e0: 65 2d 65 78 69 73 74 73 3f 20 66 75 6c 6c 70 61 e-exists? fullpa
d2f0: 74 68 29 0a 09 09 09 20 20 20 20 3b 3b 20 20 20 th).... ;;
d300: 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 20 20 (begin....
d310: 20 20 3b 3b 20 20 20 20 20 20 20 20 20 28 64 65 ;; (de
d320: 62 75 67 3a 70 72 69 6e 74 20 31 20 63 6d 64 29 bug:print 1 cmd)
d330: 0a 09 09 09 20 20 20 20 3b 3b 20 20 20 20 20 20 .... ;;
d340: 20 20 20 28 73 79 73 74 65 6d 20 63 6d 64 29 29 (system cmd))
d350: 29 0a 09 09 09 20 20 20 20 3b 3b 20 20 20 29 29 ).... ;; ))
d360: 0a 09 09 09 20 20 20 20 29 29 29 29 0a 09 09 20 .... ))))...
d370: 20 20 20 74 65 73 74 73 29 29 29 0a 0a 09 20 20 tests)))...
d380: 20 3b 3b 20 6c 6f 6f 6b 20 74 68 6f 75 67 68 20 ;; look though
d390: 74 68 65 20 64 69 72 73 2d 74 6f 2d 72 65 6d 6f the dirs-to-remo
d3a0: 76 65 20 66 6f 72 20 63 61 6e 64 69 64 61 74 65 ve for candidate
d3b0: 73 20 66 6f 72 20 72 65 6d 6f 76 61 6c 2e 20 44 s for removal. D
d3c0: 6f 20 74 68 69 73 20 61 66 74 65 72 20 64 65 6c o this after del
d3d0: 65 74 69 6e 67 20 74 68 65 20 72 65 63 6f 72 64 eting the record
d3e0: 73 0a 09 20 20 20 3b 3b 20 66 6f 72 20 65 61 63 s.. ;; for eac
d3f0: 68 20 74 65 73 74 20 69 6e 20 63 61 73 65 20 77 h test in case w
d400: 65 20 67 65 74 20 6b 69 6c 6c 65 64 2e 20 54 68 e get killed. Th
d410: 61 74 20 73 68 6f 75 6c 64 20 6d 69 6e 69 6d 69 at should minimi
d420: 7a 65 20 74 68 65 20 64 65 74 72 69 74 75 73 20 ze the detritus
d430: 6c 65 66 74 20 6f 6e 20 64 69 73 6b 0a 09 20 20 left on disk..
d440: 20 3b 3b 20 70 72 6f 63 65 73 73 20 74 68 65 20 ;; process the
d450: 64 69 72 73 20 66 72 6f 6d 20 6c 6f 6e 67 65 73 dirs from longes
d460: 74 20 73 74 72 69 6e 67 20 6c 65 6e 67 74 68 20 t string length
d470: 74 6f 20 73 68 6f 72 74 65 73 74 0a 09 20 20 20 to shortest..
d480: 28 66 6f 72 2d 65 61 63 68 20 0a 09 20 20 20 20 (for-each ..
d490: 28 6c 61 6d 62 64 61 20 28 64 69 72 2d 74 6f 2d (lambda (dir-to-
d4a0: 72 65 6d 6f 76 65 29 0a 09 20 20 20 20 20 20 28 remove).. (
d4b0: 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f if (file-exists?
d4c0: 20 64 69 72 2d 74 6f 2d 72 65 6d 6f 76 65 29 0a dir-to-remove).
d4d0: 09 09 20 20 28 6c 65 74 20 28 28 64 69 72 2d 69 .. (let ((dir-i
d4e0: 6e 2d 64 62 20 27 28 29 29 29 0a 09 09 20 20 20 n-db '()))...
d4f0: 20 28 73 71 6c 69 74 65 33 3a 66 6f 72 2d 65 61 (sqlite3:for-ea
d500: 63 68 2d 72 6f 77 0a 09 09 20 20 20 20 20 28 6c ch-row... (l
d510: 61 6d 62 64 61 20 28 64 69 72 29 0a 09 09 20 20 ambda (dir)...
d520: 20 20 20 20 20 28 73 65 74 21 20 64 69 72 2d 69 (set! dir-i
d530: 6e 2d 64 62 20 28 63 6f 6e 73 20 64 69 72 20 64 n-db (cons dir d
d540: 69 72 2d 69 6e 2d 64 62 29 29 29 0a 09 09 20 20 ir-in-db)))...
d550: 20 20 20 64 62 20 22 53 45 4c 45 43 54 20 72 75 db "SELECT ru
d560: 6e 64 69 72 20 46 52 4f 4d 20 74 65 73 74 73 20 ndir FROM tests
d570: 57 48 45 52 45 20 72 75 6e 64 69 72 20 4c 49 4b WHERE rundir LIK
d580: 45 20 3f 3b 22 20 0a 09 09 20 20 20 20 20 28 63 E ?;" ... (c
d590: 6f 6e 63 20 22 25 22 20 64 69 72 2d 74 6f 2d 72 onc "%" dir-to-r
d5a0: 65 6d 6f 76 65 20 22 25 22 29 29 20 3b 3b 20 79 emove "%")) ;; y
d5b0: 65 73 2c 20 49 27 6d 20 67 6f 69 6e 67 20 74 6f es, I'm going to
d5c0: 20 62 61 69 6c 20 69 66 20 74 68 65 72 65 20 69 bail if there i
d5d0: 73 20 61 6e 79 74 68 69 6e 67 20 6c 69 6b 65 20 s anything like
d5e0: 74 68 69 73 20 64 69 72 20 69 6e 20 74 68 65 20 this dir in the
d5f0: 64 62 0a 09 09 20 20 20 20 28 69 66 20 28 6e 75 db... (if (nu
d600: 6c 6c 3f 20 64 69 72 2d 69 6e 2d 64 62 29 0a 09 ll? dir-in-db)..
d610: 09 09 28 62 65 67 69 6e 0a 09 09 09 20 20 28 64 ..(begin.... (d
d620: 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 52 65 ebug:print 2 "Re
d630: 6d 6f 76 69 6e 67 20 64 69 72 65 63 74 6f 72 79 moving directory
d640: 20 77 69 74 68 20 7a 65 72 6f 20 64 62 20 72 65 with zero db re
d650: 66 65 72 65 6e 63 65 73 3a 20 22 20 64 69 72 2d ferences: " dir-
d660: 74 6f 2d 72 65 6d 6f 76 65 29 0a 09 09 09 20 20 to-remove)....
d670: 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 72 (system (conc "r
d680: 6d 20 2d 72 66 20 22 20 64 69 72 2d 74 6f 2d 72 m -rf " dir-to-r
d690: 65 6d 6f 76 65 29 29 0a 09 09 09 20 20 28 68 61 emove)).... (ha
d6a0: 73 68 2d 74 61 62 6c 65 2d 64 65 6c 65 74 65 21 sh-table-delete!
d6b0: 20 64 69 72 73 2d 74 6f 2d 72 65 6d 6f 76 65 20 dirs-to-remove
d6c0: 64 69 72 2d 74 6f 2d 72 65 6d 6f 76 65 29 29 0a dir-to-remove)).
d6d0: 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 ...(debug:print
d6e0: 32 20 22 53 6b 69 70 70 69 6e 67 20 72 65 6d 6f 2 "Skipping remo
d6f0: 76 61 6c 20 6f 66 20 22 20 64 69 72 2d 74 6f 2d val of " dir-to-
d700: 72 65 6d 6f 76 65 20 22 20 66 6f 72 20 6e 6f 77 remove " for now
d710: 20 61 73 20 69 74 20 73 74 69 6c 6c 20 68 61 73 as it still has
d720: 20 72 65 66 65 72 65 6e 63 65 73 20 69 6e 20 74 references in t
d730: 68 65 20 64 61 74 61 62 61 73 65 22 29 29 29 29 he database"))))
d740: 29 0a 09 20 20 20 20 28 73 6f 72 74 20 28 68 61 ).. (sort (ha
d750: 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 64 69 sh-table-keys di
d760: 72 73 2d 74 6f 2d 72 65 6d 6f 76 65 29 20 28 6c rs-to-remove) (l
d770: 61 6d 62 64 61 20 28 61 20 62 29 28 3e 20 28 73 ambda (a b)(> (s
d780: 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 61 29 28 tring-length a)(
d790: 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 62 29 string-length b)
d7a0: 29 29 29 29 0a 0a 09 20 20 20 3b 3b 20 72 65 6d ))))... ;; rem
d7b0: 6f 76 65 20 74 68 65 20 72 75 6e 20 69 66 20 7a ove the run if z
d7c0: 65 72 6f 20 74 65 73 74 73 20 72 65 6d 61 69 6e ero tests remain
d7d0: 0a 09 20 20 20 28 6c 65 74 20 28 28 72 65 6d 74 .. (let ((remt
d7e0: 65 73 74 73 20 28 64 62 2d 67 65 74 2d 74 65 73 ests (db-get-tes
d7f0: 74 73 2d 66 6f 72 2d 72 75 6e 20 64 62 20 28 64 ts-for-run db (d
d800: 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 b:get-value-by-h
d810: 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 eader run header
d820: 20 22 69 64 22 29 20 23 66 20 23 66 20 27 28 29 "id") #f #f '()
d830: 20 27 28 29 29 29 29 0a 09 20 20 20 20 20 28 69 '()))).. (i
d840: 66 20 28 6e 75 6c 6c 3f 20 72 65 6d 74 65 73 74 f (null? remtest
d850: 73 29 20 3b 3b 20 6e 6f 20 6d 6f 72 65 20 74 65 s) ;; no more te
d860: 73 74 73 20 72 65 6d 61 69 6e 69 6e 67 0a 09 09 sts remaining...
d870: 20 28 6c 65 74 2a 20 28 28 64 70 61 72 74 73 20 (let* ((dparts
d880: 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 6c (string-split l
d890: 61 73 74 74 70 61 74 68 20 22 2f 22 29 29 0a 09 asttpath "/"))..
d8a0: 09 09 28 72 75 6e 70 61 74 68 20 28 63 6f 6e 63 ..(runpath (conc
d8b0: 20 22 2f 22 20 28 73 74 72 69 6e 67 2d 69 6e 74 "/" (string-int
d8c0: 65 72 73 70 65 72 73 65 20 0a 09 09 09 09 09 20 ersperse ......
d8d0: 20 20 20 28 74 61 6b 65 20 64 70 61 72 74 73 20 (take dparts
d8e0: 28 2d 20 28 6c 65 6e 67 74 68 20 64 70 61 72 74 (- (length dpart
d8f0: 73 29 20 31 29 29 0a 09 09 09 09 09 20 20 20 20 s) 1))......
d900: 22 2f 22 29 29 29 29 0a 09 09 20 20 20 28 64 65 "/"))))... (de
d910: 62 75 67 3a 70 72 69 6e 74 20 31 20 22 52 65 6d bug:print 1 "Rem
d920: 6f 76 69 6e 67 20 72 75 6e 3a 20 22 20 72 75 6e oving run: " run
d930: 6b 65 79 20 22 20 22 20 28 64 62 3a 67 65 74 2d key " " (db:get-
d940: 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 value-by-header
d950: 72 75 6e 20 68 65 61 64 65 72 20 22 72 75 6e 6e run header "runn
d960: 61 6d 65 22 29 29 0a 09 09 20 20 20 28 64 62 3a ame"))... (db:
d970: 64 65 6c 65 74 65 2d 72 75 6e 20 64 62 20 72 75 delete-run db ru
d980: 6e 2d 69 64 29 0a 09 09 20 20 20 3b 3b 20 6e 65 n-id)... ;; ne
d990: 65 64 20 74 6f 20 66 69 67 75 72 65 20 6f 75 74 ed to figure out
d9a0: 20 74 68 65 20 70 61 74 68 20 74 6f 20 74 68 65 the path to the
d9b0: 20 72 75 6e 20 64 69 72 20 61 6e 64 20 72 65 6d run dir and rem
d9c0: 6f 76 65 20 69 74 20 69 66 20 65 6d 70 74 79 0a ove it if empty.
d9d0: 09 09 20 20 20 3b 3b 20 20 20 20 28 69 66 20 28 .. ;; (if (
d9e0: 6e 75 6c 6c 3f 20 28 67 6c 6f 62 20 28 63 6f 6e null? (glob (con
d9f0: 63 20 72 75 6e 70 61 74 68 20 22 2f 2a 22 29 29 c runpath "/*"))
da00: 29 0a 09 09 20 20 20 3b 3b 20 20 20 20 20 20 20 )... ;;
da10: 20 28 62 65 67 69 6e 0a 09 09 20 20 20 3b 3b 20 (begin... ;;
da20: 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 . (debug:print 1
da30: 20 22 52 65 6d 6f 76 69 6e 67 20 72 75 6e 20 64 "Removing run d
da40: 69 72 20 22 20 72 75 6e 70 61 74 68 29 0a 09 09 ir " runpath)...
da50: 20 20 20 3b 3b 20 09 20 28 73 79 73 74 65 6d 20 ;; . (system
da60: 28 63 6f 6e 63 20 22 72 6d 64 69 72 20 2d 70 20 (conc "rmdir -p
da70: 22 20 72 75 6e 70 61 74 68 29 29 29 29 0a 09 09 " runpath))))...
da80: 20 20 20 29 29 29 29 0a 09 20 29 29 0a 20 20 20 )))).. )).
da90: 20 20 72 75 6e 73 29 29 29 0a 0a 3b 3b 3d 3d 3d runs)))..;;===
daa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
dab0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
dac0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
dad0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
dae0: 3d 3d 3d 0a 3b 3b 20 52 6f 75 74 69 6e 65 73 20 ===.;; Routines
daf0: 66 6f 72 20 6d 61 6e 69 70 75 6c 61 74 69 6e 67 for manipulating
db00: 20 72 75 6e 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d runs.;;========
db10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
db20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
db30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
db40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
db50: 3b 3b 20 53 69 6e 63 65 20 6d 61 6e 79 20 63 61 ;; Since many ca
db60: 6c 6c 73 20 74 6f 20 61 20 72 75 6e 20 72 65 71 lls to a run req
db70: 75 69 72 65 20 70 72 65 74 74 79 20 6d 75 63 68 uire pretty much
db80: 20 74 68 65 20 73 61 6d 65 20 73 65 74 75 70 20 the same setup
db90: 0a 3b 3b 20 74 68 69 73 20 77 72 61 70 70 65 72 .;; this wrapper
dba0: 20 69 73 20 75 73 65 64 20 74 6f 20 72 65 64 75 is used to redu
dbb0: 63 65 20 74 68 65 20 72 65 70 6c 69 63 61 74 69 ce the replicati
dbc0: 6f 6e 20 6f 66 20 63 6f 64 65 0a 28 64 65 66 69 on of code.(defi
dbd0: 6e 65 20 28 67 65 6e 65 72 61 6c 2d 72 75 6e 2d ne (general-run-
dbe0: 63 61 6c 6c 20 73 77 69 74 63 68 6e 61 6d 65 20 call switchname
dbf0: 61 63 74 69 6f 6e 2d 64 65 73 63 20 70 72 6f 63 action-desc proc
dc00: 29 0a 20 20 28 69 66 20 28 6e 6f 74 20 28 61 72 ). (if (not (ar
dc10: 67 73 3a 67 65 74 2d 61 72 67 20 22 3a 72 75 6e gs:get-arg ":run
dc20: 6e 61 6d 65 22 29 29 0a 20 20 20 20 20 20 28 62 name")). (b
dc30: 65 67 69 6e 0a 09 28 64 65 62 75 67 3a 70 72 69 egin..(debug:pri
dc40: 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 4d 69 73 nt 0 "ERROR: Mis
dc50: 73 69 6e 67 20 72 65 71 75 69 72 65 64 20 70 61 sing required pa
dc60: 72 61 6d 65 74 65 72 20 66 6f 72 20 22 20 73 77 rameter for " sw
dc70: 69 74 63 68 6e 61 6d 65 20 22 2c 20 79 6f 75 20 itchname ", you
dc80: 6d 75 73 74 20 73 70 65 63 69 66 79 20 74 68 65 must specify the
dc90: 20 72 75 6e 20 6e 61 6d 65 20 77 69 74 68 20 3a run name with :
dca0: 72 75 6e 6e 61 6d 65 20 72 75 6e 6e 61 6d 65 22 runname runname"
dcb0: 29 0a 09 28 65 78 69 74 20 32 29 29 0a 20 20 20 )..(exit 2)).
dcc0: 20 20 20 28 6c 65 74 20 28 28 64 62 20 20 20 23 (let ((db #
dcd0: 66 29 0a 09 20 20 20 20 28 6b 65 79 73 20 23 66 f).. (keys #f
dce0: 29 29 0a 09 28 69 66 20 28 6e 6f 74 20 28 73 65 ))..(if (not (se
dcf0: 74 75 70 2d 66 6f 72 2d 72 75 6e 29 29 0a 09 20 tup-for-run))..
dd00: 20 20 20 28 62 65 67 69 6e 20 0a 09 20 20 20 20 (begin ..
dd10: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
dd20: 20 22 46 61 69 6c 65 64 20 74 6f 20 73 65 74 75 "Failed to setu
dd30: 70 2c 20 65 78 69 74 69 6e 67 22 29 0a 09 20 20 p, exiting")..
dd40: 20 20 20 20 28 65 78 69 74 20 31 29 29 29 0a 09 (exit 1)))..
dd50: 28 73 65 74 21 20 64 62 20 20 20 28 6f 70 65 6e (set! db (open
dd60: 2d 64 62 29 29 0a 09 28 73 65 74 21 20 6b 65 79 -db))..(set! key
dd70: 73 20 28 64 62 2d 67 65 74 2d 6b 65 79 73 20 64 s (db-get-keys d
dd80: 62 29 29 0a 09 3b 3b 20 68 61 76 65 20 65 6e 6f b))..;; have eno
dd90: 75 67 68 20 74 6f 20 70 72 6f 63 65 73 73 20 2d ugh to process -
dda0: 74 61 72 67 65 74 20 6f 72 20 2d 72 65 71 74 61 target or -reqta
ddb0: 72 67 20 68 65 72 65 0a 09 28 69 66 20 28 61 72 rg here..(if (ar
ddc0: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 71 gs:get-arg "-req
ddd0: 74 61 72 67 22 29 0a 09 20 20 20 20 28 6c 65 74 targ").. (let
dde0: 2a 20 28 28 72 75 6e 63 6f 6e 66 69 67 66 20 28 * ((runconfigf (
ddf0: 63 6f 6e 63 20 20 2a 74 6f 70 70 61 74 68 2a 20 conc *toppath*
de00: 22 2f 72 75 6e 63 6f 6e 66 69 67 73 2e 63 6f 6e "/runconfigs.con
de10: 66 69 67 22 29 29 20 3b 3b 20 44 4f 20 4e 4f 54 fig")) ;; DO NOT
de20: 20 45 56 41 4c 55 41 54 45 20 41 4c 4c 20 0a 09 EVALUATE ALL ..
de30: 09 20 20 20 28 72 75 6e 63 6f 6e 66 69 67 20 20 . (runconfig
de40: 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 72 75 6e (read-config run
de50: 63 6f 6e 66 69 67 66 20 23 66 20 23 66 20 65 6e configf #f #f en
de60: 76 69 72 6f 6e 2d 70 61 74 74 3a 20 23 66 29 29 viron-patt: #f))
de70: 29 20 0a 09 20 20 20 20 20 20 28 69 66 20 28 68 ) .. (if (h
de80: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
de90: 66 61 75 6c 74 20 72 75 6e 63 6f 6e 66 69 67 20 fault runconfig
dea0: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
deb0: 72 65 71 74 61 72 67 22 29 20 23 66 29 0a 09 09 reqtarg") #f)...
dec0: 20 20 28 6b 65 79 73 3a 74 61 72 67 65 74 2d 73 (keys:target-s
ded0: 65 74 2d 61 72 67 73 20 6b 65 79 73 20 28 61 72 et-args keys (ar
dee0: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 71 gs:get-arg "-req
def0: 74 61 72 67 22 29 20 61 72 67 73 3a 61 72 67 2d targ") args:arg-
df00: 68 61 73 68 29 0a 09 09 20 20 28 62 65 67 69 6e hash)... (begin
df10: 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 ... (debug:pr
df20: 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 5b 22 int 0 "ERROR: ["
df30: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
df40: 2d 72 65 71 74 61 72 67 22 29 20 22 5d 20 6e 6f -reqtarg") "] no
df50: 74 20 66 6f 75 6e 64 20 69 6e 20 22 20 72 75 6e t found in " run
df60: 63 6f 6e 66 69 67 66 29 0a 09 09 20 20 20 20 28 configf)... (
df70: 73 71 6c 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 sqlite3:finalize
df80: 21 20 64 62 29 0a 09 09 20 20 20 20 28 65 78 69 ! db)... (exi
df90: 74 20 31 29 29 29 29 0a 09 20 20 20 20 28 69 66 t 1)))).. (if
dfa0: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
dfb0: 2d 74 61 72 67 65 74 22 29 0a 09 09 28 6b 65 79 -target")...(key
dfc0: 73 3a 74 61 72 67 65 74 2d 73 65 74 2d 61 72 67 s:target-set-arg
dfd0: 73 20 6b 65 79 73 20 28 61 72 67 73 3a 67 65 74 s keys (args:get
dfe0: 2d 61 72 67 20 22 2d 74 61 72 67 65 74 22 20 61 -arg "-target" a
dff0: 72 67 73 3a 61 72 67 2d 68 61 73 68 29 20 61 72 rgs:arg-hash) ar
e000: 67 73 3a 61 72 67 2d 68 61 73 68 29 29 29 0a 09 gs:arg-hash)))..
e010: 28 69 66 20 28 6e 6f 74 20 28 63 61 72 20 2a 63 (if (not (car *c
e020: 6f 6e 66 69 67 69 6e 66 6f 2a 29 29 0a 09 20 20 onfiginfo*))..
e030: 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 (begin..
e040: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
e050: 45 52 52 4f 52 3a 20 41 74 74 65 6d 70 74 65 64 ERROR: Attempted
e060: 20 74 6f 20 22 20 61 63 74 69 6f 6e 2d 64 65 73 to " action-des
e070: 63 20 22 20 62 75 74 20 72 75 6e 20 61 72 65 61 c " but run area
e080: 20 63 6f 6e 66 69 67 20 66 69 6c 65 20 6e 6f 74 config file not
e090: 20 66 6f 75 6e 64 22 29 0a 09 20 20 20 20 20 20 found")..
e0a0: 28 65 78 69 74 20 31 29 29 0a 09 20 20 20 20 3b (exit 1)).. ;
e0b0: 3b 20 45 78 74 72 61 63 74 20 6f 75 74 20 73 74 ; Extract out st
e0c0: 75 66 66 20 6e 65 65 64 65 64 20 69 6e 20 6d 6f uff needed in mo
e0d0: 73 74 20 6f 72 20 6d 61 6e 79 20 63 61 6c 6c 73 st or many calls
e0e0: 0a 09 20 20 20 20 3b 3b 20 68 65 72 65 20 74 68 .. ;; here th
e0f0: 65 6e 20 63 61 6c 6c 20 70 72 6f 63 0a 09 20 20 en call proc..
e100: 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 6e 61 6d (let* ((keynam
e110: 65 73 20 20 20 28 6d 61 70 20 6b 65 79 3a 67 65 es (map key:ge
e120: 74 2d 66 69 65 6c 64 6e 61 6d 65 20 6b 65 79 73 t-fieldname keys
e130: 29 29 0a 09 09 20 20 20 28 6b 65 79 76 61 6c 6c ))... (keyvall
e140: 73 74 20 20 28 6b 65 79 73 2d 3e 76 61 6c 6c 69 st (keys->valli
e150: 73 74 20 6b 65 79 73 20 23 74 29 29 29 0a 09 20 st keys #t)))..
e160: 20 20 20 20 20 28 70 72 6f 63 20 64 62 20 6b 65 (proc db ke
e170: 79 73 20 6b 65 79 6e 61 6d 65 73 20 6b 65 79 76 ys keynames keyv
e180: 61 6c 6c 73 74 29 29 29 0a 09 28 73 71 6c 69 74 allst)))..(sqlit
e190: 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 64 62 29 e3:finalize! db)
e1a0: 0a 09 28 73 65 74 21 20 2a 64 69 64 73 6f 6d 65 ..(set! *didsome
e1b0: 74 68 69 6e 67 2a 20 23 74 29 29 29 29 0a 0a 3b thing* #t))))..;
e1c0: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
e1d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e1e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e1f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e200: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 52 6f 6c 6c 75 =======.;; Rollu
e210: 70 20 72 75 6e 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d p runs.;;=======
e220: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e230: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e240: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e250: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
e260: 0a 3b 3b 20 55 70 64 61 74 65 20 74 68 65 20 74 .;; Update the t
e270: 65 73 74 5f 6d 65 74 61 20 74 61 62 6c 65 20 66 est_meta table f
e280: 6f 72 20 74 68 69 73 20 74 65 73 74 0a 28 64 65 or this test.(de
e290: 66 69 6e 65 20 28 72 75 6e 73 3a 75 70 64 61 74 fine (runs:updat
e2a0: 65 2d 74 65 73 74 5f 6d 65 74 61 20 64 62 20 74 e-test_meta db t
e2b0: 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 63 6f est-name test-co
e2c0: 6e 66 29 0a 20 20 28 6c 65 74 20 28 28 63 75 72 nf). (let ((cur
e2d0: 72 72 65 63 6f 72 64 20 28 64 62 3a 74 65 73 74 rrecord (db:test
e2e0: 6d 65 74 61 2d 67 65 74 2d 72 65 63 6f 72 64 20 meta-get-record
e2f0: 64 62 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a db test-name))).
e300: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 63 75 72 (if (not cur
e310: 72 72 65 63 6f 72 64 29 0a 09 28 62 65 67 69 6e rrecord)..(begin
e320: 0a 09 20 20 28 73 65 74 21 20 63 75 72 72 72 65 .. (set! currre
e330: 63 6f 72 64 20 28 6d 61 6b 65 2d 76 65 63 74 6f cord (make-vecto
e340: 72 20 31 30 20 23 66 29 29 0a 09 20 20 28 64 62 r 10 #f)).. (db
e350: 3a 74 65 73 74 6d 65 74 61 2d 61 64 64 2d 72 65 :testmeta-add-re
e360: 63 6f 72 64 20 64 62 20 74 65 73 74 2d 6e 61 6d cord db test-nam
e370: 65 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 e))). (for-ea
e380: 63 68 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 ch . (lambda
e390: 20 28 6b 65 79 29 0a 20 20 20 20 20 20 20 28 6c (key). (l
e3a0: 65 74 2a 20 28 28 69 64 78 20 28 63 61 64 72 20 et* ((idx (cadr
e3b0: 6b 65 79 29 29 0a 09 20 20 20 20 20 20 28 66 6c key)).. (fl
e3c0: 64 20 28 63 61 72 20 20 6b 65 79 29 29 0a 09 20 d (car key))..
e3d0: 20 20 20 20 20 28 76 61 6c 20 28 63 6f 6e 66 69 (val (confi
e3e0: 67 2d 6c 6f 6f 6b 75 70 20 74 65 73 74 2d 63 6f g-lookup test-co
e3f0: 6e 66 20 22 74 65 73 74 5f 6d 65 74 61 22 20 66 nf "test_meta" f
e400: 6c 64 29 29 29 0a 09 20 28 69 66 20 28 61 6e 64 ld))).. (if (and
e410: 20 76 61 6c 20 28 6e 6f 74 20 28 65 71 75 61 6c val (not (equal
e420: 3f 20 28 76 65 63 74 6f 72 2d 72 65 66 20 63 75 ? (vector-ref cu
e430: 72 72 72 65 63 6f 72 64 20 69 64 78 29 20 76 61 rrrecord idx) va
e440: 6c 29 29 29 0a 09 20 20 20 20 20 28 62 65 67 69 l))).. (begi
e450: 6e 0a 09 20 20 20 20 20 20 20 28 70 72 69 6e 74 n.. (print
e460: 20 22 55 70 64 61 74 69 6e 67 20 22 20 74 65 73 "Updating " tes
e470: 74 2d 6e 61 6d 65 20 22 20 22 20 66 6c 64 20 22 t-name " " fld "
e480: 20 74 6f 20 22 20 76 61 6c 29 0a 09 20 20 20 20 to " val)..
e490: 20 20 20 28 64 62 3a 74 65 73 74 6d 65 74 61 2d (db:testmeta-
e4a0: 75 70 64 61 74 65 2d 66 69 65 6c 64 20 64 62 20 update-field db
e4b0: 74 65 73 74 2d 6e 61 6d 65 20 66 6c 64 20 76 61 test-name fld va
e4c0: 6c 29 29 29 29 29 0a 20 20 20 20 20 27 28 28 22 l))))). '(("
e4d0: 61 75 74 68 6f 72 22 20 32 29 28 22 6f 77 6e 65 author" 2)("owne
e4e0: 72 22 20 33 29 28 22 64 65 73 63 72 69 70 74 69 r" 3)("descripti
e4f0: 6f 6e 22 20 34 29 28 22 72 65 76 69 65 77 65 64 on" 4)("reviewed
e500: 22 20 35 29 28 22 74 61 67 73 22 20 39 29 29 29 " 5)("tags" 9)))
e510: 29 29 0a 0a 3b 3b 20 55 70 64 61 74 65 20 74 65 ))..;; Update te
e520: 73 74 5f 6d 65 74 61 20 66 6f 72 20 61 6c 6c 20 st_meta for all
e530: 74 65 73 74 73 0a 28 64 65 66 69 6e 65 20 28 72 tests.(define (r
e540: 75 6e 73 3a 75 70 64 61 74 65 2d 61 6c 6c 2d 74 uns:update-all-t
e550: 65 73 74 5f 6d 65 74 61 20 64 62 29 0a 20 20 28 est_meta db). (
e560: 6c 65 74 20 28 28 74 65 73 74 2d 6e 61 6d 65 73 let ((test-names
e570: 20 28 67 65 74 2d 61 6c 6c 2d 6c 65 67 61 6c 2d (get-all-legal-
e580: 74 65 73 74 73 29 29 29 0a 20 20 20 20 28 66 6f tests))). (fo
e590: 72 2d 65 61 63 68 20 0a 20 20 20 20 20 28 6c 61 r-each . (la
e5a0: 6d 62 64 61 20 28 74 65 73 74 2d 6e 61 6d 65 29 mbda (test-name)
e5b0: 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 . (let* ((
e5c0: 74 65 73 74 2d 70 61 74 68 20 20 20 20 28 63 6f test-path (co
e5d0: 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 74 nc *toppath* "/t
e5e0: 65 73 74 73 2f 22 20 74 65 73 74 2d 6e 61 6d 65 ests/" test-name
e5f0: 29 29 0a 09 20 20 20 20 20 20 28 74 65 73 74 2d )).. (test-
e600: 63 6f 6e 66 69 67 66 20 28 63 6f 6e 63 20 74 65 configf (conc te
e610: 73 74 2d 70 61 74 68 20 22 2f 74 65 73 74 63 6f st-path "/testco
e620: 6e 66 69 67 22 29 29 0a 09 20 20 20 20 20 20 28 nfig")).. (
e630: 74 65 73 74 65 78 69 73 74 73 20 20 20 28 61 6e testexists (an
e640: 64 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 d (file-exists?
e650: 74 65 73 74 2d 63 6f 6e 66 69 67 66 29 28 66 69 test-configf)(fi
e660: 6c 65 2d 72 65 61 64 2d 61 63 63 65 73 73 3f 20 le-read-access?
e670: 74 65 73 74 2d 63 6f 6e 66 69 67 66 29 29 29 0a test-configf))).
e680: 09 20 20 20 20 20 20 3b 3b 20 72 65 61 64 20 63 . ;; read c
e690: 6f 6e 66 69 67 73 20 77 69 74 68 20 74 72 69 63 onfigs with tric
e6a0: 6b 73 20 74 75 72 6e 65 64 20 6f 66 66 20 28 69 ks turned off (i
e6b0: 2e 65 2e 20 6e 6f 20 73 79 73 74 65 6d 29 0a 09 .e. no system)..
e6c0: 20 20 20 20 20 20 28 74 65 73 74 2d 63 6f 6e 66 (test-conf
e6d0: 20 20 20 20 28 69 66 20 74 65 73 74 65 78 69 73 (if testexis
e6e0: 74 73 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 ts (read-config
e6f0: 74 65 73 74 2d 63 6f 6e 66 69 67 66 20 23 66 20 test-configf #f
e700: 23 66 29 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 #f)(make-hash-ta
e710: 62 6c 65 29 29 29 29 0a 09 20 28 72 75 6e 73 3a ble)))).. (runs:
e720: 75 70 64 61 74 65 2d 74 65 73 74 5f 6d 65 74 61 update-test_meta
e730: 20 64 62 20 74 65 73 74 2d 6e 61 6d 65 20 74 65 db test-name te
e740: 73 74 2d 63 6f 6e 66 29 29 29 0a 20 20 20 20 20 st-conf))).
e750: 74 65 73 74 2d 6e 61 6d 65 73 29 29 29 0a 0a 3b test-names)))..;
e760: 3b 20 54 68 69 73 20 63 6f 75 6c 64 20 70 72 6f ; This could pro
e770: 62 61 62 6c 79 20 62 65 20 72 65 66 61 63 74 6f bably be refacto
e780: 72 65 64 20 69 6e 74 6f 20 6f 6e 65 20 63 6f 6d red into one com
e790: 70 6c 65 78 20 71 75 65 72 79 20 2e 2e 2e 0a 28 plex query ....(
e7a0: 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 72 6f 6c define (runs:rol
e7b0: 6c 75 70 2d 72 75 6e 20 64 62 20 6b 65 79 73 20 lup-run db keys
e7c0: 6b 65 79 76 61 6c 6c 73 74 20 72 75 6e 6e 61 6d keyvallst runnam
e7d0: 65 20 75 73 65 72 29 20 3b 3b 20 77 61 73 20 74 e user) ;; was t
e7e0: 61 72 67 65 74 2c 20 6e 6f 77 20 6b 65 79 76 61 arget, now keyva
e7f0: 6c 6c 73 74 0a 20 20 28 64 65 62 75 67 3a 70 72 llst. (debug:pr
e800: 69 6e 74 20 34 20 22 72 75 6e 73 3a 72 6f 6c 6c int 4 "runs:roll
e810: 75 70 2d 72 75 6e 2c 20 6b 65 79 73 3a 20 22 20 up-run, keys: "
e820: 6b 65 79 73 20 22 20 6b 65 79 76 61 6c 6c 73 74 keys " keyvallst
e830: 3a 20 22 20 6b 65 79 76 61 6c 6c 73 74 20 22 20 : " keyvallst "
e840: 3a 72 75 6e 6e 61 6d 65 20 22 20 72 75 6e 6e 61 :runname " runna
e850: 6d 65 20 22 20 75 73 65 72 3a 20 22 20 75 73 65 me " user: " use
e860: 72 29 0a 20 20 28 6c 65 74 2a 20 28 3b 20 28 6b r). (let* (; (k
e870: 65 79 76 61 6c 6c 6c 73 74 20 20 20 20 20 20 28 eyvalllst (
e880: 6b 65 79 73 3a 74 61 72 67 65 74 2d 3e 6b 65 79 keys:target->key
e890: 76 61 6c 20 6b 65 79 73 20 74 61 72 67 65 74 29 val keys target)
e8a0: 29 0a 09 20 28 6e 65 77 2d 72 75 6e 2d 69 64 20 ).. (new-run-id
e8b0: 20 20 20 20 20 28 72 75 6e 73 3a 72 65 67 69 73 (runs:regis
e8c0: 74 65 72 2d 72 75 6e 20 64 62 20 6b 65 79 73 20 ter-run db keys
e8d0: 6b 65 79 76 61 6c 6c 73 74 20 72 75 6e 6e 61 6d keyvallst runnam
e8e0: 65 20 22 6e 65 77 22 20 22 6e 2f 61 22 20 75 73 e "new" "n/a" us
e8f0: 65 72 29 29 0a 09 20 28 70 72 65 76 2d 74 65 73 er)).. (prev-tes
e900: 74 73 20 20 20 20 20 20 28 74 65 73 74 3a 67 65 ts (test:ge
e910: 74 2d 6d 61 74 63 68 69 6e 67 2d 70 72 65 76 69 t-matching-previ
e920: 6f 75 73 2d 74 65 73 74 2d 72 75 6e 2d 72 65 63 ous-test-run-rec
e930: 6f 72 64 73 20 64 62 20 6e 65 77 2d 72 75 6e 2d ords db new-run-
e940: 69 64 20 22 25 22 20 22 25 22 29 29 0a 09 20 28 id "%" "%")).. (
e950: 63 75 72 72 2d 74 65 73 74 73 20 20 20 20 20 20 curr-tests
e960: 28 64 62 2d 67 65 74 2d 74 65 73 74 73 2d 66 6f (db-get-tests-fo
e970: 72 2d 72 75 6e 20 64 62 20 6e 65 77 2d 72 75 6e r-run db new-run
e980: 2d 69 64 20 22 25 22 20 22 25 22 20 27 28 29 20 -id "%" "%" '()
e990: 27 28 29 29 29 0a 09 20 28 63 75 72 72 2d 74 65 '())).. (curr-te
e9a0: 73 74 73 2d 68 61 73 68 20 28 6d 61 6b 65 2d 68 sts-hash (make-h
e9b0: 61 73 68 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 ash-table))).
e9c0: 20 28 64 62 3a 75 70 64 61 74 65 2d 72 75 6e 2d (db:update-run-
e9d0: 65 76 65 6e 74 5f 74 69 6d 65 20 64 62 20 6e 65 event_time db ne
e9e0: 77 2d 72 75 6e 2d 69 64 29 0a 20 20 20 20 3b 3b w-run-id). ;;
e9f0: 20 69 6e 64 65 78 20 74 68 65 20 61 6c 72 65 61 index the alrea
ea00: 64 79 20 73 61 76 65 64 20 74 65 73 74 73 20 62 dy saved tests b
ea10: 79 20 74 65 73 74 6e 61 6d 65 20 61 6e 64 20 69 y testname and i
ea20: 74 65 6d 70 61 74 68 20 69 6e 20 63 75 72 72 2d tempath in curr-
ea30: 74 65 73 74 73 2d 68 61 73 68 0a 20 20 20 20 28 tests-hash. (
ea40: 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 6c for-each. (l
ea50: 61 6d 62 64 61 20 28 74 65 73 74 64 61 74 29 0a ambda (testdat).
ea60: 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 (let* ((t
ea70: 65 73 74 6e 61 6d 65 20 20 28 64 62 3a 74 65 73 estname (db:tes
ea80: 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 t-get-testname t
ea90: 65 73 74 64 61 74 29 29 0a 09 20 20 20 20 20 20 estdat))..
eaa0: 28 69 74 65 6d 2d 70 61 74 68 20 28 64 62 3a 74 (item-path (db:t
eab0: 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 est-get-item-pat
eac0: 68 20 74 65 73 74 64 61 74 29 29 0a 09 20 20 20 h testdat))..
ead0: 20 20 20 28 66 75 6c 6c 2d 6e 61 6d 65 20 28 63 (full-name (c
eae0: 6f 6e 63 20 74 65 73 74 6e 61 6d 65 20 22 2f 22 onc testname "/"
eaf0: 20 69 74 65 6d 2d 70 61 74 68 29 29 29 0a 09 20 item-path)))..
eb00: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
eb10: 20 63 75 72 72 2d 74 65 73 74 73 2d 68 61 73 68 curr-tests-hash
eb20: 20 66 75 6c 6c 2d 6e 61 6d 65 20 74 65 73 74 64 full-name testd
eb30: 61 74 29 29 29 0a 20 20 20 20 20 63 75 72 72 2d at))). curr-
eb40: 74 65 73 74 73 29 0a 20 20 20 20 3b 3b 20 4e 4f tests). ;; NO
eb50: 50 45 3a 20 4e 6f 6e 2d 6f 70 74 69 6d 61 6c 20 PE: Non-optimal
eb60: 61 70 70 72 6f 61 63 68 2e 20 54 72 79 20 74 68 approach. Try th
eb70: 69 73 20 69 6e 73 74 65 61 64 2e 0a 20 20 20 20 is instead..
eb80: 3b 3b 20 20 20 31 2e 20 74 65 73 74 73 20 61 72 ;; 1. tests ar
eb90: 65 20 72 65 63 65 69 76 65 64 20 69 6e 20 61 20 e received in a
eba0: 6c 69 73 74 2c 20 6d 6f 73 74 20 72 65 63 65 6e list, most recen
ebb0: 74 20 66 69 72 73 74 0a 20 20 20 20 3b 3b 20 20 t first. ;;
ebc0: 20 32 2e 20 72 65 70 6c 61 63 65 20 74 68 65 20 2. replace the
ebd0: 72 6f 6c 6c 75 70 20 74 65 73 74 20 77 69 74 68 rollup test with
ebe0: 20 74 68 65 20 6e 65 77 20 2a 61 6c 77 61 79 73 the new *always
ebf0: 2a 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 *. (for-each
ec00: 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 74 . (lambda (t
ec10: 65 73 74 64 61 74 29 0a 20 20 20 20 20 20 20 28 estdat). (
ec20: 6c 65 74 2a 20 28 28 74 65 73 74 6e 61 6d 65 20 let* ((testname
ec30: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 (db:test-get-te
ec40: 73 74 6e 61 6d 65 20 74 65 73 74 64 61 74 29 29 stname testdat))
ec50: 0a 09 20 20 20 20 20 20 28 69 74 65 6d 2d 70 61 .. (item-pa
ec60: 74 68 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d th (db:test-get-
ec70: 69 74 65 6d 2d 70 61 74 68 20 74 65 73 74 64 61 item-path testda
ec80: 74 29 29 0a 09 20 20 20 20 20 20 28 66 75 6c 6c t)).. (full
ec90: 2d 6e 61 6d 65 20 28 63 6f 6e 63 20 74 65 73 74 -name (conc test
eca0: 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 name "/" item-pa
ecb0: 74 68 29 29 0a 09 20 20 20 20 20 20 28 70 72 65 th)).. (pre
ecc0: 76 2d 74 65 73 74 2d 64 61 74 20 28 68 61 73 68 v-test-dat (hash
ecd0: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
ece0: 6c 74 20 63 75 72 72 2d 74 65 73 74 73 2d 68 61 lt curr-tests-ha
ecf0: 73 68 20 66 75 6c 6c 2d 6e 61 6d 65 20 23 66 29 sh full-name #f)
ed00: 29 0a 09 20 20 20 20 20 20 28 74 65 73 74 2d 73 ).. (test-s
ed10: 74 65 70 73 20 20 20 20 20 20 28 64 62 3a 67 65 teps (db:ge
ed20: 74 2d 73 74 65 70 73 2d 66 6f 72 2d 74 65 73 74 t-steps-for-test
ed30: 20 64 62 20 28 64 62 3a 74 65 73 74 2d 67 65 74 db (db:test-get
ed40: 2d 69 64 20 74 65 73 74 64 61 74 29 29 29 0a 09 -id testdat)))..
ed50: 20 20 20 20 20 20 28 6e 65 77 2d 74 65 73 74 2d (new-test-
ed60: 72 65 63 6f 72 64 20 23 66 29 29 0a 09 20 3b 3b record #f)).. ;;
ed70: 20 72 65 70 6c 61 63 65 20 74 68 65 73 65 20 77 replace these w
ed80: 69 74 68 20 69 6e 73 65 72 74 20 2e 2e 2e 20 73 ith insert ... s
ed90: 65 6c 65 63 74 0a 09 20 28 61 70 70 6c 79 20 73 elect.. (apply s
eda0: 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 0a qlite3:execute .
edb0: 09 09 64 62 20 0a 09 09 28 63 6f 6e 63 20 22 49 ..db ...(conc "I
edc0: 4e 53 45 52 54 20 4f 52 20 52 45 50 4c 41 43 45 NSERT OR REPLACE
edd0: 20 49 4e 54 4f 20 74 65 73 74 73 20 28 72 75 6e INTO tests (run
ede0: 5f 69 64 2c 74 65 73 74 6e 61 6d 65 2c 73 74 61 _id,testname,sta
edf0: 74 65 2c 73 74 61 74 75 73 2c 65 76 65 6e 74 5f te,status,event_
ee00: 74 69 6d 65 2c 68 6f 73 74 2c 63 70 75 6c 6f 61 time,host,cpuloa
ee10: 64 2c 64 69 73 6b 66 72 65 65 2c 75 6e 61 6d 65 d,diskfree,uname
ee20: 2c 72 75 6e 64 69 72 2c 69 74 65 6d 5f 70 61 74 ,rundir,item_pat
ee30: 68 2c 72 75 6e 5f 64 75 72 61 74 69 6f 6e 2c 66 h,run_duration,f
ee40: 69 6e 61 6c 5f 6c 6f 67 66 2c 63 6f 6d 6d 65 6e inal_logf,commen
ee50: 74 29 20 22 0a 09 09 20 20 20 20 20 20 22 56 41 t) "... "VA
ee60: 4c 55 45 53 20 28 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c LUES (?,?,?,?,?,
ee70: 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c ?,?,?,?,?,?,?,?,
ee80: 3f 29 3b 22 29 0a 09 09 6e 65 77 2d 72 75 6e 2d ?);")...new-run-
ee90: 69 64 20 28 63 64 64 72 20 28 76 65 63 74 6f 72 id (cddr (vector
eea0: 2d 3e 6c 69 73 74 20 74 65 73 74 64 61 74 29 29 ->list testdat))
eeb0: 29 0a 09 20 28 73 65 74 21 20 6e 65 77 2d 74 65 ).. (set! new-te
eec0: 73 74 64 61 74 20 28 63 61 72 20 28 64 62 2d 67 stdat (car (db-g
eed0: 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e et-tests-for-run
eee0: 20 64 62 20 6e 65 77 2d 72 75 6e 2d 69 64 20 74 db new-run-id t
eef0: 65 73 74 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 estname item-pat
ef00: 68 20 27 28 29 20 27 28 29 29 29 29 0a 09 20 28 h '() '()))).. (
ef10: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
ef20: 63 75 72 72 2d 74 65 73 74 73 2d 68 61 73 68 20 curr-tests-hash
ef30: 66 75 6c 6c 2d 6e 61 6d 65 20 6e 65 77 2d 74 65 full-name new-te
ef40: 73 74 64 61 74 29 20 3b 3b 20 74 68 69 73 20 63 stdat) ;; this c
ef50: 6f 75 6c 64 20 62 65 20 63 6f 6e 66 75 73 69 6e ould be confusin
ef60: 67 2c 20 77 68 69 63 68 20 72 65 63 6f 72 64 20 g, which record
ef70: 73 68 6f 75 6c 64 20 67 6f 20 69 6e 74 6f 20 74 should go into t
ef80: 68 65 20 6c 6f 6f 6b 75 70 20 74 61 62 6c 65 3f he lookup table?
ef90: 0a 09 20 3b 3b 20 4e 6f 77 20 64 75 70 6c 69 63 .. ;; Now duplic
efa0: 61 74 65 20 74 68 65 20 74 65 73 74 20 73 74 65 ate the test ste
efb0: 70 73 0a 09 20 28 64 65 62 75 67 3a 70 72 69 6e ps.. (debug:prin
efc0: 74 20 34 20 22 43 6f 70 79 69 6e 67 20 72 65 63 t 4 "Copying rec
efd0: 6f 72 64 73 20 69 6e 20 74 65 73 74 5f 73 74 65 ords in test_ste
efe0: 70 73 20 66 72 6f 6d 20 74 65 73 74 5f 69 64 3d ps from test_id=
eff0: 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 " (db:test-get-i
f000: 64 20 74 65 73 74 64 61 74 29 20 22 20 74 6f 20 d testdat) " to
f010: 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 " (db:test-get-i
f020: 64 20 6e 65 77 2d 74 65 73 74 64 61 74 29 29 0a d new-testdat)).
f030: 09 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 . (sqlite3:execu
f040: 74 65 20 0a 09 20 20 64 62 20 0a 09 20 20 28 63 te .. db .. (c
f050: 6f 6e 63 20 22 49 4e 53 45 52 54 20 4f 52 20 52 onc "INSERT OR R
f060: 45 50 4c 41 43 45 20 49 4e 54 4f 20 74 65 73 74 EPLACE INTO test
f070: 5f 73 74 65 70 73 20 28 74 65 73 74 5f 69 64 2c _steps (test_id,
f080: 73 74 65 70 6e 61 6d 65 2c 73 74 61 74 65 2c 73 stepname,state,s
f090: 74 61 74 75 73 2c 65 76 65 6e 74 5f 74 69 6d 65 tatus,event_time
f0a0: 2c 63 6f 6d 6d 65 6e 74 29 20 22 0a 09 09 22 53 ,comment) "..."S
f0b0: 45 4c 45 43 54 20 22 20 28 64 62 3a 74 65 73 74 ELECT " (db:test
f0c0: 2d 67 65 74 2d 69 64 20 6e 65 77 2d 74 65 73 74 -get-id new-test
f0d0: 64 61 74 29 20 22 2c 73 74 65 70 6e 61 6d 65 2c dat) ",stepname,
f0e0: 73 74 61 74 65 2c 73 74 61 74 75 73 2c 65 76 65 state,status,eve
f0f0: 6e 74 5f 74 69 6d 65 2c 63 6f 6d 6d 65 6e 74 20 nt_time,comment
f100: 46 52 4f 4d 20 74 65 73 74 5f 73 74 65 70 73 20 FROM test_steps
f110: 57 48 45 52 45 20 74 65 73 74 5f 69 64 3d 3f 3b WHERE test_id=?;
f120: 22 29 0a 09 20 20 28 64 62 3a 74 65 73 74 2d 67 ").. (db:test-g
f130: 65 74 2d 69 64 20 74 65 73 74 64 61 74 29 29 0a et-id testdat)).
f140: 09 20 3b 3b 20 4e 6f 77 20 64 75 70 6c 69 63 61 . ;; Now duplica
f150: 74 65 20 74 68 65 20 74 65 73 74 20 64 61 74 61 te the test data
f160: 0a 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 .. (debug:print
f170: 34 20 22 43 6f 70 79 69 6e 67 20 72 65 63 6f 72 4 "Copying recor
f180: 64 73 20 69 6e 20 74 65 73 74 5f 64 61 74 61 20 ds in test_data
f190: 66 72 6f 6d 20 74 65 73 74 5f 69 64 3d 22 20 28 from test_id=" (
f1a0: 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 db:test-get-id t
f1b0: 65 73 74 64 61 74 29 20 22 20 74 6f 20 22 20 28 estdat) " to " (
f1c0: 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 6e db:test-get-id n
f1d0: 65 77 2d 74 65 73 74 64 61 74 29 29 0a 09 20 28 ew-testdat)).. (
f1e0: 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 sqlite3:execute
f1f0: 0a 09 20 20 64 62 20 0a 09 20 20 28 63 6f 6e 63 .. db .. (conc
f200: 20 22 49 4e 53 45 52 54 20 4f 52 20 52 45 50 4c "INSERT OR REPL
f210: 41 43 45 20 49 4e 54 4f 20 74 65 73 74 5f 64 61 ACE INTO test_da
f220: 74 61 20 28 74 65 73 74 5f 69 64 2c 63 61 74 65 ta (test_id,cate
f230: 67 6f 72 79 2c 76 61 72 69 61 62 6c 65 2c 76 61 gory,variable,va
f240: 6c 75 65 2c 65 78 70 65 63 74 65 64 2c 74 6f 6c lue,expected,tol
f250: 2c 75 6e 69 74 73 2c 63 6f 6d 6d 65 6e 74 29 20 ,units,comment)
f260: 22 0a 09 09 22 53 45 4c 45 43 54 20 22 20 28 64 "..."SELECT " (d
f270: 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 6e 65 b:test-get-id ne
f280: 77 2d 74 65 73 74 64 61 74 29 20 22 2c 63 61 74 w-testdat) ",cat
f290: 65 67 6f 72 79 2c 76 61 72 69 61 62 6c 65 2c 76 egory,variable,v
f2a0: 61 6c 75 65 2c 65 78 70 65 63 74 65 64 2c 74 6f alue,expected,to
f2b0: 6c 2c 75 6e 69 74 73 2c 63 6f 6d 6d 65 6e 74 20 l,units,comment
f2c0: 46 52 4f 4d 20 74 65 73 74 5f 64 61 74 61 20 57 FROM test_data W
f2d0: 48 45 52 45 20 74 65 73 74 5f 69 64 3d 3f 3b 22 HERE test_id=?;"
f2e0: 29 0a 09 20 20 28 64 62 3a 74 65 73 74 2d 67 65 ).. (db:test-ge
f2f0: 74 2d 69 64 20 74 65 73 74 64 61 74 29 29 0a 09 t-id testdat))..
f300: 20 29 29 0a 20 20 20 20 20 70 72 65 76 2d 74 65 )). prev-te
f310: 73 74 73 29 29 29 0a 09 20 0a 20 20 20 20 20 0a sts))).. . .