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 23 name item-path #
1490: 66 20 23 66 29 29 29 0a 09 09 20 20 28 64 65 62 f #f)))... (deb
14a0: 75 67 3a 70 72 69 6e 74 20 34 20 22 47 6f 74 20 ug:print 4 "Got
14b0: 74 65 73 74 73 20 66 6f 72 20 72 75 6e 2d 69 64 tests for run-id
14c0: 20 22 20 72 75 6e 2d 69 64 20 22 2c 20 74 65 73 " run-id ", tes
14d0: 74 2d 6e 61 6d 65 20 22 20 74 65 73 74 2d 6e 61 t-name " test-na
14e0: 6d 65 20 22 2c 20 69 74 65 6d 2d 70 61 74 68 20 me ", item-path
14f0: 22 20 69 74 65 6d 2d 70 61 74 68 20 22 3a 20 22 " item-path ": "
1500: 20 72 65 73 75 6c 74 73 29 0a 09 09 20 20 28 69 results)... (i
1510: 66 20 28 61 6e 64 20 28 6e 75 6c 6c 3f 20 72 65 f (and (null? re
1520: 73 75 6c 74 73 29 0a 09 09 09 20 20 20 28 6e 6f sults).... (no
1530: 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 29 0a t (null? tal))).
1540: 09 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 .. (loop (c
1550: 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 ar tal)(cdr tal)
1560: 29 0a 09 09 20 20 20 20 20 20 28 69 66 20 28 6e )... (if (n
1570: 75 6c 6c 3f 20 72 65 73 75 6c 74 73 29 20 23 66 ull? results) #f
1580: 0a 09 09 09 20 20 28 63 61 72 20 72 65 73 75 6c .... (car resul
1590: 74 73 29 29 29 29 29 29 29 29 29 29 0a 20 20 20 ts)))))))))).
15a0: 20 0a 3b 3b 20 67 65 74 20 74 68 65 20 70 72 65 .;; get the pre
15b0: 76 69 6f 75 73 20 72 65 63 6f 72 64 73 20 66 6f vious records fo
15c0: 72 20 77 68 65 6e 20 74 68 65 73 65 20 74 65 73 r when these tes
15d0: 74 73 20 77 65 72 65 20 72 75 6e 20 77 68 65 72 ts were run wher
15e0: 65 20 61 6c 6c 20 6b 65 79 73 20 6d 61 74 63 68 e all keys match
15f0: 20 62 75 74 20 72 75 6e 6e 61 6d 65 0a 3b 3b 20 but runname.;;
1600: 4e 42 2f 2f 20 4d 65 72 67 65 20 74 68 69 73 20 NB// Merge this
1610: 77 69 74 68 20 74 65 73 74 3a 67 65 74 2d 70 72 with test:get-pr
1620: 65 76 69 6f 75 73 2d 74 65 73 74 2d 72 75 6e 2d evious-test-run-
1630: 72 65 63 6f 72 64 73 3f 20 54 68 69 73 20 6f 6e records? This on
1640: 65 20 6c 6f 6f 6b 73 20 66 6f 72 20 61 6c 6c 20 e looks for all
1650: 6d 61 74 63 68 69 6e 67 20 74 65 73 74 73 0a 3b matching tests.;
1660: 3b 20 63 61 6e 20 75 73 65 20 77 69 6c 64 63 61 ; can use wildca
1670: 72 64 73 2e 20 0a 28 64 65 66 69 6e 65 20 28 74 rds. .(define (t
1680: 65 73 74 3a 67 65 74 2d 6d 61 74 63 68 69 6e 67 est:get-matching
1690: 2d 70 72 65 76 69 6f 75 73 2d 74 65 73 74 2d 72 -previous-test-r
16a0: 75 6e 2d 72 65 63 6f 72 64 73 20 64 62 20 72 75 un-records db ru
16b0: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 n-id test-name i
16c0: 74 65 6d 2d 70 61 74 68 29 0a 20 20 28 6c 65 74 tem-path). (let
16d0: 2a 20 28 28 6b 65 79 73 20 20 20 20 28 64 62 3a * ((keys (db:
16e0: 67 65 74 2d 6b 65 79 73 20 64 62 29 29 0a 09 20 get-keys db))..
16f0: 28 73 65 6c 73 74 72 20 20 28 73 74 72 69 6e 67 (selstr (string
1700: 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 -intersperse (ma
1710: 70 20 28 6c 61 6d 62 64 61 20 28 78 29 28 76 65 p (lambda (x)(ve
1720: 63 74 6f 72 2d 72 65 66 20 78 20 30 29 29 20 6b ctor-ref x 0)) k
1730: 65 79 73 29 20 22 2c 22 29 29 0a 09 20 28 71 72 eys) ",")).. (qr
1740: 79 73 74 72 20 20 28 73 74 72 69 6e 67 2d 69 6e ystr (string-in
1750: 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 20 28 tersperse (map (
1760: 6c 61 6d 62 64 61 20 28 78 29 28 63 6f 6e 63 20 lambda (x)(conc
1770: 28 76 65 63 74 6f 72 2d 72 65 66 20 78 20 30 29 (vector-ref x 0)
1780: 20 22 3d 3f 22 29 29 20 6b 65 79 73 29 20 22 20 "=?")) keys) "
1790: 41 4e 44 20 22 29 29 0a 09 20 28 6b 65 79 76 61 AND ")).. (keyva
17a0: 6c 73 20 23 66 29 0a 09 20 28 74 65 73 74 73 2d ls #f).. (tests-
17b0: 68 61 73 68 20 28 6d 61 6b 65 2d 68 61 73 68 2d hash (make-hash-
17c0: 74 61 62 6c 65 29 29 29 0a 20 20 20 20 3b 3b 20 table))). ;;
17d0: 66 69 72 73 74 20 6c 6f 6f 6b 20 75 70 20 74 68 first look up th
17e0: 65 20 6b 65 79 20 76 61 6c 75 65 73 20 66 72 6f e key values fro
17f0: 6d 20 74 68 65 20 72 75 6e 20 73 65 6c 65 63 74 m the run select
1800: 65 64 20 62 79 20 72 75 6e 2d 69 64 0a 20 20 20 ed by run-id.
1810: 20 28 73 71 6c 69 74 65 33 3a 66 6f 72 2d 65 61 (sqlite3:for-ea
1820: 63 68 2d 72 6f 77 20 0a 20 20 20 20 20 28 6c 61 ch-row . (la
1830: 6d 62 64 61 20 28 61 20 2e 20 62 29 0a 20 20 20 mbda (a . b).
1840: 20 20 20 20 28 73 65 74 21 20 6b 65 79 76 61 6c (set! keyval
1850: 73 20 28 63 6f 6e 73 20 61 20 62 29 29 29 0a 20 s (cons a b))).
1860: 20 20 20 20 64 62 0a 20 20 20 20 20 28 63 6f 6e db. (con
1870: 63 20 22 53 45 4c 45 43 54 20 22 20 73 65 6c 73 c "SELECT " sels
1880: 74 72 20 22 20 46 52 4f 4d 20 72 75 6e 73 20 57 tr " FROM runs W
1890: 48 45 52 45 20 69 64 3d 3f 20 4f 52 44 45 52 20 HERE id=? ORDER
18a0: 42 59 20 65 76 65 6e 74 5f 74 69 6d 65 20 44 45 BY event_time DE
18b0: 53 43 3b 22 29 20 72 75 6e 2d 69 64 29 0a 20 20 SC;") run-id).
18c0: 20 20 28 69 66 20 28 6e 6f 74 20 6b 65 79 76 61 (if (not keyva
18d0: 6c 73 29 0a 09 27 28 29 0a 09 28 6c 65 74 20 28 ls)..'()..(let (
18e0: 28 70 72 65 76 2d 72 75 6e 2d 69 64 73 20 27 28 (prev-run-ids '(
18f0: 29 29 29 0a 09 20 20 28 61 70 70 6c 79 20 73 71 ))).. (apply sq
1900: 6c 69 74 65 33 3a 66 6f 72 2d 65 61 63 68 2d 72 lite3:for-each-r
1910: 6f 77 0a 09 09 20 28 6c 61 6d 62 64 61 20 28 69 ow... (lambda (i
1920: 64 29 0a 09 09 20 20 20 28 73 65 74 21 20 70 72 d)... (set! pr
1930: 65 76 2d 72 75 6e 2d 69 64 73 20 28 63 6f 6e 73 ev-run-ids (cons
1940: 20 69 64 20 70 72 65 76 2d 72 75 6e 2d 69 64 73 id prev-run-ids
1950: 29 29 29 0a 09 09 20 64 62 0a 09 09 20 28 63 6f )))... db... (co
1960: 6e 63 20 22 53 45 4c 45 43 54 20 69 64 20 46 52 nc "SELECT id FR
1970: 4f 4d 20 72 75 6e 73 20 57 48 45 52 45 20 22 20 OM runs WHERE "
1980: 71 72 79 73 74 72 20 22 20 41 4e 44 20 69 64 20 qrystr " AND id
1990: 21 3d 20 3f 3b 22 29 20 28 61 70 70 65 6e 64 20 != ?;") (append
19a0: 6b 65 79 76 61 6c 73 20 28 6c 69 73 74 20 72 75 keyvals (list ru
19b0: 6e 2d 69 64 29 29 29 0a 09 20 20 3b 3b 20 63 6f n-id))).. ;; co
19c0: 6c 6c 65 63 74 20 61 6c 6c 20 6d 61 74 63 68 69 llect all matchi
19d0: 6e 67 20 74 65 73 74 73 20 66 6f 72 20 74 68 65 ng tests for the
19e0: 20 72 75 6e 73 20 74 68 65 6e 0a 09 20 20 3b 3b runs then.. ;;
19f0: 20 65 78 74 72 61 63 74 20 74 68 65 20 6d 6f 73 extract the mos
1a00: 74 20 72 65 63 65 6e 74 20 74 65 73 74 20 61 6e t recent test an
1a10: 64 20 72 65 74 75 72 6e 20 74 68 61 74 2e 0a 09 d return that...
1a20: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 (debug:print 4
1a30: 20 22 73 65 6c 73 74 72 3a 20 22 20 73 65 6c 73 "selstr: " sels
1a40: 74 72 20 22 2c 20 71 72 79 73 74 72 3a 20 22 20 tr ", qrystr: "
1a50: 71 72 79 73 74 72 20 22 2c 20 6b 65 79 76 61 6c qrystr ", keyval
1a60: 73 3a 20 22 20 6b 65 79 76 61 6c 73 20 0a 09 09 s: " keyvals ...
1a70: 20 20 20 20 20 20 20 22 2c 20 70 72 65 76 69 6f ", previo
1a80: 75 73 20 72 75 6e 20 69 64 73 20 66 6f 75 6e 64 us run ids found
1a90: 3a 20 22 20 70 72 65 76 2d 72 75 6e 2d 69 64 73 : " prev-run-ids
1aa0: 29 0a 09 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 ).. (if (null?
1ab0: 70 72 65 76 2d 72 75 6e 2d 69 64 73 29 20 27 28 prev-run-ids) '(
1ac0: 29 20 20 3b 3b 20 6e 6f 20 70 72 65 76 69 6f 75 ) ;; no previou
1ad0: 73 20 72 75 6e 73 3f 20 72 65 74 75 72 6e 20 6e s runs? return n
1ae0: 75 6c 6c 0a 09 20 20 20 20 20 20 28 6c 65 74 20 ull.. (let
1af0: 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 61 72 20 loop ((hed (car
1b00: 70 72 65 76 2d 72 75 6e 2d 69 64 73 29 29 0a 09 prev-run-ids))..
1b10: 09 09 20 28 74 61 6c 20 28 63 64 72 20 70 72 65 .. (tal (cdr pre
1b20: 76 2d 72 75 6e 2d 69 64 73 29 29 29 0a 09 09 28 v-run-ids)))...(
1b30: 6c 65 74 20 28 28 72 65 73 75 6c 74 73 20 28 64 let ((results (d
1b40: 62 2d 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d b-get-tests-for-
1b50: 72 75 6e 20 64 62 20 68 65 64 20 74 65 73 74 2d run db hed test-
1b60: 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 23 name item-path #
1b70: 66 20 23 66 29 29 29 0a 09 09 20 20 28 64 65 62 f #f)))... (deb
1b80: 75 67 3a 70 72 69 6e 74 20 34 20 22 47 6f 74 20 ug:print 4 "Got
1b90: 74 65 73 74 73 20 66 6f 72 20 72 75 6e 2d 69 64 tests for run-id
1ba0: 20 22 20 72 75 6e 2d 69 64 20 22 2c 20 74 65 73 " run-id ", tes
1bb0: 74 2d 6e 61 6d 65 20 22 20 74 65 73 74 2d 6e 61 t-name " test-na
1bc0: 6d 65 20 0a 09 09 09 20 20 20 20 20 20 20 22 2c me .... ",
1bd0: 20 69 74 65 6d 2d 70 61 74 68 20 22 20 69 74 65 item-path " ite
1be0: 6d 2d 70 61 74 68 20 22 20 72 65 73 75 6c 74 73 m-path " results
1bf0: 3a 20 22 20 28 69 6e 74 65 72 73 70 65 72 73 65 : " (intersperse
1c00: 20 72 65 73 75 6c 74 73 20 22 5c 6e 22 29 29 0a results "\n")).
1c10: 09 09 20 20 3b 3b 20 4b 65 65 70 20 6f 6e 6c 79 .. ;; Keep only
1c20: 20 74 68 65 20 79 6f 75 6e 67 65 73 74 20 6f 66 the youngest of
1c30: 20 61 6e 79 20 74 65 73 74 2f 69 74 65 6d 20 63 any test/item c
1c40: 6f 6d 62 69 6e 61 74 69 6f 6e 0a 09 09 20 20 28 ombination... (
1c50: 66 6f 72 2d 65 61 63 68 20 0a 09 09 20 20 20 28 for-each ... (
1c60: 6c 61 6d 62 64 61 20 28 74 65 73 74 64 61 74 29 lambda (testdat)
1c70: 0a 09 09 20 20 20 20 20 28 6c 65 74 2a 20 28 28 ... (let* ((
1c80: 66 75 6c 6c 2d 74 65 73 74 6e 61 6d 65 20 28 63 full-testname (c
1c90: 6f 6e 63 20 28 64 62 3a 74 65 73 74 2d 67 65 74 onc (db:test-get
1ca0: 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 64 61 -testname testda
1cb0: 74 29 20 22 2f 22 20 28 64 62 3a 74 65 73 74 2d t) "/" (db:test-
1cc0: 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 65 get-item-path te
1cd0: 73 74 64 61 74 29 29 29 0a 09 09 09 20 20 20 20 stdat)))....
1ce0: 28 73 74 6f 72 65 64 2d 74 65 73 74 20 20 20 28 (stored-test (
1cf0: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
1d00: 65 66 61 75 6c 74 20 74 65 73 74 73 2d 68 61 73 efault tests-has
1d10: 68 20 66 75 6c 6c 2d 74 65 73 74 6e 61 6d 65 20 h full-testname
1d20: 23 66 29 29 29 0a 09 09 20 20 20 20 20 20 20 28 #f)))... (
1d30: 69 66 20 28 6f 72 20 28 6e 6f 74 20 73 74 6f 72 if (or (not stor
1d40: 65 64 2d 74 65 73 74 29 0a 09 09 09 20 20 20 20 ed-test)....
1d50: 20 20 20 28 61 6e 64 20 73 74 6f 72 65 64 2d 74 (and stored-t
1d60: 65 73 74 0a 09 09 09 09 20 20 20 20 28 3e 20 28 est..... (> (
1d70: 64 62 3a 74 65 73 74 2d 67 65 74 2d 65 76 65 6e db:test-get-even
1d80: 74 5f 74 69 6d 65 20 74 65 73 74 64 61 74 29 28 t_time testdat)(
1d90: 64 62 3a 74 65 73 74 2d 67 65 74 2d 65 76 65 6e db:test-get-even
1da0: 74 5f 74 69 6d 65 20 73 74 6f 72 65 64 2d 74 65 t_time stored-te
1db0: 73 74 29 29 29 29 0a 09 09 09 20 20 20 3b 3b 20 st)))).... ;;
1dc0: 74 68 69 73 20 74 65 73 74 20 69 73 20 79 6f 75 this test is you
1dd0: 6e 67 65 72 2c 20 73 74 6f 72 65 20 69 74 20 69 nger, store it i
1de0: 6e 20 74 68 65 20 68 61 73 68 0a 09 09 09 20 20 n the hash....
1df0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
1e00: 21 20 74 65 73 74 73 2d 68 61 73 68 20 66 75 6c ! tests-hash ful
1e10: 6c 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 64 l-testname testd
1e20: 61 74 29 29 29 29 0a 09 09 20 20 20 72 65 73 75 at))))... resu
1e30: 6c 74 73 29 0a 09 09 20 20 28 69 66 20 28 6e 75 lts)... (if (nu
1e40: 6c 6c 3f 20 74 61 6c 29 0a 09 09 20 20 20 20 20 ll? tal)...
1e50: 20 28 6d 61 70 20 63 64 72 20 28 68 61 73 68 2d (map cdr (hash-
1e60: 74 61 62 6c 65 2d 3e 61 6c 69 73 74 20 74 65 73 table->alist tes
1e70: 74 73 2d 68 61 73 68 29 29 20 3b 3b 20 72 65 74 ts-hash)) ;; ret
1e80: 75 72 6e 20 61 20 6c 69 73 74 20 6f 66 20 74 68 urn a list of th
1e90: 65 20 6d 6f 73 74 20 72 65 63 65 6e 74 20 74 65 e most recent te
1ea0: 73 74 73 0a 09 09 20 20 20 20 20 20 28 6c 6f 6f sts... (loo
1eb0: 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 p (car tal)(cdr
1ec0: 74 61 6c 29 29 29 29 29 29 29 29 29 29 0a 0a 28 tal))))))))))..(
1ed0: 64 65 66 69 6e 65 20 28 74 65 73 74 2d 73 65 74 define (test-set
1ee0: 2d 73 74 61 74 75 73 21 20 64 62 20 72 75 6e 2d -status! db run-
1ef0: 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 73 74 61 id test-name sta
1f00: 74 65 20 73 74 61 74 75 73 20 69 74 65 6d 64 61 te status itemda
1f10: 74 2d 6f 72 2d 70 61 74 68 20 63 6f 6d 6d 65 6e t-or-path commen
1f20: 74 20 64 61 74 29 0a 20 20 28 6c 65 74 2a 20 28 t dat). (let* (
1f30: 28 72 65 61 6c 2d 73 74 61 74 75 73 20 73 74 61 (real-status sta
1f40: 74 75 73 29 0a 09 20 28 69 74 65 6d 2d 70 61 74 tus).. (item-pat
1f50: 68 20 20 20 28 69 66 20 28 73 74 72 69 6e 67 3f h (if (string?
1f60: 20 69 74 65 6d 64 61 74 2d 6f 72 2d 70 61 74 68 itemdat-or-path
1f70: 29 20 69 74 65 6d 64 61 74 2d 6f 72 2d 70 61 74 ) itemdat-or-pat
1f80: 68 20 28 69 74 65 6d 2d 6c 69 73 74 2d 3e 70 61 h (item-list->pa
1f90: 74 68 20 69 74 65 6d 64 61 74 2d 6f 72 2d 70 61 th itemdat-or-pa
1fa0: 74 68 29 29 29 0a 09 20 28 74 65 73 74 64 61 74 th))).. (testdat
1fb0: 20 20 20 20 20 28 64 62 3a 67 65 74 2d 74 65 73 (db:get-tes
1fc0: 74 2d 69 6e 66 6f 20 64 62 20 72 75 6e 2d 69 64 t-info db run-id
1fd0: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item-
1fe0: 70 61 74 68 29 29 0a 09 20 28 74 65 73 74 2d 69 path)).. (test-i
1ff0: 64 20 20 20 20 20 28 69 66 20 74 65 73 74 64 61 d (if testda
2000: 74 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 t (db:test-get-i
2010: 64 20 74 65 73 74 64 61 74 29 20 23 66 29 29 0a d testdat) #f)).
2020: 09 20 28 6f 74 68 65 72 64 61 74 20 20 20 20 28 . (otherdat (
2030: 69 66 20 64 61 74 20 64 61 74 20 28 6d 61 6b 65 if dat dat (make
2040: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 0a 09 -hash-table)))..
2050: 20 3b 3b 20 62 65 66 6f 72 65 20 70 72 6f 63 65 ;; before proce
2060: 65 64 69 6e 67 20 77 65 20 6d 75 73 74 20 66 69 eding we must fi
2070: 6e 64 20 6f 75 74 20 69 66 20 74 68 65 20 70 72 nd out if the pr
2080: 65 76 69 6f 75 73 20 74 65 73 74 20 28 77 68 65 evious test (whe
2090: 72 65 20 61 6c 6c 20 6b 65 79 73 20 6d 61 74 63 re all keys matc
20a0: 68 65 64 20 65 78 63 65 70 74 20 72 75 6e 6e 61 hed except runna
20b0: 6d 65 29 0a 09 20 3b 3b 20 77 61 73 20 57 41 49 me).. ;; was WAI
20c0: 56 45 44 20 69 66 20 74 68 69 73 20 74 65 73 74 VED if this test
20d0: 20 69 73 20 46 41 49 4c 0a 09 20 28 77 61 69 76 is FAIL.. (waiv
20e0: 65 64 20 20 20 28 69 66 20 28 65 71 75 61 6c 3f ed (if (equal?
20f0: 20 73 74 61 74 75 73 20 22 46 41 49 4c 22 29 0a status "FAIL").
2100: 09 09 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 .. (let ((
2110: 70 72 65 76 2d 74 65 73 74 20 28 74 65 73 74 3a prev-test (test:
2120: 67 65 74 2d 70 72 65 76 69 6f 75 73 2d 74 65 73 get-previous-tes
2130: 74 2d 72 75 6e 2d 72 65 63 6f 72 64 20 64 62 20 t-run-record db
2140: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
2150: 20 69 74 65 6d 2d 70 61 74 68 29 29 29 0a 09 09 item-path)))...
2160: 09 20 28 69 66 20 70 72 65 76 2d 74 65 73 74 20 . (if prev-test
2170: 3b 3b 20 74 72 75 65 20 69 66 20 77 65 20 66 6f ;; true if we fo
2180: 75 6e 64 20 61 20 70 72 65 76 69 6f 75 73 20 74 und a previous t
2190: 65 73 74 20 69 6e 20 74 68 69 73 20 72 75 6e 20 est in this run
21a0: 73 65 72 69 65 73 0a 09 09 09 20 20 20 20 20 28 series.... (
21b0: 6c 65 74 20 28 28 70 72 65 76 2d 73 74 61 74 75 let ((prev-statu
21c0: 73 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 s (db:test-get-s
21d0: 74 61 74 75 73 20 20 20 70 72 65 76 2d 74 65 73 tatus prev-tes
21e0: 74 29 29 0a 09 09 09 09 20 20 20 28 70 72 65 76 t))..... (prev
21f0: 2d 73 74 61 74 65 20 20 28 64 62 3a 74 65 73 74 -state (db:test
2200: 2d 67 65 74 2d 73 74 61 74 65 20 20 20 20 70 72 -get-state pr
2210: 65 76 2d 74 65 73 74 29 29 0a 09 09 09 09 20 20 ev-test)).....
2220: 20 28 70 72 65 76 2d 63 6f 6d 6d 65 6e 74 20 28 (prev-comment (
2230: 64 62 3a 74 65 73 74 2d 67 65 74 2d 63 6f 6d 6d db:test-get-comm
2240: 65 6e 74 20 70 72 65 76 2d 74 65 73 74 29 29 29 ent prev-test)))
2250: 0a 09 09 09 20 20 20 20 20 20 20 28 64 65 62 75 .... (debu
2260: 67 3a 70 72 69 6e 74 20 34 20 22 70 72 65 76 2d g:print 4 "prev-
2270: 73 74 61 74 75 73 20 22 20 70 72 65 76 2d 73 74 status " prev-st
2280: 61 74 75 73 20 22 2c 20 70 72 65 76 2d 73 74 61 atus ", prev-sta
2290: 74 65 20 22 20 70 72 65 76 2d 73 74 61 74 65 20 te " prev-state
22a0: 22 2c 20 70 72 65 76 2d 63 6f 6d 6d 65 6e 74 20 ", prev-comment
22b0: 22 20 70 72 65 76 2d 63 6f 6d 6d 65 6e 74 29 0a " prev-comment).
22c0: 09 09 09 20 20 20 20 20 20 20 28 69 66 20 28 61 ... (if (a
22d0: 6e 64 20 28 65 71 75 61 6c 3f 20 70 72 65 76 2d nd (equal? prev-
22e0: 73 74 61 74 65 20 20 22 43 4f 4d 50 4c 45 54 45 state "COMPLETE
22f0: 44 22 29 0a 09 09 09 09 09 28 65 71 75 61 6c 3f D")......(equal?
2300: 20 70 72 65 76 2d 73 74 61 74 75 73 20 22 57 41 prev-status "WA
2310: 49 56 45 44 22 29 29 0a 09 09 09 09 20 20 20 70 IVED"))..... p
2320: 72 65 76 2d 63 6f 6d 6d 65 6e 74 20 3b 3b 20 77 rev-comment ;; w
2330: 61 69 76 65 64 20 69 73 20 65 69 74 68 65 72 20 aived is either
2340: 74 68 65 20 63 6f 6d 6d 65 6e 74 20 6f 72 20 23 the comment or #
2350: 66 0a 09 09 09 09 20 20 20 23 66 29 29 0a 09 09 f..... #f))...
2360: 09 20 20 20 20 20 23 66 29 29 0a 09 09 20 20 20 . #f))...
2370: 20 20 20 20 23 66 29 29 29 0a 20 20 20 20 28 69 #f))). (i
2380: 66 20 77 61 69 76 65 64 20 28 73 65 74 21 20 72 f waived (set! r
2390: 65 61 6c 2d 73 74 61 74 75 73 20 22 57 41 49 56 eal-status "WAIV
23a0: 45 44 22 29 29 0a 20 20 20 20 28 64 65 62 75 67 ED")). (debug
23b0: 3a 70 72 69 6e 74 20 34 20 22 72 65 61 6c 2d 73 :print 4 "real-s
23c0: 74 61 74 75 73 20 22 20 72 65 61 6c 2d 73 74 61 tatus " real-sta
23d0: 74 75 73 20 22 2c 20 77 61 69 76 65 64 20 22 20 tus ", waived "
23e0: 77 61 69 76 65 64 20 22 2c 20 73 74 61 74 75 73 waived ", status
23f0: 20 22 20 73 74 61 74 75 73 29 0a 0a 20 20 20 20 " status)..
2400: 3b 3b 20 75 70 64 61 74 65 20 74 68 65 20 70 72 ;; update the pr
2410: 69 6d 61 72 79 20 72 65 63 6f 72 64 20 49 46 20 imary record IF
2420: 73 74 61 74 65 20 41 4e 44 20 73 74 61 74 75 73 state AND status
2430: 20 61 72 65 20 64 65 66 69 6e 65 64 0a 20 20 20 are defined.
2440: 20 28 69 66 20 28 61 6e 64 20 73 74 61 74 65 20 (if (and state
2450: 73 74 61 74 75 73 29 0a 09 28 73 71 6c 69 74 65 status)..(sqlite
2460: 33 3a 65 78 65 63 75 74 65 20 64 62 20 22 55 50 3:execute db "UP
2470: 44 41 54 45 20 74 65 73 74 73 20 53 45 54 20 73 DATE tests SET s
2480: 74 61 74 65 3d 3f 2c 73 74 61 74 75 73 3d 3f 2c tate=?,status=?,
2490: 65 76 65 6e 74 5f 74 69 6d 65 3d 73 74 72 66 74 event_time=strft
24a0: 69 6d 65 28 27 25 73 27 2c 27 6e 6f 77 27 29 20 ime('%s','now')
24b0: 57 48 45 52 45 20 72 75 6e 5f 69 64 3d 3f 20 41 WHERE run_id=? A
24c0: 4e 44 20 74 65 73 74 6e 61 6d 65 3d 3f 20 41 4e ND testname=? AN
24d0: 44 20 69 74 65 6d 5f 70 61 74 68 3d 3f 3b 22 20 D item_path=?;"
24e0: 0a 09 09 09 20 73 74 61 74 65 20 72 65 61 6c 2d .... state real-
24f0: 73 74 61 74 75 73 20 72 75 6e 2d 69 64 20 74 65 status run-id te
2500: 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 st-name item-pat
2510: 68 29 29 0a 0a 20 20 20 20 3b 3b 20 69 66 20 73 h)).. ;; if s
2520: 74 61 74 75 73 20 69 73 20 22 41 55 54 4f 22 20 tatus is "AUTO"
2530: 74 68 65 6e 20 63 61 6c 6c 20 72 6f 6c 6c 75 70 then call rollup
2540: 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 74 65 . (if (and te
2550: 73 74 2d 69 64 20 73 74 61 74 65 20 73 74 61 74 st-id state stat
2560: 75 73 20 28 65 71 75 61 6c 3f 20 73 74 61 74 75 us (equal? statu
2570: 73 20 22 41 55 54 4f 22 29 29 20 0a 09 28 64 62 s "AUTO")) ..(db
2580: 3a 74 65 73 74 2d 64 61 74 61 2d 72 6f 6c 6c 75 :test-data-rollu
2590: 70 20 64 62 20 74 65 73 74 2d 69 64 29 29 0a 0a p db test-id))..
25a0: 20 20 20 20 3b 3b 20 61 64 64 20 6d 65 74 61 64 ;; add metad
25b0: 61 74 61 20 28 6e 65 65 64 20 74 6f 20 64 6f 20 ata (need to do
25c0: 74 68 69 73 20 77 61 79 20 74 6f 20 61 76 6f 69 this way to avoi
25d0: 64 20 53 51 4c 20 69 6e 6a 65 63 74 69 6f 6e 20 d SQL injection
25e0: 69 73 73 75 65 73 29 0a 0a 20 20 20 20 3b 3b 20 issues).. ;;
25f0: 3a 66 69 72 73 74 5f 65 72 72 0a 20 20 20 20 28 :first_err. (
2600: 6c 65 74 20 28 28 76 61 6c 20 28 68 61 73 68 2d let ((val (hash-
2610: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
2620: 74 20 6f 74 68 65 72 64 61 74 20 22 3a 66 69 72 t otherdat ":fir
2630: 73 74 5f 65 72 72 22 20 23 66 29 29 29 0a 20 20 st_err" #f))).
2640: 20 20 20 20 28 69 66 20 76 61 6c 0a 09 20 20 28 (if val.. (
2650: 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 sqlite3:execute
2660: 64 62 20 22 55 50 44 41 54 45 20 74 65 73 74 73 db "UPDATE tests
2670: 20 53 45 54 20 66 69 72 73 74 5f 65 72 72 3d 3f SET first_err=?
2680: 20 57 48 45 52 45 20 72 75 6e 5f 69 64 3d 3f 20 WHERE run_id=?
2690: 41 4e 44 20 74 65 73 74 6e 61 6d 65 3d 3f 20 41 AND testname=? A
26a0: 4e 44 20 69 74 65 6d 5f 70 61 74 68 3d 3f 3b 22 ND item_path=?;"
26b0: 20 76 61 6c 20 72 75 6e 2d 69 64 20 74 65 73 74 val run-id test
26c0: 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 -name item-path)
26d0: 29 29 0a 0a 20 20 20 20 3b 3b 20 3a 66 69 72 73 )).. ;; :firs
26e0: 74 5f 77 61 72 6e 0a 20 20 20 20 28 6c 65 74 20 t_warn. (let
26f0: 28 28 76 61 6c 20 28 68 61 73 68 2d 74 61 62 6c ((val (hash-tabl
2700: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 6f 74 e-ref/default ot
2710: 68 65 72 64 61 74 20 22 3a 66 69 72 73 74 5f 77 herdat ":first_w
2720: 61 72 6e 22 20 23 66 29 29 29 0a 20 20 20 20 20 arn" #f))).
2730: 20 28 69 66 20 76 61 6c 0a 09 20 20 28 73 71 6c (if val.. (sql
2740: 69 74 65 33 3a 65 78 65 63 75 74 65 20 64 62 20 ite3:execute db
2750: 22 55 50 44 41 54 45 20 74 65 73 74 73 20 53 45 "UPDATE tests SE
2760: 54 20 66 69 72 73 74 5f 77 61 72 6e 3d 3f 20 57 T first_warn=? W
2770: 48 45 52 45 20 72 75 6e 5f 69 64 3d 3f 20 41 4e HERE run_id=? AN
2780: 44 20 74 65 73 74 6e 61 6d 65 3d 3f 20 41 4e 44 D testname=? AND
2790: 20 69 74 65 6d 5f 70 61 74 68 3d 3f 3b 22 20 76 item_path=?;" v
27a0: 61 6c 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e al run-id test-n
27b0: 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 29 ame item-path)))
27c0: 0a 0a 20 20 20 20 28 6c 65 74 20 28 28 63 61 74 .. (let ((cat
27d0: 65 67 6f 72 79 20 28 68 61 73 68 2d 74 61 62 6c egory (hash-tabl
27e0: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 6f 74 e-ref/default ot
27f0: 68 65 72 64 61 74 20 22 3a 63 61 74 65 67 6f 72 herdat ":categor
2800: 79 22 20 22 22 29 29 0a 09 20 20 28 76 61 72 69 y" "")).. (vari
2810: 61 62 6c 65 20 28 68 61 73 68 2d 74 61 62 6c 65 able (hash-table
2820: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 6f 74 68 -ref/default oth
2830: 65 72 64 61 74 20 22 3a 76 61 72 69 61 62 6c 65 erdat ":variable
2840: 22 20 22 22 29 29 0a 09 20 20 28 76 61 6c 75 65 " "")).. (value
2850: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
2860: 72 65 66 2f 64 65 66 61 75 6c 74 20 6f 74 68 65 ref/default othe
2870: 72 64 61 74 20 22 3a 76 61 6c 75 65 22 20 20 20 rdat ":value"
2880: 20 23 66 29 29 0a 09 20 20 28 65 78 70 65 63 74 #f)).. (expect
2890: 65 64 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 ed (hash-table-r
28a0: 65 66 2f 64 65 66 61 75 6c 74 20 6f 74 68 65 72 ef/default other
28b0: 64 61 74 20 22 3a 65 78 70 65 63 74 65 64 22 20 dat ":expected"
28c0: 23 66 29 29 0a 09 20 20 28 74 6f 6c 20 20 20 20 #f)).. (tol
28d0: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 (hash-table-re
28e0: 66 2f 64 65 66 61 75 6c 74 20 6f 74 68 65 72 64 f/default otherd
28f0: 61 74 20 22 3a 74 6f 6c 22 20 20 20 20 20 20 23 at ":tol" #
2900: 66 29 29 0a 09 20 20 28 75 6e 69 74 73 20 20 20 f)).. (units
2910: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
2920: 2f 64 65 66 61 75 6c 74 20 6f 74 68 65 72 64 61 /default otherda
2930: 74 20 22 3a 75 6e 69 74 73 22 20 20 20 20 22 22 t ":units" ""
2940: 29 29 0a 09 20 20 28 64 63 6f 6d 6d 65 6e 74 20 )).. (dcomment
2950: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
2960: 64 65 66 61 75 6c 74 20 6f 74 68 65 72 64 61 74 default otherdat
2970: 20 22 3a 63 6f 6d 6d 65 6e 74 22 20 20 22 22 29 ":comment" "")
2980: 29 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a )). (debug:
2990: 70 72 69 6e 74 20 34 20 0a 09 09 20 20 20 22 63 print 4 ... "c
29a0: 61 74 65 67 6f 72 79 3a 20 22 20 63 61 74 65 67 ategory: " categ
29b0: 6f 72 79 20 22 2c 20 76 61 72 69 61 62 6c 65 3a ory ", variable:
29c0: 20 22 20 76 61 72 69 61 62 6c 65 20 22 2c 20 76 " variable ", v
29d0: 61 6c 75 65 3a 20 22 20 76 61 6c 75 65 0a 09 09 alue: " value...
29e0: 20 20 20 22 2c 20 65 78 70 65 63 74 65 64 3a 20 ", expected:
29f0: 22 20 65 78 70 65 63 74 65 64 20 22 2c 20 74 6f " expected ", to
2a00: 6c 3a 20 22 20 74 6f 6c 20 22 2c 20 75 6e 69 74 l: " tol ", unit
2a10: 73 3a 20 22 20 75 6e 69 74 73 29 0a 20 20 20 20 s: " units).
2a20: 20 20 28 69 66 20 28 61 6e 64 20 76 61 6c 75 65 (if (and value
2a30: 20 65 78 70 65 63 74 65 64 20 74 6f 6c 29 20 3b expected tol) ;
2a40: 3b 20 61 6c 6c 20 74 68 72 65 65 20 72 65 71 75 ; all three requ
2a50: 69 72 65 64 0a 09 20 20 28 64 62 3a 63 73 76 2d ired.. (db:csv-
2a60: 3e 74 65 73 74 2d 64 61 74 61 20 64 62 20 74 65 >test-data db te
2a70: 73 74 2d 69 64 20 0a 09 09 09 20 20 20 20 20 28 st-id .... (
2a80: 63 6f 6e 63 20 63 61 74 65 67 6f 72 79 20 22 2c conc category ",
2a90: 22 0a 09 09 09 09 20 20 20 76 61 72 69 61 62 6c "..... variabl
2aa0: 65 20 22 2c 22 0a 09 09 09 09 20 20 20 76 61 6c e ","..... val
2ab0: 75 65 20 20 20 20 22 2c 22 0a 09 09 09 09 20 20 ue ",".....
2ac0: 20 65 78 70 65 63 74 65 64 20 22 2c 22 0a 09 09 expected ","...
2ad0: 09 09 20 20 20 74 6f 6c 20 20 20 20 20 20 22 2c .. tol ",
2ae0: 22 0a 09 09 09 09 20 20 20 75 6e 69 74 73 20 20 "..... units
2af0: 20 20 22 2c 22 0a 09 09 09 09 20 20 20 64 63 6f ","..... dco
2b00: 6d 6d 65 6e 74 20 22 2c 22 29 29 29 29 0a 09 09 mment ","))))...
2b10: 09 09 20 20 20 0a 20 20 20 20 3b 3b 20 6e 65 65 .. . ;; nee
2b20: 64 20 74 6f 20 75 70 64 61 74 65 20 74 68 65 20 d to update the
2b30: 74 6f 70 20 74 65 73 74 20 72 65 63 6f 72 64 20 top test record
2b40: 69 66 20 50 41 53 53 20 6f 72 20 46 41 49 4c 20 if PASS or FAIL
2b50: 61 6e 64 20 74 68 69 73 20 69 73 20 61 20 73 75 and this is a su
2b60: 62 74 65 73 74 0a 20 20 20 20 28 69 66 20 28 61 btest. (if (a
2b70: 6e 64 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 nd (not (equal?
2b80: 69 74 65 6d 2d 70 61 74 68 20 22 22 29 29 0a 09 item-path ""))..
2b90: 20 20 20 20 20 28 6f 72 20 28 65 71 75 61 6c 3f (or (equal?
2ba0: 20 73 74 61 74 75 73 20 22 50 41 53 53 22 29 0a status "PASS").
2bb0: 09 09 20 28 65 71 75 61 6c 3f 20 73 74 61 74 75 .. (equal? statu
2bc0: 73 20 22 57 41 52 4e 22 29 0a 09 09 20 28 65 71 s "WARN")... (eq
2bd0: 75 61 6c 3f 20 73 74 61 74 75 73 20 22 46 41 49 ual? status "FAI
2be0: 4c 22 29 0a 09 09 20 28 65 71 75 61 6c 3f 20 73 L")... (equal? s
2bf0: 74 61 74 75 73 20 22 57 41 49 56 45 44 22 29 0a tatus "WAIVED").
2c00: 09 09 20 28 65 71 75 61 6c 3f 20 73 74 61 74 75 .. (equal? statu
2c10: 73 20 22 52 55 4e 4e 49 4e 47 22 29 29 29 0a 09 s "RUNNING")))..
2c20: 28 62 65 67 69 6e 0a 09 20 20 28 73 71 6c 69 74 (begin.. (sqlit
2c30: 65 33 3a 65 78 65 63 75 74 65 20 0a 09 20 20 20 e3:execute ..
2c40: 64 62 0a 09 20 20 20 22 55 50 44 41 54 45 20 74 db.. "UPDATE t
2c50: 65 73 74 73 20 0a 20 20 20 20 20 20 20 20 20 20 ests .
2c60: 20 20 20 53 45 54 20 66 61 69 6c 5f 63 6f 75 6e SET fail_coun
2c70: 74 3d 28 53 45 4c 45 43 54 20 63 6f 75 6e 74 28 t=(SELECT count(
2c80: 69 64 29 20 46 52 4f 4d 20 74 65 73 74 73 20 57 id) FROM tests W
2c90: 48 45 52 45 20 72 75 6e 5f 69 64 3d 3f 20 41 4e HERE run_id=? AN
2ca0: 44 20 74 65 73 74 6e 61 6d 65 3d 3f 20 41 4e 44 D testname=? AND
2cb0: 20 69 74 65 6d 5f 70 61 74 68 20 21 3d 20 27 27 item_path != ''
2cc0: 20 41 4e 44 20 73 74 61 74 75 73 3d 27 46 41 49 AND status='FAI
2cd0: 4c 27 29 2c 0a 20 20 20 20 20 20 20 20 20 20 20 L'),.
2ce0: 20 20 20 20 20 20 70 61 73 73 5f 63 6f 75 6e 74 pass_count
2cf0: 3d 28 53 45 4c 45 43 54 20 63 6f 75 6e 74 28 69 =(SELECT count(i
2d00: 64 29 20 46 52 4f 4d 20 74 65 73 74 73 20 57 48 d) FROM tests WH
2d10: 45 52 45 20 72 75 6e 5f 69 64 3d 3f 20 41 4e 44 ERE run_id=? AND
2d20: 20 74 65 73 74 6e 61 6d 65 3d 3f 20 41 4e 44 20 testname=? AND
2d30: 69 74 65 6d 5f 70 61 74 68 20 21 3d 20 27 27 20 item_path != ''
2d40: 41 4e 44 20 28 73 74 61 74 75 73 3d 27 50 41 53 AND (status='PAS
2d50: 53 27 20 4f 52 20 73 74 61 74 75 73 3d 27 57 41 S' OR status='WA
2d60: 52 4e 27 20 4f 52 20 73 74 61 74 75 73 3d 27 57 RN' OR status='W
2d70: 41 49 56 45 44 27 29 29 0a 20 20 20 20 20 20 20 AIVED')).
2d80: 20 20 20 20 20 20 57 48 45 52 45 20 72 75 6e 5f WHERE run_
2d90: 69 64 3d 3f 20 41 4e 44 20 74 65 73 74 6e 61 6d id=? AND testnam
2da0: 65 3d 3f 20 41 4e 44 20 69 74 65 6d 5f 70 61 74 e=? AND item_pat
2db0: 68 3d 27 27 3b 22 0a 09 20 20 20 72 75 6e 2d 69 h='';".. run-i
2dc0: 64 20 74 65 73 74 2d 6e 61 6d 65 20 72 75 6e 2d d test-name run-
2dd0: 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 72 75 6e id test-name run
2de0: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 29 0a 09 -id test-name)..
2df0: 20 20 28 69 66 20 28 65 71 75 61 6c 3f 20 73 74 (if (equal? st
2e00: 61 74 75 73 20 22 52 55 4e 4e 49 4e 47 22 29 20 atus "RUNNING")
2e10: 3b 3b 20 72 75 6e 6e 69 6e 67 20 74 61 6b 65 73 ;; running takes
2e20: 20 70 72 69 6f 72 69 74 79 20 6f 76 65 72 20 61 priority over a
2e30: 6c 6c 20 6f 74 68 65 72 20 73 74 61 74 65 73 2c ll other states,
2e40: 20 66 6f 72 63 65 20 74 68 65 20 74 65 73 74 20 force the test
2e50: 73 74 61 74 65 20 74 6f 20 52 55 4e 4e 49 4e 47 state to RUNNING
2e60: 0a 09 20 20 20 20 20 20 28 73 71 6c 69 74 65 33 .. (sqlite3
2e70: 3a 65 78 65 63 75 74 65 20 64 62 20 22 55 50 44 :execute db "UPD
2e80: 41 54 45 20 74 65 73 74 73 20 53 45 54 20 73 74 ATE tests SET st
2e90: 61 74 65 3d 3f 20 57 48 45 52 45 20 72 75 6e 5f ate=? WHERE run_
2ea0: 69 64 3d 3f 20 41 4e 44 20 74 65 73 74 6e 61 6d id=? AND testnam
2eb0: 65 3d 3f 20 41 4e 44 20 69 74 65 6d 5f 70 61 74 e=? AND item_pat
2ec0: 68 3d 27 27 3b 22 20 72 75 6e 2d 69 64 20 74 65 h='';" run-id te
2ed0: 73 74 2d 6e 61 6d 65 29 0a 09 20 20 20 20 20 20 st-name)..
2ee0: 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 (sqlite3:execute
2ef0: 0a 09 20 20 20 20 20 20 20 64 62 0a 09 20 20 20 .. db..
2f00: 20 20 20 20 22 55 50 44 41 54 45 20 74 65 73 74 "UPDATE test
2f10: 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 s.
2f20: 20 20 20 20 20 20 20 20 20 53 45 54 20 73 74 61 SET sta
2f30: 74 65 3d 43 41 53 45 20 57 48 45 4e 20 28 53 45 te=CASE WHEN (SE
2f40: 4c 45 43 54 20 63 6f 75 6e 74 28 69 64 29 20 46 LECT count(id) F
2f50: 52 4f 4d 20 74 65 73 74 73 20 57 48 45 52 45 20 ROM tests WHERE
2f60: 72 75 6e 5f 69 64 3d 3f 20 41 4e 44 20 74 65 73 run_id=? AND tes
2f70: 74 6e 61 6d 65 3d 3f 20 41 4e 44 20 69 74 65 6d tname=? AND item
2f80: 5f 70 61 74 68 20 21 3d 20 27 27 20 41 4e 44 20 _path != '' AND
2f90: 73 74 61 74 65 20 69 6e 20 28 27 52 55 4e 4e 49 state in ('RUNNI
2fa0: 4e 47 27 2c 27 4e 4f 54 5f 53 54 41 52 54 45 44 NG','NOT_STARTED
2fb0: 27 29 29 20 3e 20 30 20 54 48 45 4e 20 0a 20 20 ')) > 0 THEN .
2fc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2fd0: 20 20 20 20 20 20 20 20 27 52 55 4e 4e 49 4e 47 'RUNNING
2fe0: 27 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 '.
2ff0: 20 20 20 20 20 20 20 20 20 45 4c 53 45 20 27 43 ELSE 'C
3000: 4f 4d 50 4c 45 54 45 44 27 20 45 4e 44 2c 0a 20 OMPLETED' END,.
3010: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3020: 20 20 20 20 20 20 20 20 20 73 74 61 74 75 73 3d status=
3030: 43 41 53 45 20 57 48 45 4e 20 66 61 69 6c 5f 63 CASE WHEN fail_c
3040: 6f 75 6e 74 20 3e 20 30 20 54 48 45 4e 20 27 46 ount > 0 THEN 'F
3050: 41 49 4c 27 20 57 48 45 4e 20 70 61 73 73 5f 63 AIL' WHEN pass_c
3060: 6f 75 6e 74 20 3e 20 30 20 41 4e 44 20 66 61 69 ount > 0 AND fai
3070: 6c 5f 63 6f 75 6e 74 3d 30 20 54 48 45 4e 20 27 l_count=0 THEN '
3080: 50 41 53 53 27 20 45 4c 53 45 20 27 55 4e 4b 4e PASS' ELSE 'UNKN
3090: 4f 57 4e 27 20 45 4e 44 0a 20 20 20 20 20 20 20 OWN' END.
30a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
30b0: 57 48 45 52 45 20 72 75 6e 5f 69 64 3d 3f 20 41 WHERE run_id=? A
30c0: 4e 44 20 74 65 73 74 6e 61 6d 65 3d 3f 20 41 4e ND testname=? AN
30d0: 44 20 69 74 65 6d 5f 70 61 74 68 3d 27 27 3b 22 D item_path='';"
30e0: 0a 09 20 20 20 20 20 20 20 72 75 6e 2d 69 64 20 .. run-id
30f0: 74 65 73 74 2d 6e 61 6d 65 20 72 75 6e 2d 69 64 test-name run-id
3100: 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 29 0a 20 test-name)))).
3110: 20 20 20 28 69 66 20 28 6f 72 20 28 61 6e 64 20 (if (or (and
3120: 28 73 74 72 69 6e 67 3f 20 63 6f 6d 6d 65 6e 74 (string? comment
3130: 29 0a 09 09 20 28 73 74 72 69 6e 67 2d 6d 61 74 )... (string-mat
3140: 63 68 20 28 72 65 67 65 78 70 20 22 5c 5c 53 2b ch (regexp "\\S+
3150: 22 29 20 63 6f 6d 6d 65 6e 74 29 29 0a 09 20 20 ") comment))..
3160: 20 20 77 61 69 76 65 64 29 0a 09 28 73 71 6c 69 waived)..(sqli
3170: 74 65 33 3a 65 78 65 63 75 74 65 20 64 62 20 22 te3:execute db "
3180: 55 50 44 41 54 45 20 74 65 73 74 73 20 53 45 54 UPDATE tests SET
3190: 20 63 6f 6d 6d 65 6e 74 3d 3f 20 57 48 45 52 45 comment=? WHERE
31a0: 20 72 75 6e 5f 69 64 3d 3f 20 41 4e 44 20 74 65 run_id=? AND te
31b0: 73 74 6e 61 6d 65 3d 3f 20 41 4e 44 20 69 74 65 stname=? AND ite
31c0: 6d 5f 70 61 74 68 3d 3f 3b 22 0a 09 09 09 20 28 m_path=?;".... (
31d0: 69 66 20 77 61 69 76 65 64 20 77 61 69 76 65 64 if waived waived
31e0: 20 63 6f 6d 6d 65 6e 74 29 20 72 75 6e 2d 69 64 comment) run-id
31f0: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item-
3200: 70 61 74 68 29 29 0a 20 20 20 20 29 29 0a 0a 28 path)). ))..(
3210: 64 65 66 69 6e 65 20 28 74 65 73 74 2d 73 65 74 define (test-set
3220: 2d 6c 6f 67 21 20 64 62 20 72 75 6e 2d 69 64 20 -log! db run-id
3230: 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 64 61 test-name itemda
3240: 74 20 6c 6f 67 66 29 20 0a 20 20 28 6c 65 74 20 t logf) . (let
3250: 28 28 69 74 65 6d 2d 70 61 74 68 20 28 69 74 65 ((item-path (ite
3260: 6d 2d 6c 69 73 74 2d 3e 70 61 74 68 20 69 74 65 m-list->path ite
3270: 6d 64 61 74 29 29 29 0a 20 20 20 20 28 73 71 6c mdat))). (sql
3280: 69 74 65 33 3a 65 78 65 63 75 74 65 20 64 62 20 ite3:execute db
3290: 22 55 50 44 41 54 45 20 74 65 73 74 73 20 53 45 "UPDATE tests SE
32a0: 54 20 66 69 6e 61 6c 5f 6c 6f 67 66 3d 3f 20 57 T final_logf=? W
32b0: 48 45 52 45 20 72 75 6e 5f 69 64 3d 3f 20 41 4e HERE run_id=? AN
32c0: 44 20 74 65 73 74 6e 61 6d 65 3d 3f 20 41 4e 44 D testname=? AND
32d0: 20 69 74 65 6d 5f 70 61 74 68 3d 3f 3b 22 20 0a item_path=?;" .
32e0: 09 09 20 20 20 20 20 6c 6f 67 66 20 72 75 6e 2d .. logf run-
32f0: 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 id test-name ite
3300: 6d 2d 70 61 74 68 29 29 29 0a 0a 28 64 65 66 69 m-path)))..(defi
3310: 6e 65 20 28 74 65 73 74 2d 73 65 74 2d 74 6f 70 ne (test-set-top
3320: 6c 6f 67 21 20 64 62 20 72 75 6e 2d 69 64 20 74 log! db run-id t
3330: 65 73 74 2d 6e 61 6d 65 20 6c 6f 67 66 29 20 0a est-name logf) .
3340: 20 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 (sqlite3:execu
3350: 74 65 20 64 62 20 22 55 50 44 41 54 45 20 74 65 te db "UPDATE te
3360: 73 74 73 20 53 45 54 20 66 69 6e 61 6c 5f 6c 6f sts SET final_lo
3370: 67 66 3d 3f 20 57 48 45 52 45 20 72 75 6e 5f 69 gf=? WHERE run_i
3380: 64 3d 3f 20 41 4e 44 20 74 65 73 74 6e 61 6d 65 d=? AND testname
3390: 3d 3f 20 41 4e 44 20 69 74 65 6d 5f 70 61 74 68 =? AND item_path
33a0: 3d 27 27 3b 22 20 0a 09 09 20 20 20 6c 6f 67 66 ='';" ... logf
33b0: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
33c0: 65 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 e))..(define (te
33d0: 73 74 73 3a 73 75 6d 6d 61 72 69 7a 65 2d 69 74 sts:summarize-it
33e0: 65 6d 73 20 64 62 20 72 75 6e 2d 69 64 20 74 65 ems db run-id te
33f0: 73 74 2d 6e 61 6d 65 20 66 6f 72 63 65 29 0a 20 st-name force).
3400: 20 3b 3b 20 69 66 20 6e 6f 74 20 66 6f 72 63 65 ;; if not force
3410: 20 74 68 65 6e 20 6f 6e 6c 79 20 75 70 64 61 74 then only updat
3420: 65 20 74 68 65 20 72 65 63 6f 72 64 20 69 66 20 e the record if
3430: 6f 6e 65 20 6f 66 20 74 68 65 73 65 20 69 73 20 one of these is
3440: 74 72 75 65 3a 0a 20 20 3b 3b 20 20 20 31 2e 20 true:. ;; 1.
3450: 6c 6f 67 66 20 69 73 20 22 6c 6f 67 2f 66 69 6e logf is "log/fin
3460: 61 6c 2e 6c 6f 67 0a 20 20 3b 3b 20 20 20 32 2e al.log. ;; 2.
3470: 20 6c 6f 67 66 20 69 73 20 73 61 6d 65 20 61 73 logf is same as
3480: 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 0a outputfilename.
3490: 20 20 28 6c 65 74 20 28 28 6f 75 74 70 75 74 66 (let ((outputf
34a0: 69 6c 65 6e 61 6d 65 20 28 63 6f 6e 63 20 22 6d ilename (conc "m
34b0: 65 67 61 74 65 73 74 2d 72 6f 6c 6c 75 70 2d 22 egatest-rollup-"
34c0: 20 74 65 73 74 2d 6e 61 6d 65 20 22 2e 68 74 6d test-name ".htm
34d0: 6c 22 29 29 0a 09 28 6f 72 69 67 2d 64 69 72 20 l"))..(orig-dir
34e0: 20 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d 64 (current-d
34f0: 69 72 65 63 74 6f 72 79 29 29 0a 09 28 6c 6f 67 irectory))..(log
3500: 66 20 20 20 20 20 20 20 20 20 20 20 23 66 29 29 f #f))
3510: 0a 20 20 20 20 28 73 71 6c 69 74 65 33 3a 66 6f . (sqlite3:fo
3520: 72 2d 65 61 63 68 2d 72 6f 77 20 0a 20 20 20 20 r-each-row .
3530: 20 28 6c 61 6d 62 64 61 20 28 70 61 74 68 20 66 (lambda (path f
3540: 69 6e 61 6c 5f 6c 6f 67 66 29 0a 20 20 20 20 20 inal_logf).
3550: 20 20 28 73 65 74 21 20 6c 6f 67 66 20 66 69 6e (set! logf fin
3560: 61 6c 5f 6c 6f 67 66 29 0a 20 20 20 20 20 20 20 al_logf).
3570: 28 69 66 20 28 64 69 72 65 63 74 6f 72 79 3f 20 (if (directory?
3580: 70 61 74 68 29 0a 09 20 20 20 28 62 65 67 69 6e path).. (begin
3590: 0a 09 20 20 20 20 20 28 70 72 69 6e 74 20 22 46 .. (print "F
35a0: 6f 75 6e 64 20 70 61 74 68 3a 20 22 20 70 61 74 ound path: " pat
35b0: 68 29 0a 09 20 20 20 20 20 28 63 68 61 6e 67 65 h).. (change
35c0: 2d 64 69 72 65 63 74 6f 72 79 20 70 61 74 68 29 -directory path)
35d0: 29 0a 09 20 20 20 20 20 3b 3b 20 28 73 65 74 21 ).. ;; (set!
35e0: 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 20 outputfilename
35f0: 28 63 6f 6e 63 20 70 61 74 68 20 22 2f 22 20 6f (conc path "/" o
3600: 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 29 29 29 utputfilename)))
3610: 0a 09 20 20 20 28 70 72 69 6e 74 20 22 4e 6f 20 .. (print "No
3620: 73 75 63 68 20 70 61 74 68 3a 20 22 20 70 61 74 such path: " pat
3630: 68 29 29 29 0a 20 20 20 20 20 64 62 20 0a 20 20 h))). db .
3640: 20 20 20 22 53 45 4c 45 43 54 20 72 75 6e 64 69 "SELECT rundi
3650: 72 2c 66 69 6e 61 6c 5f 6c 6f 67 66 20 46 52 4f r,final_logf FRO
3660: 4d 20 74 65 73 74 73 20 57 48 45 52 45 20 72 75 M tests WHERE ru
3670: 6e 5f 69 64 3d 3f 20 41 4e 44 20 74 65 73 74 6e n_id=? AND testn
3680: 61 6d 65 3d 3f 20 41 4e 44 20 69 74 65 6d 5f 70 ame=? AND item_p
3690: 61 74 68 3d 27 27 3b 22 0a 20 20 20 20 20 72 75 ath='';". ru
36a0: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 29 0a n-id test-name).
36b0: 20 20 20 20 28 70 72 69 6e 74 20 22 73 75 6d 6d (print "summ
36c0: 61 72 69 7a 65 2d 69 74 65 6d 73 20 77 69 74 68 arize-items with
36d0: 20 6c 6f 67 66 20 22 20 6c 6f 67 66 29 0a 20 20 logf " logf).
36e0: 20 20 28 69 66 20 28 6f 72 20 28 65 71 75 61 6c (if (or (equal
36f0: 3f 20 6c 6f 67 66 20 22 6c 6f 67 73 2f 66 69 6e ? logf "logs/fin
3700: 61 6c 2e 6c 6f 67 22 29 0a 09 20 20 20 20 28 65 al.log").. (e
3710: 71 75 61 6c 3f 20 6c 6f 67 66 20 6f 75 74 70 75 qual? logf outpu
3720: 74 66 69 6c 65 6e 61 6d 65 29 0a 09 20 20 20 20 tfilename)..
3730: 66 6f 72 63 65 29 0a 09 28 62 65 67 69 6e 0a 09 force)..(begin..
3740: 20 20 28 69 66 20 28 6f 62 74 61 69 6e 2d 64 6f (if (obtain-do
3750: 74 2d 6c 6f 63 6b 20 6f 75 74 70 75 74 66 69 6c t-lock outputfil
3760: 65 6e 61 6d 65 20 31 20 32 30 20 33 30 29 20 3b ename 1 20 30) ;
3770: 3b 20 72 65 74 72 79 20 65 76 65 72 79 20 73 65 ; retry every se
3780: 63 6f 6e 64 20 66 6f 72 20 32 30 20 73 65 63 6f cond for 20 seco
3790: 6e 64 73 2c 20 63 61 6c 6c 20 69 74 20 64 65 61 nds, call it dea
37a0: 64 20 61 66 74 65 72 20 33 30 20 73 65 63 6f 6e d after 30 secon
37b0: 64 73 20 61 6e 64 20 73 74 65 61 6c 20 74 68 65 ds and steal the
37c0: 20 6c 6f 63 6b 0a 09 20 20 20 20 20 20 28 70 72 lock.. (pr
37d0: 69 6e 74 20 22 4f 62 74 61 69 6e 65 64 20 6c 6f int "Obtained lo
37e0: 63 6b 20 66 6f 72 20 22 20 6f 75 74 70 75 74 66 ck for " outputf
37f0: 69 6c 65 6e 61 6d 65 29 0a 09 20 20 20 20 20 20 ilename)..
3800: 28 70 72 69 6e 74 20 22 46 61 69 6c 65 64 20 74 (print "Failed t
3810: 6f 20 6f 62 74 61 69 6e 20 6c 6f 63 6b 20 66 6f o obtain lock fo
3820: 72 20 22 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 r " outputfilena
3830: 6d 65 29 29 0a 09 20 20 28 6c 65 74 20 28 28 6f me)).. (let ((o
3840: 75 70 20 20 20 20 28 6f 70 65 6e 2d 6f 75 74 70 up (open-outp
3850: 75 74 2d 66 69 6c 65 20 6f 75 74 70 75 74 66 69 ut-file outputfi
3860: 6c 65 6e 61 6d 65 29 29 0a 09 09 28 63 6f 75 6e lename))...(coun
3870: 74 73 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 ts (make-hash-ta
3880: 62 6c 65 29 29 0a 09 09 28 73 74 61 74 65 63 6f ble))...(stateco
3890: 75 6e 74 73 20 28 6d 61 6b 65 2d 68 61 73 68 2d unts (make-hash-
38a0: 74 61 62 6c 65 29 29 0a 09 09 28 6f 75 74 74 78 table))...(outtx
38b0: 74 20 22 22 29 0a 09 09 28 74 6f 74 20 20 20 20 t "")...(tot
38c0: 30 29 29 0a 09 20 20 20 20 28 77 69 74 68 2d 6f 0)).. (with-o
38d0: 75 74 70 75 74 2d 74 6f 2d 70 6f 72 74 0a 09 09 utput-to-port...
38e0: 6f 75 70 0a 09 20 20 20 20 20 20 28 6c 61 6d 62 oup.. (lamb
38f0: 64 61 20 28 29 0a 09 09 28 73 65 74 21 20 6f 75 da ()...(set! ou
3900: 74 74 78 74 20 28 63 6f 6e 63 20 6f 75 74 74 78 ttxt (conc outtx
3910: 74 20 22 3c 68 74 6d 6c 3e 3c 74 69 74 6c 65 3e t "<html><title>
3920: 53 75 6d 6d 61 72 79 3a 20 22 20 74 65 73 74 2d Summary: " test-
3930: 6e 61 6d 65 20 0a 09 09 09 09 20 20 20 22 3c 2f name ..... "</
3940: 74 69 74 6c 65 3e 3c 62 6f 64 79 3e 3c 68 32 3e title><body><h2>
3950: 53 75 6d 6d 61 72 79 20 66 6f 72 20 22 20 74 65 Summary for " te
3960: 73 74 2d 6e 61 6d 65 20 22 3c 2f 68 32 3e 22 29 st-name "</h2>")
3970: 29 0a 09 09 28 73 71 6c 69 74 65 33 3a 66 6f 72 )...(sqlite3:for
3980: 2d 65 61 63 68 2d 72 6f 77 20 0a 09 09 20 28 6c -each-row ... (l
3990: 61 6d 62 64 61 20 28 69 64 20 69 74 65 6d 70 61 ambda (id itempa
39a0: 74 68 20 73 74 61 74 65 20 73 74 61 74 75 73 20 th state status
39b0: 72 75 6e 5f 64 75 72 61 74 69 6f 6e 20 6c 6f 67 run_duration log
39c0: 66 20 63 6f 6d 6d 65 6e 74 29 0a 09 09 20 20 20 f comment)...
39d0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
39e0: 20 63 6f 75 6e 74 73 20 73 74 61 74 75 73 20 28 counts status (
39f0: 2b 20 31 20 28 68 61 73 68 2d 74 61 62 6c 65 2d + 1 (hash-table-
3a00: 72 65 66 2f 64 65 66 61 75 6c 74 20 63 6f 75 6e ref/default coun
3a10: 74 73 20 73 74 61 74 75 73 20 30 29 29 29 0a 09 ts status 0)))..
3a20: 09 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d . (hash-table-
3a30: 73 65 74 21 20 73 74 61 74 65 63 6f 75 6e 74 73 set! statecounts
3a40: 20 73 74 61 74 65 20 28 2b 20 31 20 28 68 61 73 state (+ 1 (has
3a50: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
3a60: 75 6c 74 20 73 74 61 74 65 63 6f 75 6e 74 73 20 ult statecounts
3a70: 73 74 61 74 65 20 30 29 29 29 0a 09 09 20 20 20 state 0)))...
3a80: 28 73 65 74 21 20 6f 75 74 74 78 74 20 28 63 6f (set! outtxt (co
3a90: 6e 63 20 6f 75 74 74 78 74 20 22 3c 74 72 3e 22 nc outtxt "<tr>"
3aa0: 0a 09 09 09 09 20 20 20 20 20 20 22 3c 74 64 3e ..... "<td>
3ab0: 3c 61 20 68 72 65 66 3d 5c 22 22 20 69 74 65 6d <a href=\"" item
3ac0: 70 61 74 68 20 22 2f 22 20 6c 6f 67 66 20 22 5c path "/" logf "\
3ad0: 22 3e 20 22 20 69 74 65 6d 70 61 74 68 20 22 3c "> " itempath "<
3ae0: 2f 61 3e 3c 2f 74 64 3e 22 20 0a 09 09 09 09 20 /a></td>" .....
3af0: 20 20 20 20 20 22 3c 74 64 3e 22 20 73 74 61 74 "<td>" stat
3b00: 65 20 20 20 20 22 3c 2f 74 64 3e 22 20 0a 09 09 e "</td>" ...
3b10: 09 09 20 20 20 20 20 20 22 3c 74 64 3e 3c 66 6f .. "<td><fo
3b20: 6e 74 20 63 6f 6c 6f 72 3d 22 20 28 63 6f 6d 6d nt color=" (comm
3b30: 6f 6e 3a 67 65 74 2d 63 6f 6c 6f 72 2d 66 72 6f on:get-color-fro
3b40: 6d 2d 73 74 61 74 75 73 20 73 74 61 74 75 73 29 m-status status)
3b50: 0a 09 09 09 09 20 20 20 20 20 20 22 3e 22 20 20 ..... ">"
3b60: 20 73 74 61 74 75 73 20 20 20 22 3c 2f 66 6f 6e status "</fon
3b70: 74 3e 3c 2f 74 64 3e 22 0a 09 09 09 09 20 20 20 t></td>".....
3b80: 20 20 20 22 3c 74 64 3e 22 20 28 69 66 20 28 65 "<td>" (if (e
3b90: 71 75 61 6c 3f 20 63 6f 6d 6d 65 6e 74 20 22 22 qual? comment ""
3ba0: 29 0a 09 09 09 09 09 09 20 22 26 6e 62 73 70 3b )....... "
3bb0: 22 0a 09 09 09 09 09 09 20 63 6f 6d 6d 65 6e 74 "....... comment
3bc0: 29 20 22 3c 2f 74 64 3e 22 0a 09 09 09 09 09 09 ) "</td>".......
3bd0: 20 22 3c 2f 74 72 3e 22 29 29 29 0a 09 09 20 64 "</tr>")))... d
3be0: 62 0a 09 09 20 22 53 45 4c 45 43 54 20 69 64 2c b... "SELECT id,
3bf0: 69 74 65 6d 5f 70 61 74 68 2c 73 74 61 74 65 2c item_path,state,
3c00: 73 74 61 74 75 73 2c 72 75 6e 5f 64 75 72 61 74 status,run_durat
3c10: 69 6f 6e 2c 66 69 6e 61 6c 5f 6c 6f 67 66 2c 63 ion,final_logf,c
3c20: 6f 6d 6d 65 6e 74 20 46 52 4f 4d 20 74 65 73 74 omment FROM test
3c30: 73 20 57 48 45 52 45 20 72 75 6e 5f 69 64 3d 3f s WHERE run_id=?
3c40: 20 41 4e 44 20 74 65 73 74 6e 61 6d 65 3d 3f 20 AND testname=?
3c50: 41 4e 44 20 69 74 65 6d 5f 70 61 74 68 20 21 3d AND item_path !=
3c60: 20 27 27 3b 22 0a 09 09 20 72 75 6e 2d 69 64 20 '';"... run-id
3c70: 74 65 73 74 2d 6e 61 6d 65 29 0a 0a 09 09 28 70 test-name)....(p
3c80: 72 69 6e 74 20 22 3c 74 61 62 6c 65 3e 3c 74 72 rint "<table><tr
3c90: 3e 3c 74 64 20 76 61 6c 69 67 6e 3d 5c 22 74 6f ><td valign=\"to
3ca0: 70 5c 22 3e 22 29 0a 09 09 3b 3b 20 50 72 69 6e p\">")...;; Prin
3cb0: 74 20 6f 75 74 20 73 74 61 74 73 20 66 6f 72 20 t out stats for
3cc0: 73 74 61 74 75 73 0a 09 09 28 73 65 74 21 20 74 status...(set! t
3cd0: 6f 74 20 30 29 0a 09 09 28 70 72 69 6e 74 20 22 ot 0)...(print "
3ce0: 3c 74 61 62 6c 65 20 63 65 6c 6c 73 70 61 63 69 <table cellspaci
3cf0: 6e 67 3d 5c 22 30 5c 22 20 62 6f 72 64 65 72 3d ng=\"0\" border=
3d00: 5c 22 31 5c 22 3e 3c 74 72 3e 3c 74 64 20 63 6f \"1\"><tr><td co
3d10: 6c 73 70 61 6e 3d 5c 22 32 5c 22 3e 3c 68 32 3e lspan=\"2\"><h2>
3d20: 53 74 61 74 65 20 73 74 61 74 73 3c 2f 68 32 3e State stats</h2>
3d30: 3c 2f 74 64 3e 3c 2f 74 72 3e 22 29 0a 09 09 28 </td></tr>")...(
3d40: 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 for-each (lambda
3d50: 20 28 73 74 61 74 65 29 0a 09 09 09 20 20 20 20 (state)....
3d60: 28 73 65 74 21 20 74 6f 74 20 28 2b 20 74 6f 74 (set! tot (+ tot
3d70: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
3d80: 20 73 74 61 74 65 63 6f 75 6e 74 73 20 73 74 61 statecounts sta
3d90: 74 65 29 29 29 0a 09 09 09 20 20 20 20 28 70 72 te))).... (pr
3da0: 69 6e 74 20 22 3c 74 72 3e 3c 74 64 3e 22 20 73 int "<tr><td>" s
3db0: 74 61 74 65 20 22 3c 2f 74 64 3e 3c 74 64 3e 22 tate "</td><td>"
3dc0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
3dd0: 20 73 74 61 74 65 63 6f 75 6e 74 73 20 73 74 61 statecounts sta
3de0: 74 65 29 20 22 3c 2f 74 64 3e 3c 2f 74 72 3e 22 te) "</td></tr>"
3df0: 29 29 0a 09 09 09 20 20 28 68 61 73 68 2d 74 61 )).... (hash-ta
3e00: 62 6c 65 2d 6b 65 79 73 20 73 74 61 74 65 63 6f ble-keys stateco
3e10: 75 6e 74 73 29 29 0a 09 09 28 70 72 69 6e 74 20 unts))...(print
3e20: 22 3c 74 72 3e 3c 74 64 3e 54 6f 74 61 6c 3c 2f "<tr><td>Total</
3e30: 74 64 3e 3c 74 64 3e 22 20 74 6f 74 20 22 3c 2f td><td>" tot "</
3e40: 74 64 3e 3c 2f 74 72 3e 3c 2f 74 61 62 6c 65 3e td></tr></table>
3e50: 22 29 0a 09 09 28 70 72 69 6e 74 20 22 3c 2f 74 ")...(print "</t
3e60: 64 3e 3c 74 64 20 76 61 6c 69 67 6e 3d 5c 22 74 d><td valign=\"t
3e70: 6f 70 5c 22 3e 22 29 0a 09 09 3b 3b 20 50 72 69 op\">")...;; Pri
3e80: 6e 74 20 6f 75 74 20 73 74 61 74 73 20 66 6f 72 nt out stats for
3e90: 20 73 74 61 74 65 0a 09 09 28 73 65 74 21 20 74 state...(set! t
3ea0: 6f 74 20 30 29 0a 09 09 28 70 72 69 6e 74 20 22 ot 0)...(print "
3eb0: 3c 74 61 62 6c 65 20 63 65 6c 6c 73 70 61 63 69 <table cellspaci
3ec0: 6e 67 3d 5c 22 30 5c 22 20 62 6f 72 64 65 72 3d ng=\"0\" border=
3ed0: 5c 22 31 5c 22 3e 3c 74 72 3e 3c 74 64 20 63 6f \"1\"><tr><td co
3ee0: 6c 73 70 61 6e 3d 5c 22 32 5c 22 3e 3c 68 32 3e lspan=\"2\"><h2>
3ef0: 53 74 61 74 75 73 20 73 74 61 74 73 3c 2f 68 32 Status stats</h2
3f00: 3e 3c 2f 74 64 3e 3c 2f 74 72 3e 22 29 0a 09 09 ></td></tr>")...
3f10: 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 (for-each (lambd
3f20: 61 20 28 73 74 61 74 75 73 29 0a 09 09 09 20 20 a (status)....
3f30: 20 20 28 73 65 74 21 20 74 6f 74 20 28 2b 20 74 (set! tot (+ t
3f40: 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 ot (hash-table-r
3f50: 65 66 20 63 6f 75 6e 74 73 20 73 74 61 74 75 73 ef counts status
3f60: 29 29 29 0a 09 09 09 20 20 20 20 28 70 72 69 6e ))).... (prin
3f70: 74 20 22 3c 74 72 3e 3c 74 64 3e 3c 66 6f 6e 74 t "<tr><td><font
3f80: 20 63 6f 6c 6f 72 3d 5c 22 22 20 28 63 6f 6d 6d color=\"" (comm
3f90: 6f 6e 3a 67 65 74 2d 63 6f 6c 6f 72 2d 66 72 6f on:get-color-fro
3fa0: 6d 2d 73 74 61 74 75 73 20 73 74 61 74 75 73 29 m-status status)
3fb0: 20 22 5c 22 3e 22 20 73 74 61 74 75 73 0a 09 09 "\">" status...
3fc0: 09 09 20 20 20 22 3c 2f 66 6f 6e 74 3e 3c 2f 74 .. "</font></t
3fd0: 64 3e 3c 74 64 3e 22 20 28 68 61 73 68 2d 74 61 d><td>" (hash-ta
3fe0: 62 6c 65 2d 72 65 66 20 63 6f 75 6e 74 73 20 73 ble-ref counts s
3ff0: 74 61 74 75 73 29 20 22 3c 2f 74 64 3e 3c 2f 74 tatus) "</td></t
4000: 72 3e 22 29 29 0a 09 09 09 20 20 28 68 61 73 68 r>")).... (hash
4010: 2d 74 61 62 6c 65 2d 6b 65 79 73 20 63 6f 75 6e -table-keys coun
4020: 74 73 29 29 0a 09 09 28 70 72 69 6e 74 20 22 3c ts))...(print "<
4030: 74 72 3e 3c 74 64 3e 54 6f 74 61 6c 3c 2f 74 64 tr><td>Total</td
4040: 3e 3c 74 64 3e 22 20 74 6f 74 20 22 3c 2f 74 64 ><td>" tot "</td
4050: 3e 3c 2f 74 72 3e 3c 2f 74 61 62 6c 65 3e 22 29 ></tr></table>")
4060: 0a 09 09 28 70 72 69 6e 74 20 22 3c 2f 74 64 3e ...(print "</td>
4070: 3c 2f 74 64 3e 3c 2f 74 72 3e 3c 2f 74 61 62 6c </td></tr></tabl
4080: 65 3e 22 29 0a 0a 09 09 28 70 72 69 6e 74 20 22 e>")....(print "
4090: 3c 74 61 62 6c 65 20 63 65 6c 6c 73 70 61 63 69 <table cellspaci
40a0: 6e 67 3d 5c 22 30 5c 22 20 62 6f 72 64 65 72 3d ng=\"0\" border=
40b0: 5c 22 31 5c 22 3e 22 20 0a 09 09 20 20 20 20 20 \"1\">" ...
40c0: 20 20 22 3c 74 72 3e 3c 74 64 3e 49 74 65 6d 3c "<tr><td>Item<
40d0: 2f 74 64 3e 3c 74 64 3e 53 74 61 74 65 3c 2f 74 /td><td>State</t
40e0: 64 3e 3c 74 64 3e 53 74 61 74 75 73 3c 2f 74 64 d><td>Status</td
40f0: 3e 3c 74 64 3e 43 6f 6d 6d 65 6e 74 3c 2f 74 64 ><td>Comment</td
4100: 3e 22 0a 09 09 20 20 20 20 20 20 20 6f 75 74 74 >"... outt
4110: 78 74 20 22 3c 2f 74 61 62 6c 65 3e 3c 2f 62 6f xt "</table></bo
4120: 64 79 3e 3c 2f 68 74 6d 6c 3e 22 29 0a 09 09 28 dy></html>")...(
4130: 72 65 6c 65 61 73 65 2d 64 6f 74 2d 6c 6f 63 6b release-dot-lock
4140: 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 29 outputfilename)
4150: 29 29 0a 09 20 20 20 20 28 63 6c 6f 73 65 2d 6f )).. (close-o
4160: 75 74 70 75 74 2d 70 6f 72 74 20 6f 75 70 29 0a utput-port oup).
4170: 09 20 20 20 20 28 63 68 61 6e 67 65 2d 64 69 72 . (change-dir
4180: 65 63 74 6f 72 79 20 6f 72 69 67 2d 64 69 72 29 ectory orig-dir)
4190: 0a 09 20 20 20 20 28 74 65 73 74 2d 73 65 74 2d .. (test-set-
41a0: 74 6f 70 6c 6f 67 21 20 64 62 20 72 75 6e 2d 69 toplog! db run-i
41b0: 64 20 74 65 73 74 2d 6e 61 6d 65 20 6f 75 74 70 d test-name outp
41c0: 75 74 66 69 6c 65 6e 61 6d 65 29 0a 09 20 20 20 utfilename)..
41d0: 20 29 29 29 29 29 0a 0a 3b 3b 20 3b 3b 20 54 4f )))))..;; ;; TO
41e0: 44 4f 3a 20 43 6f 6e 76 65 72 67 65 20 74 68 69 DO: Converge thi
41f0: 73 20 77 69 74 68 20 64 62 3a 67 65 74 2d 74 65 s with db:get-te
4200: 73 74 2d 69 6e 66 6f 0a 3b 3b 20 28 64 65 66 69 st-info.;; (defi
4210: 6e 65 20 28 72 75 6e 73 3a 67 65 74 2d 74 65 73 ne (runs:get-tes
4220: 74 2d 69 6e 66 6f 20 64 62 20 72 75 6e 2d 69 64 t-info db run-id
4230: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item-
4240: 70 61 74 68 29 0a 3b 3b 20 20 20 28 6c 65 74 20 path).;; (let
4250: 28 28 72 65 73 20 23 66 29 29 20 3b 3b 20 28 76 ((res #f)) ;; (v
4260: 65 63 74 6f 72 20 23 66 20 23 66 20 23 66 20 23 ector #f #f #f #
4270: 66 20 23 66 20 23 66 29 29 29 0a 3b 3b 20 20 20 f #f #f))).;;
4280: 20 20 28 73 71 6c 69 74 65 33 3a 66 6f 72 2d 65 (sqlite3:for-e
4290: 61 63 68 2d 72 6f 77 20 0a 3b 3b 20 20 20 20 20 ach-row .;;
42a0: 20 28 6c 61 6d 62 64 61 20 28 69 64 20 72 75 6e (lambda (id run
42b0: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 73 74 -id test-name st
42c0: 61 74 65 20 73 74 61 74 75 73 29 0a 3b 3b 20 20 ate status).;;
42d0: 20 20 20 20 20 20 28 73 65 74 21 20 72 65 73 20 (set! res
42e0: 28 76 65 63 74 6f 72 20 69 64 20 72 75 6e 2d 69 (vector id run-i
42f0: 64 20 74 65 73 74 2d 6e 61 6d 65 20 73 74 61 74 d test-name stat
4300: 65 20 73 74 61 74 75 73 20 69 74 65 6d 2d 70 61 e status item-pa
4310: 74 68 29 29 29 0a 3b 3b 20 20 20 20 20 20 64 62 th))).;; db
4320: 20 22 53 45 4c 45 43 54 20 69 64 2c 72 75 6e 5f "SELECT id,run_
4330: 69 64 2c 74 65 73 74 6e 61 6d 65 2c 73 74 61 74 id,testname,stat
4340: 65 2c 73 74 61 74 75 73 20 46 52 4f 4d 20 74 65 e,status FROM te
4350: 73 74 73 20 57 48 45 52 45 20 72 75 6e 5f 69 64 sts WHERE run_id
4360: 3d 3f 20 41 4e 44 20 74 65 73 74 6e 61 6d 65 3d =? AND testname=
4370: 3f 20 41 4e 44 20 69 74 65 6d 5f 70 61 74 68 3d ? AND item_path=
4380: 3f 3b 22 0a 3b 3b 20 20 20 20 20 20 72 75 6e 2d ?;".;; run-
4390: 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 id test-name ite
43a0: 6d 2d 70 61 74 68 29 0a 3b 3b 20 20 20 20 20 72 m-path).;; r
43b0: 65 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 es))..(define (r
43c0: 75 6e 73 3a 74 65 73 74 2d 67 65 74 2d 66 75 6c uns:test-get-ful
43d0: 6c 2d 70 61 74 68 20 74 65 73 74 29 0a 20 20 28 l-path test). (
43e0: 6c 65 74 2a 20 28 28 74 65 73 74 6e 61 6d 65 20 let* ((testname
43f0: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 (db:test-get-tes
4400: 74 6e 61 6d 65 20 20 20 74 65 73 74 29 29 0a 09 tname test))..
4410: 20 28 69 74 65 6d 70 61 74 68 20 28 64 62 3a 74 (itempath (db:t
4420: 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 est-get-item-pat
4430: 68 20 74 65 73 74 29 29 29 0a 20 20 20 20 28 63 h test))). (c
4440: 6f 6e 63 20 74 65 73 74 6e 61 6d 65 20 28 69 66 onc testname (if
4450: 20 28 65 71 75 61 6c 3f 20 69 74 65 6d 70 61 74 (equal? itempat
4460: 68 20 22 22 29 20 22 22 20 28 63 6f 6e 63 20 22 h "") "" (conc "
4470: 28 22 20 69 74 65 6d 70 61 74 68 20 22 29 22 29 (" itempath ")")
4480: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 ))))..(define (c
4490: 68 65 63 6b 2d 76 61 6c 69 64 2d 69 74 65 6d 73 heck-valid-items
44a0: 20 63 6c 61 73 73 20 69 74 65 6d 29 0a 20 20 28 class item). (
44b0: 6c 65 74 20 28 28 76 61 6c 69 64 2d 76 61 6c 75 let ((valid-valu
44c0: 65 73 20 28 6c 65 74 20 28 28 73 20 28 63 6f 6e es (let ((s (con
44d0: 66 69 67 2d 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 fig-lookup *conf
44e0: 69 67 64 61 74 2a 20 22 76 61 6c 69 64 76 61 6c igdat* "validval
44f0: 75 65 73 22 20 63 6c 61 73 73 29 29 29 0a 09 09 ues" class)))...
4500: 09 28 69 66 20 73 20 28 73 74 72 69 6e 67 2d 73 .(if s (string-s
4510: 70 6c 69 74 20 73 29 20 23 66 29 29 29 29 0a 20 plit s) #f)))).
4520: 20 20 20 28 69 66 20 76 61 6c 69 64 2d 76 61 6c (if valid-val
4530: 75 65 73 0a 09 28 69 66 20 28 6d 65 6d 62 65 72 ues..(if (member
4540: 20 69 74 65 6d 20 76 61 6c 69 64 2d 76 61 6c 75 item valid-valu
4550: 65 73 29 0a 09 20 20 20 20 69 74 65 6d 20 23 66 es).. item #f
4560: 29 0a 09 69 74 65 6d 29 29 29 0a 0a 28 64 65 66 )..item)))..(def
4570: 69 6e 65 20 28 74 65 73 74 73 74 65 70 2d 73 65 ine (teststep-se
4580: 74 2d 73 74 61 74 75 73 21 20 64 62 20 72 75 6e t-status! db run
4590: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 74 65 -id test-name te
45a0: 73 74 73 74 65 70 2d 6e 61 6d 65 20 73 74 61 74 ststep-name stat
45b0: 65 2d 69 6e 20 73 74 61 74 75 73 2d 69 6e 20 69 e-in status-in i
45c0: 74 65 6d 64 61 74 20 63 6f 6d 6d 65 6e 74 29 0a temdat comment).
45d0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 (debug:print 4
45e0: 20 22 72 75 6e 2d 69 64 3a 20 22 20 72 75 6e 2d "run-id: " run-
45f0: 69 64 20 22 20 74 65 73 74 2d 6e 61 6d 65 3a 20 id " test-name:
4600: 22 20 74 65 73 74 2d 6e 61 6d 65 29 0a 20 20 28 " test-name). (
4610: 6c 65 74 2a 20 28 28 73 74 61 74 65 20 20 20 20 let* ((state
4620: 20 28 63 68 65 63 6b 2d 76 61 6c 69 64 2d 69 74 (check-valid-it
4630: 65 6d 73 20 22 73 74 61 74 65 22 20 73 74 61 74 ems "state" stat
4640: 65 2d 69 6e 29 29 0a 09 20 28 73 74 61 74 75 73 e-in)).. (status
4650: 20 20 20 20 28 63 68 65 63 6b 2d 76 61 6c 69 64 (check-valid
4660: 2d 69 74 65 6d 73 20 22 73 74 61 74 75 73 22 20 -items "status"
4670: 73 74 61 74 75 73 2d 69 6e 29 29 0a 09 20 28 69 status-in)).. (i
4680: 74 65 6d 2d 70 61 74 68 20 28 69 74 65 6d 2d 6c tem-path (item-l
4690: 69 73 74 2d 3e 70 61 74 68 20 69 74 65 6d 64 61 ist->path itemda
46a0: 74 29 29 0a 09 20 28 74 65 73 74 64 61 74 20 20 t)).. (testdat
46b0: 20 28 64 62 3a 67 65 74 2d 74 65 73 74 2d 69 6e (db:get-test-in
46c0: 66 6f 20 64 62 20 72 75 6e 2d 69 64 20 74 65 73 fo db run-id tes
46d0: 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 t-name item-path
46e0: 29 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 ))). (debug:p
46f0: 72 69 6e 74 20 35 20 22 74 65 73 74 64 61 74 3a rint 5 "testdat:
4700: 20 22 20 74 65 73 74 64 61 74 29 0a 20 20 20 20 " testdat).
4710: 28 69 66 20 28 61 6e 64 20 74 65 73 74 64 61 74 (if (and testdat
4720: 20 3b 3b 20 69 66 20 74 68 65 20 73 65 63 74 69 ;; if the secti
4730: 6f 6e 20 65 78 69 73 74 73 20 74 68 65 6e 20 66 on exists then f
4740: 6f 72 63 65 20 73 70 65 63 69 66 69 63 61 74 69 orce specificati
4750: 6f 6e 20 42 55 47 2c 20 49 20 64 6f 6e 27 74 20 on BUG, I don't
4760: 6c 69 6b 65 20 68 6f 77 20 74 68 69 73 20 77 6f like how this wo
4770: 72 6b 73 2e 0a 09 20 20 20 20 20 28 6f 72 20 28 rks... (or (
4780: 6e 6f 74 20 73 74 61 74 65 29 28 6e 6f 74 20 73 not state)(not s
4790: 74 61 74 75 73 29 29 29 0a 09 28 64 65 62 75 67 tatus)))..(debug
47a0: 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e :print 0 "WARNIN
47b0: 47 3a 20 49 6e 76 61 6c 69 64 20 22 20 28 69 66 G: Invalid " (if
47c0: 20 73 74 61 74 75 73 20 22 73 74 61 74 75 73 22 status "status"
47d0: 20 22 73 74 61 74 65 22 29 0a 09 20 20 20 20 20 "state")..
47e0: 20 20 22 20 76 61 6c 75 65 20 5c 22 22 20 28 69 " value \"" (i
47f0: 66 20 73 74 61 74 75 73 20 73 74 61 74 65 2d 69 f status state-i
4800: 6e 20 73 74 61 74 75 73 2d 69 6e 29 20 22 5c 22 n status-in) "\"
4810: 2c 20 75 70 64 61 74 65 20 79 6f 75 72 20 76 61 , update your va
4820: 6c 69 64 76 61 6c 75 65 73 20 73 65 63 74 69 6f lidvalues sectio
4830: 6e 20 69 6e 20 6d 65 67 61 74 65 73 74 2e 63 6f n in megatest.co
4840: 6e 66 69 67 22 29 29 0a 20 20 20 20 28 69 66 20 nfig")). (if
4850: 74 65 73 74 64 61 74 0a 09 28 6c 65 74 20 28 28 testdat..(let ((
4860: 74 65 73 74 2d 69 64 20 28 74 65 73 74 3a 67 65 test-id (test:ge
4870: 74 2d 69 64 20 74 65 73 74 64 61 74 29 29 29 0a t-id testdat))).
4880: 09 20 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 . (sqlite3:exec
4890: 75 74 65 20 64 62 20 0a 09 09 09 22 49 4e 53 45 ute db ...."INSE
48a0: 52 54 20 4f 52 20 52 45 50 4c 41 43 45 20 69 6e RT OR REPLACE in
48b0: 74 6f 20 74 65 73 74 5f 73 74 65 70 73 20 28 74 to test_steps (t
48c0: 65 73 74 5f 69 64 2c 73 74 65 70 6e 61 6d 65 2c est_id,stepname,
48d0: 73 74 61 74 65 2c 73 74 61 74 75 73 2c 65 76 65 state,status,eve
48e0: 6e 74 5f 74 69 6d 65 2c 63 6f 6d 6d 65 6e 74 29 nt_time,comment)
48f0: 20 56 41 4c 55 45 53 28 3f 2c 3f 2c 3f 2c 3f 2c VALUES(?,?,?,?,
4900: 73 74 72 66 74 69 6d 65 28 27 25 73 27 2c 27 6e strftime('%s','n
4910: 6f 77 27 29 2c 3f 29 3b 22 0a 09 09 09 74 65 73 ow'),?);"....tes
4920: 74 2d 69 64 20 74 65 73 74 73 74 65 70 2d 6e 61 t-id teststep-na
4930: 6d 65 20 73 74 61 74 65 2d 69 6e 20 73 74 61 74 me state-in stat
4940: 75 73 2d 69 6e 20 28 69 66 20 63 6f 6d 6d 65 6e us-in (if commen
4950: 74 20 63 6f 6d 6d 65 6e 74 20 22 22 29 29 29 0a t comment ""))).
4960: 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 .(debug:print 0
4970: 22 45 52 52 4f 52 3a 20 43 61 6e 27 74 20 75 70 "ERROR: Can't up
4980: 64 61 74 65 20 22 20 74 65 73 74 2d 6e 61 6d 65 date " test-name
4990: 20 22 20 66 6f 72 20 72 75 6e 20 22 20 72 75 6e " for run " run
49a0: 2d 69 64 20 22 20 2d 3e 20 6e 6f 20 73 75 63 68 -id " -> no such
49b0: 20 74 65 73 74 20 69 6e 20 64 62 22 29 29 29 29 test in db"))))
49c0: 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 2d ..(define (test-
49d0: 67 65 74 2d 6b 69 6c 6c 2d 72 65 71 75 65 73 74 get-kill-request
49e0: 20 64 62 20 72 75 6e 2d 69 64 20 74 65 73 74 2d db run-id test-
49f0: 6e 61 6d 65 20 69 74 65 6d 64 61 74 29 0a 20 20 name itemdat).
4a00: 28 6c 65 74 2a 20 28 28 69 74 65 6d 2d 70 61 74 (let* ((item-pat
4a10: 68 20 28 69 74 65 6d 2d 6c 69 73 74 2d 3e 70 61 h (item-list->pa
4a20: 74 68 20 69 74 65 6d 64 61 74 29 29 0a 09 20 28 th itemdat)).. (
4a30: 74 65 73 74 64 61 74 20 20 20 28 64 62 3a 67 65 testdat (db:ge
4a40: 74 2d 74 65 73 74 2d 69 6e 66 6f 20 64 62 20 72 t-test-info db r
4a50: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 un-id test-name
4a60: 69 74 65 6d 2d 70 61 74 68 29 29 29 0a 20 20 20 item-path))).
4a70: 20 28 65 71 75 61 6c 3f 20 28 74 65 73 74 3a 67 (equal? (test:g
4a80: 65 74 2d 73 74 61 74 65 20 74 65 73 74 64 61 74 et-state testdat
4a90: 29 20 22 4b 49 4c 4c 52 45 51 22 29 29 29 0a 0a ) "KILLREQ")))..
4aa0: 28 64 65 66 69 6e 65 20 28 74 65 73 74 2d 73 65 (define (test-se
4ab0: 74 2d 6d 65 74 61 2d 69 6e 66 6f 20 64 62 20 72 t-meta-info db r
4ac0: 75 6e 2d 69 64 20 74 65 73 74 6e 61 6d 65 20 69 un-id testname i
4ad0: 74 65 6d 64 61 74 29 0a 20 20 28 6c 65 74 20 28 temdat). (let (
4ae0: 28 69 74 65 6d 2d 70 61 74 68 20 28 69 74 65 6d (item-path (item
4af0: 2d 6c 69 73 74 2d 3e 70 61 74 68 20 69 74 65 6d -list->path item
4b00: 64 61 74 29 29 0a 09 28 63 70 75 6c 6f 61 64 20 dat))..(cpuload
4b10: 20 28 67 65 74 2d 63 70 75 2d 6c 6f 61 64 29 29 (get-cpu-load))
4b20: 0a 09 28 68 6f 73 74 6e 61 6d 65 20 28 67 65 74 ..(hostname (get
4b30: 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 0a 09 28 64 -host-name))..(d
4b40: 69 73 6b 66 72 65 65 20 28 67 65 74 2d 64 66 20 iskfree (get-df
4b50: 28 63 75 72 72 65 6e 74 2d 64 69 72 65 63 74 6f (current-directo
4b60: 72 79 29 29 29 0a 09 28 75 6e 61 6d 65 20 20 20 ry)))..(uname
4b70: 20 28 67 65 74 2d 75 6e 61 6d 65 20 22 2d 73 72 (get-uname "-sr
4b80: 76 70 69 6f 22 29 29 0a 09 28 72 75 6e 70 61 74 vpio"))..(runpat
4b90: 68 20 20 28 63 75 72 72 65 6e 74 2d 64 69 72 65 h (current-dire
4ba0: 63 74 6f 72 79 29 29 29 0a 20 20 20 20 28 73 71 ctory))). (sq
4bb0: 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 64 62 lite3:execute db
4bc0: 20 22 55 50 44 41 54 45 20 74 65 73 74 73 20 53 "UPDATE tests S
4bd0: 45 54 20 68 6f 73 74 3d 3f 2c 63 70 75 6c 6f 61 ET host=?,cpuloa
4be0: 64 3d 3f 2c 64 69 73 6b 66 72 65 65 3d 3f 2c 75 d=?,diskfree=?,u
4bf0: 6e 61 6d 65 3d 3f 2c 72 75 6e 64 69 72 3d 3f 20 name=?,rundir=?
4c00: 57 48 45 52 45 20 72 75 6e 5f 69 64 3d 3f 20 41 WHERE run_id=? A
4c10: 4e 44 20 74 65 73 74 6e 61 6d 65 3d 3f 20 41 4e ND testname=? AN
4c20: 44 20 69 74 65 6d 5f 70 61 74 68 3d 3f 3b 22 0a D item_path=?;".
4c30: 09 09 20 20 68 6f 73 74 6e 61 6d 65 0a 09 09 20 .. hostname...
4c40: 20 63 70 75 6c 6f 61 64 0a 09 09 20 20 64 69 73 cpuload... dis
4c50: 6b 66 72 65 65 0a 09 09 20 20 75 6e 61 6d 65 0a kfree... uname.
4c60: 09 09 20 20 72 75 6e 70 61 74 68 0a 09 09 20 20 .. runpath...
4c70: 72 75 6e 2d 69 64 0a 09 09 20 20 74 65 73 74 6e run-id... testn
4c80: 61 6d 65 0a 09 09 20 20 69 74 65 6d 2d 70 61 74 ame... item-pat
4c90: 68 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 h)))..(define (t
4ca0: 65 73 74 2d 75 70 64 61 74 65 2d 6d 65 74 61 2d est-update-meta-
4cb0: 69 6e 66 6f 20 64 62 20 72 75 6e 2d 69 64 20 74 info db run-id t
4cc0: 65 73 74 6e 61 6d 65 20 69 74 65 6d 64 61 74 20 estname itemdat
4cd0: 6d 69 6e 75 74 65 73 20 63 70 75 6c 6f 61 64 20 minutes cpuload
4ce0: 64 69 73 6b 66 72 65 65 20 74 6d 70 66 72 65 65 diskfree tmpfree
4cf0: 29 0a 20 20 28 6c 65 74 20 28 28 69 74 65 6d 2d ). (let ((item-
4d00: 70 61 74 68 20 28 69 74 65 6d 2d 6c 69 73 74 2d path (item-list-
4d10: 3e 70 61 74 68 20 69 74 65 6d 64 61 74 29 29 29 >path itemdat)))
4d20: 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 69 74 . (if (not it
4d30: 65 6d 2d 70 61 74 68 29 28 62 65 67 69 6e 20 28 em-path)(begin (
4d40: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 debug:print 0 "W
4d50: 41 52 4e 49 4e 47 3a 20 49 54 45 4d 50 41 54 48 ARNING: ITEMPATH
4d60: 20 6e 6f 74 20 73 65 74 2e 22 29 20 20 20 28 73 not set.") (s
4d70: 65 74 21 20 69 74 65 6d 2d 70 61 74 68 20 22 22 et! item-path ""
4d80: 29 29 29 0a 20 20 20 20 3b 3b 20 28 6c 65 74 20 ))). ;; (let
4d90: 28 28 74 65 73 74 69 6e 66 6f 20 28 64 62 3a 67 ((testinfo (db:g
4da0: 65 74 2d 74 65 73 74 2d 69 6e 66 6f 20 64 62 20 et-test-info db
4db0: 72 75 6e 2d 69 64 20 74 65 73 74 6e 61 6d 65 20 run-id testname
4dc0: 69 74 65 6d 2d 70 61 74 68 29 29 29 0a 20 20 20 item-path))).
4dd0: 20 3b 3b 20 20 20 28 69 66 20 28 61 6e 64 20 28 ;; (if (and (
4de0: 6e 6f 74 20 28 65 71 75 61 6c 3f 20 28 64 62 3a not (equal? (db:
4df0: 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 73 20 test-get-status
4e00: 74 65 73 74 69 6e 66 6f 29 20 22 43 4f 4d 50 4c testinfo) "COMPL
4e10: 45 54 45 44 22 29 29 0a 20 20 20 20 3b 3b 20 20 ETED")). ;;
4e20: 20 20 20 20 20 20 20 20 20 20 28 6e 6f 74 20 28 (not (
4e30: 65 71 75 61 6c 3f 20 28 64 62 3a 74 65 73 74 2d equal? (db:test-
4e40: 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 69 get-status testi
4e50: 6e 66 6f 29 20 22 4b 49 4c 4c 52 45 51 22 29 29 nfo) "KILLREQ"))
4e60: 0a 20 20 20 20 28 73 71 6c 69 74 65 33 3a 65 78 . (sqlite3:ex
4e70: 65 63 75 74 65 0a 20 20 20 20 20 64 62 0a 20 20 ecute. db.
4e80: 20 20 20 22 55 50 44 41 54 45 20 74 65 73 74 73 "UPDATE tests
4e90: 20 53 45 54 20 63 70 75 6c 6f 61 64 3d 3f 2c 64 SET cpuload=?,d
4ea0: 69 73 6b 66 72 65 65 3d 3f 2c 72 75 6e 5f 64 75 iskfree=?,run_du
4eb0: 72 61 74 69 6f 6e 3d 3f 2c 73 74 61 74 65 3d 27 ration=?,state='
4ec0: 52 55 4e 4e 49 4e 47 27 20 57 48 45 52 45 20 72 RUNNING' WHERE r
4ed0: 75 6e 5f 69 64 3d 3f 20 41 4e 44 20 74 65 73 74 un_id=? AND test
4ee0: 6e 61 6d 65 3d 3f 20 41 4e 44 20 69 74 65 6d 5f name=? AND item_
4ef0: 70 61 74 68 3d 3f 20 41 4e 44 20 73 74 61 74 65 path=? AND state
4f00: 20 4e 4f 54 20 49 4e 20 28 27 43 4f 4d 50 4c 45 NOT IN ('COMPLE
4f10: 54 45 44 27 2c 27 4b 49 4c 4c 52 45 51 27 2c 27 TED','KILLREQ','
4f20: 4b 49 4c 4c 45 44 27 29 3b 22 0a 20 20 20 20 20 KILLED');".
4f30: 63 70 75 6c 6f 61 64 0a 20 20 20 20 20 64 69 73 cpuload. dis
4f40: 6b 66 72 65 65 0a 20 20 20 20 20 6d 69 6e 75 74 kfree. minut
4f50: 65 73 0a 20 20 20 20 20 72 75 6e 2d 69 64 0a 20 es. run-id.
4f60: 20 20 20 20 74 65 73 74 6e 61 6d 65 0a 20 20 20 testname.
4f70: 20 20 69 74 65 6d 2d 70 61 74 68 29 29 29 0a 0a item-path)))..
4f80: 28 64 65 66 69 6e 65 20 28 73 65 74 2d 6d 65 67 (define (set-meg
4f90: 61 74 65 73 74 2d 65 6e 76 2d 76 61 72 73 20 64 atest-env-vars d
4fa0: 62 20 72 75 6e 2d 69 64 29 0a 20 20 28 6c 65 74 b run-id). (let
4fb0: 20 28 28 6b 65 79 73 20 28 64 62 2d 67 65 74 2d ((keys (db-get-
4fc0: 6b 65 79 73 20 64 62 29 29 29 0a 20 20 20 20 28 keys db))). (
4fd0: 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 for-each (lambda
4fe0: 20 28 6b 65 79 29 0a 09 09 28 73 71 6c 69 74 65 (key)...(sqlite
4ff0: 33 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 0a 09 3:for-each-row..
5000: 09 20 28 6c 61 6d 62 64 61 20 28 76 61 6c 29 0a . (lambda (val).
5010: 09 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e .. (debug:prin
5020: 74 20 32 20 22 73 65 74 65 6e 76 20 22 20 28 6b t 2 "setenv " (k
5030: 65 79 3a 67 65 74 2d 66 69 65 6c 64 6e 61 6d 65 ey:get-fieldname
5040: 20 6b 65 79 29 20 22 20 22 20 76 61 6c 29 0a 09 key) " " val)..
5050: 09 20 20 20 28 73 65 74 65 6e 76 20 28 6b 65 79 . (setenv (key
5060: 3a 67 65 74 2d 66 69 65 6c 64 6e 61 6d 65 20 6b :get-fieldname k
5070: 65 79 29 20 76 61 6c 29 29 0a 09 09 20 64 62 20 ey) val))... db
5080: 0a 09 09 20 28 63 6f 6e 63 20 22 53 45 4c 45 43 ... (conc "SELEC
5090: 54 20 22 20 28 6b 65 79 3a 67 65 74 2d 66 69 65 T " (key:get-fie
50a0: 6c 64 6e 61 6d 65 20 6b 65 79 29 20 22 20 46 52 ldname key) " FR
50b0: 4f 4d 20 72 75 6e 73 20 57 48 45 52 45 20 69 64 OM runs WHERE id
50c0: 3d 3f 3b 22 29 0a 09 09 20 72 75 6e 2d 69 64 29 =?;")... run-id)
50d0: 29 0a 09 20 20 20 20 20 20 6b 65 79 73 29 29 29 ).. keys)))
50e0: 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 74 2d 69 ..(define (set-i
50f0: 74 65 6d 2d 65 6e 76 2d 76 61 72 73 20 69 74 65 tem-env-vars ite
5100: 6d 64 61 74 29 0a 20 20 28 66 6f 72 2d 65 61 63 mdat). (for-eac
5110: 68 20 28 6c 61 6d 62 64 61 20 28 69 74 65 6d 29 h (lambda (item)
5120: 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 .. (debug:p
5130: 72 69 6e 74 20 32 20 22 73 65 74 65 6e 76 20 22 rint 2 "setenv "
5140: 20 28 63 61 72 20 69 74 65 6d 29 20 22 20 22 20 (car item) " "
5150: 28 63 61 64 72 20 69 74 65 6d 29 29 0a 09 20 20 (cadr item))..
5160: 20 20 20 20 28 73 65 74 65 6e 76 20 28 63 61 72 (setenv (car
5170: 20 69 74 65 6d 29 20 28 63 61 64 72 20 69 74 65 item) (cadr ite
5180: 6d 29 29 29 0a 09 20 20 20 20 69 74 65 6d 64 61 m))).. itemda
5190: 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 67 65 t))..(define (ge
51a0: 74 2d 61 6c 6c 2d 6c 65 67 61 6c 2d 74 65 73 74 t-all-legal-test
51b0: 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 74 65 73 s). (let* ((tes
51c0: 74 73 20 20 28 67 6c 6f 62 20 28 63 6f 6e 63 20 ts (glob (conc
51d0: 2a 74 6f 70 70 61 74 68 2a 20 22 2f 74 65 73 74 *toppath* "/test
51e0: 73 2f 2a 22 29 29 29 0a 09 20 28 72 65 73 20 20 s/*"))).. (res
51f0: 20 20 27 28 29 29 29 0a 20 20 20 20 28 64 65 62 '())). (deb
5200: 75 67 3a 70 72 69 6e 74 20 34 20 22 49 4e 46 4f ug:print 4 "INFO
5210: 3a 20 4c 6f 6f 6b 69 6e 67 20 61 74 20 74 65 73 : Looking at tes
5220: 74 73 20 22 20 28 73 74 72 69 6e 67 2d 69 6e 74 ts " (string-int
5230: 65 72 73 70 65 72 73 65 20 74 65 73 74 73 20 22 ersperse tests "
5240: 2c 22 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 ,")). (for-ea
5250: 63 68 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 ch (lambda (test
5260: 70 61 74 68 29 0a 09 09 28 69 66 20 28 66 69 6c path)...(if (fil
5270: 65 2d 65 78 69 73 74 73 3f 20 28 63 6f 6e 63 20 e-exists? (conc
5280: 74 65 73 74 70 61 74 68 20 22 2f 74 65 73 74 63 testpath "/testc
5290: 6f 6e 66 69 67 22 29 29 0a 09 09 20 20 20 20 28 onfig"))... (
52a0: 73 65 74 21 20 72 65 73 20 28 63 6f 6e 73 20 28 set! res (cons (
52b0: 6c 61 73 74 20 28 73 74 72 69 6e 67 2d 73 70 6c last (string-spl
52c0: 69 74 20 74 65 73 74 70 61 74 68 20 22 2f 22 29 it testpath "/")
52d0: 29 20 72 65 73 29 29 29 29 0a 09 20 20 20 20 20 ) res))))..
52e0: 20 74 65 73 74 73 29 0a 20 20 20 20 72 65 73 29 tests). res)
52f0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 )..(define (runs
5300: 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 :can-run-more-te
5310: 73 74 73 20 64 62 29 0a 20 20 28 6c 65 74 20 28 sts db). (let (
5320: 28 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 28 64 62 (num-running (db
5330: 3a 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 :get-count-tests
5340: 2d 72 75 6e 6e 69 6e 67 20 64 62 29 29 0a 09 28 -running db))..(
5350: 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a max-concurrent-j
5360: 6f 62 73 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b obs (config-look
5370: 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 up *configdat* "
5380: 73 65 74 75 70 22 20 22 6d 61 78 5f 63 6f 6e 63 setup" "max_conc
5390: 75 72 72 65 6e 74 5f 6a 6f 62 73 22 29 29 29 0a urrent_jobs"))).
53a0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
53b0: 20 32 20 22 6d 61 78 2d 63 6f 6e 63 75 72 72 65 2 "max-concurre
53c0: 6e 74 2d 6a 6f 62 73 3a 20 22 20 6d 61 78 2d 63 nt-jobs: " max-c
53d0: 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 20 22 oncurrent-jobs "
53e0: 2c 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 3a 20 22 , num-running: "
53f0: 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 29 0a 20 20 num-running).
5400: 20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 (if (not (eq?
5410: 30 20 2a 67 6c 6f 62 61 6c 65 78 69 74 73 74 61 0 *globalexitsta
5420: 74 75 73 2a 29 29 0a 09 23 66 0a 09 28 69 66 20 tus*))..#f..(if
5430: 28 6f 72 20 28 6e 6f 74 20 6d 61 78 2d 63 6f 6e (or (not max-con
5440: 63 75 72 72 65 6e 74 2d 6a 6f 62 73 29 0a 09 09 current-jobs)...
5450: 28 61 6e 64 20 6d 61 78 2d 63 6f 6e 63 75 72 72 (and max-concurr
5460: 65 6e 74 2d 6a 6f 62 73 0a 09 09 20 20 20 20 20 ent-jobs...
5470: 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 (string->number
5480: 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a max-concurrent-j
5490: 6f 62 73 29 0a 09 09 20 20 20 20 20 28 6e 6f 74 obs)... (not
54a0: 20 28 3e 3d 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 (>= num-running
54b0: 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 (string->number
54c0: 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d max-concurrent-
54d0: 6a 6f 62 73 29 29 29 29 29 0a 09 20 20 20 20 23 jobs))))).. #
54e0: 74 0a 09 20 20 20 20 28 62 65 67 69 6e 20 0a 09 t.. (begin ..
54f0: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
5500: 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 4d nt 0 "WARNING: M
5510: 61 78 20 72 75 6e 6e 69 6e 67 20 6a 6f 62 73 20 ax running jobs
5520: 65 78 63 65 65 64 65 64 2c 20 63 75 72 72 65 6e exceeded, curren
5530: 74 20 6e 75 6d 62 65 72 20 72 75 6e 6e 69 6e 67 t number running
5540: 3a 20 22 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 : " num-running
5550: 0a 09 09 09 20 20 20 22 2c 20 6d 61 78 5f 63 6f .... ", max_co
5560: 6e 63 75 72 72 65 6e 74 5f 6a 6f 62 73 3a 20 22 ncurrent_jobs: "
5570: 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d max-concurrent-
5580: 6a 6f 62 73 29 0a 09 20 20 20 20 20 20 23 66 29 jobs).. #f)
5590: 29 29 29 29 0a 20 20 0a 28 64 65 66 69 6e 65 20 )))). .(define
55a0: 28 72 75 6e 2d 74 65 73 74 73 20 64 62 20 74 65 (run-tests db te
55b0: 73 74 2d 6e 61 6d 65 73 29 0a 20 20 28 6c 65 74 st-names). (let
55c0: 2a 20 28 28 6b 65 79 73 20 20 20 20 20 20 20 20 * ((keys
55d0: 28 64 62 2d 67 65 74 2d 6b 65 79 73 20 64 62 29 (db-get-keys db)
55e0: 29 0a 09 20 28 6b 65 79 76 61 6c 6c 73 74 20 20 ).. (keyvallst
55f0: 20 28 6b 65 79 73 2d 3e 76 61 6c 6c 69 73 74 20 (keys->vallist
5600: 6b 65 79 73 20 23 74 29 29 0a 09 20 28 72 75 6e keys #t)).. (run
5610: 2d 69 64 20 20 20 20 20 20 28 72 65 67 69 73 74 -id (regist
5620: 65 72 2d 72 75 6e 20 64 62 20 6b 65 79 73 29 29 er-run db keys))
5630: 20 20 3b 3b 20 20 74 65 73 74 2d 6e 61 6d 65 29 ;; test-name)
5640: 29 29 0a 09 20 28 64 65 66 65 72 72 65 64 20 20 )).. (deferred
5650: 20 20 27 28 29 29 29 20 3b 3b 20 64 65 6c 61 79 '())) ;; delay
5660: 20 72 75 6e 6e 69 6e 67 20 74 68 65 73 65 20 73 running these s
5670: 69 6e 63 65 20 74 68 65 79 20 68 61 76 65 20 61 ince they have a
5680: 20 77 61 69 74 6f 6e 20 63 6c 61 75 73 65 0a 20 waiton clause.
5690: 20 20 20 3b 3b 20 6f 6e 20 74 68 65 20 66 69 72 ;; on the fir
56a0: 73 74 20 70 61 73 73 20 6f 72 20 63 61 6c 6c 20 st pass or call
56b0: 74 6f 20 72 75 6e 2d 74 65 73 74 73 20 73 65 74 to run-tests set
56c0: 20 46 41 49 4c 53 20 74 6f 20 4e 4f 54 5f 53 54 FAILS to NOT_ST
56d0: 41 52 54 45 44 20 69 66 0a 20 20 20 20 3b 3b 20 ARTED if. ;;
56e0: 2d 6b 65 65 70 67 6f 69 6e 67 20 69 73 20 73 70 -keepgoing is sp
56f0: 65 63 69 66 69 65 64 0a 20 20 20 20 28 69 66 20 ecified. (if
5700: 28 61 6e 64 20 28 65 71 3f 20 2a 70 61 73 73 6e (and (eq? *passn
5710: 75 6d 2a 20 30 29 0a 09 20 20 20 20 20 28 61 72 um* 0).. (ar
5720: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 6b 65 65 gs:get-arg "-kee
5730: 70 67 6f 69 6e 67 22 29 29 0a 09 28 62 65 67 69 pgoing"))..(begi
5740: 6e 0a 09 20 20 3b 3b 20 68 61 76 65 20 74 6f 20 n.. ;; have to
5750: 64 65 6c 65 74 65 20 74 65 73 74 20 72 65 63 6f delete test reco
5760: 72 64 73 20 77 68 65 72 65 20 4e 4f 54 5f 53 54 rds where NOT_ST
5770: 41 52 54 45 44 20 73 69 6e 63 65 20 74 68 65 79 ARTED since they
5780: 20 63 61 6e 20 63 61 75 73 65 20 2d 6b 65 65 70 can cause -keep
5790: 67 6f 69 6e 67 20 74 6f 20 0a 09 20 20 3b 3b 20 going to .. ;;
57a0: 67 65 74 20 73 74 75 63 6b 20 64 75 65 20 74 6f get stuck due to
57b0: 20 62 65 63 6f 6d 69 6e 67 20 69 6e 61 63 63 65 becoming inacce
57c0: 73 73 69 62 6c 65 20 66 72 6f 6d 20 61 20 66 61 ssible from a fa
57d0: 69 6c 65 64 20 74 65 73 74 2e 20 49 2e 65 2e 20 iled test. I.e.
57e0: 69 66 20 74 65 73 74 20 42 20 64 65 70 65 6e 64 if test B depend
57f0: 73 20 0a 09 20 20 3b 3b 20 6f 6e 20 74 65 73 74 s .. ;; on test
5800: 20 41 20 62 75 74 20 74 65 73 74 20 42 20 72 65 A but test B re
5810: 61 63 68 65 64 20 74 68 65 20 70 6f 69 6e 74 20 ached the point
5820: 6f 6e 20 62 65 69 6e 67 20 72 65 67 69 73 74 65 on being registe
5830: 72 65 64 20 61 73 20 4e 4f 54 5f 53 54 41 52 54 red as NOT_START
5840: 45 44 20 61 6e 64 20 74 65 73 74 0a 09 20 20 3b ED and test.. ;
5850: 3b 20 41 20 66 61 69 6c 65 64 20 66 6f 72 20 73 ; A failed for s
5860: 6f 6d 65 20 72 65 61 73 6f 6e 20 74 68 65 6e 20 ome reason then
5870: 6f 6e 20 72 65 2d 72 75 6e 20 75 73 69 6e 67 20 on re-run using
5880: 2d 6b 65 65 70 67 6f 69 6e 67 20 74 68 65 20 72 -keepgoing the r
5890: 75 6e 20 63 61 6e 20 6e 65 76 65 72 20 63 6f 6d un can never com
58a0: 70 6c 65 74 65 2e 0a 09 20 20 28 64 62 3a 64 65 plete... (db:de
58b0: 6c 65 74 65 2d 74 65 73 74 73 2d 69 6e 2d 73 74 lete-tests-in-st
58c0: 61 74 65 20 64 62 20 72 75 6e 2d 69 64 20 22 4e ate db run-id "N
58d0: 4f 54 5f 53 54 41 52 54 45 44 22 29 0a 09 20 20 OT_STARTED")..
58e0: 28 64 62 3a 73 65 74 2d 74 65 73 74 73 2d 73 74 (db:set-tests-st
58f0: 61 74 65 2d 73 74 61 74 75 73 20 64 62 20 72 75 ate-status db ru
5900: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 73 20 n-id test-names
5910: 23 66 20 22 46 41 49 4c 22 20 22 4e 4f 54 5f 53 #f "FAIL" "NOT_S
5920: 54 41 52 54 45 44 22 20 22 46 41 49 4c 22 29 29 TARTED" "FAIL"))
5930: 29 0a 20 20 20 20 28 73 65 74 21 20 2a 70 61 73 ). (set! *pas
5940: 73 6e 75 6d 2a 20 28 2b 20 2a 70 61 73 73 6e 75 snum* (+ *passnu
5950: 6d 2a 20 31 29 29 0a 20 20 20 20 28 6c 65 74 20 m* 1)). (let
5960: 6c 6f 6f 70 20 28 28 6e 75 6d 74 69 6d 65 73 20 loop ((numtimes
5970: 30 29 29 0a 20 20 20 20 20 20 28 66 6f 72 2d 65 0)). (for-e
5980: 61 63 68 20 0a 20 20 20 20 20 20 20 28 6c 61 6d ach . (lam
5990: 62 64 61 20 28 74 65 73 74 2d 6e 61 6d 65 29 0a bda (test-name).
59a0: 09 20 28 69 66 20 28 72 75 6e 73 3a 63 61 6e 2d . (if (runs:can-
59b0: 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 20 64 run-more-tests d
59c0: 62 29 0a 09 20 20 20 20 20 28 72 75 6e 2d 6f 6e b).. (run-on
59d0: 65 2d 74 65 73 74 20 64 62 20 72 75 6e 2d 69 64 e-test db run-id
59e0: 20 74 65 73 74 2d 6e 61 6d 65 20 6b 65 79 76 61 test-name keyva
59f0: 6c 6c 73 74 29 0a 09 20 20 20 20 20 3b 3b 20 61 llst).. ;; a
5a00: 64 64 20 73 6f 6d 65 20 64 65 6c 61 79 20 0a 09 dd some delay ..
5a10: 20 20 20 20 20 3b 28 73 6c 65 65 70 20 32 29 0a ;(sleep 2).
5a20: 09 20 20 20 20 20 29 29 0a 20 20 20 20 20 20 20 . )).
5a30: 74 65 73 74 2d 6e 61 6d 65 73 29 0a 20 20 20 20 test-names).
5a40: 20 20 3b 3b 20 28 72 75 6e 2d 77 61 69 74 69 6e ;; (run-waitin
5a50: 67 2d 74 65 73 74 73 20 64 62 29 0a 20 20 20 20 g-tests db).
5a60: 20 20 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d (if (args:get-
5a70: 61 72 67 20 22 2d 6b 65 65 70 67 6f 69 6e 67 22 arg "-keepgoing"
5a80: 29 0a 09 20 20 28 6c 65 74 20 28 28 65 73 74 72 ).. (let ((estr
5a90: 65 6d 20 28 64 62 3a 65 73 74 69 6d 61 74 65 64 em (db:estimated
5aa0: 2d 74 65 73 74 73 2d 72 65 6d 61 69 6e 69 6e 67 -tests-remaining
5ab0: 20 64 62 20 72 75 6e 2d 69 64 29 29 29 0a 09 20 db run-id)))..
5ac0: 20 20 20 28 69 66 20 28 61 6e 64 20 28 3e 20 65 (if (and (> e
5ad0: 73 74 72 65 6d 20 30 29 0a 09 09 20 20 20 20 20 strem 0)...
5ae0: 28 65 71 3f 20 2a 67 6c 6f 62 61 6c 65 78 69 74 (eq? *globalexit
5af0: 73 74 61 74 75 73 2a 20 30 29 29 0a 09 09 28 62 status* 0))...(b
5b00: 65 67 69 6e 0a 09 09 20 20 28 64 65 62 75 67 3a egin... (debug:
5b10: 70 72 69 6e 74 20 31 20 22 4b 65 65 70 20 67 6f print 1 "Keep go
5b20: 69 6e 67 2c 20 65 73 74 69 6d 61 74 65 64 20 22 ing, estimated "
5b30: 20 65 73 74 72 65 6d 20 22 20 74 65 73 74 73 20 estrem " tests
5b40: 72 65 6d 61 69 6e 69 6e 67 20 74 6f 20 72 75 6e remaining to run
5b50: 2c 20 77 69 6c 6c 20 63 6f 6e 74 69 6e 75 65 20 , will continue
5b60: 69 6e 20 33 20 73 65 63 6f 6e 64 73 20 2e 2e 2e in 3 seconds ...
5b70: 22 29 0a 09 09 20 20 28 73 6c 65 65 70 20 33 29 ")... (sleep 3)
5b80: 0a 09 09 20 20 28 72 75 6e 2d 77 61 69 74 69 6e ... (run-waitin
5b90: 67 2d 74 65 73 74 73 20 64 62 29 0a 09 09 20 20 g-tests db)...
5ba0: 28 6c 6f 6f 70 20 28 2b 20 6e 75 6d 74 69 6d 65 (loop (+ numtime
5bb0: 73 20 31 29 29 29 29 29 29 29 29 29 0a 09 20 20 s 1)))))))))..
5bc0: 20 0a 3b 3b 20 56 45 52 59 20 49 4e 45 46 46 49 .;; VERY INEFFI
5bd0: 43 49 45 4e 54 21 20 4d 6f 76 65 20 73 74 75 66 CIENT! Move stuf
5be0: 66 20 74 68 61 74 20 73 68 6f 75 6c 64 20 62 65 f that should be
5bf0: 20 64 6f 6e 65 20 6f 6e 63 65 20 75 70 20 74 6f done once up to
5c00: 20 63 61 6c 6c 69 6e 67 20 70 72 6f 63 0a 28 64 calling proc.(d
5c10: 65 66 69 6e 65 20 28 72 75 6e 2d 6f 6e 65 2d 74 efine (run-one-t
5c20: 65 73 74 20 64 62 20 72 75 6e 2d 69 64 20 74 65 est db run-id te
5c30: 73 74 2d 6e 61 6d 65 20 6b 65 79 76 61 6c 6c 73 st-name keyvalls
5c40: 74 29 0a 20 20 28 64 65 62 75 67 3a 70 72 69 6e t). (debug:prin
5c50: 74 20 31 20 22 4c 61 75 6e 63 68 69 6e 67 20 74 t 1 "Launching t
5c60: 65 73 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 29 est " test-name)
5c70: 0a 20 20 3b 3b 20 41 6c 6c 20 74 68 65 73 65 20 . ;; All these
5c80: 76 61 72 73 20 6d 69 67 68 74 20 62 65 20 72 65 vars might be re
5c90: 66 65 72 65 6e 63 65 64 20 62 79 20 74 68 65 20 ferenced by the
5ca0: 74 65 73 74 63 6f 6e 66 69 67 20 66 69 6c 65 20 testconfig file
5cb0: 72 65 61 64 65 72 0a 20 20 28 73 65 74 65 6e 76 reader. (setenv
5cc0: 20 22 4d 54 5f 54 45 53 54 5f 4e 41 4d 45 22 20 "MT_TEST_NAME"
5cd0: 74 65 73 74 2d 6e 61 6d 65 29 20 3b 3b 20 0a 20 test-name) ;; .
5ce0: 20 28 73 65 74 65 6e 76 20 22 4d 54 5f 52 55 4e (setenv "MT_RUN
5cf0: 4e 41 4d 45 22 20 20 20 28 61 72 67 73 3a 67 65 NAME" (args:ge
5d00: 74 2d 61 72 67 20 22 3a 72 75 6e 6e 61 6d 65 22 t-arg ":runname"
5d10: 29 29 0a 20 20 28 73 65 74 2d 6d 65 67 61 74 65 )). (set-megate
5d20: 73 74 2d 65 6e 76 2d 76 61 72 73 20 64 62 20 72 st-env-vars db r
5d30: 75 6e 2d 69 64 29 20 3b 3b 20 74 68 65 73 65 20 un-id) ;; these
5d40: 6d 61 79 20 62 65 20 6e 65 65 64 65 64 20 62 79 may be needed by
5d50: 20 74 68 65 20 6c 61 75 6e 63 68 69 6e 67 20 70 the launching p
5d60: 72 6f 63 65 73 73 0a 20 20 28 63 68 61 6e 67 65 rocess. (change
5d70: 2d 64 69 72 65 63 74 6f 72 79 20 2a 74 6f 70 70 -directory *topp
5d80: 61 74 68 2a 29 0a 20 20 28 6c 65 74 2a 20 28 28 ath*). (let* ((
5d90: 74 65 73 74 2d 70 61 74 68 20 20 20 20 28 63 6f test-path (co
5da0: 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 74 nc *toppath* "/t
5db0: 65 73 74 73 2f 22 20 74 65 73 74 2d 6e 61 6d 65 ests/" test-name
5dc0: 29 29 0a 09 20 28 74 65 73 74 2d 63 6f 6e 66 69 )).. (test-confi
5dd0: 67 66 20 28 63 6f 6e 63 20 74 65 73 74 2d 70 61 gf (conc test-pa
5de0: 74 68 20 22 2f 74 65 73 74 63 6f 6e 66 69 67 22 th "/testconfig"
5df0: 29 29 0a 09 20 28 74 65 73 74 65 78 69 73 74 73 )).. (testexists
5e00: 20 20 20 28 61 6e 64 20 28 66 69 6c 65 2d 65 78 (and (file-ex
5e10: 69 73 74 73 3f 20 74 65 73 74 2d 63 6f 6e 66 69 ists? test-confi
5e20: 67 66 29 28 66 69 6c 65 2d 72 65 61 64 2d 61 63 gf)(file-read-ac
5e30: 63 65 73 73 3f 20 74 65 73 74 2d 63 6f 6e 66 69 cess? test-confi
5e40: 67 66 29 29 29 0a 09 20 28 74 65 73 74 2d 63 6f gf))).. (test-co
5e50: 6e 66 20 20 20 20 28 69 66 20 74 65 73 74 65 78 nf (if testex
5e60: 69 73 74 73 20 28 72 65 61 64 2d 63 6f 6e 66 69 ists (read-confi
5e70: 67 20 74 65 73 74 2d 63 6f 6e 66 69 67 66 20 23 g test-configf #
5e80: 66 20 23 74 29 20 28 6d 61 6b 65 2d 68 61 73 68 f #t) (make-hash
5e90: 2d 74 61 62 6c 65 29 29 29 0a 09 20 28 77 61 69 -table))).. (wai
5ea0: 74 6f 6e 20 20 20 20 20 20 20 28 6c 65 74 20 28 ton (let (
5eb0: 28 77 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 (w (config-looku
5ec0: 70 20 74 65 73 74 2d 63 6f 6e 66 20 22 72 65 71 p test-conf "req
5ed0: 75 69 72 65 6d 65 6e 74 73 22 20 22 77 61 69 74 uirements" "wait
5ee0: 6f 6e 22 29 29 29 0a 09 09 09 20 28 69 66 20 28 on"))).... (if (
5ef0: 73 74 72 69 6e 67 3f 20 77 29 28 73 74 72 69 6e string? w)(strin
5f00: 67 2d 73 70 6c 69 74 20 77 29 27 28 29 29 29 29 g-split w)'())))
5f10: 0a 09 20 28 74 61 67 73 20 20 20 20 20 20 20 20 .. (tags
5f20: 20 28 6c 65 74 20 28 28 74 20 28 63 6f 6e 66 69 (let ((t (confi
5f30: 67 2d 6c 6f 6f 6b 75 70 20 74 65 73 74 2d 63 6f g-lookup test-co
5f40: 6e 66 20 22 73 65 74 75 70 22 20 22 74 61 67 73 nf "setup" "tags
5f50: 22 29 29 29 0a 09 09 09 20 3b 3b 20 77 65 20 77 "))).... ;; we w
5f60: 61 6e 74 20 6f 75 72 20 74 61 67 73 20 74 6f 20 ant our tags to
5f70: 62 65 20 73 65 70 61 72 61 74 65 64 20 62 79 20 be separated by
5f80: 63 6f 6d 6d 61 73 20 61 6e 64 20 66 75 6c 6c 79 commas and fully
5f90: 20 64 65 6c 69 6d 69 74 65 64 20 62 79 20 63 6f delimited by co
5fa0: 6d 6d 61 73 0a 09 09 09 20 3b 3b 20 73 6f 20 74 mmas.... ;; so t
5fb0: 68 61 74 20 71 75 65 72 69 65 73 20 77 69 74 68 hat queries with
5fc0: 20 22 6c 69 6b 65 22 20 63 61 6e 20 74 69 65 20 "like" can tie
5fd0: 74 6f 20 74 68 65 20 63 6f 6d 6d 61 73 20 61 74 to the commas at
5fe0: 20 65 69 74 68 65 72 20 65 6e 64 20 6f 66 20 65 either end of e
5ff0: 61 63 68 20 74 61 67 0a 09 09 09 20 3b 3b 20 77 ach tag.... ;; w
6000: 68 69 6c 65 20 61 6c 73 6f 20 61 6c 6c 6f 77 69 hile also allowi
6010: 6e 67 20 74 68 65 20 65 6e 64 20 75 73 65 72 20 ng the end user
6020: 74 6f 20 66 72 65 65 6c 79 20 75 73 65 20 73 70 to freely use sp
6030: 61 63 65 73 20 61 6e 64 20 63 6f 6d 6d 61 73 20 aces and commas
6040: 74 6f 20 73 65 70 61 72 61 74 65 20 74 61 67 73 to separate tags
6050: 0a 09 09 09 20 28 69 66 20 28 73 74 72 69 6e 67 .... (if (string
6060: 3f 20 74 29 28 73 74 72 69 6e 67 2d 73 75 62 73 ? t)(string-subs
6070: 74 69 74 75 74 65 20 28 72 65 67 65 78 70 20 22 titute (regexp "
6080: 5b 2c 5c 5c 73 5d 2b 22 29 20 22 2c 22 20 28 63 [,\\s]+") "," (c
6090: 6f 6e 63 20 22 2c 22 20 74 20 22 2c 22 29 20 23 onc "," t ",") #
60a0: 74 29 0a 09 09 09 20 20 20 20 20 27 28 29 29 29 t).... '()))
60b0: 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 )). (if (not
60c0: 74 65 73 74 65 78 69 73 74 73 29 0a 09 28 62 65 testexists)..(be
60d0: 67 69 6e 0a 09 20 20 28 64 65 62 75 67 3a 70 72 gin.. (debug:pr
60e0: 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 43 61 int 0 "ERROR: Ca
60f0: 6e 27 74 20 66 69 6e 64 20 63 6f 6e 66 69 67 20 n't find config
6100: 66 69 6c 65 20 22 20 74 65 73 74 2d 63 6f 6e 66 file " test-conf
6110: 69 67 66 29 0a 09 20 20 28 65 78 69 74 20 32 29 igf).. (exit 2)
6120: 29 0a 09 3b 3b 20 70 75 74 20 74 6f 70 20 76 61 )..;; put top va
6130: 72 73 20 69 6e 74 6f 20 63 6f 6e 76 65 6e 69 65 rs into convenie
6140: 6e 74 20 76 61 72 69 61 62 6c 65 73 20 61 6e 64 nt variables and
6150: 20 6f 70 65 6e 20 74 68 65 20 64 62 0a 09 28 6c open the db..(l
6160: 65 74 2a 20 28 3b 3b 20 64 62 20 69 73 20 61 6c et* (;; db is al
6170: 77 61 79 73 20 61 74 20 2a 74 6f 70 70 61 74 68 ways at *toppath
6180: 2a 2f 64 62 2f 6d 65 67 61 74 65 73 74 2e 64 62 */db/megatest.db
6190: 0a 09 20 20 20 20 20 20 20 28 69 74 65 6d 73 20 .. (items
61a0: 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c (hash-tabl
61b0: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 65 e-ref/default te
61c0: 73 74 2d 63 6f 6e 66 20 22 69 74 65 6d 73 22 20 st-conf "items"
61d0: 27 28 29 29 29 0a 09 20 20 20 20 20 20 20 28 69 '())).. (i
61e0: 74 65 6d 73 74 61 62 6c 65 20 20 28 68 61 73 68 temstable (hash
61f0: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
6200: 6c 74 20 74 65 73 74 2d 63 6f 6e 66 20 22 69 74 lt test-conf "it
6210: 65 6d 73 74 61 62 6c 65 22 20 27 28 29 29 29 0a emstable" '())).
6220: 09 20 20 20 20 20 20 20 28 61 6c 6c 69 74 65 6d . (allitem
6230: 73 20 20 20 20 28 69 66 20 28 6f 72 20 28 6e 6f s (if (or (no
6240: 74 20 28 6e 75 6c 6c 3f 20 69 74 65 6d 73 29 29 t (null? items))
6250: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 69 74 65 6d (not (null? item
6260: 73 74 61 62 6c 65 29 29 29 0a 09 09 09 09 28 61 stable))).....(a
6270: 70 70 65 6e 64 20 28 69 74 65 6d 2d 61 73 73 6f ppend (item-asso
6280: 63 2d 3e 69 74 65 6d 2d 6c 69 73 74 20 69 74 65 c->item-list ite
6290: 6d 73 29 0a 09 09 09 09 09 28 69 74 65 6d 2d 74 ms)......(item-t
62a0: 61 62 6c 65 2d 3e 69 74 65 6d 2d 6c 69 73 74 20 able->item-list
62b0: 69 74 65 6d 73 74 61 62 6c 65 29 29 0a 09 09 09 itemstable))....
62c0: 09 27 28 28 29 29 29 29 20 3b 3b 20 61 20 6c 69 .'(()))) ;; a li
62d0: 73 74 20 77 69 74 68 20 6f 6e 65 20 6e 75 6c 6c st with one null
62e0: 20 6c 69 73 74 20 69 73 20 61 20 74 65 73 74 20 list is a test
62f0: 77 69 74 68 20 6e 6f 20 69 74 65 6d 73 0a 09 20 with no items..
6300: 20 20 20 20 20 20 28 72 75 6e 63 6f 6e 66 69 67 (runconfig
6310: 66 20 20 28 63 6f 6e 63 20 20 2a 74 6f 70 70 61 f (conc *toppa
6320: 74 68 2a 20 22 2f 72 75 6e 63 6f 6e 66 69 67 73 th* "/runconfigs
6330: 2e 63 6f 6e 66 69 67 22 29 29 29 0a 09 20 20 28 .config"))).. (
6340: 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 69 debug:print 1 "i
6350: 74 65 6d 73 3a 20 22 29 0a 09 20 20 28 69 66 20 tems: ").. (if
6360: 28 3e 3d 20 2a 76 65 72 62 6f 73 69 74 79 2a 20 (>= *verbosity*
6370: 31 29 28 70 70 20 61 6c 6c 69 74 65 6d 73 29 29 1)(pp allitems))
6380: 0a 09 20 20 28 69 66 20 28 3e 3d 20 2a 76 65 72 .. (if (>= *ver
6390: 62 6f 73 69 74 79 2a 20 35 29 0a 09 20 20 20 20 bosity* 5)..
63a0: 20 20 28 62 65 67 69 6e 0a 09 09 28 70 72 69 6e (begin...(prin
63b0: 74 20 22 69 74 65 6d 73 3a 20 22 29 28 70 70 20 t "items: ")(pp
63c0: 28 69 74 65 6d 2d 61 73 73 6f 63 2d 3e 69 74 65 (item-assoc->ite
63d0: 6d 2d 6c 69 73 74 20 69 74 65 6d 73 29 29 0a 09 m-list items))..
63e0: 09 28 70 72 69 6e 74 20 22 69 74 65 73 74 61 62 .(print "itestab
63f0: 6c 65 3a 20 22 29 28 70 70 20 28 69 74 65 6d 2d le: ")(pp (item-
6400: 74 61 62 6c 65 2d 3e 69 74 65 6d 2d 6c 69 73 74 table->item-list
6410: 20 69 74 65 6d 73 74 61 62 6c 65 29 29 29 29 0a itemstable)))).
6420: 09 20 20 28 69 66 20 28 61 72 67 73 3a 67 65 74 . (if (args:get
6430: 2d 61 72 67 20 22 2d 6d 22 29 0a 09 20 20 20 20 -arg "-m")..
6440: 20 20 28 64 62 3a 73 65 74 2d 63 6f 6d 6d 65 6e (db:set-commen
6450: 74 2d 66 6f 72 2d 72 75 6e 20 64 62 20 72 75 6e t-for-run db run
6460: 2d 69 64 20 28 61 72 67 73 3a 67 65 74 2d 61 72 -id (args:get-ar
6470: 67 20 22 2d 6d 22 29 29 29 0a 0a 09 20 20 3b 3b g "-m")))... ;;
6480: 20 48 65 72 65 20 69 73 20 77 68 65 72 65 20 74 Here is where t
6490: 68 65 20 74 65 73 74 5f 6d 65 74 61 20 74 61 62 he test_meta tab
64a0: 6c 65 20 69 73 20 62 65 73 74 20 75 70 64 61 74 le is best updat
64b0: 65 64 0a 09 20 20 28 72 75 6e 73 3a 75 70 64 61 ed.. (runs:upda
64c0: 74 65 2d 74 65 73 74 5f 6d 65 74 61 20 64 62 20 te-test_meta db
64d0: 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 63 test-name test-c
64e0: 6f 6e 66 29 0a 0a 09 20 20 3b 3b 20 62 72 61 69 onf)... ;; brai
64f0: 6e 64 65 61 64 20 77 6f 72 6b 2d 61 72 6f 75 6e ndead work-aroun
6500: 64 20 66 6f 72 20 70 6f 6f 72 6c 79 20 73 70 65 d for poorly spe
6510: 63 69 66 69 65 64 20 61 6c 6c 69 74 65 6d 73 20 cified allitems
6520: 6c 69 73 74 20 42 55 47 21 21 21 20 46 49 58 4d list BUG!!! FIXM
6530: 45 0a 09 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 E.. (if (null?
6540: 61 6c 6c 69 74 65 6d 73 29 28 73 65 74 21 20 61 allitems)(set! a
6550: 6c 6c 69 74 65 6d 73 20 27 28 28 29 29 29 29 0a llitems '(()))).
6560: 09 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 69 . (let loop ((i
6570: 74 65 6d 64 61 74 20 28 63 61 72 20 61 6c 6c 69 temdat (car alli
6580: 74 65 6d 73 29 29 0a 09 09 20 20 20 20 20 28 74 tems))... (t
6590: 61 6c 20 20 20 20 20 28 63 64 72 20 61 6c 6c 69 al (cdr alli
65a0: 74 65 6d 73 29 29 29 0a 09 20 20 20 20 3b 3b 20 tems))).. ;;
65b0: 28 6c 61 6d 62 64 61 20 28 69 74 65 6d 64 61 74 (lambda (itemdat
65c0: 29 20 3b 3b 3b 20 28 28 72 69 70 65 6e 65 73 73 ) ;;; ((ripeness
65d0: 20 22 6f 76 65 72 72 69 70 65 22 29 20 28 74 65 "overripe") (te
65e0: 6d 70 65 72 61 74 75 72 65 20 22 63 6f 6f 6c 22 mperature "cool"
65f0: 29 20 28 73 65 61 73 6f 6e 20 22 73 75 6d 6d 65 ) (season "summe
6600: 72 22 29 29 0a 09 20 20 20 20 3b 3b 20 48 61 6e r")).. ;; Han
6610: 64 6c 65 20 6c 69 73 74 73 20 6f 66 20 69 74 65 dle lists of ite
6620: 6d 73 0a 09 20 20 20 20 28 6c 65 74 2a 20 28 28 ms.. (let* ((
6630: 69 74 65 6d 2d 70 61 74 68 20 20 20 20 20 28 69 item-path (i
6640: 74 65 6d 2d 6c 69 73 74 2d 3e 70 61 74 68 20 69 tem-list->path i
6650: 74 65 6d 64 61 74 29 29 20 3b 3b 20 28 73 74 72 temdat)) ;; (str
6660: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
6670: 28 6d 61 70 20 63 61 64 72 20 69 74 65 6d 64 61 (map cadr itemda
6680: 74 29 20 22 2f 22 29 29 0a 09 09 20 20 20 28 6e t) "/"))... (n
6690: 65 77 2d 74 65 73 74 2d 70 61 74 68 20 28 73 74 ew-test-path (st
66a0: 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
66b0: 20 28 63 6f 6e 73 20 74 65 73 74 2d 70 61 74 68 (cons test-path
66c0: 20 28 6d 61 70 20 63 61 64 72 20 69 74 65 6d 64 (map cadr itemd
66d0: 61 74 29 29 20 22 2f 22 29 29 0a 09 09 20 20 20 at)) "/"))...
66e0: 28 6e 65 77 2d 74 65 73 74 2d 6e 61 6d 65 20 28 (new-test-name (
66f0: 69 66 20 28 65 71 75 61 6c 3f 20 69 74 65 6d 2d if (equal? item-
6700: 70 61 74 68 20 22 22 29 20 74 65 73 74 2d 6e 61 path "") test-na
6710: 6d 65 20 28 63 6f 6e 63 20 74 65 73 74 2d 6e 61 me (conc test-na
6720: 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 me "/" item-path
6730: 29 29 29 20 3b 3b 20 6a 75 73 74 20 6e 65 65 64 ))) ;; just need
6740: 20 69 74 20 74 6f 20 62 65 20 75 6e 69 71 75 65 it to be unique
6750: 0a 09 09 20 20 20 28 74 65 73 74 64 61 74 20 20 ... (testdat
6760: 20 23 66 29 0a 09 09 20 20 20 28 6e 75 6d 2d 72 #f)... (num-r
6770: 75 6e 6e 69 6e 67 20 28 64 62 3a 67 65 74 2d 63 unning (db:get-c
6780: 6f 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e 6e 69 ount-tests-runni
6790: 6e 67 20 64 62 29 29 0a 09 09 20 20 20 28 6d 61 ng db))... (ma
67a0: 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 x-concurrent-job
67b0: 73 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 s (config-lookup
67c0: 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 *configdat* "se
67d0: 74 75 70 22 20 22 6d 61 78 5f 63 6f 6e 63 75 72 tup" "max_concur
67e0: 72 65 6e 74 5f 6a 6f 62 73 22 29 29 0a 09 09 20 rent_jobs"))...
67f0: 20 20 28 70 61 72 65 6e 74 2d 74 65 73 74 20 28 (parent-test (
6800: 61 6e 64 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 and (not (null?
6810: 69 74 65 6d 73 29 29 28 65 71 75 61 6c 3f 20 69 items))(equal? i
6820: 74 65 6d 2d 70 61 74 68 20 22 22 29 29 29 0a 09 tem-path "")))..
6830: 09 20 20 20 28 73 69 6e 67 6c 65 2d 74 65 73 74 . (single-test
6840: 20 28 61 6e 64 20 28 6e 75 6c 6c 3f 20 69 74 65 (and (null? ite
6850: 6d 73 29 20 28 65 71 75 61 6c 3f 20 69 74 65 6d ms) (equal? item
6860: 2d 70 61 74 68 20 22 22 29 29 29 0a 09 09 20 20 -path "")))...
6870: 20 28 69 74 65 6d 2d 74 65 73 74 20 20 20 28 6e (item-test (n
6880: 6f 74 20 28 65 71 75 61 6c 3f 20 69 74 65 6d 2d ot (equal? item-
6890: 70 61 74 68 20 22 22 29 29 29 0a 09 09 20 20 20 path "")))...
68a0: 28 69 74 65 6d 2d 70 61 74 74 20 20 20 28 61 72 (item-patt (ar
68b0: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 69 74 65 gs:get-arg "-ite
68c0: 6d 70 61 74 74 22 29 29 0a 09 09 20 20 20 28 70 mpatt"))... (p
68d0: 61 74 74 2d 6d 61 74 63 68 20 20 28 69 66 20 69 att-match (if i
68e0: 74 65 6d 2d 70 61 74 74 0a 09 09 09 09 20 20 20 tem-patt.....
68f0: 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 28 (string-match (
6900: 67 6c 6f 62 2d 3e 72 65 67 65 78 70 0a 09 09 09 glob->regexp....
6910: 09 09 09 20 20 20 28 73 74 72 69 6e 67 2d 74 72 ... (string-tr
6920: 61 6e 73 6c 61 74 65 20 69 74 65 6d 2d 70 61 74 anslate item-pat
6930: 74 20 22 25 22 20 22 2a 22 29 29 0a 09 09 09 09 t "%" "*")).....
6940: 09 09 20 20 69 74 65 6d 2d 70 61 74 68 29 0a 09 .. item-path)..
6950: 09 09 09 20 20 20 20 23 74 29 29 29 0a 09 20 20 ... #t)))..
6960: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
6970: 20 33 20 22 6d 61 78 2d 63 6f 6e 63 75 72 72 65 3 "max-concurre
6980: 6e 74 2d 6a 6f 62 73 3a 20 22 20 6d 61 78 2d 63 nt-jobs: " max-c
6990: 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 20 22 oncurrent-jobs "
69a0: 2c 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 3a 20 22 , num-running: "
69b0: 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 29 0a 09 20 num-running)..
69c0: 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 70 61 (if (and pa
69d0: 74 74 2d 6d 61 74 63 68 20 28 72 75 6e 73 3a 63 tt-match (runs:c
69e0: 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 an-run-more-test
69f0: 73 20 64 62 29 29 0a 09 09 20 20 28 62 65 67 69 s db))... (begi
6a00: 6e 0a 09 09 20 20 20 20 28 6c 65 74 20 6c 6f 6f n... (let loo
6a10: 70 32 20 28 28 74 73 20 28 64 62 3a 67 65 74 2d p2 ((ts (db:get-
6a20: 74 65 73 74 2d 69 6e 66 6f 20 64 62 20 72 75 6e test-info db run
6a30: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 -id test-name it
6a40: 65 6d 2d 70 61 74 68 29 29 20 3b 3b 20 23 66 29 em-path)) ;; #f)
6a50: 0a 09 09 09 09 28 63 74 20 30 29 29 0a 09 09 20 .....(ct 0))...
6a60: 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 6e (if (and (n
6a70: 6f 74 20 74 73 29 0a 09 09 09 20 20 20 20 20 20 ot ts)....
6a80: 20 28 3c 20 63 74 20 31 30 29 29 0a 09 09 09 20 (< ct 10))....
6a90: 20 28 62 65 67 69 6e 0a 09 09 09 20 20 20 20 28 (begin.... (
6aa0: 72 65 67 69 73 74 65 72 2d 74 65 73 74 20 64 62 register-test db
6ab0: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
6ac0: 65 20 69 74 65 6d 2d 70 61 74 68 29 0a 09 09 09 e item-path)....
6ad0: 20 20 20 20 28 64 62 3a 74 65 73 74 2d 73 65 74 (db:test-set
6ae0: 2d 63 6f 6d 6d 65 6e 74 20 64 62 20 72 75 6e 2d -comment db run-
6af0: 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 id test-name ite
6b00: 6d 2d 70 61 74 68 20 22 22 29 0a 09 09 09 20 20 m-path "")....
6b10: 20 20 28 6c 6f 6f 70 32 20 28 64 62 3a 67 65 74 (loop2 (db:get
6b20: 2d 74 65 73 74 2d 69 6e 66 6f 20 64 62 20 72 75 -test-info db ru
6b30: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 n-id test-name i
6b40: 74 65 6d 2d 70 61 74 68 29 0a 09 09 09 09 20 20 tem-path).....
6b50: 20 28 2b 20 63 74 20 31 29 29 29 0a 09 09 09 20 (+ ct 1)))....
6b60: 20 28 69 66 20 74 73 0a 09 09 09 20 20 20 20 20 (if ts....
6b70: 20 28 73 65 74 21 20 74 65 73 74 64 61 74 20 74 (set! testdat t
6b80: 73 29 0a 09 09 09 20 20 20 20 20 20 28 62 65 67 s).... (beg
6b90: 69 6e 0a 09 09 09 09 28 64 65 62 75 67 3a 70 72 in.....(debug:pr
6ba0: 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 int 0 "WARNING:
6bb0: 43 6f 75 6c 64 6e 27 74 20 72 65 67 69 73 74 65 Couldn't registe
6bc0: 72 20 74 65 73 74 20 22 20 74 65 73 74 2d 6e 61 r test " test-na
6bd0: 6d 65 20 22 20 77 69 74 68 20 69 74 65 6d 20 70 me " with item p
6be0: 61 74 68 20 22 20 69 74 65 6d 2d 70 61 74 68 20 ath " item-path
6bf0: 22 2c 20 73 6b 69 70 70 69 6e 67 22 29 0a 09 09 ", skipping")...
6c00: 09 09 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c ..(if (not (null
6c10: 3f 20 74 61 6c 29 29 0a 09 09 09 09 20 20 20 20 ? tal)).....
6c20: 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 (loop (car tal)(
6c30: 63 64 72 20 74 61 6c 29 29 29 29 29 29 29 0a 09 cdr tal)))))))..
6c40: 09 20 20 20 20 28 63 68 61 6e 67 65 2d 64 69 72 . (change-dir
6c50: 65 63 74 6f 72 79 20 74 65 73 74 2d 70 61 74 68 ectory test-path
6c60: 29 0a 09 09 20 20 20 20 3b 3b 20 74 68 69 73 20 )... ;; this
6c70: 62 6c 6f 63 6b 20 69 73 20 68 65 72 65 20 6f 6e block is here on
6c80: 6c 79 20 74 6f 20 69 6e 66 6f 72 6d 20 74 68 65 ly to inform the
6c90: 20 75 73 65 72 20 65 61 72 6c 79 20 6f 6e 0a 09 user early on..
6ca0: 09 20 20 20 20 28 69 66 20 28 66 69 6c 65 2d 65 . (if (file-e
6cb0: 78 69 73 74 73 3f 20 72 75 6e 63 6f 6e 66 69 67 xists? runconfig
6cc0: 66 29 0a 09 09 09 28 73 65 74 75 70 2d 65 6e 76 f)....(setup-env
6cd0: 2d 64 65 66 61 75 6c 74 73 20 64 62 20 72 75 6e -defaults db run
6ce0: 63 6f 6e 66 69 67 66 20 72 75 6e 2d 69 64 20 2a configf run-id *
6cf0: 61 6c 72 65 61 64 79 2d 73 65 65 6e 2d 72 75 6e already-seen-run
6d00: 63 6f 6e 66 69 67 2d 69 6e 66 6f 2a 29 0a 09 09 config-info*)...
6d10: 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 .(debug:print 0
6d20: 22 57 41 52 4e 49 4e 47 3a 20 59 6f 75 20 64 6f "WARNING: You do
6d30: 20 6e 6f 74 20 68 61 76 65 20 61 20 72 75 6e 20 not have a run
6d40: 63 6f 6e 66 69 67 20 66 69 6c 65 3a 20 22 20 72 config file: " r
6d50: 75 6e 63 6f 6e 66 69 67 66 29 29 0a 09 09 20 20 unconfigf))...
6d60: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 (debug:print 4
6d70: 20 22 72 75 6e 2d 69 64 3a 20 22 20 72 75 6e 2d "run-id: " run-
6d80: 69 64 20 22 20 74 65 73 74 2d 6e 61 6d 65 3a 20 id " test-name:
6d90: 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 69 74 " test-name " it
6da0: 65 6d 2d 70 61 74 68 3a 20 22 20 69 74 65 6d 2d em-path: " item-
6db0: 70 61 74 68 20 22 20 74 65 73 74 64 61 74 3a 20 path " testdat:
6dc0: 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 " (test:get-stat
6dd0: 75 73 20 74 65 73 74 64 61 74 29 20 22 20 74 65 us testdat) " te
6de0: 73 74 2d 73 74 61 74 65 3a 20 22 20 28 74 65 73 st-state: " (tes
6df0: 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 t:get-state test
6e00: 64 61 74 29 29 0a 09 09 20 20 20 20 28 63 61 73 dat))... (cas
6e10: 65 20 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d e (if (args:get-
6e20: 61 72 67 20 22 2d 66 6f 72 63 65 22 29 0a 09 09 arg "-force")...
6e30: 09 20 20 20 20 20 20 27 4e 4f 54 5f 53 54 41 52 . 'NOT_STAR
6e40: 54 45 44 0a 09 09 09 20 20 20 20 20 20 28 69 66 TED.... (if
6e50: 20 74 65 73 74 64 61 74 0a 09 09 09 09 20 20 28 testdat..... (
6e60: 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 string->symbol (
6e70: 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 test:get-state t
6e80: 65 73 74 64 61 74 29 29 0a 09 09 09 09 20 20 27 estdat))..... '
6e90: 66 61 69 6c 65 64 2d 74 6f 2d 69 6e 73 65 72 74 failed-to-insert
6ea0: 29 29 0a 09 09 20 20 20 20 20 20 28 28 66 61 69 ))... ((fai
6eb0: 6c 65 64 2d 74 6f 2d 69 6e 73 65 72 74 29 0a 09 led-to-insert)..
6ec0: 09 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 . (debug:p
6ed0: 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 46 rint 0 "ERROR: F
6ee0: 61 69 6c 65 64 20 74 6f 20 69 6e 73 65 72 74 20 ailed to insert
6ef0: 74 68 65 20 72 65 63 6f 72 64 20 69 6e 74 6f 20 the record into
6f00: 74 68 65 20 64 62 22 29 29 0a 09 09 20 20 20 20 the db"))...
6f10: 20 20 28 28 4e 4f 54 5f 53 54 41 52 54 45 44 20 ((NOT_STARTED
6f20: 43 4f 4d 50 4c 45 54 45 44 29 0a 09 09 20 20 20 COMPLETED)...
6f30: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
6f40: 20 36 20 22 47 6f 74 20 68 65 72 65 2c 20 22 20 6 "Got here, "
6f50: 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 (test:get-state
6f60: 74 65 73 74 64 61 74 29 29 0a 09 09 20 20 20 20 testdat))...
6f70: 20 20 20 28 6c 65 74 20 28 28 72 75 6e 66 6c 61 (let ((runfla
6f80: 67 20 23 66 29 29 0a 09 09 09 20 28 63 6f 6e 64 g #f)).... (cond
6f90: 0a 09 09 09 20 20 3b 3b 20 69 2e 65 2e 20 74 68 .... ;; i.e. th
6fa0: 69 73 20 69 73 20 74 68 65 20 70 61 72 65 6e 74 is is the parent
6fb0: 20 74 65 73 74 20 74 6f 20 61 20 73 75 69 74 65 test to a suite
6fc0: 20 6f 66 20 69 74 65 6d 73 2c 20 6e 65 76 65 72 of items, never
6fd0: 20 22 72 75 6e 22 20 69 74 0a 09 09 09 20 20 28 "run" it.... (
6fe0: 70 61 72 65 6e 74 2d 74 65 73 74 0a 09 09 09 20 parent-test....
6ff0: 20 20 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 (set! runflag
7000: 23 66 29 29 0a 09 09 09 20 20 3b 3b 20 2d 66 6f #f)).... ;; -fo
7010: 72 63 65 2c 20 72 75 6e 20 6e 6f 20 6d 61 74 74 rce, run no matt
7020: 65 72 20 77 68 61 74 0a 09 09 09 20 20 28 28 61 er what.... ((a
7030: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 66 6f rgs:get-arg "-fo
7040: 72 63 65 22 29 28 73 65 74 21 20 72 75 6e 66 6c rce")(set! runfl
7050: 61 67 20 23 74 29 29 0a 09 09 09 20 20 3b 3b 20 ag #t)).... ;;
7060: 4e 4f 54 5f 53 54 41 52 54 45 44 2c 20 72 75 6e NOT_STARTED, run
7070: 20 6e 6f 20 6d 61 74 74 65 72 20 77 68 61 74 0a no matter what.
7080: 09 09 09 20 20 28 28 65 71 75 61 6c 3f 20 28 74 ... ((equal? (t
7090: 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 est:get-state te
70a0: 73 74 64 61 74 29 20 22 4e 4f 54 5f 53 54 41 52 stdat) "NOT_STAR
70b0: 54 45 44 22 29 28 73 65 74 21 20 72 75 6e 66 6c TED")(set! runfl
70c0: 61 67 20 23 74 29 29 0a 09 09 09 20 20 3b 3b 20 ag #t)).... ;;
70d0: 6e 6f 74 20 2d 72 65 72 75 6e 20 61 6e 64 20 50 not -rerun and P
70e0: 41 53 53 2c 20 57 41 52 4e 20 6f 72 20 43 48 45 ASS, WARN or CHE
70f0: 43 4b 2c 20 64 6f 20 6e 6f 20 72 75 6e 0a 09 09 CK, do no run...
7100: 09 20 20 28 28 61 6e 64 20 28 6f 72 20 28 6e 6f . ((and (or (no
7110: 74 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 t (args:get-arg
7120: 22 2d 72 65 72 75 6e 22 29 29 0a 09 09 09 09 20 "-rerun")).....
7130: 20 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 (args:get-arg
7140: 20 22 2d 6b 65 65 70 67 6f 69 6e 67 22 29 29 0a "-keepgoing")).
7150: 09 09 09 09 28 6d 65 6d 62 65 72 20 28 74 65 73 ....(member (tes
7160: 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 t:get-status tes
7170: 74 64 61 74 29 20 27 28 22 50 41 53 53 22 20 22 tdat) '("PASS" "
7180: 57 41 52 4e 22 20 22 43 48 45 43 4b 22 29 29 29 WARN" "CHECK")))
7190: 0a 09 09 09 20 20 20 28 73 65 74 21 20 72 75 6e .... (set! run
71a0: 66 6c 61 67 20 23 66 29 29 0a 09 09 09 20 20 3b flag #f)).... ;
71b0: 3b 20 2d 72 65 72 75 6e 20 61 6e 64 20 73 74 61 ; -rerun and sta
71c0: 74 75 73 20 69 73 20 6f 6e 65 20 6f 66 20 74 68 tus is one of th
71d0: 65 20 73 70 65 63 69 66 65 64 2c 20 72 75 6e 20 e specifed, run
71e0: 69 74 0a 09 09 09 20 20 28 28 61 6e 64 20 28 61 it.... ((and (a
71f0: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 rgs:get-arg "-re
7200: 72 75 6e 22 29 0a 09 09 09 09 28 6c 65 74 20 28 run").....(let (
7210: 28 72 65 72 75 6e 6c 73 74 20 28 73 74 72 69 6e (rerunlst (strin
7220: 67 2d 73 70 6c 69 74 20 28 61 72 67 73 3a 67 65 g-split (args:ge
7230: 74 2d 61 72 67 20 22 2d 72 65 72 75 6e 22 29 20 t-arg "-rerun")
7240: 22 2c 22 29 29 29 20 3b 3b 20 46 41 49 4c 2c 0a ","))) ;; FAIL,.
7250: 09 09 09 09 20 20 28 6d 65 6d 62 65 72 20 28 74 .... (member (t
7260: 65 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 est:get-status t
7270: 65 73 74 64 61 74 29 20 72 65 72 75 6e 6c 73 74 estdat) rerunlst
7280: 29 29 29 0a 09 09 09 20 20 20 28 73 65 74 21 20 ))).... (set!
7290: 72 75 6e 66 6c 61 67 20 23 74 29 29 0a 09 09 09 runflag #t))....
72a0: 20 20 3b 3b 20 2d 6b 65 65 70 67 6f 69 6e 67 2c ;; -keepgoing,
72b0: 20 64 6f 20 6e 6f 74 20 72 65 72 75 6e 20 46 41 do not rerun FA
72c0: 49 4c 0a 09 09 09 20 20 28 28 61 6e 64 20 28 61 IL.... ((and (a
72d0: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 6b 65 rgs:get-arg "-ke
72e0: 65 70 67 6f 69 6e 67 22 29 0a 09 09 09 09 28 6d epgoing").....(m
72f0: 65 6d 62 65 72 20 28 74 65 73 74 3a 67 65 74 2d ember (test:get-
7300: 73 74 61 74 75 73 20 74 65 73 74 64 61 74 29 20 status testdat)
7310: 27 28 22 46 41 49 4c 22 29 29 29 0a 09 09 09 20 '("FAIL")))....
7320: 20 20 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 (set! runflag
7330: 23 66 29 29 0a 09 09 09 20 20 28 28 61 6e 64 20 #f)).... ((and
7340: 28 6e 6f 74 20 28 61 72 67 73 3a 67 65 74 2d 61 (not (args:get-a
7350: 72 67 20 22 2d 72 65 72 75 6e 22 29 29 0a 09 09 rg "-rerun"))...
7360: 09 09 28 6d 65 6d 62 65 72 20 28 74 65 73 74 3a ..(member (test:
7370: 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 get-status testd
7380: 61 74 29 20 27 28 22 46 41 49 4c 22 20 22 6e 2f at) '("FAIL" "n/
7390: 61 22 29 29 29 0a 09 09 09 20 20 20 28 73 65 74 a"))).... (set
73a0: 21 20 72 75 6e 66 6c 61 67 20 23 74 29 29 0a 09 ! runflag #t))..
73b0: 09 09 20 20 28 65 6c 73 65 20 28 73 65 74 21 20 .. (else (set!
73c0: 72 75 6e 66 6c 61 67 20 23 66 29 29 29 0a 09 09 runflag #f)))...
73d0: 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 36 . (debug:print 6
73e0: 20 22 52 55 4e 4e 49 4e 47 20 3d 3e 20 72 75 6e "RUNNING => run
73f0: 66 6c 61 67 3a 20 22 20 72 75 6e 66 6c 61 67 20 flag: " runflag
7400: 22 20 53 54 41 54 45 3a 20 22 20 28 74 65 73 74 " STATE: " (test
7410: 3a 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 64 :get-state testd
7420: 61 74 29 20 22 20 53 54 41 54 55 53 3a 20 22 20 at) " STATUS: "
7430: 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 75 73 (test:get-status
7440: 20 74 65 73 74 64 61 74 29 29 0a 09 09 09 20 28 testdat)).... (
7450: 69 66 20 28 6e 6f 74 20 72 75 6e 66 6c 61 67 29 if (not runflag)
7460: 0a 09 09 09 20 20 20 20 20 28 69 66 20 28 6e 6f .... (if (no
7470: 74 20 70 61 72 65 6e 74 2d 74 65 73 74 29 0a 09 t parent-test)..
7480: 09 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ... (debug:print
7490: 20 31 20 22 4e 4f 54 45 3a 20 4e 6f 74 20 73 74 1 "NOTE: Not st
74a0: 61 72 74 69 6e 67 20 74 65 73 74 20 22 20 6e 65 arting test " ne
74b0: 77 2d 74 65 73 74 2d 6e 61 6d 65 20 22 20 61 73 w-test-name " as
74c0: 20 69 74 20 69 73 20 73 74 61 74 65 20 5c 22 43 it is state \"C
74d0: 4f 4d 50 4c 45 54 45 44 5c 22 20 61 6e 64 20 73 OMPLETED\" and s
74e0: 74 61 74 75 73 20 5c 22 22 20 28 74 65 73 74 3a tatus \"" (test:
74f0: 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 get-status testd
7500: 61 74 29 20 22 5c 22 2c 20 75 73 65 20 2d 66 6f at) "\", use -fo
7510: 72 63 65 20 74 6f 20 6f 76 65 72 72 69 64 65 22 rce to override"
7520: 29 29 0a 09 09 09 20 20 20 20 20 28 6c 65 74 2a )).... (let*
7530: 20 28 28 67 65 74 2d 70 72 65 72 65 71 73 2d 63 ((get-prereqs-c
7540: 6d 64 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 md (lambda ()...
7550: 09 09 09 09 20 20 20 20 20 20 20 28 64 62 2d 67 .... (db-g
7560: 65 74 2d 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d et-prereqs-not-m
7570: 65 74 20 64 62 20 72 75 6e 2d 69 64 20 77 61 69 et db run-id wai
7580: 74 6f 6e 29 29 29 20 3b 3b 20 63 68 65 63 6b 20 ton))) ;; check
7590: 62 65 66 6f 72 65 20 72 75 6e 6e 69 6e 67 20 2e before running .
75a0: 2e 2e 2e 0a 09 09 09 09 20 20 20 20 28 6c 61 75 ........ (lau
75b0: 6e 63 68 2d 63 6d 64 20 20 20 20 20 20 28 6c 61 nch-cmd (la
75c0: 6d 62 64 61 20 28 29 0a 09 09 09 09 09 09 20 20 mbda ().......
75d0: 20 20 20 20 20 28 6c 61 75 6e 63 68 2d 74 65 73 (launch-tes
75e0: 74 20 64 62 20 72 75 6e 2d 69 64 20 74 65 73 74 t db run-id test
75f0: 2d 63 6f 6e 66 20 6b 65 79 76 61 6c 6c 73 74 20 -conf keyvallst
7600: 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 70 test-name test-p
7610: 61 74 68 20 69 74 65 6d 64 61 74 29 29 29 0a 09 ath itemdat)))..
7620: 09 09 09 20 20 20 20 28 74 65 73 74 72 75 6e 64 ... (testrund
7630: 61 74 20 20 20 20 20 20 28 6c 69 73 74 20 67 65 at (list ge
7640: 74 2d 70 72 65 72 65 71 73 2d 63 6d 64 20 6c 61 t-prereqs-cmd la
7650: 75 6e 63 68 2d 63 6d 64 29 29 29 0a 09 09 09 20 unch-cmd)))....
7660: 20 20 20 20 20 20 28 69 66 20 28 6f 72 20 28 61 (if (or (a
7670: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 66 6f rgs:get-arg "-fo
7680: 72 63 65 22 29 0a 09 09 09 09 20 20 20 20 20 20 rce").....
7690: 20 28 6c 65 74 20 28 28 70 72 65 71 73 2d 6e 6f (let ((preqs-no
76a0: 74 2d 79 65 74 2d 6d 65 74 20 28 28 63 61 72 20 t-yet-met ((car
76b0: 74 65 73 74 72 75 6e 64 61 74 29 29 29 29 0a 09 testrundat))))..
76c0: 09 09 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e .... (debug:prin
76d0: 74 20 32 20 22 50 72 65 71 72 65 71 75 65 73 69 t 2 "Preqrequesi
76e0: 74 65 73 20 66 6f 72 20 22 20 74 65 73 74 2d 6e tes for " test-n
76f0: 61 6d 65 20 22 3a 20 22 20 70 72 65 71 73 2d 6e ame ": " preqs-n
7700: 6f 74 2d 79 65 74 2d 6d 65 74 29 0a 09 09 09 09 ot-yet-met).....
7710: 09 20 28 6e 75 6c 6c 3f 20 70 72 65 71 73 2d 6e . (null? preqs-n
7720: 6f 74 2d 79 65 74 2d 6d 65 74 29 29 29 20 3b 3b ot-yet-met))) ;;
7730: 20 61 72 65 20 74 68 65 72 65 20 61 6e 79 20 74 are there any t
7740: 65 73 74 73 20 74 68 61 74 20 6d 75 73 74 20 62 ests that must b
7750: 65 20 72 75 6e 20 62 65 66 6f 72 65 20 74 68 69 e run before thi
7760: 73 20 6f 6e 65 2e 2e 2e 0a 09 09 09 09 20 20 20 s one........
7770: 28 69 66 20 28 6e 6f 74 20 28 28 63 61 64 72 20 (if (not ((cadr
7780: 74 65 73 74 72 75 6e 64 61 74 29 29 29 20 3b 3b testrundat))) ;;
7790: 20 74 68 69 73 20 69 73 20 74 68 65 20 6c 69 6e this is the lin
77a0: 65 20 74 68 61 74 20 6c 61 75 6e 63 68 65 73 20 e that launches
77b0: 74 68 65 20 74 65 73 74 20 74 6f 20 74 68 65 20 the test to the
77c0: 72 65 6d 6f 74 65 20 68 6f 73 74 0a 09 09 09 09 remote host.....
77d0: 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 (begin...
77e0: 09 09 09 20 28 70 72 69 6e 74 20 22 45 52 52 4f ... (print "ERRO
77f0: 52 3a 20 46 61 69 6c 65 64 20 74 6f 20 6c 61 75 R: Failed to lau
7800: 6e 63 68 20 74 68 65 20 74 65 73 74 2e 20 45 78 nch the test. Ex
7810: 69 74 69 6e 67 20 61 73 20 73 6f 6f 6e 20 61 73 iting as soon as
7820: 20 70 6f 73 73 69 62 6c 65 22 29 0a 09 09 09 09 possible").....
7830: 09 20 28 73 65 74 21 20 2a 67 6c 6f 62 61 6c 65 . (set! *globale
7840: 78 69 74 73 74 61 74 75 73 2a 20 31 29 20 3b 3b xitstatus* 1) ;;
7850: 20 0a 09 09 09 09 09 20 28 70 72 6f 63 65 73 73 ...... (process
7860: 2d 73 69 67 6e 61 6c 20 28 63 75 72 72 65 6e 74 -signal (current
7870: 2d 70 72 6f 63 65 73 73 2d 69 64 29 20 73 69 67 -process-id) sig
7880: 6e 61 6c 2f 6b 69 6c 6c 29 0a 09 09 09 09 09 20 nal/kill)......
7890: 3b 28 65 78 69 74 20 31 29 0a 09 09 09 09 09 20 ;(exit 1)......
78a0: 29 29 0a 09 09 09 09 20 20 20 28 69 66 20 28 6e ))..... (if (n
78b0: 6f 74 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 ot (args:get-arg
78c0: 20 22 2d 6b 65 65 70 67 6f 69 6e 67 22 29 29 0a "-keepgoing")).
78d0: 09 09 09 09 20 20 20 20 20 20 20 28 68 61 73 68 .... (hash
78e0: 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a 77 61 69 -table-set! *wai
78f0: 74 69 6e 67 2d 71 75 65 75 65 2a 20 6e 65 77 2d ting-queue* new-
7900: 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 72 75 test-name testru
7910: 6e 64 61 74 29 29 29 29 29 29 29 0a 09 09 20 20 ndat)))))))...
7920: 20 20 20 20 28 28 4b 49 4c 4c 45 44 29 20 0a 09 ((KILLED) ..
7930: 09 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 . (debug:p
7940: 72 69 6e 74 20 31 20 22 4e 4f 54 45 3a 20 22 20 rint 1 "NOTE: "
7950: 6e 65 77 2d 74 65 73 74 2d 6e 61 6d 65 20 22 20 new-test-name "
7960: 69 73 20 61 6c 72 65 61 64 79 20 72 75 6e 6e 69 is already runni
7970: 6e 67 20 6f 72 20 77 61 73 20 65 78 70 6c 69 63 ng or was explic
7980: 74 6c 79 20 6b 69 6c 6c 65 64 2c 20 75 73 65 20 tly killed, use
7990: 2d 66 6f 72 63 65 20 74 6f 20 6c 61 75 6e 63 68 -force to launch
79a0: 20 69 74 2e 22 29 29 0a 09 09 20 20 20 20 20 20 it."))...
79b0: 28 28 4c 41 55 4e 43 48 45 44 20 52 45 4d 4f 54 ((LAUNCHED REMOT
79c0: 45 48 4f 53 54 53 54 41 52 54 20 52 55 4e 4e 49 EHOSTSTART RUNNI
79d0: 4e 47 29 20 20 0a 09 09 20 20 20 20 20 20 20 28 NG) ... (
79e0: 69 66 20 28 3e 20 28 2d 20 28 63 75 72 72 65 6e if (> (- (curren
79f0: 74 2d 73 65 63 6f 6e 64 73 29 28 2b 20 28 64 62 t-seconds)(+ (db
7a00: 3a 74 65 73 74 2d 67 65 74 2d 65 76 65 6e 74 5f :test-get-event_
7a10: 74 69 6d 65 20 74 65 73 74 64 61 74 29 0a 09 09 time testdat)...
7a20: 09 09 09 09 20 20 20 20 20 28 64 62 3a 74 65 73 .... (db:tes
7a30: 74 2d 67 65 74 2d 72 75 6e 5f 64 75 72 61 74 69 t-get-run_durati
7a40: 6f 6e 20 74 65 73 74 64 61 74 29 29 29 0a 09 09 on testdat)))...
7a50: 09 20 20 20 20 20 20 31 30 30 29 20 3b 3b 20 69 . 100) ;; i
7a60: 2e 65 2e 20 6e 6f 20 75 70 64 61 74 65 20 66 6f .e. no update fo
7a70: 72 20 6d 6f 72 65 20 74 68 61 6e 20 31 30 30 20 r more than 100
7a80: 73 65 63 6f 6e 64 73 0a 09 09 09 20 20 20 28 62 seconds.... (b
7a90: 65 67 69 6e 0a 09 09 09 20 20 20 20 20 28 64 65 egin.... (de
7aa0: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 bug:print 0 "WAR
7ab0: 4e 49 4e 47 3a 20 54 65 73 74 20 22 20 74 65 73 NING: Test " tes
7ac0: 74 2d 6e 61 6d 65 20 22 20 61 70 70 65 61 72 73 t-name " appears
7ad0: 20 74 6f 20 62 65 20 64 65 61 64 2e 20 46 6f 72 to be dead. For
7ae0: 63 69 6e 67 20 69 74 20 74 6f 20 73 74 61 74 65 cing it to state
7af0: 20 49 4e 43 4f 4d 50 4c 45 54 45 20 61 6e 64 20 INCOMPLETE and
7b00: 73 74 61 74 75 73 20 53 54 55 43 4b 2f 44 45 41 status STUCK/DEA
7b10: 44 22 29 0a 09 09 09 20 20 20 20 20 28 74 65 73 D").... (tes
7b20: 74 2d 73 65 74 2d 73 74 61 74 75 73 21 20 64 62 t-set-status! db
7b30: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
7b40: 65 20 22 49 4e 43 4f 4d 50 4c 45 54 45 22 20 22 e "INCOMPLETE" "
7b50: 53 54 55 43 4b 2f 44 45 41 44 22 20 69 74 65 6d STUCK/DEAD" item
7b60: 64 61 74 20 22 54 65 73 74 20 69 73 20 73 74 75 dat "Test is stu
7b70: 63 6b 20 6f 72 20 64 65 61 64 22 20 23 66 29 29 ck or dead" #f))
7b80: 0a 09 09 09 20 20 20 28 64 65 62 75 67 3a 70 72 .... (debug:pr
7b90: 69 6e 74 20 32 20 22 4e 4f 54 45 3a 20 22 20 74 int 2 "NOTE: " t
7ba0: 65 73 74 2d 6e 61 6d 65 20 22 20 69 73 20 61 6c est-name " is al
7bb0: 72 65 61 64 79 20 72 75 6e 6e 69 6e 67 22 29 29 ready running"))
7bc0: 29 0a 09 09 20 20 20 20 20 20 28 65 6c 73 65 20 )... (else
7bd0: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
7be0: 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 46 61 69 nt 0 "ERROR: Fai
7bf0: 6c 65 64 20 74 6f 20 6c 61 75 6e 63 68 20 74 65 led to launch te
7c00: 73 74 20 22 20 6e 65 77 2d 74 65 73 74 2d 6e 61 st " new-test-na
7c10: 6d 65 20 22 2e 20 55 6e 72 65 63 6f 67 6e 69 73 me ". Unrecognis
7c20: 65 64 20 73 74 61 74 65 20 22 20 28 74 65 73 74 ed state " (test
7c30: 3a 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 64 :get-state testd
7c40: 61 74 29 29 29 29 29 29 0a 09 20 20 20 20 20 20 at))))))..
7c50: 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 (if (not (null?
7c60: 74 61 6c 29 29 0a 09 09 20 20 28 6c 6f 6f 70 20 tal))... (loop
7c70: 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 (car tal)(cdr ta
7c80: 6c 29 29 29 29 29 29 29 29 29 0a 0a 28 64 65 66 l)))))))))..(def
7c90: 69 6e 65 20 28 72 75 6e 2d 77 61 69 74 69 6e 67 ine (run-waiting
7ca0: 2d 74 65 73 74 73 20 64 62 29 0a 20 20 28 6c 65 -tests db). (le
7cb0: 74 20 28 28 6e 75 6d 74 72 69 65 73 20 20 20 20 t ((numtries
7cc0: 20 20 20 20 20 20 20 30 29 0a 09 28 6c 61 73 74 0)..(last
7cd0: 2d 74 72 79 2d 74 69 6d 65 20 20 20 20 20 20 28 -try-time (
7ce0: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
7cf0: 29 0a 09 28 74 69 6d 65 73 20 20 20 20 20 20 20 )..(times
7d00: 20 20 20 20 20 20 20 28 6c 69 73 74 20 31 29 29 (list 1))
7d10: 29 20 3b 3b 20 6d 69 6e 75 74 65 73 20 74 6f 20 ) ;; minutes to
7d20: 77 61 69 74 20 62 65 66 6f 72 65 20 74 72 79 69 wait before tryi
7d30: 6e 67 20 61 67 61 69 6e 20 74 6f 20 6b 69 63 6b ng again to kick
7d40: 20 6f 66 66 20 72 75 6e 73 0a 20 20 20 20 3b 3b off runs. ;;
7d50: 20 42 55 47 20 74 68 69 73 20 68 61 63 6b 20 6f BUG this hack o
7d60: 66 20 62 72 75 74 65 20 66 6f 72 63 65 20 72 65 f brute force re
7d70: 74 72 79 69 6e 67 20 77 6f 72 6b 73 20 71 75 69 trying works qui
7d80: 74 65 20 77 65 6c 6c 20 66 6f 72 20 6d 61 6e 79 te well for many
7d90: 20 63 61 73 65 73 20 62 75 74 20 0a 20 20 20 20 cases but .
7da0: 3b 3b 20 20 20 20 20 77 68 61 74 20 69 73 20 6e ;; what is n
7db0: 65 65 64 65 64 20 69 73 20 74 6f 20 63 68 65 63 eeded is to chec
7dc0: 6b 20 74 68 65 20 64 62 20 66 6f 72 20 74 65 73 k the db for tes
7dd0: 74 73 20 74 68 61 74 20 68 61 76 65 20 66 61 69 ts that have fai
7de0: 6c 65 64 20 6c 65 73 73 20 74 68 61 6e 0a 20 20 led less than.
7df0: 20 20 3b 3b 20 20 20 20 20 4e 20 74 69 6d 65 73 ;; N times
7e00: 20 6f 72 20 6e 65 76 65 72 20 62 65 65 6e 20 73 or never been s
7e10: 74 61 72 74 65 64 20 61 6e 64 20 6b 69 63 6b 20 tarted and kick
7e20: 74 68 65 6d 20 6f 66 66 20 61 67 61 69 6e 0a 20 them off again.
7e30: 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 77 (let loop ((w
7e40: 61 69 74 69 6e 67 2d 74 65 73 74 2d 6e 61 6d 65 aiting-test-name
7e50: 73 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 s (hash-table-ke
7e60: 79 73 20 2a 77 61 69 74 69 6e 67 2d 71 75 65 75 ys *waiting-queu
7e70: 65 2a 29 29 29 0a 20 20 20 20 20 20 28 63 6f 6e e*))). (con
7e80: 64 0a 20 20 20 20 20 20 20 28 28 6e 6f 74 20 28 d. ((not (
7e90: 72 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 runs:can-run-mor
7ea0: 65 2d 74 65 73 74 73 20 64 62 29 29 0a 09 28 73 e-tests db))..(s
7eb0: 6c 65 65 70 20 32 29 0a 09 28 6c 6f 6f 70 20 77 leep 2)..(loop w
7ec0: 61 69 74 69 6e 67 2d 74 65 73 74 2d 6e 61 6d 65 aiting-test-name
7ed0: 73 29 29 0a 20 20 20 20 20 20 20 28 28 6e 75 6c s)). ((nul
7ee0: 6c 3f 20 77 61 69 74 69 6e 67 2d 74 65 73 74 2d l? waiting-test-
7ef0: 6e 61 6d 65 73 29 0a 09 28 64 65 62 75 67 3a 70 names)..(debug:p
7f00: 72 69 6e 74 20 31 20 22 41 6c 6c 20 74 65 73 74 rint 1 "All test
7f10: 73 20 6c 61 75 6e 63 68 65 64 22 29 29 0a 20 20 s launched")).
7f20: 20 20 20 20 20 28 65 6c 73 65 0a 09 28 73 65 74 (else..(set
7f30: 21 20 6e 75 6d 74 72 69 65 73 20 28 2b 20 6e 75 ! numtries (+ nu
7f40: 6d 74 72 69 65 73 20 31 29 29 0a 09 28 66 6f 72 mtries 1))..(for
7f50: 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 74 -each (lambda (t
7f60: 65 73 74 6e 61 6d 65 29 0a 09 09 20 20 20 20 28 estname)... (
7f70: 69 66 20 28 72 75 6e 73 3a 63 61 6e 2d 72 75 6e if (runs:can-run
7f80: 2d 6d 6f 72 65 2d 74 65 73 74 73 20 64 62 29 0a -more-tests db).
7f90: 09 09 09 28 6c 65 74 2a 20 28 28 74 65 73 74 64 ...(let* ((testd
7fa0: 61 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 at (hash-table-r
7fb0: 65 66 20 2a 77 61 69 74 69 6e 67 2d 71 75 65 75 ef *waiting-queu
7fc0: 65 2a 20 74 65 73 74 6e 61 6d 65 29 29 0a 09 09 e* testname))...
7fd0: 09 20 20 20 20 20 20 20 28 70 72 65 72 65 71 73 . (prereqs
7fe0: 20 28 28 63 61 72 20 74 65 73 74 64 61 74 29 29 ((car testdat))
7ff0: 29 0a 09 09 09 20 20 20 20 20 20 20 28 6c 64 62 ).... (ldb
8000: 20 20 20 20 20 28 69 66 20 64 62 20 64 62 20 28 (if db db (
8010: 6f 70 65 6e 2d 64 62 29 29 29 29 0a 09 09 09 20 open-db))))....
8020: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 (debug:print 2
8030: 22 70 72 65 72 65 71 73 20 72 65 6d 61 69 6e 69 "prereqs remaini
8040: 6e 67 3a 20 22 20 70 72 65 72 65 71 73 29 0a 09 ng: " prereqs)..
8050: 09 09 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 70 .. (if (null? p
8060: 72 65 72 65 71 73 29 0a 09 09 09 20 20 20 20 20 rereqs)....
8070: 20 28 62 65 67 69 6e 0a 09 09 09 09 28 64 65 62 (begin.....(deb
8080: 75 67 3a 70 72 69 6e 74 20 32 20 22 50 72 65 72 ug:print 2 "Prer
8090: 65 71 75 69 73 69 74 65 73 20 6d 65 74 2c 20 6c equisites met, l
80a0: 61 75 6e 63 68 69 6e 67 20 22 20 74 65 73 74 6e aunching " testn
80b0: 61 6d 65 29 0a 09 09 09 09 28 28 63 61 64 72 20 ame).....((cadr
80c0: 74 65 73 74 64 61 74 29 29 0a 09 09 09 09 28 68 testdat)).....(h
80d0: 61 73 68 2d 74 61 62 6c 65 2d 64 65 6c 65 74 65 ash-table-delete
80e0: 21 20 2a 77 61 69 74 69 6e 67 2d 71 75 65 75 65 ! *waiting-queue
80f0: 2a 20 74 65 73 74 6e 61 6d 65 29 29 29 0a 09 09 * testname)))...
8100: 09 20 20 28 69 66 20 28 6e 6f 74 20 64 62 29 0a . (if (not db).
8110: 09 09 09 20 20 20 20 20 20 28 73 71 6c 69 74 65 ... (sqlite
8120: 33 3a 66 69 6e 61 6c 69 7a 65 21 20 6c 64 62 29 3:finalize! ldb)
8130: 29 29 29 29 0a 09 09 20 20 77 61 69 74 69 6e 67 ))))... waiting
8140: 2d 74 65 73 74 2d 6e 61 6d 65 73 29 0a 09 3b 3b -test-names)..;;
8150: 20 28 73 6c 65 65 70 20 31 30 29 20 3b 3b 20 6e (sleep 10) ;; n
8160: 6f 20 70 6f 69 6e 74 20 69 6e 20 72 75 73 68 69 o point in rushi
8170: 6e 67 20 74 68 69 6e 67 73 20 61 74 20 74 68 69 ng things at thi
8180: 73 20 73 74 61 67 65 3f 0a 09 28 6c 6f 6f 70 20 s stage?..(loop
8190: 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 (hash-table-keys
81a0: 20 2a 77 61 69 74 69 6e 67 2d 71 75 65 75 65 2a *waiting-queue*
81b0: 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 )))))))..(define
81c0: 20 28 67 65 74 2d 64 69 72 2d 75 70 2d 6e 20 64 (get-dir-up-n d
81d0: 69 72 20 2e 20 70 61 72 61 6d 73 29 20 0a 20 20 ir . params) .
81e0: 28 6c 65 74 20 28 28 64 70 61 72 74 73 20 20 28 (let ((dparts (
81f0: 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 64 69 72 string-split dir
8200: 20 22 2f 22 29 29 0a 09 28 63 6f 75 6e 74 20 20 "/"))..(count
8210: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 70 61 72 61 (if (null? para
8220: 6d 73 29 20 31 20 28 63 61 72 20 70 61 72 61 6d ms) 1 (car param
8230: 73 29 29 29 29 0a 20 20 20 20 28 63 6f 6e 63 20 s)))). (conc
8240: 22 2f 22 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 "/" (string-inte
8250: 72 73 70 65 72 73 65 20 0a 09 20 20 20 20 20 20 rsperse ..
8260: 20 28 74 61 6b 65 20 64 70 61 72 74 73 20 28 2d (take dparts (-
8270: 20 28 6c 65 6e 67 74 68 20 64 70 61 72 74 73 29 (length dparts)
8280: 20 63 6f 75 6e 74 29 29 0a 09 20 20 20 20 20 20 count))..
8290: 20 22 2f 22 29 29 29 29 0a 3b 3b 20 52 65 6d 6f "/")))).;; Remo
82a0: 76 65 20 72 75 6e 73 0a 3b 3b 20 66 69 65 6c 64 ve runs.;; field
82b0: 73 20 61 72 65 20 70 61 73 73 69 6e 67 20 69 6e s are passing in
82c0: 20 74 68 72 6f 75 67 68 20 0a 28 64 65 66 69 6e through .(defin
82d0: 65 20 28 72 75 6e 73 3a 72 65 6d 6f 76 65 2d 72 e (runs:remove-r
82e0: 75 6e 73 20 64 62 20 72 75 6e 6e 61 6d 65 70 61 uns db runnamepa
82f0: 74 74 20 74 65 73 74 70 61 74 74 20 69 74 65 6d tt testpatt item
8300: 70 61 74 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 patt). (let* ((
8310: 6b 65 79 73 20 20 20 20 20 20 20 20 28 64 62 2d keys (db-
8320: 67 65 74 2d 6b 65 79 73 20 64 62 29 29 0a 09 20 get-keys db))..
8330: 28 72 75 6e 64 61 74 20 20 20 20 20 20 28 72 75 (rundat (ru
8340: 6e 73 3a 67 65 74 2d 72 75 6e 73 2d 62 79 2d 70 ns:get-runs-by-p
8350: 61 74 74 20 64 62 20 6b 65 79 73 20 72 75 6e 6e att db keys runn
8360: 61 6d 65 70 61 74 74 29 29 0a 09 20 28 68 65 61 amepatt)).. (hea
8370: 64 65 72 20 20 20 20 20 20 28 76 65 63 74 6f 72 der (vector
8380: 2d 72 65 66 20 72 75 6e 64 61 74 20 30 29 29 0a -ref rundat 0)).
8390: 09 20 28 72 75 6e 73 20 20 20 20 20 20 20 20 28 . (runs (
83a0: 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 64 61 vector-ref runda
83b0: 74 20 31 29 29 29 0a 20 20 20 20 28 64 65 62 75 t 1))). (debu
83c0: 67 3a 70 72 69 6e 74 20 31 20 22 48 65 61 64 65 g:print 1 "Heade
83d0: 72 3a 20 22 20 68 65 61 64 65 72 29 0a 20 20 20 r: " header).
83e0: 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 (for-each.
83f0: 28 6c 61 6d 62 64 61 20 28 72 75 6e 29 0a 20 20 (lambda (run).
8400: 20 20 20 20 20 28 6c 65 74 20 28 28 72 75 6e 6b (let ((runk
8410: 65 79 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 ey (string-inter
8420: 73 70 65 72 73 65 20 28 6d 61 70 20 28 6c 61 6d sperse (map (lam
8430: 62 64 61 20 28 6b 29 0a 09 09 09 09 09 09 28 64 bda (k).......(d
8440: 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 b:get-value-by-h
8450: 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 eader run header
8460: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 6b 20 30 (vector-ref k 0
8470: 29 29 29 20 6b 65 79 73 29 20 22 2f 22 29 29 0a ))) keys) "/")).
8480: 09 20 20 20 20 20 28 64 69 72 73 2d 74 6f 2d 72 . (dirs-to-r
8490: 65 6d 6f 76 65 20 28 6d 61 6b 65 2d 68 61 73 68 emove (make-hash
84a0: 2d 74 61 62 6c 65 29 29 29 0a 09 20 28 6c 65 74 -table))).. (let
84b0: 2a 20 28 28 72 75 6e 2d 69 64 20 28 64 62 3a 67 * ((run-id (db:g
84c0: 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 et-value-by-head
84d0: 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 69 er run header "i
84e0: 64 22 29 20 29 0a 09 09 28 74 65 73 74 73 20 20 d") )...(tests
84f0: 28 64 62 2d 67 65 74 2d 74 65 73 74 73 2d 66 6f (db-get-tests-fo
8500: 72 2d 72 75 6e 20 64 62 20 28 64 62 3a 67 65 74 r-run db (db:get
8510: 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 -value-by-header
8520: 20 72 75 6e 20 68 65 61 64 65 72 20 22 69 64 22 run header "id"
8530: 29 20 74 65 73 74 70 61 74 74 20 69 74 65 6d 70 ) testpatt itemp
8540: 61 74 74 20 23 66 20 23 66 29 29 0a 09 09 28 6c att #f #f))...(l
8550: 61 73 74 74 70 61 74 68 20 22 2f 64 6f 65 73 2f asttpath "/does/
8560: 6e 6f 74 2f 65 78 69 73 74 2f 49 2f 68 6f 70 65 not/exist/I/hope
8570: 22 29 29 0a 0a 09 20 20 20 28 69 66 20 28 6e 6f "))... (if (no
8580: 74 20 28 6e 75 6c 6c 3f 20 74 65 73 74 73 29 29 t (null? tests))
8590: 0a 09 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a .. (begin.
85a0: 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 .. (debug:print
85b0: 31 20 22 52 65 6d 6f 76 69 6e 67 20 74 65 73 74 1 "Removing test
85c0: 73 20 66 6f 72 20 72 75 6e 3a 20 22 20 72 75 6e s for run: " run
85d0: 6b 65 79 20 22 20 22 20 28 64 62 3a 67 65 74 2d key " " (db:get-
85e0: 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 value-by-header
85f0: 72 75 6e 20 68 65 61 64 65 72 20 22 72 75 6e 6e run header "runn
8600: 61 6d 65 22 29 29 0a 09 09 20 28 66 6f 72 2d 65 ame"))... (for-e
8610: 61 63 68 0a 09 09 20 20 28 6c 61 6d 62 64 61 20 ach... (lambda
8620: 28 74 65 73 74 29 0a 09 09 20 20 20 20 28 6c 65 (test)... (le
8630: 74 2a 20 28 28 69 74 65 6d 2d 70 61 74 68 20 28 t* ((item-path (
8640: 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 6d db:test-get-item
8650: 2d 70 61 74 68 20 74 65 73 74 29 29 0a 09 09 09 -path test))....
8660: 20 20 20 28 74 65 73 74 2d 6e 61 6d 65 20 28 64 (test-name (d
8670: 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e b:test-get-testn
8680: 61 6d 65 20 74 65 73 74 29 29 0a 09 09 09 20 20 ame test))....
8690: 20 28 72 75 6e 2d 64 69 72 20 20 20 28 64 62 3a (run-dir (db:
86a0: 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 20 test-get-rundir
86b0: 74 65 73 74 29 29 29 0a 09 09 20 20 20 20 20 20 test)))...
86c0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 (debug:print 1 "
86d0: 20 20 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 " (db:test-get
86e0: 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 29 20 -testname test)
86f0: 22 20 69 64 3a 20 22 20 28 64 62 3a 74 65 73 74 " id: " (db:test
8700: 2d 67 65 74 2d 69 64 20 74 65 73 74 29 20 22 20 -get-id test) "
8710: 22 20 69 74 65 6d 2d 70 61 74 68 29 0a 09 09 20 " item-path)...
8720: 20 20 20 20 20 28 64 62 3a 64 65 6c 65 74 65 2d (db:delete-
8730: 74 65 73 74 2d 72 65 63 6f 72 64 73 20 64 62 20 test-records db
8740: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 (db:test-get-id
8750: 74 65 73 74 29 29 0a 09 09 20 20 20 20 20 20 28 test))... (
8760: 69 66 20 28 3e 20 28 73 74 72 69 6e 67 2d 6c 65 if (> (string-le
8770: 6e 67 74 68 20 72 75 6e 2d 64 69 72 29 20 35 29 ngth run-dir) 5)
8780: 20 3b 3b 20 62 61 64 20 68 65 75 72 69 73 74 69 ;; bad heuristi
8790: 63 20 62 75 74 20 73 68 6f 75 6c 64 20 70 72 65 c but should pre
87a0: 76 65 6e 74 20 2f 74 6d 70 20 2f 68 6f 6d 65 20 vent /tmp /home
87b0: 65 74 63 2e 0a 09 09 09 20 20 28 6c 65 74 20 28 etc..... (let (
87c0: 28 66 75 6c 6c 70 61 74 68 20 72 75 6e 2d 64 69 (fullpath run-di
87d0: 72 29 29 20 3b 3b 20 22 2f 22 20 28 64 62 3a 74 r)) ;; "/" (db:t
87e0: 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 est-get-item-pat
87f0: 68 20 74 65 73 74 29 29 29 29 0a 09 09 09 20 20 h test))))....
8800: 20 20 28 73 65 74 21 20 6c 61 73 74 74 70 61 74 (set! lasttpat
8810: 68 20 66 75 6c 6c 70 61 74 68 29 0a 09 09 09 20 h fullpath)....
8820: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 (hash-table-s
8830: 65 74 21 20 64 69 72 73 2d 74 6f 2d 72 65 6d 6f et! dirs-to-remo
8840: 76 65 20 66 75 6c 6c 70 61 74 68 20 23 74 29 0a ve fullpath #t).
8850: 09 09 09 20 20 20 20 3b 3b 20 54 68 65 20 66 6f ... ;; The fo
8860: 6c 6c 6f 77 69 6e 67 20 77 61 73 20 74 68 65 20 llowing was the
8870: 73 61 66 65 20 64 65 6c 65 74 65 20 63 6f 64 65 safe delete code
8880: 20 62 75 74 20 69 74 20 77 61 73 20 6e 6f 74 20 but it was not
8890: 62 65 69 6e 67 20 65 78 65 63 74 75 74 65 64 2e being exectuted.
88a0: 0a 09 09 09 20 20 20 20 3b 3b 20 28 6c 65 74 2a .... ;; (let*
88b0: 20 28 28 64 69 72 73 2d 63 6f 75 6e 74 20 28 2b ((dirs-count (+
88c0: 20 31 20 28 6c 65 6e 67 74 68 20 6b 65 79 73 29 1 (length keys)
88d0: 28 6c 65 6e 67 74 68 20 28 73 74 72 69 6e 67 2d (length (string-
88e0: 73 70 6c 69 74 20 69 74 65 6d 2d 70 61 74 68 20 split item-path
88f0: 22 2f 22 29 29 29 29 0a 09 09 09 20 20 20 20 3b "/")))).... ;
8900: 3b 20 20 20 20 20 20 20 20 28 64 69 72 2d 74 6f ; (dir-to
8910: 2d 72 65 6d 20 28 67 65 74 2d 64 69 72 2d 75 70 -rem (get-dir-up
8920: 2d 6e 20 66 75 6c 6c 70 61 74 68 20 64 69 72 73 -n fullpath dirs
8930: 2d 63 6f 75 6e 74 29 29 0a 09 09 09 20 20 20 20 -count))....
8940: 3b 3b 20 20 20 20 20 20 20 20 28 72 65 6d 61 69 ;; (remai
8950: 6e 69 6e 67 64 20 28 73 74 72 69 6e 67 2d 73 75 ningd (string-su
8960: 62 73 74 69 74 75 74 65 20 28 72 65 67 65 78 70 bstitute (regexp
8970: 20 28 63 6f 6e 63 20 22 5e 22 20 64 69 72 2d 74 (conc "^" dir-t
8980: 6f 2d 72 65 6d 20 22 2f 22 29 29 20 22 22 20 66 o-rem "/")) "" f
8990: 75 6c 6c 70 61 74 68 29 29 0a 09 09 09 20 20 20 ullpath))....
89a0: 20 3b 3b 20 20 20 20 20 20 20 20 28 63 6d 64 20 ;; (cmd
89b0: 28 63 6f 6e 63 20 22 63 64 20 22 20 64 69 72 2d (conc "cd " dir-
89c0: 74 6f 2d 72 65 6d 20 22 3b 20 72 6d 64 69 72 20 to-rem "; rmdir
89d0: 2d 70 20 22 20 72 65 6d 61 69 6e 69 6e 67 64 20 -p " remainingd
89e0: 29 29 29 0a 09 09 09 20 20 20 20 3b 3b 20 20 20 ))).... ;;
89f0: 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 (if (file-exists
8a00: 3f 20 66 75 6c 6c 70 61 74 68 29 0a 09 09 09 20 ? fullpath)....
8a10: 20 20 20 3b 3b 20 20 20 20 20 20 20 28 62 65 67 ;; (beg
8a20: 69 6e 0a 09 09 09 20 20 20 20 3b 3b 20 20 20 20 in.... ;;
8a30: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
8a40: 74 20 31 20 63 6d 64 29 0a 09 09 09 20 20 20 20 t 1 cmd)....
8a50: 3b 3b 20 20 20 20 20 20 20 20 20 28 73 79 73 74 ;; (syst
8a60: 65 6d 20 63 6d 64 29 29 29 0a 09 09 09 20 20 20 em cmd)))....
8a70: 20 3b 3b 20 20 20 29 29 0a 09 09 09 20 20 20 20 ;; ))....
8a80: 29 29 29 29 0a 09 09 20 20 20 20 74 65 73 74 73 ))))... tests
8a90: 29 29 29 0a 0a 09 20 20 20 3b 3b 20 6c 6f 6f 6b )))... ;; look
8aa0: 20 74 68 6f 75 67 68 20 74 68 65 20 64 69 72 73 though the dirs
8ab0: 2d 74 6f 2d 72 65 6d 6f 76 65 20 66 6f 72 20 63 -to-remove for c
8ac0: 61 6e 64 69 64 61 74 65 73 20 66 6f 72 20 72 65 andidates for re
8ad0: 6d 6f 76 61 6c 2e 20 44 6f 20 74 68 69 73 20 61 moval. Do this a
8ae0: 66 74 65 72 20 64 65 6c 65 74 69 6e 67 20 74 68 fter deleting th
8af0: 65 20 72 65 63 6f 72 64 73 0a 09 20 20 20 3b 3b e records.. ;;
8b00: 20 66 6f 72 20 65 61 63 68 20 74 65 73 74 20 69 for each test i
8b10: 6e 20 63 61 73 65 20 77 65 20 67 65 74 20 6b 69 n case we get ki
8b20: 6c 6c 65 64 2e 20 54 68 61 74 20 73 68 6f 75 6c lled. That shoul
8b30: 64 20 6d 69 6e 69 6d 69 7a 65 20 74 68 65 20 64 d minimize the d
8b40: 65 74 72 69 74 75 73 20 6c 65 66 74 20 6f 6e 20 etritus left on
8b50: 64 69 73 6b 0a 09 20 20 20 3b 3b 20 70 72 6f 63 disk.. ;; proc
8b60: 65 73 73 20 74 68 65 20 64 69 72 73 20 66 72 6f ess the dirs fro
8b70: 6d 20 6c 6f 6e 67 65 73 74 20 73 74 72 69 6e 67 m longest string
8b80: 20 6c 65 6e 67 74 68 20 74 6f 20 73 68 6f 72 74 length to short
8b90: 65 73 74 0a 09 20 20 20 28 66 6f 72 2d 65 61 63 est.. (for-eac
8ba0: 68 20 0a 09 20 20 20 20 28 6c 61 6d 62 64 61 20 h .. (lambda
8bb0: 28 64 69 72 2d 74 6f 2d 72 65 6d 6f 76 65 29 0a (dir-to-remove).
8bc0: 09 20 20 20 20 20 20 28 69 66 20 28 66 69 6c 65 . (if (file
8bd0: 2d 65 78 69 73 74 73 3f 20 64 69 72 2d 74 6f 2d -exists? dir-to-
8be0: 72 65 6d 6f 76 65 29 0a 09 09 20 20 28 6c 65 74 remove)... (let
8bf0: 20 28 28 64 69 72 2d 69 6e 2d 64 62 20 27 28 29 ((dir-in-db '()
8c00: 29 29 0a 09 09 20 20 20 20 28 73 71 6c 69 74 65 ))... (sqlite
8c10: 33 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 0a 09 3:for-each-row..
8c20: 09 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 64 . (lambda (d
8c30: 69 72 29 0a 09 09 20 20 20 20 20 20 20 28 73 65 ir)... (se
8c40: 74 21 20 64 69 72 2d 69 6e 2d 64 62 20 28 63 6f t! dir-in-db (co
8c50: 6e 73 20 64 69 72 20 64 69 72 2d 69 6e 2d 64 62 ns dir dir-in-db
8c60: 29 29 29 0a 09 09 20 20 20 20 20 64 62 20 22 53 )))... db "S
8c70: 45 4c 45 43 54 20 72 75 6e 64 69 72 20 46 52 4f ELECT rundir FRO
8c80: 4d 20 74 65 73 74 73 20 57 48 45 52 45 20 72 75 M tests WHERE ru
8c90: 6e 64 69 72 20 4c 49 4b 45 20 3f 3b 22 20 0a 09 ndir LIKE ?;" ..
8ca0: 09 20 20 20 20 20 28 63 6f 6e 63 20 22 25 22 20 . (conc "%"
8cb0: 64 69 72 2d 74 6f 2d 72 65 6d 6f 76 65 20 22 25 dir-to-remove "%
8cc0: 22 29 29 20 3b 3b 20 79 65 73 2c 20 49 27 6d 20 ")) ;; yes, I'm
8cd0: 67 6f 69 6e 67 20 74 6f 20 62 61 69 6c 20 69 66 going to bail if
8ce0: 20 74 68 65 72 65 20 69 73 20 61 6e 79 74 68 69 there is anythi
8cf0: 6e 67 20 6c 69 6b 65 20 74 68 69 73 20 64 69 72 ng like this dir
8d00: 20 69 6e 20 74 68 65 20 64 62 0a 09 09 20 20 20 in the db...
8d10: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 64 69 72 2d (if (null? dir-
8d20: 69 6e 2d 64 62 29 0a 09 09 09 28 62 65 67 69 6e in-db)....(begin
8d30: 0a 09 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 .... (debug:pri
8d40: 6e 74 20 32 20 22 52 65 6d 6f 76 69 6e 67 20 64 nt 2 "Removing d
8d50: 69 72 65 63 74 6f 72 79 20 77 69 74 68 20 7a 65 irectory with ze
8d60: 72 6f 20 64 62 20 72 65 66 65 72 65 6e 63 65 73 ro db references
8d70: 3a 20 22 20 64 69 72 2d 74 6f 2d 72 65 6d 6f 76 : " dir-to-remov
8d80: 65 29 0a 09 09 09 20 20 28 73 79 73 74 65 6d 20 e).... (system
8d90: 28 63 6f 6e 63 20 22 72 6d 20 2d 72 66 20 22 20 (conc "rm -rf "
8da0: 64 69 72 2d 74 6f 2d 72 65 6d 6f 76 65 29 29 0a dir-to-remove)).
8db0: 09 09 09 20 20 28 68 61 73 68 2d 74 61 62 6c 65 ... (hash-table
8dc0: 2d 64 65 6c 65 74 65 21 20 64 69 72 73 2d 74 6f -delete! dirs-to
8dd0: 2d 72 65 6d 6f 76 65 20 64 69 72 2d 74 6f 2d 72 -remove dir-to-r
8de0: 65 6d 6f 76 65 29 29 0a 09 09 09 28 64 65 62 75 emove))....(debu
8df0: 67 3a 70 72 69 6e 74 20 32 20 22 53 6b 69 70 70 g:print 2 "Skipp
8e00: 69 6e 67 20 72 65 6d 6f 76 61 6c 20 6f 66 20 22 ing removal of "
8e10: 20 64 69 72 2d 74 6f 2d 72 65 6d 6f 76 65 20 22 dir-to-remove "
8e20: 20 66 6f 72 20 6e 6f 77 20 61 73 20 69 74 20 73 for now as it s
8e30: 74 69 6c 6c 20 68 61 73 20 72 65 66 65 72 65 6e till has referen
8e40: 63 65 73 20 69 6e 20 74 68 65 20 64 61 74 61 62 ces in the datab
8e50: 61 73 65 22 29 29 29 29 29 0a 09 20 20 20 20 28 ase"))))).. (
8e60: 73 6f 72 74 20 28 68 61 73 68 2d 74 61 62 6c 65 sort (hash-table
8e70: 2d 6b 65 79 73 20 64 69 72 73 2d 74 6f 2d 72 65 -keys dirs-to-re
8e80: 6d 6f 76 65 29 20 28 6c 61 6d 62 64 61 20 28 61 move) (lambda (a
8e90: 20 62 29 28 3e 20 28 73 74 72 69 6e 67 2d 6c 65 b)(> (string-le
8ea0: 6e 67 74 68 20 61 29 28 73 74 72 69 6e 67 2d 6c ngth a)(string-l
8eb0: 65 6e 67 74 68 20 62 29 29 29 29 29 0a 0a 09 20 ength b)))))...
8ec0: 20 20 3b 3b 20 72 65 6d 6f 76 65 20 74 68 65 20 ;; remove the
8ed0: 72 75 6e 20 69 66 20 7a 65 72 6f 20 74 65 73 74 run if zero test
8ee0: 73 20 72 65 6d 61 69 6e 0a 09 20 20 20 28 6c 65 s remain.. (le
8ef0: 74 20 28 28 72 65 6d 74 65 73 74 73 20 28 64 62 t ((remtests (db
8f00: 2d 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 -get-tests-for-r
8f10: 75 6e 20 64 62 20 28 64 62 3a 67 65 74 2d 76 61 un db (db:get-va
8f20: 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 lue-by-header ru
8f30: 6e 20 68 65 61 64 65 72 20 22 69 64 22 29 20 23 n header "id") #
8f40: 66 20 23 66 20 23 66 20 23 66 29 29 29 0a 09 20 f #f #f #f)))..
8f50: 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 72 (if (null? r
8f60: 65 6d 74 65 73 74 73 29 20 3b 3b 20 6e 6f 20 6d emtests) ;; no m
8f70: 6f 72 65 20 74 65 73 74 73 20 72 65 6d 61 69 6e ore tests remain
8f80: 69 6e 67 0a 09 09 20 28 6c 65 74 2a 20 28 28 64 ing... (let* ((d
8f90: 70 61 72 74 73 20 20 28 73 74 72 69 6e 67 2d 73 parts (string-s
8fa0: 70 6c 69 74 20 6c 61 73 74 74 70 61 74 68 20 22 plit lasttpath "
8fb0: 2f 22 29 29 0a 09 09 09 28 72 75 6e 70 61 74 68 /"))....(runpath
8fc0: 20 28 63 6f 6e 63 20 22 2f 22 20 28 73 74 72 69 (conc "/" (stri
8fd0: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 0a ng-intersperse .
8fe0: 09 09 09 09 09 20 20 20 20 28 74 61 6b 65 20 64 ..... (take d
8ff0: 70 61 72 74 73 20 28 2d 20 28 6c 65 6e 67 74 68 parts (- (length
9000: 20 64 70 61 72 74 73 29 20 31 29 29 0a 09 09 09 dparts) 1))....
9010: 09 09 20 20 20 20 22 2f 22 29 29 29 29 0a 09 09 .. "/"))))...
9020: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
9030: 31 20 22 52 65 6d 6f 76 69 6e 67 20 72 75 6e 3a 1 "Removing run:
9040: 20 22 20 72 75 6e 6b 65 79 20 22 20 22 20 28 64 " runkey " " (d
9050: 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 b:get-value-by-h
9060: 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 eader run header
9070: 20 22 72 75 6e 6e 61 6d 65 22 29 29 0a 09 09 20 "runname"))...
9080: 20 20 28 64 62 3a 64 65 6c 65 74 65 2d 72 75 6e (db:delete-run
9090: 20 64 62 20 72 75 6e 2d 69 64 29 0a 09 09 20 20 db run-id)...
90a0: 20 3b 3b 20 6e 65 65 64 20 74 6f 20 66 69 67 75 ;; need to figu
90b0: 72 65 20 6f 75 74 20 74 68 65 20 70 61 74 68 20 re out the path
90c0: 74 6f 20 74 68 65 20 72 75 6e 20 64 69 72 20 61 to the run dir a
90d0: 6e 64 20 72 65 6d 6f 76 65 20 69 74 20 69 66 20 nd remove it if
90e0: 65 6d 70 74 79 0a 09 09 20 20 20 3b 3b 20 20 20 empty... ;;
90f0: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 28 67 6c 6f (if (null? (glo
9100: 62 20 28 63 6f 6e 63 20 72 75 6e 70 61 74 68 20 b (conc runpath
9110: 22 2f 2a 22 29 29 29 0a 09 09 20 20 20 3b 3b 20 "/*")))... ;;
9120: 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 (begin...
9130: 20 20 20 3b 3b 20 09 20 28 64 65 62 75 67 3a 70 ;; . (debug:p
9140: 72 69 6e 74 20 31 20 22 52 65 6d 6f 76 69 6e 67 rint 1 "Removing
9150: 20 72 75 6e 20 64 69 72 20 22 20 72 75 6e 70 61 run dir " runpa
9160: 74 68 29 0a 09 09 20 20 20 3b 3b 20 09 20 28 73 th)... ;; . (s
9170: 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 72 6d 64 ystem (conc "rmd
9180: 69 72 20 2d 70 20 22 20 72 75 6e 70 61 74 68 29 ir -p " runpath)
9190: 29 29 29 0a 09 09 20 20 20 29 29 29 29 0a 09 20 )))... ))))..
91a0: 29 29 0a 20 20 20 20 20 72 75 6e 73 29 29 29 0a )). runs))).
91b0: 0a 3b 3b 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 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
91e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
91f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 52 6f 75 =========.;; Rou
9200: 74 69 6e 65 73 20 66 6f 72 20 6d 61 6e 69 70 75 tines for manipu
9210: 6c 61 74 69 6e 67 20 72 75 6e 73 0a 3b 3b 3d 3d lating runs.;;==
9220: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9230: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9240: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9250: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9260: 3d 3d 3d 3d 0a 0a 3b 3b 20 53 69 6e 63 65 20 6d ====..;; Since m
9270: 61 6e 79 20 63 61 6c 6c 73 20 74 6f 20 61 20 72 any calls to a r
9280: 75 6e 20 72 65 71 75 69 72 65 20 70 72 65 74 74 un require prett
9290: 79 20 6d 75 63 68 20 74 68 65 20 73 61 6d 65 20 y much the same
92a0: 73 65 74 75 70 20 0a 3b 3b 20 74 68 69 73 20 77 setup .;; this w
92b0: 72 61 70 70 65 72 20 69 73 20 75 73 65 64 20 74 rapper is used t
92c0: 6f 20 72 65 64 75 63 65 20 74 68 65 20 72 65 70 o reduce the rep
92d0: 6c 69 63 61 74 69 6f 6e 20 6f 66 20 63 6f 64 65 lication of code
92e0: 0a 28 64 65 66 69 6e 65 20 28 67 65 6e 65 72 61 .(define (genera
92f0: 6c 2d 72 75 6e 2d 63 61 6c 6c 20 73 77 69 74 63 l-run-call switc
9300: 68 6e 61 6d 65 20 61 63 74 69 6f 6e 2d 64 65 73 hname action-des
9310: 63 20 70 72 6f 63 29 0a 20 20 28 69 66 20 28 6e c proc). (if (n
9320: 6f 74 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 ot (args:get-arg
9330: 20 22 3a 72 75 6e 6e 61 6d 65 22 29 29 0a 20 20 ":runname")).
9340: 20 20 20 20 28 62 65 67 69 6e 0a 09 28 64 65 62 (begin..(deb
9350: 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO
9360: 52 3a 20 4d 69 73 73 69 6e 67 20 72 65 71 75 69 R: Missing requi
9370: 72 65 64 20 70 61 72 61 6d 65 74 65 72 20 66 6f red parameter fo
9380: 72 20 22 20 73 77 69 74 63 68 6e 61 6d 65 20 22 r " switchname "
9390: 2c 20 79 6f 75 20 6d 75 73 74 20 73 70 65 63 69 , you must speci
93a0: 66 79 20 74 68 65 20 72 75 6e 20 6e 61 6d 65 20 fy the run name
93b0: 77 69 74 68 20 3a 72 75 6e 6e 61 6d 65 20 72 75 with :runname ru
93c0: 6e 6e 61 6d 65 22 29 0a 09 28 65 78 69 74 20 32 nname")..(exit 2
93d0: 29 29 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 )). (let ((
93e0: 64 62 20 23 66 29 29 0a 09 28 69 66 20 28 6e 6f db #f))..(if (no
93f0: 74 20 28 73 65 74 75 70 2d 66 6f 72 2d 72 75 6e t (setup-for-run
9400: 29 29 0a 09 20 20 20 20 28 62 65 67 69 6e 20 0a )).. (begin .
9410: 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
9420: 69 6e 74 20 30 20 22 46 61 69 6c 65 64 20 74 6f int 0 "Failed to
9430: 20 73 65 74 75 70 2c 20 65 78 69 74 69 6e 67 22 setup, exiting"
9440: 29 0a 09 20 20 20 20 20 20 28 65 78 69 74 20 31 ).. (exit 1
9450: 29 29 29 0a 09 28 73 65 74 21 20 64 62 20 28 6f )))..(set! db (o
9460: 70 65 6e 2d 64 62 29 29 0a 09 28 69 66 20 28 6e pen-db))..(if (n
9470: 6f 74 20 28 63 61 72 20 2a 63 6f 6e 66 69 67 69 ot (car *configi
9480: 6e 66 6f 2a 29 29 0a 09 20 20 20 20 28 62 65 67 nfo*)).. (beg
9490: 69 6e 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 in.. (debug
94a0: 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a :print 0 "ERROR:
94b0: 20 41 74 74 65 6d 70 74 65 64 20 74 6f 20 22 20 Attempted to "
94c0: 61 63 74 69 6f 6e 2d 64 65 73 63 20 22 20 62 75 action-desc " bu
94d0: 74 20 72 75 6e 20 61 72 65 61 20 63 6f 6e 66 69 t run area confi
94e0: 67 20 66 69 6c 65 20 6e 6f 74 20 66 6f 75 6e 64 g file not found
94f0: 22 29 0a 09 20 20 20 20 20 20 28 65 78 69 74 20 ").. (exit
9500: 31 29 29 0a 09 20 20 20 20 3b 3b 20 45 78 74 72 1)).. ;; Extr
9510: 61 63 74 20 6f 75 74 20 73 74 75 66 66 20 6e 65 act out stuff ne
9520: 65 64 65 64 20 69 6e 20 6d 6f 73 74 20 6f 72 20 eded in most or
9530: 6d 61 6e 79 20 63 61 6c 6c 73 0a 09 20 20 20 20 many calls..
9540: 3b 3b 20 68 65 72 65 20 74 68 65 6e 20 63 61 6c ;; here then cal
9550: 6c 20 70 72 6f 63 0a 09 20 20 20 20 28 6c 65 74 l proc.. (let
9560: 2a 20 28 28 6b 65 79 73 20 20 20 20 20 20 20 28 * ((keys (
9570: 64 62 2d 67 65 74 2d 6b 65 79 73 20 64 62 29 29 db-get-keys db))
9580: 0a 09 09 20 20 20 28 6b 65 79 6e 61 6d 65 73 20 ... (keynames
9590: 20 20 28 6d 61 70 20 6b 65 79 3a 67 65 74 2d 66 (map key:get-f
95a0: 69 65 6c 64 6e 61 6d 65 20 6b 65 79 73 29 29 0a ieldname keys)).
95b0: 09 09 20 20 20 28 6b 65 79 76 61 6c 6c 73 74 20 .. (keyvallst
95c0: 20 28 6b 65 79 73 2d 3e 76 61 6c 6c 69 73 74 20 (keys->vallist
95d0: 6b 65 79 73 20 23 74 29 29 29 0a 09 20 20 20 20 keys #t)))..
95e0: 20 20 28 70 72 6f 63 20 64 62 20 6b 65 79 73 20 (proc db keys
95f0: 6b 65 79 6e 61 6d 65 73 20 6b 65 79 76 61 6c 6c keynames keyvall
9600: 73 74 29 29 29 0a 09 28 73 71 6c 69 74 65 33 3a st)))..(sqlite3:
9610: 66 69 6e 61 6c 69 7a 65 21 20 64 62 29 0a 09 28 finalize! db)..(
9620: 73 65 74 21 20 2a 64 69 64 73 6f 6d 65 74 68 69 set! *didsomethi
9630: 6e 67 2a 20 23 74 29 29 29 29 0a 0a 3b 3b 3d 3d ng* #t))))..;;==
9640: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9650: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9660: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9670: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9680: 3d 3d 3d 3d 0a 3b 3b 20 52 6f 6c 6c 75 70 20 72 ====.;; Rollup r
9690: 75 6e 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d uns.;;==========
96a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
96b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
96c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
96d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b ============..;;
96e0: 20 55 70 64 61 74 65 20 74 68 65 20 74 65 73 74 Update the test
96f0: 5f 6d 65 74 61 20 74 61 62 6c 65 20 66 6f 72 20 _meta table for
9700: 74 68 69 73 20 74 65 73 74 0a 28 64 65 66 69 6e this test.(defin
9710: 65 20 28 72 75 6e 73 3a 75 70 64 61 74 65 2d 74 e (runs:update-t
9720: 65 73 74 5f 6d 65 74 61 20 64 62 20 74 65 73 74 est_meta db test
9730: 2d 6e 61 6d 65 20 74 65 73 74 2d 63 6f 6e 66 29 -name test-conf)
9740: 0a 20 20 28 6c 65 74 20 28 28 63 75 72 72 72 65 . (let ((currre
9750: 63 6f 72 64 20 28 64 62 3a 74 65 73 74 6d 65 74 cord (db:testmet
9760: 61 2d 67 65 74 2d 72 65 63 6f 72 64 20 64 62 20 a-get-record db
9770: 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a 20 20 20 test-name))).
9780: 20 28 69 66 20 28 6e 6f 74 20 63 75 72 72 72 65 (if (not currre
9790: 63 6f 72 64 29 0a 09 28 62 65 67 69 6e 0a 09 20 cord)..(begin..
97a0: 20 28 73 65 74 21 20 63 75 72 72 72 65 63 6f 72 (set! currrecor
97b0: 64 20 28 6d 61 6b 65 2d 76 65 63 74 6f 72 20 31 d (make-vector 1
97c0: 30 20 23 66 29 29 0a 09 20 20 28 64 62 3a 74 65 0 #f)).. (db:te
97d0: 73 74 6d 65 74 61 2d 61 64 64 2d 72 65 63 6f 72 stmeta-add-recor
97e0: 64 20 64 62 20 74 65 73 74 2d 6e 61 6d 65 29 29 d db test-name))
97f0: 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 ). (for-each
9800: 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 6b . (lambda (k
9810: 65 79 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a ey). (let*
9820: 20 28 28 69 64 78 20 28 63 61 64 72 20 6b 65 79 ((idx (cadr key
9830: 29 29 0a 09 20 20 20 20 20 20 28 66 6c 64 20 28 )).. (fld (
9840: 63 61 72 20 20 6b 65 79 29 29 0a 09 20 20 20 20 car key))..
9850: 20 20 28 76 61 6c 20 28 63 6f 6e 66 69 67 2d 6c (val (config-l
9860: 6f 6f 6b 75 70 20 74 65 73 74 2d 63 6f 6e 66 20 ookup test-conf
9870: 22 74 65 73 74 5f 6d 65 74 61 22 20 66 6c 64 29 "test_meta" fld)
9880: 29 29 0a 09 20 28 69 66 20 28 61 6e 64 20 76 61 )).. (if (and va
9890: 6c 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 28 l (not (equal? (
98a0: 76 65 63 74 6f 72 2d 72 65 66 20 63 75 72 72 72 vector-ref currr
98b0: 65 63 6f 72 64 20 69 64 78 29 20 76 61 6c 29 29 ecord idx) val))
98c0: 29 0a 09 20 20 20 20 20 28 62 65 67 69 6e 0a 09 ).. (begin..
98d0: 20 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 55 (print "U
98e0: 70 64 61 74 69 6e 67 20 22 20 74 65 73 74 2d 6e pdating " test-n
98f0: 61 6d 65 20 22 20 22 20 66 6c 64 20 22 20 74 6f ame " " fld " to
9900: 20 22 20 76 61 6c 29 0a 09 20 20 20 20 20 20 20 " val)..
9910: 28 64 62 3a 74 65 73 74 6d 65 74 61 2d 75 70 64 (db:testmeta-upd
9920: 61 74 65 2d 66 69 65 6c 64 20 64 62 20 74 65 73 ate-field db tes
9930: 74 2d 6e 61 6d 65 20 66 6c 64 20 76 61 6c 29 29 t-name fld val))
9940: 29 29 29 0a 20 20 20 20 20 27 28 28 22 61 75 74 ))). '(("aut
9950: 68 6f 72 22 20 32 29 28 22 6f 77 6e 65 72 22 20 hor" 2)("owner"
9960: 33 29 28 22 64 65 73 63 72 69 70 74 69 6f 6e 22 3)("description"
9970: 20 34 29 28 22 72 65 76 69 65 77 65 64 22 20 35 4)("reviewed" 5
9980: 29 28 22 74 61 67 73 22 20 39 29 29 29 29 29 0a )("tags" 9))))).
9990: 0a 3b 3b 20 55 70 64 61 74 65 20 74 65 73 74 5f .;; Update test_
99a0: 6d 65 74 61 20 66 6f 72 20 61 6c 6c 20 74 65 73 meta for all tes
99b0: 74 73 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 ts.(define (runs
99c0: 3a 75 70 64 61 74 65 2d 61 6c 6c 2d 74 65 73 74 :update-all-test
99d0: 5f 6d 65 74 61 20 64 62 29 0a 20 20 28 6c 65 74 _meta db). (let
99e0: 20 28 28 74 65 73 74 2d 6e 61 6d 65 73 20 28 67 ((test-names (g
99f0: 65 74 2d 61 6c 6c 2d 6c 65 67 61 6c 2d 74 65 73 et-all-legal-tes
9a00: 74 73 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 ts))). (for-e
9a10: 61 63 68 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 ach . (lambd
9a20: 61 20 28 74 65 73 74 2d 6e 61 6d 65 29 0a 20 20 a (test-name).
9a30: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 65 73 (let* ((tes
9a40: 74 2d 70 61 74 68 20 20 20 20 28 63 6f 6e 63 20 t-path (conc
9a50: 2a 74 6f 70 70 61 74 68 2a 20 22 2f 74 65 73 74 *toppath* "/test
9a60: 73 2f 22 20 74 65 73 74 2d 6e 61 6d 65 29 29 0a s/" test-name)).
9a70: 09 20 20 20 20 20 20 28 74 65 73 74 2d 63 6f 6e . (test-con
9a80: 66 69 67 66 20 28 63 6f 6e 63 20 74 65 73 74 2d figf (conc test-
9a90: 70 61 74 68 20 22 2f 74 65 73 74 63 6f 6e 66 69 path "/testconfi
9aa0: 67 22 29 29 0a 09 20 20 20 20 20 20 28 74 65 73 g")).. (tes
9ab0: 74 65 78 69 73 74 73 20 20 20 28 61 6e 64 20 28 texists (and (
9ac0: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 74 65 73 file-exists? tes
9ad0: 74 2d 63 6f 6e 66 69 67 66 29 28 66 69 6c 65 2d t-configf)(file-
9ae0: 72 65 61 64 2d 61 63 63 65 73 73 3f 20 74 65 73 read-access? tes
9af0: 74 2d 63 6f 6e 66 69 67 66 29 29 29 0a 09 20 20 t-configf)))..
9b00: 20 20 20 20 3b 3b 20 72 65 61 64 20 63 6f 6e 66 ;; read conf
9b10: 69 67 73 20 77 69 74 68 20 74 72 69 63 6b 73 20 igs with tricks
9b20: 74 75 72 6e 65 64 20 6f 66 66 20 28 69 2e 65 2e turned off (i.e.
9b30: 20 6e 6f 20 73 79 73 74 65 6d 29 0a 09 20 20 20 no system)..
9b40: 20 20 20 28 74 65 73 74 2d 63 6f 6e 66 20 20 20 (test-conf
9b50: 20 28 69 66 20 74 65 73 74 65 78 69 73 74 73 20 (if testexists
9b60: 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 74 65 73 (read-config tes
9b70: 74 2d 63 6f 6e 66 69 67 66 20 23 66 20 23 66 29 t-configf #f #f)
9b80: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
9b90: 29 29 29 29 0a 09 20 28 72 75 6e 73 3a 75 70 64 )))).. (runs:upd
9ba0: 61 74 65 2d 74 65 73 74 5f 6d 65 74 61 20 64 62 ate-test_meta db
9bb0: 20 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d test-name test-
9bc0: 63 6f 6e 66 29 29 29 0a 20 20 20 20 20 74 65 73 conf))). tes
9bd0: 74 2d 6e 61 6d 65 73 29 29 29 0a 09 20 0a 3b 3b t-names))).. .;;
9be0: 20 54 68 69 73 20 63 6f 75 6c 64 20 70 72 6f 62 This could prob
9bf0: 61 62 6c 79 20 62 65 20 72 65 66 61 63 74 6f 72 ably be refactor
9c00: 65 64 20 69 6e 74 6f 20 6f 6e 65 20 63 6f 6d 70 ed into one comp
9c10: 6c 65 78 20 71 75 65 72 79 20 2e 2e 2e 0a 28 64 lex query ....(d
9c20: 65 66 69 6e 65 20 28 72 75 6e 73 3a 72 6f 6c 6c efine (runs:roll
9c30: 75 70 2d 72 75 6e 20 64 62 20 6b 65 79 73 29 0a up-run db keys).
9c40: 20 20 28 6c 65 74 2a 20 28 28 6e 65 77 2d 72 75 (let* ((new-ru
9c50: 6e 2d 69 64 20 20 20 20 20 20 28 72 65 67 69 73 n-id (regis
9c60: 74 65 72 2d 72 75 6e 20 64 62 20 6b 65 79 73 29 ter-run db keys)
9c70: 29 0a 09 20 28 70 72 65 76 2d 74 65 73 74 73 20 ).. (prev-tests
9c80: 20 20 20 20 20 28 74 65 73 74 3a 67 65 74 2d 6d (test:get-m
9c90: 61 74 63 68 69 6e 67 2d 70 72 65 76 69 6f 75 73 atching-previous
9ca0: 2d 74 65 73 74 2d 72 75 6e 2d 72 65 63 6f 72 64 -test-run-record
9cb0: 73 20 64 62 20 6e 65 77 2d 72 75 6e 2d 69 64 20 s db new-run-id
9cc0: 22 25 22 20 22 25 22 29 29 0a 09 20 28 63 75 72 "%" "%")).. (cur
9cd0: 72 2d 74 65 73 74 73 20 20 20 20 20 20 28 64 62 r-tests (db
9ce0: 2d 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 -get-tests-for-r
9cf0: 75 6e 20 64 62 20 6e 65 77 2d 72 75 6e 2d 69 64 un db new-run-id
9d00: 20 22 25 22 20 22 25 22 20 23 66 20 23 66 29 29 "%" "%" #f #f))
9d10: 0a 09 20 28 63 75 72 72 2d 74 65 73 74 73 2d 68 .. (curr-tests-h
9d20: 61 73 68 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 ash (make-hash-t
9d30: 61 62 6c 65 29 29 29 0a 20 20 20 20 3b 3b 20 69 able))). ;; i
9d40: 6e 64 65 78 20 74 68 65 20 61 6c 72 65 61 64 79 ndex the already
9d50: 20 73 61 76 65 64 20 74 65 73 74 73 20 62 79 20 saved tests by
9d60: 74 65 73 74 6e 61 6d 65 20 61 6e 64 20 69 74 65 testname and ite
9d70: 6d 70 61 74 68 20 69 6e 20 63 75 72 72 2d 74 65 mpath in curr-te
9d80: 73 74 73 2d 68 61 73 68 0a 20 20 20 20 28 66 6f sts-hash. (fo
9d90: 72 2d 65 61 63 68 0a 20 20 20 20 20 28 6c 61 6d r-each. (lam
9da0: 62 64 61 20 28 74 65 73 74 64 61 74 29 0a 20 20 bda (testdat).
9db0: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 65 73 (let* ((tes
9dc0: 74 6e 61 6d 65 20 20 28 64 62 3a 74 65 73 74 2d tname (db:test-
9dd0: 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 get-testname tes
9de0: 74 64 61 74 29 29 0a 09 20 20 20 20 20 20 28 69 tdat)).. (i
9df0: 74 65 6d 2d 70 61 74 68 20 28 64 62 3a 74 65 73 tem-path (db:tes
9e00: 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 t-get-item-path
9e10: 74 65 73 74 64 61 74 29 29 0a 09 20 20 20 20 20 testdat))..
9e20: 20 28 66 75 6c 6c 2d 6e 61 6d 65 20 28 63 6f 6e (full-name (con
9e30: 63 20 74 65 73 74 6e 61 6d 65 20 22 2f 22 20 69 c testname "/" i
9e40: 74 65 6d 2d 70 61 74 68 29 29 29 0a 09 20 28 68 tem-path))).. (h
9e50: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 63 ash-table-set! c
9e60: 75 72 72 2d 74 65 73 74 73 2d 68 61 73 68 20 66 urr-tests-hash f
9e70: 75 6c 6c 2d 6e 61 6d 65 20 74 65 73 74 64 61 74 ull-name testdat
9e80: 29 29 29 0a 20 20 20 20 20 63 75 72 72 2d 74 65 ))). curr-te
9e90: 73 74 73 29 0a 20 20 20 20 3b 3b 20 4e 4f 50 45 sts). ;; NOPE
9ea0: 3a 20 4e 6f 6e 2d 6f 70 74 69 6d 61 6c 20 61 70 : Non-optimal ap
9eb0: 70 72 6f 61 63 68 2e 20 54 72 79 20 74 68 69 73 proach. Try this
9ec0: 20 69 6e 73 74 65 61 64 2e 0a 20 20 20 20 3b 3b instead.. ;;
9ed0: 20 20 20 31 2e 20 74 65 73 74 73 20 61 72 65 20 1. tests are
9ee0: 72 65 63 65 69 76 65 64 20 69 6e 20 61 20 6c 69 received in a li
9ef0: 73 74 2c 20 6d 6f 73 74 20 72 65 63 65 6e 74 20 st, most recent
9f00: 66 69 72 73 74 0a 20 20 20 20 3b 3b 20 20 20 32 first. ;; 2
9f10: 2e 20 72 65 70 6c 61 63 65 20 74 68 65 20 72 6f . replace the ro
9f20: 6c 6c 75 70 20 74 65 73 74 20 77 69 74 68 20 74 llup test with t
9f30: 68 65 20 6e 65 77 20 2a 61 6c 77 61 79 73 2a 0a he new *always*.
9f40: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 (for-each .
9f50: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 74 65 73 (lambda (tes
9f60: 74 64 61 74 29 0a 20 20 20 20 20 20 20 28 6c 65 tdat). (le
9f70: 74 2a 20 28 28 74 65 73 74 6e 61 6d 65 20 20 28 t* ((testname (
9f80: 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 db:test-get-test
9f90: 6e 61 6d 65 20 74 65 73 74 64 61 74 29 29 0a 09 name testdat))..
9fa0: 20 20 20 20 20 20 28 69 74 65 6d 2d 70 61 74 68 (item-path
9fb0: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 (db:test-get-it
9fc0: 65 6d 2d 70 61 74 68 20 74 65 73 74 64 61 74 29 em-path testdat)
9fd0: 29 0a 09 20 20 20 20 20 20 28 66 75 6c 6c 2d 6e ).. (full-n
9fe0: 61 6d 65 20 28 63 6f 6e 63 20 74 65 73 74 6e 61 ame (conc testna
9ff0: 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 me "/" item-path
a000: 29 29 0a 09 20 20 20 20 20 20 28 70 72 65 76 2d )).. (prev-
a010: 74 65 73 74 2d 64 61 74 20 28 68 61 73 68 2d 74 test-dat (hash-t
a020: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
a030: 20 63 75 72 72 2d 74 65 73 74 73 2d 68 61 73 68 curr-tests-hash
a040: 20 66 75 6c 6c 2d 6e 61 6d 65 20 23 66 29 29 0a full-name #f)).
a050: 09 20 20 20 20 20 20 28 74 65 73 74 2d 73 74 65 . (test-ste
a060: 70 73 20 20 20 20 20 20 28 64 62 3a 67 65 74 2d ps (db:get-
a070: 73 74 65 70 73 2d 66 6f 72 2d 74 65 73 74 20 64 steps-for-test d
a080: 62 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 b (db:test-get-i
a090: 64 20 74 65 73 74 64 61 74 29 29 29 0a 09 20 20 d testdat)))..
a0a0: 20 20 20 20 28 6e 65 77 2d 74 65 73 74 2d 72 65 (new-test-re
a0b0: 63 6f 72 64 20 23 66 29 29 0a 09 20 3b 3b 20 72 cord #f)).. ;; r
a0c0: 65 70 6c 61 63 65 20 74 68 65 73 65 20 77 69 74 eplace these wit
a0d0: 68 20 69 6e 73 65 72 74 20 2e 2e 2e 20 73 65 6c h insert ... sel
a0e0: 65 63 74 0a 09 20 28 61 70 70 6c 79 20 73 71 6c ect.. (apply sql
a0f0: 69 74 65 33 3a 65 78 65 63 75 74 65 20 0a 09 09 ite3:execute ...
a100: 64 62 20 0a 09 09 28 63 6f 6e 63 20 22 49 4e 53 db ...(conc "INS
a110: 45 52 54 20 4f 52 20 52 45 50 4c 41 43 45 20 49 ERT OR REPLACE I
a120: 4e 54 4f 20 74 65 73 74 73 20 28 72 75 6e 5f 69 NTO tests (run_i
a130: 64 2c 74 65 73 74 6e 61 6d 65 2c 73 74 61 74 65 d,testname,state
a140: 2c 73 74 61 74 75 73 2c 65 76 65 6e 74 5f 74 69 ,status,event_ti
a150: 6d 65 2c 68 6f 73 74 2c 63 70 75 6c 6f 61 64 2c me,host,cpuload,
a160: 64 69 73 6b 66 72 65 65 2c 75 6e 61 6d 65 2c 72 diskfree,uname,r
a170: 75 6e 64 69 72 2c 69 74 65 6d 5f 70 61 74 68 2c undir,item_path,
a180: 72 75 6e 5f 64 75 72 61 74 69 6f 6e 2c 66 69 6e run_duration,fin
a190: 61 6c 5f 6c 6f 67 66 2c 63 6f 6d 6d 65 6e 74 2c al_logf,comment,
a1a0: 66 69 72 73 74 5f 65 72 72 2c 66 69 72 73 74 5f first_err,first_
a1b0: 77 61 72 6e 29 20 22 0a 09 09 20 20 20 20 20 20 warn) "...
a1c0: 22 56 41 4c 55 45 53 20 28 3f 2c 3f 2c 3f 2c 3f "VALUES (?,?,?,?
a1d0: 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f ,?,?,?,?,?,?,?,?
a1e0: 2c 3f 2c 3f 2c 3f 2c 3f 29 3b 22 29 0a 09 09 6e ,?,?,?,?);")...n
a1f0: 65 77 2d 72 75 6e 2d 69 64 20 28 63 64 64 72 20 ew-run-id (cddr
a200: 28 76 65 63 74 6f 72 2d 3e 6c 69 73 74 20 74 65 (vector->list te
a210: 73 74 64 61 74 29 29 29 0a 09 20 28 73 65 74 21 stdat))).. (set!
a220: 20 6e 65 77 2d 74 65 73 74 64 61 74 20 28 63 61 new-testdat (ca
a230: 72 20 28 64 62 2d 67 65 74 2d 74 65 73 74 73 2d r (db-get-tests-
a240: 66 6f 72 2d 72 75 6e 20 64 62 20 6e 65 77 2d 72 for-run db new-r
a250: 75 6e 2d 69 64 20 74 65 73 74 6e 61 6d 65 20 69 un-id testname i
a260: 74 65 6d 2d 70 61 74 68 20 23 66 20 23 66 29 29 tem-path #f #f))
a270: 29 0a 09 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ).. (hash-table-
a280: 73 65 74 21 20 63 75 72 72 2d 74 65 73 74 73 2d set! curr-tests-
a290: 68 61 73 68 20 66 75 6c 6c 2d 6e 61 6d 65 20 6e hash full-name n
a2a0: 65 77 2d 74 65 73 74 64 61 74 29 20 3b 3b 20 74 ew-testdat) ;; t
a2b0: 68 69 73 20 63 6f 75 6c 64 20 62 65 20 63 6f 6e his could be con
a2c0: 66 75 73 69 6e 67 2c 20 77 68 69 63 68 20 72 65 fusing, which re
a2d0: 63 6f 72 64 20 73 68 6f 75 6c 64 20 67 6f 20 69 cord should go i
a2e0: 6e 74 6f 20 74 68 65 20 6c 6f 6f 6b 75 70 20 74 nto the lookup t
a2f0: 61 62 6c 65 3f 0a 09 20 3b 3b 20 4e 6f 77 20 64 able?.. ;; Now d
a300: 75 70 6c 69 63 61 74 65 20 74 68 65 20 74 65 73 uplicate the tes
a310: 74 20 73 74 65 70 73 0a 09 20 28 64 65 62 75 67 t steps.. (debug
a320: 3a 70 72 69 6e 74 20 34 20 22 43 6f 70 79 69 6e :print 4 "Copyin
a330: 67 20 72 65 63 6f 72 64 73 20 69 6e 20 74 65 73 g records in tes
a340: 74 5f 73 74 65 70 73 20 66 72 6f 6d 20 74 65 73 t_steps from tes
a350: 74 5f 69 64 3d 22 20 28 64 62 3a 74 65 73 74 2d t_id=" (db:test-
a360: 67 65 74 2d 69 64 20 74 65 73 74 64 61 74 29 20 get-id testdat)
a370: 22 20 74 6f 20 22 20 28 64 62 3a 74 65 73 74 2d " to " (db:test-
a380: 67 65 74 2d 69 64 20 6e 65 77 2d 74 65 73 74 64 get-id new-testd
a390: 61 74 29 29 0a 09 20 28 73 71 6c 69 74 65 33 3a at)).. (sqlite3:
a3a0: 65 78 65 63 75 74 65 20 0a 09 20 20 64 62 20 0a execute .. db .
a3b0: 09 20 20 28 63 6f 6e 63 20 22 49 4e 53 45 52 54 . (conc "INSERT
a3c0: 20 4f 52 20 52 45 50 4c 41 43 45 20 49 4e 54 4f OR REPLACE INTO
a3d0: 20 74 65 73 74 5f 73 74 65 70 73 20 28 74 65 73 test_steps (tes
a3e0: 74 5f 69 64 2c 73 74 65 70 6e 61 6d 65 2c 73 74 t_id,stepname,st
a3f0: 61 74 65 2c 73 74 61 74 75 73 2c 65 76 65 6e 74 ate,status,event
a400: 5f 74 69 6d 65 2c 63 6f 6d 6d 65 6e 74 29 20 22 _time,comment) "
a410: 0a 09 09 22 53 45 4c 45 43 54 20 22 20 28 64 62 ..."SELECT " (db
a420: 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 6e 65 77 :test-get-id new
a430: 2d 74 65 73 74 64 61 74 29 20 22 2c 73 74 65 70 -testdat) ",step
a440: 6e 61 6d 65 2c 73 74 61 74 65 2c 73 74 61 74 75 name,state,statu
a450: 73 2c 65 76 65 6e 74 5f 74 69 6d 65 2c 63 6f 6d s,event_time,com
a460: 6d 65 6e 74 20 46 52 4f 4d 20 74 65 73 74 5f 73 ment FROM test_s
a470: 74 65 70 73 20 57 48 45 52 45 20 74 65 73 74 5f teps WHERE test_
a480: 69 64 3d 3f 3b 22 29 0a 09 20 20 28 64 62 3a 74 id=?;").. (db:t
a490: 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 64 est-get-id testd
a4a0: 61 74 29 29 0a 09 20 3b 3b 20 4e 6f 77 20 64 75 at)).. ;; Now du
a4b0: 70 6c 69 63 61 74 65 20 74 68 65 20 74 65 73 74 plicate the test
a4c0: 20 64 61 74 61 0a 09 20 28 64 65 62 75 67 3a 70 data.. (debug:p
a4d0: 72 69 6e 74 20 34 20 22 43 6f 70 79 69 6e 67 20 rint 4 "Copying
a4e0: 72 65 63 6f 72 64 73 20 69 6e 20 74 65 73 74 5f records in test_
a4f0: 64 61 74 61 20 66 72 6f 6d 20 74 65 73 74 5f 69 data from test_i
a500: 64 3d 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 d=" (db:test-get
a510: 2d 69 64 20 74 65 73 74 64 61 74 29 20 22 20 74 -id testdat) " t
a520: 6f 20 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 o " (db:test-get
a530: 2d 69 64 20 6e 65 77 2d 74 65 73 74 64 61 74 29 -id new-testdat)
a540: 29 0a 09 20 28 73 71 6c 69 74 65 33 3a 65 78 65 ).. (sqlite3:exe
a550: 63 75 74 65 20 0a 09 20 20 64 62 20 0a 09 20 20 cute .. db ..
a560: 28 63 6f 6e 63 20 22 49 4e 53 45 52 54 20 4f 52 (conc "INSERT OR
a570: 20 52 45 50 4c 41 43 45 20 49 4e 54 4f 20 74 65 REPLACE INTO te
a580: 73 74 5f 64 61 74 61 20 28 74 65 73 74 5f 69 64 st_data (test_id
a590: 2c 63 61 74 65 67 6f 72 79 2c 76 61 72 69 61 62 ,category,variab
a5a0: 6c 65 2c 76 61 6c 75 65 2c 65 78 70 65 63 74 65 le,value,expecte
a5b0: 64 2c 74 6f 6c 2c 75 6e 69 74 73 2c 63 6f 6d 6d d,tol,units,comm
a5c0: 65 6e 74 29 20 22 0a 09 09 22 53 45 4c 45 43 54 ent) "..."SELECT
a5d0: 20 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d " (db:test-get-
a5e0: 69 64 20 6e 65 77 2d 74 65 73 74 64 61 74 29 20 id new-testdat)
a5f0: 22 2c 63 61 74 65 67 6f 72 79 2c 76 61 72 69 61 ",category,varia
a600: 62 6c 65 2c 76 61 6c 75 65 2c 65 78 70 65 63 74 ble,value,expect
a610: 65 64 2c 74 6f 6c 2c 75 6e 69 74 73 2c 63 6f 6d ed,tol,units,com
a620: 6d 65 6e 74 20 46 52 4f 4d 20 74 65 73 74 5f 64 ment FROM test_d
a630: 61 74 61 20 57 48 45 52 45 20 74 65 73 74 5f 69 ata WHERE test_i
a640: 64 3d 3f 3b 22 29 0a 09 20 20 28 64 62 3a 74 65 d=?;").. (db:te
a650: 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 64 61 st-get-id testda
a660: 74 29 29 0a 09 20 29 29 0a 20 20 20 20 20 70 72 t)).. )). pr
a670: 65 76 2d 74 65 73 74 73 29 29 29 0a 09 20 0a 20 ev-tests))).. .
a680: 20 20 20 20 0a .