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 69 74 65 6d 2d 70 61 74 68 20 28 69 66 20 ((item-path (if
1340: 28 73 74 72 69 6e 67 3f 20 69 74 65 6d 64 61 74 (string? itemdat
1350: 2d 6f 72 2d 70 61 74 68 29 20 69 74 65 6d 64 61 -or-path) itemda
1360: 74 2d 6f 72 2d 70 61 74 68 20 28 69 74 65 6d 2d t-or-path (item-
1370: 6c 69 73 74 2d 3e 70 61 74 68 20 69 74 65 6d 64 list->path itemd
1380: 61 74 2d 6f 72 2d 70 61 74 68 29 29 29 0a 09 28 at-or-path)))..(
1390: 6f 74 68 65 72 64 61 74 20 20 28 69 66 20 64 61 otherdat (if da
13a0: 74 20 64 61 74 20 28 6d 61 6b 65 2d 68 61 73 68 t dat (make-hash
13b0: 2d 74 61 62 6c 65 29 29 29 0a 09 3b 3b 20 62 65 -table)))..;; be
13c0: 66 6f 72 65 20 70 72 6f 63 65 65 64 69 6e 67 20 fore proceeding
13d0: 77 65 20 6d 75 73 74 20 66 69 6e 64 20 6f 75 74 we must find out
13e0: 20 69 66 20 74 68 65 20 70 72 65 76 69 6f 75 73 if the previous
13f0: 20 74 65 73 74 20 28 77 68 65 72 65 20 61 6c 6c test (where all
1400: 20 6b 65 79 73 20 6d 61 74 63 68 65 64 20 65 78 keys matched ex
1410: 63 65 70 74 20 72 75 6e 6e 61 6d 65 29 0a 09 3b cept runname)..;
1420: 3b 20 77 61 73 20 57 41 49 56 45 44 20 69 66 20 ; was WAIVED if
1430: 74 68 69 73 20 74 65 73 74 20 69 73 20 46 41 49 this test is FAI
1440: 4c 0a 09 28 77 61 69 76 65 64 20 20 20 28 69 66 L..(waived (if
1450: 20 28 65 71 75 61 6c 3f 20 73 74 61 74 75 73 20 (equal? status
1460: 22 46 41 49 4c 22 29 0a 09 09 20 20 20 20 20 20 "FAIL")...
1470: 28 6c 65 74 20 28 28 70 72 65 76 2d 74 65 73 74 (let ((prev-test
1480: 20 28 74 65 73 74 3a 67 65 74 2d 70 72 65 76 69 (test:get-previ
1490: 6f 75 73 2d 74 65 73 74 2d 72 75 6e 2d 72 65 63 ous-test-run-rec
14a0: 6f 72 64 73 20 64 62 20 72 75 6e 2d 69 64 20 74 ords db run-id t
14b0: 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 est-name item-pa
14c0: 74 68 29 29 29 0a 09 09 09 28 69 66 20 28 61 6e th)))....(if (an
14d0: 64 20 70 72 65 76 2d 74 65 73 74 20 28 6e 6f 74 d prev-test (not
14e0: 20 28 6e 75 6c 6c 3f 20 70 72 65 76 2d 74 65 73 (null? prev-tes
14f0: 74 29 29 29 20 3b 3b 20 74 72 75 65 20 69 66 20 t))) ;; true if
1500: 77 65 20 66 6f 75 6e 64 20 61 20 70 72 65 76 69 we found a previ
1510: 6f 75 73 20 74 65 73 74 20 69 6e 20 74 68 69 73 ous test in this
1520: 20 72 75 6e 20 73 65 72 69 65 73 0a 09 09 09 20 run series....
1530: 20 20 20 28 6c 65 74 20 28 28 70 72 65 76 2d 73 (let ((prev-s
1540: 74 61 74 75 73 20 28 64 62 3a 74 65 73 74 2d 67 tatus (db:test-g
1550: 65 74 2d 73 74 61 74 75 73 20 20 20 70 72 65 76 et-status prev
1560: 2d 74 65 73 74 29 29 0a 09 09 09 09 20 20 28 70 -test))..... (p
1570: 72 65 76 2d 73 74 61 74 65 20 20 28 64 62 3a 74 rev-state (db:t
1580: 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 20 20 est-get-state
1590: 20 70 72 65 76 2d 74 65 73 74 29 29 0a 09 09 09 prev-test))....
15a0: 09 20 20 28 70 72 65 76 2d 63 6f 6d 6d 65 6e 74 . (prev-comment
15b0: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 63 6f (db:test-get-co
15c0: 6d 6d 65 6e 74 20 70 72 65 76 2d 74 65 73 74 29 mment prev-test)
15d0: 29 29 0a 09 09 09 20 20 20 20 20 20 28 69 66 20 )).... (if
15e0: 28 61 6e 64 20 28 65 71 75 61 6c 3f 20 70 72 65 (and (equal? pre
15f0: 76 2d 73 74 61 74 75 73 20 22 43 4f 4d 50 4c 45 v-status "COMPLE
1600: 54 45 44 22 29 0a 09 09 09 09 20 20 20 20 20 20 TED").....
1610: 20 28 65 71 75 61 6c 3f 20 70 72 65 76 2d 73 74 (equal? prev-st
1620: 61 74 65 20 20 22 57 41 49 56 45 44 22 29 29 0a ate "WAIVED")).
1630: 09 09 09 09 20 20 70 72 65 76 2d 63 6f 6d 6d 65 .... prev-comme
1640: 6e 74 20 3b 3b 20 77 61 69 76 65 64 20 69 73 20 nt ;; waived is
1650: 65 69 74 68 65 72 20 74 68 65 20 63 6f 6d 6d 65 either the comme
1660: 6e 74 20 6f 72 20 23 66 0a 09 09 09 09 20 20 23 nt or #f..... #
1670: 66 29 29 0a 09 09 09 20 20 20 20 23 66 29 29 0a f)).... #f)).
1680: 09 09 20 20 20 20 20 20 23 66 29 29 29 0a 0a 20 .. #f)))..
1690: 20 20 20 3b 3b 20 75 70 64 61 74 65 20 74 68 65 ;; update the
16a0: 20 70 72 69 6d 61 72 79 20 72 65 63 6f 72 64 20 primary record
16b0: 49 46 20 73 74 61 74 65 20 41 4e 44 20 73 74 61 IF state AND sta
16c0: 74 75 73 20 61 72 65 20 64 65 66 69 6e 65 64 0a tus are defined.
16d0: 20 20 20 20 28 69 66 20 28 61 6e 64 20 73 74 61 (if (and sta
16e0: 74 65 20 73 74 61 74 75 73 29 0a 09 28 73 71 6c te status)..(sql
16f0: 69 74 65 33 3a 65 78 65 63 75 74 65 20 64 62 20 ite3:execute db
1700: 22 55 50 44 41 54 45 20 74 65 73 74 73 20 53 45 "UPDATE tests SE
1710: 54 20 73 74 61 74 65 3d 3f 2c 73 74 61 74 75 73 T state=?,status
1720: 3d 3f 2c 65 76 65 6e 74 5f 74 69 6d 65 3d 73 74 =?,event_time=st
1730: 72 66 74 69 6d 65 28 27 25 73 27 2c 27 6e 6f 77 rftime('%s','now
1740: 27 29 20 57 48 45 52 45 20 72 75 6e 5f 69 64 3d ') WHERE run_id=
1750: 3f 20 41 4e 44 20 74 65 73 74 6e 61 6d 65 3d 3f ? AND testname=?
1760: 20 41 4e 44 20 69 74 65 6d 5f 70 61 74 68 3d 3f AND item_path=?
1770: 3b 22 20 0a 09 09 09 20 73 74 61 74 65 20 73 74 ;" .... state st
1780: 61 74 75 73 20 72 75 6e 2d 69 64 20 74 65 73 74 atus run-id test
1790: 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 -name item-path)
17a0: 29 0a 20 20 20 20 3b 3b 20 61 64 64 20 6d 65 74 ). ;; add met
17b0: 61 64 61 74 61 20 28 6e 65 65 64 20 74 6f 20 64 adata (need to d
17c0: 6f 20 74 68 69 73 20 77 61 79 20 74 6f 20 61 76 o this way to av
17d0: 6f 69 64 20 53 51 4c 20 69 6e 6a 65 63 74 69 6f oid SQL injectio
17e0: 6e 20 69 73 73 75 65 73 29 0a 20 20 20 20 3b 3b n issues). ;;
17f0: 20 3a 76 61 6c 75 65 0a 20 20 20 20 28 6c 65 74 :value. (let
1800: 20 28 28 76 61 6c 20 28 68 61 73 68 2d 74 61 62 ((val (hash-tab
1810: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 6f le-ref/default o
1820: 74 68 65 72 64 61 74 20 22 3a 76 61 6c 75 65 22 therdat ":value"
1830: 20 23 66 29 29 29 0a 20 20 20 20 20 20 28 69 66 #f))). (if
1840: 20 76 61 6c 0a 09 20 20 28 73 71 6c 69 74 65 33 val.. (sqlite3
1850: 3a 65 78 65 63 75 74 65 20 64 62 20 22 55 50 44 :execute db "UPD
1860: 41 54 45 20 74 65 73 74 73 20 53 45 54 20 76 61 ATE tests SET va
1870: 6c 75 65 3d 3f 20 57 48 45 52 45 20 72 75 6e 5f lue=? WHERE run_
1880: 69 64 3d 3f 20 41 4e 44 20 74 65 73 74 6e 61 6d id=? AND testnam
1890: 65 3d 3f 20 41 4e 44 20 69 74 65 6d 5f 70 61 74 e=? AND item_pat
18a0: 68 3d 3f 3b 22 20 76 61 6c 20 72 75 6e 2d 69 64 h=?;" val run-id
18b0: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item-
18c0: 70 61 74 68 29 29 29 0a 20 20 20 20 3b 3b 20 3a path))). ;; :
18d0: 65 78 70 65 63 74 65 64 5f 76 61 6c 75 65 0a 20 expected_value.
18e0: 20 20 20 28 6c 65 74 20 28 28 76 61 6c 20 28 68 (let ((val (h
18f0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
1900: 66 61 75 6c 74 20 6f 74 68 65 72 64 61 74 20 22 fault otherdat "
1910: 3a 65 78 70 65 63 74 65 64 5f 76 61 6c 75 65 22 :expected_value"
1920: 20 23 66 29 29 29 0a 20 20 20 20 20 20 28 69 66 #f))). (if
1930: 20 76 61 6c 0a 09 20 20 28 73 71 6c 69 74 65 33 val.. (sqlite3
1940: 3a 65 78 65 63 75 74 65 20 64 62 20 22 55 50 44 :execute db "UPD
1950: 41 54 45 20 74 65 73 74 73 20 53 45 54 20 65 78 ATE tests SET ex
1960: 70 65 63 74 65 64 5f 76 61 6c 75 65 3d 3f 20 57 pected_value=? W
1970: 48 45 52 45 20 72 75 6e 5f 69 64 3d 3f 20 41 4e HERE run_id=? AN
1980: 44 20 74 65 73 74 6e 61 6d 65 3d 3f 20 41 4e 44 D testname=? AND
1990: 20 69 74 65 6d 5f 70 61 74 68 3d 3f 3b 22 20 76 item_path=?;" v
19a0: 61 6c 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e al run-id test-n
19b0: 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 29 ame item-path)))
19c0: 0a 20 20 20 20 3b 3b 20 3a 74 6f 6c 0a 20 20 20 . ;; :tol.
19d0: 20 28 6c 65 74 20 28 28 76 61 6c 20 28 68 61 73 (let ((val (has
19e0: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
19f0: 75 6c 74 20 6f 74 68 65 72 64 61 74 20 22 3a 74 ult otherdat ":t
1a00: 6f 6c 22 20 23 66 29 29 29 0a 20 20 20 20 20 20 ol" #f))).
1a10: 28 69 66 20 76 61 6c 0a 09 20 20 28 73 71 6c 69 (if val.. (sqli
1a20: 74 65 33 3a 65 78 65 63 75 74 65 20 64 62 20 22 te3:execute db "
1a30: 55 50 44 41 54 45 20 74 65 73 74 73 20 53 45 54 UPDATE tests SET
1a40: 20 74 6f 6c 3d 3f 20 57 48 45 52 45 20 72 75 6e tol=? WHERE run
1a50: 5f 69 64 3d 3f 20 41 4e 44 20 74 65 73 74 6e 61 _id=? AND testna
1a60: 6d 65 3d 3f 20 41 4e 44 20 69 74 65 6d 5f 70 61 me=? AND item_pa
1a70: 74 68 3d 3f 3b 22 20 76 61 6c 20 72 75 6e 2d 69 th=?;" val run-i
1a80: 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d d test-name item
1a90: 2d 70 61 74 68 29 29 29 0a 20 20 20 20 3b 3b 20 -path))). ;;
1aa0: 3a 66 69 72 73 74 5f 65 72 72 0a 20 20 20 20 28 :first_err. (
1ab0: 6c 65 74 20 28 28 76 61 6c 20 28 68 61 73 68 2d let ((val (hash-
1ac0: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
1ad0: 74 20 6f 74 68 65 72 64 61 74 20 22 3a 66 69 72 t otherdat ":fir
1ae0: 73 74 5f 65 72 72 22 20 23 66 29 29 29 0a 20 20 st_err" #f))).
1af0: 20 20 20 20 28 69 66 20 76 61 6c 0a 09 20 20 28 (if val.. (
1b00: 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 sqlite3:execute
1b10: 64 62 20 22 55 50 44 41 54 45 20 74 65 73 74 73 db "UPDATE tests
1b20: 20 53 45 54 20 66 69 72 73 74 5f 65 72 72 3d 3f SET first_err=?
1b30: 20 57 48 45 52 45 20 72 75 6e 5f 69 64 3d 3f 20 WHERE run_id=?
1b40: 41 4e 44 20 74 65 73 74 6e 61 6d 65 3d 3f 20 41 AND testname=? A
1b50: 4e 44 20 69 74 65 6d 5f 70 61 74 68 3d 3f 3b 22 ND item_path=?;"
1b60: 20 76 61 6c 20 72 75 6e 2d 69 64 20 74 65 73 74 val run-id test
1b70: 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 -name item-path)
1b80: 29 29 0a 20 20 20 20 3b 3b 20 3a 66 69 72 73 74 )). ;; :first
1b90: 5f 77 61 72 6e 0a 20 20 20 20 28 6c 65 74 20 28 _warn. (let (
1ba0: 28 76 61 6c 20 28 68 61 73 68 2d 74 61 62 6c 65 (val (hash-table
1bb0: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 6f 74 68 -ref/default oth
1bc0: 65 72 64 61 74 20 22 3a 66 69 72 73 74 5f 77 61 erdat ":first_wa
1bd0: 72 6e 22 20 23 66 29 29 29 0a 20 20 20 20 20 20 rn" #f))).
1be0: 28 69 66 20 76 61 6c 0a 09 20 20 28 73 71 6c 69 (if val.. (sqli
1bf0: 74 65 33 3a 65 78 65 63 75 74 65 20 64 62 20 22 te3:execute db "
1c00: 55 50 44 41 54 45 20 74 65 73 74 73 20 53 45 54 UPDATE tests SET
1c10: 20 66 69 72 73 74 5f 77 61 72 6e 3d 3f 20 57 48 first_warn=? WH
1c20: 45 52 45 20 72 75 6e 5f 69 64 3d 3f 20 41 4e 44 ERE run_id=? AND
1c30: 20 74 65 73 74 6e 61 6d 65 3d 3f 20 41 4e 44 20 testname=? AND
1c40: 69 74 65 6d 5f 70 61 74 68 3d 3f 3b 22 20 76 61 item_path=?;" va
1c50: 6c 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 l run-id test-na
1c60: 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 29 0a me item-path))).
1c70: 20 20 20 20 28 6c 65 74 20 28 28 76 61 6c 20 28 (let ((val (
1c80: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
1c90: 65 66 61 75 6c 74 20 6f 74 68 65 72 64 61 74 20 efault otherdat
1ca0: 22 3a 75 6e 69 74 73 22 20 23 66 29 29 29 0a 20 ":units" #f))).
1cb0: 20 20 20 20 20 28 69 66 20 76 61 6c 0a 09 20 20 (if val..
1cc0: 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 (sqlite3:execute
1cd0: 20 64 62 20 22 55 50 44 41 54 45 20 74 65 73 74 db "UPDATE test
1ce0: 73 20 53 45 54 20 75 6e 69 74 73 3d 3f 20 57 48 s SET units=? WH
1cf0: 45 52 45 20 72 75 6e 5f 69 64 3d 3f 20 41 4e 44 ERE run_id=? AND
1d00: 20 74 65 73 74 6e 61 6d 65 3d 3f 20 41 4e 44 20 testname=? AND
1d10: 69 74 65 6d 5f 70 61 74 68 3d 3f 3b 22 20 76 61 item_path=?;" va
1d20: 6c 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 l run-id test-na
1d30: 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 29 0a me item-path))).
1d40: 20 20 20 20 3b 3b 20 3a 74 6f 6c 5f 70 65 72 63 ;; :tol_perc
1d50: 0a 20 20 20 20 28 6c 65 74 20 28 28 76 61 6c 20 . (let ((val
1d60: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
1d70: 64 65 66 61 75 6c 74 20 6f 74 68 65 72 64 61 74 default otherdat
1d80: 20 22 3a 74 6f 6c 5f 70 65 72 63 22 20 23 66 29 ":tol_perc" #f)
1d90: 29 29 0a 20 20 20 20 20 20 28 69 66 20 76 61 6c )). (if val
1da0: 0a 09 20 20 28 73 71 6c 69 74 65 33 3a 65 78 65 .. (sqlite3:exe
1db0: 63 75 74 65 20 64 62 20 22 55 50 44 41 54 45 20 cute db "UPDATE
1dc0: 74 65 73 74 73 20 53 45 54 20 74 6f 6c 5f 70 65 tests SET tol_pe
1dd0: 72 63 3d 3f 20 57 48 45 52 45 20 72 75 6e 5f 69 rc=? WHERE run_i
1de0: 64 3d 3f 20 41 4e 44 20 74 65 73 74 6e 61 6d 65 d=? AND testname
1df0: 3d 3f 20 41 4e 44 20 69 74 65 6d 5f 70 61 74 68 =? AND item_path
1e00: 3d 3f 3b 22 20 76 61 6c 20 72 75 6e 2d 69 64 20 =?;" val run-id
1e10: 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 test-name item-p
1e20: 61 74 68 29 29 29 0a 0a 20 20 20 20 3b 3b 20 6e ath))).. ;; n
1e30: 65 65 64 20 74 6f 20 75 70 64 61 74 65 20 74 68 eed to update th
1e40: 65 20 74 6f 70 20 74 65 73 74 20 72 65 63 6f 72 e top test recor
1e50: 64 20 69 66 20 50 41 53 53 20 6f 72 20 46 41 49 d if PASS or FAI
1e60: 4c 20 61 6e 64 20 74 68 69 73 20 69 73 20 61 20 L and this is a
1e70: 73 75 62 74 65 73 74 0a 20 20 20 20 28 69 66 20 subtest. (if
1e80: 28 61 6e 64 20 28 6e 6f 74 20 28 65 71 75 61 6c (and (not (equal
1e90: 3f 20 69 74 65 6d 2d 70 61 74 68 20 22 22 29 29 ? item-path ""))
1ea0: 0a 09 20 20 20 20 20 28 6f 72 20 28 65 71 75 61 .. (or (equa
1eb0: 6c 3f 20 73 74 61 74 75 73 20 22 50 41 53 53 22 l? status "PASS"
1ec0: 29 0a 09 09 20 28 65 71 75 61 6c 3f 20 73 74 61 )... (equal? sta
1ed0: 74 75 73 20 22 57 41 52 4e 22 29 0a 09 09 20 28 tus "WARN")... (
1ee0: 65 71 75 61 6c 3f 20 73 74 61 74 75 73 20 22 46 equal? status "F
1ef0: 41 49 4c 22 29 29 29 0a 09 28 62 65 67 69 6e 0a AIL")))..(begin.
1f00: 09 20 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 . (sqlite3:exec
1f10: 75 74 65 20 0a 09 20 20 20 64 62 0a 09 20 20 20 ute .. db..
1f20: 22 55 50 44 41 54 45 20 74 65 73 74 73 20 0a 20 "UPDATE tests .
1f30: 20 20 20 20 20 20 20 20 20 20 20 20 53 45 54 20 SET
1f40: 66 61 69 6c 5f 63 6f 75 6e 74 3d 28 53 45 4c 45 fail_count=(SELE
1f50: 43 54 20 63 6f 75 6e 74 28 69 64 29 20 46 52 4f CT count(id) FRO
1f60: 4d 20 74 65 73 74 73 20 57 48 45 52 45 20 72 75 M tests WHERE ru
1f70: 6e 5f 69 64 3d 3f 20 41 4e 44 20 74 65 73 74 6e n_id=? AND testn
1f80: 61 6d 65 3d 3f 20 41 4e 44 20 69 74 65 6d 5f 70 ame=? AND item_p
1f90: 61 74 68 20 21 3d 20 27 27 20 41 4e 44 20 73 74 ath != '' AND st
1fa0: 61 74 75 73 3d 27 46 41 49 4c 27 29 2c 0a 20 20 atus='FAIL'),.
1fb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 70 p
1fc0: 61 73 73 5f 63 6f 75 6e 74 3d 28 53 45 4c 45 43 ass_count=(SELEC
1fd0: 54 20 63 6f 75 6e 74 28 69 64 29 20 46 52 4f 4d T count(id) FROM
1fe0: 20 74 65 73 74 73 20 57 48 45 52 45 20 72 75 6e tests WHERE run
1ff0: 5f 69 64 3d 3f 20 41 4e 44 20 74 65 73 74 6e 61 _id=? AND testna
2000: 6d 65 3d 3f 20 41 4e 44 20 69 74 65 6d 5f 70 61 me=? AND item_pa
2010: 74 68 20 21 3d 20 27 27 20 41 4e 44 20 28 73 74 th != '' AND (st
2020: 61 74 75 73 3d 27 50 41 53 53 27 20 4f 52 20 73 atus='PASS' OR s
2030: 74 61 74 75 73 3d 27 57 41 52 4e 27 29 29 0a 20 tatus='WARN')).
2040: 20 20 20 20 20 20 20 20 20 20 20 20 57 48 45 52 WHER
2050: 45 20 72 75 6e 5f 69 64 3d 3f 20 41 4e 44 20 74 E run_id=? AND t
2060: 65 73 74 6e 61 6d 65 3d 3f 20 41 4e 44 20 69 74 estname=? AND it
2070: 65 6d 5f 70 61 74 68 3d 27 27 3b 22 0a 09 20 20 em_path='';"..
2080: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
2090: 65 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 e run-id test-na
20a0: 6d 65 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e me run-id test-n
20b0: 61 6d 65 29 0a 09 20 20 28 73 71 6c 69 74 65 33 ame).. (sqlite3
20c0: 3a 65 78 65 63 75 74 65 0a 09 20 20 20 64 62 0a :execute.. db.
20d0: 09 20 20 20 22 55 50 44 41 54 45 20 74 65 73 74 . "UPDATE test
20e0: 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 53 s. S
20f0: 45 54 20 73 74 61 74 65 3d 43 41 53 45 20 57 48 ET state=CASE WH
2100: 45 4e 20 28 53 45 4c 45 43 54 20 63 6f 75 6e 74 EN (SELECT count
2110: 28 69 64 29 20 46 52 4f 4d 20 74 65 73 74 73 20 (id) FROM tests
2120: 57 48 45 52 45 20 72 75 6e 5f 69 64 3d 3f 20 41 WHERE run_id=? A
2130: 4e 44 20 74 65 73 74 6e 61 6d 65 3d 3f 20 41 4e ND testname=? AN
2140: 44 20 69 74 65 6d 5f 70 61 74 68 20 21 3d 20 27 D item_path != '
2150: 27 20 41 4e 44 20 73 74 61 74 65 20 69 6e 20 28 ' AND state in (
2160: 27 52 55 4e 4e 49 4e 47 27 2c 27 4e 4f 54 5f 53 'RUNNING','NOT_S
2170: 54 41 52 54 45 44 27 29 29 20 3e 20 30 20 54 48 TARTED')) > 0 TH
2180: 45 4e 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 EN .
2190: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 27 52 'R
21a0: 55 4e 4e 49 4e 47 27 0a 20 20 20 20 20 20 20 20 UNNING'.
21b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 45 E
21c0: 4c 53 45 20 27 43 4f 4d 50 4c 45 54 45 44 27 20 LSE 'COMPLETED'
21d0: 45 4e 44 2c 0a 20 20 20 20 20 20 20 20 20 20 20 END,.
21e0: 20 20 20 20 20 73 74 61 74 75 73 3d 43 41 53 45 status=CASE
21f0: 20 57 48 45 4e 20 66 61 69 6c 5f 63 6f 75 6e 74 WHEN fail_count
2200: 20 3e 20 30 20 54 48 45 4e 20 27 46 41 49 4c 27 > 0 THEN 'FAIL'
2210: 20 57 48 45 4e 20 70 61 73 73 5f 63 6f 75 6e 74 WHEN pass_count
2220: 20 3e 20 30 20 41 4e 44 20 66 61 69 6c 5f 63 6f > 0 AND fail_co
2230: 75 6e 74 3d 30 20 54 48 45 4e 20 27 50 41 53 53 unt=0 THEN 'PASS
2240: 27 20 45 4c 53 45 20 27 55 4e 4b 4e 4f 57 4e 27 ' ELSE 'UNKNOWN'
2250: 20 45 4e 44 0a 20 20 20 20 20 20 20 20 20 20 20 END.
2260: 20 20 57 48 45 52 45 20 72 75 6e 5f 69 64 3d 3f WHERE run_id=?
2270: 20 41 4e 44 20 74 65 73 74 6e 61 6d 65 3d 3f 20 AND testname=?
2280: 41 4e 44 20 69 74 65 6d 5f 70 61 74 68 3d 27 27 AND item_path=''
2290: 3b 22 0a 09 20 20 20 72 75 6e 2d 69 64 20 74 65 ;".. run-id te
22a0: 73 74 2d 6e 61 6d 65 20 72 75 6e 2d 69 64 20 74 st-name run-id t
22b0: 65 73 74 2d 6e 61 6d 65 29 29 29 0a 20 20 20 20 est-name))).
22c0: 28 69 66 20 28 61 6e 64 20 28 73 74 72 69 6e 67 (if (and (string
22d0: 3f 20 63 6f 6d 6d 65 6e 74 29 0a 09 20 20 20 20 ? comment)..
22e0: 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 28 (string-match (
22f0: 72 65 67 65 78 70 20 22 5c 5c 53 2b 22 29 20 63 regexp "\\S+") c
2300: 6f 6d 6d 65 6e 74 29 29 0a 09 28 73 71 6c 69 74 omment))..(sqlit
2310: 65 33 3a 65 78 65 63 75 74 65 20 64 62 20 22 55 e3:execute db "U
2320: 50 44 41 54 45 20 74 65 73 74 73 20 53 45 54 20 PDATE tests SET
2330: 63 6f 6d 6d 65 6e 74 3d 3f 20 57 48 45 52 45 20 comment=? WHERE
2340: 72 75 6e 5f 69 64 3d 3f 20 41 4e 44 20 74 65 73 run_id=? AND tes
2350: 74 6e 61 6d 65 3d 3f 20 41 4e 44 20 69 74 65 6d tname=? AND item
2360: 5f 70 61 74 68 3d 3f 3b 22 0a 09 09 09 20 28 63 _path=?;".... (c
2370: 61 72 20 63 6f 6d 6d 65 6e 74 29 20 72 75 6e 2d ar comment) run-
2380: 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 id test-name ite
2390: 6d 2d 70 61 74 68 29 29 0a 20 20 20 20 29 29 0a m-path)). )).
23a0: 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 2d 73 .(define (test-s
23b0: 65 74 2d 6c 6f 67 21 20 64 62 20 72 75 6e 2d 69 et-log! db run-i
23c0: 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d d test-name item
23d0: 64 61 74 20 6c 6f 67 66 29 20 0a 20 20 28 6c 65 dat logf) . (le
23e0: 74 20 28 28 69 74 65 6d 2d 70 61 74 68 20 28 69 t ((item-path (i
23f0: 74 65 6d 2d 6c 69 73 74 2d 3e 70 61 74 68 20 69 tem-list->path i
2400: 74 65 6d 64 61 74 29 29 29 0a 20 20 20 20 28 73 temdat))). (s
2410: 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 64 qlite3:execute d
2420: 62 20 22 55 50 44 41 54 45 20 74 65 73 74 73 20 b "UPDATE tests
2430: 53 45 54 20 66 69 6e 61 6c 5f 6c 6f 67 66 3d 3f SET final_logf=?
2440: 20 57 48 45 52 45 20 72 75 6e 5f 69 64 3d 3f 20 WHERE run_id=?
2450: 41 4e 44 20 74 65 73 74 6e 61 6d 65 3d 3f 20 41 AND testname=? A
2460: 4e 44 20 69 74 65 6d 5f 70 61 74 68 3d 3f 3b 22 ND item_path=?;"
2470: 20 0a 09 09 20 20 20 20 20 6c 6f 67 66 20 72 75 ... logf ru
2480: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 n-id test-name i
2490: 74 65 6d 2d 70 61 74 68 29 29 29 0a 0a 28 64 65 tem-path)))..(de
24a0: 66 69 6e 65 20 28 74 65 73 74 2d 73 65 74 2d 74 fine (test-set-t
24b0: 6f 70 6c 6f 67 21 20 64 62 20 72 75 6e 2d 69 64 oplog! db run-id
24c0: 20 74 65 73 74 2d 6e 61 6d 65 20 6c 6f 67 66 29 test-name logf)
24d0: 20 0a 20 20 28 73 71 6c 69 74 65 33 3a 65 78 65 . (sqlite3:exe
24e0: 63 75 74 65 20 64 62 20 22 55 50 44 41 54 45 20 cute db "UPDATE
24f0: 74 65 73 74 73 20 53 45 54 20 66 69 6e 61 6c 5f tests SET final_
2500: 6c 6f 67 66 3d 3f 20 57 48 45 52 45 20 72 75 6e logf=? WHERE run
2510: 5f 69 64 3d 3f 20 41 4e 44 20 74 65 73 74 6e 61 _id=? AND testna
2520: 6d 65 3d 3f 20 41 4e 44 20 69 74 65 6d 5f 70 61 me=? AND item_pa
2530: 74 68 3d 27 27 3b 22 20 0a 09 09 20 20 20 6c 6f th='';" ... lo
2540: 67 66 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e gf run-id test-n
2550: 61 6d 65 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 ame))..(define (
2560: 74 65 73 74 73 3a 73 75 6d 6d 61 72 69 7a 65 2d tests:summarize-
2570: 69 74 65 6d 73 20 64 62 20 72 75 6e 2d 69 64 20 items db run-id
2580: 74 65 73 74 2d 6e 61 6d 65 20 66 6f 72 63 65 29 test-name force)
2590: 0a 20 20 3b 3b 20 69 66 20 6e 6f 74 20 66 6f 72 . ;; if not for
25a0: 63 65 20 74 68 65 6e 20 6f 6e 6c 79 20 75 70 64 ce then only upd
25b0: 61 74 65 20 74 68 65 20 72 65 63 6f 72 64 20 69 ate the record i
25c0: 66 20 6f 6e 65 20 6f 66 20 74 68 65 73 65 20 69 f one of these i
25d0: 73 20 74 72 75 65 3a 0a 20 20 3b 3b 20 20 20 31 s true:. ;; 1
25e0: 2e 20 6c 6f 67 66 20 69 73 20 22 6c 6f 67 2f 66 . logf is "log/f
25f0: 69 6e 61 6c 2e 6c 6f 67 0a 20 20 3b 3b 20 20 20 inal.log. ;;
2600: 32 2e 20 6c 6f 67 66 20 69 73 20 73 61 6d 65 20 2. logf is same
2610: 61 73 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d as outputfilenam
2620: 65 0a 20 20 28 6c 65 74 20 28 28 6f 75 74 70 75 e. (let ((outpu
2630: 74 66 69 6c 65 6e 61 6d 65 20 28 63 6f 6e 63 20 tfilename (conc
2640: 22 6d 65 67 61 74 65 73 74 2d 72 6f 6c 6c 75 70 "megatest-rollup
2650: 2d 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 2e 68 -" test-name ".h
2660: 74 6d 6c 22 29 29 0a 09 28 6f 72 69 67 2d 64 69 tml"))..(orig-di
2670: 72 20 20 20 20 20 20 20 28 63 75 72 72 65 6e 74 r (current
2680: 2d 64 69 72 65 63 74 6f 72 79 29 29 0a 09 28 6c -directory))..(l
2690: 6f 67 66 20 20 20 20 20 20 20 20 20 20 20 23 66 ogf #f
26a0: 29 29 0a 20 20 20 20 28 73 71 6c 69 74 65 33 3a )). (sqlite3:
26b0: 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 0a 20 20 for-each-row .
26c0: 20 20 20 28 6c 61 6d 62 64 61 20 28 70 61 74 68 (lambda (path
26d0: 20 66 69 6e 61 6c 5f 6c 6f 67 66 29 0a 20 20 20 final_logf).
26e0: 20 20 20 20 28 73 65 74 21 20 6c 6f 67 66 20 66 (set! logf f
26f0: 69 6e 61 6c 5f 6c 6f 67 66 29 0a 20 20 20 20 20 inal_logf).
2700: 20 20 28 69 66 20 28 64 69 72 65 63 74 6f 72 79 (if (directory
2710: 3f 20 70 61 74 68 29 0a 09 20 20 20 28 62 65 67 ? path).. (beg
2720: 69 6e 0a 09 20 20 20 20 20 28 70 72 69 6e 74 20 in.. (print
2730: 22 46 6f 75 6e 64 20 70 61 74 68 3a 20 22 20 70 "Found path: " p
2740: 61 74 68 29 0a 09 20 20 20 20 20 28 63 68 61 6e ath).. (chan
2750: 67 65 2d 64 69 72 65 63 74 6f 72 79 20 70 61 74 ge-directory pat
2760: 68 29 29 0a 09 20 20 20 20 20 3b 3b 20 28 73 65 h)).. ;; (se
2770: 74 21 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d t! outputfilenam
2780: 65 20 28 63 6f 6e 63 20 70 61 74 68 20 22 2f 22 e (conc path "/"
2790: 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 29 outputfilename)
27a0: 29 29 0a 09 20 20 20 28 70 72 69 6e 74 20 22 4e )).. (print "N
27b0: 6f 20 73 75 63 68 20 70 61 74 68 3a 20 22 20 70 o such path: " p
27c0: 61 74 68 29 29 29 0a 20 20 20 20 20 64 62 20 0a ath))). db .
27d0: 20 20 20 20 20 22 53 45 4c 45 43 54 20 72 75 6e "SELECT run
27e0: 64 69 72 2c 66 69 6e 61 6c 5f 6c 6f 67 66 20 46 dir,final_logf F
27f0: 52 4f 4d 20 74 65 73 74 73 20 57 48 45 52 45 20 ROM tests WHERE
2800: 72 75 6e 5f 69 64 3d 3f 20 41 4e 44 20 74 65 73 run_id=? AND tes
2810: 74 6e 61 6d 65 3d 3f 20 41 4e 44 20 69 74 65 6d tname=? AND item
2820: 5f 70 61 74 68 3d 27 27 3b 22 0a 20 20 20 20 20 _path='';".
2830: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
2840: 29 0a 20 20 20 20 28 70 72 69 6e 74 20 22 73 75 ). (print "su
2850: 6d 6d 61 72 69 7a 65 2d 69 74 65 6d 73 20 77 69 mmarize-items wi
2860: 74 68 20 6c 6f 67 66 20 22 20 6c 6f 67 66 29 0a th logf " logf).
2870: 20 20 20 20 28 69 66 20 28 6f 72 20 28 65 71 75 (if (or (equ
2880: 61 6c 3f 20 6c 6f 67 66 20 22 6c 6f 67 73 2f 66 al? logf "logs/f
2890: 69 6e 61 6c 2e 6c 6f 67 22 29 0a 09 20 20 20 20 inal.log")..
28a0: 28 65 71 75 61 6c 3f 20 6c 6f 67 66 20 6f 75 74 (equal? logf out
28b0: 70 75 74 66 69 6c 65 6e 61 6d 65 29 0a 09 20 20 putfilename)..
28c0: 20 20 66 6f 72 63 65 29 0a 09 28 62 65 67 69 6e force)..(begin
28d0: 0a 09 20 20 28 69 66 20 28 6f 62 74 61 69 6e 2d .. (if (obtain-
28e0: 64 6f 74 2d 6c 6f 63 6b 20 6f 75 74 70 75 74 66 dot-lock outputf
28f0: 69 6c 65 6e 61 6d 65 20 31 20 32 30 20 33 30 29 ilename 1 20 30)
2900: 20 3b 3b 20 72 65 74 72 79 20 65 76 65 72 79 20 ;; retry every
2910: 73 65 63 6f 6e 64 20 66 6f 72 20 32 30 20 73 65 second for 20 se
2920: 63 6f 6e 64 73 2c 20 63 61 6c 6c 20 69 74 20 64 conds, call it d
2930: 65 61 64 20 61 66 74 65 72 20 33 30 20 73 65 63 ead after 30 sec
2940: 6f 6e 64 73 20 61 6e 64 20 73 74 65 61 6c 20 74 onds and steal t
2950: 68 65 20 6c 6f 63 6b 0a 09 20 20 20 20 20 20 28 he lock.. (
2960: 70 72 69 6e 74 20 22 4f 62 74 61 69 6e 65 64 20 print "Obtained
2970: 6c 6f 63 6b 20 66 6f 72 20 22 20 6f 75 74 70 75 lock for " outpu
2980: 74 66 69 6c 65 6e 61 6d 65 29 0a 09 20 20 20 20 tfilename)..
2990: 20 20 28 70 72 69 6e 74 20 22 46 61 69 6c 65 64 (print "Failed
29a0: 20 74 6f 20 6f 62 74 61 69 6e 20 6c 6f 63 6b 20 to obtain lock
29b0: 66 6f 72 20 22 20 6f 75 74 70 75 74 66 69 6c 65 for " outputfile
29c0: 6e 61 6d 65 29 29 0a 09 20 20 28 6c 65 74 20 28 name)).. (let (
29d0: 28 6f 75 70 20 20 20 20 28 6f 70 65 6e 2d 6f 75 (oup (open-ou
29e0: 74 70 75 74 2d 66 69 6c 65 20 6f 75 74 70 75 74 tput-file output
29f0: 66 69 6c 65 6e 61 6d 65 29 29 0a 09 09 28 63 6f filename))...(co
2a00: 75 6e 74 73 20 28 6d 61 6b 65 2d 68 61 73 68 2d unts (make-hash-
2a10: 74 61 62 6c 65 29 29 0a 09 09 28 73 74 61 74 65 table))...(state
2a20: 63 6f 75 6e 74 73 20 28 6d 61 6b 65 2d 68 61 73 counts (make-has
2a30: 68 2d 74 61 62 6c 65 29 29 0a 09 09 28 6f 75 74 h-table))...(out
2a40: 74 78 74 20 22 22 29 0a 09 09 28 74 6f 74 20 20 txt "")...(tot
2a50: 20 20 30 29 29 0a 09 20 20 20 20 28 77 69 74 68 0)).. (with
2a60: 2d 6f 75 74 70 75 74 2d 74 6f 2d 70 6f 72 74 0a -output-to-port.
2a70: 09 09 6f 75 70 0a 09 20 20 20 20 20 20 28 6c 61 ..oup.. (la
2a80: 6d 62 64 61 20 28 29 0a 09 09 28 73 65 74 21 20 mbda ()...(set!
2a90: 6f 75 74 74 78 74 20 28 63 6f 6e 63 20 6f 75 74 outtxt (conc out
2aa0: 74 78 74 20 22 3c 68 74 6d 6c 3e 3c 74 69 74 6c txt "<html><titl
2ab0: 65 3e 53 75 6d 6d 61 72 79 3a 20 22 20 74 65 73 e>Summary: " tes
2ac0: 74 2d 6e 61 6d 65 20 0a 09 09 09 09 20 20 20 22 t-name ..... "
2ad0: 3c 2f 74 69 74 6c 65 3e 3c 62 6f 64 79 3e 3c 68 </title><body><h
2ae0: 32 3e 53 75 6d 6d 61 72 79 20 66 6f 72 20 22 20 2>Summary for "
2af0: 74 65 73 74 2d 6e 61 6d 65 20 22 3c 2f 68 32 3e test-name "</h2>
2b00: 22 29 29 0a 09 09 28 73 71 6c 69 74 65 33 3a 66 "))...(sqlite3:f
2b10: 6f 72 2d 65 61 63 68 2d 72 6f 77 20 0a 09 09 20 or-each-row ...
2b20: 28 6c 61 6d 62 64 61 20 28 69 64 20 69 74 65 6d (lambda (id item
2b30: 70 61 74 68 20 73 74 61 74 65 20 73 74 61 74 75 path state statu
2b40: 73 20 72 75 6e 5f 64 75 72 61 74 69 6f 6e 20 6c s run_duration l
2b50: 6f 67 66 20 63 6f 6d 6d 65 6e 74 29 0a 09 09 20 ogf comment)...
2b60: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
2b70: 74 21 20 63 6f 75 6e 74 73 20 73 74 61 74 75 73 t! counts status
2b80: 20 28 2b 20 31 20 28 68 61 73 68 2d 74 61 62 6c (+ 1 (hash-tabl
2b90: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 63 6f e-ref/default co
2ba0: 75 6e 74 73 20 73 74 61 74 75 73 20 30 29 29 29 unts status 0)))
2bb0: 0a 09 09 20 20 20 28 68 61 73 68 2d 74 61 62 6c ... (hash-tabl
2bc0: 65 2d 73 65 74 21 20 73 74 61 74 65 63 6f 75 6e e-set! statecoun
2bd0: 74 73 20 73 74 61 74 65 20 28 2b 20 31 20 28 68 ts state (+ 1 (h
2be0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
2bf0: 66 61 75 6c 74 20 73 74 61 74 65 63 6f 75 6e 74 fault statecount
2c00: 73 20 73 74 61 74 65 20 30 29 29 29 0a 09 09 20 s state 0)))...
2c10: 20 20 28 73 65 74 21 20 6f 75 74 74 78 74 20 28 (set! outtxt (
2c20: 63 6f 6e 63 20 6f 75 74 74 78 74 20 22 3c 74 72 conc outtxt "<tr
2c30: 3e 22 0a 09 09 09 09 20 20 20 20 20 20 22 3c 74 >"..... "<t
2c40: 64 3e 3c 61 20 68 72 65 66 3d 5c 22 22 20 69 74 d><a href=\"" it
2c50: 65 6d 70 61 74 68 20 22 2f 22 20 6c 6f 67 66 20 empath "/" logf
2c60: 22 5c 22 3e 20 22 20 69 74 65 6d 70 61 74 68 20 "\"> " itempath
2c70: 22 3c 2f 61 3e 3c 2f 74 64 3e 22 20 0a 09 09 09 "</a></td>" ....
2c80: 09 20 20 20 20 20 20 22 3c 74 64 3e 22 20 73 74 . "<td>" st
2c90: 61 74 65 20 20 20 20 22 3c 2f 74 64 3e 22 20 0a ate "</td>" .
2ca0: 09 09 09 09 20 20 20 20 20 20 22 3c 74 64 3e 3c .... "<td><
2cb0: 66 6f 6e 74 20 63 6f 6c 6f 72 3d 22 20 28 63 6f font color=" (co
2cc0: 6d 6d 6f 6e 3a 67 65 74 2d 63 6f 6c 6f 72 2d 66 mmon:get-color-f
2cd0: 72 6f 6d 2d 73 74 61 74 75 73 20 73 74 61 74 75 rom-status statu
2ce0: 73 29 0a 09 09 09 09 20 20 20 20 20 20 22 3e 22 s)..... ">"
2cf0: 20 20 20 73 74 61 74 75 73 20 20 20 22 3c 2f 66 status "</f
2d00: 6f 6e 74 3e 3c 2f 74 64 3e 22 0a 09 09 09 09 20 ont></td>".....
2d10: 20 20 20 20 20 22 3c 74 64 3e 22 20 28 69 66 20 "<td>" (if
2d20: 28 65 71 75 61 6c 3f 20 63 6f 6d 6d 65 6e 74 20 (equal? comment
2d30: 22 22 29 0a 09 09 09 09 09 09 20 22 26 6e 62 73 "")....... "&nbs
2d40: 70 3b 22 0a 09 09 09 09 09 09 20 63 6f 6d 6d 65 p;"....... comme
2d50: 6e 74 29 20 22 3c 2f 74 64 3e 22 0a 09 09 09 09 nt) "</td>".....
2d60: 09 09 20 22 3c 2f 74 72 3e 22 29 29 29 0a 09 09 .. "</tr>")))...
2d70: 20 64 62 0a 09 09 20 22 53 45 4c 45 43 54 20 69 db... "SELECT i
2d80: 64 2c 69 74 65 6d 5f 70 61 74 68 2c 73 74 61 74 d,item_path,stat
2d90: 65 2c 73 74 61 74 75 73 2c 72 75 6e 5f 64 75 72 e,status,run_dur
2da0: 61 74 69 6f 6e 2c 66 69 6e 61 6c 5f 6c 6f 67 66 ation,final_logf
2db0: 2c 63 6f 6d 6d 65 6e 74 20 46 52 4f 4d 20 74 65 ,comment FROM te
2dc0: 73 74 73 20 57 48 45 52 45 20 72 75 6e 5f 69 64 sts WHERE run_id
2dd0: 3d 3f 20 41 4e 44 20 74 65 73 74 6e 61 6d 65 3d =? AND testname=
2de0: 3f 20 41 4e 44 20 69 74 65 6d 5f 70 61 74 68 20 ? AND item_path
2df0: 21 3d 20 27 27 3b 22 0a 09 09 20 72 75 6e 2d 69 != '';"... run-i
2e00: 64 20 74 65 73 74 2d 6e 61 6d 65 29 0a 0a 09 09 d test-name)....
2e10: 28 70 72 69 6e 74 20 22 3c 74 61 62 6c 65 3e 3c (print "<table><
2e20: 74 72 3e 3c 74 64 20 76 61 6c 69 67 6e 3d 5c 22 tr><td valign=\"
2e30: 74 6f 70 5c 22 3e 22 29 0a 09 09 3b 3b 20 50 72 top\">")...;; Pr
2e40: 69 6e 74 20 6f 75 74 20 73 74 61 74 73 20 66 6f int out stats fo
2e50: 72 20 73 74 61 74 75 73 0a 09 09 28 73 65 74 21 r status...(set!
2e60: 20 74 6f 74 20 30 29 0a 09 09 28 70 72 69 6e 74 tot 0)...(print
2e70: 20 22 3c 74 61 62 6c 65 20 63 65 6c 6c 73 70 61 "<table cellspa
2e80: 63 69 6e 67 3d 5c 22 30 5c 22 20 62 6f 72 64 65 cing=\"0\" borde
2e90: 72 3d 5c 22 31 5c 22 3e 3c 74 72 3e 3c 74 64 20 r=\"1\"><tr><td
2ea0: 63 6f 6c 73 70 61 6e 3d 5c 22 32 5c 22 3e 3c 68 colspan=\"2\"><h
2eb0: 32 3e 53 74 61 74 65 20 73 74 61 74 73 3c 2f 68 2>State stats</h
2ec0: 32 3e 3c 2f 74 64 3e 3c 2f 74 72 3e 22 29 0a 09 2></td></tr>")..
2ed0: 09 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 .(for-each (lamb
2ee0: 64 61 20 28 73 74 61 74 65 29 0a 09 09 09 20 20 da (state)....
2ef0: 20 20 28 73 65 74 21 20 74 6f 74 20 28 2b 20 74 (set! tot (+ t
2f00: 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 ot (hash-table-r
2f10: 65 66 20 73 74 61 74 65 63 6f 75 6e 74 73 20 73 ef statecounts s
2f20: 74 61 74 65 29 29 29 0a 09 09 09 20 20 20 20 28 tate))).... (
2f30: 70 72 69 6e 74 20 22 3c 74 72 3e 3c 74 64 3e 22 print "<tr><td>"
2f40: 20 73 74 61 74 65 20 22 3c 2f 74 64 3e 3c 74 64 state "</td><td
2f50: 3e 22 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 >" (hash-table-r
2f60: 65 66 20 73 74 61 74 65 63 6f 75 6e 74 73 20 73 ef statecounts s
2f70: 74 61 74 65 29 20 22 3c 2f 74 64 3e 3c 2f 74 72 tate) "</td></tr
2f80: 3e 22 29 29 0a 09 09 09 20 20 28 68 61 73 68 2d >")).... (hash-
2f90: 74 61 62 6c 65 2d 6b 65 79 73 20 73 74 61 74 65 table-keys state
2fa0: 63 6f 75 6e 74 73 29 29 0a 09 09 28 70 72 69 6e counts))...(prin
2fb0: 74 20 22 3c 74 72 3e 3c 74 64 3e 54 6f 74 61 6c t "<tr><td>Total
2fc0: 3c 2f 74 64 3e 3c 74 64 3e 22 20 74 6f 74 20 22 </td><td>" tot "
2fd0: 3c 2f 74 64 3e 3c 2f 74 72 3e 3c 2f 74 61 62 6c </td></tr></tabl
2fe0: 65 3e 22 29 0a 09 09 28 70 72 69 6e 74 20 22 3c e>")...(print "<
2ff0: 2f 74 64 3e 3c 74 64 20 76 61 6c 69 67 6e 3d 5c /td><td valign=\
3000: 22 74 6f 70 5c 22 3e 22 29 0a 09 09 3b 3b 20 50 "top\">")...;; P
3010: 72 69 6e 74 20 6f 75 74 20 73 74 61 74 73 20 66 rint out stats f
3020: 6f 72 20 73 74 61 74 65 0a 09 09 28 73 65 74 21 or state...(set!
3030: 20 74 6f 74 20 30 29 0a 09 09 28 70 72 69 6e 74 tot 0)...(print
3040: 20 22 3c 74 61 62 6c 65 20 63 65 6c 6c 73 70 61 "<table cellspa
3050: 63 69 6e 67 3d 5c 22 30 5c 22 20 62 6f 72 64 65 cing=\"0\" borde
3060: 72 3d 5c 22 31 5c 22 3e 3c 74 72 3e 3c 74 64 20 r=\"1\"><tr><td
3070: 63 6f 6c 73 70 61 6e 3d 5c 22 32 5c 22 3e 3c 68 colspan=\"2\"><h
3080: 32 3e 53 74 61 74 75 73 20 73 74 61 74 73 3c 2f 2>Status stats</
3090: 68 32 3e 3c 2f 74 64 3e 3c 2f 74 72 3e 22 29 0a h2></td></tr>").
30a0: 09 09 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d ..(for-each (lam
30b0: 62 64 61 20 28 73 74 61 74 75 73 29 0a 09 09 09 bda (status)....
30c0: 20 20 20 20 28 73 65 74 21 20 74 6f 74 20 28 2b (set! tot (+
30d0: 20 74 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 tot (hash-table
30e0: 2d 72 65 66 20 63 6f 75 6e 74 73 20 73 74 61 74 -ref counts stat
30f0: 75 73 29 29 29 0a 09 09 09 20 20 20 20 28 70 72 us))).... (pr
3100: 69 6e 74 20 22 3c 74 72 3e 3c 74 64 3e 3c 66 6f int "<tr><td><fo
3110: 6e 74 20 63 6f 6c 6f 72 3d 5c 22 22 20 28 63 6f nt color=\"" (co
3120: 6d 6d 6f 6e 3a 67 65 74 2d 63 6f 6c 6f 72 2d 66 mmon:get-color-f
3130: 72 6f 6d 2d 73 74 61 74 75 73 20 73 74 61 74 75 rom-status statu
3140: 73 29 20 22 5c 22 3e 22 20 73 74 61 74 75 73 0a s) "\">" status.
3150: 09 09 09 09 20 20 20 22 3c 2f 66 6f 6e 74 3e 3c .... "</font><
3160: 2f 74 64 3e 3c 74 64 3e 22 20 28 68 61 73 68 2d /td><td>" (hash-
3170: 74 61 62 6c 65 2d 72 65 66 20 63 6f 75 6e 74 73 table-ref counts
3180: 20 73 74 61 74 75 73 29 20 22 3c 2f 74 64 3e 3c status) "</td><
3190: 2f 74 72 3e 22 29 29 0a 09 09 09 20 20 28 68 61 /tr>")).... (ha
31a0: 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 63 6f sh-table-keys co
31b0: 75 6e 74 73 29 29 0a 09 09 28 70 72 69 6e 74 20 unts))...(print
31c0: 22 3c 74 72 3e 3c 74 64 3e 54 6f 74 61 6c 3c 2f "<tr><td>Total</
31d0: 74 64 3e 3c 74 64 3e 22 20 74 6f 74 20 22 3c 2f td><td>" tot "</
31e0: 74 64 3e 3c 2f 74 72 3e 3c 2f 74 61 62 6c 65 3e td></tr></table>
31f0: 22 29 0a 09 09 28 70 72 69 6e 74 20 22 3c 2f 74 ")...(print "</t
3200: 64 3e 3c 2f 74 64 3e 3c 2f 74 72 3e 3c 2f 74 61 d></td></tr></ta
3210: 62 6c 65 3e 22 29 0a 0a 09 09 28 70 72 69 6e 74 ble>")....(print
3220: 20 22 3c 74 61 62 6c 65 20 63 65 6c 6c 73 70 61 "<table cellspa
3230: 63 69 6e 67 3d 5c 22 30 5c 22 20 62 6f 72 64 65 cing=\"0\" borde
3240: 72 3d 5c 22 31 5c 22 3e 22 20 0a 09 09 20 20 20 r=\"1\">" ...
3250: 20 20 20 20 22 3c 74 72 3e 3c 74 64 3e 49 74 65 "<tr><td>Ite
3260: 6d 3c 2f 74 64 3e 3c 74 64 3e 53 74 61 74 65 3c m</td><td>State<
3270: 2f 74 64 3e 3c 74 64 3e 53 74 61 74 75 73 3c 2f /td><td>Status</
3280: 74 64 3e 3c 74 64 3e 43 6f 6d 6d 65 6e 74 3c 2f td><td>Comment</
3290: 74 64 3e 22 0a 09 09 20 20 20 20 20 20 20 6f 75 td>"... ou
32a0: 74 74 78 74 20 22 3c 2f 74 61 62 6c 65 3e 3c 2f ttxt "</table></
32b0: 62 6f 64 79 3e 3c 2f 68 74 6d 6c 3e 22 29 0a 09 body></html>")..
32c0: 09 28 72 65 6c 65 61 73 65 2d 64 6f 74 2d 6c 6f .(release-dot-lo
32d0: 63 6b 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d ck outputfilenam
32e0: 65 29 29 29 0a 09 20 20 20 20 28 63 6c 6f 73 65 e))).. (close
32f0: 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 6f 75 70 -output-port oup
3300: 29 0a 09 20 20 20 20 28 63 68 61 6e 67 65 2d 64 ).. (change-d
3310: 69 72 65 63 74 6f 72 79 20 6f 72 69 67 2d 64 69 irectory orig-di
3320: 72 29 0a 09 20 20 20 20 28 74 65 73 74 2d 73 65 r).. (test-se
3330: 74 2d 74 6f 70 6c 6f 67 21 20 64 62 20 72 75 6e t-toplog! db run
3340: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 6f 75 -id test-name ou
3350: 74 70 75 74 66 69 6c 65 6e 61 6d 65 29 0a 09 20 tputfilename)..
3360: 20 20 20 29 29 29 29 29 0a 0a 3b 3b 20 3b 3b 20 )))))..;; ;;
3370: 54 4f 44 4f 3a 20 43 6f 6e 76 65 72 67 65 20 74 TODO: Converge t
3380: 68 69 73 20 77 69 74 68 20 64 62 3a 67 65 74 2d his with db:get-
3390: 74 65 73 74 2d 69 6e 66 6f 0a 3b 3b 20 28 64 65 test-info.;; (de
33a0: 66 69 6e 65 20 28 72 75 6e 73 3a 67 65 74 2d 74 fine (runs:get-t
33b0: 65 73 74 2d 69 6e 66 6f 20 64 62 20 72 75 6e 2d est-info db run-
33c0: 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 id test-name ite
33d0: 6d 2d 70 61 74 68 29 0a 3b 3b 20 20 20 28 6c 65 m-path).;; (le
33e0: 74 20 28 28 72 65 73 20 23 66 29 29 20 3b 3b 20 t ((res #f)) ;;
33f0: 28 76 65 63 74 6f 72 20 23 66 20 23 66 20 23 66 (vector #f #f #f
3400: 20 23 66 20 23 66 20 23 66 29 29 29 0a 3b 3b 20 #f #f #f))).;;
3410: 20 20 20 20 28 73 71 6c 69 74 65 33 3a 66 6f 72 (sqlite3:for
3420: 2d 65 61 63 68 2d 72 6f 77 20 0a 3b 3b 20 20 20 -each-row .;;
3430: 20 20 20 28 6c 61 6d 62 64 61 20 28 69 64 20 72 (lambda (id r
3440: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 un-id test-name
3450: 73 74 61 74 65 20 73 74 61 74 75 73 29 0a 3b 3b state status).;;
3460: 20 20 20 20 20 20 20 20 28 73 65 74 21 20 72 65 (set! re
3470: 73 20 28 76 65 63 74 6f 72 20 69 64 20 72 75 6e s (vector id run
3480: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 73 74 -id test-name st
3490: 61 74 65 20 73 74 61 74 75 73 20 69 74 65 6d 2d ate status item-
34a0: 70 61 74 68 29 29 29 0a 3b 3b 20 20 20 20 20 20 path))).;;
34b0: 64 62 20 22 53 45 4c 45 43 54 20 69 64 2c 72 75 db "SELECT id,ru
34c0: 6e 5f 69 64 2c 74 65 73 74 6e 61 6d 65 2c 73 74 n_id,testname,st
34d0: 61 74 65 2c 73 74 61 74 75 73 20 46 52 4f 4d 20 ate,status FROM
34e0: 74 65 73 74 73 20 57 48 45 52 45 20 72 75 6e 5f tests WHERE run_
34f0: 69 64 3d 3f 20 41 4e 44 20 74 65 73 74 6e 61 6d id=? AND testnam
3500: 65 3d 3f 20 41 4e 44 20 69 74 65 6d 5f 70 61 74 e=? AND item_pat
3510: 68 3d 3f 3b 22 0a 3b 3b 20 20 20 20 20 20 72 75 h=?;".;; ru
3520: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 n-id test-name i
3530: 74 65 6d 2d 70 61 74 68 29 0a 3b 3b 20 20 20 20 tem-path).;;
3540: 20 72 65 73 29 29 0a 0a 28 64 65 66 69 6e 65 2d res))..(define-
3550: 69 6e 6c 69 6e 65 20 28 74 65 73 74 3a 67 65 74 inline (test:get
3560: 2d 69 64 20 76 65 63 29 20 20 20 20 20 20 20 28 -id vec) (
3570: 76 65 63 74 6f 72 2d 72 65 66 20 76 65 63 20 30 vector-ref vec 0
3580: 29 29 0a 28 64 65 66 69 6e 65 2d 69 6e 6c 69 6e )).(define-inlin
3590: 65 20 28 74 65 73 74 3a 67 65 74 2d 72 75 6e 5f e (test:get-run_
35a0: 69 64 20 76 65 63 29 20 20 20 28 76 65 63 74 6f id vec) (vecto
35b0: 72 2d 72 65 66 20 76 65 63 20 31 29 29 0a 28 64 r-ref vec 1)).(d
35c0: 65 66 69 6e 65 2d 69 6e 6c 69 6e 65 20 28 74 65 efine-inline (te
35d0: 73 74 3a 67 65 74 2d 74 65 73 74 2d 6e 61 6d 65 st:get-test-name
35e0: 20 76 65 63 29 28 76 65 63 74 6f 72 2d 72 65 66 vec)(vector-ref
35f0: 20 76 65 63 20 32 29 29 0a 28 64 65 66 69 6e 65 vec 2)).(define
3600: 2d 69 6e 6c 69 6e 65 20 28 74 65 73 74 3a 67 65 -inline (test:ge
3610: 74 2d 73 74 61 74 65 20 76 65 63 29 20 20 20 20 t-state vec)
3620: 28 76 65 63 74 6f 72 2d 72 65 66 20 76 65 63 20 (vector-ref vec
3630: 33 29 29 0a 28 64 65 66 69 6e 65 2d 69 6e 6c 69 3)).(define-inli
3640: 6e 65 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 ne (test:get-sta
3650: 74 75 73 20 76 65 63 29 20 20 20 28 76 65 63 74 tus vec) (vect
3660: 6f 72 2d 72 65 66 20 76 65 63 20 34 29 29 0a 28 or-ref vec 4)).(
3670: 64 65 66 69 6e 65 2d 69 6e 6c 69 6e 65 20 28 74 define-inline (t
3680: 65 73 74 3a 67 65 74 2d 69 74 65 6d 2d 70 61 74 est:get-item-pat
3690: 68 20 76 65 63 29 28 76 65 63 74 6f 72 2d 72 65 h vec)(vector-re
36a0: 66 20 76 65 63 20 35 29 29 0a 0a 28 64 65 66 69 f vec 5))..(defi
36b0: 6e 65 20 28 72 75 6e 73 3a 74 65 73 74 2d 67 65 ne (runs:test-ge
36c0: 74 2d 66 75 6c 6c 2d 70 61 74 68 20 74 65 73 74 t-full-path test
36d0: 29 0a 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 ). (let* ((test
36e0: 6e 61 6d 65 20 28 64 62 3a 74 65 73 74 2d 67 65 name (db:test-ge
36f0: 74 2d 74 65 73 74 6e 61 6d 65 20 20 20 74 65 73 t-testname tes
3700: 74 29 29 0a 09 20 28 69 74 65 6d 70 61 74 68 20 t)).. (itempath
3710: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 (db:test-get-ite
3720: 6d 2d 70 61 74 68 20 74 65 73 74 29 29 29 0a 20 m-path test))).
3730: 20 20 20 28 63 6f 6e 63 20 74 65 73 74 6e 61 6d (conc testnam
3740: 65 20 28 69 66 20 28 65 71 75 61 6c 3f 20 69 74 e (if (equal? it
3750: 65 6d 70 61 74 68 20 22 22 29 20 22 22 20 28 63 empath "") "" (c
3760: 6f 6e 63 20 22 28 22 20 69 74 65 6d 70 61 74 68 onc "(" itempath
3770: 20 22 29 22 29 29 29 29 29 0a 0a 28 64 65 66 69 ")")))))..(defi
3780: 6e 65 2d 69 6e 6c 69 6e 65 20 28 74 65 73 74 3a ne-inline (test:
3790: 74 65 73 74 2d 67 65 74 2d 66 75 6c 6c 6e 61 6d test-get-fullnam
37a0: 65 20 74 65 73 74 29 0a 20 20 20 28 63 6f 6e 63 e test). (conc
37b0: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 (db:test-get-te
37c0: 73 74 6e 61 6d 65 20 74 65 73 74 29 0a 09 20 28 stname test).. (
37d0: 69 66 20 28 65 71 75 61 6c 3f 20 28 64 62 3a 74 if (equal? (db:t
37e0: 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 est-get-item-pat
37f0: 68 20 74 65 73 74 29 20 22 22 29 0a 09 20 20 20 h test) "")..
3800: 20 20 22 22 0a 09 20 20 20 20 20 28 63 6f 6e 63 "".. (conc
3810: 20 22 28 22 20 28 64 62 3a 74 65 73 74 2d 67 65 "(" (db:test-ge
3820: 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 65 73 74 t-item-path test
3830: 29 20 22 29 22 29 29 29 29 0a 0a 28 64 65 66 69 ) ")"))))..(defi
3840: 6e 65 20 28 63 68 65 63 6b 2d 76 61 6c 69 64 2d ne (check-valid-
3850: 69 74 65 6d 73 20 63 6c 61 73 73 20 69 74 65 6d items class item
3860: 29 0a 20 20 28 6c 65 74 20 28 28 76 61 6c 69 64 ). (let ((valid
3870: 2d 76 61 6c 75 65 73 20 28 6c 65 74 20 28 28 73 -values (let ((s
3880: 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 (config-lookup
3890: 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 76 61 6c *configdat* "val
38a0: 69 64 76 61 6c 75 65 73 22 20 63 6c 61 73 73 29 idvalues" class)
38b0: 29 29 0a 09 09 09 28 69 66 20 73 20 28 73 74 72 ))....(if s (str
38c0: 69 6e 67 2d 73 70 6c 69 74 20 73 29 20 23 66 29 ing-split s) #f)
38d0: 29 29 29 0a 20 20 20 20 28 69 66 20 76 61 6c 69 ))). (if vali
38e0: 64 2d 76 61 6c 75 65 73 0a 09 28 69 66 20 28 6d d-values..(if (m
38f0: 65 6d 62 65 72 20 69 74 65 6d 20 76 61 6c 69 64 ember item valid
3900: 2d 76 61 6c 75 65 73 29 0a 09 20 20 20 20 69 74 -values).. it
3910: 65 6d 20 23 66 29 0a 09 69 74 65 6d 29 29 29 0a em #f)..item))).
3920: 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 74 .(define (testst
3930: 65 70 2d 73 65 74 2d 73 74 61 74 75 73 21 20 64 ep-set-status! d
3940: 62 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 b run-id test-na
3950: 6d 65 20 74 65 73 74 73 74 65 70 2d 6e 61 6d 65 me teststep-name
3960: 20 73 74 61 74 65 2d 69 6e 20 73 74 61 74 75 73 state-in status
3970: 2d 69 6e 20 69 74 65 6d 64 61 74 20 63 6f 6d 6d -in itemdat comm
3980: 65 6e 74 29 0a 20 20 28 64 65 62 75 67 3a 70 72 ent). (debug:pr
3990: 69 6e 74 20 34 20 22 72 75 6e 2d 69 64 3a 20 22 int 4 "run-id: "
39a0: 20 72 75 6e 2d 69 64 20 22 20 74 65 73 74 2d 6e run-id " test-n
39b0: 61 6d 65 3a 20 22 20 74 65 73 74 2d 6e 61 6d 65 ame: " test-name
39c0: 29 0a 20 20 28 6c 65 74 2a 20 28 28 73 74 61 74 ). (let* ((stat
39d0: 65 20 20 20 20 20 28 63 68 65 63 6b 2d 76 61 6c e (check-val
39e0: 69 64 2d 69 74 65 6d 73 20 22 73 74 61 74 65 22 id-items "state"
39f0: 20 73 74 61 74 65 2d 69 6e 29 29 0a 09 20 28 73 state-in)).. (s
3a00: 74 61 74 75 73 20 20 20 20 28 63 68 65 63 6b 2d tatus (check-
3a10: 76 61 6c 69 64 2d 69 74 65 6d 73 20 22 73 74 61 valid-items "sta
3a20: 74 75 73 22 20 73 74 61 74 75 73 2d 69 6e 29 29 tus" status-in))
3a30: 0a 09 20 28 69 74 65 6d 2d 70 61 74 68 20 28 69 .. (item-path (i
3a40: 74 65 6d 2d 6c 69 73 74 2d 3e 70 61 74 68 20 69 tem-list->path i
3a50: 74 65 6d 64 61 74 29 29 0a 09 20 28 74 65 73 74 temdat)).. (test
3a60: 64 61 74 20 20 20 28 64 62 3a 67 65 74 2d 74 65 dat (db:get-te
3a70: 73 74 2d 69 6e 66 6f 20 64 62 20 72 75 6e 2d 69 st-info db run-i
3a80: 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d d test-name item
3a90: 2d 70 61 74 68 29 29 29 0a 20 20 20 20 28 64 65 -path))). (de
3aa0: 62 75 67 3a 70 72 69 6e 74 20 35 20 22 74 65 73 bug:print 5 "tes
3ab0: 74 64 61 74 3a 20 22 20 74 65 73 74 64 61 74 29 tdat: " testdat)
3ac0: 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 74 65 . (if (and te
3ad0: 73 74 64 61 74 20 3b 3b 20 69 66 20 74 68 65 20 stdat ;; if the
3ae0: 73 65 63 74 69 6f 6e 20 65 78 69 73 74 73 20 74 section exists t
3af0: 68 65 6e 20 66 6f 72 63 65 20 73 70 65 63 69 66 hen force specif
3b00: 69 63 61 74 69 6f 6e 20 42 55 47 2c 20 49 20 64 ication BUG, I d
3b10: 6f 6e 27 74 20 6c 69 6b 65 20 68 6f 77 20 74 68 on't like how th
3b20: 69 73 20 77 6f 72 6b 73 2e 0a 09 20 20 20 20 20 is works...
3b30: 28 6f 72 20 28 6e 6f 74 20 73 74 61 74 65 29 28 (or (not state)(
3b40: 6e 6f 74 20 73 74 61 74 75 73 29 29 29 0a 09 28 not status)))..(
3b50: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 debug:print 0 "W
3b60: 41 52 4e 49 4e 47 3a 20 49 6e 76 61 6c 69 64 20 ARNING: Invalid
3b70: 22 20 28 69 66 20 73 74 61 74 75 73 20 22 73 74 " (if status "st
3b80: 61 74 75 73 22 20 22 73 74 61 74 65 22 29 0a 09 atus" "state")..
3b90: 20 20 20 20 20 20 20 22 20 76 61 6c 75 65 20 5c " value \
3ba0: 22 22 20 28 69 66 20 73 74 61 74 75 73 20 73 74 "" (if status st
3bb0: 61 74 75 73 2d 69 6e 20 73 74 61 74 65 2d 69 6e atus-in state-in
3bc0: 29 20 22 5c 22 2c 20 75 70 64 61 74 65 20 79 6f ) "\", update yo
3bd0: 75 72 20 76 61 6c 69 64 73 74 61 74 65 73 20 73 ur validstates s
3be0: 65 63 74 69 6f 6e 20 69 6e 20 6d 65 67 61 74 65 ection in megate
3bf0: 73 74 2e 63 6f 6e 66 69 67 22 29 29 0a 20 20 20 st.config")).
3c00: 20 28 69 66 20 74 65 73 74 64 61 74 0a 09 28 6c (if testdat..(l
3c10: 65 74 20 28 28 74 65 73 74 2d 69 64 20 28 74 65 et ((test-id (te
3c20: 73 74 3a 67 65 74 2d 69 64 20 74 65 73 74 64 61 st:get-id testda
3c30: 74 29 29 29 0a 09 20 20 28 73 71 6c 69 74 65 33 t))).. (sqlite3
3c40: 3a 65 78 65 63 75 74 65 20 64 62 20 0a 09 09 09 :execute db ....
3c50: 22 49 4e 53 45 52 54 20 4f 52 20 52 45 50 4c 41 "INSERT OR REPLA
3c60: 43 45 20 69 6e 74 6f 20 74 65 73 74 5f 73 74 65 CE into test_ste
3c70: 70 73 20 28 74 65 73 74 5f 69 64 2c 73 74 65 70 ps (test_id,step
3c80: 6e 61 6d 65 2c 73 74 61 74 65 2c 73 74 61 74 75 name,state,statu
3c90: 73 2c 65 76 65 6e 74 5f 74 69 6d 65 2c 63 6f 6d s,event_time,com
3ca0: 6d 65 6e 74 29 20 56 41 4c 55 45 53 28 3f 2c 3f ment) VALUES(?,?
3cb0: 2c 3f 2c 3f 2c 73 74 72 66 74 69 6d 65 28 27 25 ,?,?,strftime('%
3cc0: 73 27 2c 27 6e 6f 77 27 29 2c 3f 29 3b 22 0a 09 s','now'),?);"..
3cd0: 09 09 74 65 73 74 2d 69 64 20 74 65 73 74 73 74 ..test-id testst
3ce0: 65 70 2d 6e 61 6d 65 20 73 74 61 74 65 20 73 74 ep-name state st
3cf0: 61 74 75 73 20 28 69 66 20 63 6f 6d 6d 65 6e 74 atus (if comment
3d00: 20 63 6f 6d 6d 65 6e 74 20 22 22 29 29 29 0a 09 comment "")))..
3d10: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
3d20: 45 52 52 4f 52 3a 20 43 61 6e 27 74 20 75 70 64 ERROR: Can't upd
3d30: 61 74 65 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 ate " test-name
3d40: 22 20 66 6f 72 20 72 75 6e 20 22 20 72 75 6e 2d " for run " run-
3d50: 69 64 20 22 20 2d 3e 20 6e 6f 20 73 75 63 68 20 id " -> no such
3d60: 74 65 73 74 20 69 6e 20 64 62 22 29 29 29 29 0a test in db")))).
3d70: 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 2d 67 .(define (test-g
3d80: 65 74 2d 6b 69 6c 6c 2d 72 65 71 75 65 73 74 20 et-kill-request
3d90: 64 62 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e db run-id test-n
3da0: 61 6d 65 20 69 74 65 6d 64 61 74 29 0a 20 20 28 ame itemdat). (
3db0: 6c 65 74 2a 20 28 28 69 74 65 6d 2d 70 61 74 68 let* ((item-path
3dc0: 20 28 69 74 65 6d 2d 6c 69 73 74 2d 3e 70 61 74 (item-list->pat
3dd0: 68 20 69 74 65 6d 64 61 74 29 29 0a 09 20 28 74 h itemdat)).. (t
3de0: 65 73 74 64 61 74 20 20 20 28 64 62 3a 67 65 74 estdat (db:get
3df0: 2d 74 65 73 74 2d 69 6e 66 6f 20 64 62 20 72 75 -test-info db ru
3e00: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 n-id test-name i
3e10: 74 65 6d 2d 70 61 74 68 29 29 29 0a 20 20 20 20 tem-path))).
3e20: 28 65 71 75 61 6c 3f 20 28 74 65 73 74 3a 67 65 (equal? (test:ge
3e30: 74 2d 73 74 61 74 65 20 74 65 73 74 64 61 74 29 t-state testdat)
3e40: 20 22 4b 49 4c 4c 52 45 51 22 29 29 29 0a 0a 28 "KILLREQ")))..(
3e50: 64 65 66 69 6e 65 20 28 74 65 73 74 2d 73 65 74 define (test-set
3e60: 2d 6d 65 74 61 2d 69 6e 66 6f 20 64 62 20 72 75 -meta-info db ru
3e70: 6e 2d 69 64 20 74 65 73 74 6e 61 6d 65 20 69 74 n-id testname it
3e80: 65 6d 64 61 74 29 0a 20 20 28 6c 65 74 20 28 28 emdat). (let ((
3e90: 69 74 65 6d 2d 70 61 74 68 20 28 69 74 65 6d 2d item-path (item-
3ea0: 6c 69 73 74 2d 3e 70 61 74 68 20 69 74 65 6d 64 list->path itemd
3eb0: 61 74 29 29 0a 09 28 63 70 75 6c 6f 61 64 20 20 at))..(cpuload
3ec0: 28 67 65 74 2d 63 70 75 2d 6c 6f 61 64 29 29 0a (get-cpu-load)).
3ed0: 09 28 68 6f 73 74 6e 61 6d 65 20 28 67 65 74 2d .(hostname (get-
3ee0: 68 6f 73 74 2d 6e 61 6d 65 29 29 0a 09 28 64 69 host-name))..(di
3ef0: 73 6b 66 72 65 65 20 28 67 65 74 2d 64 66 20 28 skfree (get-df (
3f00: 63 75 72 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 current-director
3f10: 79 29 29 29 0a 09 28 75 6e 61 6d 65 20 20 20 20 y)))..(uname
3f20: 28 67 65 74 2d 75 6e 61 6d 65 20 22 2d 73 72 76 (get-uname "-srv
3f30: 70 69 6f 22 29 29 0a 09 28 72 75 6e 70 61 74 68 pio"))..(runpath
3f40: 20 20 28 63 75 72 72 65 6e 74 2d 64 69 72 65 63 (current-direc
3f50: 74 6f 72 79 29 29 29 0a 20 20 20 20 28 73 71 6c tory))). (sql
3f60: 69 74 65 33 3a 65 78 65 63 75 74 65 20 64 62 20 ite3:execute db
3f70: 22 55 50 44 41 54 45 20 74 65 73 74 73 20 53 45 "UPDATE tests SE
3f80: 54 20 68 6f 73 74 3d 3f 2c 63 70 75 6c 6f 61 64 T host=?,cpuload
3f90: 3d 3f 2c 64 69 73 6b 66 72 65 65 3d 3f 2c 75 6e =?,diskfree=?,un
3fa0: 61 6d 65 3d 3f 2c 72 75 6e 64 69 72 3d 3f 20 57 ame=?,rundir=? W
3fb0: 48 45 52 45 20 72 75 6e 5f 69 64 3d 3f 20 41 4e HERE run_id=? AN
3fc0: 44 20 74 65 73 74 6e 61 6d 65 3d 3f 20 41 4e 44 D testname=? AND
3fd0: 20 69 74 65 6d 5f 70 61 74 68 3d 3f 3b 22 0a 09 item_path=?;"..
3fe0: 09 20 20 68 6f 73 74 6e 61 6d 65 0a 09 09 20 20 . hostname...
3ff0: 63 70 75 6c 6f 61 64 0a 09 09 20 20 64 69 73 6b cpuload... disk
4000: 66 72 65 65 0a 09 09 20 20 75 6e 61 6d 65 0a 09 free... uname..
4010: 09 20 20 72 75 6e 70 61 74 68 0a 09 09 20 20 72 . runpath... r
4020: 75 6e 2d 69 64 0a 09 09 20 20 74 65 73 74 6e 61 un-id... testna
4030: 6d 65 0a 09 09 20 20 69 74 65 6d 2d 70 61 74 68 me... item-path
4040: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 )))..(define (te
4050: 73 74 2d 75 70 64 61 74 65 2d 6d 65 74 61 2d 69 st-update-meta-i
4060: 6e 66 6f 20 64 62 20 72 75 6e 2d 69 64 20 74 65 nfo db run-id te
4070: 73 74 6e 61 6d 65 20 69 74 65 6d 64 61 74 20 6d stname itemdat m
4080: 69 6e 75 74 65 73 29 0a 20 20 28 6c 65 74 20 28 inutes). (let (
4090: 28 69 74 65 6d 2d 70 61 74 68 20 28 69 74 65 6d (item-path (item
40a0: 2d 6c 69 73 74 2d 3e 70 61 74 68 20 69 74 65 6d -list->path item
40b0: 64 61 74 29 29 0a 09 28 63 70 75 6c 6f 61 64 20 dat))..(cpuload
40c0: 20 28 67 65 74 2d 63 70 75 2d 6c 6f 61 64 29 29 (get-cpu-load))
40d0: 0a 09 28 64 69 73 6b 66 72 65 65 20 28 67 65 74 ..(diskfree (get
40e0: 2d 64 66 20 28 63 75 72 72 65 6e 74 2d 64 69 72 -df (current-dir
40f0: 65 63 74 6f 72 79 29 29 29 29 0a 20 20 20 20 28 ectory)))). (
4100: 69 66 20 28 6e 6f 74 20 63 70 75 6c 6f 61 64 29 if (not cpuload)
4110: 20 20 28 62 65 67 69 6e 20 28 64 65 62 75 67 3a (begin (debug:
4120: 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 print 0 "WARNING
4130: 3a 20 43 50 55 4c 4f 41 44 20 6e 6f 74 20 66 6f : CPULOAD not fo
4140: 75 6e 64 2e 22 29 20 20 28 73 65 74 21 20 63 70 und.") (set! cp
4150: 75 6c 6f 61 64 20 22 6e 2f 61 22 29 29 29 0a 20 uload "n/a"))).
4160: 20 20 20 28 69 66 20 28 6e 6f 74 20 64 69 73 6b (if (not disk
4170: 66 72 65 65 29 20 28 62 65 67 69 6e 20 28 64 65 free) (begin (de
4180: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 bug:print 0 "WAR
4190: 4e 49 4e 47 3a 20 44 49 53 4b 46 52 45 45 20 6e NING: DISKFREE n
41a0: 6f 74 20 66 6f 75 6e 64 2e 22 29 20 28 73 65 74 ot found.") (set
41b0: 21 20 64 69 73 6b 66 72 65 65 20 22 6e 2f 61 22 ! diskfree "n/a"
41c0: 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 ))). (if (not
41d0: 20 69 74 65 6d 2d 70 61 74 68 29 28 62 65 67 69 item-path)(begi
41e0: 6e 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 n (debug:print 0
41f0: 20 22 57 41 52 4e 49 4e 47 3a 20 49 54 45 4d 50 "WARNING: ITEMP
4200: 41 54 48 20 6e 6f 74 20 73 65 74 2e 22 29 20 20 ATH not set.")
4210: 20 28 73 65 74 21 20 69 74 65 6d 2d 70 61 74 68 (set! item-path
4220: 20 22 22 29 29 29 0a 20 20 20 20 3b 3b 20 28 6c ""))). ;; (l
4230: 65 74 20 28 28 74 65 73 74 69 6e 66 6f 20 28 64 et ((testinfo (d
4240: 62 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 20 b:get-test-info
4250: 64 62 20 72 75 6e 2d 69 64 20 74 65 73 74 6e 61 db run-id testna
4260: 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 29 0a me item-path))).
4270: 20 20 20 20 3b 3b 20 20 20 28 69 66 20 28 61 6e ;; (if (an
4280: 64 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 28 d (not (equal? (
4290: 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 db:test-get-stat
42a0: 75 73 20 74 65 73 74 69 6e 66 6f 29 20 22 43 4f us testinfo) "CO
42b0: 4d 50 4c 45 54 45 44 22 29 29 0a 20 20 20 20 3b MPLETED")). ;
42c0: 3b 20 20 20 20 20 20 20 20 20 20 20 20 28 6e 6f ; (no
42d0: 74 20 28 65 71 75 61 6c 3f 20 28 64 62 3a 74 65 t (equal? (db:te
42e0: 73 74 2d 67 65 74 2d 73 74 61 74 75 73 20 74 65 st-get-status te
42f0: 73 74 69 6e 66 6f 29 20 22 4b 49 4c 4c 52 45 51 stinfo) "KILLREQ
4300: 22 29 29 0a 20 20 20 20 28 73 71 6c 69 74 65 33 ")). (sqlite3
4310: 3a 65 78 65 63 75 74 65 0a 20 20 20 20 20 64 62 :execute. db
4320: 0a 20 20 20 20 20 22 55 50 44 41 54 45 20 74 65 . "UPDATE te
4330: 73 74 73 20 53 45 54 20 63 70 75 6c 6f 61 64 3d sts SET cpuload=
4340: 3f 2c 64 69 73 6b 66 72 65 65 3d 3f 2c 72 75 6e ?,diskfree=?,run
4350: 5f 64 75 72 61 74 69 6f 6e 3d 3f 2c 73 74 61 74 _duration=?,stat
4360: 65 3d 27 52 55 4e 4e 49 4e 47 27 20 57 48 45 52 e='RUNNING' WHER
4370: 45 20 72 75 6e 5f 69 64 3d 3f 20 41 4e 44 20 74 E run_id=? AND t
4380: 65 73 74 6e 61 6d 65 3d 3f 20 41 4e 44 20 69 74 estname=? AND it
4390: 65 6d 5f 70 61 74 68 3d 3f 20 41 4e 44 20 73 74 em_path=? AND st
43a0: 61 74 65 20 4e 4f 54 20 49 4e 20 28 27 43 4f 4d ate NOT IN ('COM
43b0: 50 4c 45 54 45 44 27 2c 27 4b 49 4c 4c 52 45 51 PLETED','KILLREQ
43c0: 27 2c 27 4b 49 4c 4c 45 44 27 29 3b 22 0a 20 20 ','KILLED');".
43d0: 20 20 20 63 70 75 6c 6f 61 64 0a 20 20 20 20 20 cpuload.
43e0: 64 69 73 6b 66 72 65 65 0a 20 20 20 20 20 6d 69 diskfree. mi
43f0: 6e 75 74 65 73 0a 20 20 20 20 20 72 75 6e 2d 69 nutes. run-i
4400: 64 0a 20 20 20 20 20 74 65 73 74 6e 61 6d 65 0a d. testname.
4410: 20 20 20 20 20 69 74 65 6d 2d 70 61 74 68 29 29 item-path))
4420: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 74 2d )..(define (set-
4430: 6d 65 67 61 74 65 73 74 2d 65 6e 76 2d 76 61 72 megatest-env-var
4440: 73 20 64 62 20 72 75 6e 2d 69 64 29 0a 20 20 28 s db run-id). (
4450: 6c 65 74 20 28 28 6b 65 79 73 20 28 64 62 2d 67 let ((keys (db-g
4460: 65 74 2d 6b 65 79 73 20 64 62 29 29 29 0a 20 20 et-keys db))).
4470: 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d (for-each (lam
4480: 62 64 61 20 28 6b 65 79 29 0a 09 09 28 73 71 6c bda (key)...(sql
4490: 69 74 65 33 3a 66 6f 72 2d 65 61 63 68 2d 72 6f ite3:for-each-ro
44a0: 77 0a 09 09 20 28 6c 61 6d 62 64 61 20 28 76 61 w... (lambda (va
44b0: 6c 29 0a 09 09 20 20 20 28 64 65 62 75 67 3a 70 l)... (debug:p
44c0: 72 69 6e 74 20 32 20 22 73 65 74 65 6e 76 20 22 rint 2 "setenv "
44d0: 20 28 6b 65 79 3a 67 65 74 2d 66 69 65 6c 64 6e (key:get-fieldn
44e0: 61 6d 65 20 6b 65 79 29 20 22 20 22 20 76 61 6c ame key) " " val
44f0: 29 0a 09 09 20 20 20 28 73 65 74 65 6e 76 20 28 )... (setenv (
4500: 6b 65 79 3a 67 65 74 2d 66 69 65 6c 64 6e 61 6d key:get-fieldnam
4510: 65 20 6b 65 79 29 20 76 61 6c 29 29 0a 09 09 20 e key) val))...
4520: 64 62 20 0a 09 09 20 28 63 6f 6e 63 20 22 53 45 db ... (conc "SE
4530: 4c 45 43 54 20 22 20 28 6b 65 79 3a 67 65 74 2d LECT " (key:get-
4540: 66 69 65 6c 64 6e 61 6d 65 20 6b 65 79 29 20 22 fieldname key) "
4550: 20 46 52 4f 4d 20 72 75 6e 73 20 57 48 45 52 45 FROM runs WHERE
4560: 20 69 64 3d 3f 3b 22 29 0a 09 09 20 72 75 6e 2d id=?;")... run-
4570: 69 64 29 29 0a 09 20 20 20 20 20 20 6b 65 79 73 id)).. keys
4580: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 )))..(define (se
4590: 74 2d 69 74 65 6d 2d 65 6e 76 2d 76 61 72 73 20 t-item-env-vars
45a0: 69 74 65 6d 64 61 74 29 0a 20 20 28 66 6f 72 2d itemdat). (for-
45b0: 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 69 74 each (lambda (it
45c0: 65 6d 29 0a 09 20 20 20 20 20 20 28 64 65 62 75 em).. (debu
45d0: 67 3a 70 72 69 6e 74 20 32 20 22 73 65 74 65 6e g:print 2 "seten
45e0: 76 20 22 20 28 63 61 72 20 69 74 65 6d 29 20 22 v " (car item) "
45f0: 20 22 20 28 63 61 64 72 20 69 74 65 6d 29 29 0a " (cadr item)).
4600: 09 20 20 20 20 20 20 28 73 65 74 65 6e 76 20 28 . (setenv (
4610: 63 61 72 20 69 74 65 6d 29 20 28 63 61 64 72 20 car item) (cadr
4620: 69 74 65 6d 29 29 29 0a 09 20 20 20 20 69 74 65 item))).. ite
4630: 6d 64 61 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 mdat))..(define
4640: 28 67 65 74 2d 61 6c 6c 2d 6c 65 67 61 6c 2d 74 (get-all-legal-t
4650: 65 73 74 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 ests). (let* ((
4660: 74 65 73 74 73 20 20 28 67 6c 6f 62 20 28 63 6f tests (glob (co
4670: 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 74 nc *toppath* "/t
4680: 65 73 74 73 2f 2a 22 29 29 29 0a 09 20 28 72 65 ests/*"))).. (re
4690: 73 20 20 20 20 27 28 29 29 29 0a 20 20 20 20 28 s '())). (
46a0: 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 49 debug:print 4 "I
46b0: 4e 46 4f 3a 20 4c 6f 6f 6b 69 6e 67 20 61 74 20 NFO: Looking at
46c0: 74 65 73 74 73 20 22 20 28 73 74 72 69 6e 67 2d tests " (string-
46d0: 69 6e 74 65 72 73 70 65 72 73 65 20 74 65 73 74 intersperse test
46e0: 73 20 22 2c 22 29 29 0a 20 20 20 20 28 66 6f 72 s ",")). (for
46f0: 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 74 -each (lambda (t
4700: 65 73 74 70 61 74 68 29 0a 09 09 28 69 66 20 28 estpath)...(if (
4710: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 28 63 6f file-exists? (co
4720: 6e 63 20 74 65 73 74 70 61 74 68 20 22 2f 74 65 nc testpath "/te
4730: 73 74 63 6f 6e 66 69 67 22 29 29 0a 09 09 20 20 stconfig"))...
4740: 20 20 28 73 65 74 21 20 72 65 73 20 28 63 6f 6e (set! res (con
4750: 73 20 28 6c 61 73 74 20 28 73 74 72 69 6e 67 2d s (last (string-
4760: 73 70 6c 69 74 20 74 65 73 74 70 61 74 68 20 22 split testpath "
4770: 2f 22 29 29 20 72 65 73 29 29 29 29 0a 09 20 20 /")) res))))..
4780: 20 20 20 20 74 65 73 74 73 29 0a 20 20 20 20 72 tests). r
4790: 65 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 es))..(define (r
47a0: 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 uns:can-run-more
47b0: 2d 74 65 73 74 73 20 64 62 29 0a 20 20 28 6c 65 -tests db). (le
47c0: 74 20 28 28 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 t ((num-running
47d0: 28 64 62 3a 67 65 74 2d 63 6f 75 6e 74 2d 74 65 (db:get-count-te
47e0: 73 74 73 2d 72 75 6e 6e 69 6e 67 20 64 62 29 29 sts-running db))
47f0: 0a 09 28 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e ..(max-concurren
4800: 74 2d 6a 6f 62 73 20 28 63 6f 6e 66 69 67 2d 6c t-jobs (config-l
4810: 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 ookup *configdat
4820: 2a 20 22 73 65 74 75 70 22 20 22 6d 61 78 5f 63 * "setup" "max_c
4830: 6f 6e 63 75 72 72 65 6e 74 5f 6a 6f 62 73 22 29 oncurrent_jobs")
4840: 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 )). (debug:pr
4850: 69 6e 74 20 32 20 22 6d 61 78 2d 63 6f 6e 63 75 int 2 "max-concu
4860: 72 72 65 6e 74 2d 6a 6f 62 73 3a 20 22 20 6d 61 rrent-jobs: " ma
4870: 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 x-concurrent-job
4880: 73 20 22 2c 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 s ", num-running
4890: 3a 20 22 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 29 : " num-running)
48a0: 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 65 . (if (not (e
48b0: 71 3f 20 30 20 2a 67 6c 6f 62 61 6c 65 78 69 74 q? 0 *globalexit
48c0: 73 74 61 74 75 73 2a 29 29 0a 09 23 66 0a 09 28 status*))..#f..(
48d0: 69 66 20 28 6f 72 20 28 6e 6f 74 20 6d 61 78 2d if (or (not max-
48e0: 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 29 concurrent-jobs)
48f0: 0a 09 09 28 61 6e 64 20 6d 61 78 2d 63 6f 6e 63 ...(and max-conc
4900: 75 72 72 65 6e 74 2d 6a 6f 62 73 0a 09 09 20 20 urrent-jobs...
4910: 20 20 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 (string->numb
4920: 65 72 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e er max-concurren
4930: 74 2d 6a 6f 62 73 29 0a 09 09 20 20 20 20 20 28 t-jobs)... (
4940: 6e 6f 74 20 28 3e 3d 20 6e 75 6d 2d 72 75 6e 6e not (>= num-runn
4950: 69 6e 67 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d ing (string->num
4960: 62 65 72 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 ber max-concurre
4970: 6e 74 2d 6a 6f 62 73 29 29 29 29 29 0a 09 20 20 nt-jobs)))))..
4980: 20 20 23 74 0a 09 20 20 20 20 28 62 65 67 69 6e #t.. (begin
4990: 20 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 3a .. (debug:
49a0: 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 print 0 "WARNING
49b0: 3a 20 4d 61 78 20 72 75 6e 6e 69 6e 67 20 6a 6f : Max running jo
49c0: 62 73 20 65 78 63 65 65 64 65 64 2c 20 63 75 72 bs exceeded, cur
49d0: 72 65 6e 74 20 6e 75 6d 62 65 72 20 72 75 6e 6e rent number runn
49e0: 69 6e 67 3a 20 22 20 6e 75 6d 2d 72 75 6e 6e 69 ing: " num-runni
49f0: 6e 67 20 0a 09 09 09 20 20 20 22 2c 20 6d 61 78 ng .... ", max
4a00: 5f 63 6f 6e 63 75 72 72 65 6e 74 5f 6a 6f 62 73 _concurrent_jobs
4a10: 3a 20 22 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 : " max-concurre
4a20: 6e 74 2d 6a 6f 62 73 29 0a 09 20 20 20 20 20 20 nt-jobs)..
4a30: 23 66 29 29 29 29 29 0a 20 20 0a 28 64 65 66 69 #f))))). .(defi
4a40: 6e 65 20 28 72 75 6e 2d 74 65 73 74 73 20 64 62 ne (run-tests db
4a50: 20 74 65 73 74 2d 6e 61 6d 65 73 29 0a 20 20 28 test-names). (
4a60: 6c 65 74 2a 20 28 28 6b 65 79 73 20 20 20 20 20 let* ((keys
4a70: 20 20 20 28 64 62 2d 67 65 74 2d 6b 65 79 73 20 (db-get-keys
4a80: 64 62 29 29 0a 09 20 28 6b 65 79 76 61 6c 6c 73 db)).. (keyvalls
4a90: 74 20 20 20 28 6b 65 79 73 2d 3e 76 61 6c 6c 69 t (keys->valli
4aa0: 73 74 20 6b 65 79 73 20 23 74 29 29 0a 09 20 28 st keys #t)).. (
4ab0: 72 75 6e 2d 69 64 20 20 20 20 20 20 28 72 65 67 run-id (reg
4ac0: 69 73 74 65 72 2d 72 75 6e 20 64 62 20 6b 65 79 ister-run db key
4ad0: 73 29 29 20 20 3b 3b 20 20 74 65 73 74 2d 6e 61 s)) ;; test-na
4ae0: 6d 65 29 29 29 0a 09 20 28 64 65 66 65 72 72 65 me))).. (deferre
4af0: 64 20 20 20 20 27 28 29 29 29 20 3b 3b 20 64 65 d '())) ;; de
4b00: 6c 61 79 20 72 75 6e 6e 69 6e 67 20 74 68 65 73 lay running thes
4b10: 65 20 73 69 6e 63 65 20 74 68 65 79 20 68 61 76 e since they hav
4b20: 65 20 61 20 77 61 69 74 6f 6e 20 63 6c 61 75 73 e a waiton claus
4b30: 65 0a 20 20 20 20 3b 3b 20 6f 6e 20 74 68 65 20 e. ;; on the
4b40: 66 69 72 73 74 20 70 61 73 73 20 6f 72 20 63 61 first pass or ca
4b50: 6c 6c 20 74 6f 20 72 75 6e 2d 74 65 73 74 73 20 ll to run-tests
4b60: 73 65 74 20 46 41 49 4c 53 20 74 6f 20 4e 4f 54 set FAILS to NOT
4b70: 5f 53 54 41 52 54 45 44 20 69 66 0a 20 20 20 20 _STARTED if.
4b80: 3b 3b 20 2d 6b 65 65 70 67 6f 69 6e 67 20 69 73 ;; -keepgoing is
4b90: 20 73 70 65 63 69 66 69 65 64 0a 20 20 20 20 28 specified. (
4ba0: 69 66 20 28 61 6e 64 20 28 65 71 3f 20 2a 70 61 if (and (eq? *pa
4bb0: 73 73 6e 75 6d 2a 20 30 29 0a 09 20 20 20 20 20 ssnum* 0)..
4bc0: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
4bd0: 6b 65 65 70 67 6f 69 6e 67 22 29 29 0a 09 28 62 keepgoing"))..(b
4be0: 65 67 69 6e 0a 09 20 20 3b 3b 20 68 61 76 65 20 egin.. ;; have
4bf0: 74 6f 20 64 65 6c 65 74 65 20 74 65 73 74 20 72 to delete test r
4c00: 65 63 6f 72 64 73 20 77 68 65 72 65 20 4e 4f 54 ecords where NOT
4c10: 5f 53 54 41 52 54 45 44 20 73 69 6e 63 65 20 74 _STARTED since t
4c20: 68 65 79 20 63 61 6e 20 63 61 75 73 65 20 2d 6b hey can cause -k
4c30: 65 65 70 67 6f 69 6e 67 20 74 6f 20 0a 09 20 20 eepgoing to ..
4c40: 3b 3b 20 67 65 74 20 73 74 75 63 6b 20 64 75 65 ;; get stuck due
4c50: 20 74 6f 20 62 65 63 6f 6d 69 6e 67 20 69 6e 61 to becoming ina
4c60: 63 63 65 73 73 69 62 6c 65 20 66 72 6f 6d 20 61 ccessible from a
4c70: 20 66 61 69 6c 65 64 20 74 65 73 74 2e 20 49 2e failed test. I.
4c80: 65 2e 20 69 66 20 74 65 73 74 20 42 20 64 65 70 e. if test B dep
4c90: 65 6e 64 73 20 0a 09 20 20 3b 3b 20 6f 6e 20 74 ends .. ;; on t
4ca0: 65 73 74 20 41 20 62 75 74 20 74 65 73 74 20 42 est A but test B
4cb0: 20 72 65 61 63 68 65 64 20 74 68 65 20 70 6f 69 reached the poi
4cc0: 6e 74 20 6f 6e 20 62 65 69 6e 67 20 72 65 67 69 nt on being regi
4cd0: 73 74 65 72 65 64 20 61 73 20 4e 4f 54 5f 53 54 stered as NOT_ST
4ce0: 41 52 54 45 44 20 61 6e 64 20 74 65 73 74 0a 09 ARTED and test..
4cf0: 20 20 3b 3b 20 41 20 66 61 69 6c 65 64 20 66 6f ;; A failed fo
4d00: 72 20 73 6f 6d 65 20 72 65 61 73 6f 6e 20 74 68 r some reason th
4d10: 65 6e 20 6f 6e 20 72 65 2d 72 75 6e 20 75 73 69 en on re-run usi
4d20: 6e 67 20 2d 6b 65 65 70 67 6f 69 6e 67 20 74 68 ng -keepgoing th
4d30: 65 20 72 75 6e 20 63 61 6e 20 6e 65 76 65 72 20 e run can never
4d40: 63 6f 6d 70 6c 65 74 65 2e 0a 09 20 20 28 64 62 complete... (db
4d50: 3a 64 65 6c 65 74 65 2d 74 65 73 74 73 2d 69 6e :delete-tests-in
4d60: 2d 73 74 61 74 65 20 64 62 20 72 75 6e 2d 69 64 -state db run-id
4d70: 20 22 4e 4f 54 5f 53 54 41 52 54 45 44 22 29 0a "NOT_STARTED").
4d80: 09 20 20 28 64 62 3a 73 65 74 2d 74 65 73 74 73 . (db:set-tests
4d90: 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 64 62 -state-status db
4da0: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
4db0: 65 73 20 23 66 20 22 46 41 49 4c 22 20 22 4e 4f es #f "FAIL" "NO
4dc0: 54 5f 53 54 41 52 54 45 44 22 20 22 46 41 49 4c T_STARTED" "FAIL
4dd0: 22 29 29 29 0a 20 20 20 20 28 73 65 74 21 20 2a "))). (set! *
4de0: 70 61 73 73 6e 75 6d 2a 20 28 2b 20 2a 70 61 73 passnum* (+ *pas
4df0: 73 6e 75 6d 2a 20 31 29 29 0a 20 20 20 20 28 6c snum* 1)). (l
4e00: 65 74 20 6c 6f 6f 70 20 28 28 6e 75 6d 74 69 6d et loop ((numtim
4e10: 65 73 20 30 29 29 0a 20 20 20 20 20 20 28 66 6f es 0)). (fo
4e20: 72 2d 65 61 63 68 20 0a 20 20 20 20 20 20 20 28 r-each . (
4e30: 6c 61 6d 62 64 61 20 28 74 65 73 74 2d 6e 61 6d lambda (test-nam
4e40: 65 29 0a 09 20 28 69 66 20 28 72 75 6e 73 3a 63 e).. (if (runs:c
4e50: 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 an-run-more-test
4e60: 73 20 64 62 29 0a 09 20 20 20 20 20 28 72 75 6e s db).. (run
4e70: 2d 6f 6e 65 2d 74 65 73 74 20 64 62 20 72 75 6e -one-test db run
4e80: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 6b 65 -id test-name ke
4e90: 79 76 61 6c 6c 73 74 29 0a 09 20 20 20 20 20 3b yvallst).. ;
4ea0: 3b 20 61 64 64 20 73 6f 6d 65 20 64 65 6c 61 79 ; add some delay
4eb0: 20 0a 09 20 20 20 20 20 3b 28 73 6c 65 65 70 20 .. ;(sleep
4ec0: 32 29 0a 09 20 20 20 20 20 29 29 0a 20 20 20 20 2).. )).
4ed0: 20 20 20 74 65 73 74 2d 6e 61 6d 65 73 29 0a 20 test-names).
4ee0: 20 20 20 20 20 3b 3b 20 28 72 75 6e 2d 77 61 69 ;; (run-wai
4ef0: 74 69 6e 67 2d 74 65 73 74 73 20 64 62 29 0a 20 ting-tests db).
4f00: 20 20 20 20 20 28 69 66 20 28 61 72 67 73 3a 67 (if (args:g
4f10: 65 74 2d 61 72 67 20 22 2d 6b 65 65 70 67 6f 69 et-arg "-keepgoi
4f20: 6e 67 22 29 0a 09 20 20 28 6c 65 74 20 28 28 65 ng").. (let ((e
4f30: 73 74 72 65 6d 20 28 64 62 3a 65 73 74 69 6d 61 strem (db:estima
4f40: 74 65 64 2d 74 65 73 74 73 2d 72 65 6d 61 69 6e ted-tests-remain
4f50: 69 6e 67 20 64 62 20 72 75 6e 2d 69 64 29 29 29 ing db run-id)))
4f60: 0a 09 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 .. (if (and (
4f70: 3e 20 65 73 74 72 65 6d 20 30 29 0a 09 09 20 20 > estrem 0)...
4f80: 20 20 20 28 65 71 3f 20 2a 67 6c 6f 62 61 6c 65 (eq? *globale
4f90: 78 69 74 73 74 61 74 75 73 2a 20 30 29 29 0a 09 xitstatus* 0))..
4fa0: 09 28 62 65 67 69 6e 0a 09 09 20 20 28 64 65 62 .(begin... (deb
4fb0: 75 67 3a 70 72 69 6e 74 20 31 20 22 4b 65 65 70 ug:print 1 "Keep
4fc0: 20 67 6f 69 6e 67 2c 20 65 73 74 69 6d 61 74 65 going, estimate
4fd0: 64 20 22 20 65 73 74 72 65 6d 20 22 20 74 65 73 d " estrem " tes
4fe0: 74 73 20 72 65 6d 61 69 6e 69 6e 67 20 74 6f 20 ts remaining to
4ff0: 72 75 6e 2c 20 77 69 6c 6c 20 63 6f 6e 74 69 6e run, will contin
5000: 75 65 20 69 6e 20 33 20 73 65 63 6f 6e 64 73 20 ue in 3 seconds
5010: 2e 2e 2e 22 29 0a 09 09 20 20 28 73 6c 65 65 70 ...")... (sleep
5020: 20 33 29 0a 09 09 20 20 28 72 75 6e 2d 77 61 69 3)... (run-wai
5030: 74 69 6e 67 2d 74 65 73 74 73 20 64 62 29 0a 09 ting-tests db)..
5040: 09 20 20 28 6c 6f 6f 70 20 28 2b 20 6e 75 6d 74 . (loop (+ numt
5050: 69 6d 65 73 20 31 29 29 29 29 29 29 29 29 29 0a imes 1))))))))).
5060: 09 20 20 20 0a 3b 3b 20 56 45 52 59 20 49 4e 45 . .;; VERY INE
5070: 46 46 49 43 49 45 4e 54 21 20 4d 6f 76 65 20 73 FFICIENT! Move s
5080: 74 75 66 66 20 74 68 61 74 20 73 68 6f 75 6c 64 tuff that should
5090: 20 62 65 20 64 6f 6e 65 20 6f 6e 63 65 20 75 70 be done once up
50a0: 20 74 6f 20 63 61 6c 6c 69 6e 67 20 70 72 6f 63 to calling proc
50b0: 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 2d 6f 6e .(define (run-on
50c0: 65 2d 74 65 73 74 20 64 62 20 72 75 6e 2d 69 64 e-test db run-id
50d0: 20 74 65 73 74 2d 6e 61 6d 65 20 6b 65 79 76 61 test-name keyva
50e0: 6c 6c 73 74 29 0a 20 20 28 64 65 62 75 67 3a 70 llst). (debug:p
50f0: 72 69 6e 74 20 31 20 22 4c 61 75 6e 63 68 69 6e rint 1 "Launchin
5100: 67 20 74 65 73 74 20 22 20 74 65 73 74 2d 6e 61 g test " test-na
5110: 6d 65 29 0a 20 20 3b 3b 20 41 6c 6c 20 74 68 65 me). ;; All the
5120: 73 65 20 76 61 72 73 20 6d 69 67 68 74 20 62 65 se vars might be
5130: 20 72 65 66 65 72 65 6e 63 65 64 20 62 79 20 74 referenced by t
5140: 68 65 20 74 65 73 74 63 6f 6e 66 69 67 20 66 69 he testconfig fi
5150: 6c 65 20 72 65 61 64 65 72 0a 20 20 28 73 65 74 le reader. (set
5160: 65 6e 76 20 22 4d 54 5f 54 45 53 54 5f 4e 41 4d env "MT_TEST_NAM
5170: 45 22 20 74 65 73 74 2d 6e 61 6d 65 29 20 3b 3b E" test-name) ;;
5180: 20 0a 20 20 28 73 65 74 65 6e 76 20 22 4d 54 5f . (setenv "MT_
5190: 52 55 4e 4e 41 4d 45 22 20 20 20 28 61 72 67 73 RUNNAME" (args
51a0: 3a 67 65 74 2d 61 72 67 20 22 3a 72 75 6e 6e 61 :get-arg ":runna
51b0: 6d 65 22 29 29 0a 20 20 28 73 65 74 2d 6d 65 67 me")). (set-meg
51c0: 61 74 65 73 74 2d 65 6e 76 2d 76 61 72 73 20 64 atest-env-vars d
51d0: 62 20 72 75 6e 2d 69 64 29 20 3b 3b 20 74 68 65 b run-id) ;; the
51e0: 73 65 20 6d 61 79 20 62 65 20 6e 65 65 64 65 64 se may be needed
51f0: 20 62 79 20 74 68 65 20 6c 61 75 6e 63 68 69 6e by the launchin
5200: 67 20 70 72 6f 63 65 73 73 0a 20 20 28 63 68 61 g process. (cha
5210: 6e 67 65 2d 64 69 72 65 63 74 6f 72 79 20 2a 74 nge-directory *t
5220: 6f 70 70 61 74 68 2a 29 0a 20 20 28 6c 65 74 2a oppath*). (let*
5230: 20 28 28 74 65 73 74 2d 70 61 74 68 20 20 20 20 ((test-path
5240: 28 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 (conc *toppath*
5250: 22 2f 74 65 73 74 73 2f 22 20 74 65 73 74 2d 6e "/tests/" test-n
5260: 61 6d 65 29 29 0a 09 20 28 74 65 73 74 2d 63 6f ame)).. (test-co
5270: 6e 66 69 67 66 20 28 63 6f 6e 63 20 74 65 73 74 nfigf (conc test
5280: 2d 70 61 74 68 20 22 2f 74 65 73 74 63 6f 6e 66 -path "/testconf
5290: 69 67 22 29 29 0a 09 20 28 74 65 73 74 65 78 69 ig")).. (testexi
52a0: 73 74 73 20 20 20 28 61 6e 64 20 28 66 69 6c 65 sts (and (file
52b0: 2d 65 78 69 73 74 73 3f 20 74 65 73 74 2d 63 6f -exists? test-co
52c0: 6e 66 69 67 66 29 28 66 69 6c 65 2d 72 65 61 64 nfigf)(file-read
52d0: 2d 61 63 63 65 73 73 3f 20 74 65 73 74 2d 63 6f -access? test-co
52e0: 6e 66 69 67 66 29 29 29 0a 09 20 28 74 65 73 74 nfigf))).. (test
52f0: 2d 63 6f 6e 66 20 20 20 20 28 69 66 20 74 65 73 -conf (if tes
5300: 74 65 78 69 73 74 73 20 28 72 65 61 64 2d 63 6f texists (read-co
5310: 6e 66 69 67 20 74 65 73 74 2d 63 6f 6e 66 69 67 nfig test-config
5320: 66 20 23 66 20 23 74 29 20 28 6d 61 6b 65 2d 68 f #f #t) (make-h
5330: 61 73 68 2d 74 61 62 6c 65 29 29 29 0a 09 20 28 ash-table))).. (
5340: 77 61 69 74 6f 6e 20 20 20 20 20 20 20 28 6c 65 waiton (le
5350: 74 20 28 28 77 20 28 63 6f 6e 66 69 67 2d 6c 6f t ((w (config-lo
5360: 6f 6b 75 70 20 74 65 73 74 2d 63 6f 6e 66 20 22 okup test-conf "
5370: 72 65 71 75 69 72 65 6d 65 6e 74 73 22 20 22 77 requirements" "w
5380: 61 69 74 6f 6e 22 29 29 29 0a 09 09 09 20 28 69 aiton"))).... (i
5390: 66 20 28 73 74 72 69 6e 67 3f 20 77 29 28 73 74 f (string? w)(st
53a0: 72 69 6e 67 2d 73 70 6c 69 74 20 77 29 27 28 29 ring-split w)'()
53b0: 29 29 29 0a 09 20 28 74 61 67 73 20 20 20 20 20 ))).. (tags
53c0: 20 20 20 20 28 6c 65 74 20 28 28 74 20 28 63 6f (let ((t (co
53d0: 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 74 65 73 74 nfig-lookup test
53e0: 2d 63 6f 6e 66 20 22 73 65 74 75 70 22 20 22 74 -conf "setup" "t
53f0: 61 67 73 22 29 29 29 0a 09 09 09 20 3b 3b 20 77 ags"))).... ;; w
5400: 65 20 77 61 6e 74 20 6f 75 72 20 74 61 67 73 20 e want our tags
5410: 74 6f 20 62 65 20 73 65 70 61 72 61 74 65 64 20 to be separated
5420: 62 79 20 63 6f 6d 6d 61 73 20 61 6e 64 20 66 75 by commas and fu
5430: 6c 6c 79 20 64 65 6c 69 6d 69 74 65 64 20 62 79 lly delimited by
5440: 20 63 6f 6d 6d 61 73 0a 09 09 09 20 3b 3b 20 73 commas.... ;; s
5450: 6f 20 74 68 61 74 20 71 75 65 72 69 65 73 20 77 o that queries w
5460: 69 74 68 20 22 6c 69 6b 65 22 20 63 61 6e 20 74 ith "like" can t
5470: 69 65 20 74 6f 20 74 68 65 20 63 6f 6d 6d 61 73 ie to the commas
5480: 20 61 74 20 65 69 74 68 65 72 20 65 6e 64 20 6f at either end o
5490: 66 20 65 61 63 68 20 74 61 67 0a 09 09 09 20 3b f each tag.... ;
54a0: 3b 20 77 68 69 6c 65 20 61 6c 73 6f 20 61 6c 6c ; while also all
54b0: 6f 77 69 6e 67 20 74 68 65 20 65 6e 64 20 75 73 owing the end us
54c0: 65 72 20 74 6f 20 66 72 65 65 6c 79 20 75 73 65 er to freely use
54d0: 20 73 70 61 63 65 73 20 61 6e 64 20 63 6f 6d 6d spaces and comm
54e0: 61 73 20 74 6f 20 73 65 70 61 72 61 74 65 20 74 as to separate t
54f0: 61 67 73 0a 09 09 09 20 28 69 66 20 28 73 74 72 ags.... (if (str
5500: 69 6e 67 3f 20 74 29 28 73 74 72 69 6e 67 2d 73 ing? t)(string-s
5510: 75 62 73 74 69 74 75 74 65 20 28 72 65 67 65 78 ubstitute (regex
5520: 70 20 22 5b 2c 5c 5c 73 5d 2b 22 29 20 22 2c 22 p "[,\\s]+") ","
5530: 20 28 63 6f 6e 63 20 22 2c 22 20 74 20 22 2c 22 (conc "," t ","
5540: 29 20 23 74 29 0a 09 09 09 20 20 20 20 20 27 28 ) #t).... '(
5550: 29 29 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e ))))). (if (n
5560: 6f 74 20 74 65 73 74 65 78 69 73 74 73 29 0a 09 ot testexists)..
5570: 28 62 65 67 69 6e 0a 09 20 20 28 64 65 62 75 67 (begin.. (debug
5580: 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a :print 0 "ERROR:
5590: 20 43 61 6e 27 74 20 66 69 6e 64 20 63 6f 6e 66 Can't find conf
55a0: 69 67 20 66 69 6c 65 20 22 20 74 65 73 74 2d 63 ig file " test-c
55b0: 6f 6e 66 69 67 66 29 0a 09 20 20 28 65 78 69 74 onfigf).. (exit
55c0: 20 32 29 29 0a 09 3b 3b 20 70 75 74 20 74 6f 70 2))..;; put top
55d0: 20 76 61 72 73 20 69 6e 74 6f 20 63 6f 6e 76 65 vars into conve
55e0: 6e 69 65 6e 74 20 76 61 72 69 61 62 6c 65 73 20 nient variables
55f0: 61 6e 64 20 6f 70 65 6e 20 74 68 65 20 64 62 0a and open the db.
5600: 09 28 6c 65 74 2a 20 28 3b 3b 20 64 62 20 69 73 .(let* (;; db is
5610: 20 61 6c 77 61 79 73 20 61 74 20 2a 74 6f 70 70 always at *topp
5620: 61 74 68 2a 2f 64 62 2f 6d 65 67 61 74 65 73 74 ath*/db/megatest
5630: 2e 64 62 0a 09 20 20 20 20 20 20 20 28 69 74 65 .db.. (ite
5640: 6d 73 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 ms (hash-t
5650: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
5660: 20 74 65 73 74 2d 63 6f 6e 66 20 22 69 74 65 6d test-conf "item
5670: 73 22 20 27 28 29 29 29 0a 09 20 20 20 20 20 20 s" '()))..
5680: 20 28 69 74 65 6d 73 74 61 62 6c 65 20 20 28 68 (itemstable (h
5690: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
56a0: 66 61 75 6c 74 20 74 65 73 74 2d 63 6f 6e 66 20 fault test-conf
56b0: 22 69 74 65 6d 73 74 61 62 6c 65 22 20 27 28 29 "itemstable" '()
56c0: 29 29 0a 09 20 20 20 20 20 20 20 28 61 6c 6c 69 )).. (alli
56d0: 74 65 6d 73 20 20 20 20 28 69 66 20 28 6f 72 20 tems (if (or
56e0: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 69 74 65 6d (not (null? item
56f0: 73 29 29 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 69 s))(not (null? i
5700: 74 65 6d 73 74 61 62 6c 65 29 29 29 0a 09 09 09 temstable)))....
5710: 09 28 61 70 70 65 6e 64 20 28 69 74 65 6d 2d 61 .(append (item-a
5720: 73 73 6f 63 2d 3e 69 74 65 6d 2d 6c 69 73 74 20 ssoc->item-list
5730: 69 74 65 6d 73 29 0a 09 09 09 09 09 28 69 74 65 items)......(ite
5740: 6d 2d 74 61 62 6c 65 2d 3e 69 74 65 6d 2d 6c 69 m-table->item-li
5750: 73 74 20 69 74 65 6d 73 74 61 62 6c 65 29 29 0a st itemstable)).
5760: 09 09 09 09 27 28 28 29 29 29 29 20 3b 3b 20 61 ....'(()))) ;; a
5770: 20 6c 69 73 74 20 77 69 74 68 20 6f 6e 65 20 6e list with one n
5780: 75 6c 6c 20 6c 69 73 74 20 69 73 20 61 20 74 65 ull list is a te
5790: 73 74 20 77 69 74 68 20 6e 6f 20 69 74 65 6d 73 st with no items
57a0: 0a 09 20 20 20 20 20 20 20 28 72 75 6e 63 6f 6e .. (runcon
57b0: 66 69 67 66 20 20 28 63 6f 6e 63 20 20 2a 74 6f figf (conc *to
57c0: 70 70 61 74 68 2a 20 22 2f 72 75 6e 63 6f 6e 66 ppath* "/runconf
57d0: 69 67 73 2e 63 6f 6e 66 69 67 22 29 29 29 0a 09 igs.config")))..
57e0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 (debug:print 1
57f0: 20 22 69 74 65 6d 73 3a 20 22 29 0a 09 20 20 28 "items: ").. (
5800: 69 66 20 28 3e 3d 20 2a 76 65 72 62 6f 73 69 74 if (>= *verbosit
5810: 79 2a 20 31 29 28 70 70 20 61 6c 6c 69 74 65 6d y* 1)(pp allitem
5820: 73 29 29 0a 09 20 20 28 69 66 20 28 3e 3d 20 2a s)).. (if (>= *
5830: 76 65 72 62 6f 73 69 74 79 2a 20 35 29 0a 09 20 verbosity* 5)..
5840: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 28 70 (begin...(p
5850: 72 69 6e 74 20 22 69 74 65 6d 73 3a 20 22 29 28 rint "items: ")(
5860: 70 70 20 28 69 74 65 6d 2d 61 73 73 6f 63 2d 3e pp (item-assoc->
5870: 69 74 65 6d 2d 6c 69 73 74 20 69 74 65 6d 73 29 item-list items)
5880: 29 0a 09 09 28 70 72 69 6e 74 20 22 69 74 65 73 )...(print "ites
5890: 74 61 62 6c 65 3a 20 22 29 28 70 70 20 28 69 74 table: ")(pp (it
58a0: 65 6d 2d 74 61 62 6c 65 2d 3e 69 74 65 6d 2d 6c em-table->item-l
58b0: 69 73 74 20 69 74 65 6d 73 74 61 62 6c 65 29 29 ist itemstable))
58c0: 29 29 0a 09 20 20 28 69 66 20 28 61 72 67 73 3a )).. (if (args:
58d0: 67 65 74 2d 61 72 67 20 22 2d 6d 22 29 0a 09 20 get-arg "-m")..
58e0: 20 20 20 20 20 28 64 62 3a 73 65 74 2d 63 6f 6d (db:set-com
58f0: 6d 65 6e 74 2d 66 6f 72 2d 72 75 6e 20 64 62 20 ment-for-run db
5900: 72 75 6e 2d 69 64 20 28 61 72 67 73 3a 67 65 74 run-id (args:get
5910: 2d 61 72 67 20 22 2d 6d 22 29 29 29 0a 0a 09 20 -arg "-m")))...
5920: 20 3b 3b 20 48 65 72 65 20 69 73 20 77 68 65 72 ;; Here is wher
5930: 65 20 74 68 65 20 74 65 73 74 5f 6d 65 74 61 20 e the test_meta
5940: 74 61 62 6c 65 20 69 73 20 62 65 73 74 20 75 70 table is best up
5950: 64 61 74 65 64 0a 09 20 20 28 72 75 6e 73 3a 75 dated.. (runs:u
5960: 70 64 61 74 65 2d 74 65 73 74 5f 6d 65 74 61 20 pdate-test_meta
5970: 64 62 20 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 db test-name tes
5980: 74 2d 63 6f 6e 66 29 0a 0a 09 20 20 3b 3b 20 62 t-conf)... ;; b
5990: 72 61 69 6e 64 65 61 64 20 77 6f 72 6b 2d 61 72 raindead work-ar
59a0: 6f 75 6e 64 20 66 6f 72 20 70 6f 6f 72 6c 79 20 ound for poorly
59b0: 73 70 65 63 69 66 69 65 64 20 61 6c 6c 69 74 65 specified allite
59c0: 6d 73 20 6c 69 73 74 20 42 55 47 21 21 21 20 46 ms list BUG!!! F
59d0: 49 58 4d 45 0a 09 20 20 28 69 66 20 28 6e 75 6c IXME.. (if (nul
59e0: 6c 3f 20 61 6c 6c 69 74 65 6d 73 29 28 73 65 74 l? allitems)(set
59f0: 21 20 61 6c 6c 69 74 65 6d 73 20 27 28 28 29 29 ! allitems '(())
5a00: 29 29 0a 09 20 20 28 6c 65 74 20 6c 6f 6f 70 20 )).. (let loop
5a10: 28 28 69 74 65 6d 64 61 74 20 28 63 61 72 20 61 ((itemdat (car a
5a20: 6c 6c 69 74 65 6d 73 29 29 0a 09 09 20 20 20 20 llitems))...
5a30: 20 28 74 61 6c 20 20 20 20 20 28 63 64 72 20 61 (tal (cdr a
5a40: 6c 6c 69 74 65 6d 73 29 29 29 0a 09 20 20 20 20 llitems)))..
5a50: 3b 3b 20 28 6c 61 6d 62 64 61 20 28 69 74 65 6d ;; (lambda (item
5a60: 64 61 74 29 20 3b 3b 3b 20 28 28 72 69 70 65 6e dat) ;;; ((ripen
5a70: 65 73 73 20 22 6f 76 65 72 72 69 70 65 22 29 20 ess "overripe")
5a80: 28 74 65 6d 70 65 72 61 74 75 72 65 20 22 63 6f (temperature "co
5a90: 6f 6c 22 29 20 28 73 65 61 73 6f 6e 20 22 73 75 ol") (season "su
5aa0: 6d 6d 65 72 22 29 29 0a 09 20 20 20 20 3b 3b 20 mmer")).. ;;
5ab0: 48 61 6e 64 6c 65 20 6c 69 73 74 73 20 6f 66 20 Handle lists of
5ac0: 69 74 65 6d 73 0a 09 20 20 20 20 28 6c 65 74 2a items.. (let*
5ad0: 20 28 28 69 74 65 6d 2d 70 61 74 68 20 20 20 20 ((item-path
5ae0: 20 28 69 74 65 6d 2d 6c 69 73 74 2d 3e 70 61 74 (item-list->pat
5af0: 68 20 69 74 65 6d 64 61 74 29 29 20 3b 3b 20 28 h itemdat)) ;; (
5b00: 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
5b10: 73 65 20 28 6d 61 70 20 63 61 64 72 20 69 74 65 se (map cadr ite
5b20: 6d 64 61 74 29 20 22 2f 22 29 29 0a 09 09 20 20 mdat) "/"))...
5b30: 20 28 6e 65 77 2d 74 65 73 74 2d 70 61 74 68 20 (new-test-path
5b40: 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 (string-interspe
5b50: 72 73 65 20 28 63 6f 6e 73 20 74 65 73 74 2d 70 rse (cons test-p
5b60: 61 74 68 20 28 6d 61 70 20 63 61 64 72 20 69 74 ath (map cadr it
5b70: 65 6d 64 61 74 29 29 20 22 2f 22 29 29 0a 09 09 emdat)) "/"))...
5b80: 20 20 20 28 6e 65 77 2d 74 65 73 74 2d 6e 61 6d (new-test-nam
5b90: 65 20 28 69 66 20 28 65 71 75 61 6c 3f 20 69 74 e (if (equal? it
5ba0: 65 6d 2d 70 61 74 68 20 22 22 29 20 74 65 73 74 em-path "") test
5bb0: 2d 6e 61 6d 65 20 28 63 6f 6e 63 20 74 65 73 74 -name (conc test
5bc0: 2d 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 -name "/" item-p
5bd0: 61 74 68 29 29 29 20 3b 3b 20 6a 75 73 74 20 6e ath))) ;; just n
5be0: 65 65 64 20 69 74 20 74 6f 20 62 65 20 75 6e 69 eed it to be uni
5bf0: 71 75 65 0a 09 09 20 20 20 28 74 65 73 74 64 61 que... (testda
5c00: 74 20 20 20 23 66 29 0a 09 09 20 20 20 28 6e 75 t #f)... (nu
5c10: 6d 2d 72 75 6e 6e 69 6e 67 20 28 64 62 3a 67 65 m-running (db:ge
5c20: 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d 72 75 t-count-tests-ru
5c30: 6e 6e 69 6e 67 20 64 62 29 29 0a 09 09 20 20 20 nning db))...
5c40: 28 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d (max-concurrent-
5c50: 6a 6f 62 73 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f jobs (config-loo
5c60: 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 kup *configdat*
5c70: 22 73 65 74 75 70 22 20 22 6d 61 78 5f 63 6f 6e "setup" "max_con
5c80: 63 75 72 72 65 6e 74 5f 6a 6f 62 73 22 29 29 0a current_jobs")).
5c90: 09 09 20 20 20 28 70 61 72 65 6e 74 2d 74 65 73 .. (parent-tes
5ca0: 74 20 28 61 6e 64 20 28 6e 6f 74 20 28 6e 75 6c t (and (not (nul
5cb0: 6c 3f 20 69 74 65 6d 73 29 29 28 65 71 75 61 6c l? items))(equal
5cc0: 3f 20 69 74 65 6d 2d 70 61 74 68 20 22 22 29 29 ? item-path ""))
5cd0: 29 0a 09 09 20 20 20 28 73 69 6e 67 6c 65 2d 74 )... (single-t
5ce0: 65 73 74 20 28 61 6e 64 20 28 6e 75 6c 6c 3f 20 est (and (null?
5cf0: 69 74 65 6d 73 29 20 28 65 71 75 61 6c 3f 20 69 items) (equal? i
5d00: 74 65 6d 2d 70 61 74 68 20 22 22 29 29 29 0a 09 tem-path "")))..
5d10: 09 20 20 20 28 69 74 65 6d 2d 74 65 73 74 20 20 . (item-test
5d20: 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 69 74 (not (equal? it
5d30: 65 6d 2d 70 61 74 68 20 22 22 29 29 29 29 0a 09 em-path ""))))..
5d40: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
5d50: 6e 74 20 33 20 22 6d 61 78 2d 63 6f 6e 63 75 72 nt 3 "max-concur
5d60: 72 65 6e 74 2d 6a 6f 62 73 3a 20 22 20 6d 61 78 rent-jobs: " max
5d70: 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 -concurrent-jobs
5d80: 20 22 2c 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 3a ", num-running:
5d90: 20 22 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 29 0a " num-running).
5da0: 09 20 20 20 20 20 20 28 69 66 20 28 72 75 6e 73 . (if (runs
5db0: 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 :can-run-more-te
5dc0: 73 74 73 20 64 62 29 0a 09 09 20 20 28 62 65 67 sts db)... (beg
5dd0: 69 6e 0a 09 09 20 20 20 20 28 6c 65 74 20 6c 6f in... (let lo
5de0: 6f 70 32 20 28 28 74 73 20 28 64 62 3a 67 65 74 op2 ((ts (db:get
5df0: 2d 74 65 73 74 2d 69 6e 66 6f 20 64 62 20 72 75 -test-info db ru
5e00: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 n-id test-name i
5e10: 74 65 6d 2d 70 61 74 68 29 29 20 3b 3b 20 23 66 tem-path)) ;; #f
5e20: 29 0a 09 09 09 09 28 63 74 20 30 29 29 0a 09 09 ).....(ct 0))...
5e30: 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 (if (and (
5e40: 6e 6f 74 20 74 73 29 0a 09 09 09 20 20 20 20 20 not ts)....
5e50: 20 20 28 3c 20 63 74 20 31 30 29 29 0a 09 09 09 (< ct 10))....
5e60: 20 20 28 62 65 67 69 6e 0a 09 09 09 20 20 20 20 (begin....
5e70: 28 72 65 67 69 73 74 65 72 2d 74 65 73 74 20 64 (register-test d
5e80: 62 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 b run-id test-na
5e90: 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 0a 09 09 me item-path)...
5ea0: 09 20 20 20 20 28 64 62 3a 74 65 73 74 2d 73 65 . (db:test-se
5eb0: 74 2d 63 6f 6d 6d 65 6e 74 20 64 62 20 72 75 6e t-comment db run
5ec0: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 -id test-name it
5ed0: 65 6d 2d 70 61 74 68 20 22 22 29 0a 09 09 09 20 em-path "")....
5ee0: 20 20 20 28 6c 6f 6f 70 32 20 28 64 62 3a 67 65 (loop2 (db:ge
5ef0: 74 2d 74 65 73 74 2d 69 6e 66 6f 20 64 62 20 72 t-test-info db r
5f00: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 un-id test-name
5f10: 69 74 65 6d 2d 70 61 74 68 29 0a 09 09 09 09 20 item-path).....
5f20: 20 20 28 2b 20 63 74 20 31 29 29 29 0a 09 09 09 (+ ct 1)))....
5f30: 20 20 28 69 66 20 74 73 0a 09 09 09 20 20 20 20 (if ts....
5f40: 20 20 28 73 65 74 21 20 74 65 73 74 64 61 74 20 (set! testdat
5f50: 74 73 29 0a 09 09 09 20 20 20 20 20 20 28 62 65 ts).... (be
5f60: 67 69 6e 0a 09 09 09 09 28 64 65 62 75 67 3a 70 gin.....(debug:p
5f70: 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a rint 0 "WARNING:
5f80: 20 43 6f 75 6c 64 6e 27 74 20 72 65 67 69 73 74 Couldn't regist
5f90: 65 72 20 74 65 73 74 20 22 20 74 65 73 74 2d 6e er test " test-n
5fa0: 61 6d 65 20 22 20 77 69 74 68 20 69 74 65 6d 20 ame " with item
5fb0: 70 61 74 68 20 22 20 69 74 65 6d 2d 70 61 74 68 path " item-path
5fc0: 20 22 2c 20 73 6b 69 70 70 69 6e 67 22 29 0a 09 ", skipping")..
5fd0: 09 09 09 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c ...(if (not (nul
5fe0: 6c 3f 20 74 61 6c 29 29 0a 09 09 09 09 20 20 20 l? tal)).....
5ff0: 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 (loop (car tal)
6000: 28 63 64 72 20 74 61 6c 29 29 29 29 29 29 29 0a (cdr tal))))))).
6010: 09 09 20 20 20 20 28 63 68 61 6e 67 65 2d 64 69 .. (change-di
6020: 72 65 63 74 6f 72 79 20 74 65 73 74 2d 70 61 74 rectory test-pat
6030: 68 29 0a 09 09 20 20 20 20 3b 3b 20 74 68 69 73 h)... ;; this
6040: 20 62 6c 6f 63 6b 20 69 73 20 68 65 72 65 20 6f block is here o
6050: 6e 6c 79 20 74 6f 20 69 6e 66 6f 72 6d 20 74 68 nly to inform th
6060: 65 20 75 73 65 72 20 65 61 72 6c 79 20 6f 6e 0a e user early on.
6070: 09 09 20 20 20 20 28 69 66 20 28 66 69 6c 65 2d .. (if (file-
6080: 65 78 69 73 74 73 3f 20 72 75 6e 63 6f 6e 66 69 exists? runconfi
6090: 67 66 29 0a 09 09 09 28 73 65 74 75 70 2d 65 6e gf)....(setup-en
60a0: 76 2d 64 65 66 61 75 6c 74 73 20 64 62 20 72 75 v-defaults db ru
60b0: 6e 63 6f 6e 66 69 67 66 20 72 75 6e 2d 69 64 20 nconfigf run-id
60c0: 2a 61 6c 72 65 61 64 79 2d 73 65 65 6e 2d 72 75 *already-seen-ru
60d0: 6e 63 6f 6e 66 69 67 2d 69 6e 66 6f 2a 29 0a 09 nconfig-info*)..
60e0: 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 ..(debug:print 0
60f0: 20 22 57 41 52 4e 49 4e 47 3a 20 59 6f 75 20 64 "WARNING: You d
6100: 6f 20 6e 6f 74 20 68 61 76 65 20 61 20 72 75 6e o not have a run
6110: 20 63 6f 6e 66 69 67 20 66 69 6c 65 3a 20 22 20 config file: "
6120: 72 75 6e 63 6f 6e 66 69 67 66 29 29 0a 09 09 20 runconfigf))...
6130: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
6140: 34 20 22 72 75 6e 2d 69 64 3a 20 22 20 72 75 6e 4 "run-id: " run
6150: 2d 69 64 20 22 20 74 65 73 74 2d 6e 61 6d 65 3a -id " test-name:
6160: 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 69 " test-name " i
6170: 74 65 6d 2d 70 61 74 68 3a 20 22 20 69 74 65 6d tem-path: " item
6180: 2d 70 61 74 68 20 22 20 74 65 73 74 64 61 74 3a -path " testdat:
6190: 20 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 " (test:get-sta
61a0: 74 75 73 20 74 65 73 74 64 61 74 29 20 22 20 74 tus testdat) " t
61b0: 65 73 74 2d 73 74 61 74 65 3a 20 22 20 28 74 65 est-state: " (te
61c0: 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 73 st:get-state tes
61d0: 74 64 61 74 29 29 0a 09 09 20 20 20 20 28 63 61 tdat))... (ca
61e0: 73 65 20 28 69 66 20 28 61 72 67 73 3a 67 65 74 se (if (args:get
61f0: 2d 61 72 67 20 22 2d 66 6f 72 63 65 22 29 0a 09 -arg "-force")..
6200: 09 09 20 20 20 20 20 20 27 4e 4f 54 5f 53 54 41 .. 'NOT_STA
6210: 52 54 45 44 0a 09 09 09 20 20 20 20 20 20 28 69 RTED.... (i
6220: 66 20 74 65 73 74 64 61 74 0a 09 09 09 09 20 20 f testdat.....
6230: 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 (string->symbol
6240: 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 (test:get-state
6250: 74 65 73 74 64 61 74 29 29 0a 09 09 09 09 20 20 testdat)).....
6260: 27 66 61 69 6c 65 64 2d 74 6f 2d 69 6e 73 65 72 'failed-to-inser
6270: 74 29 29 0a 09 09 20 20 20 20 20 20 28 28 66 61 t))... ((fa
6280: 69 6c 65 64 2d 74 6f 2d 69 6e 73 65 72 74 29 0a iled-to-insert).
6290: 09 09 20 20 20 20 20 20 20 28 64 65 62 75 67 3a .. (debug:
62a0: 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 print 0 "ERROR:
62b0: 46 61 69 6c 65 64 20 74 6f 20 69 6e 73 65 72 74 Failed to insert
62c0: 20 74 68 65 20 72 65 63 6f 72 64 20 69 6e 74 6f the record into
62d0: 20 74 68 65 20 64 62 22 29 29 0a 09 09 20 20 20 the db"))...
62e0: 20 20 20 28 28 4e 4f 54 5f 53 54 41 52 54 45 44 ((NOT_STARTED
62f0: 20 43 4f 4d 50 4c 45 54 45 44 29 0a 09 09 20 20 COMPLETED)...
6300: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
6310: 74 20 36 20 22 47 6f 74 20 68 65 72 65 2c 20 22 t 6 "Got here, "
6320: 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 (test:get-state
6330: 20 74 65 73 74 64 61 74 29 29 0a 09 09 20 20 20 testdat))...
6340: 20 20 20 20 28 6c 65 74 20 28 28 72 75 6e 66 6c (let ((runfl
6350: 61 67 20 23 66 29 29 0a 09 09 09 20 28 63 6f 6e ag #f)).... (con
6360: 64 0a 09 09 09 20 20 3b 3b 20 69 2e 65 2e 20 74 d.... ;; i.e. t
6370: 68 69 73 20 69 73 20 74 68 65 20 70 61 72 65 6e his is the paren
6380: 74 20 74 65 73 74 20 74 6f 20 61 20 73 75 69 74 t test to a suit
6390: 65 20 6f 66 20 69 74 65 6d 73 2c 20 6e 65 76 65 e of items, neve
63a0: 72 20 22 72 75 6e 22 20 69 74 0a 09 09 09 20 20 r "run" it....
63b0: 28 70 61 72 65 6e 74 2d 74 65 73 74 0a 09 09 09 (parent-test....
63c0: 20 20 20 28 73 65 74 21 20 72 75 6e 66 6c 61 67 (set! runflag
63d0: 20 23 66 29 29 0a 09 09 09 20 20 3b 3b 20 2d 66 #f)).... ;; -f
63e0: 6f 72 63 65 2c 20 72 75 6e 20 6e 6f 20 6d 61 74 orce, run no mat
63f0: 74 65 72 20 77 68 61 74 0a 09 09 09 20 20 28 28 ter what.... ((
6400: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 66 args:get-arg "-f
6410: 6f 72 63 65 22 29 28 73 65 74 21 20 72 75 6e 66 orce")(set! runf
6420: 6c 61 67 20 23 74 29 29 0a 09 09 09 20 20 3b 3b lag #t)).... ;;
6430: 20 4e 4f 54 5f 53 54 41 52 54 45 44 2c 20 72 75 NOT_STARTED, ru
6440: 6e 20 6e 6f 20 6d 61 74 74 65 72 20 77 68 61 74 n no matter what
6450: 0a 09 09 09 20 20 28 28 65 71 75 61 6c 3f 20 28 .... ((equal? (
6460: 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 test:get-state t
6470: 65 73 74 64 61 74 29 20 22 4e 4f 54 5f 53 54 41 estdat) "NOT_STA
6480: 52 54 45 44 22 29 28 73 65 74 21 20 72 75 6e 66 RTED")(set! runf
6490: 6c 61 67 20 23 74 29 29 0a 09 09 09 20 20 3b 3b lag #t)).... ;;
64a0: 20 6e 6f 74 20 2d 72 65 72 75 6e 20 61 6e 64 20 not -rerun and
64b0: 50 41 53 53 2c 20 57 41 52 4e 20 6f 72 20 43 48 PASS, WARN or CH
64c0: 45 43 4b 2c 20 64 6f 20 6e 6f 20 72 75 6e 0a 09 ECK, do no run..
64d0: 09 09 20 20 28 28 61 6e 64 20 28 6f 72 20 28 6e .. ((and (or (n
64e0: 6f 74 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 ot (args:get-arg
64f0: 20 22 2d 72 65 72 75 6e 22 29 29 0a 09 09 09 09 "-rerun")).....
6500: 20 20 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (args:get-ar
6510: 67 20 22 2d 6b 65 65 70 67 6f 69 6e 67 22 29 29 g "-keepgoing"))
6520: 0a 09 09 09 09 28 6d 65 6d 62 65 72 20 28 74 65 .....(member (te
6530: 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 st:get-status te
6540: 73 74 64 61 74 29 20 27 28 22 50 41 53 53 22 20 stdat) '("PASS"
6550: 22 57 41 52 4e 22 20 22 43 48 45 43 4b 22 29 29 "WARN" "CHECK"))
6560: 29 0a 09 09 09 20 20 20 28 73 65 74 21 20 72 75 ).... (set! ru
6570: 6e 66 6c 61 67 20 23 66 29 29 0a 09 09 09 20 20 nflag #f))....
6580: 3b 3b 20 2d 72 65 72 75 6e 20 61 6e 64 20 73 74 ;; -rerun and st
6590: 61 74 75 73 20 69 73 20 6f 6e 65 20 6f 66 20 74 atus is one of t
65a0: 68 65 20 73 70 65 63 69 66 65 64 2c 20 72 75 6e he specifed, run
65b0: 20 69 74 0a 09 09 09 20 20 28 28 61 6e 64 20 28 it.... ((and (
65c0: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 args:get-arg "-r
65d0: 65 72 75 6e 22 29 0a 09 09 09 09 28 6c 65 74 20 erun").....(let
65e0: 28 28 72 65 72 75 6e 6c 73 74 20 28 73 74 72 69 ((rerunlst (stri
65f0: 6e 67 2d 73 70 6c 69 74 20 28 61 72 67 73 3a 67 ng-split (args:g
6600: 65 74 2d 61 72 67 20 22 2d 72 65 72 75 6e 22 29 et-arg "-rerun")
6610: 20 22 2c 22 29 29 29 20 3b 3b 20 46 41 49 4c 2c ","))) ;; FAIL,
6620: 0a 09 09 09 09 20 20 28 6d 65 6d 62 65 72 20 28 ..... (member (
6630: 74 65 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 test:get-status
6640: 74 65 73 74 64 61 74 29 20 72 65 72 75 6e 6c 73 testdat) rerunls
6650: 74 29 29 29 0a 09 09 09 20 20 20 28 73 65 74 21 t))).... (set!
6660: 20 72 75 6e 66 6c 61 67 20 23 74 29 29 0a 09 09 runflag #t))...
6670: 09 20 20 3b 3b 20 2d 6b 65 65 70 67 6f 69 6e 67 . ;; -keepgoing
6680: 2c 20 64 6f 20 6e 6f 74 20 72 65 72 75 6e 20 46 , do not rerun F
6690: 41 49 4c 0a 09 09 09 20 20 28 28 61 6e 64 20 28 AIL.... ((and (
66a0: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 6b args:get-arg "-k
66b0: 65 65 70 67 6f 69 6e 67 22 29 0a 09 09 09 09 28 eepgoing").....(
66c0: 6d 65 6d 62 65 72 20 28 74 65 73 74 3a 67 65 74 member (test:get
66d0: 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 74 29 -status testdat)
66e0: 20 27 28 22 46 41 49 4c 22 29 29 29 0a 09 09 09 '("FAIL")))....
66f0: 20 20 20 28 73 65 74 21 20 72 75 6e 66 6c 61 67 (set! runflag
6700: 20 23 66 29 29 0a 09 09 09 20 20 28 28 61 6e 64 #f)).... ((and
6710: 20 28 6e 6f 74 20 28 61 72 67 73 3a 67 65 74 2d (not (args:get-
6720: 61 72 67 20 22 2d 72 65 72 75 6e 22 29 29 0a 09 arg "-rerun"))..
6730: 09 09 09 28 6d 65 6d 62 65 72 20 28 74 65 73 74 ...(member (test
6740: 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 :get-status test
6750: 64 61 74 29 20 27 28 22 46 41 49 4c 22 20 22 6e dat) '("FAIL" "n
6760: 2f 61 22 29 29 29 0a 09 09 09 20 20 20 28 73 65 /a"))).... (se
6770: 74 21 20 72 75 6e 66 6c 61 67 20 23 74 29 29 0a t! runflag #t)).
6780: 09 09 09 20 20 28 65 6c 73 65 20 28 73 65 74 21 ... (else (set!
6790: 20 72 75 6e 66 6c 61 67 20 23 66 29 29 29 0a 09 runflag #f)))..
67a0: 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 .. (debug:print
67b0: 36 20 22 52 55 4e 4e 49 4e 47 20 3d 3e 20 72 75 6 "RUNNING => ru
67c0: 6e 66 6c 61 67 3a 20 22 20 72 75 6e 66 6c 61 67 nflag: " runflag
67d0: 20 22 20 53 54 41 54 45 3a 20 22 20 28 74 65 73 " STATE: " (tes
67e0: 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 t:get-state test
67f0: 64 61 74 29 20 22 20 53 54 41 54 55 53 3a 20 22 dat) " STATUS: "
6800: 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 75 (test:get-statu
6810: 73 20 74 65 73 74 64 61 74 29 29 0a 09 09 09 20 s testdat))....
6820: 28 69 66 20 28 6e 6f 74 20 72 75 6e 66 6c 61 67 (if (not runflag
6830: 29 0a 09 09 09 20 20 20 20 20 28 69 66 20 28 6e ).... (if (n
6840: 6f 74 20 70 61 72 65 6e 74 2d 74 65 73 74 29 0a ot parent-test).
6850: 09 09 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e .... (debug:prin
6860: 74 20 31 20 22 4e 4f 54 45 3a 20 4e 6f 74 20 73 t 1 "NOTE: Not s
6870: 74 61 72 74 69 6e 67 20 74 65 73 74 20 22 20 6e tarting test " n
6880: 65 77 2d 74 65 73 74 2d 6e 61 6d 65 20 22 20 61 ew-test-name " a
6890: 73 20 69 74 20 69 73 20 73 74 61 74 65 20 5c 22 s it is state \"
68a0: 43 4f 4d 50 4c 45 54 45 44 5c 22 20 61 6e 64 20 COMPLETED\" and
68b0: 73 74 61 74 75 73 20 5c 22 22 20 28 74 65 73 74 status \"" (test
68c0: 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 :get-status test
68d0: 64 61 74 29 20 22 5c 22 2c 20 75 73 65 20 2d 66 dat) "\", use -f
68e0: 6f 72 63 65 20 74 6f 20 6f 76 65 72 72 69 64 65 orce to override
68f0: 22 29 29 0a 09 09 09 20 20 20 20 20 28 6c 65 74 ")).... (let
6900: 2a 20 28 28 67 65 74 2d 70 72 65 72 65 71 73 2d * ((get-prereqs-
6910: 63 6d 64 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 cmd (lambda ()..
6920: 09 09 09 09 09 20 20 20 20 20 20 20 28 64 62 2d ..... (db-
6930: 67 65 74 2d 70 72 65 72 65 71 73 2d 6e 6f 74 2d get-prereqs-not-
6940: 6d 65 74 20 64 62 20 72 75 6e 2d 69 64 20 77 61 met db run-id wa
6950: 69 74 6f 6e 29 29 29 20 3b 3b 20 63 68 65 63 6b iton))) ;; check
6960: 20 62 65 66 6f 72 65 20 72 75 6e 6e 69 6e 67 20 before running
6970: 2e 2e 2e 2e 0a 09 09 09 09 20 20 20 20 28 6c 61 ......... (la
6980: 75 6e 63 68 2d 63 6d 64 20 20 20 20 20 20 28 6c unch-cmd (l
6990: 61 6d 62 64 61 20 28 29 0a 09 09 09 09 09 09 20 ambda ().......
69a0: 20 20 20 20 20 20 28 6c 61 75 6e 63 68 2d 74 65 (launch-te
69b0: 73 74 20 64 62 20 72 75 6e 2d 69 64 20 74 65 73 st db run-id tes
69c0: 74 2d 63 6f 6e 66 20 6b 65 79 76 61 6c 6c 73 74 t-conf keyvallst
69d0: 20 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d test-name test-
69e0: 70 61 74 68 20 69 74 65 6d 64 61 74 29 29 29 0a path itemdat))).
69f0: 09 09 09 09 20 20 20 20 28 74 65 73 74 72 75 6e .... (testrun
6a00: 64 61 74 20 20 20 20 20 20 28 6c 69 73 74 20 67 dat (list g
6a10: 65 74 2d 70 72 65 72 65 71 73 2d 63 6d 64 20 6c et-prereqs-cmd l
6a20: 61 75 6e 63 68 2d 63 6d 64 29 29 29 0a 09 09 09 aunch-cmd)))....
6a30: 20 20 20 20 20 20 20 28 69 66 20 28 6f 72 20 28 (if (or (
6a40: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 66 args:get-arg "-f
6a50: 6f 72 63 65 22 29 0a 09 09 09 09 20 20 20 20 20 orce").....
6a60: 20 20 28 6c 65 74 20 28 28 70 72 65 71 73 2d 6e (let ((preqs-n
6a70: 6f 74 2d 79 65 74 2d 6d 65 74 20 28 28 63 61 72 ot-yet-met ((car
6a80: 20 74 65 73 74 72 75 6e 64 61 74 29 29 29 29 0a testrundat)))).
6a90: 09 09 09 09 09 20 28 64 65 62 75 67 3a 70 72 69 ..... (debug:pri
6aa0: 6e 74 20 32 20 22 50 72 65 71 72 65 71 75 65 73 nt 2 "Preqreques
6ab0: 69 74 65 73 20 66 6f 72 20 22 20 74 65 73 74 2d ites for " test-
6ac0: 6e 61 6d 65 20 22 3a 20 22 20 70 72 65 71 73 2d name ": " preqs-
6ad0: 6e 6f 74 2d 79 65 74 2d 6d 65 74 29 0a 09 09 09 not-yet-met)....
6ae0: 09 09 20 28 6e 75 6c 6c 3f 20 70 72 65 71 73 2d .. (null? preqs-
6af0: 6e 6f 74 2d 79 65 74 2d 6d 65 74 29 29 29 20 3b not-yet-met))) ;
6b00: 3b 20 61 72 65 20 74 68 65 72 65 20 61 6e 79 20 ; are there any
6b10: 74 65 73 74 73 20 74 68 61 74 20 6d 75 73 74 20 tests that must
6b20: 62 65 20 72 75 6e 20 62 65 66 6f 72 65 20 74 68 be run before th
6b30: 69 73 20 6f 6e 65 2e 2e 2e 0a 09 09 09 09 20 20 is one........
6b40: 20 28 69 66 20 28 6e 6f 74 20 28 28 63 61 64 72 (if (not ((cadr
6b50: 20 74 65 73 74 72 75 6e 64 61 74 29 29 29 20 3b testrundat))) ;
6b60: 3b 20 74 68 69 73 20 69 73 20 74 68 65 20 6c 69 ; this is the li
6b70: 6e 65 20 74 68 61 74 20 6c 61 75 6e 63 68 65 73 ne that launches
6b80: 20 74 68 65 20 74 65 73 74 20 74 6f 20 74 68 65 the test to the
6b90: 20 72 65 6d 6f 74 65 20 68 6f 73 74 0a 09 09 09 remote host....
6ba0: 09 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 . (begin..
6bb0: 09 09 09 09 20 28 70 72 69 6e 74 20 22 45 52 52 .... (print "ERR
6bc0: 4f 52 3a 20 46 61 69 6c 65 64 20 74 6f 20 6c 61 OR: Failed to la
6bd0: 75 6e 63 68 20 74 68 65 20 74 65 73 74 2e 20 45 unch the test. E
6be0: 78 69 74 69 6e 67 20 61 73 20 73 6f 6f 6e 20 61 xiting as soon a
6bf0: 73 20 70 6f 73 73 69 62 6c 65 22 29 0a 09 09 09 s possible")....
6c00: 09 09 20 28 73 65 74 21 20 2a 67 6c 6f 62 61 6c .. (set! *global
6c10: 65 78 69 74 73 74 61 74 75 73 2a 20 31 29 20 3b exitstatus* 1) ;
6c20: 3b 20 0a 09 09 09 09 09 20 28 70 72 6f 63 65 73 ; ...... (proces
6c30: 73 2d 73 69 67 6e 61 6c 20 28 63 75 72 72 65 6e s-signal (curren
6c40: 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 20 73 69 t-process-id) si
6c50: 67 6e 61 6c 2f 6b 69 6c 6c 29 0a 09 09 09 09 09 gnal/kill)......
6c60: 20 3b 28 65 78 69 74 20 31 29 0a 09 09 09 09 09 ;(exit 1)......
6c70: 20 29 29 0a 09 09 09 09 20 20 20 28 69 66 20 28 ))..... (if (
6c80: 6e 6f 74 20 28 61 72 67 73 3a 67 65 74 2d 61 72 not (args:get-ar
6c90: 67 20 22 2d 6b 65 65 70 67 6f 69 6e 67 22 29 29 g "-keepgoing"))
6ca0: 0a 09 09 09 09 20 20 20 20 20 20 20 28 68 61 73 ..... (has
6cb0: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a 77 61 h-table-set! *wa
6cc0: 69 74 69 6e 67 2d 71 75 65 75 65 2a 20 6e 65 77 iting-queue* new
6cd0: 2d 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 72 -test-name testr
6ce0: 75 6e 64 61 74 29 29 29 29 29 29 29 0a 09 09 20 undat)))))))...
6cf0: 20 20 20 20 20 28 28 4b 49 4c 4c 45 44 29 20 0a ((KILLED) .
6d00: 09 09 20 20 20 20 20 20 20 28 64 65 62 75 67 3a .. (debug:
6d10: 70 72 69 6e 74 20 31 20 22 4e 4f 54 45 3a 20 22 print 1 "NOTE: "
6d20: 20 6e 65 77 2d 74 65 73 74 2d 6e 61 6d 65 20 22 new-test-name "
6d30: 20 69 73 20 61 6c 72 65 61 64 79 20 72 75 6e 6e is already runn
6d40: 69 6e 67 20 6f 72 20 77 61 73 20 65 78 70 6c 69 ing or was expli
6d50: 63 74 6c 79 20 6b 69 6c 6c 65 64 2c 20 75 73 65 ctly killed, use
6d60: 20 2d 66 6f 72 63 65 20 74 6f 20 6c 61 75 6e 63 -force to launc
6d70: 68 20 69 74 2e 22 29 29 0a 09 09 20 20 20 20 20 h it."))...
6d80: 20 28 28 4c 41 55 4e 43 48 45 44 20 52 45 4d 4f ((LAUNCHED REMO
6d90: 54 45 48 4f 53 54 53 54 41 52 54 20 52 55 4e 4e TEHOSTSTART RUNN
6da0: 49 4e 47 29 20 20 0a 09 09 20 20 20 20 20 20 20 ING) ...
6db0: 28 69 66 20 28 3e 20 28 2d 20 28 63 75 72 72 65 (if (> (- (curre
6dc0: 6e 74 2d 73 65 63 6f 6e 64 73 29 28 2b 20 28 64 nt-seconds)(+ (d
6dd0: 62 3a 74 65 73 74 2d 67 65 74 2d 65 76 65 6e 74 b:test-get-event
6de0: 5f 74 69 6d 65 20 74 65 73 74 64 61 74 29 0a 09 _time testdat)..
6df0: 09 09 09 09 09 20 20 20 20 20 28 64 62 3a 74 65 ..... (db:te
6e00: 73 74 2d 67 65 74 2d 72 75 6e 5f 64 75 72 61 74 st-get-run_durat
6e10: 69 6f 6e 20 74 65 73 74 64 61 74 29 29 29 0a 09 ion testdat)))..
6e20: 09 09 20 20 20 20 20 20 31 30 30 29 20 3b 3b 20 .. 100) ;;
6e30: 69 2e 65 2e 20 6e 6f 20 75 70 64 61 74 65 20 66 i.e. no update f
6e40: 6f 72 20 6d 6f 72 65 20 74 68 61 6e 20 31 30 30 or more than 100
6e50: 20 73 65 63 6f 6e 64 73 0a 09 09 09 20 20 20 28 seconds.... (
6e60: 62 65 67 69 6e 0a 09 09 09 20 20 20 20 20 28 64 begin.... (d
6e70: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 ebug:print 0 "WA
6e80: 52 4e 49 4e 47 3a 20 54 65 73 74 20 22 20 74 65 RNING: Test " te
6e90: 73 74 2d 6e 61 6d 65 20 22 20 61 70 70 65 61 72 st-name " appear
6ea0: 73 20 74 6f 20 62 65 20 64 65 61 64 2e 20 46 6f s to be dead. Fo
6eb0: 72 63 69 6e 67 20 69 74 20 74 6f 20 73 74 61 74 rcing it to stat
6ec0: 65 20 49 4e 43 4f 4d 50 4c 45 54 45 20 61 6e 64 e INCOMPLETE and
6ed0: 20 73 74 61 74 75 73 20 53 54 55 43 4b 2f 44 45 status STUCK/DE
6ee0: 41 44 22 29 0a 09 09 09 20 20 20 20 20 28 74 65 AD").... (te
6ef0: 73 74 2d 73 65 74 2d 73 74 61 74 75 73 21 20 64 st-set-status! d
6f00: 62 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 b run-id test-na
6f10: 6d 65 20 22 49 4e 43 4f 4d 50 4c 45 54 45 22 20 me "INCOMPLETE"
6f20: 22 53 54 55 43 4b 2f 44 45 41 44 22 20 69 74 65 "STUCK/DEAD" ite
6f30: 6d 64 61 74 20 22 54 65 73 74 20 69 73 20 73 74 mdat "Test is st
6f40: 75 63 6b 20 6f 72 20 64 65 61 64 22 20 23 66 29 uck or dead" #f)
6f50: 29 0a 09 09 09 20 20 20 28 64 65 62 75 67 3a 70 ).... (debug:p
6f60: 72 69 6e 74 20 32 20 22 4e 4f 54 45 3a 20 22 20 rint 2 "NOTE: "
6f70: 74 65 73 74 2d 6e 61 6d 65 20 22 20 69 73 20 61 test-name " is a
6f80: 6c 72 65 61 64 79 20 72 75 6e 6e 69 6e 67 22 29 lready running")
6f90: 29 29 0a 09 09 20 20 20 20 20 20 28 65 6c 73 65 ))... (else
6fa0: 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 (debug:pr
6fb0: 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 46 61 int 0 "ERROR: Fa
6fc0: 69 6c 65 64 20 74 6f 20 6c 61 75 6e 63 68 20 74 iled to launch t
6fd0: 65 73 74 20 22 20 6e 65 77 2d 74 65 73 74 2d 6e est " new-test-n
6fe0: 61 6d 65 20 22 2e 20 55 6e 72 65 63 6f 67 6e 69 ame ". Unrecogni
6ff0: 73 65 64 20 73 74 61 74 65 20 22 20 28 74 65 73 sed state " (tes
7000: 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 t:get-state test
7010: 64 61 74 29 29 29 29 29 29 0a 09 20 20 20 20 20 dat))))))..
7020: 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f (if (not (null?
7030: 20 74 61 6c 29 29 0a 09 09 20 20 28 6c 6f 6f 70 tal))... (loop
7040: 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 (car tal)(cdr t
7050: 61 6c 29 29 29 29 29 29 29 29 29 0a 0a 28 64 65 al)))))))))..(de
7060: 66 69 6e 65 20 28 72 75 6e 2d 77 61 69 74 69 6e fine (run-waitin
7070: 67 2d 74 65 73 74 73 20 64 62 29 0a 20 20 28 6c g-tests db). (l
7080: 65 74 20 28 28 6e 75 6d 74 72 69 65 73 20 20 20 et ((numtries
7090: 20 20 20 20 20 20 20 20 30 29 0a 09 28 6c 61 73 0)..(las
70a0: 74 2d 74 72 79 2d 74 69 6d 65 20 20 20 20 20 20 t-try-time
70b0: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
70c0: 29 29 0a 09 28 74 69 6d 65 73 20 20 20 20 20 20 ))..(times
70d0: 20 20 20 20 20 20 20 20 28 6c 69 73 74 20 31 29 (list 1)
70e0: 29 29 20 3b 3b 20 6d 69 6e 75 74 65 73 20 74 6f )) ;; minutes to
70f0: 20 77 61 69 74 20 62 65 66 6f 72 65 20 74 72 79 wait before try
7100: 69 6e 67 20 61 67 61 69 6e 20 74 6f 20 6b 69 63 ing again to kic
7110: 6b 20 6f 66 66 20 72 75 6e 73 0a 20 20 20 20 3b k off runs. ;
7120: 3b 20 42 55 47 20 74 68 69 73 20 68 61 63 6b 20 ; BUG this hack
7130: 6f 66 20 62 72 75 74 65 20 66 6f 72 63 65 20 72 of brute force r
7140: 65 74 72 79 69 6e 67 20 77 6f 72 6b 73 20 71 75 etrying works qu
7150: 69 74 65 20 77 65 6c 6c 20 66 6f 72 20 6d 61 6e ite well for man
7160: 79 20 63 61 73 65 73 20 62 75 74 20 0a 20 20 20 y cases but .
7170: 20 3b 3b 20 20 20 20 20 77 68 61 74 20 69 73 20 ;; what is
7180: 6e 65 65 64 65 64 20 69 73 20 74 6f 20 63 68 65 needed is to che
7190: 63 6b 20 74 68 65 20 64 62 20 66 6f 72 20 74 65 ck the db for te
71a0: 73 74 73 20 74 68 61 74 20 68 61 76 65 20 66 61 sts that have fa
71b0: 69 6c 65 64 20 6c 65 73 73 20 74 68 61 6e 0a 20 iled less than.
71c0: 20 20 20 3b 3b 20 20 20 20 20 4e 20 74 69 6d 65 ;; N time
71d0: 73 20 6f 72 20 6e 65 76 65 72 20 62 65 65 6e 20 s or never been
71e0: 73 74 61 72 74 65 64 20 61 6e 64 20 6b 69 63 6b started and kick
71f0: 20 74 68 65 6d 20 6f 66 66 20 61 67 61 69 6e 0a them off again.
7200: 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 (let loop ((
7210: 77 61 69 74 69 6e 67 2d 74 65 73 74 2d 6e 61 6d waiting-test-nam
7220: 65 73 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b es (hash-table-k
7230: 65 79 73 20 2a 77 61 69 74 69 6e 67 2d 71 75 65 eys *waiting-que
7240: 75 65 2a 29 29 29 0a 20 20 20 20 20 20 28 63 6f ue*))). (co
7250: 6e 64 0a 20 20 20 20 20 20 20 28 28 6e 6f 74 20 nd. ((not
7260: 28 72 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f (runs:can-run-mo
7270: 72 65 2d 74 65 73 74 73 20 64 62 29 29 0a 09 28 re-tests db))..(
7280: 73 6c 65 65 70 20 32 29 0a 09 28 6c 6f 6f 70 20 sleep 2)..(loop
7290: 77 61 69 74 69 6e 67 2d 74 65 73 74 2d 6e 61 6d waiting-test-nam
72a0: 65 73 29 29 0a 20 20 20 20 20 20 20 28 28 6e 75 es)). ((nu
72b0: 6c 6c 3f 20 77 61 69 74 69 6e 67 2d 74 65 73 74 ll? waiting-test
72c0: 2d 6e 61 6d 65 73 29 0a 09 28 64 65 62 75 67 3a -names)..(debug:
72d0: 70 72 69 6e 74 20 31 20 22 41 6c 6c 20 74 65 73 print 1 "All tes
72e0: 74 73 20 6c 61 75 6e 63 68 65 64 22 29 29 0a 20 ts launched")).
72f0: 20 20 20 20 20 20 28 65 6c 73 65 0a 09 28 73 65 (else..(se
7300: 74 21 20 6e 75 6d 74 72 69 65 73 20 28 2b 20 6e t! numtries (+ n
7310: 75 6d 74 72 69 65 73 20 31 29 29 0a 09 28 66 6f umtries 1))..(fo
7320: 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 r-each (lambda (
7330: 74 65 73 74 6e 61 6d 65 29 0a 09 09 20 20 20 20 testname)...
7340: 28 69 66 20 28 72 75 6e 73 3a 63 61 6e 2d 72 75 (if (runs:can-ru
7350: 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 20 64 62 29 n-more-tests db)
7360: 0a 09 09 09 28 6c 65 74 2a 20 28 28 74 65 73 74 ....(let* ((test
7370: 64 61 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d dat (hash-table-
7380: 72 65 66 20 2a 77 61 69 74 69 6e 67 2d 71 75 65 ref *waiting-que
7390: 75 65 2a 20 74 65 73 74 6e 61 6d 65 29 29 0a 09 ue* testname))..
73a0: 09 09 20 20 20 20 20 20 20 28 70 72 65 72 65 71 .. (prereq
73b0: 73 20 28 28 63 61 72 20 74 65 73 74 64 61 74 29 s ((car testdat)
73c0: 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 6c 64 )).... (ld
73d0: 62 20 20 20 20 20 28 69 66 20 64 62 20 64 62 20 b (if db db
73e0: 28 6f 70 65 6e 2d 64 62 29 29 29 29 0a 09 09 09 (open-db))))....
73f0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 (debug:print 2
7400: 20 22 70 72 65 72 65 71 73 20 72 65 6d 61 69 6e "prereqs remain
7410: 69 6e 67 3a 20 22 20 70 72 65 72 65 71 73 29 0a ing: " prereqs).
7420: 09 09 09 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 ... (if (null?
7430: 70 72 65 72 65 71 73 29 0a 09 09 09 20 20 20 20 prereqs)....
7440: 20 20 28 62 65 67 69 6e 0a 09 09 09 09 28 64 65 (begin.....(de
7450: 62 75 67 3a 70 72 69 6e 74 20 32 20 22 50 72 65 bug:print 2 "Pre
7460: 72 65 71 75 69 73 69 74 65 73 20 6d 65 74 2c 20 requisites met,
7470: 6c 61 75 6e 63 68 69 6e 67 20 22 20 74 65 73 74 launching " test
7480: 6e 61 6d 65 29 0a 09 09 09 09 28 28 63 61 64 72 name).....((cadr
7490: 20 74 65 73 74 64 61 74 29 29 0a 09 09 09 09 28 testdat)).....(
74a0: 68 61 73 68 2d 74 61 62 6c 65 2d 64 65 6c 65 74 hash-table-delet
74b0: 65 21 20 2a 77 61 69 74 69 6e 67 2d 71 75 65 75 e! *waiting-queu
74c0: 65 2a 20 74 65 73 74 6e 61 6d 65 29 29 29 0a 09 e* testname)))..
74d0: 09 09 20 20 28 69 66 20 28 6e 6f 74 20 64 62 29 .. (if (not db)
74e0: 0a 09 09 09 20 20 20 20 20 20 28 73 71 6c 69 74 .... (sqlit
74f0: 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 6c 64 62 e3:finalize! ldb
7500: 29 29 29 29 29 0a 09 09 20 20 77 61 69 74 69 6e )))))... waitin
7510: 67 2d 74 65 73 74 2d 6e 61 6d 65 73 29 0a 09 3b g-test-names)..;
7520: 3b 20 28 73 6c 65 65 70 20 31 30 29 20 3b 3b 20 ; (sleep 10) ;;
7530: 6e 6f 20 70 6f 69 6e 74 20 69 6e 20 72 75 73 68 no point in rush
7540: 69 6e 67 20 74 68 69 6e 67 73 20 61 74 20 74 68 ing things at th
7550: 69 73 20 73 74 61 67 65 3f 0a 09 28 6c 6f 6f 70 is stage?..(loop
7560: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 (hash-table-key
7570: 73 20 2a 77 61 69 74 69 6e 67 2d 71 75 65 75 65 s *waiting-queue
7580: 2a 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e *)))))))..(defin
7590: 65 20 28 67 65 74 2d 64 69 72 2d 75 70 2d 6e 20 e (get-dir-up-n
75a0: 64 69 72 20 2e 20 70 61 72 61 6d 73 29 20 0a 20 dir . params) .
75b0: 20 28 6c 65 74 20 28 28 64 70 61 72 74 73 20 20 (let ((dparts
75c0: 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 64 69 (string-split di
75d0: 72 20 22 2f 22 29 29 0a 09 28 63 6f 75 6e 74 20 r "/"))..(count
75e0: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 70 61 72 (if (null? par
75f0: 61 6d 73 29 20 31 20 28 63 61 72 20 70 61 72 61 ams) 1 (car para
7600: 6d 73 29 29 29 29 0a 20 20 20 20 28 63 6f 6e 63 ms)))). (conc
7610: 20 22 2f 22 20 28 73 74 72 69 6e 67 2d 69 6e 74 "/" (string-int
7620: 65 72 73 70 65 72 73 65 20 0a 09 20 20 20 20 20 ersperse ..
7630: 20 20 28 74 61 6b 65 20 64 70 61 72 74 73 20 28 (take dparts (
7640: 2d 20 28 6c 65 6e 67 74 68 20 64 70 61 72 74 73 - (length dparts
7650: 29 20 63 6f 75 6e 74 29 29 0a 09 20 20 20 20 20 ) count))..
7660: 20 20 22 2f 22 29 29 29 29 0a 3b 3b 20 52 65 6d "/")))).;; Rem
7670: 6f 76 65 20 72 75 6e 73 0a 3b 3b 20 66 69 65 6c ove runs.;; fiel
7680: 64 73 20 61 72 65 20 70 61 73 73 69 6e 67 20 69 ds are passing i
7690: 6e 20 74 68 72 6f 75 67 68 20 0a 28 64 65 66 69 n through .(defi
76a0: 6e 65 20 28 72 75 6e 73 3a 72 65 6d 6f 76 65 2d ne (runs:remove-
76b0: 72 75 6e 73 20 64 62 20 72 75 6e 6e 61 6d 65 70 runs db runnamep
76c0: 61 74 74 20 74 65 73 74 70 61 74 74 20 69 74 65 att testpatt ite
76d0: 6d 70 61 74 74 29 0a 20 20 28 6c 65 74 2a 20 28 mpatt). (let* (
76e0: 28 6b 65 79 73 20 20 20 20 20 20 20 20 28 64 62 (keys (db
76f0: 2d 67 65 74 2d 6b 65 79 73 20 64 62 29 29 0a 09 -get-keys db))..
7700: 20 28 72 75 6e 64 61 74 20 20 20 20 20 20 28 72 (rundat (r
7710: 75 6e 73 3a 67 65 74 2d 72 75 6e 73 2d 62 79 2d uns:get-runs-by-
7720: 70 61 74 74 20 64 62 20 6b 65 79 73 20 72 75 6e patt db keys run
7730: 6e 61 6d 65 70 61 74 74 29 29 0a 09 20 28 68 65 namepatt)).. (he
7740: 61 64 65 72 20 20 20 20 20 20 28 76 65 63 74 6f ader (vecto
7750: 72 2d 72 65 66 20 72 75 6e 64 61 74 20 30 29 29 r-ref rundat 0))
7760: 0a 09 20 28 72 75 6e 73 20 20 20 20 20 20 20 20 .. (runs
7770: 28 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 64 (vector-ref rund
7780: 61 74 20 31 29 29 29 0a 20 20 20 20 28 64 65 62 at 1))). (deb
7790: 75 67 3a 70 72 69 6e 74 20 31 20 22 48 65 61 64 ug:print 1 "Head
77a0: 65 72 3a 20 22 20 68 65 61 64 65 72 29 0a 20 20 er: " header).
77b0: 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 (for-each.
77c0: 20 28 6c 61 6d 62 64 61 20 28 72 75 6e 29 0a 20 (lambda (run).
77d0: 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 75 6e (let ((run
77e0: 6b 65 79 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 key (string-inte
77f0: 72 73 70 65 72 73 65 20 28 6d 61 70 20 28 6c 61 rsperse (map (la
7800: 6d 62 64 61 20 28 6b 29 0a 09 09 09 09 09 09 28 mbda (k).......(
7810: 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d db:get-value-by-
7820: 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 header run heade
7830: 72 20 28 76 65 63 74 6f 72 2d 72 65 66 20 6b 20 r (vector-ref k
7840: 30 29 29 29 20 6b 65 79 73 29 20 22 2f 22 29 29 0))) keys) "/"))
7850: 29 0a 09 20 28 6c 65 74 2a 20 28 28 72 75 6e 2d ).. (let* ((run-
7860: 69 64 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 id (db:get-value
7870: 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 -by-header run h
7880: 65 61 64 65 72 20 22 69 64 22 29 20 29 0a 09 09 eader "id") )...
7890: 28 74 65 73 74 73 20 20 28 64 62 2d 67 65 74 2d (tests (db-get-
78a0: 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 64 62 tests-for-run db
78b0: 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 (db:get-value-b
78c0: 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 y-header run hea
78d0: 64 65 72 20 22 69 64 22 29 20 74 65 73 74 70 61 der "id") testpa
78e0: 74 74 20 69 74 65 6d 70 61 74 74 29 29 0a 09 09 tt itempatt))...
78f0: 28 6c 61 73 74 74 70 61 74 68 20 22 2f 64 6f 65 (lasttpath "/doe
7900: 73 2f 6e 6f 74 2f 65 78 69 73 74 2f 49 2f 68 6f s/not/exist/I/ho
7910: 70 65 22 29 29 0a 09 20 20 20 28 69 66 20 28 6e pe")).. (if (n
7920: 6f 74 20 28 6e 75 6c 6c 3f 20 74 65 73 74 73 29 ot (null? tests)
7930: 29 0a 09 20 20 20 20 20 20 20 28 62 65 67 69 6e ).. (begin
7940: 0a 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ... (debug:print
7950: 20 31 20 22 52 65 6d 6f 76 69 6e 67 20 74 65 73 1 "Removing tes
7960: 74 73 20 66 6f 72 20 72 75 6e 3a 20 22 20 72 75 ts for run: " ru
7970: 6e 6b 65 79 20 22 20 22 20 28 64 62 3a 67 65 74 nkey " " (db:get
7980: 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 -value-by-header
7990: 20 72 75 6e 20 68 65 61 64 65 72 20 22 72 75 6e run header "run
79a0: 6e 61 6d 65 22 29 29 0a 09 09 20 28 66 6f 72 2d name"))... (for-
79b0: 65 61 63 68 0a 09 09 20 20 28 6c 61 6d 62 64 61 each... (lambda
79c0: 20 28 74 65 73 74 29 0a 09 09 20 20 20 20 28 6c (test)... (l
79d0: 65 74 2a 20 28 28 69 74 65 6d 2d 70 61 74 68 20 et* ((item-path
79e0: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 (db:test-get-ite
79f0: 6d 2d 70 61 74 68 20 74 65 73 74 29 29 0a 09 09 m-path test))...
7a00: 09 20 20 20 28 74 65 73 74 2d 6e 61 6d 65 20 28 . (test-name (
7a10: 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 db:test-get-test
7a20: 6e 61 6d 65 20 74 65 73 74 29 29 0a 09 09 09 20 name test))....
7a30: 20 20 28 72 75 6e 2d 64 69 72 20 20 20 28 64 62 (run-dir (db
7a40: 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 :test-get-rundir
7a50: 20 74 65 73 74 29 29 29 0a 09 09 20 20 20 20 20 test)))...
7a60: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 (debug:print 1
7a70: 22 20 20 22 20 28 64 62 3a 74 65 73 74 2d 67 65 " " (db:test-ge
7a80: 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 29 t-testname test)
7a90: 20 22 20 69 64 3a 20 22 20 28 64 62 3a 74 65 73 " id: " (db:tes
7aa0: 74 2d 67 65 74 2d 69 64 20 74 65 73 74 29 20 22 t-get-id test) "
7ab0: 20 22 20 69 74 65 6d 2d 70 61 74 68 29 0a 09 09 " item-path)...
7ac0: 20 20 20 20 20 20 28 64 62 3a 64 65 6c 65 74 65 (db:delete
7ad0: 2d 74 65 73 74 2d 72 65 63 6f 72 64 73 20 64 62 -test-records db
7ae0: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 (db:test-get-id
7af0: 20 74 65 73 74 29 29 0a 09 09 20 20 20 20 20 20 test))...
7b00: 28 69 66 20 28 3e 20 28 73 74 72 69 6e 67 2d 6c (if (> (string-l
7b10: 65 6e 67 74 68 20 72 75 6e 2d 64 69 72 29 20 35 ength run-dir) 5
7b20: 29 20 3b 3b 20 62 61 64 20 68 65 75 72 69 73 74 ) ;; bad heurist
7b30: 69 63 20 62 75 74 20 73 68 6f 75 6c 64 20 70 72 ic but should pr
7b40: 65 76 65 6e 74 20 2f 74 6d 70 20 2f 68 6f 6d 65 event /tmp /home
7b50: 20 65 74 63 2e 0a 09 09 09 20 20 28 6c 65 74 20 etc..... (let
7b60: 28 28 66 75 6c 6c 70 61 74 68 20 72 75 6e 2d 64 ((fullpath run-d
7b70: 69 72 29 29 20 3b 3b 20 22 2f 22 20 28 64 62 3a ir)) ;; "/" (db:
7b80: 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 test-get-item-pa
7b90: 74 68 20 74 65 73 74 29 29 29 29 0a 09 09 09 20 th test))))....
7ba0: 20 20 20 28 73 65 74 21 20 6c 61 73 74 74 70 61 (set! lasttpa
7bb0: 74 68 20 66 75 6c 6c 70 61 74 68 29 0a 09 09 09 th fullpath)....
7bc0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
7bd0: 20 31 20 22 72 6d 20 2d 72 66 20 22 20 66 75 6c 1 "rm -rf " ful
7be0: 6c 70 61 74 68 29 0a 09 09 09 20 20 20 20 28 73 lpath).... (s
7bf0: 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 72 6d 20 ystem (conc "rm
7c00: 2d 72 66 20 22 20 66 75 6c 6c 70 61 74 68 29 29 -rf " fullpath))
7c10: 0a 09 09 09 20 20 20 20 28 6c 65 74 2a 20 28 28 .... (let* ((
7c20: 64 69 72 73 2d 63 6f 75 6e 74 20 28 2b 20 31 20 dirs-count (+ 1
7c30: 28 6c 65 6e 67 74 68 20 6b 65 79 73 29 28 6c 65 (length keys)(le
7c40: 6e 67 74 68 20 28 73 74 72 69 6e 67 2d 73 70 6c ngth (string-spl
7c50: 69 74 20 69 74 65 6d 2d 70 61 74 68 20 22 2f 22 it item-path "/"
7c60: 29 29 29 29 0a 09 09 09 09 20 20 20 28 64 69 72 ))))..... (dir
7c70: 2d 74 6f 2d 72 65 6d 20 28 67 65 74 2d 64 69 72 -to-rem (get-dir
7c80: 2d 75 70 2d 6e 20 66 75 6c 6c 70 61 74 68 20 64 -up-n fullpath d
7c90: 69 72 73 2d 63 6f 75 6e 74 29 29 0a 09 09 09 09 irs-count)).....
7ca0: 20 20 20 28 72 65 6d 61 69 6e 69 6e 67 64 20 28 (remainingd (
7cb0: 73 74 72 69 6e 67 2d 73 75 62 73 74 69 74 75 74 string-substitut
7cc0: 65 20 28 72 65 67 65 78 70 20 28 63 6f 6e 63 20 e (regexp (conc
7cd0: 22 5e 22 20 64 69 72 2d 74 6f 2d 72 65 6d 20 22 "^" dir-to-rem "
7ce0: 2f 22 29 29 20 22 22 20 66 75 6c 6c 70 61 74 68 /")) "" fullpath
7cf0: 29 29 0a 09 09 09 09 20 20 20 28 63 6d 64 20 28 ))..... (cmd (
7d00: 63 6f 6e 63 20 22 63 64 20 22 20 64 69 72 2d 74 conc "cd " dir-t
7d10: 6f 2d 72 65 6d 20 22 3b 20 72 6d 64 69 72 20 2d o-rem "; rmdir -
7d20: 70 20 22 20 72 65 6d 61 69 6e 69 6e 67 64 20 29 p " remainingd )
7d30: 29 29 0a 09 09 09 20 20 20 20 20 20 28 69 66 20 )).... (if
7d40: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 66 75 (file-exists? fu
7d50: 6c 6c 70 61 74 68 29 0a 09 09 09 09 20 20 28 62 llpath)..... (b
7d60: 65 67 69 6e 0a 09 09 09 09 20 20 20 20 28 64 65 egin..... (de
7d70: 62 75 67 3a 70 72 69 6e 74 20 31 20 63 6d 64 29 bug:print 1 cmd)
7d80: 0a 09 09 09 09 20 20 20 20 28 73 79 73 74 65 6d ..... (system
7d90: 20 63 6d 64 29 29 29 0a 09 09 09 20 20 20 20 20 cmd)))....
7da0: 20 29 29 0a 09 09 09 20 20 20 20 29 29 29 0a 09 )).... )))..
7db0: 09 20 20 20 20 74 65 73 74 73 29 29 29 0a 09 20 . tests)))..
7dc0: 20 20 28 6c 65 74 20 28 28 72 65 6d 74 65 73 74 (let ((remtest
7dd0: 73 20 28 64 62 2d 67 65 74 2d 74 65 73 74 73 2d s (db-get-tests-
7de0: 66 6f 72 2d 72 75 6e 20 64 62 20 28 64 62 3a 67 for-run db (db:g
7df0: 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 et-value-by-head
7e00: 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 69 er run header "i
7e10: 64 22 29 29 29 29 0a 09 20 20 20 20 20 28 69 66 d")))).. (if
7e20: 20 28 6e 75 6c 6c 3f 20 72 65 6d 74 65 73 74 73 (null? remtests
7e30: 29 20 3b 3b 20 6e 6f 20 6d 6f 72 65 20 74 65 73 ) ;; no more tes
7e40: 74 73 20 72 65 6d 61 69 6e 69 6e 67 0a 09 09 20 ts remaining...
7e50: 28 6c 65 74 2a 20 28 28 64 70 61 72 74 73 20 20 (let* ((dparts
7e60: 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 6c 61 (string-split la
7e70: 73 74 74 70 61 74 68 20 22 2f 22 29 29 0a 09 09 sttpath "/"))...
7e80: 09 28 72 75 6e 70 61 74 68 20 28 63 6f 6e 63 20 .(runpath (conc
7e90: 22 2f 22 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 "/" (string-inte
7ea0: 72 73 70 65 72 73 65 20 0a 09 09 09 09 09 20 20 rsperse ......
7eb0: 20 20 28 74 61 6b 65 20 64 70 61 72 74 73 20 28 (take dparts (
7ec0: 2d 20 28 6c 65 6e 67 74 68 20 64 70 61 72 74 73 - (length dparts
7ed0: 29 20 31 29 29 0a 09 09 09 09 09 20 20 20 20 22 ) 1))...... "
7ee0: 2f 22 29 29 29 29 0a 09 09 20 20 20 28 64 65 62 /"))))... (deb
7ef0: 75 67 3a 70 72 69 6e 74 20 31 20 22 52 65 6d 6f ug:print 1 "Remo
7f00: 76 69 6e 67 20 72 75 6e 3a 20 22 20 72 75 6e 6b ving run: " runk
7f10: 65 79 20 22 20 22 20 28 64 62 3a 67 65 74 2d 76 ey " " (db:get-v
7f20: 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 alue-by-header r
7f30: 75 6e 20 68 65 61 64 65 72 20 22 72 75 6e 6e 61 un header "runna
7f40: 6d 65 22 29 29 0a 09 09 20 20 20 28 64 62 3a 64 me"))... (db:d
7f50: 65 6c 65 74 65 2d 72 75 6e 20 64 62 20 72 75 6e elete-run db run
7f60: 2d 69 64 29 0a 09 09 20 20 20 3b 3b 20 6e 65 65 -id)... ;; nee
7f70: 64 20 74 6f 20 66 69 67 75 72 65 20 6f 75 74 20 d to figure out
7f80: 74 68 65 20 70 61 74 68 20 74 6f 20 74 68 65 20 the path to the
7f90: 72 75 6e 20 64 69 72 20 61 6e 64 20 72 65 6d 6f run dir and remo
7fa0: 76 65 20 69 74 20 69 66 20 65 6d 70 74 79 0a 09 ve it if empty..
7fb0: 09 20 20 20 3b 3b 20 20 20 20 28 69 66 20 28 6e . ;; (if (n
7fc0: 75 6c 6c 3f 20 28 67 6c 6f 62 20 28 63 6f 6e 63 ull? (glob (conc
7fd0: 20 72 75 6e 70 61 74 68 20 22 2f 2a 22 29 29 29 runpath "/*")))
7fe0: 0a 09 09 20 20 20 3b 3b 20 20 20 20 20 20 20 20 ... ;;
7ff0: 28 62 65 67 69 6e 0a 09 09 20 20 20 3b 3b 20 09 (begin... ;; .
8000: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 (debug:print 1
8010: 22 52 65 6d 6f 76 69 6e 67 20 72 75 6e 20 64 69 "Removing run di
8020: 72 20 22 20 72 75 6e 70 61 74 68 29 0a 09 09 20 r " runpath)...
8030: 20 20 3b 3b 20 09 20 28 73 79 73 74 65 6d 20 28 ;; . (system (
8040: 63 6f 6e 63 20 22 72 6d 64 69 72 20 2d 70 20 22 conc "rmdir -p "
8050: 20 72 75 6e 70 61 74 68 29 29 29 29 0a 09 09 20 runpath))))...
8060: 20 20 29 29 29 29 0a 09 20 29 29 0a 20 20 20 20 )))).. )).
8070: 20 72 75 6e 73 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d runs)))..;;====
8080: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8090: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
80a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
80b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
80c0: 3d 3d 0a 3b 3b 20 52 6f 75 74 69 6e 65 73 20 66 ==.;; Routines f
80d0: 6f 72 20 6d 61 6e 69 70 75 6c 61 74 69 6e 67 20 or manipulating
80e0: 72 75 6e 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d runs.;;=========
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 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b =============..;
8130: 3b 20 53 69 6e 63 65 20 6d 61 6e 79 20 63 61 6c ; Since many cal
8140: 6c 73 20 74 6f 20 61 20 72 75 6e 20 72 65 71 75 ls to a run requ
8150: 69 72 65 20 70 72 65 74 74 79 20 6d 75 63 68 20 ire pretty much
8160: 74 68 65 20 73 61 6d 65 20 73 65 74 75 70 20 0a the same setup .
8170: 3b 3b 20 74 68 69 73 20 77 72 61 70 70 65 72 20 ;; this wrapper
8180: 69 73 20 75 73 65 64 20 74 6f 20 72 65 64 75 63 is used to reduc
8190: 65 20 74 68 65 20 72 65 70 6c 69 63 61 74 69 6f e the replicatio
81a0: 6e 20 6f 66 20 63 6f 64 65 0a 28 64 65 66 69 6e n of code.(defin
81b0: 65 20 28 67 65 6e 65 72 61 6c 2d 72 75 6e 2d 63 e (general-run-c
81c0: 61 6c 6c 20 73 77 69 74 63 68 6e 61 6d 65 20 61 all switchname a
81d0: 63 74 69 6f 6e 2d 64 65 73 63 20 70 72 6f 63 29 ction-desc proc)
81e0: 0a 20 20 28 69 66 20 28 6e 6f 74 20 28 61 72 67 . (if (not (arg
81f0: 73 3a 67 65 74 2d 61 72 67 20 22 3a 72 75 6e 6e s:get-arg ":runn
8200: 61 6d 65 22 29 29 0a 20 20 20 20 20 20 28 62 65 ame")). (be
8210: 67 69 6e 0a 09 28 64 65 62 75 67 3a 70 72 69 6e gin..(debug:prin
8220: 74 20 30 20 22 45 52 52 4f 52 3a 20 4d 69 73 73 t 0 "ERROR: Miss
8230: 69 6e 67 20 72 65 71 75 69 72 65 64 20 70 61 72 ing required par
8240: 61 6d 65 74 65 72 20 66 6f 72 20 22 20 73 77 69 ameter for " swi
8250: 74 63 68 6e 61 6d 65 20 22 2c 20 79 6f 75 20 6d tchname ", you m
8260: 75 73 74 20 73 70 65 63 69 66 79 20 74 68 65 20 ust specify the
8270: 72 75 6e 20 6e 61 6d 65 20 77 69 74 68 20 3a 72 run name with :r
8280: 75 6e 6e 61 6d 65 20 72 75 6e 6e 61 6d 65 22 29 unname runname")
8290: 0a 09 28 65 78 69 74 20 32 29 29 0a 20 20 20 20 ..(exit 2)).
82a0: 20 20 28 6c 65 74 20 28 28 64 62 20 23 66 29 29 (let ((db #f))
82b0: 0a 09 28 69 66 20 28 6e 6f 74 20 28 73 65 74 75 ..(if (not (setu
82c0: 70 2d 66 6f 72 2d 72 75 6e 29 29 0a 09 20 20 20 p-for-run))..
82d0: 20 28 62 65 67 69 6e 20 0a 09 20 20 20 20 20 20 (begin ..
82e0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
82f0: 46 61 69 6c 65 64 20 74 6f 20 73 65 74 75 70 2c Failed to setup,
8300: 20 65 78 69 74 69 6e 67 22 29 0a 09 20 20 20 20 exiting")..
8310: 20 20 28 65 78 69 74 20 31 29 29 29 0a 09 28 73 (exit 1)))..(s
8320: 65 74 21 20 64 62 20 28 6f 70 65 6e 2d 64 62 29 et! db (open-db)
8330: 29 0a 09 28 69 66 20 28 6e 6f 74 20 28 63 61 72 )..(if (not (car
8340: 20 2a 63 6f 6e 66 69 67 69 6e 66 6f 2a 29 29 0a *configinfo*)).
8350: 09 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 . (begin..
8360: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
8370: 30 20 22 45 52 52 4f 52 3a 20 41 74 74 65 6d 70 0 "ERROR: Attemp
8380: 74 65 64 20 74 6f 20 22 20 61 63 74 69 6f 6e 2d ted to " action-
8390: 64 65 73 63 20 22 20 62 75 74 20 72 75 6e 20 61 desc " but run a
83a0: 72 65 61 20 63 6f 6e 66 69 67 20 66 69 6c 65 20 rea config file
83b0: 6e 6f 74 20 66 6f 75 6e 64 22 29 0a 09 20 20 20 not found")..
83c0: 20 20 20 28 65 78 69 74 20 31 29 29 0a 09 20 20 (exit 1))..
83d0: 20 20 3b 3b 20 45 78 74 72 61 63 74 20 6f 75 74 ;; Extract out
83e0: 20 73 74 75 66 66 20 6e 65 65 64 65 64 20 69 6e stuff needed in
83f0: 20 6d 6f 73 74 20 6f 72 20 6d 61 6e 79 20 63 61 most or many ca
8400: 6c 6c 73 0a 09 20 20 20 20 3b 3b 20 68 65 72 65 lls.. ;; here
8410: 20 74 68 65 6e 20 63 61 6c 6c 20 70 72 6f 63 0a then call proc.
8420: 09 20 20 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 . (let* ((key
8430: 73 20 20 20 20 20 20 20 28 64 62 2d 67 65 74 2d s (db-get-
8440: 6b 65 79 73 20 64 62 29 29 0a 09 09 20 20 20 28 keys db))... (
8450: 6b 65 79 6e 61 6d 65 73 20 20 20 28 6d 61 70 20 keynames (map
8460: 6b 65 79 3a 67 65 74 2d 66 69 65 6c 64 6e 61 6d key:get-fieldnam
8470: 65 20 6b 65 79 73 29 29 0a 09 09 20 20 20 28 6b e keys))... (k
8480: 65 79 76 61 6c 6c 73 74 20 20 28 6b 65 79 73 2d eyvallst (keys-
8490: 3e 76 61 6c 6c 69 73 74 20 6b 65 79 73 20 23 74 >vallist keys #t
84a0: 29 29 29 0a 09 20 20 20 20 20 20 28 70 72 6f 63 ))).. (proc
84b0: 20 64 62 20 6b 65 79 73 20 6b 65 79 6e 61 6d 65 db keys keyname
84c0: 73 20 6b 65 79 76 61 6c 6c 73 74 29 29 29 0a 09 s keyvallst)))..
84d0: 28 73 71 6c 69 74 65 33 3a 66 69 6e 61 6c 69 7a (sqlite3:finaliz
84e0: 65 21 20 64 62 29 0a 09 28 73 65 74 21 20 2a 64 e! db)..(set! *d
84f0: 69 64 73 6f 6d 65 74 68 69 6e 67 2a 20 23 74 29 idsomething* #t)
8500: 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d )))..;;=========
8510: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8520: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8530: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8540: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
8550: 20 52 6f 6c 6c 75 70 20 72 75 6e 73 0a 3b 3b 3d Rollup runs.;;=
8560: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
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 0a 0a 3b 3b 20 55 70 64 61 74 65 =====..;; Update
85b0: 20 74 68 65 20 74 65 73 74 5f 6d 65 74 61 20 74 the test_meta t
85c0: 61 62 6c 65 20 66 6f 72 20 74 68 69 73 20 74 65 able for this te
85d0: 73 74 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 st.(define (runs
85e0: 3a 75 70 64 61 74 65 2d 74 65 73 74 5f 6d 65 74 :update-test_met
85f0: 61 20 64 62 20 74 65 73 74 2d 6e 61 6d 65 20 74 a db test-name t
8600: 65 73 74 2d 63 6f 6e 66 29 0a 20 20 28 6c 65 74 est-conf). (let
8610: 20 28 28 63 75 72 72 72 65 63 6f 72 64 20 28 64 ((currrecord (d
8620: 62 3a 74 65 73 74 6d 65 74 61 2d 67 65 74 2d 72 b:testmeta-get-r
8630: 65 63 6f 72 64 20 64 62 20 74 65 73 74 2d 6e 61 ecord db test-na
8640: 6d 65 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e me))). (if (n
8650: 6f 74 20 63 75 72 72 72 65 63 6f 72 64 29 0a 09 ot currrecord)..
8660: 28 62 65 67 69 6e 0a 09 20 20 28 73 65 74 21 20 (begin.. (set!
8670: 63 75 72 72 72 65 63 6f 72 64 20 28 6d 61 6b 65 currrecord (make
8680: 2d 76 65 63 74 6f 72 20 31 30 20 23 66 29 29 0a -vector 10 #f)).
8690: 09 20 20 28 64 62 3a 74 65 73 74 6d 65 74 61 2d . (db:testmeta-
86a0: 61 64 64 2d 72 65 63 6f 72 64 20 64 62 20 74 65 add-record db te
86b0: 73 74 2d 6e 61 6d 65 29 29 29 0a 20 20 20 20 28 st-name))). (
86c0: 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 20 28 for-each . (
86d0: 6c 61 6d 62 64 61 20 28 6b 65 79 29 0a 20 20 20 lambda (key).
86e0: 20 20 20 20 28 6c 65 74 2a 20 28 28 69 64 78 20 (let* ((idx
86f0: 28 63 61 64 72 20 6b 65 79 29 29 0a 09 20 20 20 (cadr key))..
8700: 20 20 20 28 66 6c 64 20 28 63 61 72 20 20 6b 65 (fld (car ke
8710: 79 29 29 0a 09 20 20 20 20 20 20 28 76 61 6c 20 y)).. (val
8720: 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 74 (config-lookup t
8730: 65 73 74 2d 63 6f 6e 66 20 22 74 65 73 74 5f 6d est-conf "test_m
8740: 65 74 61 22 20 66 6c 64 29 29 29 0a 09 20 28 69 eta" fld))).. (i
8750: 66 20 28 61 6e 64 20 76 61 6c 20 28 6e 6f 74 20 f (and val (not
8760: 28 65 71 75 61 6c 3f 20 28 76 65 63 74 6f 72 2d (equal? (vector-
8770: 72 65 66 20 63 75 72 72 72 65 63 6f 72 64 20 69 ref currrecord i
8780: 64 78 29 20 76 61 6c 29 29 29 0a 09 20 20 20 20 dx) val)))..
8790: 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 20 (begin..
87a0: 28 70 72 69 6e 74 20 22 55 70 64 61 74 69 6e 67 (print "Updating
87b0: 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 22 " test-name " "
87c0: 20 66 6c 64 20 22 20 74 6f 20 22 20 76 61 6c 29 fld " to " val)
87d0: 0a 09 20 20 20 20 20 20 20 28 64 62 3a 74 65 73 .. (db:tes
87e0: 74 6d 65 74 61 2d 75 70 64 61 74 65 2d 66 69 65 tmeta-update-fie
87f0: 6c 64 20 64 62 20 74 65 73 74 2d 6e 61 6d 65 20 ld db test-name
8800: 66 6c 64 20 76 61 6c 29 29 29 29 29 0a 20 20 20 fld val))))).
8810: 20 20 27 28 28 22 61 75 74 68 6f 72 22 20 32 29 '(("author" 2)
8820: 28 22 6f 77 6e 65 72 22 20 33 29 28 22 64 65 73 ("owner" 3)("des
8830: 63 72 69 70 74 69 6f 6e 22 20 34 29 28 22 72 65 cription" 4)("re
8840: 76 69 65 77 65 64 22 20 35 29 28 22 74 61 67 73 viewed" 5)("tags
8850: 22 20 39 29 29 29 29 29 0a 0a 3b 3b 20 55 70 64 " 9)))))..;; Upd
8860: 61 74 65 20 74 65 73 74 5f 6d 65 74 61 20 66 6f ate test_meta fo
8870: 72 20 61 6c 6c 20 74 65 73 74 73 0a 28 64 65 66 r all tests.(def
8880: 69 6e 65 20 28 72 75 6e 73 3a 75 70 64 61 74 65 ine (runs:update
8890: 2d 61 6c 6c 2d 74 65 73 74 5f 6d 65 74 61 20 64 -all-test_meta d
88a0: 62 29 0a 20 20 28 6c 65 74 20 28 28 74 65 73 74 b). (let ((test
88b0: 2d 6e 61 6d 65 73 20 28 67 65 74 2d 61 6c 6c 2d -names (get-all-
88c0: 6c 65 67 61 6c 2d 74 65 73 74 73 29 29 29 0a 20 legal-tests))).
88d0: 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 (for-each .
88e0: 20 20 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 (lambda (test
88f0: 2d 6e 61 6d 65 29 0a 20 20 20 20 20 20 20 28 6c -name). (l
8900: 65 74 2a 20 28 28 74 65 73 74 2d 70 61 74 68 20 et* ((test-path
8910: 20 20 20 28 63 6f 6e 63 20 2a 74 6f 70 70 61 74 (conc *toppat
8920: 68 2a 20 22 2f 74 65 73 74 73 2f 22 20 74 65 73 h* "/tests/" tes
8930: 74 2d 6e 61 6d 65 29 29 0a 09 20 20 20 20 20 20 t-name))..
8940: 28 74 65 73 74 2d 63 6f 6e 66 69 67 66 20 28 63 (test-configf (c
8950: 6f 6e 63 20 74 65 73 74 2d 70 61 74 68 20 22 2f onc test-path "/
8960: 74 65 73 74 63 6f 6e 66 69 67 22 29 29 0a 09 20 testconfig"))..
8970: 20 20 20 20 20 28 74 65 73 74 65 78 69 73 74 73 (testexists
8980: 20 20 20 28 61 6e 64 20 28 66 69 6c 65 2d 65 78 (and (file-ex
8990: 69 73 74 73 3f 20 74 65 73 74 2d 63 6f 6e 66 69 ists? test-confi
89a0: 67 66 29 28 66 69 6c 65 2d 72 65 61 64 2d 61 63 gf)(file-read-ac
89b0: 63 65 73 73 3f 20 74 65 73 74 2d 63 6f 6e 66 69 cess? test-confi
89c0: 67 66 29 29 29 0a 09 20 20 20 20 20 20 3b 3b 20 gf))).. ;;
89d0: 72 65 61 64 20 63 6f 6e 66 69 67 73 20 77 69 74 read configs wit
89e0: 68 20 74 72 69 63 6b 73 20 74 75 72 6e 65 64 20 h tricks turned
89f0: 6f 66 66 20 28 69 2e 65 2e 20 6e 6f 20 73 79 73 off (i.e. no sys
8a00: 74 65 6d 29 0a 09 20 20 20 20 20 20 28 74 65 73 tem).. (tes
8a10: 74 2d 63 6f 6e 66 20 20 20 20 28 69 66 20 74 65 t-conf (if te
8a20: 73 74 65 78 69 73 74 73 20 28 72 65 61 64 2d 63 stexists (read-c
8a30: 6f 6e 66 69 67 20 74 65 73 74 2d 63 6f 6e 66 69 onfig test-confi
8a40: 67 66 20 23 66 20 23 66 29 28 6d 61 6b 65 2d 68 gf #f #f)(make-h
8a50: 61 73 68 2d 74 61 62 6c 65 29 29 29 29 0a 09 20 ash-table))))..
8a60: 28 72 75 6e 73 3a 75 70 64 61 74 65 2d 74 65 73 (runs:update-tes
8a70: 74 5f 6d 65 74 61 20 64 62 20 74 65 73 74 2d 6e t_meta db test-n
8a80: 61 6d 65 20 74 65 73 74 2d 63 6f 6e 66 29 29 29 ame test-conf)))
8a90: 0a 20 20 20 20 20 74 65 73 74 2d 6e 61 6d 65 73 . test-names
8aa0: 29 29 29 0a 09 20 0a 28 64 65 66 69 6e 65 20 28 ))).. .(define (
8ab0: 72 75 6e 73 3a 72 6f 6c 6c 75 70 2d 72 75 6e 20 runs:rollup-run
8ac0: 64 62 20 6b 65 79 73 20 6b 65 79 6e 61 6d 65 73 db keys keynames
8ad0: 20 6b 65 79 76 61 6c 6c 73 74 20 6e 29 0a 20 20 keyvallst n).
8ae0: 28 6c 65 74 2a 20 28 28 6e 65 77 2d 72 75 6e 2d (let* ((new-run-
8af0: 69 64 20 20 20 28 72 65 67 69 73 74 65 72 2d 72 id (register-r
8b00: 75 6e 20 64 62 20 6b 65 79 73 29 29 0a 09 20 28 un db keys)).. (
8b10: 73 69 6d 69 6c 61 72 2d 72 75 6e 73 20 28 64 62 similar-runs (db
8b20: 3a 67 65 74 2d 72 75 6e 73 20 64 62 20 6b 65 79 :get-runs db key
8b30: 73 29 29 0a 09 20 28 74 65 73 74 73 2d 6e 2d 64 s)).. (tests-n-d
8b40: 61 79 73 20 28 64 62 3a 67 65 74 2d 74 65 73 74 ays (db:get-test
8b50: 73 2d 6e 2d 64 61 79 73 20 64 62 20 73 69 6d 69 s-n-days db simi
8b60: 6c 61 72 2d 72 75 6e 73 29 29 29 0a 20 20 20 20 lar-runs))).
8b70: 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 20 (for-each .
8b80: 28 6c 61 6d 62 64 61 20 28 74 65 73 74 2d 69 64 (lambda (test-id
8b90: 29 0a 20 20 20 20 20 20 20 28 64 62 3a 72 6f 6c ). (db:rol
8ba0: 6c 75 70 2d 74 65 73 74 20 64 62 20 72 75 6e 2d lup-test db run-
8bb0: 69 64 20 74 65 73 74 2d 69 64 29 29 0a 20 20 20 id test-id)).
8bc0: 20 20 74 65 73 74 73 2d 6e 2d 64 61 79 73 29 29 tests-n-days))
8bd0: 29 0a ).