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: 3b 3b 20 72 65 67 69 73 74 65 72 20 61 20 74 65 ;; register a te
0190: 73 74 20 72 75 6e 20 77 69 74 68 20 74 68 65 20 st run with the
01a0: 64 62 0a 28 64 65 66 69 6e 65 20 28 72 65 67 69 db.(define (regi
01b0: 73 74 65 72 2d 72 75 6e 20 64 62 20 6b 65 79 73 ster-run db keys
01c0: 29 20 3b 3b 20 74 65 73 74 2d 6e 61 6d 65 29 0a ) ;; test-name).
01d0: 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 73 74 72 (let* ((keystr
01e0: 20 20 20 20 28 6b 65 79 73 2d 3e 6b 65 79 73 74 (keys->keyst
01f0: 72 20 6b 65 79 73 29 29 0a 09 20 28 63 6f 6d 6d r keys)).. (comm
0200: 61 20 20 20 20 20 28 69 66 20 28 3e 20 28 6c 65 a (if (> (le
0210: 6e 67 74 68 20 6b 65 79 73 29 20 30 29 20 22 2c ngth keys) 0) ",
0220: 22 20 22 22 29 29 0a 09 20 28 61 6e 64 73 74 72 " "")).. (andstr
0230: 20 20 20 20 28 69 66 20 28 3e 20 28 6c 65 6e 67 (if (> (leng
0240: 74 68 20 6b 65 79 73 29 20 30 29 20 22 20 41 4e th keys) 0) " AN
0250: 44 20 22 20 22 22 29 29 0a 09 20 28 76 61 6c 73 D " "")).. (vals
0260: 6c 6f 74 73 20 20 28 6b 65 79 73 2d 3e 76 61 6c lots (keys->val
0270: 73 6c 6f 74 73 20 6b 65 79 73 29 29 20 3b 3b 20 slots keys)) ;;
0280: 3f 2c 3f 2c 3f 20 2e 2e 2e 0a 09 20 28 6b 65 79 ?,?,? ..... (key
0290: 76 61 6c 6c 73 74 20 28 6b 65 79 73 2d 3e 76 61 vallst (keys->va
02a0: 6c 6c 69 73 74 20 6b 65 79 73 29 29 20 3b 3b 20 llist keys)) ;;
02b0: 65 78 74 72 61 63 74 73 20 74 68 65 20 76 61 6c extracts the val
02c0: 75 65 73 20 66 72 6f 6d 20 72 65 6d 61 69 6e 64 ues from remaind
02d0: 65 72 20 6f 66 20 28 61 72 67 76 29 0a 09 20 28 er of (argv).. (
02e0: 72 75 6e 6e 61 6d 65 20 20 20 28 67 65 74 2d 77 runname (get-w
02f0: 69 74 68 2d 64 65 66 61 75 6c 74 20 22 3a 72 75 ith-default ":ru
0300: 6e 6e 61 6d 65 22 20 23 66 29 29 0a 09 20 28 73 nname" #f)).. (s
0310: 74 61 74 65 20 20 20 20 20 28 67 65 74 2d 77 69 tate (get-wi
0320: 74 68 2d 64 65 66 61 75 6c 74 20 22 3a 73 74 61 th-default ":sta
0330: 74 65 22 20 22 6e 6f 22 29 29 0a 09 20 28 73 74 te" "no")).. (st
0340: 61 74 75 73 20 20 20 20 28 67 65 74 2d 77 69 74 atus (get-wit
0350: 68 2d 64 65 66 61 75 6c 74 20 22 3a 73 74 61 74 h-default ":stat
0360: 75 73 22 20 22 6e 2f 61 22 29 29 0a 09 20 28 61 us" "n/a")).. (a
0370: 6c 6c 76 61 6c 73 20 20 20 28 61 70 70 65 6e 64 llvals (append
0380: 20 28 6c 69 73 74 20 72 75 6e 6e 61 6d 65 20 73 (list runname s
0390: 74 61 74 65 20 73 74 61 74 75 73 20 75 73 65 72 tate status user
03a0: 29 20 6b 65 79 76 61 6c 6c 73 74 29 29 0a 09 20 ) keyvallst))..
03b0: 28 71 72 79 76 61 6c 73 20 20 20 28 61 70 70 65 (qryvals (appe
03c0: 6e 64 20 28 6c 69 73 74 20 72 75 6e 6e 61 6d 65 nd (list runname
03d0: 29 20 6b 65 79 76 61 6c 6c 73 74 29 29 0a 09 20 ) keyvallst))..
03e0: 28 6b 65 79 3d 3f 73 74 72 20 20 28 73 74 72 69 (key=?str (stri
03f0: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 ng-intersperse (
0400: 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 6b 29 28 map (lambda (k)(
0410: 63 6f 6e 63 20 28 6b 65 79 3a 67 65 74 2d 66 69 conc (key:get-fi
0420: 65 6c 64 6e 61 6d 65 20 6b 29 20 22 3d 3f 22 29 eldname k) "=?")
0430: 29 20 6b 65 79 73 29 20 22 20 41 4e 44 20 22 29 ) keys) " AND ")
0440: 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 )). (debug:pr
0450: 69 6e 74 20 33 20 22 6b 65 79 73 3a 20 22 20 6b int 3 "keys: " k
0460: 65 79 73 20 22 20 61 6c 6c 76 61 6c 73 3a 20 22 eys " allvals: "
0470: 20 61 6c 6c 76 61 6c 73 20 22 20 6b 65 79 76 61 allvals " keyva
0480: 6c 6c 73 74 3a 20 22 20 6b 65 79 76 61 6c 6c 73 llst: " keyvalls
0490: 74 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 t). (debug:pr
04a0: 69 6e 74 20 32 20 22 4e 4f 54 45 3a 20 75 73 69 int 2 "NOTE: usi
04b0: 6e 67 20 6b 65 79 20 22 20 28 73 74 72 69 6e 67 ng key " (string
04c0: 2d 69 6e 74 65 72 73 70 65 72 73 65 20 6b 65 79 -intersperse key
04d0: 76 61 6c 6c 73 74 20 22 2f 22 29 20 22 20 66 6f vallst "/") " fo
04e0: 72 20 74 68 69 73 20 72 75 6e 22 29 0a 20 20 20 r this run").
04f0: 20 28 69 66 20 28 61 6e 64 20 72 75 6e 6e 61 6d (if (and runnam
0500: 65 20 28 6e 75 6c 6c 3f 20 28 66 69 6c 74 65 72 e (null? (filter
0510: 20 28 6c 61 6d 62 64 61 20 28 78 29 28 6e 6f 74 (lambda (x)(not
0520: 20 78 29 29 20 6b 65 79 76 61 6c 6c 73 74 29 29 x)) keyvallst))
0530: 29 20 3b 3b 20 74 68 65 72 65 20 6d 75 73 74 20 ) ;; there must
0540: 62 65 20 61 20 62 65 74 74 65 72 20 77 61 79 20 be a better way
0550: 74 6f 20 22 61 70 70 6c 79 20 61 6e 64 22 0a 09 to "apply and"..
0560: 28 6c 65 74 20 28 28 72 65 73 20 23 66 29 29 0a (let ((res #f)).
0570: 09 20 20 28 61 70 70 6c 79 20 73 71 6c 69 74 65 . (apply sqlite
0580: 33 3a 65 78 65 63 75 74 65 20 64 62 20 28 63 6f 3:execute db (co
0590: 6e 63 20 22 49 4e 53 45 52 54 20 4f 52 20 49 47 nc "INSERT OR IG
05a0: 4e 4f 52 45 20 49 4e 54 4f 20 72 75 6e 73 20 28 NORE INTO runs (
05b0: 72 75 6e 6e 61 6d 65 2c 73 74 61 74 65 2c 73 74 runname,state,st
05c0: 61 74 75 73 2c 6f 77 6e 65 72 2c 65 76 65 6e 74 atus,owner,event
05d0: 5f 74 69 6d 65 22 20 63 6f 6d 6d 61 20 6b 65 79 _time" comma key
05e0: 73 74 72 20 22 29 20 56 41 4c 55 45 53 20 28 3f str ") VALUES (?
05f0: 2c 3f 2c 3f 2c 3f 2c 73 74 72 66 74 69 6d 65 28 ,?,?,?,strftime(
0600: 27 25 73 27 2c 27 6e 6f 77 27 29 22 20 63 6f 6d '%s','now')" com
0610: 6d 61 20 76 61 6c 73 6c 6f 74 73 20 22 29 3b 22 ma valslots ");"
0620: 29 0a 09 09 20 61 6c 6c 76 61 6c 73 29 0a 09 20 )... allvals)..
0630: 20 28 61 70 70 6c 79 20 73 71 6c 69 74 65 33 3a (apply sqlite3:
0640: 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 0a 09 20 for-each-row ..
0650: 20 20 28 6c 61 6d 62 64 61 20 28 69 64 29 0a 09 (lambda (id)..
0660: 20 20 20 20 20 28 73 65 74 21 20 72 65 73 20 69 (set! res i
0670: 64 29 29 0a 09 20 20 20 64 62 0a 09 20 20 20 28 d)).. db.. (
0680: 6c 65 74 20 28 28 71 72 79 20 28 63 6f 6e 63 20 let ((qry (conc
0690: 22 53 45 4c 45 43 54 20 69 64 20 46 52 4f 4d 20 "SELECT id FROM
06a0: 72 75 6e 73 20 57 48 45 52 45 20 28 72 75 6e 6e runs WHERE (runn
06b0: 61 6d 65 3d 3f 20 22 20 61 6e 64 73 74 72 20 6b ame=? " andstr k
06c0: 65 79 3d 3f 73 74 72 20 22 29 3b 22 29 29 29 0a ey=?str ");"))).
06d0: 09 20 20 20 20 20 3b 28 64 65 62 75 67 3a 70 72 . ;(debug:pr
06e0: 69 6e 74 20 34 20 22 71 72 79 3a 20 22 20 71 72 int 4 "qry: " qr
06f0: 79 29 20 0a 09 20 20 20 20 20 71 72 79 29 0a 09 y) .. qry)..
0700: 20 20 20 71 72 79 76 61 6c 73 29 0a 09 20 20 28 qryvals).. (
0710: 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 sqlite3:execute
0720: 64 62 20 22 55 50 44 41 54 45 20 72 75 6e 73 20 db "UPDATE runs
0730: 53 45 54 20 73 74 61 74 65 3d 3f 2c 73 74 61 74 SET state=?,stat
0740: 75 73 3d 3f 20 57 48 45 52 45 20 69 64 3d 3f 3b us=? WHERE id=?;
0750: 22 20 73 74 61 74 65 20 73 74 61 74 75 73 20 72 " state status r
0760: 65 73 29 0a 09 20 20 72 65 73 29 20 0a 09 28 62 es).. res) ..(b
0770: 65 67 69 6e 0a 09 20 20 28 64 65 62 75 67 3a 70 egin.. (debug:p
0780: 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 43 rint 0 "ERROR: C
0790: 61 6c 6c 65 64 20 77 69 74 68 6f 75 74 20 61 6c alled without al
07a0: 6c 20 6e 65 63 65 73 73 61 72 79 20 6b 65 79 73 l necessary keys
07b0: 22 29 0a 09 20 20 23 66 29 29 29 29 0a 0a 3b 3b ").. #f))))..;;
07c0: 20 72 75 6e 73 3a 67 65 74 2d 72 75 6e 73 2d 62 runs:get-runs-b
07d0: 79 2d 70 61 74 74 0a 3b 3b 20 67 65 74 20 72 75 y-patt.;; get ru
07e0: 6e 73 20 62 79 20 6c 69 73 74 20 6f 66 20 63 72 ns by list of cr
07f0: 69 74 65 72 69 61 0a 3b 3b 20 72 65 67 69 73 74 iteria.;; regist
0800: 65 72 20 61 20 74 65 73 74 20 72 75 6e 20 77 69 er a test run wi
0810: 74 68 20 74 68 65 20 64 62 0a 3b 3b 0a 3b 3b 20 th the db.;;.;;
0820: 55 73 65 3a 20 28 64 62 2d 67 65 74 2d 76 61 6c Use: (db-get-val
0830: 75 65 2d 62 79 2d 68 65 61 64 65 72 20 28 64 62 ue-by-header (db
0840: 3a 67 65 74 2d 68 65 61 64 65 72 20 72 75 6e 69 :get-header runi
0850: 6e 66 6f 29 28 64 62 3a 67 65 74 2d 72 6f 77 20 nfo)(db:get-row
0860: 72 75 6e 69 6e 66 6f 29 29 0a 3b 3b 20 20 74 6f runinfo)).;; to
0870: 20 65 78 74 72 61 63 74 20 69 6e 66 6f 20 66 72 extract info fr
0880: 6f 6d 20 74 68 65 20 73 74 72 75 63 74 75 72 65 om the structure
0890: 20 72 65 74 75 72 6e 65 64 0a 3b 3b 0a 28 64 65 returned.;;.(de
08a0: 66 69 6e 65 20 28 72 75 6e 73 3a 67 65 74 2d 72 fine (runs:get-r
08b0: 75 6e 73 2d 62 79 2d 70 61 74 74 20 64 62 20 6b uns-by-patt db k
08c0: 65 79 73 20 72 75 6e 6e 61 6d 65 70 61 74 74 20 eys runnamepatt
08d0: 2e 20 70 61 72 61 6d 73 29 20 3b 3b 20 74 65 73 . params) ;; tes
08e0: 74 2d 6e 61 6d 65 29 0a 20 20 28 6c 65 74 2a 20 t-name). (let*
08f0: 28 28 6b 65 79 76 61 6c 6c 73 74 20 28 6b 65 79 ((keyvallst (key
0900: 73 2d 3e 76 61 6c 6c 69 73 74 20 6b 65 79 73 29 s->vallist keys)
0910: 29 0a 09 20 28 74 6d 70 20 20 20 20 20 20 28 72 ).. (tmp (r
0920: 75 6e 73 3a 67 65 74 2d 73 74 64 2d 72 75 6e 2d uns:get-std-run-
0930: 66 69 65 6c 64 73 20 6b 65 79 73 20 27 28 22 69 fields keys '("i
0940: 64 22 20 22 72 75 6e 6e 61 6d 65 22 20 22 73 74 d" "runname" "st
0950: 61 74 65 22 20 22 73 74 61 74 75 73 22 20 22 6f ate" "status" "o
0960: 77 6e 65 72 22 20 22 65 76 65 6e 74 5f 74 69 6d wner" "event_tim
0970: 65 22 29 29 29 0a 09 20 28 6b 65 79 73 74 72 20 e"))).. (keystr
0980: 20 20 28 63 61 72 20 74 6d 70 29 29 0a 09 20 28 (car tmp)).. (
0990: 68 65 61 64 65 72 20 20 20 28 63 61 64 72 20 74 header (cadr t
09a0: 6d 70 29 29 0a 09 20 28 72 65 73 20 20 20 20 20 mp)).. (res
09b0: 27 28 29 29 0a 09 20 28 6b 65 79 2d 70 61 74 74 '()).. (key-patt
09c0: 20 22 22 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 "")). (for-e
09d0: 61 63 68 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 ach (lambda (key
09e0: 76 61 6c 29 0a 09 09 28 6c 65 74 2a 20 28 28 6b val)...(let* ((k
09f0: 65 79 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 ey (vector-re
0a00: 66 20 6b 65 79 76 61 6c 20 30 29 29 0a 09 09 20 f keyval 0))...
0a10: 20 20 20 20 20 20 28 66 75 6c 6b 65 79 20 28 63 (fulkey (c
0a20: 6f 6e 63 20 22 3a 22 20 6b 65 79 29 29 0a 09 09 onc ":" key))...
0a30: 20 20 20 20 20 20 20 28 70 61 74 74 20 20 20 28 (patt (
0a40: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 66 75 6c args:get-arg ful
0a50: 6b 65 79 29 29 29 0a 09 09 20 20 28 69 66 20 70 key)))... (if p
0a60: 61 74 74 0a 09 09 20 20 20 20 20 20 28 73 65 74 att... (set
0a70: 21 20 6b 65 79 2d 70 61 74 74 20 28 63 6f 6e 63 ! key-patt (conc
0a80: 20 6b 65 79 2d 70 61 74 74 20 22 20 41 4e 44 20 key-patt " AND
0a90: 22 20 6b 65 79 20 22 20 6c 69 6b 65 20 27 22 20 " key " like '"
0aa0: 70 61 74 74 20 22 27 22 29 29 0a 09 09 20 20 20 patt "'"))...
0ab0: 20 20 20 28 62 65 67 69 6e 0a 09 09 09 28 64 65 (begin....(de
0ac0: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 bug:print 0 "ERR
0ad0: 4f 52 3a 20 73 65 61 72 63 68 69 6e 67 20 66 6f OR: searching fo
0ae0: 72 20 72 75 6e 73 20 77 69 74 68 20 6e 6f 20 70 r runs with no p
0af0: 61 74 74 65 72 6e 20 73 65 74 20 66 6f 72 20 22 attern set for "
0b00: 20 66 75 6c 6b 65 79 29 0a 09 09 09 28 65 78 69 fulkey)....(exi
0b10: 74 20 36 29 29 29 29 29 0a 09 20 20 20 20 20 20 t 6)))))..
0b20: 6b 65 79 73 29 0a 20 20 20 20 28 73 71 6c 69 74 keys). (sqlit
0b30: 65 33 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 e3:for-each-row
0b40: 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 61 . (lambda (a
0b50: 20 2e 20 72 29 0a 20 20 20 20 20 20 20 28 73 65 . r). (se
0b60: 74 21 20 72 65 73 20 28 63 6f 6e 73 20 28 6c 69 t! res (cons (li
0b70: 73 74 2d 3e 76 65 63 74 6f 72 20 28 63 6f 6e 73 st->vector (cons
0b80: 20 61 20 72 29 29 20 72 65 73 29 29 29 0a 20 20 a r)) res))).
0b90: 20 20 20 64 62 20 0a 20 20 20 20 20 28 63 6f 6e db . (con
0ba0: 63 20 22 53 45 4c 45 43 54 20 22 20 6b 65 79 73 c "SELECT " keys
0bb0: 74 72 20 22 20 46 52 4f 4d 20 72 75 6e 73 20 57 tr " FROM runs W
0bc0: 48 45 52 45 20 72 75 6e 6e 61 6d 65 20 6c 69 6b HERE runname lik
0bd0: 65 20 3f 20 22 20 6b 65 79 2d 70 61 74 74 20 22 e ? " key-patt "
0be0: 3b 22 29 0a 20 20 20 20 20 72 75 6e 6e 61 6d 65 ;"). runname
0bf0: 70 61 74 74 29 0a 20 20 20 20 28 76 65 63 74 6f patt). (vecto
0c00: 72 20 68 65 61 64 65 72 20 72 65 73 29 29 29 0a r header res))).
0c10: 0a 28 64 65 66 69 6e 65 20 28 72 65 67 69 73 74 .(define (regist
0c20: 65 72 2d 74 65 73 74 20 64 62 20 72 75 6e 2d 69 er-test db run-i
0c30: 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d d test-name item
0c40: 2d 70 61 74 68 29 0a 20 20 28 6c 65 74 20 28 28 -path). (let ((
0c50: 69 74 65 6d 2d 70 61 74 68 73 20 28 69 66 20 28 item-paths (if (
0c60: 65 71 75 61 6c 3f 20 69 74 65 6d 2d 70 61 74 68 equal? item-path
0c70: 20 22 22 29 0a 09 09 09 28 6c 69 73 74 20 69 74 "")....(list it
0c80: 65 6d 2d 70 61 74 68 29 0a 09 09 09 28 6c 69 73 em-path)....(lis
0c90: 74 20 69 74 65 6d 2d 70 61 74 68 20 22 22 29 29 t item-path ""))
0ca0: 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 )). (for-each
0cb0: 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 . (lambda (
0cc0: 70 74 68 29 0a 20 20 20 20 20 20 20 28 73 71 6c pth). (sql
0cd0: 69 74 65 33 3a 65 78 65 63 75 74 65 20 64 62 20 ite3:execute db
0ce0: 22 49 4e 53 45 52 54 20 4f 52 20 49 47 4e 4f 52 "INSERT OR IGNOR
0cf0: 45 20 49 4e 54 4f 20 74 65 73 74 73 20 28 72 75 E INTO tests (ru
0d00: 6e 5f 69 64 2c 74 65 73 74 6e 61 6d 65 2c 65 76 n_id,testname,ev
0d10: 65 6e 74 5f 74 69 6d 65 2c 69 74 65 6d 5f 70 61 ent_time,item_pa
0d20: 74 68 2c 73 74 61 74 65 2c 73 74 61 74 75 73 29 th,state,status)
0d30: 20 56 41 4c 55 45 53 20 28 3f 2c 3f 2c 73 74 72 VALUES (?,?,str
0d40: 66 74 69 6d 65 28 27 25 73 27 2c 27 6e 6f 77 27 ftime('%s','now'
0d50: 29 2c 3f 2c 27 4e 4f 54 5f 53 54 41 52 54 45 44 ),?,'NOT_STARTED
0d60: 27 2c 27 6e 2f 61 27 29 3b 22 20 0a 09 09 09 72 ','n/a');" ....r
0d70: 75 6e 2d 69 64 20 0a 09 09 09 74 65 73 74 2d 6e un-id ....test-n
0d80: 61 6d 65 0a 09 09 09 70 74 68 20 0a 09 09 09 3b ame....pth ....;
0d90: 3b 20 28 63 6f 6e 63 20 22 2c 22 20 28 73 74 72 ; (conc "," (str
0da0: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
0db0: 74 61 67 73 20 22 2c 22 29 20 22 2c 22 29 0a 09 tags ",") ",")..
0dc0: 09 09 29 29 0a 20 20 20 20 20 69 74 65 6d 2d 70 ..)). item-p
0dd0: 61 74 68 73 20 29 29 29 0a 0a 3b 3b 20 67 65 74 aths )))..;; get
0de0: 20 74 68 65 20 70 72 65 76 69 6f 75 73 20 72 65 the previous re
0df0: 63 6f 72 64 20 66 6f 72 20 77 68 65 6e 20 74 68 cord for when th
0e00: 69 73 20 74 65 73 74 20 77 61 73 20 72 75 6e 20 is test was run
0e10: 77 68 65 72 65 20 61 6c 6c 20 6b 65 79 73 20 6d where all keys m
0e20: 61 74 63 68 20 62 75 74 20 72 75 6e 6e 61 6d 65 atch but runname
0e30: 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 3a 67 .(define (test:g
0e40: 65 74 2d 70 72 65 76 69 6f 75 73 2d 74 65 73 74 et-previous-test
0e50: 2d 72 75 6e 2d 72 65 63 6f 72 64 73 20 64 62 20 -run-records db
0e60: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
0e70: 20 69 74 65 6d 2d 70 61 74 68 29 0a 20 20 28 6c item-path). (l
0e80: 65 74 2a 20 28 28 6b 65 79 73 20 20 20 20 28 64 et* ((keys (d
0e90: 62 3a 67 65 74 2d 6b 65 79 73 20 64 62 29 29 0a b:get-keys db)).
0ea0: 09 20 28 73 65 6c 73 74 72 20 20 28 73 74 72 69 . (selstr (stri
0eb0: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 ng-intersperse (
0ec0: 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 78 29 28 map (lambda (x)(
0ed0: 76 65 63 74 6f 72 2d 72 65 66 20 78 20 30 29 29 vector-ref x 0))
0ee0: 20 6b 65 79 73 29 20 22 2c 22 29 29 0a 09 20 28 keys) ",")).. (
0ef0: 71 72 79 73 74 72 20 20 28 73 74 72 69 6e 67 2d qrystr (string-
0f00: 69 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 intersperse (map
0f10: 20 28 6c 61 6d 62 64 61 20 28 78 29 28 63 6f 6e (lambda (x)(con
0f20: 63 20 28 76 65 63 74 6f 72 2d 72 65 66 20 78 20 c (vector-ref x
0f30: 30 29 20 22 3d 3f 22 29 29 20 6b 65 79 73 29 20 0) "=?")) keys)
0f40: 22 20 41 4e 44 20 22 29 29 0a 09 20 28 6b 65 79 " AND ")).. (key
0f50: 76 61 6c 73 20 23 66 29 29 0a 20 20 20 20 3b 3b vals #f)). ;;
0f60: 20 66 69 72 73 74 20 6c 6f 6f 6b 20 75 70 20 74 first look up t
0f70: 68 65 20 6b 65 79 20 76 61 6c 75 65 73 20 66 72 he key values fr
0f80: 6f 6d 20 74 68 65 20 72 75 6e 20 73 65 6c 65 63 om the run selec
0f90: 74 65 64 20 62 79 20 72 75 6e 2d 69 64 0a 20 20 ted by run-id.
0fa0: 20 20 28 73 71 6c 69 74 65 33 3a 66 6f 72 2d 65 (sqlite3:for-e
0fb0: 61 63 68 2d 72 6f 77 20 0a 20 20 20 20 20 28 6c ach-row . (l
0fc0: 61 6d 62 64 61 20 28 61 20 2e 20 62 29 0a 20 20 ambda (a . b).
0fd0: 20 20 20 20 20 28 73 65 74 21 20 6b 65 79 76 61 (set! keyva
0fe0: 6c 73 20 28 63 6f 6e 73 20 61 20 62 29 29 29 0a ls (cons a b))).
0ff0: 20 20 20 20 20 64 62 0a 20 20 20 20 20 28 63 6f db. (co
1000: 6e 63 20 22 53 45 4c 45 43 54 20 22 20 73 65 6c nc "SELECT " sel
1010: 73 74 72 20 22 20 46 52 4f 4d 20 72 75 6e 73 20 str " FROM runs
1020: 57 48 45 52 45 20 72 75 6e 5f 69 64 3d 3f 20 4f WHERE run_id=? O
1030: 52 44 45 52 20 42 59 20 65 76 65 6e 74 5f 74 69 RDER BY event_ti
1040: 6d 65 20 44 45 53 43 3b 22 29 29 0a 20 20 20 20 me DESC;")).
1050: 28 69 66 20 28 6e 6f 74 20 6b 65 79 76 61 6c 73 (if (not keyvals
1060: 29 0a 09 23 66 0a 09 28 6c 65 74 20 28 28 70 72 )..#f..(let ((pr
1070: 65 76 2d 72 75 6e 2d 69 64 73 20 27 28 29 29 29 ev-run-ids '()))
1080: 0a 09 20 20 28 61 70 70 6c 79 20 73 71 6c 69 74 .. (apply sqlit
1090: 65 33 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 0a e3:for-each-row.
10a0: 09 09 20 28 6c 61 6d 62 64 61 20 28 69 64 29 0a .. (lambda (id).
10b0: 09 09 20 20 20 28 73 65 74 21 20 70 72 65 76 2d .. (set! prev-
10c0: 72 75 6e 2d 69 64 73 20 28 63 6f 6e 73 20 69 64 run-ids (cons id
10d0: 20 70 72 65 76 2d 72 75 6e 2d 69 64 73 29 29 29 prev-run-ids)))
10e0: 0a 09 09 20 64 62 0a 09 09 20 28 63 6f 6e 63 20 ... db... (conc
10f0: 22 53 45 4c 45 43 54 20 72 75 6e 5f 69 64 20 46 "SELECT run_id F
1100: 52 4f 4d 20 72 75 6e 73 20 57 48 45 52 45 20 22 ROM runs WHERE "
1110: 20 71 72 79 73 74 72 20 22 3b 22 29 29 0a 09 20 qrystr ";"))..
1120: 20 3b 3b 20 66 6f 72 20 65 61 63 68 20 72 75 6e ;; for each run
1130: 20 73 74 61 72 74 69 6e 67 20 77 69 74 68 20 74 starting with t
1140: 68 65 20 6d 6f 73 74 20 72 65 63 65 6e 74 20 6c he most recent l
1150: 6f 6f 6b 20 74 6f 20 73 65 65 20 69 66 20 74 68 ook to see if th
1160: 65 72 65 20 69 73 20 61 20 6d 61 74 63 68 69 6e ere is a matchin
1170: 67 20 74 65 73 74 0a 09 20 20 3b 3b 20 69 66 20 g test.. ;; if
1180: 66 6f 75 6e 64 20 74 68 65 6e 20 72 65 74 75 72 found then retur
1190: 6e 20 74 68 61 74 20 6d 61 74 63 68 69 6e 67 20 n that matching
11a0: 74 65 73 74 20 72 65 63 6f 72 64 0a 09 20 20 28 test record.. (
11b0: 69 66 20 28 6e 75 6c 6c 3f 20 70 72 65 76 2d 72 if (null? prev-r
11c0: 75 6e 2d 69 64 73 29 20 23 66 0a 09 20 20 20 20 un-ids) #f..
11d0: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 (let loop ((he
11e0: 64 20 28 63 61 72 20 70 72 65 76 2d 72 75 6e 2d d (car prev-run-
11f0: 69 64 73 29 29 0a 09 09 09 20 28 74 61 6c 20 28 ids)).... (tal (
1200: 63 64 72 20 70 72 65 76 2d 72 75 6e 2d 69 64 73 cdr prev-run-ids
1210: 29 29 29 0a 09 09 28 6c 65 74 20 28 28 72 65 73 )))...(let ((res
1220: 75 6c 74 73 20 28 64 62 2d 67 65 74 2d 74 65 73 ults (db-get-tes
1230: 74 73 2d 66 6f 72 2d 72 75 6e 20 64 62 20 74 65 ts-for-run db te
1240: 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 st-name item-pat
1250: 68 29 29 29 0a 09 09 20 20 28 69 66 20 28 61 6e h)))... (if (an
1260: 64 20 28 6e 75 6c 6c 3f 20 72 65 73 75 6c 74 73 d (null? results
1270: 29 0a 09 09 09 20 20 20 28 6e 6f 74 20 28 6e 75 ).... (not (nu
1280: 6c 6c 3f 20 74 61 6c 29 29 29 0a 09 09 20 20 20 ll? tal)))...
1290: 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 (loop (car ta
12a0: 6c 29 28 63 64 72 20 74 61 6c 29 29 0a 09 09 20 l)(cdr tal))...
12b0: 20 20 20 20 20 28 63 61 72 20 72 65 73 75 6c 74 (car result
12c0: 73 29 29 29 29 29 29 29 29 29 0a 20 20 20 20 0a s))))))))). .
12d0: 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 2d 73 .(define (test-s
12e0: 65 74 2d 73 74 61 74 75 73 21 20 64 62 20 72 75 et-status! db ru
12f0: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 73 n-id test-name s
1300: 74 61 74 65 20 73 74 61 74 75 73 20 69 74 65 6d tate status item
1310: 64 61 74 2d 6f 72 2d 70 61 74 68 20 63 6f 6d 6d dat-or-path comm
1320: 65 6e 74 20 64 61 74 29 0a 20 20 28 6c 65 74 20 ent dat). (let
1330: 28 28 72 65 61 6c 2d 73 74 61 74 75 73 20 73 74 ((real-status st
1340: 61 74 75 73 29 0a 09 28 69 74 65 6d 2d 70 61 74 atus)..(item-pat
1350: 68 20 20 20 28 69 66 20 28 73 74 72 69 6e 67 3f h (if (string?
1360: 20 69 74 65 6d 64 61 74 2d 6f 72 2d 70 61 74 68 itemdat-or-path
1370: 29 20 69 74 65 6d 64 61 74 2d 6f 72 2d 70 61 74 ) itemdat-or-pat
1380: 68 20 28 69 74 65 6d 2d 6c 69 73 74 2d 3e 70 61 h (item-list->pa
1390: 74 68 20 69 74 65 6d 64 61 74 2d 6f 72 2d 70 61 th itemdat-or-pa
13a0: 74 68 29 29 29 0a 09 28 6f 74 68 65 72 64 61 74 th)))..(otherdat
13b0: 20 20 20 20 28 69 66 20 64 61 74 20 64 61 74 20 (if dat dat
13c0: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
13d0: 29 29 29 0a 09 3b 3b 20 62 65 66 6f 72 65 20 70 )))..;; before p
13e0: 72 6f 63 65 65 64 69 6e 67 20 77 65 20 6d 75 73 roceeding we mus
13f0: 74 20 66 69 6e 64 20 6f 75 74 20 69 66 20 74 68 t find out if th
1400: 65 20 70 72 65 76 69 6f 75 73 20 74 65 73 74 20 e previous test
1410: 28 77 68 65 72 65 20 61 6c 6c 20 6b 65 79 73 20 (where all keys
1420: 6d 61 74 63 68 65 64 20 65 78 63 65 70 74 20 72 matched except r
1430: 75 6e 6e 61 6d 65 29 0a 09 3b 3b 20 77 61 73 20 unname)..;; was
1440: 57 41 49 56 45 44 20 69 66 20 74 68 69 73 20 74 WAIVED if this t
1450: 65 73 74 20 69 73 20 46 41 49 4c 0a 09 28 77 61 est is FAIL..(wa
1460: 69 76 65 64 20 20 20 28 69 66 20 28 65 71 75 61 ived (if (equa
1470: 6c 3f 20 73 74 61 74 75 73 20 22 46 41 49 4c 22 l? status "FAIL"
1480: 29 0a 09 09 20 20 20 20 20 20 28 6c 65 74 20 28 )... (let (
1490: 28 70 72 65 76 2d 74 65 73 74 20 28 74 65 73 74 (prev-test (test
14a0: 3a 67 65 74 2d 70 72 65 76 69 6f 75 73 2d 74 65 :get-previous-te
14b0: 73 74 2d 72 75 6e 2d 72 65 63 6f 72 64 73 20 64 st-run-records d
14c0: 62 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 b run-id test-na
14d0: 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 29 0a me item-path))).
14e0: 09 09 09 28 69 66 20 28 61 6e 64 20 70 72 65 76 ...(if (and prev
14f0: 2d 74 65 73 74 20 28 6e 6f 74 20 28 6e 75 6c 6c -test (not (null
1500: 3f 20 70 72 65 76 2d 74 65 73 74 29 29 29 20 3b ? prev-test))) ;
1510: 3b 20 74 72 75 65 20 69 66 20 77 65 20 66 6f 75 ; true if we fou
1520: 6e 64 20 61 20 70 72 65 76 69 6f 75 73 20 74 65 nd a previous te
1530: 73 74 20 69 6e 20 74 68 69 73 20 72 75 6e 20 73 st in this run s
1540: 65 72 69 65 73 0a 09 09 09 20 20 20 20 28 6c 65 eries.... (le
1550: 74 20 28 28 70 72 65 76 2d 73 74 61 74 75 73 20 t ((prev-status
1560: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 (db:test-get-sta
1570: 74 75 73 20 20 20 70 72 65 76 2d 74 65 73 74 29 tus prev-test)
1580: 29 0a 09 09 09 09 20 20 28 70 72 65 76 2d 73 74 )..... (prev-st
1590: 61 74 65 20 20 28 64 62 3a 74 65 73 74 2d 67 65 ate (db:test-ge
15a0: 74 2d 73 74 61 74 65 20 20 20 20 70 72 65 76 2d t-state prev-
15b0: 74 65 73 74 29 29 0a 09 09 09 09 20 20 28 70 72 test))..... (pr
15c0: 65 76 2d 63 6f 6d 6d 65 6e 74 20 28 64 62 3a 74 ev-comment (db:t
15d0: 65 73 74 2d 67 65 74 2d 63 6f 6d 6d 65 6e 74 20 est-get-comment
15e0: 70 72 65 76 2d 74 65 73 74 29 29 29 0a 09 09 09 prev-test)))....
15f0: 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 (if (and (
1600: 65 71 75 61 6c 3f 20 70 72 65 76 2d 73 74 61 74 equal? prev-stat
1610: 75 73 20 22 43 4f 4d 50 4c 45 54 45 44 22 29 0a us "COMPLETED").
1620: 09 09 09 09 20 20 20 20 20 20 20 28 65 71 75 61 .... (equa
1630: 6c 3f 20 70 72 65 76 2d 73 74 61 74 65 20 20 22 l? prev-state "
1640: 57 41 49 56 45 44 22 29 29 0a 09 09 09 09 20 20 WAIVED")).....
1650: 70 72 65 76 2d 63 6f 6d 6d 65 6e 74 20 3b 3b 20 prev-comment ;;
1660: 77 61 69 76 65 64 20 69 73 20 65 69 74 68 65 72 waived is either
1670: 20 74 68 65 20 63 6f 6d 6d 65 6e 74 20 6f 72 20 the comment or
1680: 23 66 0a 09 09 09 09 20 20 23 66 29 29 0a 09 09 #f..... #f))...
1690: 09 20 20 20 20 23 66 29 29 0a 09 09 20 20 20 20 . #f))...
16a0: 20 20 23 66 29 29 29 0a 0a 20 20 20 20 28 69 66 #f))).. (if
16b0: 20 77 61 69 76 65 64 20 28 73 65 74 21 20 72 65 waived (set! re
16c0: 61 6c 2d 73 74 61 74 75 73 20 22 57 41 49 56 45 al-status "WAIVE
16d0: 44 22 29 29 0a 0a 20 20 20 20 3b 3b 20 75 70 64 D")).. ;; upd
16e0: 61 74 65 20 74 68 65 20 70 72 69 6d 61 72 79 20 ate the primary
16f0: 72 65 63 6f 72 64 20 49 46 20 73 74 61 74 65 20 record IF state
1700: 41 4e 44 20 73 74 61 74 75 73 20 61 72 65 20 64 AND status are d
1710: 65 66 69 6e 65 64 0a 20 20 20 20 28 69 66 20 28 efined. (if (
1720: 61 6e 64 20 73 74 61 74 65 20 73 74 61 74 75 73 and state status
1730: 29 0a 09 28 73 71 6c 69 74 65 33 3a 65 78 65 63 )..(sqlite3:exec
1740: 75 74 65 20 64 62 20 22 55 50 44 41 54 45 20 74 ute db "UPDATE t
1750: 65 73 74 73 20 53 45 54 20 73 74 61 74 65 3d 3f ests SET state=?
1760: 2c 73 74 61 74 75 73 3d 3f 2c 65 76 65 6e 74 5f ,status=?,event_
1770: 74 69 6d 65 3d 73 74 72 66 74 69 6d 65 28 27 25 time=strftime('%
1780: 73 27 2c 27 6e 6f 77 27 29 20 57 48 45 52 45 20 s','now') WHERE
1790: 72 75 6e 5f 69 64 3d 3f 20 41 4e 44 20 74 65 73 run_id=? AND tes
17a0: 74 6e 61 6d 65 3d 3f 20 41 4e 44 20 69 74 65 6d tname=? AND item
17b0: 5f 70 61 74 68 3d 3f 3b 22 20 0a 09 09 09 20 73 _path=?;" .... s
17c0: 74 61 74 65 20 73 74 61 74 75 73 20 72 75 6e 2d tate status run-
17d0: 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 id test-name ite
17e0: 6d 2d 70 61 74 68 29 29 0a 20 20 20 20 3b 3b 20 m-path)). ;;
17f0: 61 64 64 20 6d 65 74 61 64 61 74 61 20 28 6e 65 add metadata (ne
1800: 65 64 20 74 6f 20 64 6f 20 74 68 69 73 20 77 61 ed to do this wa
1810: 79 20 74 6f 20 61 76 6f 69 64 20 53 51 4c 20 69 y to avoid SQL i
1820: 6e 6a 65 63 74 69 6f 6e 20 69 73 73 75 65 73 29 njection issues)
1830: 0a 20 20 20 20 3b 3b 20 3a 76 61 6c 75 65 0a 20 . ;; :value.
1840: 20 20 20 28 6c 65 74 20 28 28 76 61 6c 20 28 68 (let ((val (h
1850: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
1860: 66 61 75 6c 74 20 6f 74 68 65 72 64 61 74 20 22 fault otherdat "
1870: 3a 76 61 6c 75 65 22 20 23 66 29 29 29 0a 20 20 :value" #f))).
1880: 20 20 20 20 28 69 66 20 76 61 6c 0a 09 20 20 28 (if val.. (
1890: 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 sqlite3:execute
18a0: 64 62 20 22 55 50 44 41 54 45 20 74 65 73 74 73 db "UPDATE tests
18b0: 20 53 45 54 20 76 61 6c 75 65 3d 3f 20 57 48 45 SET value=? WHE
18c0: 52 45 20 72 75 6e 5f 69 64 3d 3f 20 41 4e 44 20 RE run_id=? AND
18d0: 74 65 73 74 6e 61 6d 65 3d 3f 20 41 4e 44 20 69 testname=? AND i
18e0: 74 65 6d 5f 70 61 74 68 3d 3f 3b 22 20 76 61 6c tem_path=?;" val
18f0: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
1900: 65 20 69 74 65 6d 2d 70 61 74 68 29 29 29 0a 20 e item-path))).
1910: 20 20 20 3b 3b 20 3a 65 78 70 65 63 74 65 64 5f ;; :expected_
1920: 76 61 6c 75 65 0a 20 20 20 20 28 6c 65 74 20 28 value. (let (
1930: 28 76 61 6c 20 28 68 61 73 68 2d 74 61 62 6c 65 (val (hash-table
1940: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 6f 74 68 -ref/default oth
1950: 65 72 64 61 74 20 22 3a 65 78 70 65 63 74 65 64 erdat ":expected
1960: 5f 76 61 6c 75 65 22 20 23 66 29 29 29 0a 20 20 _value" #f))).
1970: 20 20 20 20 28 69 66 20 76 61 6c 0a 09 20 20 28 (if val.. (
1980: 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 sqlite3:execute
1990: 64 62 20 22 55 50 44 41 54 45 20 74 65 73 74 73 db "UPDATE tests
19a0: 20 53 45 54 20 65 78 70 65 63 74 65 64 5f 76 61 SET expected_va
19b0: 6c 75 65 3d 3f 20 57 48 45 52 45 20 72 75 6e 5f lue=? WHERE run_
19c0: 69 64 3d 3f 20 41 4e 44 20 74 65 73 74 6e 61 6d id=? AND testnam
19d0: 65 3d 3f 20 41 4e 44 20 69 74 65 6d 5f 70 61 74 e=? AND item_pat
19e0: 68 3d 3f 3b 22 20 76 61 6c 20 72 75 6e 2d 69 64 h=?;" val run-id
19f0: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item-
1a00: 70 61 74 68 29 29 29 0a 20 20 20 20 3b 3b 20 3a path))). ;; :
1a10: 74 6f 6c 0a 20 20 20 20 28 6c 65 74 20 28 28 76 tol. (let ((v
1a20: 61 6c 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 al (hash-table-r
1a30: 65 66 2f 64 65 66 61 75 6c 74 20 6f 74 68 65 72 ef/default other
1a40: 64 61 74 20 22 3a 74 6f 6c 22 20 23 66 29 29 29 dat ":tol" #f)))
1a50: 0a 20 20 20 20 20 20 28 69 66 20 76 61 6c 0a 09 . (if val..
1a60: 20 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 (sqlite3:execu
1a70: 74 65 20 64 62 20 22 55 50 44 41 54 45 20 74 65 te db "UPDATE te
1a80: 73 74 73 20 53 45 54 20 74 6f 6c 3d 3f 20 57 48 sts SET tol=? WH
1a90: 45 52 45 20 72 75 6e 5f 69 64 3d 3f 20 41 4e 44 ERE run_id=? AND
1aa0: 20 74 65 73 74 6e 61 6d 65 3d 3f 20 41 4e 44 20 testname=? AND
1ab0: 69 74 65 6d 5f 70 61 74 68 3d 3f 3b 22 20 76 61 item_path=?;" va
1ac0: 6c 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 l run-id test-na
1ad0: 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 29 0a me item-path))).
1ae0: 20 20 20 20 3b 3b 20 3a 66 69 72 73 74 5f 65 72 ;; :first_er
1af0: 72 0a 20 20 20 20 28 6c 65 74 20 28 28 76 61 6c r. (let ((val
1b00: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
1b10: 2f 64 65 66 61 75 6c 74 20 6f 74 68 65 72 64 61 /default otherda
1b20: 74 20 22 3a 66 69 72 73 74 5f 65 72 72 22 20 23 t ":first_err" #
1b30: 66 29 29 29 0a 20 20 20 20 20 20 28 69 66 20 76 f))). (if v
1b40: 61 6c 0a 09 20 20 28 73 71 6c 69 74 65 33 3a 65 al.. (sqlite3:e
1b50: 78 65 63 75 74 65 20 64 62 20 22 55 50 44 41 54 xecute db "UPDAT
1b60: 45 20 74 65 73 74 73 20 53 45 54 20 66 69 72 73 E tests SET firs
1b70: 74 5f 65 72 72 3d 3f 20 57 48 45 52 45 20 72 75 t_err=? WHERE ru
1b80: 6e 5f 69 64 3d 3f 20 41 4e 44 20 74 65 73 74 6e n_id=? AND testn
1b90: 61 6d 65 3d 3f 20 41 4e 44 20 69 74 65 6d 5f 70 ame=? AND item_p
1ba0: 61 74 68 3d 3f 3b 22 20 76 61 6c 20 72 75 6e 2d ath=?;" val run-
1bb0: 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 id test-name ite
1bc0: 6d 2d 70 61 74 68 29 29 29 0a 20 20 20 20 3b 3b m-path))). ;;
1bd0: 20 3a 66 69 72 73 74 5f 77 61 72 6e 0a 20 20 20 :first_warn.
1be0: 20 28 6c 65 74 20 28 28 76 61 6c 20 28 68 61 73 (let ((val (has
1bf0: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
1c00: 75 6c 74 20 6f 74 68 65 72 64 61 74 20 22 3a 66 ult otherdat ":f
1c10: 69 72 73 74 5f 77 61 72 6e 22 20 23 66 29 29 29 irst_warn" #f)))
1c20: 0a 20 20 20 20 20 20 28 69 66 20 76 61 6c 0a 09 . (if val..
1c30: 20 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 (sqlite3:execu
1c40: 74 65 20 64 62 20 22 55 50 44 41 54 45 20 74 65 te db "UPDATE te
1c50: 73 74 73 20 53 45 54 20 66 69 72 73 74 5f 77 61 sts SET first_wa
1c60: 72 6e 3d 3f 20 57 48 45 52 45 20 72 75 6e 5f 69 rn=? WHERE run_i
1c70: 64 3d 3f 20 41 4e 44 20 74 65 73 74 6e 61 6d 65 d=? AND testname
1c80: 3d 3f 20 41 4e 44 20 69 74 65 6d 5f 70 61 74 68 =? AND item_path
1c90: 3d 3f 3b 22 20 76 61 6c 20 72 75 6e 2d 69 64 20 =?;" val run-id
1ca0: 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 test-name item-p
1cb0: 61 74 68 29 29 29 0a 20 20 20 20 28 6c 65 74 20 ath))). (let
1cc0: 28 28 76 61 6c 20 28 68 61 73 68 2d 74 61 62 6c ((val (hash-tabl
1cd0: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 6f 74 e-ref/default ot
1ce0: 68 65 72 64 61 74 20 22 3a 75 6e 69 74 73 22 20 herdat ":units"
1cf0: 23 66 29 29 29 0a 20 20 20 20 20 20 28 69 66 20 #f))). (if
1d00: 76 61 6c 0a 09 20 20 28 73 71 6c 69 74 65 33 3a val.. (sqlite3:
1d10: 65 78 65 63 75 74 65 20 64 62 20 22 55 50 44 41 execute db "UPDA
1d20: 54 45 20 74 65 73 74 73 20 53 45 54 20 75 6e 69 TE tests SET uni
1d30: 74 73 3d 3f 20 57 48 45 52 45 20 72 75 6e 5f 69 ts=? WHERE run_i
1d40: 64 3d 3f 20 41 4e 44 20 74 65 73 74 6e 61 6d 65 d=? AND testname
1d50: 3d 3f 20 41 4e 44 20 69 74 65 6d 5f 70 61 74 68 =? AND item_path
1d60: 3d 3f 3b 22 20 76 61 6c 20 72 75 6e 2d 69 64 20 =?;" val run-id
1d70: 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 test-name item-p
1d80: 61 74 68 29 29 29 0a 20 20 20 20 3b 3b 20 3a 74 ath))). ;; :t
1d90: 6f 6c 5f 70 65 72 63 0a 20 20 20 20 28 6c 65 74 ol_perc. (let
1da0: 20 28 28 76 61 6c 20 28 68 61 73 68 2d 74 61 62 ((val (hash-tab
1db0: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 6f le-ref/default o
1dc0: 74 68 65 72 64 61 74 20 22 3a 74 6f 6c 5f 70 65 therdat ":tol_pe
1dd0: 72 63 22 20 23 66 29 29 29 0a 20 20 20 20 20 20 rc" #f))).
1de0: 28 69 66 20 76 61 6c 0a 09 20 20 28 73 71 6c 69 (if val.. (sqli
1df0: 74 65 33 3a 65 78 65 63 75 74 65 20 64 62 20 22 te3:execute db "
1e00: 55 50 44 41 54 45 20 74 65 73 74 73 20 53 45 54 UPDATE tests SET
1e10: 20 74 6f 6c 5f 70 65 72 63 3d 3f 20 57 48 45 52 tol_perc=? WHER
1e20: 45 20 72 75 6e 5f 69 64 3d 3f 20 41 4e 44 20 74 E run_id=? AND t
1e30: 65 73 74 6e 61 6d 65 3d 3f 20 41 4e 44 20 69 74 estname=? AND it
1e40: 65 6d 5f 70 61 74 68 3d 3f 3b 22 20 76 61 6c 20 em_path=?;" val
1e50: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
1e60: 20 69 74 65 6d 2d 70 61 74 68 29 29 29 0a 0a 20 item-path)))..
1e70: 20 20 20 3b 3b 20 6e 65 65 64 20 74 6f 20 75 70 ;; need to up
1e80: 64 61 74 65 20 74 68 65 20 74 6f 70 20 74 65 73 date the top tes
1e90: 74 20 72 65 63 6f 72 64 20 69 66 20 50 41 53 53 t record if PASS
1ea0: 20 6f 72 20 46 41 49 4c 20 61 6e 64 20 74 68 69 or FAIL and thi
1eb0: 73 20 69 73 20 61 20 73 75 62 74 65 73 74 0a 20 s is a subtest.
1ec0: 20 20 20 28 69 66 20 28 61 6e 64 20 28 6e 6f 74 (if (and (not
1ed0: 20 28 65 71 75 61 6c 3f 20 69 74 65 6d 2d 70 61 (equal? item-pa
1ee0: 74 68 20 22 22 29 29 0a 09 20 20 20 20 20 28 6f th "")).. (o
1ef0: 72 20 28 65 71 75 61 6c 3f 20 73 74 61 74 75 73 r (equal? status
1f00: 20 22 50 41 53 53 22 29 0a 09 09 20 28 65 71 75 "PASS")... (equ
1f10: 61 6c 3f 20 73 74 61 74 75 73 20 22 57 41 52 4e al? status "WARN
1f20: 22 29 0a 09 09 20 28 65 71 75 61 6c 3f 20 73 74 ")... (equal? st
1f30: 61 74 75 73 20 22 46 41 49 4c 22 29 29 29 0a 09 atus "FAIL")))..
1f40: 28 62 65 67 69 6e 0a 09 20 20 28 73 71 6c 69 74 (begin.. (sqlit
1f50: 65 33 3a 65 78 65 63 75 74 65 20 0a 09 20 20 20 e3:execute ..
1f60: 64 62 0a 09 20 20 20 22 55 50 44 41 54 45 20 74 db.. "UPDATE t
1f70: 65 73 74 73 20 0a 20 20 20 20 20 20 20 20 20 20 ests .
1f80: 20 20 20 53 45 54 20 66 61 69 6c 5f 63 6f 75 6e SET fail_coun
1f90: 74 3d 28 53 45 4c 45 43 54 20 63 6f 75 6e 74 28 t=(SELECT count(
1fa0: 69 64 29 20 46 52 4f 4d 20 74 65 73 74 73 20 57 id) FROM tests W
1fb0: 48 45 52 45 20 72 75 6e 5f 69 64 3d 3f 20 41 4e HERE run_id=? AN
1fc0: 44 20 74 65 73 74 6e 61 6d 65 3d 3f 20 41 4e 44 D testname=? AND
1fd0: 20 69 74 65 6d 5f 70 61 74 68 20 21 3d 20 27 27 item_path != ''
1fe0: 20 41 4e 44 20 73 74 61 74 75 73 3d 27 46 41 49 AND status='FAI
1ff0: 4c 27 29 2c 0a 20 20 20 20 20 20 20 20 20 20 20 L'),.
2000: 20 20 20 20 20 20 70 61 73 73 5f 63 6f 75 6e 74 pass_count
2010: 3d 28 53 45 4c 45 43 54 20 63 6f 75 6e 74 28 69 =(SELECT count(i
2020: 64 29 20 46 52 4f 4d 20 74 65 73 74 73 20 57 48 d) FROM tests WH
2030: 45 52 45 20 72 75 6e 5f 69 64 3d 3f 20 41 4e 44 ERE run_id=? AND
2040: 20 74 65 73 74 6e 61 6d 65 3d 3f 20 41 4e 44 20 testname=? AND
2050: 69 74 65 6d 5f 70 61 74 68 20 21 3d 20 27 27 20 item_path != ''
2060: 41 4e 44 20 28 73 74 61 74 75 73 3d 27 50 41 53 AND (status='PAS
2070: 53 27 20 4f 52 20 73 74 61 74 75 73 3d 27 57 41 S' OR status='WA
2080: 52 4e 27 29 29 0a 20 20 20 20 20 20 20 20 20 20 RN')).
2090: 20 20 20 57 48 45 52 45 20 72 75 6e 5f 69 64 3d WHERE run_id=
20a0: 3f 20 41 4e 44 20 74 65 73 74 6e 61 6d 65 3d 3f ? AND testname=?
20b0: 20 41 4e 44 20 69 74 65 6d 5f 70 61 74 68 3d 27 AND item_path='
20c0: 27 3b 22 0a 09 20 20 20 72 75 6e 2d 69 64 20 74 ';".. run-id t
20d0: 65 73 74 2d 6e 61 6d 65 20 72 75 6e 2d 69 64 20 est-name run-id
20e0: 74 65 73 74 2d 6e 61 6d 65 20 72 75 6e 2d 69 64 test-name run-id
20f0: 20 74 65 73 74 2d 6e 61 6d 65 29 0a 09 20 20 28 test-name).. (
2100: 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 0a sqlite3:execute.
2110: 09 20 20 20 64 62 0a 09 20 20 20 22 55 50 44 41 . db.. "UPDA
2120: 54 45 20 74 65 73 74 73 0a 20 20 20 20 20 20 20 TE tests.
2130: 20 20 20 20 20 20 53 45 54 20 73 74 61 74 65 3d SET state=
2140: 43 41 53 45 20 57 48 45 4e 20 28 53 45 4c 45 43 CASE WHEN (SELEC
2150: 54 20 63 6f 75 6e 74 28 69 64 29 20 46 52 4f 4d T count(id) FROM
2160: 20 74 65 73 74 73 20 57 48 45 52 45 20 72 75 6e tests WHERE run
2170: 5f 69 64 3d 3f 20 41 4e 44 20 74 65 73 74 6e 61 _id=? AND testna
2180: 6d 65 3d 3f 20 41 4e 44 20 69 74 65 6d 5f 70 61 me=? AND item_pa
2190: 74 68 20 21 3d 20 27 27 20 41 4e 44 20 73 74 61 th != '' AND sta
21a0: 74 65 20 69 6e 20 28 27 52 55 4e 4e 49 4e 47 27 te in ('RUNNING'
21b0: 2c 27 4e 4f 54 5f 53 54 41 52 54 45 44 27 29 29 ,'NOT_STARTED'))
21c0: 20 3e 20 30 20 54 48 45 4e 20 0a 20 20 20 20 20 > 0 THEN .
21d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
21e0: 20 20 20 20 20 27 52 55 4e 4e 49 4e 47 27 0a 20 'RUNNING'.
21f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2200: 20 20 20 20 20 20 45 4c 53 45 20 27 43 4f 4d 50 ELSE 'COMP
2210: 4c 45 54 45 44 27 20 45 4e 44 2c 0a 20 20 20 20 LETED' END,.
2220: 20 20 20 20 20 20 20 20 20 20 20 20 73 74 61 74 stat
2230: 75 73 3d 43 41 53 45 20 57 48 45 4e 20 66 61 69 us=CASE WHEN fai
2240: 6c 5f 63 6f 75 6e 74 20 3e 20 30 20 54 48 45 4e l_count > 0 THEN
2250: 20 27 46 41 49 4c 27 20 57 48 45 4e 20 70 61 73 'FAIL' WHEN pas
2260: 73 5f 63 6f 75 6e 74 20 3e 20 30 20 41 4e 44 20 s_count > 0 AND
2270: 66 61 69 6c 5f 63 6f 75 6e 74 3d 30 20 54 48 45 fail_count=0 THE
2280: 4e 20 27 50 41 53 53 27 20 45 4c 53 45 20 27 55 N 'PASS' ELSE 'U
2290: 4e 4b 4e 4f 57 4e 27 20 45 4e 44 0a 20 20 20 20 NKNOWN' END.
22a0: 20 20 20 20 20 20 20 20 20 57 48 45 52 45 20 72 WHERE r
22b0: 75 6e 5f 69 64 3d 3f 20 41 4e 44 20 74 65 73 74 un_id=? AND test
22c0: 6e 61 6d 65 3d 3f 20 41 4e 44 20 69 74 65 6d 5f name=? AND item_
22d0: 70 61 74 68 3d 27 27 3b 22 0a 09 20 20 20 72 75 path='';".. ru
22e0: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 72 n-id test-name r
22f0: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 29 un-id test-name)
2300: 29 29 0a 20 20 20 20 28 69 66 20 28 6f 72 20 28 )). (if (or (
2310: 61 6e 64 20 28 73 74 72 69 6e 67 3f 20 63 6f 6d and (string? com
2320: 6d 65 6e 74 29 0a 09 09 20 28 73 74 72 69 6e 67 ment)... (string
2330: 2d 6d 61 74 63 68 20 28 72 65 67 65 78 70 20 22 -match (regexp "
2340: 5c 5c 53 2b 22 29 20 63 6f 6d 6d 65 6e 74 29 29 \\S+") comment))
2350: 0a 09 20 20 20 20 77 61 69 76 65 64 29 0a 09 28 .. waived)..(
2360: 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 sqlite3:execute
2370: 64 62 20 22 55 50 44 41 54 45 20 74 65 73 74 73 db "UPDATE tests
2380: 20 53 45 54 20 63 6f 6d 6d 65 6e 74 3d 3f 20 57 SET comment=? W
2390: 48 45 52 45 20 72 75 6e 5f 69 64 3d 3f 20 41 4e HERE run_id=? AN
23a0: 44 20 74 65 73 74 6e 61 6d 65 3d 3f 20 41 4e 44 D testname=? AND
23b0: 20 69 74 65 6d 5f 70 61 74 68 3d 3f 3b 22 0a 09 item_path=?;"..
23c0: 09 09 20 28 69 66 20 77 61 69 76 65 64 20 77 61 .. (if waived wa
23d0: 69 76 65 64 20 63 6f 6d 6d 65 6e 74 29 20 72 75 ived comment) ru
23e0: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 n-id test-name i
23f0: 74 65 6d 2d 70 61 74 68 29 29 0a 20 20 20 20 29 tem-path)). )
2400: 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 )..(define (test
2410: 2d 73 65 74 2d 6c 6f 67 21 20 64 62 20 72 75 6e -set-log! db run
2420: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 -id test-name it
2430: 65 6d 64 61 74 20 6c 6f 67 66 29 20 0a 20 20 28 emdat logf) . (
2440: 6c 65 74 20 28 28 69 74 65 6d 2d 70 61 74 68 20 let ((item-path
2450: 28 69 74 65 6d 2d 6c 69 73 74 2d 3e 70 61 74 68 (item-list->path
2460: 20 69 74 65 6d 64 61 74 29 29 29 0a 20 20 20 20 itemdat))).
2470: 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 (sqlite3:execute
2480: 20 64 62 20 22 55 50 44 41 54 45 20 74 65 73 74 db "UPDATE test
2490: 73 20 53 45 54 20 66 69 6e 61 6c 5f 6c 6f 67 66 s SET final_logf
24a0: 3d 3f 20 57 48 45 52 45 20 72 75 6e 5f 69 64 3d =? WHERE run_id=
24b0: 3f 20 41 4e 44 20 74 65 73 74 6e 61 6d 65 3d 3f ? AND testname=?
24c0: 20 41 4e 44 20 69 74 65 6d 5f 70 61 74 68 3d 3f AND item_path=?
24d0: 3b 22 20 0a 09 09 20 20 20 20 20 6c 6f 67 66 20 ;" ... logf
24e0: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
24f0: 20 69 74 65 6d 2d 70 61 74 68 29 29 29 0a 0a 28 item-path)))..(
2500: 64 65 66 69 6e 65 20 28 74 65 73 74 2d 73 65 74 define (test-set
2510: 2d 74 6f 70 6c 6f 67 21 20 64 62 20 72 75 6e 2d -toplog! db run-
2520: 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 6c 6f 67 id test-name log
2530: 66 29 20 0a 20 20 28 73 71 6c 69 74 65 33 3a 65 f) . (sqlite3:e
2540: 78 65 63 75 74 65 20 64 62 20 22 55 50 44 41 54 xecute db "UPDAT
2550: 45 20 74 65 73 74 73 20 53 45 54 20 66 69 6e 61 E tests SET fina
2560: 6c 5f 6c 6f 67 66 3d 3f 20 57 48 45 52 45 20 72 l_logf=? WHERE r
2570: 75 6e 5f 69 64 3d 3f 20 41 4e 44 20 74 65 73 74 un_id=? AND test
2580: 6e 61 6d 65 3d 3f 20 41 4e 44 20 69 74 65 6d 5f name=? AND item_
2590: 70 61 74 68 3d 27 27 3b 22 20 0a 09 09 20 20 20 path='';" ...
25a0: 6c 6f 67 66 20 72 75 6e 2d 69 64 20 74 65 73 74 logf run-id test
25b0: 2d 6e 61 6d 65 29 29 0a 0a 28 64 65 66 69 6e 65 -name))..(define
25c0: 20 28 74 65 73 74 73 3a 73 75 6d 6d 61 72 69 7a (tests:summariz
25d0: 65 2d 69 74 65 6d 73 20 64 62 20 72 75 6e 2d 69 e-items db run-i
25e0: 64 20 74 65 73 74 2d 6e 61 6d 65 20 66 6f 72 63 d test-name forc
25f0: 65 29 0a 20 20 3b 3b 20 69 66 20 6e 6f 74 20 66 e). ;; if not f
2600: 6f 72 63 65 20 74 68 65 6e 20 6f 6e 6c 79 20 75 orce then only u
2610: 70 64 61 74 65 20 74 68 65 20 72 65 63 6f 72 64 pdate the record
2620: 20 69 66 20 6f 6e 65 20 6f 66 20 74 68 65 73 65 if one of these
2630: 20 69 73 20 74 72 75 65 3a 0a 20 20 3b 3b 20 20 is true:. ;;
2640: 20 31 2e 20 6c 6f 67 66 20 69 73 20 22 6c 6f 67 1. logf is "log
2650: 2f 66 69 6e 61 6c 2e 6c 6f 67 0a 20 20 3b 3b 20 /final.log. ;;
2660: 20 20 32 2e 20 6c 6f 67 66 20 69 73 20 73 61 6d 2. logf is sam
2670: 65 20 61 73 20 6f 75 74 70 75 74 66 69 6c 65 6e e as outputfilen
2680: 61 6d 65 0a 20 20 28 6c 65 74 20 28 28 6f 75 74 ame. (let ((out
2690: 70 75 74 66 69 6c 65 6e 61 6d 65 20 28 63 6f 6e putfilename (con
26a0: 63 20 22 6d 65 67 61 74 65 73 74 2d 72 6f 6c 6c c "megatest-roll
26b0: 75 70 2d 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 up-" test-name "
26c0: 2e 68 74 6d 6c 22 29 29 0a 09 28 6f 72 69 67 2d .html"))..(orig-
26d0: 64 69 72 20 20 20 20 20 20 20 28 63 75 72 72 65 dir (curre
26e0: 6e 74 2d 64 69 72 65 63 74 6f 72 79 29 29 0a 09 nt-directory))..
26f0: 28 6c 6f 67 66 20 20 20 20 20 20 20 20 20 20 20 (logf
2700: 23 66 29 29 0a 20 20 20 20 28 73 71 6c 69 74 65 #f)). (sqlite
2710: 33 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 0a 3:for-each-row .
2720: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 70 61 (lambda (pa
2730: 74 68 20 66 69 6e 61 6c 5f 6c 6f 67 66 29 0a 20 th final_logf).
2740: 20 20 20 20 20 20 28 73 65 74 21 20 6c 6f 67 66 (set! logf
2750: 20 66 69 6e 61 6c 5f 6c 6f 67 66 29 0a 20 20 20 final_logf).
2760: 20 20 20 20 28 69 66 20 28 64 69 72 65 63 74 6f (if (directo
2770: 72 79 3f 20 70 61 74 68 29 0a 09 20 20 20 28 62 ry? path).. (b
2780: 65 67 69 6e 0a 09 20 20 20 20 20 28 70 72 69 6e egin.. (prin
2790: 74 20 22 46 6f 75 6e 64 20 70 61 74 68 3a 20 22 t "Found path: "
27a0: 20 70 61 74 68 29 0a 09 20 20 20 20 20 28 63 68 path).. (ch
27b0: 61 6e 67 65 2d 64 69 72 65 63 74 6f 72 79 20 70 ange-directory p
27c0: 61 74 68 29 29 0a 09 20 20 20 20 20 3b 3b 20 28 ath)).. ;; (
27d0: 73 65 74 21 20 6f 75 74 70 75 74 66 69 6c 65 6e set! outputfilen
27e0: 61 6d 65 20 28 63 6f 6e 63 20 70 61 74 68 20 22 ame (conc path "
27f0: 2f 22 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d /" outputfilenam
2800: 65 29 29 29 0a 09 20 20 20 28 70 72 69 6e 74 20 e))).. (print
2810: 22 4e 6f 20 73 75 63 68 20 70 61 74 68 3a 20 22 "No such path: "
2820: 20 70 61 74 68 29 29 29 0a 20 20 20 20 20 64 62 path))). db
2830: 20 0a 20 20 20 20 20 22 53 45 4c 45 43 54 20 72 . "SELECT r
2840: 75 6e 64 69 72 2c 66 69 6e 61 6c 5f 6c 6f 67 66 undir,final_logf
2850: 20 46 52 4f 4d 20 74 65 73 74 73 20 57 48 45 52 FROM tests WHER
2860: 45 20 72 75 6e 5f 69 64 3d 3f 20 41 4e 44 20 74 E run_id=? AND t
2870: 65 73 74 6e 61 6d 65 3d 3f 20 41 4e 44 20 69 74 estname=? AND it
2880: 65 6d 5f 70 61 74 68 3d 27 27 3b 22 0a 20 20 20 em_path='';".
2890: 20 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 run-id test-na
28a0: 6d 65 29 0a 20 20 20 20 28 70 72 69 6e 74 20 22 me). (print "
28b0: 73 75 6d 6d 61 72 69 7a 65 2d 69 74 65 6d 73 20 summarize-items
28c0: 77 69 74 68 20 6c 6f 67 66 20 22 20 6c 6f 67 66 with logf " logf
28d0: 29 0a 20 20 20 20 28 69 66 20 28 6f 72 20 28 65 ). (if (or (e
28e0: 71 75 61 6c 3f 20 6c 6f 67 66 20 22 6c 6f 67 73 qual? logf "logs
28f0: 2f 66 69 6e 61 6c 2e 6c 6f 67 22 29 0a 09 20 20 /final.log")..
2900: 20 20 28 65 71 75 61 6c 3f 20 6c 6f 67 66 20 6f (equal? logf o
2910: 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 29 0a 09 utputfilename)..
2920: 20 20 20 20 66 6f 72 63 65 29 0a 09 28 62 65 67 force)..(beg
2930: 69 6e 0a 09 20 20 28 69 66 20 28 6f 62 74 61 69 in.. (if (obtai
2940: 6e 2d 64 6f 74 2d 6c 6f 63 6b 20 6f 75 74 70 75 n-dot-lock outpu
2950: 74 66 69 6c 65 6e 61 6d 65 20 31 20 32 30 20 33 tfilename 1 20 3
2960: 30 29 20 3b 3b 20 72 65 74 72 79 20 65 76 65 72 0) ;; retry ever
2970: 79 20 73 65 63 6f 6e 64 20 66 6f 72 20 32 30 20 y second for 20
2980: 73 65 63 6f 6e 64 73 2c 20 63 61 6c 6c 20 69 74 seconds, call it
2990: 20 64 65 61 64 20 61 66 74 65 72 20 33 30 20 73 dead after 30 s
29a0: 65 63 6f 6e 64 73 20 61 6e 64 20 73 74 65 61 6c econds and steal
29b0: 20 74 68 65 20 6c 6f 63 6b 0a 09 20 20 20 20 20 the lock..
29c0: 20 28 70 72 69 6e 74 20 22 4f 62 74 61 69 6e 65 (print "Obtaine
29d0: 64 20 6c 6f 63 6b 20 66 6f 72 20 22 20 6f 75 74 d lock for " out
29e0: 70 75 74 66 69 6c 65 6e 61 6d 65 29 0a 09 20 20 putfilename)..
29f0: 20 20 20 20 28 70 72 69 6e 74 20 22 46 61 69 6c (print "Fail
2a00: 65 64 20 74 6f 20 6f 62 74 61 69 6e 20 6c 6f 63 ed to obtain loc
2a10: 6b 20 66 6f 72 20 22 20 6f 75 74 70 75 74 66 69 k for " outputfi
2a20: 6c 65 6e 61 6d 65 29 29 0a 09 20 20 28 6c 65 74 lename)).. (let
2a30: 20 28 28 6f 75 70 20 20 20 20 28 6f 70 65 6e 2d ((oup (open-
2a40: 6f 75 74 70 75 74 2d 66 69 6c 65 20 6f 75 74 70 output-file outp
2a50: 75 74 66 69 6c 65 6e 61 6d 65 29 29 0a 09 09 28 utfilename))...(
2a60: 63 6f 75 6e 74 73 20 28 6d 61 6b 65 2d 68 61 73 counts (make-has
2a70: 68 2d 74 61 62 6c 65 29 29 0a 09 09 28 73 74 61 h-table))...(sta
2a80: 74 65 63 6f 75 6e 74 73 20 28 6d 61 6b 65 2d 68 tecounts (make-h
2a90: 61 73 68 2d 74 61 62 6c 65 29 29 0a 09 09 28 6f ash-table))...(o
2aa0: 75 74 74 78 74 20 22 22 29 0a 09 09 28 74 6f 74 uttxt "")...(tot
2ab0: 20 20 20 20 30 29 29 0a 09 20 20 20 20 28 77 69 0)).. (wi
2ac0: 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 70 6f 72 th-output-to-por
2ad0: 74 0a 09 09 6f 75 70 0a 09 20 20 20 20 20 20 28 t...oup.. (
2ae0: 6c 61 6d 62 64 61 20 28 29 0a 09 09 28 73 65 74 lambda ()...(set
2af0: 21 20 6f 75 74 74 78 74 20 28 63 6f 6e 63 20 6f ! outtxt (conc o
2b00: 75 74 74 78 74 20 22 3c 68 74 6d 6c 3e 3c 74 69 uttxt "<html><ti
2b10: 74 6c 65 3e 53 75 6d 6d 61 72 79 3a 20 22 20 74 tle>Summary: " t
2b20: 65 73 74 2d 6e 61 6d 65 20 0a 09 09 09 09 20 20 est-name .....
2b30: 20 22 3c 2f 74 69 74 6c 65 3e 3c 62 6f 64 79 3e "</title><body>
2b40: 3c 68 32 3e 53 75 6d 6d 61 72 79 20 66 6f 72 20 <h2>Summary for
2b50: 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 3c 2f 68 " test-name "</h
2b60: 32 3e 22 29 29 0a 09 09 28 73 71 6c 69 74 65 33 2>"))...(sqlite3
2b70: 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 0a 09 :for-each-row ..
2b80: 09 20 28 6c 61 6d 62 64 61 20 28 69 64 20 69 74 . (lambda (id it
2b90: 65 6d 70 61 74 68 20 73 74 61 74 65 20 73 74 61 empath state sta
2ba0: 74 75 73 20 72 75 6e 5f 64 75 72 61 74 69 6f 6e tus run_duration
2bb0: 20 6c 6f 67 66 20 63 6f 6d 6d 65 6e 74 29 0a 09 logf comment)..
2bc0: 09 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d . (hash-table-
2bd0: 73 65 74 21 20 63 6f 75 6e 74 73 20 73 74 61 74 set! counts stat
2be0: 75 73 20 28 2b 20 31 20 28 68 61 73 68 2d 74 61 us (+ 1 (hash-ta
2bf0: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
2c00: 63 6f 75 6e 74 73 20 73 74 61 74 75 73 20 30 29 counts status 0)
2c10: 29 29 0a 09 09 20 20 20 28 68 61 73 68 2d 74 61 ))... (hash-ta
2c20: 62 6c 65 2d 73 65 74 21 20 73 74 61 74 65 63 6f ble-set! stateco
2c30: 75 6e 74 73 20 73 74 61 74 65 20 28 2b 20 31 20 unts state (+ 1
2c40: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
2c50: 64 65 66 61 75 6c 74 20 73 74 61 74 65 63 6f 75 default statecou
2c60: 6e 74 73 20 73 74 61 74 65 20 30 29 29 29 0a 09 nts state 0)))..
2c70: 09 20 20 20 28 73 65 74 21 20 6f 75 74 74 78 74 . (set! outtxt
2c80: 20 28 63 6f 6e 63 20 6f 75 74 74 78 74 20 22 3c (conc outtxt "<
2c90: 74 72 3e 22 0a 09 09 09 09 20 20 20 20 20 20 22 tr>"..... "
2ca0: 3c 74 64 3e 3c 61 20 68 72 65 66 3d 5c 22 22 20 <td><a href=\""
2cb0: 69 74 65 6d 70 61 74 68 20 22 2f 22 20 6c 6f 67 itempath "/" log
2cc0: 66 20 22 5c 22 3e 20 22 20 69 74 65 6d 70 61 74 f "\"> " itempat
2cd0: 68 20 22 3c 2f 61 3e 3c 2f 74 64 3e 22 20 0a 09 h "</a></td>" ..
2ce0: 09 09 09 20 20 20 20 20 20 22 3c 74 64 3e 22 20 ... "<td>"
2cf0: 73 74 61 74 65 20 20 20 20 22 3c 2f 74 64 3e 22 state "</td>"
2d00: 20 0a 09 09 09 09 20 20 20 20 20 20 22 3c 74 64 ..... "<td
2d10: 3e 3c 66 6f 6e 74 20 63 6f 6c 6f 72 3d 22 20 28 ><font color=" (
2d20: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 6f 6c 6f 72 common:get-color
2d30: 2d 66 72 6f 6d 2d 73 74 61 74 75 73 20 73 74 61 -from-status sta
2d40: 74 75 73 29 0a 09 09 09 09 20 20 20 20 20 20 22 tus)..... "
2d50: 3e 22 20 20 20 73 74 61 74 75 73 20 20 20 22 3c >" status "<
2d60: 2f 66 6f 6e 74 3e 3c 2f 74 64 3e 22 0a 09 09 09 /font></td>"....
2d70: 09 20 20 20 20 20 20 22 3c 74 64 3e 22 20 28 69 . "<td>" (i
2d80: 66 20 28 65 71 75 61 6c 3f 20 63 6f 6d 6d 65 6e f (equal? commen
2d90: 74 20 22 22 29 0a 09 09 09 09 09 09 20 22 26 6e t "")....... "&n
2da0: 62 73 70 3b 22 0a 09 09 09 09 09 09 20 63 6f 6d bsp;"....... com
2db0: 6d 65 6e 74 29 20 22 3c 2f 74 64 3e 22 0a 09 09 ment) "</td>"...
2dc0: 09 09 09 09 20 22 3c 2f 74 72 3e 22 29 29 29 0a .... "</tr>"))).
2dd0: 09 09 20 64 62 0a 09 09 20 22 53 45 4c 45 43 54 .. db... "SELECT
2de0: 20 69 64 2c 69 74 65 6d 5f 70 61 74 68 2c 73 74 id,item_path,st
2df0: 61 74 65 2c 73 74 61 74 75 73 2c 72 75 6e 5f 64 ate,status,run_d
2e00: 75 72 61 74 69 6f 6e 2c 66 69 6e 61 6c 5f 6c 6f uration,final_lo
2e10: 67 66 2c 63 6f 6d 6d 65 6e 74 20 46 52 4f 4d 20 gf,comment FROM
2e20: 74 65 73 74 73 20 57 48 45 52 45 20 72 75 6e 5f tests WHERE run_
2e30: 69 64 3d 3f 20 41 4e 44 20 74 65 73 74 6e 61 6d id=? AND testnam
2e40: 65 3d 3f 20 41 4e 44 20 69 74 65 6d 5f 70 61 74 e=? AND item_pat
2e50: 68 20 21 3d 20 27 27 3b 22 0a 09 09 20 72 75 6e h != '';"... run
2e60: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 29 0a 0a -id test-name)..
2e70: 09 09 28 70 72 69 6e 74 20 22 3c 74 61 62 6c 65 ..(print "<table
2e80: 3e 3c 74 72 3e 3c 74 64 20 76 61 6c 69 67 6e 3d ><tr><td valign=
2e90: 5c 22 74 6f 70 5c 22 3e 22 29 0a 09 09 3b 3b 20 \"top\">")...;;
2ea0: 50 72 69 6e 74 20 6f 75 74 20 73 74 61 74 73 20 Print out stats
2eb0: 66 6f 72 20 73 74 61 74 75 73 0a 09 09 28 73 65 for status...(se
2ec0: 74 21 20 74 6f 74 20 30 29 0a 09 09 28 70 72 69 t! tot 0)...(pri
2ed0: 6e 74 20 22 3c 74 61 62 6c 65 20 63 65 6c 6c 73 nt "<table cells
2ee0: 70 61 63 69 6e 67 3d 5c 22 30 5c 22 20 62 6f 72 pacing=\"0\" bor
2ef0: 64 65 72 3d 5c 22 31 5c 22 3e 3c 74 72 3e 3c 74 der=\"1\"><tr><t
2f00: 64 20 63 6f 6c 73 70 61 6e 3d 5c 22 32 5c 22 3e d colspan=\"2\">
2f10: 3c 68 32 3e 53 74 61 74 65 20 73 74 61 74 73 3c <h2>State stats<
2f20: 2f 68 32 3e 3c 2f 74 64 3e 3c 2f 74 72 3e 22 29 /h2></td></tr>")
2f30: 0a 09 09 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 ...(for-each (la
2f40: 6d 62 64 61 20 28 73 74 61 74 65 29 0a 09 09 09 mbda (state)....
2f50: 20 20 20 20 28 73 65 74 21 20 74 6f 74 20 28 2b (set! tot (+
2f60: 20 74 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 tot (hash-table
2f70: 2d 72 65 66 20 73 74 61 74 65 63 6f 75 6e 74 73 -ref statecounts
2f80: 20 73 74 61 74 65 29 29 29 0a 09 09 09 20 20 20 state)))....
2f90: 20 28 70 72 69 6e 74 20 22 3c 74 72 3e 3c 74 64 (print "<tr><td
2fa0: 3e 22 20 73 74 61 74 65 20 22 3c 2f 74 64 3e 3c >" state "</td><
2fb0: 74 64 3e 22 20 28 68 61 73 68 2d 74 61 62 6c 65 td>" (hash-table
2fc0: 2d 72 65 66 20 73 74 61 74 65 63 6f 75 6e 74 73 -ref statecounts
2fd0: 20 73 74 61 74 65 29 20 22 3c 2f 74 64 3e 3c 2f state) "</td></
2fe0: 74 72 3e 22 29 29 0a 09 09 09 20 20 28 68 61 73 tr>")).... (has
2ff0: 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 73 74 61 h-table-keys sta
3000: 74 65 63 6f 75 6e 74 73 29 29 0a 09 09 28 70 72 tecounts))...(pr
3010: 69 6e 74 20 22 3c 74 72 3e 3c 74 64 3e 54 6f 74 int "<tr><td>Tot
3020: 61 6c 3c 2f 74 64 3e 3c 74 64 3e 22 20 74 6f 74 al</td><td>" tot
3030: 20 22 3c 2f 74 64 3e 3c 2f 74 72 3e 3c 2f 74 61 "</td></tr></ta
3040: 62 6c 65 3e 22 29 0a 09 09 28 70 72 69 6e 74 20 ble>")...(print
3050: 22 3c 2f 74 64 3e 3c 74 64 20 76 61 6c 69 67 6e "</td><td valign
3060: 3d 5c 22 74 6f 70 5c 22 3e 22 29 0a 09 09 3b 3b =\"top\">")...;;
3070: 20 50 72 69 6e 74 20 6f 75 74 20 73 74 61 74 73 Print out stats
3080: 20 66 6f 72 20 73 74 61 74 65 0a 09 09 28 73 65 for state...(se
3090: 74 21 20 74 6f 74 20 30 29 0a 09 09 28 70 72 69 t! tot 0)...(pri
30a0: 6e 74 20 22 3c 74 61 62 6c 65 20 63 65 6c 6c 73 nt "<table cells
30b0: 70 61 63 69 6e 67 3d 5c 22 30 5c 22 20 62 6f 72 pacing=\"0\" bor
30c0: 64 65 72 3d 5c 22 31 5c 22 3e 3c 74 72 3e 3c 74 der=\"1\"><tr><t
30d0: 64 20 63 6f 6c 73 70 61 6e 3d 5c 22 32 5c 22 3e d colspan=\"2\">
30e0: 3c 68 32 3e 53 74 61 74 75 73 20 73 74 61 74 73 <h2>Status stats
30f0: 3c 2f 68 32 3e 3c 2f 74 64 3e 3c 2f 74 72 3e 22 </h2></td></tr>"
3100: 29 0a 09 09 28 66 6f 72 2d 65 61 63 68 20 28 6c )...(for-each (l
3110: 61 6d 62 64 61 20 28 73 74 61 74 75 73 29 0a 09 ambda (status)..
3120: 09 09 20 20 20 20 28 73 65 74 21 20 74 6f 74 20 .. (set! tot
3130: 28 2b 20 74 6f 74 20 28 68 61 73 68 2d 74 61 62 (+ tot (hash-tab
3140: 6c 65 2d 72 65 66 20 63 6f 75 6e 74 73 20 73 74 le-ref counts st
3150: 61 74 75 73 29 29 29 0a 09 09 09 20 20 20 20 28 atus))).... (
3160: 70 72 69 6e 74 20 22 3c 74 72 3e 3c 74 64 3e 3c print "<tr><td><
3170: 66 6f 6e 74 20 63 6f 6c 6f 72 3d 5c 22 22 20 28 font color=\"" (
3180: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 6f 6c 6f 72 common:get-color
3190: 2d 66 72 6f 6d 2d 73 74 61 74 75 73 20 73 74 61 -from-status sta
31a0: 74 75 73 29 20 22 5c 22 3e 22 20 73 74 61 74 75 tus) "\">" statu
31b0: 73 0a 09 09 09 09 20 20 20 22 3c 2f 66 6f 6e 74 s..... "</font
31c0: 3e 3c 2f 74 64 3e 3c 74 64 3e 22 20 28 68 61 73 ></td><td>" (has
31d0: 68 2d 74 61 62 6c 65 2d 72 65 66 20 63 6f 75 6e h-table-ref coun
31e0: 74 73 20 73 74 61 74 75 73 29 20 22 3c 2f 74 64 ts status) "</td
31f0: 3e 3c 2f 74 72 3e 22 29 29 0a 09 09 09 20 20 28 ></tr>")).... (
3200: 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 hash-table-keys
3210: 63 6f 75 6e 74 73 29 29 0a 09 09 28 70 72 69 6e counts))...(prin
3220: 74 20 22 3c 74 72 3e 3c 74 64 3e 54 6f 74 61 6c t "<tr><td>Total
3230: 3c 2f 74 64 3e 3c 74 64 3e 22 20 74 6f 74 20 22 </td><td>" tot "
3240: 3c 2f 74 64 3e 3c 2f 74 72 3e 3c 2f 74 61 62 6c </td></tr></tabl
3250: 65 3e 22 29 0a 09 09 28 70 72 69 6e 74 20 22 3c e>")...(print "<
3260: 2f 74 64 3e 3c 2f 74 64 3e 3c 2f 74 72 3e 3c 2f /td></td></tr></
3270: 74 61 62 6c 65 3e 22 29 0a 0a 09 09 28 70 72 69 table>")....(pri
3280: 6e 74 20 22 3c 74 61 62 6c 65 20 63 65 6c 6c 73 nt "<table cells
3290: 70 61 63 69 6e 67 3d 5c 22 30 5c 22 20 62 6f 72 pacing=\"0\" bor
32a0: 64 65 72 3d 5c 22 31 5c 22 3e 22 20 0a 09 09 20 der=\"1\">" ...
32b0: 20 20 20 20 20 20 22 3c 74 72 3e 3c 74 64 3e 49 "<tr><td>I
32c0: 74 65 6d 3c 2f 74 64 3e 3c 74 64 3e 53 74 61 74 tem</td><td>Stat
32d0: 65 3c 2f 74 64 3e 3c 74 64 3e 53 74 61 74 75 73 e</td><td>Status
32e0: 3c 2f 74 64 3e 3c 74 64 3e 43 6f 6d 6d 65 6e 74 </td><td>Comment
32f0: 3c 2f 74 64 3e 22 0a 09 09 20 20 20 20 20 20 20 </td>"...
3300: 6f 75 74 74 78 74 20 22 3c 2f 74 61 62 6c 65 3e outtxt "</table>
3310: 3c 2f 62 6f 64 79 3e 3c 2f 68 74 6d 6c 3e 22 29 </body></html>")
3320: 0a 09 09 28 72 65 6c 65 61 73 65 2d 64 6f 74 2d ...(release-dot-
3330: 6c 6f 63 6b 20 6f 75 74 70 75 74 66 69 6c 65 6e lock outputfilen
3340: 61 6d 65 29 29 29 0a 09 20 20 20 20 28 63 6c 6f ame))).. (clo
3350: 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 6f se-output-port o
3360: 75 70 29 0a 09 20 20 20 20 28 63 68 61 6e 67 65 up).. (change
3370: 2d 64 69 72 65 63 74 6f 72 79 20 6f 72 69 67 2d -directory orig-
3380: 64 69 72 29 0a 09 20 20 20 20 28 74 65 73 74 2d dir).. (test-
3390: 73 65 74 2d 74 6f 70 6c 6f 67 21 20 64 62 20 72 set-toplog! db r
33a0: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 un-id test-name
33b0: 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 29 0a outputfilename).
33c0: 09 20 20 20 20 29 29 29 29 29 0a 0a 3b 3b 20 3b . )))))..;; ;
33d0: 3b 20 54 4f 44 4f 3a 20 43 6f 6e 76 65 72 67 65 ; TODO: Converge
33e0: 20 74 68 69 73 20 77 69 74 68 20 64 62 3a 67 65 this with db:ge
33f0: 74 2d 74 65 73 74 2d 69 6e 66 6f 0a 3b 3b 20 28 t-test-info.;; (
3400: 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 67 65 74 define (runs:get
3410: 2d 74 65 73 74 2d 69 6e 66 6f 20 64 62 20 72 75 -test-info db ru
3420: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 n-id test-name i
3430: 74 65 6d 2d 70 61 74 68 29 0a 3b 3b 20 20 20 28 tem-path).;; (
3440: 6c 65 74 20 28 28 72 65 73 20 23 66 29 29 20 3b let ((res #f)) ;
3450: 3b 20 28 76 65 63 74 6f 72 20 23 66 20 23 66 20 ; (vector #f #f
3460: 23 66 20 23 66 20 23 66 20 23 66 29 29 29 0a 3b #f #f #f #f))).;
3470: 3b 20 20 20 20 20 28 73 71 6c 69 74 65 33 3a 66 ; (sqlite3:f
3480: 6f 72 2d 65 61 63 68 2d 72 6f 77 20 0a 3b 3b 20 or-each-row .;;
3490: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 69 64 (lambda (id
34a0: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
34b0: 65 20 73 74 61 74 65 20 73 74 61 74 75 73 29 0a e state status).
34c0: 3b 3b 20 20 20 20 20 20 20 20 28 73 65 74 21 20 ;; (set!
34d0: 72 65 73 20 28 76 65 63 74 6f 72 20 69 64 20 72 res (vector id r
34e0: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 un-id test-name
34f0: 73 74 61 74 65 20 73 74 61 74 75 73 20 69 74 65 state status ite
3500: 6d 2d 70 61 74 68 29 29 29 0a 3b 3b 20 20 20 20 m-path))).;;
3510: 20 20 64 62 20 22 53 45 4c 45 43 54 20 69 64 2c db "SELECT id,
3520: 72 75 6e 5f 69 64 2c 74 65 73 74 6e 61 6d 65 2c run_id,testname,
3530: 73 74 61 74 65 2c 73 74 61 74 75 73 20 46 52 4f state,status FRO
3540: 4d 20 74 65 73 74 73 20 57 48 45 52 45 20 72 75 M tests WHERE ru
3550: 6e 5f 69 64 3d 3f 20 41 4e 44 20 74 65 73 74 6e n_id=? AND testn
3560: 61 6d 65 3d 3f 20 41 4e 44 20 69 74 65 6d 5f 70 ame=? AND item_p
3570: 61 74 68 3d 3f 3b 22 0a 3b 3b 20 20 20 20 20 20 ath=?;".;;
3580: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
3590: 20 69 74 65 6d 2d 70 61 74 68 29 0a 3b 3b 20 20 item-path).;;
35a0: 20 20 20 72 65 73 29 29 0a 0a 28 64 65 66 69 6e res))..(defin
35b0: 65 2d 69 6e 6c 69 6e 65 20 28 74 65 73 74 3a 67 e-inline (test:g
35c0: 65 74 2d 69 64 20 76 65 63 29 20 20 20 20 20 20 et-id vec)
35d0: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 76 65 63 (vector-ref vec
35e0: 20 30 29 29 0a 28 64 65 66 69 6e 65 2d 69 6e 6c 0)).(define-inl
35f0: 69 6e 65 20 28 74 65 73 74 3a 67 65 74 2d 72 75 ine (test:get-ru
3600: 6e 5f 69 64 20 76 65 63 29 20 20 20 28 76 65 63 n_id vec) (vec
3610: 74 6f 72 2d 72 65 66 20 76 65 63 20 31 29 29 0a tor-ref vec 1)).
3620: 28 64 65 66 69 6e 65 2d 69 6e 6c 69 6e 65 20 28 (define-inline (
3630: 74 65 73 74 3a 67 65 74 2d 74 65 73 74 2d 6e 61 test:get-test-na
3640: 6d 65 20 76 65 63 29 28 76 65 63 74 6f 72 2d 72 me vec)(vector-r
3650: 65 66 20 76 65 63 20 32 29 29 0a 28 64 65 66 69 ef vec 2)).(defi
3660: 6e 65 2d 69 6e 6c 69 6e 65 20 28 74 65 73 74 3a ne-inline (test:
3670: 67 65 74 2d 73 74 61 74 65 20 76 65 63 29 20 20 get-state vec)
3680: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 76 65 (vector-ref ve
3690: 63 20 33 29 29 0a 28 64 65 66 69 6e 65 2d 69 6e c 3)).(define-in
36a0: 6c 69 6e 65 20 28 74 65 73 74 3a 67 65 74 2d 73 line (test:get-s
36b0: 74 61 74 75 73 20 76 65 63 29 20 20 20 28 76 65 tatus vec) (ve
36c0: 63 74 6f 72 2d 72 65 66 20 76 65 63 20 34 29 29 ctor-ref vec 4))
36d0: 0a 28 64 65 66 69 6e 65 2d 69 6e 6c 69 6e 65 20 .(define-inline
36e0: 28 74 65 73 74 3a 67 65 74 2d 69 74 65 6d 2d 70 (test:get-item-p
36f0: 61 74 68 20 76 65 63 29 28 76 65 63 74 6f 72 2d ath vec)(vector-
3700: 72 65 66 20 76 65 63 20 35 29 29 0a 0a 28 64 65 ref vec 5))..(de
3710: 66 69 6e 65 20 28 72 75 6e 73 3a 74 65 73 74 2d fine (runs:test-
3720: 67 65 74 2d 66 75 6c 6c 2d 70 61 74 68 20 74 65 get-full-path te
3730: 73 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 74 65 st). (let* ((te
3740: 73 74 6e 61 6d 65 20 28 64 62 3a 74 65 73 74 2d stname (db:test-
3750: 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 20 20 74 get-testname t
3760: 65 73 74 29 29 0a 09 20 28 69 74 65 6d 70 61 74 est)).. (itempat
3770: 68 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 h (db:test-get-i
3780: 74 65 6d 2d 70 61 74 68 20 74 65 73 74 29 29 29 tem-path test)))
3790: 0a 20 20 20 20 28 63 6f 6e 63 20 74 65 73 74 6e . (conc testn
37a0: 61 6d 65 20 28 69 66 20 28 65 71 75 61 6c 3f 20 ame (if (equal?
37b0: 69 74 65 6d 70 61 74 68 20 22 22 29 20 22 22 20 itempath "") ""
37c0: 28 63 6f 6e 63 20 22 28 22 20 69 74 65 6d 70 61 (conc "(" itempa
37d0: 74 68 20 22 29 22 29 29 29 29 29 0a 0a 28 64 65 th ")")))))..(de
37e0: 66 69 6e 65 2d 69 6e 6c 69 6e 65 20 28 74 65 73 fine-inline (tes
37f0: 74 3a 74 65 73 74 2d 67 65 74 2d 66 75 6c 6c 6e t:test-get-fulln
3800: 61 6d 65 20 74 65 73 74 29 0a 20 20 20 28 63 6f ame test). (co
3810: 6e 63 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d nc (db:test-get-
3820: 74 65 73 74 6e 61 6d 65 20 74 65 73 74 29 0a 09 testname test)..
3830: 20 28 69 66 20 28 65 71 75 61 6c 3f 20 28 64 62 (if (equal? (db
3840: 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 :test-get-item-p
3850: 61 74 68 20 74 65 73 74 29 20 22 22 29 0a 09 20 ath test) "")..
3860: 20 20 20 20 22 22 0a 09 20 20 20 20 20 28 63 6f "".. (co
3870: 6e 63 20 22 28 22 20 28 64 62 3a 74 65 73 74 2d nc "(" (db:test-
3880: 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 65 get-item-path te
3890: 73 74 29 20 22 29 22 29 29 29 29 0a 0a 28 64 65 st) ")"))))..(de
38a0: 66 69 6e 65 20 28 63 68 65 63 6b 2d 76 61 6c 69 fine (check-vali
38b0: 64 2d 69 74 65 6d 73 20 63 6c 61 73 73 20 69 74 d-items class it
38c0: 65 6d 29 0a 20 20 28 6c 65 74 20 28 28 76 61 6c em). (let ((val
38d0: 69 64 2d 76 61 6c 75 65 73 20 28 6c 65 74 20 28 id-values (let (
38e0: 28 73 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 (s (config-looku
38f0: 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 76 p *configdat* "v
3900: 61 6c 69 64 76 61 6c 75 65 73 22 20 63 6c 61 73 alidvalues" clas
3910: 73 29 29 29 0a 09 09 09 28 69 66 20 73 20 28 73 s)))....(if s (s
3920: 74 72 69 6e 67 2d 73 70 6c 69 74 20 73 29 20 23 tring-split s) #
3930: 66 29 29 29 29 0a 20 20 20 20 28 69 66 20 76 61 f)))). (if va
3940: 6c 69 64 2d 76 61 6c 75 65 73 0a 09 28 69 66 20 lid-values..(if
3950: 28 6d 65 6d 62 65 72 20 69 74 65 6d 20 76 61 6c (member item val
3960: 69 64 2d 76 61 6c 75 65 73 29 0a 09 20 20 20 20 id-values)..
3970: 69 74 65 6d 20 23 66 29 0a 09 69 74 65 6d 29 29 item #f)..item))
3980: 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 )..(define (test
3990: 73 74 65 70 2d 73 65 74 2d 73 74 61 74 75 73 21 step-set-status!
39a0: 20 64 62 20 72 75 6e 2d 69 64 20 74 65 73 74 2d db run-id test-
39b0: 6e 61 6d 65 20 74 65 73 74 73 74 65 70 2d 6e 61 name teststep-na
39c0: 6d 65 20 73 74 61 74 65 2d 69 6e 20 73 74 61 74 me state-in stat
39d0: 75 73 2d 69 6e 20 69 74 65 6d 64 61 74 20 63 6f us-in itemdat co
39e0: 6d 6d 65 6e 74 29 0a 20 20 28 64 65 62 75 67 3a mment). (debug:
39f0: 70 72 69 6e 74 20 34 20 22 72 75 6e 2d 69 64 3a print 4 "run-id:
3a00: 20 22 20 72 75 6e 2d 69 64 20 22 20 74 65 73 74 " run-id " test
3a10: 2d 6e 61 6d 65 3a 20 22 20 74 65 73 74 2d 6e 61 -name: " test-na
3a20: 6d 65 29 0a 20 20 28 6c 65 74 2a 20 28 28 73 74 me). (let* ((st
3a30: 61 74 65 20 20 20 20 20 28 63 68 65 63 6b 2d 76 ate (check-v
3a40: 61 6c 69 64 2d 69 74 65 6d 73 20 22 73 74 61 74 alid-items "stat
3a50: 65 22 20 73 74 61 74 65 2d 69 6e 29 29 0a 09 20 e" state-in))..
3a60: 28 73 74 61 74 75 73 20 20 20 20 28 63 68 65 63 (status (chec
3a70: 6b 2d 76 61 6c 69 64 2d 69 74 65 6d 73 20 22 73 k-valid-items "s
3a80: 74 61 74 75 73 22 20 73 74 61 74 75 73 2d 69 6e tatus" status-in
3a90: 29 29 0a 09 20 28 69 74 65 6d 2d 70 61 74 68 20 )).. (item-path
3aa0: 28 69 74 65 6d 2d 6c 69 73 74 2d 3e 70 61 74 68 (item-list->path
3ab0: 20 69 74 65 6d 64 61 74 29 29 0a 09 20 28 74 65 itemdat)).. (te
3ac0: 73 74 64 61 74 20 20 20 28 64 62 3a 67 65 74 2d stdat (db:get-
3ad0: 74 65 73 74 2d 69 6e 66 6f 20 64 62 20 72 75 6e test-info db run
3ae0: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 -id test-name it
3af0: 65 6d 2d 70 61 74 68 29 29 29 0a 20 20 20 20 28 em-path))). (
3b00: 64 65 62 75 67 3a 70 72 69 6e 74 20 35 20 22 74 debug:print 5 "t
3b10: 65 73 74 64 61 74 3a 20 22 20 74 65 73 74 64 61 estdat: " testda
3b20: 74 29 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 t). (if (and
3b30: 74 65 73 74 64 61 74 20 3b 3b 20 69 66 20 74 68 testdat ;; if th
3b40: 65 20 73 65 63 74 69 6f 6e 20 65 78 69 73 74 73 e section exists
3b50: 20 74 68 65 6e 20 66 6f 72 63 65 20 73 70 65 63 then force spec
3b60: 69 66 69 63 61 74 69 6f 6e 20 42 55 47 2c 20 49 ification BUG, I
3b70: 20 64 6f 6e 27 74 20 6c 69 6b 65 20 68 6f 77 20 don't like how
3b80: 74 68 69 73 20 77 6f 72 6b 73 2e 0a 09 20 20 20 this works...
3b90: 20 20 28 6f 72 20 28 6e 6f 74 20 73 74 61 74 65 (or (not state
3ba0: 29 28 6e 6f 74 20 73 74 61 74 75 73 29 29 29 0a )(not status))).
3bb0: 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 .(debug:print 0
3bc0: 22 57 41 52 4e 49 4e 47 3a 20 49 6e 76 61 6c 69 "WARNING: Invali
3bd0: 64 20 22 20 28 69 66 20 73 74 61 74 75 73 20 22 d " (if status "
3be0: 73 74 61 74 75 73 22 20 22 73 74 61 74 65 22 29 status" "state")
3bf0: 0a 09 20 20 20 20 20 20 20 22 20 76 61 6c 75 65 .. " value
3c00: 20 5c 22 22 20 28 69 66 20 73 74 61 74 75 73 20 \"" (if status
3c10: 73 74 61 74 75 73 2d 69 6e 20 73 74 61 74 65 2d status-in state-
3c20: 69 6e 29 20 22 5c 22 2c 20 75 70 64 61 74 65 20 in) "\", update
3c30: 79 6f 75 72 20 76 61 6c 69 64 73 74 61 74 65 73 your validstates
3c40: 20 73 65 63 74 69 6f 6e 20 69 6e 20 6d 65 67 61 section in mega
3c50: 74 65 73 74 2e 63 6f 6e 66 69 67 22 29 29 0a 20 test.config")).
3c60: 20 20 20 28 69 66 20 74 65 73 74 64 61 74 0a 09 (if testdat..
3c70: 28 6c 65 74 20 28 28 74 65 73 74 2d 69 64 20 28 (let ((test-id (
3c80: 74 65 73 74 3a 67 65 74 2d 69 64 20 74 65 73 74 test:get-id test
3c90: 64 61 74 29 29 29 0a 09 20 20 28 73 71 6c 69 74 dat))).. (sqlit
3ca0: 65 33 3a 65 78 65 63 75 74 65 20 64 62 20 0a 09 e3:execute db ..
3cb0: 09 09 22 49 4e 53 45 52 54 20 4f 52 20 52 45 50 .."INSERT OR REP
3cc0: 4c 41 43 45 20 69 6e 74 6f 20 74 65 73 74 5f 73 LACE into test_s
3cd0: 74 65 70 73 20 28 74 65 73 74 5f 69 64 2c 73 74 teps (test_id,st
3ce0: 65 70 6e 61 6d 65 2c 73 74 61 74 65 2c 73 74 61 epname,state,sta
3cf0: 74 75 73 2c 65 76 65 6e 74 5f 74 69 6d 65 2c 63 tus,event_time,c
3d00: 6f 6d 6d 65 6e 74 29 20 56 41 4c 55 45 53 28 3f omment) VALUES(?
3d10: 2c 3f 2c 3f 2c 3f 2c 73 74 72 66 74 69 6d 65 28 ,?,?,?,strftime(
3d20: 27 25 73 27 2c 27 6e 6f 77 27 29 2c 3f 29 3b 22 '%s','now'),?);"
3d30: 0a 09 09 09 74 65 73 74 2d 69 64 20 74 65 73 74 ....test-id test
3d40: 73 74 65 70 2d 6e 61 6d 65 20 73 74 61 74 65 20 step-name state
3d50: 73 74 61 74 75 73 20 28 69 66 20 63 6f 6d 6d 65 status (if comme
3d60: 6e 74 20 63 6f 6d 6d 65 6e 74 20 22 22 29 29 29 nt comment "")))
3d70: 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 ..(debug:print 0
3d80: 20 22 45 52 52 4f 52 3a 20 43 61 6e 27 74 20 75 "ERROR: Can't u
3d90: 70 64 61 74 65 20 22 20 74 65 73 74 2d 6e 61 6d pdate " test-nam
3da0: 65 20 22 20 66 6f 72 20 72 75 6e 20 22 20 72 75 e " for run " ru
3db0: 6e 2d 69 64 20 22 20 2d 3e 20 6e 6f 20 73 75 63 n-id " -> no suc
3dc0: 68 20 74 65 73 74 20 69 6e 20 64 62 22 29 29 29 h test in db")))
3dd0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 )..(define (test
3de0: 2d 67 65 74 2d 6b 69 6c 6c 2d 72 65 71 75 65 73 -get-kill-reques
3df0: 74 20 64 62 20 72 75 6e 2d 69 64 20 74 65 73 74 t db run-id test
3e00: 2d 6e 61 6d 65 20 69 74 65 6d 64 61 74 29 0a 20 -name itemdat).
3e10: 20 28 6c 65 74 2a 20 28 28 69 74 65 6d 2d 70 61 (let* ((item-pa
3e20: 74 68 20 28 69 74 65 6d 2d 6c 69 73 74 2d 3e 70 th (item-list->p
3e30: 61 74 68 20 69 74 65 6d 64 61 74 29 29 0a 09 20 ath itemdat))..
3e40: 28 74 65 73 74 64 61 74 20 20 20 28 64 62 3a 67 (testdat (db:g
3e50: 65 74 2d 74 65 73 74 2d 69 6e 66 6f 20 64 62 20 et-test-info db
3e60: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
3e70: 20 69 74 65 6d 2d 70 61 74 68 29 29 29 0a 20 20 item-path))).
3e80: 20 20 28 65 71 75 61 6c 3f 20 28 74 65 73 74 3a (equal? (test:
3e90: 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 64 61 get-state testda
3ea0: 74 29 20 22 4b 49 4c 4c 52 45 51 22 29 29 29 0a t) "KILLREQ"))).
3eb0: 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 2d 73 .(define (test-s
3ec0: 65 74 2d 6d 65 74 61 2d 69 6e 66 6f 20 64 62 20 et-meta-info db
3ed0: 72 75 6e 2d 69 64 20 74 65 73 74 6e 61 6d 65 20 run-id testname
3ee0: 69 74 65 6d 64 61 74 29 0a 20 20 28 6c 65 74 20 itemdat). (let
3ef0: 28 28 69 74 65 6d 2d 70 61 74 68 20 28 69 74 65 ((item-path (ite
3f00: 6d 2d 6c 69 73 74 2d 3e 70 61 74 68 20 69 74 65 m-list->path ite
3f10: 6d 64 61 74 29 29 0a 09 28 63 70 75 6c 6f 61 64 mdat))..(cpuload
3f20: 20 20 28 67 65 74 2d 63 70 75 2d 6c 6f 61 64 29 (get-cpu-load)
3f30: 29 0a 09 28 68 6f 73 74 6e 61 6d 65 20 28 67 65 )..(hostname (ge
3f40: 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 0a 09 28 t-host-name))..(
3f50: 64 69 73 6b 66 72 65 65 20 28 67 65 74 2d 64 66 diskfree (get-df
3f60: 20 28 63 75 72 72 65 6e 74 2d 64 69 72 65 63 74 (current-direct
3f70: 6f 72 79 29 29 29 0a 09 28 75 6e 61 6d 65 20 20 ory)))..(uname
3f80: 20 20 28 67 65 74 2d 75 6e 61 6d 65 20 22 2d 73 (get-uname "-s
3f90: 72 76 70 69 6f 22 29 29 0a 09 28 72 75 6e 70 61 rvpio"))..(runpa
3fa0: 74 68 20 20 28 63 75 72 72 65 6e 74 2d 64 69 72 th (current-dir
3fb0: 65 63 74 6f 72 79 29 29 29 0a 20 20 20 20 28 73 ectory))). (s
3fc0: 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 64 qlite3:execute d
3fd0: 62 20 22 55 50 44 41 54 45 20 74 65 73 74 73 20 b "UPDATE tests
3fe0: 53 45 54 20 68 6f 73 74 3d 3f 2c 63 70 75 6c 6f SET host=?,cpulo
3ff0: 61 64 3d 3f 2c 64 69 73 6b 66 72 65 65 3d 3f 2c ad=?,diskfree=?,
4000: 75 6e 61 6d 65 3d 3f 2c 72 75 6e 64 69 72 3d 3f uname=?,rundir=?
4010: 20 57 48 45 52 45 20 72 75 6e 5f 69 64 3d 3f 20 WHERE run_id=?
4020: 41 4e 44 20 74 65 73 74 6e 61 6d 65 3d 3f 20 41 AND testname=? A
4030: 4e 44 20 69 74 65 6d 5f 70 61 74 68 3d 3f 3b 22 ND item_path=?;"
4040: 0a 09 09 20 20 68 6f 73 74 6e 61 6d 65 0a 09 09 ... hostname...
4050: 20 20 63 70 75 6c 6f 61 64 0a 09 09 20 20 64 69 cpuload... di
4060: 73 6b 66 72 65 65 0a 09 09 20 20 75 6e 61 6d 65 skfree... uname
4070: 0a 09 09 20 20 72 75 6e 70 61 74 68 0a 09 09 20 ... runpath...
4080: 20 72 75 6e 2d 69 64 0a 09 09 20 20 74 65 73 74 run-id... test
4090: 6e 61 6d 65 0a 09 09 20 20 69 74 65 6d 2d 70 61 name... item-pa
40a0: 74 68 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 th)))..(define (
40b0: 74 65 73 74 2d 75 70 64 61 74 65 2d 6d 65 74 61 test-update-meta
40c0: 2d 69 6e 66 6f 20 64 62 20 72 75 6e 2d 69 64 20 -info db run-id
40d0: 74 65 73 74 6e 61 6d 65 20 69 74 65 6d 64 61 74 testname itemdat
40e0: 20 6d 69 6e 75 74 65 73 29 0a 20 20 28 6c 65 74 minutes). (let
40f0: 20 28 28 69 74 65 6d 2d 70 61 74 68 20 28 69 74 ((item-path (it
4100: 65 6d 2d 6c 69 73 74 2d 3e 70 61 74 68 20 69 74 em-list->path it
4110: 65 6d 64 61 74 29 29 0a 09 28 63 70 75 6c 6f 61 emdat))..(cpuloa
4120: 64 20 20 28 67 65 74 2d 63 70 75 2d 6c 6f 61 64 d (get-cpu-load
4130: 29 29 0a 09 28 64 69 73 6b 66 72 65 65 20 28 67 ))..(diskfree (g
4140: 65 74 2d 64 66 20 28 63 75 72 72 65 6e 74 2d 64 et-df (current-d
4150: 69 72 65 63 74 6f 72 79 29 29 29 29 0a 20 20 20 irectory)))).
4160: 20 28 69 66 20 28 6e 6f 74 20 63 70 75 6c 6f 61 (if (not cpuloa
4170: 64 29 20 20 28 62 65 67 69 6e 20 28 64 65 62 75 d) (begin (debu
4180: 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 g:print 0 "WARNI
4190: 4e 47 3a 20 43 50 55 4c 4f 41 44 20 6e 6f 74 20 NG: CPULOAD not
41a0: 66 6f 75 6e 64 2e 22 29 20 20 28 73 65 74 21 20 found.") (set!
41b0: 63 70 75 6c 6f 61 64 20 22 6e 2f 61 22 29 29 29 cpuload "n/a")))
41c0: 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 64 69 . (if (not di
41d0: 73 6b 66 72 65 65 29 20 28 62 65 67 69 6e 20 28 skfree) (begin (
41e0: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 debug:print 0 "W
41f0: 41 52 4e 49 4e 47 3a 20 44 49 53 4b 46 52 45 45 ARNING: DISKFREE
4200: 20 6e 6f 74 20 66 6f 75 6e 64 2e 22 29 20 28 73 not found.") (s
4210: 65 74 21 20 64 69 73 6b 66 72 65 65 20 22 6e 2f et! diskfree "n/
4220: 61 22 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e a"))). (if (n
4230: 6f 74 20 69 74 65 6d 2d 70 61 74 68 29 28 62 65 ot item-path)(be
4240: 67 69 6e 20 28 64 65 62 75 67 3a 70 72 69 6e 74 gin (debug:print
4250: 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 49 54 45 0 "WARNING: ITE
4260: 4d 50 41 54 48 20 6e 6f 74 20 73 65 74 2e 22 29 MPATH not set.")
4270: 20 20 20 28 73 65 74 21 20 69 74 65 6d 2d 70 61 (set! item-pa
4280: 74 68 20 22 22 29 29 29 0a 20 20 20 20 3b 3b 20 th ""))). ;;
4290: 28 6c 65 74 20 28 28 74 65 73 74 69 6e 66 6f 20 (let ((testinfo
42a0: 28 64 62 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 (db:get-test-inf
42b0: 6f 20 64 62 20 72 75 6e 2d 69 64 20 74 65 73 74 o db run-id test
42c0: 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 name item-path))
42d0: 29 0a 20 20 20 20 3b 3b 20 20 20 28 69 66 20 28 ). ;; (if (
42e0: 61 6e 64 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f and (not (equal?
42f0: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 (db:test-get-st
4300: 61 74 75 73 20 74 65 73 74 69 6e 66 6f 29 20 22 atus testinfo) "
4310: 43 4f 4d 50 4c 45 54 45 44 22 29 29 0a 20 20 20 COMPLETED")).
4320: 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 28 ;; (
4330: 6e 6f 74 20 28 65 71 75 61 6c 3f 20 28 64 62 3a not (equal? (db:
4340: 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 73 20 test-get-status
4350: 74 65 73 74 69 6e 66 6f 29 20 22 4b 49 4c 4c 52 testinfo) "KILLR
4360: 45 51 22 29 29 0a 20 20 20 20 28 73 71 6c 69 74 EQ")). (sqlit
4370: 65 33 3a 65 78 65 63 75 74 65 0a 20 20 20 20 20 e3:execute.
4380: 64 62 0a 20 20 20 20 20 22 55 50 44 41 54 45 20 db. "UPDATE
4390: 74 65 73 74 73 20 53 45 54 20 63 70 75 6c 6f 61 tests SET cpuloa
43a0: 64 3d 3f 2c 64 69 73 6b 66 72 65 65 3d 3f 2c 72 d=?,diskfree=?,r
43b0: 75 6e 5f 64 75 72 61 74 69 6f 6e 3d 3f 2c 73 74 un_duration=?,st
43c0: 61 74 65 3d 27 52 55 4e 4e 49 4e 47 27 20 57 48 ate='RUNNING' WH
43d0: 45 52 45 20 72 75 6e 5f 69 64 3d 3f 20 41 4e 44 ERE run_id=? AND
43e0: 20 74 65 73 74 6e 61 6d 65 3d 3f 20 41 4e 44 20 testname=? AND
43f0: 69 74 65 6d 5f 70 61 74 68 3d 3f 20 41 4e 44 20 item_path=? AND
4400: 73 74 61 74 65 20 4e 4f 54 20 49 4e 20 28 27 43 state NOT IN ('C
4410: 4f 4d 50 4c 45 54 45 44 27 2c 27 4b 49 4c 4c 52 OMPLETED','KILLR
4420: 45 51 27 2c 27 4b 49 4c 4c 45 44 27 29 3b 22 0a EQ','KILLED');".
4430: 20 20 20 20 20 63 70 75 6c 6f 61 64 0a 20 20 20 cpuload.
4440: 20 20 64 69 73 6b 66 72 65 65 0a 20 20 20 20 20 diskfree.
4450: 6d 69 6e 75 74 65 73 0a 20 20 20 20 20 72 75 6e minutes. run
4460: 2d 69 64 0a 20 20 20 20 20 74 65 73 74 6e 61 6d -id. testnam
4470: 65 0a 20 20 20 20 20 69 74 65 6d 2d 70 61 74 68 e. item-path
4480: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 )))..(define (se
4490: 74 2d 6d 65 67 61 74 65 73 74 2d 65 6e 76 2d 76 t-megatest-env-v
44a0: 61 72 73 20 64 62 20 72 75 6e 2d 69 64 29 0a 20 ars db run-id).
44b0: 20 28 6c 65 74 20 28 28 6b 65 79 73 20 28 64 62 (let ((keys (db
44c0: 2d 67 65 74 2d 6b 65 79 73 20 64 62 29 29 29 0a -get-keys db))).
44d0: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c (for-each (l
44e0: 61 6d 62 64 61 20 28 6b 65 79 29 0a 09 09 28 73 ambda (key)...(s
44f0: 71 6c 69 74 65 33 3a 66 6f 72 2d 65 61 63 68 2d qlite3:for-each-
4500: 72 6f 77 0a 09 09 20 28 6c 61 6d 62 64 61 20 28 row... (lambda (
4510: 76 61 6c 29 0a 09 09 20 20 20 28 64 65 62 75 67 val)... (debug
4520: 3a 70 72 69 6e 74 20 32 20 22 73 65 74 65 6e 76 :print 2 "setenv
4530: 20 22 20 28 6b 65 79 3a 67 65 74 2d 66 69 65 6c " (key:get-fiel
4540: 64 6e 61 6d 65 20 6b 65 79 29 20 22 20 22 20 76 dname key) " " v
4550: 61 6c 29 0a 09 09 20 20 20 28 73 65 74 65 6e 76 al)... (setenv
4560: 20 28 6b 65 79 3a 67 65 74 2d 66 69 65 6c 64 6e (key:get-fieldn
4570: 61 6d 65 20 6b 65 79 29 20 76 61 6c 29 29 0a 09 ame key) val))..
4580: 09 20 64 62 20 0a 09 09 20 28 63 6f 6e 63 20 22 . db ... (conc "
4590: 53 45 4c 45 43 54 20 22 20 28 6b 65 79 3a 67 65 SELECT " (key:ge
45a0: 74 2d 66 69 65 6c 64 6e 61 6d 65 20 6b 65 79 29 t-fieldname key)
45b0: 20 22 20 46 52 4f 4d 20 72 75 6e 73 20 57 48 45 " FROM runs WHE
45c0: 52 45 20 69 64 3d 3f 3b 22 29 0a 09 09 20 72 75 RE id=?;")... ru
45d0: 6e 2d 69 64 29 29 0a 09 20 20 20 20 20 20 6b 65 n-id)).. ke
45e0: 79 73 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 ys)))..(define (
45f0: 73 65 74 2d 69 74 65 6d 2d 65 6e 76 2d 76 61 72 set-item-env-var
4600: 73 20 69 74 65 6d 64 61 74 29 0a 20 20 28 66 6f s itemdat). (fo
4610: 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 r-each (lambda (
4620: 69 74 65 6d 29 0a 09 20 20 20 20 20 20 28 64 65 item).. (de
4630: 62 75 67 3a 70 72 69 6e 74 20 32 20 22 73 65 74 bug:print 2 "set
4640: 65 6e 76 20 22 20 28 63 61 72 20 69 74 65 6d 29 env " (car item)
4650: 20 22 20 22 20 28 63 61 64 72 20 69 74 65 6d 29 " " (cadr item)
4660: 29 0a 09 20 20 20 20 20 20 28 73 65 74 65 6e 76 ).. (setenv
4670: 20 28 63 61 72 20 69 74 65 6d 29 20 28 63 61 64 (car item) (cad
4680: 72 20 69 74 65 6d 29 29 29 0a 09 20 20 20 20 69 r item))).. i
4690: 74 65 6d 64 61 74 29 29 0a 0a 28 64 65 66 69 6e temdat))..(defin
46a0: 65 20 28 67 65 74 2d 61 6c 6c 2d 6c 65 67 61 6c e (get-all-legal
46b0: 2d 74 65 73 74 73 29 0a 20 20 28 6c 65 74 2a 20 -tests). (let*
46c0: 28 28 74 65 73 74 73 20 20 28 67 6c 6f 62 20 28 ((tests (glob (
46d0: 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 conc *toppath* "
46e0: 2f 74 65 73 74 73 2f 2a 22 29 29 29 0a 09 20 28 /tests/*"))).. (
46f0: 72 65 73 20 20 20 20 27 28 29 29 29 0a 20 20 20 res '())).
4700: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 (debug:print 4
4710: 22 49 4e 46 4f 3a 20 4c 6f 6f 6b 69 6e 67 20 61 "INFO: Looking a
4720: 74 20 74 65 73 74 73 20 22 20 28 73 74 72 69 6e t tests " (strin
4730: 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 74 65 g-intersperse te
4740: 73 74 73 20 22 2c 22 29 29 0a 20 20 20 20 28 66 sts ",")). (f
4750: 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 or-each (lambda
4760: 28 74 65 73 74 70 61 74 68 29 0a 09 09 28 69 66 (testpath)...(if
4770: 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 28 (file-exists? (
4780: 63 6f 6e 63 20 74 65 73 74 70 61 74 68 20 22 2f conc testpath "/
4790: 74 65 73 74 63 6f 6e 66 69 67 22 29 29 0a 09 09 testconfig"))...
47a0: 20 20 20 20 28 73 65 74 21 20 72 65 73 20 28 63 (set! res (c
47b0: 6f 6e 73 20 28 6c 61 73 74 20 28 73 74 72 69 6e ons (last (strin
47c0: 67 2d 73 70 6c 69 74 20 74 65 73 74 70 61 74 68 g-split testpath
47d0: 20 22 2f 22 29 29 20 72 65 73 29 29 29 29 0a 09 "/")) res))))..
47e0: 20 20 20 20 20 20 74 65 73 74 73 29 0a 20 20 20 tests).
47f0: 20 72 65 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 res))..(define
4800: 28 72 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f (runs:can-run-mo
4810: 72 65 2d 74 65 73 74 73 20 64 62 29 0a 20 20 28 re-tests db). (
4820: 6c 65 74 20 28 28 6e 75 6d 2d 72 75 6e 6e 69 6e let ((num-runnin
4830: 67 20 28 64 62 3a 67 65 74 2d 63 6f 75 6e 74 2d g (db:get-count-
4840: 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 20 64 62 tests-running db
4850: 29 29 0a 09 28 6d 61 78 2d 63 6f 6e 63 75 72 72 ))..(max-concurr
4860: 65 6e 74 2d 6a 6f 62 73 20 28 63 6f 6e 66 69 67 ent-jobs (config
4870: 2d 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 -lookup *configd
4880: 61 74 2a 20 22 73 65 74 75 70 22 20 22 6d 61 78 at* "setup" "max
4890: 5f 63 6f 6e 63 75 72 72 65 6e 74 5f 6a 6f 62 73 _concurrent_jobs
48a0: 22 29 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a "))). (debug:
48b0: 70 72 69 6e 74 20 32 20 22 6d 61 78 2d 63 6f 6e print 2 "max-con
48c0: 63 75 72 72 65 6e 74 2d 6a 6f 62 73 3a 20 22 20 current-jobs: "
48d0: 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a max-concurrent-j
48e0: 6f 62 73 20 22 2c 20 6e 75 6d 2d 72 75 6e 6e 69 obs ", num-runni
48f0: 6e 67 3a 20 22 20 6e 75 6d 2d 72 75 6e 6e 69 6e ng: " num-runnin
4900: 67 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 g). (if (not
4910: 28 65 71 3f 20 30 20 2a 67 6c 6f 62 61 6c 65 78 (eq? 0 *globalex
4920: 69 74 73 74 61 74 75 73 2a 29 29 0a 09 23 66 0a itstatus*))..#f.
4930: 09 28 69 66 20 28 6f 72 20 28 6e 6f 74 20 6d 61 .(if (or (not ma
4940: 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 x-concurrent-job
4950: 73 29 0a 09 09 28 61 6e 64 20 6d 61 78 2d 63 6f s)...(and max-co
4960: 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 0a 09 09 ncurrent-jobs...
4970: 20 20 20 20 20 28 73 74 72 69 6e 67 2d 3e 6e 75 (string->nu
4980: 6d 62 65 72 20 6d 61 78 2d 63 6f 6e 63 75 72 72 mber max-concurr
4990: 65 6e 74 2d 6a 6f 62 73 29 0a 09 09 20 20 20 20 ent-jobs)...
49a0: 20 28 6e 6f 74 20 28 3e 3d 20 6e 75 6d 2d 72 75 (not (>= num-ru
49b0: 6e 6e 69 6e 67 20 28 73 74 72 69 6e 67 2d 3e 6e nning (string->n
49c0: 75 6d 62 65 72 20 6d 61 78 2d 63 6f 6e 63 75 72 umber max-concur
49d0: 72 65 6e 74 2d 6a 6f 62 73 29 29 29 29 29 0a 09 rent-jobs)))))..
49e0: 20 20 20 20 23 74 0a 09 20 20 20 20 28 62 65 67 #t.. (beg
49f0: 69 6e 20 0a 09 20 20 20 20 20 20 28 64 65 62 75 in .. (debu
4a00: 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 g:print 0 "WARNI
4a10: 4e 47 3a 20 4d 61 78 20 72 75 6e 6e 69 6e 67 20 NG: Max running
4a20: 6a 6f 62 73 20 65 78 63 65 65 64 65 64 2c 20 63 jobs exceeded, c
4a30: 75 72 72 65 6e 74 20 6e 75 6d 62 65 72 20 72 75 urrent number ru
4a40: 6e 6e 69 6e 67 3a 20 22 20 6e 75 6d 2d 72 75 6e nning: " num-run
4a50: 6e 69 6e 67 20 0a 09 09 09 20 20 20 22 2c 20 6d ning .... ", m
4a60: 61 78 5f 63 6f 6e 63 75 72 72 65 6e 74 5f 6a 6f ax_concurrent_jo
4a70: 62 73 3a 20 22 20 6d 61 78 2d 63 6f 6e 63 75 72 bs: " max-concur
4a80: 72 65 6e 74 2d 6a 6f 62 73 29 0a 09 20 20 20 20 rent-jobs)..
4a90: 20 20 23 66 29 29 29 29 29 0a 20 20 0a 28 64 65 #f))))). .(de
4aa0: 66 69 6e 65 20 28 72 75 6e 2d 74 65 73 74 73 20 fine (run-tests
4ab0: 64 62 20 74 65 73 74 2d 6e 61 6d 65 73 29 0a 20 db test-names).
4ac0: 20 28 6c 65 74 2a 20 28 28 6b 65 79 73 20 20 20 (let* ((keys
4ad0: 20 20 20 20 20 28 64 62 2d 67 65 74 2d 6b 65 79 (db-get-key
4ae0: 73 20 64 62 29 29 0a 09 20 28 6b 65 79 76 61 6c s db)).. (keyval
4af0: 6c 73 74 20 20 20 28 6b 65 79 73 2d 3e 76 61 6c lst (keys->val
4b00: 6c 69 73 74 20 6b 65 79 73 20 23 74 29 29 0a 09 list keys #t))..
4b10: 20 28 72 75 6e 2d 69 64 20 20 20 20 20 20 28 72 (run-id (r
4b20: 65 67 69 73 74 65 72 2d 72 75 6e 20 64 62 20 6b egister-run db k
4b30: 65 79 73 29 29 20 20 3b 3b 20 20 74 65 73 74 2d eys)) ;; test-
4b40: 6e 61 6d 65 29 29 29 0a 09 20 28 64 65 66 65 72 name))).. (defer
4b50: 72 65 64 20 20 20 20 27 28 29 29 29 20 3b 3b 20 red '())) ;;
4b60: 64 65 6c 61 79 20 72 75 6e 6e 69 6e 67 20 74 68 delay running th
4b70: 65 73 65 20 73 69 6e 63 65 20 74 68 65 79 20 68 ese since they h
4b80: 61 76 65 20 61 20 77 61 69 74 6f 6e 20 63 6c 61 ave a waiton cla
4b90: 75 73 65 0a 20 20 20 20 3b 3b 20 6f 6e 20 74 68 use. ;; on th
4ba0: 65 20 66 69 72 73 74 20 70 61 73 73 20 6f 72 20 e first pass or
4bb0: 63 61 6c 6c 20 74 6f 20 72 75 6e 2d 74 65 73 74 call to run-test
4bc0: 73 20 73 65 74 20 46 41 49 4c 53 20 74 6f 20 4e s set FAILS to N
4bd0: 4f 54 5f 53 54 41 52 54 45 44 20 69 66 0a 20 20 OT_STARTED if.
4be0: 20 20 3b 3b 20 2d 6b 65 65 70 67 6f 69 6e 67 20 ;; -keepgoing
4bf0: 69 73 20 73 70 65 63 69 66 69 65 64 0a 20 20 20 is specified.
4c00: 20 28 69 66 20 28 61 6e 64 20 28 65 71 3f 20 2a (if (and (eq? *
4c10: 70 61 73 73 6e 75 6d 2a 20 30 29 0a 09 20 20 20 passnum* 0)..
4c20: 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 (args:get-arg
4c30: 22 2d 6b 65 65 70 67 6f 69 6e 67 22 29 29 0a 09 "-keepgoing"))..
4c40: 28 62 65 67 69 6e 0a 09 20 20 3b 3b 20 68 61 76 (begin.. ;; hav
4c50: 65 20 74 6f 20 64 65 6c 65 74 65 20 74 65 73 74 e to delete test
4c60: 20 72 65 63 6f 72 64 73 20 77 68 65 72 65 20 4e records where N
4c70: 4f 54 5f 53 54 41 52 54 45 44 20 73 69 6e 63 65 OT_STARTED since
4c80: 20 74 68 65 79 20 63 61 6e 20 63 61 75 73 65 20 they can cause
4c90: 2d 6b 65 65 70 67 6f 69 6e 67 20 74 6f 20 0a 09 -keepgoing to ..
4ca0: 20 20 3b 3b 20 67 65 74 20 73 74 75 63 6b 20 64 ;; get stuck d
4cb0: 75 65 20 74 6f 20 62 65 63 6f 6d 69 6e 67 20 69 ue to becoming i
4cc0: 6e 61 63 63 65 73 73 69 62 6c 65 20 66 72 6f 6d naccessible from
4cd0: 20 61 20 66 61 69 6c 65 64 20 74 65 73 74 2e 20 a failed test.
4ce0: 49 2e 65 2e 20 69 66 20 74 65 73 74 20 42 20 64 I.e. if test B d
4cf0: 65 70 65 6e 64 73 20 0a 09 20 20 3b 3b 20 6f 6e epends .. ;; on
4d00: 20 74 65 73 74 20 41 20 62 75 74 20 74 65 73 74 test A but test
4d10: 20 42 20 72 65 61 63 68 65 64 20 74 68 65 20 70 B reached the p
4d20: 6f 69 6e 74 20 6f 6e 20 62 65 69 6e 67 20 72 65 oint on being re
4d30: 67 69 73 74 65 72 65 64 20 61 73 20 4e 4f 54 5f gistered as NOT_
4d40: 53 54 41 52 54 45 44 20 61 6e 64 20 74 65 73 74 STARTED and test
4d50: 0a 09 20 20 3b 3b 20 41 20 66 61 69 6c 65 64 20 .. ;; A failed
4d60: 66 6f 72 20 73 6f 6d 65 20 72 65 61 73 6f 6e 20 for some reason
4d70: 74 68 65 6e 20 6f 6e 20 72 65 2d 72 75 6e 20 75 then on re-run u
4d80: 73 69 6e 67 20 2d 6b 65 65 70 67 6f 69 6e 67 20 sing -keepgoing
4d90: 74 68 65 20 72 75 6e 20 63 61 6e 20 6e 65 76 65 the run can neve
4da0: 72 20 63 6f 6d 70 6c 65 74 65 2e 0a 09 20 20 28 r complete... (
4db0: 64 62 3a 64 65 6c 65 74 65 2d 74 65 73 74 73 2d db:delete-tests-
4dc0: 69 6e 2d 73 74 61 74 65 20 64 62 20 72 75 6e 2d in-state db run-
4dd0: 69 64 20 22 4e 4f 54 5f 53 54 41 52 54 45 44 22 id "NOT_STARTED"
4de0: 29 0a 09 20 20 28 64 62 3a 73 65 74 2d 74 65 73 ).. (db:set-tes
4df0: 74 73 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 ts-state-status
4e00: 64 62 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e db run-id test-n
4e10: 61 6d 65 73 20 23 66 20 22 46 41 49 4c 22 20 22 ames #f "FAIL" "
4e20: 4e 4f 54 5f 53 54 41 52 54 45 44 22 20 22 46 41 NOT_STARTED" "FA
4e30: 49 4c 22 29 29 29 0a 20 20 20 20 28 73 65 74 21 IL"))). (set!
4e40: 20 2a 70 61 73 73 6e 75 6d 2a 20 28 2b 20 2a 70 *passnum* (+ *p
4e50: 61 73 73 6e 75 6d 2a 20 31 29 29 0a 20 20 20 20 assnum* 1)).
4e60: 28 6c 65 74 20 6c 6f 6f 70 20 28 28 6e 75 6d 74 (let loop ((numt
4e70: 69 6d 65 73 20 30 29 29 0a 20 20 20 20 20 20 28 imes 0)). (
4e80: 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 20 20 for-each .
4e90: 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 2d 6e (lambda (test-n
4ea0: 61 6d 65 29 0a 09 20 28 69 66 20 28 72 75 6e 73 ame).. (if (runs
4eb0: 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 :can-run-more-te
4ec0: 73 74 73 20 64 62 29 0a 09 20 20 20 20 20 28 72 sts db).. (r
4ed0: 75 6e 2d 6f 6e 65 2d 74 65 73 74 20 64 62 20 72 un-one-test db r
4ee0: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 un-id test-name
4ef0: 6b 65 79 76 61 6c 6c 73 74 29 0a 09 20 20 20 20 keyvallst)..
4f00: 20 3b 3b 20 61 64 64 20 73 6f 6d 65 20 64 65 6c ;; add some del
4f10: 61 79 20 0a 09 20 20 20 20 20 3b 28 73 6c 65 65 ay .. ;(slee
4f20: 70 20 32 29 0a 09 20 20 20 20 20 29 29 0a 20 20 p 2).. )).
4f30: 20 20 20 20 20 74 65 73 74 2d 6e 61 6d 65 73 29 test-names)
4f40: 0a 20 20 20 20 20 20 3b 3b 20 28 72 75 6e 2d 77 . ;; (run-w
4f50: 61 69 74 69 6e 67 2d 74 65 73 74 73 20 64 62 29 aiting-tests db)
4f60: 0a 20 20 20 20 20 20 28 69 66 20 28 61 72 67 73 . (if (args
4f70: 3a 67 65 74 2d 61 72 67 20 22 2d 6b 65 65 70 67 :get-arg "-keepg
4f80: 6f 69 6e 67 22 29 0a 09 20 20 28 6c 65 74 20 28 oing").. (let (
4f90: 28 65 73 74 72 65 6d 20 28 64 62 3a 65 73 74 69 (estrem (db:esti
4fa0: 6d 61 74 65 64 2d 74 65 73 74 73 2d 72 65 6d 61 mated-tests-rema
4fb0: 69 6e 69 6e 67 20 64 62 20 72 75 6e 2d 69 64 29 ining db run-id)
4fc0: 29 29 0a 09 20 20 20 20 28 69 66 20 28 61 6e 64 )).. (if (and
4fd0: 20 28 3e 20 65 73 74 72 65 6d 20 30 29 0a 09 09 (> estrem 0)...
4fe0: 20 20 20 20 20 28 65 71 3f 20 2a 67 6c 6f 62 61 (eq? *globa
4ff0: 6c 65 78 69 74 73 74 61 74 75 73 2a 20 30 29 29 lexitstatus* 0))
5000: 0a 09 09 28 62 65 67 69 6e 0a 09 09 20 20 28 64 ...(begin... (d
5010: 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 4b 65 ebug:print 1 "Ke
5020: 65 70 20 67 6f 69 6e 67 2c 20 65 73 74 69 6d 61 ep going, estima
5030: 74 65 64 20 22 20 65 73 74 72 65 6d 20 22 20 74 ted " estrem " t
5040: 65 73 74 73 20 72 65 6d 61 69 6e 69 6e 67 20 74 ests remaining t
5050: 6f 20 72 75 6e 2c 20 77 69 6c 6c 20 63 6f 6e 74 o run, will cont
5060: 69 6e 75 65 20 69 6e 20 33 20 73 65 63 6f 6e 64 inue in 3 second
5070: 73 20 2e 2e 2e 22 29 0a 09 09 20 20 28 73 6c 65 s ...")... (sle
5080: 65 70 20 33 29 0a 09 09 20 20 28 72 75 6e 2d 77 ep 3)... (run-w
5090: 61 69 74 69 6e 67 2d 74 65 73 74 73 20 64 62 29 aiting-tests db)
50a0: 0a 09 09 20 20 28 6c 6f 6f 70 20 28 2b 20 6e 75 ... (loop (+ nu
50b0: 6d 74 69 6d 65 73 20 31 29 29 29 29 29 29 29 29 mtimes 1))))))))
50c0: 29 0a 09 20 20 20 0a 3b 3b 20 56 45 52 59 20 49 ).. .;; VERY I
50d0: 4e 45 46 46 49 43 49 45 4e 54 21 20 4d 6f 76 65 NEFFICIENT! Move
50e0: 20 73 74 75 66 66 20 74 68 61 74 20 73 68 6f 75 stuff that shou
50f0: 6c 64 20 62 65 20 64 6f 6e 65 20 6f 6e 63 65 20 ld be done once
5100: 75 70 20 74 6f 20 63 61 6c 6c 69 6e 67 20 70 72 up to calling pr
5110: 6f 63 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 2d oc.(define (run-
5120: 6f 6e 65 2d 74 65 73 74 20 64 62 20 72 75 6e 2d one-test db run-
5130: 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 6b 65 79 id test-name key
5140: 76 61 6c 6c 73 74 29 0a 20 20 28 64 65 62 75 67 vallst). (debug
5150: 3a 70 72 69 6e 74 20 31 20 22 4c 61 75 6e 63 68 :print 1 "Launch
5160: 69 6e 67 20 74 65 73 74 20 22 20 74 65 73 74 2d ing test " test-
5170: 6e 61 6d 65 29 0a 20 20 3b 3b 20 41 6c 6c 20 74 name). ;; All t
5180: 68 65 73 65 20 76 61 72 73 20 6d 69 67 68 74 20 hese vars might
5190: 62 65 20 72 65 66 65 72 65 6e 63 65 64 20 62 79 be referenced by
51a0: 20 74 68 65 20 74 65 73 74 63 6f 6e 66 69 67 20 the testconfig
51b0: 66 69 6c 65 20 72 65 61 64 65 72 0a 20 20 28 73 file reader. (s
51c0: 65 74 65 6e 76 20 22 4d 54 5f 54 45 53 54 5f 4e etenv "MT_TEST_N
51d0: 41 4d 45 22 20 74 65 73 74 2d 6e 61 6d 65 29 20 AME" test-name)
51e0: 3b 3b 20 0a 20 20 28 73 65 74 65 6e 76 20 22 4d ;; . (setenv "M
51f0: 54 5f 52 55 4e 4e 41 4d 45 22 20 20 20 28 61 72 T_RUNNAME" (ar
5200: 67 73 3a 67 65 74 2d 61 72 67 20 22 3a 72 75 6e gs:get-arg ":run
5210: 6e 61 6d 65 22 29 29 0a 20 20 28 73 65 74 2d 6d name")). (set-m
5220: 65 67 61 74 65 73 74 2d 65 6e 76 2d 76 61 72 73 egatest-env-vars
5230: 20 64 62 20 72 75 6e 2d 69 64 29 20 3b 3b 20 74 db run-id) ;; t
5240: 68 65 73 65 20 6d 61 79 20 62 65 20 6e 65 65 64 hese may be need
5250: 65 64 20 62 79 20 74 68 65 20 6c 61 75 6e 63 68 ed by the launch
5260: 69 6e 67 20 70 72 6f 63 65 73 73 0a 20 20 28 63 ing process. (c
5270: 68 61 6e 67 65 2d 64 69 72 65 63 74 6f 72 79 20 hange-directory
5280: 2a 74 6f 70 70 61 74 68 2a 29 0a 20 20 28 6c 65 *toppath*). (le
5290: 74 2a 20 28 28 74 65 73 74 2d 70 61 74 68 20 20 t* ((test-path
52a0: 20 20 28 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 (conc *toppath
52b0: 2a 20 22 2f 74 65 73 74 73 2f 22 20 74 65 73 74 * "/tests/" test
52c0: 2d 6e 61 6d 65 29 29 0a 09 20 28 74 65 73 74 2d -name)).. (test-
52d0: 63 6f 6e 66 69 67 66 20 28 63 6f 6e 63 20 74 65 configf (conc te
52e0: 73 74 2d 70 61 74 68 20 22 2f 74 65 73 74 63 6f st-path "/testco
52f0: 6e 66 69 67 22 29 29 0a 09 20 28 74 65 73 74 65 nfig")).. (teste
5300: 78 69 73 74 73 20 20 20 28 61 6e 64 20 28 66 69 xists (and (fi
5310: 6c 65 2d 65 78 69 73 74 73 3f 20 74 65 73 74 2d le-exists? test-
5320: 63 6f 6e 66 69 67 66 29 28 66 69 6c 65 2d 72 65 configf)(file-re
5330: 61 64 2d 61 63 63 65 73 73 3f 20 74 65 73 74 2d ad-access? test-
5340: 63 6f 6e 66 69 67 66 29 29 29 0a 09 20 28 74 65 configf))).. (te
5350: 73 74 2d 63 6f 6e 66 20 20 20 20 28 69 66 20 74 st-conf (if t
5360: 65 73 74 65 78 69 73 74 73 20 28 72 65 61 64 2d estexists (read-
5370: 63 6f 6e 66 69 67 20 74 65 73 74 2d 63 6f 6e 66 config test-conf
5380: 69 67 66 20 23 66 20 23 74 29 20 28 6d 61 6b 65 igf #f #t) (make
5390: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 0a 09 -hash-table)))..
53a0: 20 28 77 61 69 74 6f 6e 20 20 20 20 20 20 20 28 (waiton (
53b0: 6c 65 74 20 28 28 77 20 28 63 6f 6e 66 69 67 2d let ((w (config-
53c0: 6c 6f 6f 6b 75 70 20 74 65 73 74 2d 63 6f 6e 66 lookup test-conf
53d0: 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 22 20 "requirements"
53e0: 22 77 61 69 74 6f 6e 22 29 29 29 0a 09 09 09 20 "waiton")))....
53f0: 28 69 66 20 28 73 74 72 69 6e 67 3f 20 77 29 28 (if (string? w)(
5400: 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 77 29 27 string-split w)'
5410: 28 29 29 29 29 0a 09 20 28 74 61 67 73 20 20 20 ()))).. (tags
5420: 20 20 20 20 20 20 28 6c 65 74 20 28 28 74 20 28 (let ((t (
5430: 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 74 65 config-lookup te
5440: 73 74 2d 63 6f 6e 66 20 22 73 65 74 75 70 22 20 st-conf "setup"
5450: 22 74 61 67 73 22 29 29 29 0a 09 09 09 20 3b 3b "tags"))).... ;;
5460: 20 77 65 20 77 61 6e 74 20 6f 75 72 20 74 61 67 we want our tag
5470: 73 20 74 6f 20 62 65 20 73 65 70 61 72 61 74 65 s to be separate
5480: 64 20 62 79 20 63 6f 6d 6d 61 73 20 61 6e 64 20 d by commas and
5490: 66 75 6c 6c 79 20 64 65 6c 69 6d 69 74 65 64 20 fully delimited
54a0: 62 79 20 63 6f 6d 6d 61 73 0a 09 09 09 20 3b 3b by commas.... ;;
54b0: 20 73 6f 20 74 68 61 74 20 71 75 65 72 69 65 73 so that queries
54c0: 20 77 69 74 68 20 22 6c 69 6b 65 22 20 63 61 6e with "like" can
54d0: 20 74 69 65 20 74 6f 20 74 68 65 20 63 6f 6d 6d tie to the comm
54e0: 61 73 20 61 74 20 65 69 74 68 65 72 20 65 6e 64 as at either end
54f0: 20 6f 66 20 65 61 63 68 20 74 61 67 0a 09 09 09 of each tag....
5500: 20 3b 3b 20 77 68 69 6c 65 20 61 6c 73 6f 20 61 ;; while also a
5510: 6c 6c 6f 77 69 6e 67 20 74 68 65 20 65 6e 64 20 llowing the end
5520: 75 73 65 72 20 74 6f 20 66 72 65 65 6c 79 20 75 user to freely u
5530: 73 65 20 73 70 61 63 65 73 20 61 6e 64 20 63 6f se spaces and co
5540: 6d 6d 61 73 20 74 6f 20 73 65 70 61 72 61 74 65 mmas to separate
5550: 20 74 61 67 73 0a 09 09 09 20 28 69 66 20 28 73 tags.... (if (s
5560: 74 72 69 6e 67 3f 20 74 29 28 73 74 72 69 6e 67 tring? t)(string
5570: 2d 73 75 62 73 74 69 74 75 74 65 20 28 72 65 67 -substitute (reg
5580: 65 78 70 20 22 5b 2c 5c 5c 73 5d 2b 22 29 20 22 exp "[,\\s]+") "
5590: 2c 22 20 28 63 6f 6e 63 20 22 2c 22 20 74 20 22 ," (conc "," t "
55a0: 2c 22 29 20 23 74 29 0a 09 09 09 20 20 20 20 20 ,") #t)....
55b0: 27 28 29 29 29 29 29 0a 20 20 20 20 28 69 66 20 '())))). (if
55c0: 28 6e 6f 74 20 74 65 73 74 65 78 69 73 74 73 29 (not testexists)
55d0: 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 64 65 62 ..(begin.. (deb
55e0: 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO
55f0: 52 3a 20 43 61 6e 27 74 20 66 69 6e 64 20 63 6f R: Can't find co
5600: 6e 66 69 67 20 66 69 6c 65 20 22 20 74 65 73 74 nfig file " test
5610: 2d 63 6f 6e 66 69 67 66 29 0a 09 20 20 28 65 78 -configf).. (ex
5620: 69 74 20 32 29 29 0a 09 3b 3b 20 70 75 74 20 74 it 2))..;; put t
5630: 6f 70 20 76 61 72 73 20 69 6e 74 6f 20 63 6f 6e op vars into con
5640: 76 65 6e 69 65 6e 74 20 76 61 72 69 61 62 6c 65 venient variable
5650: 73 20 61 6e 64 20 6f 70 65 6e 20 74 68 65 20 64 s and open the d
5660: 62 0a 09 28 6c 65 74 2a 20 28 3b 3b 20 64 62 20 b..(let* (;; db
5670: 69 73 20 61 6c 77 61 79 73 20 61 74 20 2a 74 6f is always at *to
5680: 70 70 61 74 68 2a 2f 64 62 2f 6d 65 67 61 74 65 ppath*/db/megate
5690: 73 74 2e 64 62 0a 09 20 20 20 20 20 20 20 28 69 st.db.. (i
56a0: 74 65 6d 73 20 20 20 20 20 20 20 28 68 61 73 68 tems (hash
56b0: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
56c0: 6c 74 20 74 65 73 74 2d 63 6f 6e 66 20 22 69 74 lt test-conf "it
56d0: 65 6d 73 22 20 27 28 29 29 29 0a 09 20 20 20 20 ems" '()))..
56e0: 20 20 20 28 69 74 65 6d 73 74 61 62 6c 65 20 20 (itemstable
56f0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
5700: 64 65 66 61 75 6c 74 20 74 65 73 74 2d 63 6f 6e default test-con
5710: 66 20 22 69 74 65 6d 73 74 61 62 6c 65 22 20 27 f "itemstable" '
5720: 28 29 29 29 0a 09 20 20 20 20 20 20 20 28 61 6c ())).. (al
5730: 6c 69 74 65 6d 73 20 20 20 20 28 69 66 20 28 6f litems (if (o
5740: 72 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 69 74 r (not (null? it
5750: 65 6d 73 29 29 28 6e 6f 74 20 28 6e 75 6c 6c 3f ems))(not (null?
5760: 20 69 74 65 6d 73 74 61 62 6c 65 29 29 29 0a 09 itemstable)))..
5770: 09 09 09 28 61 70 70 65 6e 64 20 28 69 74 65 6d ...(append (item
5780: 2d 61 73 73 6f 63 2d 3e 69 74 65 6d 2d 6c 69 73 -assoc->item-lis
5790: 74 20 69 74 65 6d 73 29 0a 09 09 09 09 09 28 69 t items)......(i
57a0: 74 65 6d 2d 74 61 62 6c 65 2d 3e 69 74 65 6d 2d tem-table->item-
57b0: 6c 69 73 74 20 69 74 65 6d 73 74 61 62 6c 65 29 list itemstable)
57c0: 29 0a 09 09 09 09 27 28 28 29 29 29 29 20 3b 3b ).....'(()))) ;;
57d0: 20 61 20 6c 69 73 74 20 77 69 74 68 20 6f 6e 65 a list with one
57e0: 20 6e 75 6c 6c 20 6c 69 73 74 20 69 73 20 61 20 null list is a
57f0: 74 65 73 74 20 77 69 74 68 20 6e 6f 20 69 74 65 test with no ite
5800: 6d 73 0a 09 20 20 20 20 20 20 20 28 72 75 6e 63 ms.. (runc
5810: 6f 6e 66 69 67 66 20 20 28 63 6f 6e 63 20 20 2a onfigf (conc *
5820: 74 6f 70 70 61 74 68 2a 20 22 2f 72 75 6e 63 6f toppath* "/runco
5830: 6e 66 69 67 73 2e 63 6f 6e 66 69 67 22 29 29 29 nfigs.config")))
5840: 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
5850: 20 31 20 22 69 74 65 6d 73 3a 20 22 29 0a 09 20 1 "items: ")..
5860: 20 28 69 66 20 28 3e 3d 20 2a 76 65 72 62 6f 73 (if (>= *verbos
5870: 69 74 79 2a 20 31 29 28 70 70 20 61 6c 6c 69 74 ity* 1)(pp allit
5880: 65 6d 73 29 29 0a 09 20 20 28 69 66 20 28 3e 3d ems)).. (if (>=
5890: 20 2a 76 65 72 62 6f 73 69 74 79 2a 20 35 29 0a *verbosity* 5).
58a0: 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 . (begin...
58b0: 28 70 72 69 6e 74 20 22 69 74 65 6d 73 3a 20 22 (print "items: "
58c0: 29 28 70 70 20 28 69 74 65 6d 2d 61 73 73 6f 63 )(pp (item-assoc
58d0: 2d 3e 69 74 65 6d 2d 6c 69 73 74 20 69 74 65 6d ->item-list item
58e0: 73 29 29 0a 09 09 28 70 72 69 6e 74 20 22 69 74 s))...(print "it
58f0: 65 73 74 61 62 6c 65 3a 20 22 29 28 70 70 20 28 estable: ")(pp (
5900: 69 74 65 6d 2d 74 61 62 6c 65 2d 3e 69 74 65 6d item-table->item
5910: 2d 6c 69 73 74 20 69 74 65 6d 73 74 61 62 6c 65 -list itemstable
5920: 29 29 29 29 0a 09 20 20 28 69 66 20 28 61 72 67 )))).. (if (arg
5930: 73 3a 67 65 74 2d 61 72 67 20 22 2d 6d 22 29 0a s:get-arg "-m").
5940: 09 20 20 20 20 20 20 28 64 62 3a 73 65 74 2d 63 . (db:set-c
5950: 6f 6d 6d 65 6e 74 2d 66 6f 72 2d 72 75 6e 20 64 omment-for-run d
5960: 62 20 72 75 6e 2d 69 64 20 28 61 72 67 73 3a 67 b run-id (args:g
5970: 65 74 2d 61 72 67 20 22 2d 6d 22 29 29 29 0a 0a et-arg "-m")))..
5980: 09 20 20 3b 3b 20 48 65 72 65 20 69 73 20 77 68 . ;; Here is wh
5990: 65 72 65 20 74 68 65 20 74 65 73 74 5f 6d 65 74 ere the test_met
59a0: 61 20 74 61 62 6c 65 20 69 73 20 62 65 73 74 20 a table is best
59b0: 75 70 64 61 74 65 64 0a 09 20 20 28 72 75 6e 73 updated.. (runs
59c0: 3a 75 70 64 61 74 65 2d 74 65 73 74 5f 6d 65 74 :update-test_met
59d0: 61 20 64 62 20 74 65 73 74 2d 6e 61 6d 65 20 74 a db test-name t
59e0: 65 73 74 2d 63 6f 6e 66 29 0a 0a 09 20 20 3b 3b est-conf)... ;;
59f0: 20 62 72 61 69 6e 64 65 61 64 20 77 6f 72 6b 2d braindead work-
5a00: 61 72 6f 75 6e 64 20 66 6f 72 20 70 6f 6f 72 6c around for poorl
5a10: 79 20 73 70 65 63 69 66 69 65 64 20 61 6c 6c 69 y specified alli
5a20: 74 65 6d 73 20 6c 69 73 74 20 42 55 47 21 21 21 tems list BUG!!!
5a30: 20 46 49 58 4d 45 0a 09 20 20 28 69 66 20 28 6e FIXME.. (if (n
5a40: 75 6c 6c 3f 20 61 6c 6c 69 74 65 6d 73 29 28 73 ull? allitems)(s
5a50: 65 74 21 20 61 6c 6c 69 74 65 6d 73 20 27 28 28 et! allitems '((
5a60: 29 29 29 29 0a 09 20 20 28 6c 65 74 20 6c 6f 6f )))).. (let loo
5a70: 70 20 28 28 69 74 65 6d 64 61 74 20 28 63 61 72 p ((itemdat (car
5a80: 20 61 6c 6c 69 74 65 6d 73 29 29 0a 09 09 20 20 allitems))...
5a90: 20 20 20 28 74 61 6c 20 20 20 20 20 28 63 64 72 (tal (cdr
5aa0: 20 61 6c 6c 69 74 65 6d 73 29 29 29 0a 09 20 20 allitems)))..
5ab0: 20 20 3b 3b 20 28 6c 61 6d 62 64 61 20 28 69 74 ;; (lambda (it
5ac0: 65 6d 64 61 74 29 20 3b 3b 3b 20 28 28 72 69 70 emdat) ;;; ((rip
5ad0: 65 6e 65 73 73 20 22 6f 76 65 72 72 69 70 65 22 eness "overripe"
5ae0: 29 20 28 74 65 6d 70 65 72 61 74 75 72 65 20 22 ) (temperature "
5af0: 63 6f 6f 6c 22 29 20 28 73 65 61 73 6f 6e 20 22 cool") (season "
5b00: 73 75 6d 6d 65 72 22 29 29 0a 09 20 20 20 20 3b summer")).. ;
5b10: 3b 20 48 61 6e 64 6c 65 20 6c 69 73 74 73 20 6f ; Handle lists o
5b20: 66 20 69 74 65 6d 73 0a 09 20 20 20 20 28 6c 65 f items.. (le
5b30: 74 2a 20 28 28 69 74 65 6d 2d 70 61 74 68 20 20 t* ((item-path
5b40: 20 20 20 28 69 74 65 6d 2d 6c 69 73 74 2d 3e 70 (item-list->p
5b50: 61 74 68 20 69 74 65 6d 64 61 74 29 29 20 3b 3b ath itemdat)) ;;
5b60: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
5b70: 65 72 73 65 20 28 6d 61 70 20 63 61 64 72 20 69 erse (map cadr i
5b80: 74 65 6d 64 61 74 29 20 22 2f 22 29 29 0a 09 09 temdat) "/"))...
5b90: 20 20 20 28 6e 65 77 2d 74 65 73 74 2d 70 61 74 (new-test-pat
5ba0: 68 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 h (string-inters
5bb0: 70 65 72 73 65 20 28 63 6f 6e 73 20 74 65 73 74 perse (cons test
5bc0: 2d 70 61 74 68 20 28 6d 61 70 20 63 61 64 72 20 -path (map cadr
5bd0: 69 74 65 6d 64 61 74 29 29 20 22 2f 22 29 29 0a itemdat)) "/")).
5be0: 09 09 20 20 20 28 6e 65 77 2d 74 65 73 74 2d 6e .. (new-test-n
5bf0: 61 6d 65 20 28 69 66 20 28 65 71 75 61 6c 3f 20 ame (if (equal?
5c00: 69 74 65 6d 2d 70 61 74 68 20 22 22 29 20 74 65 item-path "") te
5c10: 73 74 2d 6e 61 6d 65 20 28 63 6f 6e 63 20 74 65 st-name (conc te
5c20: 73 74 2d 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d st-name "/" item
5c30: 2d 70 61 74 68 29 29 29 20 3b 3b 20 6a 75 73 74 -path))) ;; just
5c40: 20 6e 65 65 64 20 69 74 20 74 6f 20 62 65 20 75 need it to be u
5c50: 6e 69 71 75 65 0a 09 09 20 20 20 28 74 65 73 74 nique... (test
5c60: 64 61 74 20 20 20 23 66 29 0a 09 09 20 20 20 28 dat #f)... (
5c70: 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 28 64 62 3a num-running (db:
5c80: 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d get-count-tests-
5c90: 72 75 6e 6e 69 6e 67 20 64 62 29 29 0a 09 09 20 running db))...
5ca0: 20 20 28 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e (max-concurren
5cb0: 74 2d 6a 6f 62 73 20 28 63 6f 6e 66 69 67 2d 6c t-jobs (config-l
5cc0: 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 ookup *configdat
5cd0: 2a 20 22 73 65 74 75 70 22 20 22 6d 61 78 5f 63 * "setup" "max_c
5ce0: 6f 6e 63 75 72 72 65 6e 74 5f 6a 6f 62 73 22 29 oncurrent_jobs")
5cf0: 29 0a 09 09 20 20 20 28 70 61 72 65 6e 74 2d 74 )... (parent-t
5d00: 65 73 74 20 28 61 6e 64 20 28 6e 6f 74 20 28 6e est (and (not (n
5d10: 75 6c 6c 3f 20 69 74 65 6d 73 29 29 28 65 71 75 ull? items))(equ
5d20: 61 6c 3f 20 69 74 65 6d 2d 70 61 74 68 20 22 22 al? item-path ""
5d30: 29 29 29 0a 09 09 20 20 20 28 73 69 6e 67 6c 65 )))... (single
5d40: 2d 74 65 73 74 20 28 61 6e 64 20 28 6e 75 6c 6c -test (and (null
5d50: 3f 20 69 74 65 6d 73 29 20 28 65 71 75 61 6c 3f ? items) (equal?
5d60: 20 69 74 65 6d 2d 70 61 74 68 20 22 22 29 29 29 item-path "")))
5d70: 0a 09 09 20 20 20 28 69 74 65 6d 2d 74 65 73 74 ... (item-test
5d80: 20 20 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 (not (equal?
5d90: 69 74 65 6d 2d 70 61 74 68 20 22 22 29 29 29 29 item-path ""))))
5da0: 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 .. (debug:p
5db0: 72 69 6e 74 20 33 20 22 6d 61 78 2d 63 6f 6e 63 rint 3 "max-conc
5dc0: 75 72 72 65 6e 74 2d 6a 6f 62 73 3a 20 22 20 6d urrent-jobs: " m
5dd0: 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f ax-concurrent-jo
5de0: 62 73 20 22 2c 20 6e 75 6d 2d 72 75 6e 6e 69 6e bs ", num-runnin
5df0: 67 3a 20 22 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 g: " num-running
5e00: 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 72 75 ).. (if (ru
5e10: 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d ns:can-run-more-
5e20: 74 65 73 74 73 20 64 62 29 0a 09 09 20 20 28 62 tests db)... (b
5e30: 65 67 69 6e 0a 09 09 20 20 20 20 28 6c 65 74 20 egin... (let
5e40: 6c 6f 6f 70 32 20 28 28 74 73 20 28 64 62 3a 67 loop2 ((ts (db:g
5e50: 65 74 2d 74 65 73 74 2d 69 6e 66 6f 20 64 62 20 et-test-info db
5e60: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
5e70: 20 69 74 65 6d 2d 70 61 74 68 29 29 20 3b 3b 20 item-path)) ;;
5e80: 23 66 29 0a 09 09 09 09 28 63 74 20 30 29 29 0a #f).....(ct 0)).
5e90: 09 09 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 .. (if (and
5ea0: 20 28 6e 6f 74 20 74 73 29 0a 09 09 09 20 20 20 (not ts)....
5eb0: 20 20 20 20 28 3c 20 63 74 20 31 30 29 29 0a 09 (< ct 10))..
5ec0: 09 09 20 20 28 62 65 67 69 6e 0a 09 09 09 20 20 .. (begin....
5ed0: 20 20 28 72 65 67 69 73 74 65 72 2d 74 65 73 74 (register-test
5ee0: 20 64 62 20 72 75 6e 2d 69 64 20 74 65 73 74 2d db run-id test-
5ef0: 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 0a name item-path).
5f00: 09 09 09 20 20 20 20 28 64 62 3a 74 65 73 74 2d ... (db:test-
5f10: 73 65 74 2d 63 6f 6d 6d 65 6e 74 20 64 62 20 72 set-comment db r
5f20: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 un-id test-name
5f30: 69 74 65 6d 2d 70 61 74 68 20 22 22 29 0a 09 09 item-path "")...
5f40: 09 20 20 20 20 28 6c 6f 6f 70 32 20 28 64 62 3a . (loop2 (db:
5f50: 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 20 64 62 get-test-info db
5f60: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
5f70: 65 20 69 74 65 6d 2d 70 61 74 68 29 0a 09 09 09 e item-path)....
5f80: 09 20 20 20 28 2b 20 63 74 20 31 29 29 29 0a 09 . (+ ct 1)))..
5f90: 09 09 20 20 28 69 66 20 74 73 0a 09 09 09 20 20 .. (if ts....
5fa0: 20 20 20 20 28 73 65 74 21 20 74 65 73 74 64 61 (set! testda
5fb0: 74 20 74 73 29 0a 09 09 09 20 20 20 20 20 20 28 t ts).... (
5fc0: 62 65 67 69 6e 0a 09 09 09 09 28 64 65 62 75 67 begin.....(debug
5fd0: 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e :print 0 "WARNIN
5fe0: 47 3a 20 43 6f 75 6c 64 6e 27 74 20 72 65 67 69 G: Couldn't regi
5ff0: 73 74 65 72 20 74 65 73 74 20 22 20 74 65 73 74 ster test " test
6000: 2d 6e 61 6d 65 20 22 20 77 69 74 68 20 69 74 65 -name " with ite
6010: 6d 20 70 61 74 68 20 22 20 69 74 65 6d 2d 70 61 m path " item-pa
6020: 74 68 20 22 2c 20 73 6b 69 70 70 69 6e 67 22 29 th ", skipping")
6030: 0a 09 09 09 09 28 69 66 20 28 6e 6f 74 20 28 6e .....(if (not (n
6040: 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 09 09 09 20 ull? tal)).....
6050: 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 (loop (car ta
6060: 6c 29 28 63 64 72 20 74 61 6c 29 29 29 29 29 29 l)(cdr tal))))))
6070: 29 0a 09 09 20 20 20 20 28 63 68 61 6e 67 65 2d )... (change-
6080: 64 69 72 65 63 74 6f 72 79 20 74 65 73 74 2d 70 directory test-p
6090: 61 74 68 29 0a 09 09 20 20 20 20 3b 3b 20 74 68 ath)... ;; th
60a0: 69 73 20 62 6c 6f 63 6b 20 69 73 20 68 65 72 65 is block is here
60b0: 20 6f 6e 6c 79 20 74 6f 20 69 6e 66 6f 72 6d 20 only to inform
60c0: 74 68 65 20 75 73 65 72 20 65 61 72 6c 79 20 6f the user early o
60d0: 6e 0a 09 09 20 20 20 20 28 69 66 20 28 66 69 6c n... (if (fil
60e0: 65 2d 65 78 69 73 74 73 3f 20 72 75 6e 63 6f 6e e-exists? runcon
60f0: 66 69 67 66 29 0a 09 09 09 28 73 65 74 75 70 2d figf)....(setup-
6100: 65 6e 76 2d 64 65 66 61 75 6c 74 73 20 64 62 20 env-defaults db
6110: 72 75 6e 63 6f 6e 66 69 67 66 20 72 75 6e 2d 69 runconfigf run-i
6120: 64 20 2a 61 6c 72 65 61 64 79 2d 73 65 65 6e 2d d *already-seen-
6130: 72 75 6e 63 6f 6e 66 69 67 2d 69 6e 66 6f 2a 29 runconfig-info*)
6140: 0a 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 ....(debug:print
6150: 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 59 6f 75 0 "WARNING: You
6160: 20 64 6f 20 6e 6f 74 20 68 61 76 65 20 61 20 72 do not have a r
6170: 75 6e 20 63 6f 6e 66 69 67 20 66 69 6c 65 3a 20 un config file:
6180: 22 20 72 75 6e 63 6f 6e 66 69 67 66 29 29 0a 09 " runconfigf))..
6190: 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
61a0: 74 20 34 20 22 72 75 6e 2d 69 64 3a 20 22 20 72 t 4 "run-id: " r
61b0: 75 6e 2d 69 64 20 22 20 74 65 73 74 2d 6e 61 6d un-id " test-nam
61c0: 65 3a 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 e: " test-name "
61d0: 20 69 74 65 6d 2d 70 61 74 68 3a 20 22 20 69 74 item-path: " it
61e0: 65 6d 2d 70 61 74 68 20 22 20 74 65 73 74 64 61 em-path " testda
61f0: 74 3a 20 22 20 28 74 65 73 74 3a 67 65 74 2d 73 t: " (test:get-s
6200: 74 61 74 75 73 20 74 65 73 74 64 61 74 29 20 22 tatus testdat) "
6210: 20 74 65 73 74 2d 73 74 61 74 65 3a 20 22 20 28 test-state: " (
6220: 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 test:get-state t
6230: 65 73 74 64 61 74 29 29 0a 09 09 20 20 20 20 28 estdat))... (
6240: 63 61 73 65 20 28 69 66 20 28 61 72 67 73 3a 67 case (if (args:g
6250: 65 74 2d 61 72 67 20 22 2d 66 6f 72 63 65 22 29 et-arg "-force")
6260: 0a 09 09 09 20 20 20 20 20 20 27 4e 4f 54 5f 53 .... 'NOT_S
6270: 54 41 52 54 45 44 0a 09 09 09 20 20 20 20 20 20 TARTED....
6280: 28 69 66 20 74 65 73 74 64 61 74 0a 09 09 09 09 (if testdat.....
6290: 20 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f (string->symbo
62a0: 6c 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 l (test:get-stat
62b0: 65 20 74 65 73 74 64 61 74 29 29 0a 09 09 09 09 e testdat)).....
62c0: 20 20 27 66 61 69 6c 65 64 2d 74 6f 2d 69 6e 73 'failed-to-ins
62d0: 65 72 74 29 29 0a 09 09 20 20 20 20 20 20 28 28 ert))... ((
62e0: 66 61 69 6c 65 64 2d 74 6f 2d 69 6e 73 65 72 74 failed-to-insert
62f0: 29 0a 09 09 20 20 20 20 20 20 20 28 64 65 62 75 )... (debu
6300: 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 g:print 0 "ERROR
6310: 3a 20 46 61 69 6c 65 64 20 74 6f 20 69 6e 73 65 : Failed to inse
6320: 72 74 20 74 68 65 20 72 65 63 6f 72 64 20 69 6e rt the record in
6330: 74 6f 20 74 68 65 20 64 62 22 29 29 0a 09 09 20 to the db"))...
6340: 20 20 20 20 20 28 28 4e 4f 54 5f 53 54 41 52 54 ((NOT_START
6350: 45 44 20 43 4f 4d 50 4c 45 54 45 44 29 0a 09 09 ED COMPLETED)...
6360: 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 (debug:pr
6370: 69 6e 74 20 36 20 22 47 6f 74 20 68 65 72 65 2c int 6 "Got here,
6380: 20 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 " (test:get-sta
6390: 74 65 20 74 65 73 74 64 61 74 29 29 0a 09 09 20 te testdat))...
63a0: 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 75 6e (let ((run
63b0: 66 6c 61 67 20 23 66 29 29 0a 09 09 09 20 28 63 flag #f)).... (c
63c0: 6f 6e 64 0a 09 09 09 20 20 3b 3b 20 69 2e 65 2e ond.... ;; i.e.
63d0: 20 74 68 69 73 20 69 73 20 74 68 65 20 70 61 72 this is the par
63e0: 65 6e 74 20 74 65 73 74 20 74 6f 20 61 20 73 75 ent test to a su
63f0: 69 74 65 20 6f 66 20 69 74 65 6d 73 2c 20 6e 65 ite of items, ne
6400: 76 65 72 20 22 72 75 6e 22 20 69 74 0a 09 09 09 ver "run" it....
6410: 20 20 28 70 61 72 65 6e 74 2d 74 65 73 74 0a 09 (parent-test..
6420: 09 09 20 20 20 28 73 65 74 21 20 72 75 6e 66 6c .. (set! runfl
6430: 61 67 20 23 66 29 29 0a 09 09 09 20 20 3b 3b 20 ag #f)).... ;;
6440: 2d 66 6f 72 63 65 2c 20 72 75 6e 20 6e 6f 20 6d -force, run no m
6450: 61 74 74 65 72 20 77 68 61 74 0a 09 09 09 20 20 atter what....
6460: 28 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 ((args:get-arg "
6470: 2d 66 6f 72 63 65 22 29 28 73 65 74 21 20 72 75 -force")(set! ru
6480: 6e 66 6c 61 67 20 23 74 29 29 0a 09 09 09 20 20 nflag #t))....
6490: 3b 3b 20 4e 4f 54 5f 53 54 41 52 54 45 44 2c 20 ;; NOT_STARTED,
64a0: 72 75 6e 20 6e 6f 20 6d 61 74 74 65 72 20 77 68 run no matter wh
64b0: 61 74 0a 09 09 09 20 20 28 28 65 71 75 61 6c 3f at.... ((equal?
64c0: 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 (test:get-state
64d0: 20 74 65 73 74 64 61 74 29 20 22 4e 4f 54 5f 53 testdat) "NOT_S
64e0: 54 41 52 54 45 44 22 29 28 73 65 74 21 20 72 75 TARTED")(set! ru
64f0: 6e 66 6c 61 67 20 23 74 29 29 0a 09 09 09 20 20 nflag #t))....
6500: 3b 3b 20 6e 6f 74 20 2d 72 65 72 75 6e 20 61 6e ;; not -rerun an
6510: 64 20 50 41 53 53 2c 20 57 41 52 4e 20 6f 72 20 d PASS, WARN or
6520: 43 48 45 43 4b 2c 20 64 6f 20 6e 6f 20 72 75 6e CHECK, do no run
6530: 0a 09 09 09 20 20 28 28 61 6e 64 20 28 6f 72 20 .... ((and (or
6540: 28 6e 6f 74 20 28 61 72 67 73 3a 67 65 74 2d 61 (not (args:get-a
6550: 72 67 20 22 2d 72 65 72 75 6e 22 29 29 0a 09 09 rg "-rerun"))...
6560: 09 09 20 20 20 20 28 61 72 67 73 3a 67 65 74 2d .. (args:get-
6570: 61 72 67 20 22 2d 6b 65 65 70 67 6f 69 6e 67 22 arg "-keepgoing"
6580: 29 29 0a 09 09 09 09 28 6d 65 6d 62 65 72 20 28 )).....(member (
6590: 74 65 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 test:get-status
65a0: 74 65 73 74 64 61 74 29 20 27 28 22 50 41 53 53 testdat) '("PASS
65b0: 22 20 22 57 41 52 4e 22 20 22 43 48 45 43 4b 22 " "WARN" "CHECK"
65c0: 29 29 29 0a 09 09 09 20 20 20 28 73 65 74 21 20 ))).... (set!
65d0: 72 75 6e 66 6c 61 67 20 23 66 29 29 0a 09 09 09 runflag #f))....
65e0: 20 20 3b 3b 20 2d 72 65 72 75 6e 20 61 6e 64 20 ;; -rerun and
65f0: 73 74 61 74 75 73 20 69 73 20 6f 6e 65 20 6f 66 status is one of
6600: 20 74 68 65 20 73 70 65 63 69 66 65 64 2c 20 72 the specifed, r
6610: 75 6e 20 69 74 0a 09 09 09 20 20 28 28 61 6e 64 un it.... ((and
6620: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
6630: 2d 72 65 72 75 6e 22 29 0a 09 09 09 09 28 6c 65 -rerun").....(le
6640: 74 20 28 28 72 65 72 75 6e 6c 73 74 20 28 73 74 t ((rerunlst (st
6650: 72 69 6e 67 2d 73 70 6c 69 74 20 28 61 72 67 73 ring-split (args
6660: 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 72 75 6e :get-arg "-rerun
6670: 22 29 20 22 2c 22 29 29 29 20 3b 3b 20 46 41 49 ") ","))) ;; FAI
6680: 4c 2c 0a 09 09 09 09 20 20 28 6d 65 6d 62 65 72 L,..... (member
6690: 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 75 (test:get-statu
66a0: 73 20 74 65 73 74 64 61 74 29 20 72 65 72 75 6e s testdat) rerun
66b0: 6c 73 74 29 29 29 0a 09 09 09 20 20 20 28 73 65 lst))).... (se
66c0: 74 21 20 72 75 6e 66 6c 61 67 20 23 74 29 29 0a t! runflag #t)).
66d0: 09 09 09 20 20 3b 3b 20 2d 6b 65 65 70 67 6f 69 ... ;; -keepgoi
66e0: 6e 67 2c 20 64 6f 20 6e 6f 74 20 72 65 72 75 6e ng, do not rerun
66f0: 20 46 41 49 4c 0a 09 09 09 20 20 28 28 61 6e 64 FAIL.... ((and
6700: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
6710: 2d 6b 65 65 70 67 6f 69 6e 67 22 29 0a 09 09 09 -keepgoing")....
6720: 09 28 6d 65 6d 62 65 72 20 28 74 65 73 74 3a 67 .(member (test:g
6730: 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 et-status testda
6740: 74 29 20 27 28 22 46 41 49 4c 22 29 29 29 0a 09 t) '("FAIL")))..
6750: 09 09 20 20 20 28 73 65 74 21 20 72 75 6e 66 6c .. (set! runfl
6760: 61 67 20 23 66 29 29 0a 09 09 09 20 20 28 28 61 ag #f)).... ((a
6770: 6e 64 20 28 6e 6f 74 20 28 61 72 67 73 3a 67 65 nd (not (args:ge
6780: 74 2d 61 72 67 20 22 2d 72 65 72 75 6e 22 29 29 t-arg "-rerun"))
6790: 0a 09 09 09 09 28 6d 65 6d 62 65 72 20 28 74 65 .....(member (te
67a0: 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 st:get-status te
67b0: 73 74 64 61 74 29 20 27 28 22 46 41 49 4c 22 20 stdat) '("FAIL"
67c0: 22 6e 2f 61 22 29 29 29 0a 09 09 09 20 20 20 28 "n/a"))).... (
67d0: 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 74 29 set! runflag #t)
67e0: 29 0a 09 09 09 20 20 28 65 6c 73 65 20 28 73 65 ).... (else (se
67f0: 74 21 20 72 75 6e 66 6c 61 67 20 23 66 29 29 29 t! runflag #f)))
6800: 0a 09 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e .... (debug:prin
6810: 74 20 36 20 22 52 55 4e 4e 49 4e 47 20 3d 3e 20 t 6 "RUNNING =>
6820: 72 75 6e 66 6c 61 67 3a 20 22 20 72 75 6e 66 6c runflag: " runfl
6830: 61 67 20 22 20 53 54 41 54 45 3a 20 22 20 28 74 ag " STATE: " (t
6840: 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 est:get-state te
6850: 73 74 64 61 74 29 20 22 20 53 54 41 54 55 53 3a stdat) " STATUS:
6860: 20 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 " (test:get-sta
6870: 74 75 73 20 74 65 73 74 64 61 74 29 29 0a 09 09 tus testdat))...
6880: 09 20 28 69 66 20 28 6e 6f 74 20 72 75 6e 66 6c . (if (not runfl
6890: 61 67 29 0a 09 09 09 20 20 20 20 20 28 69 66 20 ag).... (if
68a0: 28 6e 6f 74 20 70 61 72 65 6e 74 2d 74 65 73 74 (not parent-test
68b0: 29 0a 09 09 09 09 20 28 64 65 62 75 67 3a 70 72 )..... (debug:pr
68c0: 69 6e 74 20 31 20 22 4e 4f 54 45 3a 20 4e 6f 74 int 1 "NOTE: Not
68d0: 20 73 74 61 72 74 69 6e 67 20 74 65 73 74 20 22 starting test "
68e0: 20 6e 65 77 2d 74 65 73 74 2d 6e 61 6d 65 20 22 new-test-name "
68f0: 20 61 73 20 69 74 20 69 73 20 73 74 61 74 65 20 as it is state
6900: 5c 22 43 4f 4d 50 4c 45 54 45 44 5c 22 20 61 6e \"COMPLETED\" an
6910: 64 20 73 74 61 74 75 73 20 5c 22 22 20 28 74 65 d status \"" (te
6920: 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 st:get-status te
6930: 73 74 64 61 74 29 20 22 5c 22 2c 20 75 73 65 20 stdat) "\", use
6940: 2d 66 6f 72 63 65 20 74 6f 20 6f 76 65 72 72 69 -force to overri
6950: 64 65 22 29 29 0a 09 09 09 20 20 20 20 20 28 6c de")).... (l
6960: 65 74 2a 20 28 28 67 65 74 2d 70 72 65 72 65 71 et* ((get-prereq
6970: 73 2d 63 6d 64 20 28 6c 61 6d 62 64 61 20 28 29 s-cmd (lambda ()
6980: 0a 09 09 09 09 09 09 20 20 20 20 20 20 20 28 64 ....... (d
6990: 62 2d 67 65 74 2d 70 72 65 72 65 71 73 2d 6e 6f b-get-prereqs-no
69a0: 74 2d 6d 65 74 20 64 62 20 72 75 6e 2d 69 64 20 t-met db run-id
69b0: 77 61 69 74 6f 6e 29 29 29 20 3b 3b 20 63 68 65 waiton))) ;; che
69c0: 63 6b 20 62 65 66 6f 72 65 20 72 75 6e 6e 69 6e ck before runnin
69d0: 67 20 2e 2e 2e 2e 0a 09 09 09 09 20 20 20 20 28 g ......... (
69e0: 6c 61 75 6e 63 68 2d 63 6d 64 20 20 20 20 20 20 launch-cmd
69f0: 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 09 09 (lambda ()......
6a00: 09 20 20 20 20 20 20 20 28 6c 61 75 6e 63 68 2d . (launch-
6a10: 74 65 73 74 20 64 62 20 72 75 6e 2d 69 64 20 74 test db run-id t
6a20: 65 73 74 2d 63 6f 6e 66 20 6b 65 79 76 61 6c 6c est-conf keyvall
6a30: 73 74 20 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 st test-name tes
6a40: 74 2d 70 61 74 68 20 69 74 65 6d 64 61 74 29 29 t-path itemdat))
6a50: 29 0a 09 09 09 09 20 20 20 20 28 74 65 73 74 72 )..... (testr
6a60: 75 6e 64 61 74 20 20 20 20 20 20 28 6c 69 73 74 undat (list
6a70: 20 67 65 74 2d 70 72 65 72 65 71 73 2d 63 6d 64 get-prereqs-cmd
6a80: 20 6c 61 75 6e 63 68 2d 63 6d 64 29 29 29 0a 09 launch-cmd)))..
6a90: 09 09 20 20 20 20 20 20 20 28 69 66 20 28 6f 72 .. (if (or
6aa0: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
6ab0: 2d 66 6f 72 63 65 22 29 0a 09 09 09 09 20 20 20 -force").....
6ac0: 20 20 20 20 28 6c 65 74 20 28 28 70 72 65 71 73 (let ((preqs
6ad0: 2d 6e 6f 74 2d 79 65 74 2d 6d 65 74 20 28 28 63 -not-yet-met ((c
6ae0: 61 72 20 74 65 73 74 72 75 6e 64 61 74 29 29 29 ar testrundat)))
6af0: 29 0a 09 09 09 09 09 20 28 64 65 62 75 67 3a 70 )...... (debug:p
6b00: 72 69 6e 74 20 32 20 22 50 72 65 71 72 65 71 75 rint 2 "Preqrequ
6b10: 65 73 69 74 65 73 20 66 6f 72 20 22 20 74 65 73 esites for " tes
6b20: 74 2d 6e 61 6d 65 20 22 3a 20 22 20 70 72 65 71 t-name ": " preq
6b30: 73 2d 6e 6f 74 2d 79 65 74 2d 6d 65 74 29 0a 09 s-not-yet-met)..
6b40: 09 09 09 09 20 28 6e 75 6c 6c 3f 20 70 72 65 71 .... (null? preq
6b50: 73 2d 6e 6f 74 2d 79 65 74 2d 6d 65 74 29 29 29 s-not-yet-met)))
6b60: 20 3b 3b 20 61 72 65 20 74 68 65 72 65 20 61 6e ;; are there an
6b70: 79 20 74 65 73 74 73 20 74 68 61 74 20 6d 75 73 y tests that mus
6b80: 74 20 62 65 20 72 75 6e 20 62 65 66 6f 72 65 20 t be run before
6b90: 74 68 69 73 20 6f 6e 65 2e 2e 2e 0a 09 09 09 09 this one........
6ba0: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 28 63 61 (if (not ((ca
6bb0: 64 72 20 74 65 73 74 72 75 6e 64 61 74 29 29 29 dr testrundat)))
6bc0: 20 3b 3b 20 74 68 69 73 20 69 73 20 74 68 65 20 ;; this is the
6bd0: 6c 69 6e 65 20 74 68 61 74 20 6c 61 75 6e 63 68 line that launch
6be0: 65 73 20 74 68 65 20 74 65 73 74 20 74 6f 20 74 es the test to t
6bf0: 68 65 20 72 65 6d 6f 74 65 20 68 6f 73 74 0a 09 he remote host..
6c00: 09 09 09 20 20 20 20 20 20 20 28 62 65 67 69 6e ... (begin
6c10: 0a 09 09 09 09 09 20 28 70 72 69 6e 74 20 22 45 ...... (print "E
6c20: 52 52 4f 52 3a 20 46 61 69 6c 65 64 20 74 6f 20 RROR: Failed to
6c30: 6c 61 75 6e 63 68 20 74 68 65 20 74 65 73 74 2e launch the test.
6c40: 20 45 78 69 74 69 6e 67 20 61 73 20 73 6f 6f 6e Exiting as soon
6c50: 20 61 73 20 70 6f 73 73 69 62 6c 65 22 29 0a 09 as possible")..
6c60: 09 09 09 09 20 28 73 65 74 21 20 2a 67 6c 6f 62 .... (set! *glob
6c70: 61 6c 65 78 69 74 73 74 61 74 75 73 2a 20 31 29 alexitstatus* 1)
6c80: 20 3b 3b 20 0a 09 09 09 09 09 20 28 70 72 6f 63 ;; ...... (proc
6c90: 65 73 73 2d 73 69 67 6e 61 6c 20 28 63 75 72 72 ess-signal (curr
6ca0: 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 20 ent-process-id)
6cb0: 73 69 67 6e 61 6c 2f 6b 69 6c 6c 29 0a 09 09 09 signal/kill)....
6cc0: 09 09 20 3b 28 65 78 69 74 20 31 29 0a 09 09 09 .. ;(exit 1)....
6cd0: 09 09 20 29 29 0a 09 09 09 09 20 20 20 28 69 66 .. ))..... (if
6ce0: 20 28 6e 6f 74 20 28 61 72 67 73 3a 67 65 74 2d (not (args:get-
6cf0: 61 72 67 20 22 2d 6b 65 65 70 67 6f 69 6e 67 22 arg "-keepgoing"
6d00: 29 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 68 ))..... (h
6d10: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a ash-table-set! *
6d20: 77 61 69 74 69 6e 67 2d 71 75 65 75 65 2a 20 6e waiting-queue* n
6d30: 65 77 2d 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 ew-test-name tes
6d40: 74 72 75 6e 64 61 74 29 29 29 29 29 29 29 0a 09 trundat)))))))..
6d50: 09 20 20 20 20 20 20 28 28 4b 49 4c 4c 45 44 29 . ((KILLED)
6d60: 20 0a 09 09 20 20 20 20 20 20 20 28 64 65 62 75 ... (debu
6d70: 67 3a 70 72 69 6e 74 20 31 20 22 4e 4f 54 45 3a g:print 1 "NOTE:
6d80: 20 22 20 6e 65 77 2d 74 65 73 74 2d 6e 61 6d 65 " new-test-name
6d90: 20 22 20 69 73 20 61 6c 72 65 61 64 79 20 72 75 " is already ru
6da0: 6e 6e 69 6e 67 20 6f 72 20 77 61 73 20 65 78 70 nning or was exp
6db0: 6c 69 63 74 6c 79 20 6b 69 6c 6c 65 64 2c 20 75 lictly killed, u
6dc0: 73 65 20 2d 66 6f 72 63 65 20 74 6f 20 6c 61 75 se -force to lau
6dd0: 6e 63 68 20 69 74 2e 22 29 29 0a 09 09 20 20 20 nch it."))...
6de0: 20 20 20 28 28 4c 41 55 4e 43 48 45 44 20 52 45 ((LAUNCHED RE
6df0: 4d 4f 54 45 48 4f 53 54 53 54 41 52 54 20 52 55 MOTEHOSTSTART RU
6e00: 4e 4e 49 4e 47 29 20 20 0a 09 09 20 20 20 20 20 NNING) ...
6e10: 20 20 28 69 66 20 28 3e 20 28 2d 20 28 63 75 72 (if (> (- (cur
6e20: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 28 2b 20 rent-seconds)(+
6e30: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 65 76 65 (db:test-get-eve
6e40: 6e 74 5f 74 69 6d 65 20 74 65 73 74 64 61 74 29 nt_time testdat)
6e50: 0a 09 09 09 09 09 09 20 20 20 20 20 28 64 62 3a ....... (db:
6e60: 74 65 73 74 2d 67 65 74 2d 72 75 6e 5f 64 75 72 test-get-run_dur
6e70: 61 74 69 6f 6e 20 74 65 73 74 64 61 74 29 29 29 ation testdat)))
6e80: 0a 09 09 09 20 20 20 20 20 20 31 30 30 29 20 3b .... 100) ;
6e90: 3b 20 69 2e 65 2e 20 6e 6f 20 75 70 64 61 74 65 ; i.e. no update
6ea0: 20 66 6f 72 20 6d 6f 72 65 20 74 68 61 6e 20 31 for more than 1
6eb0: 30 30 20 73 65 63 6f 6e 64 73 0a 09 09 09 20 20 00 seconds....
6ec0: 20 28 62 65 67 69 6e 0a 09 09 09 20 20 20 20 20 (begin....
6ed0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
6ee0: 57 41 52 4e 49 4e 47 3a 20 54 65 73 74 20 22 20 WARNING: Test "
6ef0: 74 65 73 74 2d 6e 61 6d 65 20 22 20 61 70 70 65 test-name " appe
6f00: 61 72 73 20 74 6f 20 62 65 20 64 65 61 64 2e 20 ars to be dead.
6f10: 46 6f 72 63 69 6e 67 20 69 74 20 74 6f 20 73 74 Forcing it to st
6f20: 61 74 65 20 49 4e 43 4f 4d 50 4c 45 54 45 20 61 ate INCOMPLETE a
6f30: 6e 64 20 73 74 61 74 75 73 20 53 54 55 43 4b 2f nd status STUCK/
6f40: 44 45 41 44 22 29 0a 09 09 09 20 20 20 20 20 28 DEAD").... (
6f50: 74 65 73 74 2d 73 65 74 2d 73 74 61 74 75 73 21 test-set-status!
6f60: 20 64 62 20 72 75 6e 2d 69 64 20 74 65 73 74 2d db run-id test-
6f70: 6e 61 6d 65 20 22 49 4e 43 4f 4d 50 4c 45 54 45 name "INCOMPLETE
6f80: 22 20 22 53 54 55 43 4b 2f 44 45 41 44 22 20 69 " "STUCK/DEAD" i
6f90: 74 65 6d 64 61 74 20 22 54 65 73 74 20 69 73 20 temdat "Test is
6fa0: 73 74 75 63 6b 20 6f 72 20 64 65 61 64 22 20 23 stuck or dead" #
6fb0: 66 29 29 0a 09 09 09 20 20 20 28 64 65 62 75 67 f)).... (debug
6fc0: 3a 70 72 69 6e 74 20 32 20 22 4e 4f 54 45 3a 20 :print 2 "NOTE:
6fd0: 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 69 73 " test-name " is
6fe0: 20 61 6c 72 65 61 64 79 20 72 75 6e 6e 69 6e 67 already running
6ff0: 22 29 29 29 0a 09 09 20 20 20 20 20 20 28 65 6c ")))... (el
7000: 73 65 20 20 20 20 20 20 20 28 64 65 62 75 67 3a se (debug:
7010: 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 print 0 "ERROR:
7020: 46 61 69 6c 65 64 20 74 6f 20 6c 61 75 6e 63 68 Failed to launch
7030: 20 74 65 73 74 20 22 20 6e 65 77 2d 74 65 73 74 test " new-test
7040: 2d 6e 61 6d 65 20 22 2e 20 55 6e 72 65 63 6f 67 -name ". Unrecog
7050: 6e 69 73 65 64 20 73 74 61 74 65 20 22 20 28 74 nised state " (t
7060: 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 est:get-state te
7070: 73 74 64 61 74 29 29 29 29 29 29 0a 09 20 20 20 stdat))))))..
7080: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c (if (not (nul
7090: 6c 3f 20 74 61 6c 29 29 0a 09 09 20 20 28 6c 6f l? tal))... (lo
70a0: 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 op (car tal)(cdr
70b0: 20 74 61 6c 29 29 29 29 29 29 29 29 29 0a 0a 28 tal)))))))))..(
70c0: 64 65 66 69 6e 65 20 28 72 75 6e 2d 77 61 69 74 define (run-wait
70d0: 69 6e 67 2d 74 65 73 74 73 20 64 62 29 0a 20 20 ing-tests db).
70e0: 28 6c 65 74 20 28 28 6e 75 6d 74 72 69 65 73 20 (let ((numtries
70f0: 20 20 20 20 20 20 20 20 20 20 30 29 0a 09 28 6c 0)..(l
7100: 61 73 74 2d 74 72 79 2d 74 69 6d 65 20 20 20 20 ast-try-time
7110: 20 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e (current-secon
7120: 64 73 29 29 0a 09 28 74 69 6d 65 73 20 20 20 20 ds))..(times
7130: 20 20 20 20 20 20 20 20 20 20 28 6c 69 73 74 20 (list
7140: 31 29 29 29 20 3b 3b 20 6d 69 6e 75 74 65 73 20 1))) ;; minutes
7150: 74 6f 20 77 61 69 74 20 62 65 66 6f 72 65 20 74 to wait before t
7160: 72 79 69 6e 67 20 61 67 61 69 6e 20 74 6f 20 6b rying again to k
7170: 69 63 6b 20 6f 66 66 20 72 75 6e 73 0a 20 20 20 ick off runs.
7180: 20 3b 3b 20 42 55 47 20 74 68 69 73 20 68 61 63 ;; BUG this hac
7190: 6b 20 6f 66 20 62 72 75 74 65 20 66 6f 72 63 65 k of brute force
71a0: 20 72 65 74 72 79 69 6e 67 20 77 6f 72 6b 73 20 retrying works
71b0: 71 75 69 74 65 20 77 65 6c 6c 20 66 6f 72 20 6d quite well for m
71c0: 61 6e 79 20 63 61 73 65 73 20 62 75 74 20 0a 20 any cases but .
71d0: 20 20 20 3b 3b 20 20 20 20 20 77 68 61 74 20 69 ;; what i
71e0: 73 20 6e 65 65 64 65 64 20 69 73 20 74 6f 20 63 s needed is to c
71f0: 68 65 63 6b 20 74 68 65 20 64 62 20 66 6f 72 20 heck the db for
7200: 74 65 73 74 73 20 74 68 61 74 20 68 61 76 65 20 tests that have
7210: 66 61 69 6c 65 64 20 6c 65 73 73 20 74 68 61 6e failed less than
7220: 0a 20 20 20 20 3b 3b 20 20 20 20 20 4e 20 74 69 . ;; N ti
7230: 6d 65 73 20 6f 72 20 6e 65 76 65 72 20 62 65 65 mes or never bee
7240: 6e 20 73 74 61 72 74 65 64 20 61 6e 64 20 6b 69 n started and ki
7250: 63 6b 20 74 68 65 6d 20 6f 66 66 20 61 67 61 69 ck them off agai
7260: 6e 0a 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 n. (let loop
7270: 28 28 77 61 69 74 69 6e 67 2d 74 65 73 74 2d 6e ((waiting-test-n
7280: 61 6d 65 73 20 28 68 61 73 68 2d 74 61 62 6c 65 ames (hash-table
7290: 2d 6b 65 79 73 20 2a 77 61 69 74 69 6e 67 2d 71 -keys *waiting-q
72a0: 75 65 75 65 2a 29 29 29 0a 20 20 20 20 20 20 28 ueue*))). (
72b0: 63 6f 6e 64 0a 20 20 20 20 20 20 20 28 28 6e 6f cond. ((no
72c0: 74 20 28 72 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d t (runs:can-run-
72d0: 6d 6f 72 65 2d 74 65 73 74 73 20 64 62 29 29 0a more-tests db)).
72e0: 09 28 73 6c 65 65 70 20 32 29 0a 09 28 6c 6f 6f .(sleep 2)..(loo
72f0: 70 20 77 61 69 74 69 6e 67 2d 74 65 73 74 2d 6e p waiting-test-n
7300: 61 6d 65 73 29 29 0a 20 20 20 20 20 20 20 28 28 ames)). ((
7310: 6e 75 6c 6c 3f 20 77 61 69 74 69 6e 67 2d 74 65 null? waiting-te
7320: 73 74 2d 6e 61 6d 65 73 29 0a 09 28 64 65 62 75 st-names)..(debu
7330: 67 3a 70 72 69 6e 74 20 31 20 22 41 6c 6c 20 74 g:print 1 "All t
7340: 65 73 74 73 20 6c 61 75 6e 63 68 65 64 22 29 29 ests launched"))
7350: 0a 20 20 20 20 20 20 20 28 65 6c 73 65 0a 09 28 . (else..(
7360: 73 65 74 21 20 6e 75 6d 74 72 69 65 73 20 28 2b set! numtries (+
7370: 20 6e 75 6d 74 72 69 65 73 20 31 29 29 0a 09 28 numtries 1))..(
7380: 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 for-each (lambda
7390: 20 28 74 65 73 74 6e 61 6d 65 29 0a 09 09 20 20 (testname)...
73a0: 20 20 28 69 66 20 28 72 75 6e 73 3a 63 61 6e 2d (if (runs:can-
73b0: 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 20 64 run-more-tests d
73c0: 62 29 0a 09 09 09 28 6c 65 74 2a 20 28 28 74 65 b)....(let* ((te
73d0: 73 74 64 61 74 20 28 68 61 73 68 2d 74 61 62 6c stdat (hash-tabl
73e0: 65 2d 72 65 66 20 2a 77 61 69 74 69 6e 67 2d 71 e-ref *waiting-q
73f0: 75 65 75 65 2a 20 74 65 73 74 6e 61 6d 65 29 29 ueue* testname))
7400: 0a 09 09 09 20 20 20 20 20 20 20 28 70 72 65 72 .... (prer
7410: 65 71 73 20 28 28 63 61 72 20 74 65 73 74 64 61 eqs ((car testda
7420: 74 29 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 t))).... (
7430: 6c 64 62 20 20 20 20 20 28 69 66 20 64 62 20 64 ldb (if db d
7440: 62 20 28 6f 70 65 6e 2d 64 62 29 29 29 29 0a 09 b (open-db))))..
7450: 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
7460: 20 32 20 22 70 72 65 72 65 71 73 20 72 65 6d 61 2 "prereqs rema
7470: 69 6e 69 6e 67 3a 20 22 20 70 72 65 72 65 71 73 ining: " prereqs
7480: 29 0a 09 09 09 20 20 28 69 66 20 28 6e 75 6c 6c ).... (if (null
7490: 3f 20 70 72 65 72 65 71 73 29 0a 09 09 09 20 20 ? prereqs)....
74a0: 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 09 28 (begin.....(
74b0: 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 50 debug:print 2 "P
74c0: 72 65 72 65 71 75 69 73 69 74 65 73 20 6d 65 74 rerequisites met
74d0: 2c 20 6c 61 75 6e 63 68 69 6e 67 20 22 20 74 65 , launching " te
74e0: 73 74 6e 61 6d 65 29 0a 09 09 09 09 28 28 63 61 stname).....((ca
74f0: 64 72 20 74 65 73 74 64 61 74 29 29 0a 09 09 09 dr testdat))....
7500: 09 28 68 61 73 68 2d 74 61 62 6c 65 2d 64 65 6c .(hash-table-del
7510: 65 74 65 21 20 2a 77 61 69 74 69 6e 67 2d 71 75 ete! *waiting-qu
7520: 65 75 65 2a 20 74 65 73 74 6e 61 6d 65 29 29 29 eue* testname)))
7530: 0a 09 09 09 20 20 28 69 66 20 28 6e 6f 74 20 64 .... (if (not d
7540: 62 29 0a 09 09 09 20 20 20 20 20 20 28 73 71 6c b).... (sql
7550: 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 6c ite3:finalize! l
7560: 64 62 29 29 29 29 29 0a 09 09 20 20 77 61 69 74 db)))))... wait
7570: 69 6e 67 2d 74 65 73 74 2d 6e 61 6d 65 73 29 0a ing-test-names).
7580: 09 3b 3b 20 28 73 6c 65 65 70 20 31 30 29 20 3b .;; (sleep 10) ;
7590: 3b 20 6e 6f 20 70 6f 69 6e 74 20 69 6e 20 72 75 ; no point in ru
75a0: 73 68 69 6e 67 20 74 68 69 6e 67 73 20 61 74 20 shing things at
75b0: 74 68 69 73 20 73 74 61 67 65 3f 0a 09 28 6c 6f this stage?..(lo
75c0: 6f 70 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b op (hash-table-k
75d0: 65 79 73 20 2a 77 61 69 74 69 6e 67 2d 71 75 65 eys *waiting-que
75e0: 75 65 2a 29 29 29 29 29 29 29 0a 0a 28 64 65 66 ue*)))))))..(def
75f0: 69 6e 65 20 28 67 65 74 2d 64 69 72 2d 75 70 2d ine (get-dir-up-
7600: 6e 20 64 69 72 20 2e 20 70 61 72 61 6d 73 29 20 n dir . params)
7610: 0a 20 20 28 6c 65 74 20 28 28 64 70 61 72 74 73 . (let ((dparts
7620: 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 (string-split
7630: 64 69 72 20 22 2f 22 29 29 0a 09 28 63 6f 75 6e dir "/"))..(coun
7640: 74 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 70 t (if (null? p
7650: 61 72 61 6d 73 29 20 31 20 28 63 61 72 20 70 61 arams) 1 (car pa
7660: 72 61 6d 73 29 29 29 29 0a 20 20 20 20 28 63 6f rams)))). (co
7670: 6e 63 20 22 2f 22 20 28 73 74 72 69 6e 67 2d 69 nc "/" (string-i
7680: 6e 74 65 72 73 70 65 72 73 65 20 0a 09 20 20 20 ntersperse ..
7690: 20 20 20 20 28 74 61 6b 65 20 64 70 61 72 74 73 (take dparts
76a0: 20 28 2d 20 28 6c 65 6e 67 74 68 20 64 70 61 72 (- (length dpar
76b0: 74 73 29 20 63 6f 75 6e 74 29 29 0a 09 20 20 20 ts) count))..
76c0: 20 20 20 20 22 2f 22 29 29 29 29 0a 3b 3b 20 52 "/")))).;; R
76d0: 65 6d 6f 76 65 20 72 75 6e 73 0a 3b 3b 20 66 69 emove runs.;; fi
76e0: 65 6c 64 73 20 61 72 65 20 70 61 73 73 69 6e 67 elds are passing
76f0: 20 69 6e 20 74 68 72 6f 75 67 68 20 0a 28 64 65 in through .(de
7700: 66 69 6e 65 20 28 72 75 6e 73 3a 72 65 6d 6f 76 fine (runs:remov
7710: 65 2d 72 75 6e 73 20 64 62 20 72 75 6e 6e 61 6d e-runs db runnam
7720: 65 70 61 74 74 20 74 65 73 74 70 61 74 74 20 69 epatt testpatt i
7730: 74 65 6d 70 61 74 74 29 0a 20 20 28 6c 65 74 2a tempatt). (let*
7740: 20 28 28 6b 65 79 73 20 20 20 20 20 20 20 20 28 ((keys (
7750: 64 62 2d 67 65 74 2d 6b 65 79 73 20 64 62 29 29 db-get-keys db))
7760: 0a 09 20 28 72 75 6e 64 61 74 20 20 20 20 20 20 .. (rundat
7770: 28 72 75 6e 73 3a 67 65 74 2d 72 75 6e 73 2d 62 (runs:get-runs-b
7780: 79 2d 70 61 74 74 20 64 62 20 6b 65 79 73 20 72 y-patt db keys r
7790: 75 6e 6e 61 6d 65 70 61 74 74 29 29 0a 09 20 28 unnamepatt)).. (
77a0: 68 65 61 64 65 72 20 20 20 20 20 20 28 76 65 63 header (vec
77b0: 74 6f 72 2d 72 65 66 20 72 75 6e 64 61 74 20 30 tor-ref rundat 0
77c0: 29 29 0a 09 20 28 72 75 6e 73 20 20 20 20 20 20 )).. (runs
77d0: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 75 (vector-ref ru
77e0: 6e 64 61 74 20 31 29 29 29 0a 20 20 20 20 28 64 ndat 1))). (d
77f0: 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 48 65 ebug:print 1 "He
7800: 61 64 65 72 3a 20 22 20 68 65 61 64 65 72 29 0a ader: " header).
7810: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 (for-each.
7820: 20 20 20 28 6c 61 6d 62 64 61 20 28 72 75 6e 29 (lambda (run)
7830: 0a 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 . (let ((r
7840: 75 6e 6b 65 79 20 28 73 74 72 69 6e 67 2d 69 6e unkey (string-in
7850: 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 20 28 tersperse (map (
7860: 6c 61 6d 62 64 61 20 28 6b 29 0a 09 09 09 09 09 lambda (k)......
7870: 09 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 .(db:get-value-b
7880: 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 y-header run hea
7890: 64 65 72 20 28 76 65 63 74 6f 72 2d 72 65 66 20 der (vector-ref
78a0: 6b 20 30 29 29 29 20 6b 65 79 73 29 20 22 2f 22 k 0))) keys) "/"
78b0: 29 29 29 0a 09 20 28 6c 65 74 2a 20 28 28 72 75 ))).. (let* ((ru
78c0: 6e 2d 69 64 20 28 64 62 3a 67 65 74 2d 76 61 6c n-id (db:get-val
78d0: 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e ue-by-header run
78e0: 20 68 65 61 64 65 72 20 22 69 64 22 29 20 29 0a header "id") ).
78f0: 09 09 28 74 65 73 74 73 20 20 28 64 62 2d 67 65 ..(tests (db-ge
7900: 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 t-tests-for-run
7910: 64 62 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 db (db:get-value
7920: 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 -by-header run h
7930: 65 61 64 65 72 20 22 69 64 22 29 20 74 65 73 74 eader "id") test
7940: 70 61 74 74 20 69 74 65 6d 70 61 74 74 29 29 0a patt itempatt)).
7950: 09 09 28 6c 61 73 74 74 70 61 74 68 20 22 2f 64 ..(lasttpath "/d
7960: 6f 65 73 2f 6e 6f 74 2f 65 78 69 73 74 2f 49 2f oes/not/exist/I/
7970: 68 6f 70 65 22 29 29 0a 09 20 20 20 28 69 66 20 hope")).. (if
7980: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 65 73 74 (not (null? test
7990: 73 29 29 0a 09 20 20 20 20 20 20 20 28 62 65 67 s)).. (beg
79a0: 69 6e 0a 09 09 20 28 64 65 62 75 67 3a 70 72 69 in... (debug:pri
79b0: 6e 74 20 31 20 22 52 65 6d 6f 76 69 6e 67 20 74 nt 1 "Removing t
79c0: 65 73 74 73 20 66 6f 72 20 72 75 6e 3a 20 22 20 ests for run: "
79d0: 72 75 6e 6b 65 79 20 22 20 22 20 28 64 62 3a 67 runkey " " (db:g
79e0: 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 et-value-by-head
79f0: 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 72 er run header "r
7a00: 75 6e 6e 61 6d 65 22 29 29 0a 09 09 20 28 66 6f unname"))... (fo
7a10: 72 2d 65 61 63 68 0a 09 09 20 20 28 6c 61 6d 62 r-each... (lamb
7a20: 64 61 20 28 74 65 73 74 29 0a 09 09 20 20 20 20 da (test)...
7a30: 28 6c 65 74 2a 20 28 28 69 74 65 6d 2d 70 61 74 (let* ((item-pat
7a40: 68 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 h (db:test-get-i
7a50: 74 65 6d 2d 70 61 74 68 20 74 65 73 74 29 29 0a tem-path test)).
7a60: 09 09 09 20 20 20 28 74 65 73 74 2d 6e 61 6d 65 ... (test-name
7a70: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 (db:test-get-te
7a80: 73 74 6e 61 6d 65 20 74 65 73 74 29 29 0a 09 09 stname test))...
7a90: 09 20 20 20 28 72 75 6e 2d 64 69 72 20 20 20 28 . (run-dir (
7aa0: 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 db:test-get-rund
7ab0: 69 72 20 74 65 73 74 29 29 29 0a 09 09 20 20 20 ir test)))...
7ac0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
7ad0: 31 20 22 20 20 22 20 28 64 62 3a 74 65 73 74 2d 1 " " (db:test-
7ae0: 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 get-testname tes
7af0: 74 29 20 22 20 69 64 3a 20 22 20 28 64 62 3a 74 t) " id: " (db:t
7b00: 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 29 est-get-id test)
7b10: 20 22 20 22 20 69 74 65 6d 2d 70 61 74 68 29 0a " " item-path).
7b20: 09 09 20 20 20 20 20 20 28 64 62 3a 64 65 6c 65 .. (db:dele
7b30: 74 65 2d 74 65 73 74 2d 72 65 63 6f 72 64 73 20 te-test-records
7b40: 64 62 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d db (db:test-get-
7b50: 69 64 20 74 65 73 74 29 29 0a 09 09 20 20 20 20 id test))...
7b60: 20 20 28 69 66 20 28 3e 20 28 73 74 72 69 6e 67 (if (> (string
7b70: 2d 6c 65 6e 67 74 68 20 72 75 6e 2d 64 69 72 29 -length run-dir)
7b80: 20 35 29 20 3b 3b 20 62 61 64 20 68 65 75 72 69 5) ;; bad heuri
7b90: 73 74 69 63 20 62 75 74 20 73 68 6f 75 6c 64 20 stic but should
7ba0: 70 72 65 76 65 6e 74 20 2f 74 6d 70 20 2f 68 6f prevent /tmp /ho
7bb0: 6d 65 20 65 74 63 2e 0a 09 09 09 20 20 28 6c 65 me etc..... (le
7bc0: 74 20 28 28 66 75 6c 6c 70 61 74 68 20 72 75 6e t ((fullpath run
7bd0: 2d 64 69 72 29 29 20 3b 3b 20 22 2f 22 20 28 64 -dir)) ;; "/" (d
7be0: 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d b:test-get-item-
7bf0: 70 61 74 68 20 74 65 73 74 29 29 29 29 0a 09 09 path test))))...
7c00: 09 20 20 20 20 28 73 65 74 21 20 6c 61 73 74 74 . (set! lastt
7c10: 70 61 74 68 20 66 75 6c 6c 70 61 74 68 29 0a 09 path fullpath)..
7c20: 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
7c30: 6e 74 20 31 20 22 72 6d 20 2d 72 66 20 22 20 66 nt 1 "rm -rf " f
7c40: 75 6c 6c 70 61 74 68 29 0a 09 09 09 20 20 20 20 ullpath)....
7c50: 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 72 (system (conc "r
7c60: 6d 20 2d 72 66 20 22 20 66 75 6c 6c 70 61 74 68 m -rf " fullpath
7c70: 29 29 0a 09 09 09 20 20 20 20 28 6c 65 74 2a 20 )).... (let*
7c80: 28 28 64 69 72 73 2d 63 6f 75 6e 74 20 28 2b 20 ((dirs-count (+
7c90: 31 20 28 6c 65 6e 67 74 68 20 6b 65 79 73 29 28 1 (length keys)(
7ca0: 6c 65 6e 67 74 68 20 28 73 74 72 69 6e 67 2d 73 length (string-s
7cb0: 70 6c 69 74 20 69 74 65 6d 2d 70 61 74 68 20 22 plit item-path "
7cc0: 2f 22 29 29 29 29 0a 09 09 09 09 20 20 20 28 64 /"))))..... (d
7cd0: 69 72 2d 74 6f 2d 72 65 6d 20 28 67 65 74 2d 64 ir-to-rem (get-d
7ce0: 69 72 2d 75 70 2d 6e 20 66 75 6c 6c 70 61 74 68 ir-up-n fullpath
7cf0: 20 64 69 72 73 2d 63 6f 75 6e 74 29 29 0a 09 09 dirs-count))...
7d00: 09 09 20 20 20 28 72 65 6d 61 69 6e 69 6e 67 64 .. (remainingd
7d10: 20 28 73 74 72 69 6e 67 2d 73 75 62 73 74 69 74 (string-substit
7d20: 75 74 65 20 28 72 65 67 65 78 70 20 28 63 6f 6e ute (regexp (con
7d30: 63 20 22 5e 22 20 64 69 72 2d 74 6f 2d 72 65 6d c "^" dir-to-rem
7d40: 20 22 2f 22 29 29 20 22 22 20 66 75 6c 6c 70 61 "/")) "" fullpa
7d50: 74 68 29 29 0a 09 09 09 09 20 20 20 28 63 6d 64 th))..... (cmd
7d60: 20 28 63 6f 6e 63 20 22 63 64 20 22 20 64 69 72 (conc "cd " dir
7d70: 2d 74 6f 2d 72 65 6d 20 22 3b 20 72 6d 64 69 72 -to-rem "; rmdir
7d80: 20 2d 70 20 22 20 72 65 6d 61 69 6e 69 6e 67 64 -p " remainingd
7d90: 20 29 29 29 0a 09 09 09 20 20 20 20 20 20 28 69 ))).... (i
7da0: 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 f (file-exists?
7db0: 66 75 6c 6c 70 61 74 68 29 0a 09 09 09 09 20 20 fullpath).....
7dc0: 28 62 65 67 69 6e 0a 09 09 09 09 20 20 20 20 28 (begin..... (
7dd0: 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 63 6d debug:print 1 cm
7de0: 64 29 0a 09 09 09 09 20 20 20 20 28 73 79 73 74 d)..... (syst
7df0: 65 6d 20 63 6d 64 29 29 29 0a 09 09 09 20 20 20 em cmd)))....
7e00: 20 20 20 29 29 0a 09 09 09 20 20 20 20 29 29 29 )).... )))
7e10: 0a 09 09 20 20 20 20 74 65 73 74 73 29 29 29 0a ... tests))).
7e20: 09 20 20 20 28 6c 65 74 20 28 28 72 65 6d 74 65 . (let ((remte
7e30: 73 74 73 20 28 64 62 2d 67 65 74 2d 74 65 73 74 sts (db-get-test
7e40: 73 2d 66 6f 72 2d 72 75 6e 20 64 62 20 28 64 62 s-for-run db (db
7e50: 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 :get-value-by-he
7e60: 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 ader run header
7e70: 22 69 64 22 29 29 29 29 0a 09 20 20 20 20 20 28 "id")))).. (
7e80: 69 66 20 28 6e 75 6c 6c 3f 20 72 65 6d 74 65 73 if (null? remtes
7e90: 74 73 29 20 3b 3b 20 6e 6f 20 6d 6f 72 65 20 74 ts) ;; no more t
7ea0: 65 73 74 73 20 72 65 6d 61 69 6e 69 6e 67 0a 09 ests remaining..
7eb0: 09 20 28 6c 65 74 2a 20 28 28 64 70 61 72 74 73 . (let* ((dparts
7ec0: 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 (string-split
7ed0: 6c 61 73 74 74 70 61 74 68 20 22 2f 22 29 29 0a lasttpath "/")).
7ee0: 09 09 09 28 72 75 6e 70 61 74 68 20 28 63 6f 6e ...(runpath (con
7ef0: 63 20 22 2f 22 20 28 73 74 72 69 6e 67 2d 69 6e c "/" (string-in
7f00: 74 65 72 73 70 65 72 73 65 20 0a 09 09 09 09 09 tersperse ......
7f10: 20 20 20 20 28 74 61 6b 65 20 64 70 61 72 74 73 (take dparts
7f20: 20 28 2d 20 28 6c 65 6e 67 74 68 20 64 70 61 72 (- (length dpar
7f30: 74 73 29 20 31 29 29 0a 09 09 09 09 09 20 20 20 ts) 1))......
7f40: 20 22 2f 22 29 29 29 29 0a 09 09 20 20 20 28 64 "/"))))... (d
7f50: 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 52 65 ebug:print 1 "Re
7f60: 6d 6f 76 69 6e 67 20 72 75 6e 3a 20 22 20 72 75 moving run: " ru
7f70: 6e 6b 65 79 20 22 20 22 20 28 64 62 3a 67 65 74 nkey " " (db:get
7f80: 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 -value-by-header
7f90: 20 72 75 6e 20 68 65 61 64 65 72 20 22 72 75 6e run header "run
7fa0: 6e 61 6d 65 22 29 29 0a 09 09 20 20 20 28 64 62 name"))... (db
7fb0: 3a 64 65 6c 65 74 65 2d 72 75 6e 20 64 62 20 72 :delete-run db r
7fc0: 75 6e 2d 69 64 29 0a 09 09 20 20 20 3b 3b 20 6e un-id)... ;; n
7fd0: 65 65 64 20 74 6f 20 66 69 67 75 72 65 20 6f 75 eed to figure ou
7fe0: 74 20 74 68 65 20 70 61 74 68 20 74 6f 20 74 68 t the path to th
7ff0: 65 20 72 75 6e 20 64 69 72 20 61 6e 64 20 72 65 e run dir and re
8000: 6d 6f 76 65 20 69 74 20 69 66 20 65 6d 70 74 79 move it if empty
8010: 0a 09 09 20 20 20 3b 3b 20 20 20 20 28 69 66 20 ... ;; (if
8020: 28 6e 75 6c 6c 3f 20 28 67 6c 6f 62 20 28 63 6f (null? (glob (co
8030: 6e 63 20 72 75 6e 70 61 74 68 20 22 2f 2a 22 29 nc runpath "/*")
8040: 29 29 0a 09 09 20 20 20 3b 3b 20 20 20 20 20 20 ))... ;;
8050: 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 3b 3b (begin... ;;
8060: 20 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 . (debug:print
8070: 31 20 22 52 65 6d 6f 76 69 6e 67 20 72 75 6e 20 1 "Removing run
8080: 64 69 72 20 22 20 72 75 6e 70 61 74 68 29 0a 09 dir " runpath)..
8090: 09 20 20 20 3b 3b 20 09 20 28 73 79 73 74 65 6d . ;; . (system
80a0: 20 28 63 6f 6e 63 20 22 72 6d 64 69 72 20 2d 70 (conc "rmdir -p
80b0: 20 22 20 72 75 6e 70 61 74 68 29 29 29 29 0a 09 " runpath))))..
80c0: 09 20 20 20 29 29 29 29 0a 09 20 29 29 0a 20 20 . )))).. )).
80d0: 20 20 20 72 75 6e 73 29 29 29 0a 0a 3b 3b 3d 3d runs)))..;;==
80e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
80f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8100: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8110: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8120: 3d 3d 3d 3d 0a 3b 3b 20 52 6f 75 74 69 6e 65 73 ====.;; Routines
8130: 20 66 6f 72 20 6d 61 6e 69 70 75 6c 61 74 69 6e for manipulatin
8140: 67 20 72 75 6e 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d g runs.;;=======
8150: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8160: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8170: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8180: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
8190: 0a 3b 3b 20 53 69 6e 63 65 20 6d 61 6e 79 20 63 .;; Since many c
81a0: 61 6c 6c 73 20 74 6f 20 61 20 72 75 6e 20 72 65 alls to a run re
81b0: 71 75 69 72 65 20 70 72 65 74 74 79 20 6d 75 63 quire pretty muc
81c0: 68 20 74 68 65 20 73 61 6d 65 20 73 65 74 75 70 h the same setup
81d0: 20 0a 3b 3b 20 74 68 69 73 20 77 72 61 70 70 65 .;; this wrappe
81e0: 72 20 69 73 20 75 73 65 64 20 74 6f 20 72 65 64 r is used to red
81f0: 75 63 65 20 74 68 65 20 72 65 70 6c 69 63 61 74 uce the replicat
8200: 69 6f 6e 20 6f 66 20 63 6f 64 65 0a 28 64 65 66 ion of code.(def
8210: 69 6e 65 20 28 67 65 6e 65 72 61 6c 2d 72 75 6e ine (general-run
8220: 2d 63 61 6c 6c 20 73 77 69 74 63 68 6e 61 6d 65 -call switchname
8230: 20 61 63 74 69 6f 6e 2d 64 65 73 63 20 70 72 6f action-desc pro
8240: 63 29 0a 20 20 28 69 66 20 28 6e 6f 74 20 28 61 c). (if (not (a
8250: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 3a 72 75 rgs:get-arg ":ru
8260: 6e 6e 61 6d 65 22 29 29 0a 20 20 20 20 20 20 28 nname")). (
8270: 62 65 67 69 6e 0a 09 28 64 65 62 75 67 3a 70 72 begin..(debug:pr
8280: 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 4d 69 int 0 "ERROR: Mi
8290: 73 73 69 6e 67 20 72 65 71 75 69 72 65 64 20 70 ssing required p
82a0: 61 72 61 6d 65 74 65 72 20 66 6f 72 20 22 20 73 arameter for " s
82b0: 77 69 74 63 68 6e 61 6d 65 20 22 2c 20 79 6f 75 witchname ", you
82c0: 20 6d 75 73 74 20 73 70 65 63 69 66 79 20 74 68 must specify th
82d0: 65 20 72 75 6e 20 6e 61 6d 65 20 77 69 74 68 20 e run name with
82e0: 3a 72 75 6e 6e 61 6d 65 20 72 75 6e 6e 61 6d 65 :runname runname
82f0: 22 29 0a 09 28 65 78 69 74 20 32 29 29 0a 20 20 ")..(exit 2)).
8300: 20 20 20 20 28 6c 65 74 20 28 28 64 62 20 23 66 (let ((db #f
8310: 29 29 0a 09 28 69 66 20 28 6e 6f 74 20 28 73 65 ))..(if (not (se
8320: 74 75 70 2d 66 6f 72 2d 72 75 6e 29 29 0a 09 20 tup-for-run))..
8330: 20 20 20 28 62 65 67 69 6e 20 0a 09 20 20 20 20 (begin ..
8340: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
8350: 20 22 46 61 69 6c 65 64 20 74 6f 20 73 65 74 75 "Failed to setu
8360: 70 2c 20 65 78 69 74 69 6e 67 22 29 0a 09 20 20 p, exiting")..
8370: 20 20 20 20 28 65 78 69 74 20 31 29 29 29 0a 09 (exit 1)))..
8380: 28 73 65 74 21 20 64 62 20 28 6f 70 65 6e 2d 64 (set! db (open-d
8390: 62 29 29 0a 09 28 69 66 20 28 6e 6f 74 20 28 63 b))..(if (not (c
83a0: 61 72 20 2a 63 6f 6e 66 69 67 69 6e 66 6f 2a 29 ar *configinfo*)
83b0: 29 0a 09 20 20 20 20 28 62 65 67 69 6e 0a 09 20 ).. (begin..
83c0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
83d0: 74 20 30 20 22 45 52 52 4f 52 3a 20 41 74 74 65 t 0 "ERROR: Atte
83e0: 6d 70 74 65 64 20 74 6f 20 22 20 61 63 74 69 6f mpted to " actio
83f0: 6e 2d 64 65 73 63 20 22 20 62 75 74 20 72 75 6e n-desc " but run
8400: 20 61 72 65 61 20 63 6f 6e 66 69 67 20 66 69 6c area config fil
8410: 65 20 6e 6f 74 20 66 6f 75 6e 64 22 29 0a 09 20 e not found")..
8420: 20 20 20 20 20 28 65 78 69 74 20 31 29 29 0a 09 (exit 1))..
8430: 20 20 20 20 3b 3b 20 45 78 74 72 61 63 74 20 6f ;; Extract o
8440: 75 74 20 73 74 75 66 66 20 6e 65 65 64 65 64 20 ut stuff needed
8450: 69 6e 20 6d 6f 73 74 20 6f 72 20 6d 61 6e 79 20 in most or many
8460: 63 61 6c 6c 73 0a 09 20 20 20 20 3b 3b 20 68 65 calls.. ;; he
8470: 72 65 20 74 68 65 6e 20 63 61 6c 6c 20 70 72 6f re then call pro
8480: 63 0a 09 20 20 20 20 28 6c 65 74 2a 20 28 28 6b c.. (let* ((k
8490: 65 79 73 20 20 20 20 20 20 20 28 64 62 2d 67 65 eys (db-ge
84a0: 74 2d 6b 65 79 73 20 64 62 29 29 0a 09 09 20 20 t-keys db))...
84b0: 20 28 6b 65 79 6e 61 6d 65 73 20 20 20 28 6d 61 (keynames (ma
84c0: 70 20 6b 65 79 3a 67 65 74 2d 66 69 65 6c 64 6e p key:get-fieldn
84d0: 61 6d 65 20 6b 65 79 73 29 29 0a 09 09 20 20 20 ame keys))...
84e0: 28 6b 65 79 76 61 6c 6c 73 74 20 20 28 6b 65 79 (keyvallst (key
84f0: 73 2d 3e 76 61 6c 6c 69 73 74 20 6b 65 79 73 20 s->vallist keys
8500: 23 74 29 29 29 0a 09 20 20 20 20 20 20 28 70 72 #t))).. (pr
8510: 6f 63 20 64 62 20 6b 65 79 73 20 6b 65 79 6e 61 oc db keys keyna
8520: 6d 65 73 20 6b 65 79 76 61 6c 6c 73 74 29 29 29 mes keyvallst)))
8530: 0a 09 28 73 71 6c 69 74 65 33 3a 66 69 6e 61 6c ..(sqlite3:final
8540: 69 7a 65 21 20 64 62 29 0a 09 28 73 65 74 21 20 ize! db)..(set!
8550: 2a 64 69 64 73 6f 6d 65 74 68 69 6e 67 2a 20 23 *didsomething* #
8560: 74 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d t))))..;;=======
8570: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8580: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8590: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
85a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
85b0: 3b 3b 20 52 6f 6c 6c 75 70 20 72 75 6e 73 0a 3b ;; Rollup runs.;
85c0: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
85d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
85e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
85f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8600: 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 55 70 64 61 =======..;; Upda
8610: 74 65 20 74 68 65 20 74 65 73 74 5f 6d 65 74 61 te the test_meta
8620: 20 74 61 62 6c 65 20 66 6f 72 20 74 68 69 73 20 table for this
8630: 74 65 73 74 0a 28 64 65 66 69 6e 65 20 28 72 75 test.(define (ru
8640: 6e 73 3a 75 70 64 61 74 65 2d 74 65 73 74 5f 6d ns:update-test_m
8650: 65 74 61 20 64 62 20 74 65 73 74 2d 6e 61 6d 65 eta db test-name
8660: 20 74 65 73 74 2d 63 6f 6e 66 29 0a 20 20 28 6c test-conf). (l
8670: 65 74 20 28 28 63 75 72 72 72 65 63 6f 72 64 20 et ((currrecord
8680: 28 64 62 3a 74 65 73 74 6d 65 74 61 2d 67 65 74 (db:testmeta-get
8690: 2d 72 65 63 6f 72 64 20 64 62 20 74 65 73 74 2d -record db test-
86a0: 6e 61 6d 65 29 29 29 0a 20 20 20 20 28 69 66 20 name))). (if
86b0: 28 6e 6f 74 20 63 75 72 72 72 65 63 6f 72 64 29 (not currrecord)
86c0: 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 73 65 74 ..(begin.. (set
86d0: 21 20 63 75 72 72 72 65 63 6f 72 64 20 28 6d 61 ! currrecord (ma
86e0: 6b 65 2d 76 65 63 74 6f 72 20 31 30 20 23 66 29 ke-vector 10 #f)
86f0: 29 0a 09 20 20 28 64 62 3a 74 65 73 74 6d 65 74 ).. (db:testmet
8700: 61 2d 61 64 64 2d 72 65 63 6f 72 64 20 64 62 20 a-add-record db
8710: 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a 20 20 20 test-name))).
8720: 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 (for-each .
8730: 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 29 0a 20 (lambda (key).
8740: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 69 64 (let* ((id
8750: 78 20 28 63 61 64 72 20 6b 65 79 29 29 0a 09 20 x (cadr key))..
8760: 20 20 20 20 20 28 66 6c 64 20 28 63 61 72 20 20 (fld (car
8770: 6b 65 79 29 29 0a 09 20 20 20 20 20 20 28 76 61 key)).. (va
8780: 6c 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 l (config-lookup
8790: 20 74 65 73 74 2d 63 6f 6e 66 20 22 74 65 73 74 test-conf "test
87a0: 5f 6d 65 74 61 22 20 66 6c 64 29 29 29 0a 09 20 _meta" fld)))..
87b0: 28 69 66 20 28 61 6e 64 20 76 61 6c 20 28 6e 6f (if (and val (no
87c0: 74 20 28 65 71 75 61 6c 3f 20 28 76 65 63 74 6f t (equal? (vecto
87d0: 72 2d 72 65 66 20 63 75 72 72 72 65 63 6f 72 64 r-ref currrecord
87e0: 20 69 64 78 29 20 76 61 6c 29 29 29 0a 09 20 20 idx) val)))..
87f0: 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 (begin..
8800: 20 20 28 70 72 69 6e 74 20 22 55 70 64 61 74 69 (print "Updati
8810: 6e 67 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 ng " test-name "
8820: 20 22 20 66 6c 64 20 22 20 74 6f 20 22 20 76 61 " fld " to " va
8830: 6c 29 0a 09 20 20 20 20 20 20 20 28 64 62 3a 74 l).. (db:t
8840: 65 73 74 6d 65 74 61 2d 75 70 64 61 74 65 2d 66 estmeta-update-f
8850: 69 65 6c 64 20 64 62 20 74 65 73 74 2d 6e 61 6d ield db test-nam
8860: 65 20 66 6c 64 20 76 61 6c 29 29 29 29 29 0a 20 e fld val))))).
8870: 20 20 20 20 27 28 28 22 61 75 74 68 6f 72 22 20 '(("author"
8880: 32 29 28 22 6f 77 6e 65 72 22 20 33 29 28 22 64 2)("owner" 3)("d
8890: 65 73 63 72 69 70 74 69 6f 6e 22 20 34 29 28 22 escription" 4)("
88a0: 72 65 76 69 65 77 65 64 22 20 35 29 28 22 74 61 reviewed" 5)("ta
88b0: 67 73 22 20 39 29 29 29 29 29 0a 0a 3b 3b 20 55 gs" 9)))))..;; U
88c0: 70 64 61 74 65 20 74 65 73 74 5f 6d 65 74 61 20 pdate test_meta
88d0: 66 6f 72 20 61 6c 6c 20 74 65 73 74 73 0a 28 64 for all tests.(d
88e0: 65 66 69 6e 65 20 28 72 75 6e 73 3a 75 70 64 61 efine (runs:upda
88f0: 74 65 2d 61 6c 6c 2d 74 65 73 74 5f 6d 65 74 61 te-all-test_meta
8900: 20 64 62 29 0a 20 20 28 6c 65 74 20 28 28 74 65 db). (let ((te
8910: 73 74 2d 6e 61 6d 65 73 20 28 67 65 74 2d 61 6c st-names (get-al
8920: 6c 2d 6c 65 67 61 6c 2d 74 65 73 74 73 29 29 29 l-legal-tests)))
8930: 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a . (for-each .
8940: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 74 65 (lambda (te
8950: 73 74 2d 6e 61 6d 65 29 0a 20 20 20 20 20 20 20 st-name).
8960: 28 6c 65 74 2a 20 28 28 74 65 73 74 2d 70 61 74 (let* ((test-pat
8970: 68 20 20 20 20 28 63 6f 6e 63 20 2a 74 6f 70 70 h (conc *topp
8980: 61 74 68 2a 20 22 2f 74 65 73 74 73 2f 22 20 74 ath* "/tests/" t
8990: 65 73 74 2d 6e 61 6d 65 29 29 0a 09 20 20 20 20 est-name))..
89a0: 20 20 28 74 65 73 74 2d 63 6f 6e 66 69 67 66 20 (test-configf
89b0: 28 63 6f 6e 63 20 74 65 73 74 2d 70 61 74 68 20 (conc test-path
89c0: 22 2f 74 65 73 74 63 6f 6e 66 69 67 22 29 29 0a "/testconfig")).
89d0: 09 20 20 20 20 20 20 28 74 65 73 74 65 78 69 73 . (testexis
89e0: 74 73 20 20 20 28 61 6e 64 20 28 66 69 6c 65 2d ts (and (file-
89f0: 65 78 69 73 74 73 3f 20 74 65 73 74 2d 63 6f 6e exists? test-con
8a00: 66 69 67 66 29 28 66 69 6c 65 2d 72 65 61 64 2d figf)(file-read-
8a10: 61 63 63 65 73 73 3f 20 74 65 73 74 2d 63 6f 6e access? test-con
8a20: 66 69 67 66 29 29 29 0a 09 20 20 20 20 20 20 3b figf))).. ;
8a30: 3b 20 72 65 61 64 20 63 6f 6e 66 69 67 73 20 77 ; read configs w
8a40: 69 74 68 20 74 72 69 63 6b 73 20 74 75 72 6e 65 ith tricks turne
8a50: 64 20 6f 66 66 20 28 69 2e 65 2e 20 6e 6f 20 73 d off (i.e. no s
8a60: 79 73 74 65 6d 29 0a 09 20 20 20 20 20 20 28 74 ystem).. (t
8a70: 65 73 74 2d 63 6f 6e 66 20 20 20 20 28 69 66 20 est-conf (if
8a80: 74 65 73 74 65 78 69 73 74 73 20 28 72 65 61 64 testexists (read
8a90: 2d 63 6f 6e 66 69 67 20 74 65 73 74 2d 63 6f 6e -config test-con
8aa0: 66 69 67 66 20 23 66 20 23 66 29 28 6d 61 6b 65 figf #f #f)(make
8ab0: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 29 0a -hash-table)))).
8ac0: 09 20 28 72 75 6e 73 3a 75 70 64 61 74 65 2d 74 . (runs:update-t
8ad0: 65 73 74 5f 6d 65 74 61 20 64 62 20 74 65 73 74 est_meta db test
8ae0: 2d 6e 61 6d 65 20 74 65 73 74 2d 63 6f 6e 66 29 -name test-conf)
8af0: 29 29 0a 20 20 20 20 20 74 65 73 74 2d 6e 61 6d )). test-nam
8b00: 65 73 29 29 29 0a 09 20 0a 28 64 65 66 69 6e 65 es))).. .(define
8b10: 20 28 72 75 6e 73 3a 72 6f 6c 6c 75 70 2d 72 75 (runs:rollup-ru
8b20: 6e 20 64 62 20 6b 65 79 73 20 6b 65 79 6e 61 6d n db keys keynam
8b30: 65 73 20 6b 65 79 76 61 6c 6c 73 74 20 6e 29 0a es keyvallst n).
8b40: 20 20 28 6c 65 74 2a 20 28 28 6e 65 77 2d 72 75 (let* ((new-ru
8b50: 6e 2d 69 64 20 20 20 28 72 65 67 69 73 74 65 72 n-id (register
8b60: 2d 72 75 6e 20 64 62 20 6b 65 79 73 29 29 0a 09 -run db keys))..
8b70: 20 28 73 69 6d 69 6c 61 72 2d 72 75 6e 73 20 28 (similar-runs (
8b80: 64 62 3a 67 65 74 2d 72 75 6e 73 20 64 62 20 6b db:get-runs db k
8b90: 65 79 73 29 29 0a 09 20 28 74 65 73 74 73 2d 6e eys)).. (tests-n
8ba0: 2d 64 61 79 73 20 28 64 62 3a 67 65 74 2d 74 65 -days (db:get-te
8bb0: 73 74 73 2d 6e 2d 64 61 79 73 20 64 62 20 73 69 sts-n-days db si
8bc0: 6d 69 6c 61 72 2d 72 75 6e 73 29 29 29 0a 20 20 milar-runs))).
8bd0: 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 (for-each .
8be0: 20 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 2d (lambda (test-
8bf0: 69 64 29 0a 20 20 20 20 20 20 20 28 64 62 3a 72 id). (db:r
8c00: 6f 6c 6c 75 70 2d 74 65 73 74 20 64 62 20 72 75 ollup-test db ru
8c10: 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 29 0a 20 n-id test-id)).
8c20: 20 20 20 20 74 65 73 74 73 2d 6e 2d 64 61 79 73 tests-n-days
8c30: 29 29 29 0a ))).