0000: 0a 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 32 30 .;; Copyright 20
0010: 30 36 2d 32 30 31 31 2c 20 4d 61 74 74 68 65 77 06-2011, Matthew
0020: 20 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 0a 3b 3b Welland..;; .;;
0030: 20 20 54 68 69 73 20 70 72 6f 67 72 61 6d 20 69 This program i
0040: 73 20 6d 61 64 65 20 61 76 61 69 6c 61 62 6c 65 s made available
0050: 20 75 6e 64 65 72 20 74 68 65 20 47 4e 55 20 47 under the GNU G
0060: 50 4c 20 76 65 72 73 69 6f 6e 20 32 2e 30 20 6f PL version 2.0 o
0070: 72 0a 3b 3b 20 20 67 72 65 61 74 65 72 2e 20 53 r.;; greater. S
0080: 65 65 20 74 68 65 20 61 63 63 6f 6d 70 61 6e 79 ee the accompany
0090: 69 6e 67 20 66 69 6c 65 20 43 4f 50 59 49 4e 47 ing file COPYING
00a0: 20 66 6f 72 20 64 65 74 61 69 6c 73 2e 0a 3b 3b for details..;;
00b0: 20 0a 3b 3b 20 20 54 68 69 73 20 70 72 6f 67 72 .;; This progr
00c0: 61 6d 20 69 73 20 64 69 73 74 72 69 62 75 74 65 am is distribute
00d0: 64 20 57 49 54 48 4f 55 54 20 41 4e 59 20 57 41 d WITHOUT ANY WA
00e0: 52 52 41 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 RRANTY; without
00f0: 65 76 65 6e 20 74 68 65 0a 3b 3b 20 20 69 6d 70 even the.;; imp
0100: 6c 69 65 64 20 77 61 72 72 61 6e 74 79 20 6f 66 lied warranty of
0110: 20 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 MERCHANTABILITY
0120: 20 6f 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 or FITNESS FOR
0130: 41 20 50 41 52 54 49 43 55 4c 41 52 0a 3b 3b 20 A PARTICULAR.;;
0140: 20 50 55 52 50 4f 53 45 2e 0a 0a 3b 3b 20 20 73 PURPOSE...;; s
0150: 74 72 66 74 69 6d 65 28 27 25 6d 2f 25 64 2f 25 trftime('%m/%d/%
0160: 59 20 25 48 3a 25 4d 3a 25 53 27 2c 27 6e 6f 77 Y %H:%M:%S','now
0170: 27 2c 27 6c 6f 63 61 6c 74 69 6d 65 27 29 0a 0a ','localtime')..
0180: 28 75 73 65 20 73 71 6c 69 74 65 33 20 73 72 66 (use sqlite3 srf
0190: 69 2d 31 20 70 6f 73 69 78 20 72 65 67 65 78 20 i-1 posix regex
01a0: 72 65 67 65 78 2d 63 61 73 65 20 73 72 66 69 2d regex-case srfi-
01b0: 36 39 20 64 6f 74 2d 6c 6f 63 6b 69 6e 67 29 0a 69 dot-locking).
01c0: 28 69 6d 70 6f 72 74 20 28 70 72 65 66 69 78 20 (import (prefix
01d0: 73 71 6c 69 74 65 33 20 73 71 6c 69 74 65 33 3a sqlite3 sqlite3:
01e0: 29 29 0a 0a 28 64 65 63 6c 61 72 65 20 28 75 6e ))..(declare (un
01f0: 69 74 20 72 75 6e 73 29 29 0a 28 64 65 63 6c 61 it runs)).(decla
0200: 72 65 20 28 75 73 65 73 20 64 62 29 29 0a 28 64 re (uses db)).(d
0210: 65 63 6c 61 72 65 20 28 75 73 65 73 20 63 6f 6d eclare (uses com
0220: 6d 6f 6e 29 29 0a 28 64 65 63 6c 61 72 65 20 28 mon)).(declare (
0230: 75 73 65 73 20 69 74 65 6d 73 29 29 0a 28 64 65 uses items)).(de
0240: 63 6c 61 72 65 20 28 75 73 65 73 20 72 75 6e 63 clare (uses runc
0250: 6f 6e 66 69 67 29 29 0a 28 64 65 63 6c 61 72 65 onfig)).(declare
0260: 20 28 75 73 65 73 20 74 65 73 74 73 29 29 0a 0a (uses tests))..
0270: 28 69 6e 63 6c 75 64 65 20 22 63 6f 6d 6d 6f 6e (include "common
0280: 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a 28 _records.scm").(
0290: 69 6e 63 6c 75 64 65 20 22 6b 65 79 5f 72 65 63 include "key_rec
02a0: 6f 72 64 73 2e 73 63 6d 22 29 0a 28 69 6e 63 6c ords.scm").(incl
02b0: 75 64 65 20 22 64 62 5f 72 65 63 6f 72 64 73 2e ude "db_records.
02c0: 73 63 6d 22 29 0a 28 69 6e 63 6c 75 64 65 20 22 scm").(include "
02d0: 72 75 6e 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 run_records.scm"
02e0: 29 0a 0a 3b 3b 20 73 74 75 66 66 20 74 6f 20 62 )..;; stuff to b
02f0: 65 20 64 65 70 72 65 63 61 74 65 64 20 74 68 65 e deprecated the
0300: 6e 20 72 65 6d 6f 76 65 64 0a 28 69 6e 63 6c 75 n removed.(inclu
0310: 64 65 20 22 6f 6c 64 2d 72 75 6e 73 2e 73 63 6d de "old-runs.scm
0320: 22 29 0a 0a 0a 3b 3b 20 72 75 6e 73 3a 67 65 74 ")...;; runs:get
0330: 2d 72 75 6e 73 2d 62 79 2d 70 61 74 74 0a 3b 3b -runs-by-patt.;;
0340: 20 67 65 74 20 72 75 6e 73 20 62 79 20 6c 69 73 get runs by lis
0350: 74 20 6f 66 20 63 72 69 74 65 72 69 61 0a 3b 3b t of criteria.;;
0360: 20 72 65 67 69 73 74 65 72 20 61 20 74 65 73 74 register a test
0370: 20 72 75 6e 20 77 69 74 68 20 74 68 65 20 64 62 run with the db
0380: 0a 3b 3b 0a 3b 3b 20 55 73 65 3a 20 28 64 62 2d .;;.;; Use: (db-
0390: 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 get-value-by-hea
03a0: 64 65 72 20 28 64 62 3a 67 65 74 2d 68 65 61 64 der (db:get-head
03b0: 65 72 20 72 75 6e 69 6e 66 6f 29 28 64 62 3a 67 er runinfo)(db:g
03c0: 65 74 2d 72 6f 77 20 72 75 6e 69 6e 66 6f 29 29 et-row runinfo))
03d0: 0a 3b 3b 20 20 74 6f 20 65 78 74 72 61 63 74 20 .;; to extract
03e0: 69 6e 66 6f 20 66 72 6f 6d 20 74 68 65 20 73 74 info from the st
03f0: 72 75 63 74 75 72 65 20 72 65 74 75 72 6e 65 64 ructure returned
0400: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 72 75 6e .;;.(define (run
0410: 73 3a 67 65 74 2d 72 75 6e 73 2d 62 79 2d 70 61 s:get-runs-by-pa
0420: 74 74 20 64 62 20 6b 65 79 73 20 72 75 6e 6e 61 tt db keys runna
0430: 6d 65 70 61 74 74 20 2e 20 70 61 72 61 6d 73 29 mepatt . params)
0440: 20 3b 3b 20 74 65 73 74 2d 6e 61 6d 65 29 0a 20 ;; test-name).
0450: 20 28 6c 65 74 2a 20 28 28 6b 65 79 76 61 6c 6c (let* ((keyvall
0460: 73 74 20 28 6b 65 79 73 2d 3e 76 61 6c 6c 69 73 st (keys->vallis
0470: 74 20 6b 65 79 73 29 29 0a 09 20 28 74 6d 70 20 t keys)).. (tmp
0480: 20 20 20 20 20 28 72 75 6e 73 3a 67 65 74 2d 73 (runs:get-s
0490: 74 64 2d 72 75 6e 2d 66 69 65 6c 64 73 20 6b 65 td-run-fields ke
04a0: 79 73 20 27 28 22 69 64 22 20 22 72 75 6e 6e 61 ys '("id" "runna
04b0: 6d 65 22 20 22 73 74 61 74 65 22 20 22 73 74 61 me" "state" "sta
04c0: 74 75 73 22 20 22 6f 77 6e 65 72 22 20 22 65 76 tus" "owner" "ev
04d0: 65 6e 74 5f 74 69 6d 65 22 29 29 29 0a 09 20 28 ent_time"))).. (
04e0: 6b 65 79 73 74 72 20 20 20 28 63 61 72 20 74 6d keystr (car tm
04f0: 70 29 29 0a 09 20 28 68 65 61 64 65 72 20 20 20 p)).. (header
0500: 28 63 61 64 72 20 74 6d 70 29 29 0a 09 20 28 72 (cadr tmp)).. (r
0510: 65 73 20 20 20 20 20 27 28 29 29 0a 09 20 28 6b es '()).. (k
0520: 65 79 2d 70 61 74 74 20 22 22 29 29 0a 20 20 20 ey-patt "")).
0530: 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 (for-each (lamb
0540: 64 61 20 28 6b 65 79 76 61 6c 29 0a 09 09 28 6c da (keyval)...(l
0550: 65 74 2a 20 28 28 6b 65 79 20 20 20 20 28 76 65 et* ((key (ve
0560: 63 74 6f 72 2d 72 65 66 20 6b 65 79 76 61 6c 20 ctor-ref keyval
0570: 30 29 29 0a 09 09 20 20 20 20 20 20 20 28 66 75 0))... (fu
0580: 6c 6b 65 79 20 28 63 6f 6e 63 20 22 3a 22 20 6b lkey (conc ":" k
0590: 65 79 29 29 0a 09 09 20 20 20 20 20 20 20 28 70 ey))... (p
05a0: 61 74 74 20 20 20 28 61 72 67 73 3a 67 65 74 2d att (args:get-
05b0: 61 72 67 20 66 75 6c 6b 65 79 29 29 29 0a 09 09 arg fulkey)))...
05c0: 20 20 28 69 66 20 70 61 74 74 0a 09 09 20 20 20 (if patt...
05d0: 20 20 20 28 73 65 74 21 20 6b 65 79 2d 70 61 74 (set! key-pat
05e0: 74 20 28 63 6f 6e 63 20 6b 65 79 2d 70 61 74 74 t (conc key-patt
05f0: 20 22 20 41 4e 44 20 22 20 6b 65 79 20 22 20 6c " AND " key " l
0600: 69 6b 65 20 27 22 20 70 61 74 74 20 22 27 22 29 ike '" patt "'")
0610: 29 0a 09 09 20 20 20 20 20 20 28 62 65 67 69 6e )... (begin
0620: 0a 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 ....(debug:print
0630: 20 30 20 22 45 52 52 4f 52 3a 20 73 65 61 72 63 0 "ERROR: searc
0640: 68 69 6e 67 20 66 6f 72 20 72 75 6e 73 20 77 69 hing for runs wi
0650: 74 68 20 6e 6f 20 70 61 74 74 65 72 6e 20 73 65 th no pattern se
0660: 74 20 66 6f 72 20 22 20 66 75 6c 6b 65 79 29 0a t for " fulkey).
0670: 09 09 09 28 65 78 69 74 20 36 29 29 29 29 29 0a ...(exit 6))))).
0680: 09 20 20 20 20 20 20 6b 65 79 73 29 0a 20 20 20 . keys).
0690: 20 28 73 71 6c 69 74 65 33 3a 66 6f 72 2d 65 61 (sqlite3:for-ea
06a0: 63 68 2d 72 6f 77 20 0a 20 20 20 20 20 28 6c 61 ch-row . (la
06b0: 6d 62 64 61 20 28 61 20 2e 20 72 29 0a 20 20 20 mbda (a . r).
06c0: 20 20 20 20 28 73 65 74 21 20 72 65 73 20 28 63 (set! res (c
06d0: 6f 6e 73 20 28 6c 69 73 74 2d 3e 76 65 63 74 6f ons (list->vecto
06e0: 72 20 28 63 6f 6e 73 20 61 20 72 29 29 20 72 65 r (cons a r)) re
06f0: 73 29 29 29 0a 20 20 20 20 20 64 62 20 0a 20 20 s))). db .
0700: 20 20 20 28 63 6f 6e 63 20 22 53 45 4c 45 43 54 (conc "SELECT
0710: 20 22 20 6b 65 79 73 74 72 20 22 20 46 52 4f 4d " keystr " FROM
0720: 20 72 75 6e 73 20 57 48 45 52 45 20 72 75 6e 6e runs WHERE runn
0730: 61 6d 65 20 6c 69 6b 65 20 3f 20 22 20 6b 65 79 ame like ? " key
0740: 2d 70 61 74 74 20 22 3b 22 29 0a 20 20 20 20 20 -patt ";").
0750: 72 75 6e 6e 61 6d 65 70 61 74 74 29 0a 20 20 20 runnamepatt).
0760: 20 28 76 65 63 74 6f 72 20 68 65 61 64 65 72 20 (vector header
0770: 72 65 73 29 29 29 0a 0a 3b 3b 20 3b 3b 20 54 4f res)))..;; ;; TO
0780: 44 4f 3a 20 43 6f 6e 76 65 72 67 65 20 74 68 69 DO: Converge thi
0790: 73 20 77 69 74 68 20 64 62 3a 67 65 74 2d 74 65 s with db:get-te
07a0: 73 74 2d 69 6e 66 6f 0a 3b 3b 20 28 64 65 66 69 st-info.;; (defi
07b0: 6e 65 20 28 72 75 6e 73 3a 67 65 74 2d 74 65 73 ne (runs:get-tes
07c0: 74 2d 69 6e 66 6f 20 64 62 20 72 75 6e 2d 69 64 t-info db run-id
07d0: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item-
07e0: 70 61 74 68 29 0a 3b 3b 20 20 20 28 6c 65 74 20 path).;; (let
07f0: 28 28 72 65 73 20 23 66 29 29 20 3b 3b 20 28 76 ((res #f)) ;; (v
0800: 65 63 74 6f 72 20 23 66 20 23 66 20 23 66 20 23 ector #f #f #f #
0810: 66 20 23 66 20 23 66 29 29 29 0a 3b 3b 20 20 20 f #f #f))).;;
0820: 20 20 28 73 71 6c 69 74 65 33 3a 66 6f 72 2d 65 (sqlite3:for-e
0830: 61 63 68 2d 72 6f 77 20 0a 3b 3b 20 20 20 20 20 ach-row .;;
0840: 20 28 6c 61 6d 62 64 61 20 28 69 64 20 72 75 6e (lambda (id run
0850: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 73 74 -id test-name st
0860: 61 74 65 20 73 74 61 74 75 73 29 0a 3b 3b 20 20 ate status).;;
0870: 20 20 20 20 20 20 28 73 65 74 21 20 72 65 73 20 (set! res
0880: 28 76 65 63 74 6f 72 20 69 64 20 72 75 6e 2d 69 (vector id run-i
0890: 64 20 74 65 73 74 2d 6e 61 6d 65 20 73 74 61 74 d test-name stat
08a0: 65 20 73 74 61 74 75 73 20 69 74 65 6d 2d 70 61 e status item-pa
08b0: 74 68 29 29 29 0a 3b 3b 20 20 20 20 20 20 64 62 th))).;; db
08c0: 20 22 53 45 4c 45 43 54 20 69 64 2c 72 75 6e 5f "SELECT id,run_
08d0: 69 64 2c 74 65 73 74 6e 61 6d 65 2c 73 74 61 74 id,testname,stat
08e0: 65 2c 73 74 61 74 75 73 20 46 52 4f 4d 20 74 65 e,status FROM te
08f0: 73 74 73 20 57 48 45 52 45 20 72 75 6e 5f 69 64 sts WHERE run_id
0900: 3d 3f 20 41 4e 44 20 74 65 73 74 6e 61 6d 65 3d =? AND testname=
0910: 3f 20 41 4e 44 20 69 74 65 6d 5f 70 61 74 68 3d ? AND item_path=
0920: 3f 3b 22 0a 3b 3b 20 20 20 20 20 20 72 75 6e 2d ?;".;; run-
0930: 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 id test-name ite
0940: 6d 2d 70 61 74 68 29 0a 3b 3b 20 20 20 20 20 72 m-path).;; r
0950: 65 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 es))..(define (r
0960: 75 6e 73 3a 74 65 73 74 2d 67 65 74 2d 66 75 6c uns:test-get-ful
0970: 6c 2d 70 61 74 68 20 74 65 73 74 29 0a 20 20 28 l-path test). (
0980: 6c 65 74 2a 20 28 28 74 65 73 74 6e 61 6d 65 20 let* ((testname
0990: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 (db:test-get-tes
09a0: 74 6e 61 6d 65 20 20 20 74 65 73 74 29 29 0a 09 tname test))..
09b0: 20 28 69 74 65 6d 70 61 74 68 20 28 64 62 3a 74 (itempath (db:t
09c0: 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 est-get-item-pat
09d0: 68 20 74 65 73 74 29 29 29 0a 20 20 20 20 28 63 h test))). (c
09e0: 6f 6e 63 20 74 65 73 74 6e 61 6d 65 20 28 69 66 onc testname (if
09f0: 20 28 65 71 75 61 6c 3f 20 69 74 65 6d 70 61 74 (equal? itempat
0a00: 68 20 22 22 29 20 22 22 20 28 63 6f 6e 63 20 22 h "") "" (conc "
0a10: 28 22 20 69 74 65 6d 70 61 74 68 20 22 29 22 29 (" itempath ")")
0a20: 29 29 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 ))))...(define (
0a30: 73 65 74 2d 6d 65 67 61 74 65 73 74 2d 65 6e 76 set-megatest-env
0a40: 2d 76 61 72 73 20 64 62 20 72 75 6e 2d 69 64 29 -vars db run-id)
0a50: 0a 20 20 28 6c 65 74 20 28 28 6b 65 79 73 20 28 . (let ((keys (
0a60: 64 62 2d 67 65 74 2d 6b 65 79 73 20 64 62 29 29 db-get-keys db))
0a70: 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 ). (for-each
0a80: 28 6c 61 6d 62 64 61 20 28 6b 65 79 29 0a 09 09 (lambda (key)...
0a90: 28 73 71 6c 69 74 65 33 3a 66 6f 72 2d 65 61 63 (sqlite3:for-eac
0aa0: 68 2d 72 6f 77 0a 09 09 20 28 6c 61 6d 62 64 61 h-row... (lambda
0ab0: 20 28 76 61 6c 29 0a 09 09 20 20 20 28 64 65 62 (val)... (deb
0ac0: 75 67 3a 70 72 69 6e 74 20 32 20 22 73 65 74 65 ug:print 2 "sete
0ad0: 6e 76 20 22 20 28 6b 65 79 3a 67 65 74 2d 66 69 nv " (key:get-fi
0ae0: 65 6c 64 6e 61 6d 65 20 6b 65 79 29 20 22 20 22 eldname key) " "
0af0: 20 76 61 6c 29 0a 09 09 20 20 20 28 73 65 74 65 val)... (sete
0b00: 6e 76 20 28 6b 65 79 3a 67 65 74 2d 66 69 65 6c nv (key:get-fiel
0b10: 64 6e 61 6d 65 20 6b 65 79 29 20 76 61 6c 29 29 dname key) val))
0b20: 0a 09 09 20 64 62 20 0a 09 09 20 28 63 6f 6e 63 ... db ... (conc
0b30: 20 22 53 45 4c 45 43 54 20 22 20 28 6b 65 79 3a "SELECT " (key:
0b40: 67 65 74 2d 66 69 65 6c 64 6e 61 6d 65 20 6b 65 get-fieldname ke
0b50: 79 29 20 22 20 46 52 4f 4d 20 72 75 6e 73 20 57 y) " FROM runs W
0b60: 48 45 52 45 20 69 64 3d 3f 3b 22 29 0a 09 09 20 HERE id=?;")...
0b70: 72 75 6e 2d 69 64 29 29 0a 09 20 20 20 20 20 20 run-id))..
0b80: 6b 65 79 73 29 29 29 0a 0a 28 64 65 66 69 6e 65 keys)))..(define
0b90: 20 28 73 65 74 2d 69 74 65 6d 2d 65 6e 76 2d 76 (set-item-env-v
0ba0: 61 72 73 20 69 74 65 6d 64 61 74 29 0a 20 20 28 ars itemdat). (
0bb0: 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 for-each (lambda
0bc0: 20 28 69 74 65 6d 29 0a 09 20 20 20 20 20 20 28 (item).. (
0bd0: 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 73 debug:print 2 "s
0be0: 65 74 65 6e 76 20 22 20 28 63 61 72 20 69 74 65 etenv " (car ite
0bf0: 6d 29 20 22 20 22 20 28 63 61 64 72 20 69 74 65 m) " " (cadr ite
0c00: 6d 29 29 0a 09 20 20 20 20 20 20 28 73 65 74 65 m)).. (sete
0c10: 6e 76 20 28 63 61 72 20 69 74 65 6d 29 20 28 63 nv (car item) (c
0c20: 61 64 72 20 69 74 65 6d 29 29 29 0a 09 20 20 20 adr item)))..
0c30: 20 69 74 65 6d 64 61 74 29 29 0a 0a 28 64 65 66 itemdat))..(def
0c40: 69 6e 65 20 28 72 75 6e 73 3a 63 61 6e 2d 72 75 ine (runs:can-ru
0c50: 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 20 64 62 29 n-more-tests db)
0c60: 0a 20 20 28 6c 65 74 20 28 28 6e 75 6d 2d 72 75 . (let ((num-ru
0c70: 6e 6e 69 6e 67 20 28 64 62 3a 67 65 74 2d 63 6f nning (db:get-co
0c80: 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e unt-tests-runnin
0c90: 67 20 64 62 29 29 0a 09 28 6d 61 78 2d 63 6f 6e g db))..(max-con
0ca0: 63 75 72 72 65 6e 74 2d 6a 6f 62 73 20 28 63 6f current-jobs (co
0cb0: 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 2a 63 6f 6e nfig-lookup *con
0cc0: 66 69 67 64 61 74 2a 20 22 73 65 74 75 70 22 20 figdat* "setup"
0cd0: 22 6d 61 78 5f 63 6f 6e 63 75 72 72 65 6e 74 5f "max_concurrent_
0ce0: 6a 6f 62 73 22 29 29 29 0a 20 20 20 20 28 64 65 jobs"))). (de
0cf0: 62 75 67 3a 70 72 69 6e 74 20 32 20 22 6d 61 78 bug:print 2 "max
0d00: 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 -concurrent-jobs
0d10: 3a 20 22 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 : " max-concurre
0d20: 6e 74 2d 6a 6f 62 73 20 22 2c 20 6e 75 6d 2d 72 nt-jobs ", num-r
0d30: 75 6e 6e 69 6e 67 3a 20 22 20 6e 75 6d 2d 72 75 unning: " num-ru
0d40: 6e 6e 69 6e 67 29 0a 20 20 20 20 28 69 66 20 28 nning). (if (
0d50: 6e 6f 74 20 28 65 71 3f 20 30 20 2a 67 6c 6f 62 not (eq? 0 *glob
0d60: 61 6c 65 78 69 74 73 74 61 74 75 73 2a 29 29 0a alexitstatus*)).
0d70: 09 23 66 0a 09 28 69 66 20 28 6f 72 20 28 6e 6f .#f..(if (or (no
0d80: 74 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 t max-concurrent
0d90: 2d 6a 6f 62 73 29 0a 09 09 28 61 6e 64 20 6d 61 -jobs)...(and ma
0da0: 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 x-concurrent-job
0db0: 73 0a 09 09 20 20 20 20 20 28 73 74 72 69 6e 67 s... (string
0dc0: 2d 3e 6e 75 6d 62 65 72 20 6d 61 78 2d 63 6f 6e ->number max-con
0dd0: 63 75 72 72 65 6e 74 2d 6a 6f 62 73 29 0a 09 09 current-jobs)...
0de0: 20 20 20 20 20 28 6e 6f 74 20 28 3e 3d 20 6e 75 (not (>= nu
0df0: 6d 2d 72 75 6e 6e 69 6e 67 20 28 73 74 72 69 6e m-running (strin
0e00: 67 2d 3e 6e 75 6d 62 65 72 20 6d 61 78 2d 63 6f g->number max-co
0e10: 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 29 29 29 ncurrent-jobs)))
0e20: 29 29 0a 09 20 20 20 20 23 74 0a 09 20 20 20 20 )).. #t..
0e30: 28 62 65 67 69 6e 20 0a 09 20 20 20 20 20 20 28 (begin .. (
0e40: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 debug:print 0 "W
0e50: 41 52 4e 49 4e 47 3a 20 4d 61 78 20 72 75 6e 6e ARNING: Max runn
0e60: 69 6e 67 20 6a 6f 62 73 20 65 78 63 65 65 64 65 ing jobs exceede
0e70: 64 2c 20 63 75 72 72 65 6e 74 20 6e 75 6d 62 65 d, current numbe
0e80: 72 20 72 75 6e 6e 69 6e 67 3a 20 22 20 6e 75 6d r running: " num
0e90: 2d 72 75 6e 6e 69 6e 67 20 0a 09 09 09 20 20 20 -running ....
0ea0: 22 2c 20 6d 61 78 5f 63 6f 6e 63 75 72 72 65 6e ", max_concurren
0eb0: 74 5f 6a 6f 62 73 3a 20 22 20 6d 61 78 2d 63 6f t_jobs: " max-co
0ec0: 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 29 0a 09 ncurrent-jobs)..
0ed0: 20 20 20 20 20 20 23 66 29 29 29 29 29 0a 0a 0a #f)))))...
0ee0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
0ef0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0f00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0f10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0f20: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4e 65 77 20 ========.;; New
0f30: 6d 65 74 68 6f 64 6f 6c 6f 67 79 2e 20 54 68 65 methodology. The
0f40: 73 65 20 72 6f 75 74 69 6e 65 73 20 77 69 6c 6c se routines will
0f50: 20 72 65 70 6c 61 63 65 20 74 68 65 20 61 62 6f replace the abo
0f60: 76 65 20 69 6e 20 74 69 6d 65 2e 20 46 6f 72 0a ve in time. For.
0f70: 3b 3b 20 6e 6f 77 20 74 68 65 20 63 6f 64 65 20 ;; now the code
0f80: 69 73 20 64 75 70 6c 69 63 61 74 65 64 2e 20 54 is duplicated. T
0f90: 68 69 73 20 73 74 75 66 66 20 69 73 20 69 6e 69 his stuff is ini
0fa0: 74 69 61 6c 6c 79 20 75 73 65 64 20 69 6e 20 74 tially used in t
0fb0: 68 65 20 6d 6f 6e 69 74 6f 72 0a 3b 3b 20 62 61 he monitor.;; ba
0fc0: 73 65 64 20 63 6f 64 65 2e 0a 3b 3b 3d 3d 3d 3d sed code..;;====
0fd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0fe0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0ff0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1000: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1010: 3d 3d 0a 0a 3b 3b 20 72 65 67 69 73 74 65 72 20 ==..;; register
1020: 61 20 74 65 73 74 20 72 75 6e 20 77 69 74 68 20 a test run with
1030: 74 68 65 20 64 62 0a 28 64 65 66 69 6e 65 20 28 the db.(define (
1040: 72 75 6e 73 3a 72 65 67 69 73 74 65 72 2d 72 75 runs:register-ru
1050: 6e 20 64 62 20 6b 65 79 73 20 6b 65 79 76 61 6c n db keys keyval
1060: 6c 73 74 20 72 75 6e 6e 61 6d 65 20 73 74 61 74 lst runname stat
1070: 65 20 73 74 61 74 75 73 20 75 73 65 72 29 0a 20 e status user).
1080: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 33 20 (debug:print 3
1090: 22 72 75 6e 73 3a 72 65 67 69 73 74 65 72 2d 72 "runs:register-r
10a0: 75 6e 2c 20 6b 65 79 73 3a 20 22 20 6b 65 79 73 un, keys: " keys
10b0: 20 22 20 6b 65 79 76 61 6c 6c 73 74 3a 20 22 20 " keyvallst: "
10c0: 6b 65 79 76 61 6c 6c 73 74 20 22 20 72 75 6e 6e keyvallst " runn
10d0: 61 6d 65 3a 20 22 20 72 75 6e 6e 61 6d 65 20 22 ame: " runname "
10e0: 20 73 74 61 74 65 3a 20 22 20 73 74 61 74 65 20 state: " state
10f0: 22 20 73 74 61 74 75 73 3a 20 22 20 73 74 61 74 " status: " stat
1100: 75 73 20 22 20 75 73 65 72 3a 20 22 20 75 73 65 us " user: " use
1110: 72 29 0a 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 r). (let* ((key
1120: 73 74 72 20 20 20 20 28 6b 65 79 73 2d 3e 6b 65 str (keys->ke
1130: 79 73 74 72 20 6b 65 79 73 29 29 0a 09 20 28 63 ystr keys)).. (c
1140: 6f 6d 6d 61 20 20 20 20 20 28 69 66 20 28 3e 20 omma (if (>
1150: 28 6c 65 6e 67 74 68 20 6b 65 79 73 29 20 30 29 (length keys) 0)
1160: 20 22 2c 22 20 22 22 29 29 0a 09 20 28 61 6e 64 "," "")).. (and
1170: 73 74 72 20 20 20 20 28 69 66 20 28 3e 20 28 6c str (if (> (l
1180: 65 6e 67 74 68 20 6b 65 79 73 29 20 30 29 20 22 ength keys) 0) "
1190: 20 41 4e 44 20 22 20 22 22 29 29 0a 09 20 28 76 AND " "")).. (v
11a0: 61 6c 73 6c 6f 74 73 20 20 28 6b 65 79 73 2d 3e alslots (keys->
11b0: 76 61 6c 73 6c 6f 74 73 20 6b 65 79 73 29 29 20 valslots keys))
11c0: 3b 3b 20 3f 2c 3f 2c 3f 20 2e 2e 2e 0a 09 20 28 ;; ?,?,? ..... (
11d0: 6b 65 79 76 61 6c 73 20 20 20 28 6d 61 70 20 63 keyvals (map c
11e0: 61 64 72 20 6b 65 79 76 61 6c 6c 73 74 29 29 0a adr keyvallst)).
11f0: 09 20 28 61 6c 6c 76 61 6c 73 20 20 20 28 61 70 . (allvals (ap
1200: 70 65 6e 64 20 28 6c 69 73 74 20 72 75 6e 6e 61 pend (list runna
1210: 6d 65 20 73 74 61 74 65 20 73 74 61 74 75 73 20 me state status
1220: 75 73 65 72 29 20 6b 65 79 76 61 6c 73 29 29 0a user) keyvals)).
1230: 09 20 28 71 72 79 76 61 6c 73 20 20 20 28 61 70 . (qryvals (ap
1240: 70 65 6e 64 20 28 6c 69 73 74 20 72 75 6e 6e 61 pend (list runna
1250: 6d 65 29 20 6b 65 79 76 61 6c 73 29 29 0a 09 20 me) keyvals))..
1260: 28 6b 65 79 3d 3f 73 74 72 20 20 28 73 74 72 69 (key=?str (stri
1270: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 ng-intersperse (
1280: 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 6b 29 28 map (lambda (k)(
1290: 63 6f 6e 63 20 28 6b 65 79 3a 67 65 74 2d 66 69 conc (key:get-fi
12a0: 65 6c 64 6e 61 6d 65 20 6b 29 20 22 3d 3f 22 29 eldname k) "=?")
12b0: 29 20 6b 65 79 73 29 20 22 20 41 4e 44 20 22 29 ) keys) " AND ")
12c0: 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 )). (debug:pr
12d0: 69 6e 74 20 33 20 22 6b 65 79 73 3a 20 22 20 6b int 3 "keys: " k
12e0: 65 79 73 20 22 20 61 6c 6c 76 61 6c 73 3a 20 22 eys " allvals: "
12f0: 20 61 6c 6c 76 61 6c 73 20 22 20 6b 65 79 76 61 allvals " keyva
1300: 6c 73 3a 20 22 20 6b 65 79 76 61 6c 73 29 0a 20 ls: " keyvals).
1310: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
1320: 32 20 22 4e 4f 54 45 3a 20 75 73 69 6e 67 20 74 2 "NOTE: using t
1330: 61 72 67 65 74 20 22 20 28 73 74 72 69 6e 67 2d arget " (string-
1340: 69 6e 74 65 72 73 70 65 72 73 65 20 6b 65 79 76 intersperse keyv
1350: 61 6c 73 20 22 2f 22 29 20 22 20 66 6f 72 20 74 als "/") " for t
1360: 68 69 73 20 72 75 6e 22 29 0a 20 20 20 20 28 69 his run"). (i
1370: 66 20 28 61 6e 64 20 72 75 6e 6e 61 6d 65 20 28 f (and runname (
1380: 6e 75 6c 6c 3f 20 28 66 69 6c 74 65 72 20 28 6c null? (filter (l
1390: 61 6d 62 64 61 20 28 78 29 28 6e 6f 74 20 78 29 ambda (x)(not x)
13a0: 29 20 6b 65 79 76 61 6c 73 29 29 29 20 3b 3b 20 ) keyvals))) ;;
13b0: 74 68 65 72 65 20 6d 75 73 74 20 62 65 20 61 20 there must be a
13c0: 62 65 74 74 65 72 20 77 61 79 20 74 6f 20 22 61 better way to "a
13d0: 70 70 6c 79 20 61 6e 64 22 0a 09 28 6c 65 74 20 pply and"..(let
13e0: 28 28 72 65 73 20 23 66 29 29 0a 09 20 20 28 61 ((res #f)).. (a
13f0: 70 70 6c 79 20 73 71 6c 69 74 65 33 3a 65 78 65 pply sqlite3:exe
1400: 63 75 74 65 20 64 62 20 28 63 6f 6e 63 20 22 49 cute db (conc "I
1410: 4e 53 45 52 54 20 4f 52 20 49 47 4e 4f 52 45 20 NSERT OR IGNORE
1420: 49 4e 54 4f 20 72 75 6e 73 20 28 72 75 6e 6e 61 INTO runs (runna
1430: 6d 65 2c 73 74 61 74 65 2c 73 74 61 74 75 73 2c me,state,status,
1440: 6f 77 6e 65 72 2c 65 76 65 6e 74 5f 74 69 6d 65 owner,event_time
1450: 22 20 63 6f 6d 6d 61 20 6b 65 79 73 74 72 20 22 " comma keystr "
1460: 29 20 56 41 4c 55 45 53 20 28 3f 2c 3f 2c 3f 2c ) VALUES (?,?,?,
1470: 3f 2c 73 74 72 66 74 69 6d 65 28 27 25 73 27 2c ?,strftime('%s',
1480: 27 6e 6f 77 27 29 22 20 63 6f 6d 6d 61 20 76 61 'now')" comma va
1490: 6c 73 6c 6f 74 73 20 22 29 3b 22 29 0a 09 09 20 lslots ");")...
14a0: 61 6c 6c 76 61 6c 73 29 0a 09 20 20 28 61 70 70 allvals).. (app
14b0: 6c 79 20 73 71 6c 69 74 65 33 3a 66 6f 72 2d 65 ly sqlite3:for-e
14c0: 61 63 68 2d 72 6f 77 20 0a 09 20 20 20 28 6c 61 ach-row .. (la
14d0: 6d 62 64 61 20 28 69 64 29 0a 09 20 20 20 20 20 mbda (id)..
14e0: 28 73 65 74 21 20 72 65 73 20 69 64 29 29 0a 09 (set! res id))..
14f0: 20 20 20 64 62 0a 09 20 20 20 28 6c 65 74 20 28 db.. (let (
1500: 28 71 72 79 20 28 63 6f 6e 63 20 22 53 45 4c 45 (qry (conc "SELE
1510: 43 54 20 69 64 20 46 52 4f 4d 20 72 75 6e 73 20 CT id FROM runs
1520: 57 48 45 52 45 20 28 72 75 6e 6e 61 6d 65 3d 3f WHERE (runname=?
1530: 20 22 20 61 6e 64 73 74 72 20 6b 65 79 3d 3f 73 " andstr key=?s
1540: 74 72 20 22 29 3b 22 29 29 29 0a 09 20 20 20 20 tr ");")))..
1550: 20 3b 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 ;(debug:print 4
1560: 20 22 71 72 79 3a 20 22 20 71 72 79 29 20 0a 09 "qry: " qry) ..
1570: 20 20 20 20 20 71 72 79 29 0a 09 20 20 20 71 72 qry).. qr
1580: 79 76 61 6c 73 29 0a 09 20 20 28 73 71 6c 69 74 yvals).. (sqlit
1590: 65 33 3a 65 78 65 63 75 74 65 20 64 62 20 22 55 e3:execute db "U
15a0: 50 44 41 54 45 20 72 75 6e 73 20 53 45 54 20 73 PDATE runs SET s
15b0: 74 61 74 65 3d 3f 2c 73 74 61 74 75 73 3d 3f 20 tate=?,status=?
15c0: 57 48 45 52 45 20 69 64 3d 3f 3b 22 20 73 74 61 WHERE id=?;" sta
15d0: 74 65 20 73 74 61 74 75 73 20 72 65 73 29 0a 09 te status res)..
15e0: 20 20 72 65 73 29 20 0a 09 28 62 65 67 69 6e 0a res) ..(begin.
15f0: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 . (debug:print
1600: 30 20 22 45 52 52 4f 52 3a 20 43 61 6c 6c 65 64 0 "ERROR: Called
1610: 20 77 69 74 68 6f 75 74 20 61 6c 6c 20 6e 65 63 without all nec
1620: 65 73 73 61 72 79 20 6b 65 79 73 22 29 0a 09 20 essary keys")..
1630: 20 23 66 29 29 29 29 0a 0a 3b 3b 20 54 68 69 73 #f))))..;; This
1640: 20 69 73 20 61 20 64 75 70 6c 69 63 61 74 65 20 is a duplicate
1650: 6f 66 20 72 75 6e 2d 74 65 73 74 73 20 28 77 68 of run-tests (wh
1660: 69 63 68 20 68 61 73 20 62 65 65 6e 20 64 65 70 ich has been dep
1670: 72 65 63 61 74 65 64 29 2e 20 55 73 65 20 74 68 recated). Use th
1680: 69 73 20 6f 6e 65 20 69 6e 73 74 65 61 64 20 6f is one instead o
1690: 66 20 72 75 6e 20 74 65 73 74 73 2e 0a 3b 3b 20 f run tests..;;
16a0: 6b 65 79 76 61 6c 73 0a 28 64 65 66 69 6e 65 20 keyvals.(define
16b0: 28 72 75 6e 73 3a 72 75 6e 2d 74 65 73 74 73 20 (runs:run-tests
16c0: 64 62 20 74 61 72 67 65 74 20 72 75 6e 6e 61 6d db target runnam
16d0: 65 20 74 65 73 74 2d 70 61 74 74 73 20 69 74 65 e test-patts ite
16e0: 6d 2d 70 61 74 74 73 20 75 73 65 72 20 66 6c 61 m-patts user fla
16f0: 67 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 6b 65 gs). (let* ((ke
1700: 79 73 20 20 20 20 20 20 20 20 28 64 62 2d 67 65 ys (db-ge
1710: 74 2d 6b 65 79 73 20 64 62 29 29 0a 09 20 28 6b t-keys db)).. (k
1720: 65 79 76 61 6c 6c 73 74 20 20 20 28 6b 65 79 73 eyvallst (keys
1730: 3a 74 61 72 67 65 74 2d 3e 6b 65 79 76 61 6c 20 :target->keyval
1740: 6b 65 79 73 20 74 61 72 67 65 74 29 29 0a 09 20 keys target))..
1750: 28 72 75 6e 2d 69 64 20 20 20 20 20 20 28 72 75 (run-id (ru
1760: 6e 73 3a 72 65 67 69 73 74 65 72 2d 72 75 6e 20 ns:register-run
1770: 64 62 20 6b 65 79 73 20 6b 65 79 76 61 6c 6c 73 db keys keyvalls
1780: 74 20 72 75 6e 6e 61 6d 65 20 22 6e 65 77 22 20 t runname "new"
1790: 22 6e 2f 61 22 20 75 73 65 72 29 29 20 20 3b 3b "n/a" user)) ;;
17a0: 20 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a 09 test-name)))..
17b0: 20 28 64 65 66 65 72 72 65 64 20 20 20 20 27 28 (deferred '(
17c0: 29 29 20 3b 3b 20 64 65 6c 61 79 20 72 75 6e 6e )) ;; delay runn
17d0: 69 6e 67 20 74 68 65 73 65 20 73 69 6e 63 65 20 ing these since
17e0: 74 68 65 79 20 68 61 76 65 20 61 20 77 61 69 74 they have a wait
17f0: 6f 6e 20 63 6c 61 75 73 65 0a 09 20 28 6b 65 65 on clause.. (kee
1800: 70 67 6f 69 6e 67 20 20 20 28 68 61 73 68 2d 74 pgoing (hash-t
1810: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
1820: 20 66 6c 61 67 73 20 22 2d 6b 65 65 70 67 6f 69 flags "-keepgoi
1830: 6e 67 22 20 23 66 29 29 0a 09 20 28 74 65 73 74 ng" #f)).. (test
1840: 2d 6e 61 6d 65 73 20 20 27 28 29 29 0a 09 20 28 -names '()).. (
1850: 72 75 6e 63 6f 6e 66 69 67 66 20 20 20 28 63 6f runconfigf (co
1860: 6e 63 20 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f nc *toppath* "/
1870: 72 75 6e 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 69 runconfigs.confi
1880: 67 22 29 29 0a 09 20 28 72 65 71 75 69 72 65 64 g")).. (required
1890: 2d 74 65 73 74 73 20 27 28 29 29 29 0a 0a 20 20 -tests '()))..
18a0: 20 20 28 73 65 74 2d 6d 65 67 61 74 65 73 74 2d (set-megatest-
18b0: 65 6e 76 2d 76 61 72 73 20 64 62 20 72 75 6e 2d env-vars db run-
18c0: 69 64 29 20 3b 3b 20 74 68 65 73 65 20 6d 61 79 id) ;; these may
18d0: 20 62 65 20 6e 65 65 64 65 64 20 62 79 20 74 68 be needed by th
18e0: 65 20 6c 61 75 6e 63 68 69 6e 67 20 70 72 6f 63 e launching proc
18f0: 65 73 73 0a 0a 20 20 20 20 28 69 66 20 28 66 69 ess.. (if (fi
1900: 6c 65 2d 65 78 69 73 74 73 3f 20 72 75 6e 63 6f le-exists? runco
1910: 6e 66 69 67 66 29 0a 09 28 73 65 74 75 70 2d 65 nfigf)..(setup-e
1920: 6e 76 2d 64 65 66 61 75 6c 74 73 20 64 62 20 72 nv-defaults db r
1930: 75 6e 63 6f 6e 66 69 67 66 20 72 75 6e 2d 69 64 unconfigf run-id
1940: 20 2a 61 6c 72 65 61 64 79 2d 73 65 65 6e 2d 72 *already-seen-r
1950: 75 6e 63 6f 6e 66 69 67 2d 69 6e 66 6f 2a 20 22 unconfig-info* "
1960: 70 72 65 2d 6c 61 75 6e 63 68 2d 65 6e 76 2d 76 pre-launch-env-v
1970: 61 72 73 22 29 0a 09 28 64 65 62 75 67 3a 70 72 ars")..(debug:pr
1980: 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 int 0 "WARNING:
1990: 59 6f 75 20 64 6f 20 6e 6f 74 20 68 61 76 65 20 You do not have
19a0: 61 20 72 75 6e 20 63 6f 6e 66 69 67 20 66 69 6c a run config fil
19b0: 65 3a 20 22 20 72 75 6e 63 6f 6e 66 69 67 66 29 e: " runconfigf)
19c0: 29 0a 20 20 20 20 0a 20 20 20 20 3b 3b 20 6c 6f ). . ;; lo
19d0: 6f 6b 20 75 70 20 61 6c 6c 20 74 65 73 74 73 20 ok up all tests
19e0: 6d 61 74 63 68 69 6e 67 20 74 68 65 20 63 6f 6d matching the com
19f0: 6d 61 20 73 65 70 61 72 61 74 65 64 20 6c 69 73 ma separated lis
1a00: 74 20 6f 66 20 67 6c 6f 62 73 20 69 6e 0a 20 20 t of globs in.
1a10: 20 20 3b 3b 20 74 65 73 74 2d 70 61 74 74 73 20 ;; test-patts
1a20: 28 75 73 69 6e 67 20 25 20 61 73 20 77 69 6c 64 (using % as wild
1a30: 63 61 72 64 29 0a 20 20 20 20 28 66 6f 72 2d 65 card). (for-e
1a40: 61 63 68 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 ach . (lambd
1a50: 61 20 28 70 61 74 74 29 0a 20 20 20 20 20 20 20 a (patt).
1a60: 28 6c 65 74 20 28 28 74 65 73 74 73 20 28 67 6c (let ((tests (gl
1a70: 6f 62 20 28 63 6f 6e 63 20 2a 74 6f 70 70 61 74 ob (conc *toppat
1a80: 68 2a 20 22 2f 74 65 73 74 73 2f 22 20 28 73 74 h* "/tests/" (st
1a90: 72 69 6e 67 2d 74 72 61 6e 73 6c 61 74 65 20 70 ring-translate p
1aa0: 61 74 74 20 22 25 22 20 22 2a 22 29 29 29 29 29 att "%" "*")))))
1ab0: 0a 09 20 28 73 65 74 21 20 74 65 73 74 73 20 28 .. (set! tests (
1ac0: 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 filter (lambda (
1ad0: 74 65 73 74 29 28 66 69 6c 65 2d 65 78 69 73 74 test)(file-exist
1ae0: 73 3f 20 28 63 6f 6e 63 20 74 65 73 74 20 22 2f s? (conc test "/
1af0: 74 65 73 74 63 6f 6e 66 69 67 22 29 29 29 20 74 testconfig"))) t
1b00: 65 73 74 73 29 29 0a 09 20 28 73 65 74 21 20 74 ests)).. (set! t
1b10: 65 73 74 2d 6e 61 6d 65 73 20 28 61 70 70 65 6e est-names (appen
1b20: 64 20 74 65 73 74 2d 6e 61 6d 65 73 20 0a 09 09 d test-names ...
1b30: 09 09 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 .. (map (lambda
1b40: 20 28 74 65 73 74 70 29 0a 09 09 09 09 09 20 28 (testp)...... (
1b50: 6c 61 73 74 20 28 73 74 72 69 6e 67 2d 73 70 6c last (string-spl
1b60: 69 74 20 74 65 73 74 70 20 22 2f 22 29 29 29 0a it testp "/"))).
1b70: 09 09 09 09 20 20 20 20 20 20 20 74 65 73 74 73 .... tests
1b80: 29 29 29 29 29 0a 20 20 20 20 20 28 73 74 72 69 ))))). (stri
1b90: 6e 67 2d 73 70 6c 69 74 20 74 65 73 74 2d 70 61 ng-split test-pa
1ba0: 74 74 73 20 22 2c 22 29 29 0a 0a 20 20 20 20 20 tts ","))..
1bb0: 3b 3b 20 6e 6f 77 20 72 65 6d 6f 76 65 20 64 75 ;; now remove du
1bc0: 70 6c 69 63 61 74 65 73 0a 20 20 20 20 28 73 65 plicates. (se
1bd0: 74 21 20 74 65 73 74 2d 6e 61 6d 65 73 20 28 64 t! test-names (d
1be0: 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 74 65 73 elete-duplicates
1bf0: 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 0a 0a 20 test-names))..
1c00: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
1c10: 30 20 22 49 4e 46 4f 3a 20 74 65 73 74 20 6e 61 0 "INFO: test na
1c20: 6d 65 73 20 22 20 74 65 73 74 2d 6e 61 6d 65 73 mes " test-names
1c30: 29 0a 0a 20 20 20 20 3b 3b 20 6e 6f 77 20 61 64 ).. ;; now ad
1c40: 64 20 6e 6f 6e 2d 64 69 72 65 63 74 6c 79 20 72 d non-directly r
1c50: 65 66 65 72 65 6e 63 65 64 20 64 65 70 65 6e 64 eferenced depend
1c60: 65 6e 63 69 65 73 20 28 69 2e 65 2e 20 77 61 69 encies (i.e. wai
1c70: 74 6f 6e 29 0a 20 20 20 20 3b 3b 20 63 6f 75 6c ton). ;; coul
1c80: 64 20 63 61 63 68 65 20 61 6c 6c 20 74 68 65 73 d cache all thes
1c90: 65 20 73 69 6e 63 65 20 74 68 65 79 20 6e 65 65 e since they nee
1ca0: 64 20 74 6f 20 62 65 20 72 65 61 64 20 61 67 61 d to be read aga
1cb0: 69 6e 20 2e 2e 2e 0a 20 20 20 20 3b 3b 20 46 49 in .... ;; FI
1cc0: 58 4d 45 20 53 4f 4d 45 44 41 59 0a 20 20 20 20 XME SOMEDAY.
1cd0: 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 (if (not (null?
1ce0: 74 65 73 74 2d 6e 61 6d 65 73 29 29 0a 09 28 6c test-names))..(l
1cf0: 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 et loop ((hed (c
1d00: 61 72 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 0a ar test-names)).
1d10: 09 09 20 20 20 28 74 61 6c 20 28 63 64 72 20 74 .. (tal (cdr t
1d20: 65 73 74 2d 6e 61 6d 65 73 29 29 29 0a 09 20 20 est-names)))..
1d30: 28 6c 65 74 2a 20 28 28 63 6f 6e 66 69 67 20 20 (let* ((config
1d40: 28 74 65 73 74 3a 67 65 74 2d 74 65 73 74 63 6f (test:get-testco
1d50: 6e 66 69 67 20 68 65 64 20 23 66 29 29 0a 09 09 nfig hed #f))...
1d60: 20 28 77 61 69 74 6f 6e 73 20 28 73 74 72 69 6e (waitons (strin
1d70: 67 2d 73 70 6c 69 74 20 28 6c 65 74 20 28 28 77 g-split (let ((w
1d80: 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 (config-lookup
1d90: 63 6f 6e 66 69 67 20 22 72 65 71 75 69 72 65 6d config "requirem
1da0: 65 6e 74 73 22 20 22 77 61 69 74 6f 6e 22 29 29 ents" "waiton"))
1db0: 29 0a 09 09 09 09 09 20 20 28 69 66 20 77 20 77 )...... (if w w
1dc0: 20 22 22 29 29 29 29 29 0a 09 20 20 20 20 28 66 ""))))).. (f
1dd0: 6f 72 2d 65 61 63 68 20 0a 09 20 20 20 20 20 28 or-each .. (
1de0: 6c 61 6d 62 64 61 20 28 77 61 69 74 6f 6e 29 0a lambda (waiton).
1df0: 09 20 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 . (if (and
1e00: 20 77 61 69 74 6f 6e 20 28 6e 6f 74 20 28 6d 65 waiton (not (me
1e10: 6d 62 65 72 20 77 61 69 74 6f 6e 20 74 65 73 74 mber waiton test
1e20: 2d 6e 61 6d 65 73 29 29 29 0a 09 09 20 20 20 28 -names)))... (
1e30: 62 65 67 69 6e 0a 09 09 20 20 20 20 20 28 73 65 begin... (se
1e40: 74 21 20 72 65 71 75 69 72 65 64 2d 74 65 73 74 t! required-test
1e50: 73 20 28 63 6f 6e 73 20 77 61 69 74 6f 6e 20 72 s (cons waiton r
1e60: 65 71 75 69 72 65 64 2d 74 65 73 74 73 29 29 0a equired-tests)).
1e70: 09 09 20 20 20 20 20 28 73 65 74 21 20 74 65 73 .. (set! tes
1e80: 74 2d 6e 61 6d 65 73 20 28 61 70 70 65 6e 64 20 t-names (append
1e90: 74 65 73 74 2d 6e 61 6d 65 73 20 28 6c 69 73 74 test-names (list
1ea0: 20 77 61 69 74 6f 6e 29 29 29 29 29 29 0a 09 20 waiton))))))..
1eb0: 20 20 20 20 77 61 69 74 6f 6e 73 29 0a 09 20 20 waitons)..
1ec0: 20 20 28 6c 65 74 20 28 28 72 65 6d 74 65 73 74 (let ((remtest
1ed0: 73 20 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 s (delete-duplic
1ee0: 61 74 65 73 20 28 61 70 70 65 6e 64 20 77 61 69 ates (append wai
1ef0: 74 6f 6e 73 20 74 61 6c 29 29 29 29 0a 09 20 20 tons tal))))..
1f00: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 (if (not (nu
1f10: 6c 6c 3f 20 72 65 6d 74 65 73 74 73 29 29 0a 09 ll? remtests))..
1f20: 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 72 65 . (loop (car re
1f30: 6d 74 65 73 74 73 29 28 63 64 72 20 72 65 6d 74 mtests)(cdr remt
1f40: 65 73 74 73 29 29 29 29 29 29 29 0a 0a 20 20 20 ests)))))))..
1f50: 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f (if (not (null?
1f60: 20 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 29 required-tests)
1f70: 29 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 )..(debug:print
1f80: 31 20 22 49 4e 46 4f 3a 20 41 64 64 69 6e 67 20 1 "INFO: Adding
1f90: 22 20 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 " required-tests
1fa0: 20 22 20 74 6f 20 74 68 65 20 72 75 6e 20 71 75 " to the run qu
1fb0: 65 75 65 22 29 29 0a 0a 20 20 20 20 3b 3b 20 6f eue")).. ;; o
1fc0: 6e 20 74 68 65 20 66 69 72 73 74 20 70 61 73 73 n the first pass
1fd0: 20 6f 72 20 63 61 6c 6c 20 74 6f 20 72 75 6e 2d or call to run-
1fe0: 74 65 73 74 73 20 73 65 74 20 46 41 49 4c 53 20 tests set FAILS
1ff0: 74 6f 20 4e 4f 54 5f 53 54 41 52 54 45 44 20 69 to NOT_STARTED i
2000: 66 0a 20 20 20 20 3b 3b 20 2d 6b 65 65 70 67 6f f. ;; -keepgo
2010: 69 6e 67 20 69 73 20 73 70 65 63 69 66 69 65 64 ing is specified
2020: 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 65 . (if (and (e
2030: 71 3f 20 2a 70 61 73 73 6e 75 6d 2a 20 30 29 0a q? *passnum* 0).
2040: 09 20 20 20 20 20 6b 65 65 70 67 6f 69 6e 67 29 . keepgoing)
2050: 0a 09 28 62 65 67 69 6e 0a 09 20 20 3b 3b 20 68 ..(begin.. ;; h
2060: 61 76 65 20 74 6f 20 64 65 6c 65 74 65 20 74 65 ave to delete te
2070: 73 74 20 72 65 63 6f 72 64 73 20 77 68 65 72 65 st records where
2080: 20 4e 4f 54 5f 53 54 41 52 54 45 44 20 73 69 6e NOT_STARTED sin
2090: 63 65 20 74 68 65 79 20 63 61 6e 20 63 61 75 73 ce they can caus
20a0: 65 20 2d 6b 65 65 70 67 6f 69 6e 67 20 74 6f 20 e -keepgoing to
20b0: 0a 09 20 20 3b 3b 20 67 65 74 20 73 74 75 63 6b .. ;; get stuck
20c0: 20 64 75 65 20 74 6f 20 62 65 63 6f 6d 69 6e 67 due to becoming
20d0: 20 69 6e 61 63 63 65 73 73 69 62 6c 65 20 66 72 inaccessible fr
20e0: 6f 6d 20 61 20 66 61 69 6c 65 64 20 74 65 73 74 om a failed test
20f0: 2e 20 49 2e 65 2e 20 69 66 20 74 65 73 74 20 42 . I.e. if test B
2100: 20 64 65 70 65 6e 64 73 20 0a 09 20 20 3b 3b 20 depends .. ;;
2110: 6f 6e 20 74 65 73 74 20 41 20 62 75 74 20 74 65 on test A but te
2120: 73 74 20 42 20 72 65 61 63 68 65 64 20 74 68 65 st B reached the
2130: 20 70 6f 69 6e 74 20 6f 6e 20 62 65 69 6e 67 20 point on being
2140: 72 65 67 69 73 74 65 72 65 64 20 61 73 20 4e 4f registered as NO
2150: 54 5f 53 54 41 52 54 45 44 20 61 6e 64 20 74 65 T_STARTED and te
2160: 73 74 0a 09 20 20 3b 3b 20 41 20 66 61 69 6c 65 st.. ;; A faile
2170: 64 20 66 6f 72 20 73 6f 6d 65 20 72 65 61 73 6f d for some reaso
2180: 6e 20 74 68 65 6e 20 6f 6e 20 72 65 2d 72 75 6e n then on re-run
2190: 20 75 73 69 6e 67 20 2d 6b 65 65 70 67 6f 69 6e using -keepgoin
21a0: 67 20 74 68 65 20 72 75 6e 20 63 61 6e 20 6e 65 g the run can ne
21b0: 76 65 72 20 63 6f 6d 70 6c 65 74 65 2e 0a 09 20 ver complete...
21c0: 20 28 64 62 3a 64 65 6c 65 74 65 2d 74 65 73 74 (db:delete-test
21d0: 73 2d 69 6e 2d 73 74 61 74 65 20 64 62 20 72 75 s-in-state db ru
21e0: 6e 2d 69 64 20 22 4e 4f 54 5f 53 54 41 52 54 45 n-id "NOT_STARTE
21f0: 44 22 29 0a 09 20 20 28 64 62 3a 73 65 74 2d 74 D").. (db:set-t
2200: 65 73 74 73 2d 73 74 61 74 65 2d 73 74 61 74 75 ests-state-statu
2210: 73 20 64 62 20 72 75 6e 2d 69 64 20 74 65 73 74 s db run-id test
2220: 2d 6e 61 6d 65 73 20 23 66 20 22 46 41 49 4c 22 -names #f "FAIL"
2230: 20 22 4e 4f 54 5f 53 54 41 52 54 45 44 22 20 22 "NOT_STARTED" "
2240: 46 41 49 4c 22 29 29 29 0a 20 20 20 20 28 73 65 FAIL"))). (se
2250: 74 21 20 2a 70 61 73 73 6e 75 6d 2a 20 28 2b 20 t! *passnum* (+
2260: 2a 70 61 73 73 6e 75 6d 2a 20 31 29 29 0a 20 20 *passnum* 1)).
2270: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 6e 75 (let loop ((nu
2280: 6d 74 69 6d 65 73 20 30 29 29 0a 20 20 20 20 20 mtimes 0)).
2290: 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 (for-each .
22a0: 20 20 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 (lambda (test
22b0: 2d 6e 61 6d 65 29 0a 09 20 28 69 66 20 28 72 75 -name).. (if (ru
22c0: 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d ns:can-run-more-
22d0: 74 65 73 74 73 20 64 62 29 0a 09 20 20 20 20 20 tests db)..
22e0: 28 72 75 6e 3a 74 65 73 74 20 64 62 20 72 75 6e (run:test db run
22f0: 2d 69 64 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 -id runname test
2300: 2d 6e 61 6d 65 20 6b 65 79 76 61 6c 6c 73 74 20 -name keyvallst
2310: 69 74 65 6d 2d 70 61 74 74 73 20 66 6c 61 67 73 item-patts flags
2320: 29 0a 09 20 20 20 20 20 29 29 0a 20 20 20 20 20 ).. )).
2330: 20 20 28 74 65 73 74 73 3a 73 6f 72 74 2d 62 79 (tests:sort-by
2340: 2d 70 72 69 6f 72 69 74 79 2d 61 6e 64 2d 77 61 -priority-and-wa
2350: 69 74 6f 6e 20 74 65 73 74 2d 6e 61 6d 65 73 29 iton test-names)
2360: 29 0a 20 20 20 20 20 20 3b 3b 20 28 72 75 6e 2d ). ;; (run-
2370: 77 61 69 74 69 6e 67 2d 74 65 73 74 73 20 64 62 waiting-tests db
2380: 29 0a 20 20 20 20 20 20 28 69 66 20 6b 65 65 70 ). (if keep
2390: 67 6f 69 6e 67 0a 09 20 20 28 6c 65 74 20 28 28 going.. (let ((
23a0: 65 73 74 72 65 6d 20 28 64 62 3a 65 73 74 69 6d estrem (db:estim
23b0: 61 74 65 64 2d 74 65 73 74 73 2d 72 65 6d 61 69 ated-tests-remai
23c0: 6e 69 6e 67 20 64 62 20 72 75 6e 2d 69 64 29 29 ning db run-id))
23d0: 29 0a 09 20 20 20 20 28 69 66 20 28 61 6e 64 20 ).. (if (and
23e0: 28 3e 20 65 73 74 72 65 6d 20 30 29 0a 09 09 20 (> estrem 0)...
23f0: 20 20 20 20 28 65 71 3f 20 2a 67 6c 6f 62 61 6c (eq? *global
2400: 65 78 69 74 73 74 61 74 75 73 2a 20 30 29 29 0a exitstatus* 0)).
2410: 09 09 28 62 65 67 69 6e 0a 09 09 20 20 28 64 65 ..(begin... (de
2420: 62 75 67 3a 70 72 69 6e 74 20 31 20 22 4b 65 65 bug:print 1 "Kee
2430: 70 20 67 6f 69 6e 67 2c 20 65 73 74 69 6d 61 74 p going, estimat
2440: 65 64 20 22 20 65 73 74 72 65 6d 20 22 20 74 65 ed " estrem " te
2450: 73 74 73 20 72 65 6d 61 69 6e 69 6e 67 20 74 6f sts remaining to
2460: 20 72 75 6e 2c 20 77 69 6c 6c 20 63 6f 6e 74 69 run, will conti
2470: 6e 75 65 20 69 6e 20 33 20 73 65 63 6f 6e 64 73 nue in 3 seconds
2480: 20 2e 2e 2e 22 29 0a 09 09 20 20 28 74 68 72 65 ...")... (thre
2490: 61 64 2d 73 6c 65 65 70 21 20 33 29 0a 09 09 20 ad-sleep! 3)...
24a0: 20 28 72 75 6e 2d 77 61 69 74 69 6e 67 2d 74 65 (run-waiting-te
24b0: 73 74 73 20 64 62 29 0a 09 09 20 20 28 6c 6f 6f sts db)... (loo
24c0: 70 20 28 2b 20 6e 75 6d 74 69 6d 65 73 20 31 29 p (+ numtimes 1)
24d0: 29 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e ))))))))..(defin
24e0: 65 20 28 72 75 6e 3a 74 65 73 74 20 64 62 20 72 e (run:test db r
24f0: 75 6e 2d 69 64 20 72 75 6e 6e 61 6d 65 20 74 65 un-id runname te
2500: 73 74 2d 6e 61 6d 65 20 6b 65 79 76 61 6c 6c 73 st-name keyvalls
2510: 74 20 69 74 65 6d 2d 70 61 74 74 73 20 66 6c 61 t item-patts fla
2520: 67 73 29 0a 20 20 28 64 65 62 75 67 3a 70 72 69 gs). (debug:pri
2530: 6e 74 20 31 20 22 4c 61 75 6e 63 68 69 6e 67 20 nt 1 "Launching
2540: 74 65 73 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 test " test-name
2550: 29 0a 20 20 3b 3b 20 41 6c 6c 20 74 68 65 73 65 ). ;; All these
2560: 20 76 61 72 73 20 6d 69 67 68 74 20 62 65 20 72 vars might be r
2570: 65 66 65 72 65 6e 63 65 64 20 62 79 20 74 68 65 eferenced by the
2580: 20 74 65 73 74 63 6f 6e 66 69 67 20 66 69 6c 65 testconfig file
2590: 20 72 65 61 64 65 72 0a 20 20 28 73 65 74 65 6e reader. (seten
25a0: 76 20 22 4d 54 5f 54 45 53 54 5f 4e 41 4d 45 22 v "MT_TEST_NAME"
25b0: 20 74 65 73 74 2d 6e 61 6d 65 29 20 3b 3b 20 0a test-name) ;; .
25c0: 20 20 28 73 65 74 65 6e 76 20 22 4d 54 5f 52 55 (setenv "MT_RU
25d0: 4e 4e 41 4d 45 22 20 20 20 72 75 6e 6e 61 6d 65 NNAME" runname
25e0: 29 0a 20 20 28 73 65 74 2d 6d 65 67 61 74 65 73 ). (set-megates
25f0: 74 2d 65 6e 76 2d 76 61 72 73 20 64 62 20 72 75 t-env-vars db ru
2600: 6e 2d 69 64 29 20 3b 3b 20 74 68 65 73 65 20 6d n-id) ;; these m
2610: 61 79 20 62 65 20 6e 65 65 64 65 64 20 62 79 20 ay be needed by
2620: 74 68 65 20 6c 61 75 6e 63 68 69 6e 67 20 70 72 the launching pr
2630: 6f 63 65 73 73 0a 20 20 28 63 68 61 6e 67 65 2d ocess. (change-
2640: 64 69 72 65 63 74 6f 72 79 20 2a 74 6f 70 70 61 directory *toppa
2650: 74 68 2a 29 0a 20 20 28 6c 65 74 2a 20 28 28 74 th*). (let* ((t
2660: 65 73 74 2d 70 61 74 68 20 20 20 20 28 63 6f 6e est-path (con
2670: 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 74 65 c *toppath* "/te
2680: 73 74 73 2f 22 20 74 65 73 74 2d 6e 61 6d 65 29 sts/" test-name)
2690: 29 20 3b 3b 20 63 6f 75 6c 64 20 75 73 65 20 74 ) ;; could use t
26a0: 65 73 74 3a 67 65 74 2d 74 65 73 74 63 6f 6e 66 est:get-testconf
26b0: 69 67 20 68 65 72 65 20 2e 2e 2e 0a 09 20 28 74 ig here ..... (t
26c0: 65 73 74 2d 63 6f 6e 66 69 67 66 20 28 63 6f 6e est-configf (con
26d0: 63 20 74 65 73 74 2d 70 61 74 68 20 22 2f 74 65 c test-path "/te
26e0: 73 74 63 6f 6e 66 69 67 22 29 29 0a 09 20 28 74 stconfig")).. (t
26f0: 65 73 74 65 78 69 73 74 73 20 20 20 28 61 6e 64 estexists (and
2700: 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 74 (file-exists? t
2710: 65 73 74 2d 63 6f 6e 66 69 67 66 29 28 66 69 6c est-configf)(fil
2720: 65 2d 72 65 61 64 2d 61 63 63 65 73 73 3f 20 74 e-read-access? t
2730: 65 73 74 2d 63 6f 6e 66 69 67 66 29 29 29 0a 09 est-configf)))..
2740: 20 28 74 65 73 74 2d 63 6f 6e 66 20 20 20 20 28 (test-conf (
2750: 69 66 20 74 65 73 74 65 78 69 73 74 73 20 28 72 if testexists (r
2760: 65 61 64 2d 63 6f 6e 66 69 67 20 74 65 73 74 2d ead-config test-
2770: 63 6f 6e 66 69 67 66 20 23 66 20 23 74 29 20 28 configf #f #t) (
2780: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
2790: 29 29 0a 09 20 28 77 61 69 74 6f 6e 20 20 20 20 )).. (waiton
27a0: 20 20 20 28 6c 65 74 20 28 28 77 20 28 63 6f 6e (let ((w (con
27b0: 66 69 67 2d 6c 6f 6f 6b 75 70 20 74 65 73 74 2d fig-lookup test-
27c0: 63 6f 6e 66 20 22 72 65 71 75 69 72 65 6d 65 6e conf "requiremen
27d0: 74 73 22 20 22 77 61 69 74 6f 6e 22 29 29 29 0a ts" "waiton"))).
27e0: 09 09 09 20 28 69 66 20 28 73 74 72 69 6e 67 3f ... (if (string?
27f0: 20 77 29 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 w)(string-split
2800: 20 77 29 27 28 29 29 29 29 0a 09 20 28 66 6f 72 w)'()))).. (for
2810: 63 65 20 20 20 20 20 20 20 20 28 68 61 73 68 2d ce (hash-
2820: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
2830: 74 20 66 6c 61 67 73 20 22 2d 66 6f 72 63 65 22 t flags "-force"
2840: 20 23 66 29 29 0a 09 20 28 72 65 72 75 6e 20 20 #f)).. (rerun
2850: 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c (hash-tabl
2860: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 66 6c e-ref/default fl
2870: 61 67 73 20 22 2d 72 65 72 75 6e 22 20 23 66 29 ags "-rerun" #f)
2880: 29 0a 09 20 28 6b 65 65 70 67 6f 69 6e 67 20 20 ).. (keepgoing
2890: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 (hash-table-re
28a0: 66 2f 64 65 66 61 75 6c 74 20 66 6c 61 67 73 20 f/default flags
28b0: 22 2d 6b 65 65 70 67 6f 69 6e 67 22 20 23 66 29 "-keepgoing" #f)
28c0: 29 0a 09 20 3b 3b 20 41 72 65 20 74 68 65 73 65 ).. ;; Are these
28d0: 20 74 61 67 73 20 73 74 69 6c 6c 20 75 73 65 64 tags still used
28e0: 3f 20 49 20 64 6f 6e 27 74 20 74 68 69 6e 6b 20 ? I don't think
28f0: 73 6f 2e 2e 2e 0a 09 20 3b 3b 28 74 61 67 73 20 so..... ;;(tags
2900: 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 74 (let ((t
2910: 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 (config-lookup
2920: 74 65 73 74 2d 63 6f 6e 66 20 22 73 65 74 75 70 test-conf "setup
2930: 22 20 22 74 61 67 73 22 29 29 29 0a 09 20 3b 3b " "tags"))).. ;;
2940: 20 20 20 20 20 20 20 09 20 3b 3b 20 77 65 20 77 . ;; we w
2950: 61 6e 74 20 6f 75 72 20 74 61 67 73 20 74 6f 20 ant our tags to
2960: 62 65 20 73 65 70 61 72 61 74 65 64 20 62 79 20 be separated by
2970: 63 6f 6d 6d 61 73 20 61 6e 64 20 66 75 6c 6c 79 commas and fully
2980: 20 64 65 6c 69 6d 69 74 65 64 20 62 79 20 63 6f delimited by co
2990: 6d 6d 61 73 0a 09 20 3b 3b 20 20 20 20 20 20 20 mmas.. ;;
29a0: 09 20 3b 3b 20 73 6f 20 74 68 61 74 20 71 75 65 . ;; so that que
29b0: 72 69 65 73 20 77 69 74 68 20 22 6c 69 6b 65 22 ries with "like"
29c0: 20 63 61 6e 20 74 69 65 20 74 6f 20 74 68 65 20 can tie to the
29d0: 63 6f 6d 6d 61 73 20 61 74 20 65 69 74 68 65 72 commas at either
29e0: 20 65 6e 64 20 6f 66 20 65 61 63 68 20 74 61 67 end of each tag
29f0: 0a 09 20 3b 3b 20 20 20 20 20 20 20 09 20 3b 3b .. ;; . ;;
2a00: 20 77 68 69 6c 65 20 61 6c 73 6f 20 61 6c 6c 6f while also allo
2a10: 77 69 6e 67 20 74 68 65 20 65 6e 64 20 75 73 65 wing the end use
2a20: 72 20 74 6f 20 66 72 65 65 6c 79 20 75 73 65 20 r to freely use
2a30: 73 70 61 63 65 73 20 61 6e 64 20 63 6f 6d 6d 61 spaces and comma
2a40: 73 20 74 6f 20 73 65 70 61 72 61 74 65 20 74 61 s to separate ta
2a50: 67 73 0a 09 20 3b 3b 20 20 20 20 20 20 20 09 20 gs.. ;; .
2a60: 28 69 66 20 28 73 74 72 69 6e 67 3f 20 74 29 28 (if (string? t)(
2a70: 73 74 72 69 6e 67 2d 73 75 62 73 74 69 74 75 74 string-substitut
2a80: 65 20 28 72 65 67 65 78 70 20 22 5b 2c 5c 5c 73 e (regexp "[,\\s
2a90: 5d 2b 22 29 20 22 2c 22 20 28 63 6f 6e 63 20 22 ]+") "," (conc "
2aa0: 2c 22 20 74 20 22 2c 22 29 20 23 74 29 0a 09 20 ," t ",") #t)..
2ab0: 3b 3b 20 20 20 20 20 20 20 09 20 20 20 20 20 27 ;; . '
2ac0: 28 29 29 29 29 29 0a 09 20 29 0a 20 20 20 20 28 ())))).. ). (
2ad0: 69 66 20 28 6e 6f 74 20 74 65 73 74 65 78 69 73 if (not testexis
2ae0: 74 73 29 0a 09 3b 3b 20 69 66 20 74 68 65 20 74 ts)..;; if the t
2af0: 65 73 74 20 69 73 20 69 6c 6c 20 64 65 66 69 6e est is ill defin
2b00: 65 64 20 73 70 69 74 20 6f 75 74 20 61 6e 20 65 ed spit out an e
2b10: 72 72 6f 72 20 62 75 74 20 6b 65 65 70 20 67 6f rror but keep go
2b20: 69 6e 67 20 28 64 69 66 66 65 72 65 6e 74 20 66 ing (different f
2b30: 72 6f 6d 20 68 6f 77 20 64 6f 6e 65 20 70 72 65 rom how done pre
2b40: 76 69 6f 75 73 6c 79 0a 09 28 64 65 62 75 67 3a viously..(debug:
2b50: 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 print 0 "ERROR:
2b60: 43 61 6e 27 74 20 66 69 6e 64 20 63 6f 6e 66 69 Can't find confi
2b70: 67 20 66 69 6c 65 20 22 20 74 65 73 74 2d 63 6f g file " test-co
2b80: 6e 66 69 67 66 29 0a 09 3b 3b 20 70 75 74 20 74 nfigf)..;; put t
2b90: 6f 70 20 76 61 72 73 20 69 6e 74 6f 20 63 6f 6e op vars into con
2ba0: 76 65 6e 69 65 6e 74 20 76 61 72 69 61 62 6c 65 venient variable
2bb0: 73 20 61 6e 64 20 6f 70 65 6e 20 74 68 65 20 64 s and open the d
2bc0: 62 0a 09 28 6c 65 74 2a 20 28 3b 3b 20 64 62 20 b..(let* (;; db
2bd0: 69 73 20 61 6c 77 61 79 73 20 61 74 20 2a 74 6f is always at *to
2be0: 70 70 61 74 68 2a 2f 64 62 2f 6d 65 67 61 74 65 ppath*/db/megate
2bf0: 73 74 2e 64 62 0a 09 20 20 20 20 20 20 20 28 69 st.db.. (i
2c00: 74 65 6d 73 20 20 20 20 20 20 20 28 68 61 73 68 tems (hash
2c10: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
2c20: 6c 74 20 74 65 73 74 2d 63 6f 6e 66 20 22 69 74 lt test-conf "it
2c30: 65 6d 73 22 20 27 28 29 29 29 0a 09 20 20 20 20 ems" '()))..
2c40: 20 20 20 28 69 74 65 6d 73 74 61 62 6c 65 20 20 (itemstable
2c50: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
2c60: 64 65 66 61 75 6c 74 20 74 65 73 74 2d 63 6f 6e default test-con
2c70: 66 20 22 69 74 65 6d 73 74 61 62 6c 65 22 20 27 f "itemstable" '
2c80: 28 29 29 29 0a 09 20 20 20 20 20 20 20 28 61 6c ())).. (al
2c90: 6c 69 74 65 6d 73 20 20 20 20 28 69 66 20 28 6f litems (if (o
2ca0: 72 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 69 74 r (not (null? it
2cb0: 65 6d 73 29 29 28 6e 6f 74 20 28 6e 75 6c 6c 3f ems))(not (null?
2cc0: 20 69 74 65 6d 73 74 61 62 6c 65 29 29 29 0a 09 itemstable)))..
2cd0: 09 09 09 28 61 70 70 65 6e 64 20 28 69 74 65 6d ...(append (item
2ce0: 2d 61 73 73 6f 63 2d 3e 69 74 65 6d 2d 6c 69 73 -assoc->item-lis
2cf0: 74 20 69 74 65 6d 73 29 0a 09 09 09 09 09 28 69 t items)......(i
2d00: 74 65 6d 2d 74 61 62 6c 65 2d 3e 69 74 65 6d 2d tem-table->item-
2d10: 6c 69 73 74 20 69 74 65 6d 73 74 61 62 6c 65 29 list itemstable)
2d20: 29 0a 09 09 09 09 27 28 28 29 29 29 29 29 20 3b ).....'(())))) ;
2d30: 3b 20 61 20 6c 69 73 74 20 77 69 74 68 20 6f 6e ; a list with on
2d40: 65 20 6e 75 6c 6c 20 6c 69 73 74 20 69 73 20 61 e null list is a
2d50: 20 74 65 73 74 20 77 69 74 68 20 6e 6f 20 69 74 test with no it
2d60: 65 6d 73 0a 09 20 20 3b 3b 20 28 72 75 6e 63 6f ems.. ;; (runco
2d70: 6e 66 69 67 66 20 20 28 63 6f 6e 63 20 20 2a 74 nfigf (conc *t
2d80: 6f 70 70 61 74 68 2a 20 22 2f 72 75 6e 63 6f 6e oppath* "/runcon
2d90: 66 69 67 73 2e 63 6f 6e 66 69 67 22 29 29 29 0a figs.config"))).
2da0: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 . (debug:print
2db0: 31 20 22 69 74 65 6d 73 3a 20 22 29 0a 09 20 20 1 "items: ")..
2dc0: 28 69 66 20 28 3e 3d 20 2a 76 65 72 62 6f 73 69 (if (>= *verbosi
2dd0: 74 79 2a 20 31 29 28 70 70 20 61 6c 6c 69 74 65 ty* 1)(pp allite
2de0: 6d 73 29 29 0a 09 20 20 28 69 66 20 28 3e 3d 20 ms)).. (if (>=
2df0: 2a 76 65 72 62 6f 73 69 74 79 2a 20 35 29 0a 09 *verbosity* 5)..
2e00: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 28 (begin...(
2e10: 70 72 69 6e 74 20 22 69 74 65 6d 73 3a 20 22 29 print "items: ")
2e20: 28 70 70 20 28 69 74 65 6d 2d 61 73 73 6f 63 2d (pp (item-assoc-
2e30: 3e 69 74 65 6d 2d 6c 69 73 74 20 69 74 65 6d 73 >item-list items
2e40: 29 29 0a 09 09 28 70 72 69 6e 74 20 22 69 74 65 ))...(print "ite
2e50: 6d 73 74 61 62 6c 65 3a 20 22 29 28 70 70 20 28 mstable: ")(pp (
2e60: 69 74 65 6d 2d 74 61 62 6c 65 2d 3e 69 74 65 6d item-table->item
2e70: 2d 6c 69 73 74 20 69 74 65 6d 73 74 61 62 6c 65 -list itemstable
2e80: 29 29 29 29 0a 0a 09 20 20 3b 3b 20 43 6f 6d 6d ))))... ;; Comm
2e90: 65 6e 74 73 20 61 72 65 20 6c 6f 61 64 65 64 20 ents are loaded
2ea0: 62 79 20 74 68 65 20 74 65 73 74 20 72 75 6e 2c by the test run,
2eb0: 20 6e 6f 74 20 61 74 20 6c 61 75 6e 63 68 20 74 not at launch t
2ec0: 69 6d 65 20 28 69 6e 20 67 65 6e 65 72 61 6c 29 ime (in general)
2ed0: 0a 09 20 20 3b 3b 28 69 66 20 28 61 72 67 73 3a .. ;;(if (args:
2ee0: 67 65 74 2d 61 72 67 20 22 2d 6d 22 29 0a 09 20 get-arg "-m")..
2ef0: 20 3b 3b 20 20 20 20 28 64 62 3a 73 65 74 2d 63 ;; (db:set-c
2f00: 6f 6d 6d 65 6e 74 2d 66 6f 72 2d 72 75 6e 20 64 omment-for-run d
2f10: 62 20 72 75 6e 2d 69 64 20 28 61 72 67 73 3a 67 b run-id (args:g
2f20: 65 74 2d 61 72 67 20 22 2d 6d 22 29 29 29 0a 0a et-arg "-m")))..
2f30: 09 20 20 3b 3b 20 48 65 72 65 20 69 73 20 77 68 . ;; Here is wh
2f40: 65 72 65 20 74 68 65 20 74 65 73 74 5f 6d 65 74 ere the test_met
2f50: 61 20 74 61 62 6c 65 20 69 73 20 62 65 73 74 20 a table is best
2f60: 75 70 64 61 74 65 64 0a 09 20 20 28 72 75 6e 73 updated.. (runs
2f70: 3a 75 70 64 61 74 65 2d 74 65 73 74 5f 6d 65 74 :update-test_met
2f80: 61 20 64 62 20 74 65 73 74 2d 6e 61 6d 65 20 74 a db test-name t
2f90: 65 73 74 2d 63 6f 6e 66 29 0a 0a 09 20 20 3b 3b est-conf)... ;;
2fa0: 20 62 72 61 69 6e 64 65 61 64 20 77 6f 72 6b 2d braindead work-
2fb0: 61 72 6f 75 6e 64 20 66 6f 72 20 70 6f 6f 72 6c around for poorl
2fc0: 79 20 73 70 65 63 69 66 69 65 64 20 61 6c 6c 69 y specified alli
2fd0: 74 65 6d 73 20 6c 69 73 74 20 42 55 47 21 21 21 tems list BUG!!!
2fe0: 20 46 49 58 4d 45 0a 09 20 20 28 69 66 20 28 6e FIXME.. (if (n
2ff0: 75 6c 6c 3f 20 61 6c 6c 69 74 65 6d 73 29 28 73 ull? allitems)(s
3000: 65 74 21 20 61 6c 6c 69 74 65 6d 73 20 27 28 28 et! allitems '((
3010: 29 29 29 29 0a 09 20 20 28 6c 65 74 20 6c 6f 6f )))).. (let loo
3020: 70 20 28 28 69 74 65 6d 64 61 74 20 28 63 61 72 p ((itemdat (car
3030: 20 61 6c 6c 69 74 65 6d 73 29 29 0a 09 09 20 20 allitems))...
3040: 20 20 20 28 74 61 6c 20 20 20 20 20 28 63 64 72 (tal (cdr
3050: 20 61 6c 6c 69 74 65 6d 73 29 29 29 0a 09 20 20 allitems)))..
3060: 20 20 3b 3b 20 28 6c 61 6d 62 64 61 20 28 69 74 ;; (lambda (it
3070: 65 6d 64 61 74 29 20 3b 3b 3b 20 28 28 72 69 70 emdat) ;;; ((rip
3080: 65 6e 65 73 73 20 22 6f 76 65 72 72 69 70 65 22 eness "overripe"
3090: 29 20 28 74 65 6d 70 65 72 61 74 75 72 65 20 22 ) (temperature "
30a0: 63 6f 6f 6c 22 29 20 28 73 65 61 73 6f 6e 20 22 cool") (season "
30b0: 73 75 6d 6d 65 72 22 29 29 0a 09 20 20 20 20 3b summer")).. ;
30c0: 3b 20 48 61 6e 64 6c 65 20 6c 69 73 74 73 20 6f ; Handle lists o
30d0: 66 20 69 74 65 6d 73 0a 09 20 20 20 20 28 6c 65 f items.. (le
30e0: 74 2a 20 28 28 69 74 65 6d 2d 70 61 74 68 20 20 t* ((item-path
30f0: 20 20 20 28 69 74 65 6d 2d 6c 69 73 74 2d 3e 70 (item-list->p
3100: 61 74 68 20 69 74 65 6d 64 61 74 29 29 20 3b 3b ath itemdat)) ;;
3110: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
3120: 65 72 73 65 20 28 6d 61 70 20 63 61 64 72 20 69 erse (map cadr i
3130: 74 65 6d 64 61 74 29 20 22 2f 22 29 29 0a 09 09 temdat) "/"))...
3140: 20 20 20 28 6e 65 77 2d 74 65 73 74 2d 70 61 74 (new-test-pat
3150: 68 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 h (string-inters
3160: 70 65 72 73 65 20 28 63 6f 6e 73 20 74 65 73 74 perse (cons test
3170: 2d 70 61 74 68 20 28 6d 61 70 20 63 61 64 72 20 -path (map cadr
3180: 69 74 65 6d 64 61 74 29 29 20 22 2f 22 29 29 0a itemdat)) "/")).
3190: 09 09 20 20 20 28 6e 65 77 2d 74 65 73 74 2d 6e .. (new-test-n
31a0: 61 6d 65 20 28 69 66 20 28 65 71 75 61 6c 3f 20 ame (if (equal?
31b0: 69 74 65 6d 2d 70 61 74 68 20 22 22 29 20 74 65 item-path "") te
31c0: 73 74 2d 6e 61 6d 65 20 28 63 6f 6e 63 20 74 65 st-name (conc te
31d0: 73 74 2d 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d st-name "/" item
31e0: 2d 70 61 74 68 29 29 29 20 3b 3b 20 6a 75 73 74 -path))) ;; just
31f0: 20 6e 65 65 64 20 69 74 20 74 6f 20 62 65 20 75 need it to be u
3200: 6e 69 71 75 65 0a 09 09 20 20 20 28 74 65 73 74 nique... (test
3210: 64 61 74 20 20 20 23 66 29 0a 09 09 20 20 20 28 dat #f)... (
3220: 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 28 64 62 3a num-running (db:
3230: 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d get-count-tests-
3240: 72 75 6e 6e 69 6e 67 20 64 62 29 29 0a 09 09 20 running db))...
3250: 20 20 28 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e (max-concurren
3260: 74 2d 6a 6f 62 73 20 28 63 6f 6e 66 69 67 2d 6c t-jobs (config-l
3270: 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 ookup *configdat
3280: 2a 20 22 73 65 74 75 70 22 20 22 6d 61 78 5f 63 * "setup" "max_c
3290: 6f 6e 63 75 72 72 65 6e 74 5f 6a 6f 62 73 22 29 oncurrent_jobs")
32a0: 29 0a 09 09 20 20 20 28 70 61 72 65 6e 74 2d 74 )... (parent-t
32b0: 65 73 74 20 28 61 6e 64 20 28 6e 6f 74 20 28 6e est (and (not (n
32c0: 75 6c 6c 3f 20 69 74 65 6d 73 29 29 28 65 71 75 ull? items))(equ
32d0: 61 6c 3f 20 69 74 65 6d 2d 70 61 74 68 20 22 22 al? item-path ""
32e0: 29 29 29 0a 09 09 20 20 20 28 73 69 6e 67 6c 65 )))... (single
32f0: 2d 74 65 73 74 20 28 61 6e 64 20 28 6e 75 6c 6c -test (and (null
3300: 3f 20 69 74 65 6d 73 29 20 28 65 71 75 61 6c 3f ? items) (equal?
3310: 20 69 74 65 6d 2d 70 61 74 68 20 22 22 29 29 29 item-path "")))
3320: 0a 09 09 20 20 20 28 69 74 65 6d 2d 74 65 73 74 ... (item-test
3330: 20 20 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 (not (equal?
3340: 69 74 65 6d 2d 70 61 74 68 20 22 22 29 29 29 0a item-path ""))).
3350: 09 09 20 20 20 3b 3b 20 6c 6f 6f 6b 20 74 68 72 .. ;; look thr
3360: 6f 75 67 68 20 61 6c 6c 20 74 68 65 20 69 74 65 ough all the ite
3370: 6d 2d 70 61 74 74 73 20 69 66 20 64 65 66 69 6e m-patts if defin
3380: 65 64 2c 20 66 6f 72 6d 61 74 20 69 73 20 70 61 ed, format is pa
3390: 74 74 31 2c 70 61 74 74 32 2c 70 61 74 74 33 20 tt1,patt2,patt3
33a0: 2e 2e 2e 20 77 69 6c 64 63 61 72 64 20 69 73 20 ... wildcard is
33b0: 25 0a 09 09 20 20 20 28 69 74 65 6d 2d 6d 61 74 %... (item-mat
33c0: 63 68 65 73 20 28 69 66 20 69 74 65 6d 2d 70 61 ches (if item-pa
33d0: 74 74 73 0a 09 09 09 09 20 20 20 20 20 28 6c 65 tts..... (le
33e0: 74 20 28 28 72 65 73 20 23 66 29 29 0a 09 09 09 t ((res #f))....
33f0: 09 20 20 20 20 20 20 20 28 66 6f 72 2d 65 61 63 . (for-eac
3400: 68 20 0a 09 09 09 09 09 28 6c 61 6d 62 64 61 20 h ......(lambda
3410: 28 70 61 74 74 29 0a 09 09 09 09 09 20 20 28 69 (patt)...... (i
3420: 66 20 28 73 74 72 69 6e 67 2d 73 65 61 72 63 68 f (string-search
3430: 20 28 67 6c 6f 62 2d 3e 72 65 67 65 78 70 0a 09 (glob->regexp..
3440: 09 09 09 09 09 09 20 20 20 20 20 20 28 73 74 72 ...... (str
3450: 69 6e 67 2d 74 72 61 6e 73 6c 61 74 65 20 70 61 ing-translate pa
3460: 74 74 20 22 25 22 20 22 2a 22 29 29 0a 09 09 09 tt "%" "*"))....
3470: 09 09 09 09 20 20 20 20 20 69 74 65 6d 2d 70 61 .... item-pa
3480: 74 68 29 0a 09 09 09 09 09 20 20 20 20 20 20 28 th)...... (
3490: 73 65 74 21 20 72 65 73 20 23 74 29 29 29 0a 09 set! res #t)))..
34a0: 09 09 09 09 28 73 74 72 69 6e 67 2d 73 70 6c 69 ....(string-spli
34b0: 74 20 69 74 65 6d 2d 70 61 74 74 73 20 22 2c 22 t item-patts ","
34c0: 29 29 0a 09 09 09 09 20 20 20 20 20 20 20 72 65 ))..... re
34d0: 73 29 0a 09 09 09 09 20 20 20 20 20 23 74 29 29 s)..... #t))
34e0: 29 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 3a ).. (debug:
34f0: 70 72 69 6e 74 20 33 20 22 6d 61 78 2d 63 6f 6e print 3 "max-con
3500: 63 75 72 72 65 6e 74 2d 6a 6f 62 73 3a 20 22 20 current-jobs: "
3510: 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a max-concurrent-j
3520: 6f 62 73 20 22 2c 20 6e 75 6d 2d 72 75 6e 6e 69 obs ", num-runni
3530: 6e 67 3a 20 22 20 6e 75 6d 2d 72 75 6e 6e 69 6e ng: " num-runnin
3540: 67 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 61 g).. (if (a
3550: 6e 64 20 69 74 65 6d 2d 6d 61 74 63 68 65 73 20 nd item-matches
3560: 28 72 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f (runs:can-run-mo
3570: 72 65 2d 74 65 73 74 73 20 64 62 29 29 0a 09 09 re-tests db))...
3580: 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 28 (begin... (
3590: 6c 65 74 20 6c 6f 6f 70 32 20 28 28 74 73 20 28 let loop2 ((ts (
35a0: 64 62 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f db:get-test-info
35b0: 20 64 62 20 72 75 6e 2d 69 64 20 74 65 73 74 2d db run-id test-
35c0: 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 name item-path))
35d0: 20 3b 3b 20 23 66 29 0a 09 09 09 09 28 63 74 20 ;; #f).....(ct
35e0: 30 29 29 0a 09 09 20 20 20 20 20 20 28 69 66 20 0))... (if
35f0: 28 61 6e 64 20 28 6e 6f 74 20 74 73 29 0a 09 09 (and (not ts)...
3600: 09 20 20 20 20 20 20 20 28 3c 20 63 74 20 31 30 . (< ct 10
3610: 29 29 0a 09 09 09 20 20 28 62 65 67 69 6e 0a 09 )).... (begin..
3620: 09 09 20 20 20 20 28 72 65 67 69 73 74 65 72 2d .. (register-
3630: 74 65 73 74 20 64 62 20 72 75 6e 2d 69 64 20 74 test db run-id t
3640: 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 est-name item-pa
3650: 74 68 29 0a 09 09 09 20 20 20 20 3b 3b 20 57 68 th).... ;; Wh
3660: 79 20 64 69 64 20 49 20 73 65 74 20 74 68 65 20 y did I set the
3670: 63 6f 6d 6d 65 6e 74 20 68 65 72 65 3f 21 3f 20 comment here?!?
3680: 50 4f 53 53 49 42 4c 45 20 42 55 47 20 42 55 54 POSSIBLE BUG BUT
3690: 20 49 27 4d 20 52 45 4d 4f 56 49 4e 47 20 49 54 I'M REMOVING IT
36a0: 20 46 4f 52 20 4e 4f 57 20 31 30 2f 32 33 2f 32 FOR NOW 10/23/2
36b0: 30 31 31 0a 09 09 09 20 20 20 20 3b 3b 20 28 64 011.... ;; (d
36c0: 62 3a 74 65 73 74 2d 73 65 74 2d 63 6f 6d 6d 65 b:test-set-comme
36d0: 6e 74 20 64 62 20 72 75 6e 2d 69 64 20 74 65 73 nt db run-id tes
36e0: 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 t-name item-path
36f0: 20 22 22 29 0a 09 09 09 20 20 20 20 28 6c 6f 6f "").... (loo
3700: 70 32 20 28 64 62 3a 67 65 74 2d 74 65 73 74 2d p2 (db:get-test-
3710: 69 6e 66 6f 20 64 62 20 72 75 6e 2d 69 64 20 74 info db run-id t
3720: 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 est-name item-pa
3730: 74 68 29 0a 09 09 09 09 20 20 20 28 2b 20 63 74 th)..... (+ ct
3740: 20 31 29 29 29 0a 09 09 09 20 20 28 69 66 20 74 1))).... (if t
3750: 73 0a 09 09 09 20 20 20 20 20 20 28 73 65 74 21 s.... (set!
3760: 20 74 65 73 74 64 61 74 20 74 73 29 0a 09 09 09 testdat ts)....
3770: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 (begin....
3780: 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 .(debug:print 0
3790: 22 57 41 52 4e 49 4e 47 3a 20 43 6f 75 6c 64 6e "WARNING: Couldn
37a0: 27 74 20 72 65 67 69 73 74 65 72 20 74 65 73 74 't register test
37b0: 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 77 " test-name " w
37c0: 69 74 68 20 69 74 65 6d 20 70 61 74 68 20 22 20 ith item path "
37d0: 69 74 65 6d 2d 70 61 74 68 20 22 2c 20 73 6b 69 item-path ", ski
37e0: 70 70 69 6e 67 22 29 0a 09 09 09 09 28 69 66 20 pping").....(if
37f0: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 (not (null? tal)
3800: 29 0a 09 09 09 09 20 20 20 20 28 6c 6f 6f 70 20 )..... (loop
3810: 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 (car tal)(cdr ta
3820: 6c 29 29 29 29 29 29 29 0a 09 09 20 20 20 20 28 l)))))))... (
3830: 63 68 61 6e 67 65 2d 64 69 72 65 63 74 6f 72 79 change-directory
3840: 20 74 65 73 74 2d 70 61 74 68 29 0a 09 09 20 20 test-path)...
3850: 20 20 3b 3b 20 74 68 69 73 20 62 6c 6f 63 6b 20 ;; this block
3860: 69 73 20 68 65 72 65 20 6f 6e 6c 79 20 74 6f 20 is here only to
3870: 69 6e 66 6f 72 6d 20 74 68 65 20 75 73 65 72 20 inform the user
3880: 65 61 72 6c 79 20 6f 6e 0a 09 09 20 20 20 20 0a early on... .
3890: 09 09 20 20 20 20 3b 3b 20 4d 6f 76 69 6e 67 20 .. ;; Moving
38a0: 74 68 69 73 20 74 6f 20 74 68 65 20 72 75 6e 20 this to the run
38b0: 63 61 6c 6c 69 6e 67 20 62 6c 6f 63 6b 0a 0a 09 calling block...
38c0: 09 20 20 20 20 3b 3b 20 28 69 66 20 28 66 69 6c . ;; (if (fil
38d0: 65 2d 65 78 69 73 74 73 3f 20 72 75 6e 63 6f 6e e-exists? runcon
38e0: 66 69 67 66 29 0a 09 09 20 20 20 20 3b 3b 20 20 figf)... ;;
38f0: 20 20 20 28 73 65 74 75 70 2d 65 6e 76 2d 64 65 (setup-env-de
3900: 66 61 75 6c 74 73 20 64 62 20 72 75 6e 63 6f 6e faults db runcon
3910: 66 69 67 66 20 72 75 6e 2d 69 64 20 2a 61 6c 72 figf run-id *alr
3920: 65 61 64 79 2d 73 65 65 6e 2d 72 75 6e 63 6f 6e eady-seen-runcon
3930: 66 69 67 2d 69 6e 66 6f 2a 29 0a 09 09 20 20 20 fig-info*)...
3940: 20 3b 3b 20 20 20 20 20 28 64 65 62 75 67 3a 70 ;; (debug:p
3950: 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a rint 0 "WARNING:
3960: 20 59 6f 75 20 64 6f 20 6e 6f 74 20 68 61 76 65 You do not have
3970: 20 61 20 72 75 6e 20 63 6f 6e 66 69 67 20 66 69 a run config fi
3980: 6c 65 3a 20 22 20 72 75 6e 63 6f 6e 66 69 67 66 le: " runconfigf
3990: 29 29 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a ))... (debug:
39a0: 70 72 69 6e 74 20 34 20 22 72 75 6e 2d 69 64 3a print 4 "run-id:
39b0: 20 22 20 72 75 6e 2d 69 64 20 22 20 74 65 73 74 " run-id " test
39c0: 2d 6e 61 6d 65 3a 20 22 20 74 65 73 74 2d 6e 61 -name: " test-na
39d0: 6d 65 20 22 20 69 74 65 6d 2d 70 61 74 68 3a 20 me " item-path:
39e0: 22 20 69 74 65 6d 2d 70 61 74 68 20 22 20 74 65 " item-path " te
39f0: 73 74 64 61 74 3a 20 22 20 28 74 65 73 74 3a 67 stdat: " (test:g
3a00: 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 et-status testda
3a10: 74 29 20 22 20 74 65 73 74 2d 73 74 61 74 65 3a t) " test-state:
3a20: 20 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 " (test:get-sta
3a30: 74 65 20 74 65 73 74 64 61 74 29 29 0a 09 09 20 te testdat))...
3a40: 20 20 20 28 63 61 73 65 20 28 69 66 20 66 6f 72 (case (if for
3a50: 63 65 20 3b 3b 20 28 61 72 67 73 3a 67 65 74 2d ce ;; (args:get-
3a60: 61 72 67 20 22 2d 66 6f 72 63 65 22 29 0a 09 09 arg "-force")...
3a70: 09 20 20 20 20 20 20 27 4e 4f 54 5f 53 54 41 52 . 'NOT_STAR
3a80: 54 45 44 0a 09 09 09 20 20 20 20 20 20 28 69 66 TED.... (if
3a90: 20 74 65 73 74 64 61 74 0a 09 09 09 09 20 20 28 testdat..... (
3aa0: 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 string->symbol (
3ab0: 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 test:get-state t
3ac0: 65 73 74 64 61 74 29 29 0a 09 09 09 09 20 20 27 estdat))..... '
3ad0: 66 61 69 6c 65 64 2d 74 6f 2d 69 6e 73 65 72 74 failed-to-insert
3ae0: 29 29 0a 09 09 20 20 20 20 20 20 28 28 66 61 69 ))... ((fai
3af0: 6c 65 64 2d 74 6f 2d 69 6e 73 65 72 74 29 0a 09 led-to-insert)..
3b00: 09 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 . (debug:p
3b10: 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 46 rint 0 "ERROR: F
3b20: 61 69 6c 65 64 20 74 6f 20 69 6e 73 65 72 74 20 ailed to insert
3b30: 74 68 65 20 72 65 63 6f 72 64 20 69 6e 74 6f 20 the record into
3b40: 74 68 65 20 64 62 22 29 29 0a 09 09 20 20 20 20 the db"))...
3b50: 20 20 28 28 4e 4f 54 5f 53 54 41 52 54 45 44 20 ((NOT_STARTED
3b60: 43 4f 4d 50 4c 45 54 45 44 29 0a 09 09 20 20 20 COMPLETED)...
3b70: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
3b80: 20 36 20 22 47 6f 74 20 68 65 72 65 2c 20 22 20 6 "Got here, "
3b90: 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 (test:get-state
3ba0: 74 65 73 74 64 61 74 29 29 0a 09 09 20 20 20 20 testdat))...
3bb0: 20 20 20 28 6c 65 74 20 28 28 72 75 6e 66 6c 61 (let ((runfla
3bc0: 67 20 23 66 29 29 0a 09 09 09 20 28 63 6f 6e 64 g #f)).... (cond
3bd0: 0a 09 09 09 20 20 3b 3b 20 69 2e 65 2e 20 74 68 .... ;; i.e. th
3be0: 69 73 20 69 73 20 74 68 65 20 70 61 72 65 6e 74 is is the parent
3bf0: 20 74 65 73 74 20 74 6f 20 61 20 73 75 69 74 65 test to a suite
3c00: 20 6f 66 20 69 74 65 6d 73 2c 20 6e 65 76 65 72 of items, never
3c10: 20 22 72 75 6e 22 20 69 74 0a 09 09 09 20 20 28 "run" it.... (
3c20: 70 61 72 65 6e 74 2d 74 65 73 74 0a 09 09 09 20 parent-test....
3c30: 20 20 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 (set! runflag
3c40: 23 66 29 29 0a 09 09 09 20 20 3b 3b 20 2d 66 6f #f)).... ;; -fo
3c50: 72 63 65 2c 20 72 75 6e 20 6e 6f 20 6d 61 74 74 rce, run no matt
3c60: 65 72 20 77 68 61 74 0a 09 09 09 20 20 28 66 6f er what.... (fo
3c70: 72 63 65 20 28 73 65 74 21 20 72 75 6e 66 6c 61 rce (set! runfla
3c80: 67 20 23 74 29 29 0a 09 09 09 20 20 3b 3b 20 4e g #t)).... ;; N
3c90: 4f 54 5f 53 54 41 52 54 45 44 2c 20 72 75 6e 20 OT_STARTED, run
3ca0: 6e 6f 20 6d 61 74 74 65 72 20 77 68 61 74 0a 09 no matter what..
3cb0: 09 09 20 20 28 28 65 71 75 61 6c 3f 20 28 74 65 .. ((equal? (te
3cc0: 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 73 st:get-state tes
3cd0: 74 64 61 74 29 20 22 4e 4f 54 5f 53 54 41 52 54 tdat) "NOT_START
3ce0: 45 44 22 29 28 73 65 74 21 20 72 75 6e 66 6c 61 ED")(set! runfla
3cf0: 67 20 23 74 29 29 0a 09 09 09 20 20 3b 3b 20 6e g #t)).... ;; n
3d00: 6f 74 20 2d 72 65 72 75 6e 20 61 6e 64 20 50 41 ot -rerun and PA
3d10: 53 53 2c 20 57 41 52 4e 20 6f 72 20 43 48 45 43 SS, WARN or CHEC
3d20: 4b 2c 20 64 6f 20 6e 6f 20 72 75 6e 0a 09 09 09 K, do no run....
3d30: 20 20 28 28 61 6e 64 20 28 6f 72 20 28 6e 6f 74 ((and (or (not
3d40: 20 72 65 72 75 6e 29 0a 09 09 09 09 20 20 20 20 rerun).....
3d50: 6b 65 65 70 67 6f 69 6e 67 29 0a 09 09 09 09 28 keepgoing).....(
3d60: 6d 65 6d 62 65 72 20 28 74 65 73 74 3a 67 65 74 member (test:get
3d70: 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 74 29 -status testdat)
3d80: 20 27 28 22 50 41 53 53 22 20 22 57 41 52 4e 22 '("PASS" "WARN"
3d90: 20 22 43 48 45 43 4b 22 29 29 29 0a 09 09 09 20 "CHECK")))....
3da0: 20 20 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 (set! runflag
3db0: 23 66 29 29 0a 09 09 09 20 20 3b 3b 20 2d 72 65 #f)).... ;; -re
3dc0: 72 75 6e 20 61 6e 64 20 73 74 61 74 75 73 20 69 run and status i
3dd0: 73 20 6f 6e 65 20 6f 66 20 74 68 65 20 73 70 65 s one of the spe
3de0: 63 69 66 65 64 2c 20 72 75 6e 20 69 74 0a 09 09 cifed, run it...
3df0: 09 20 20 28 28 61 6e 64 20 72 65 72 75 6e 0a 09 . ((and rerun..
3e00: 09 09 09 28 6c 65 74 20 28 28 72 65 72 75 6e 6c ...(let ((rerunl
3e10: 73 74 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 st (string-split
3e20: 20 72 65 72 75 6e 20 22 2c 22 29 29 29 20 3b 3b rerun ","))) ;;
3e30: 20 46 41 49 4c 2c 0a 09 09 09 09 20 20 28 6d 65 FAIL,..... (me
3e40: 6d 62 65 72 20 28 74 65 73 74 3a 67 65 74 2d 73 mber (test:get-s
3e50: 74 61 74 75 73 20 74 65 73 74 64 61 74 29 20 72 tatus testdat) r
3e60: 65 72 75 6e 6c 73 74 29 29 29 0a 09 09 09 20 20 erunlst)))....
3e70: 20 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 (set! runflag #
3e80: 74 29 29 0a 09 09 09 20 20 3b 3b 20 2d 6b 65 65 t)).... ;; -kee
3e90: 70 67 6f 69 6e 67 2c 20 64 6f 20 6e 6f 74 20 72 pgoing, do not r
3ea0: 65 72 75 6e 20 46 41 49 4c 0a 09 09 09 20 20 28 erun FAIL.... (
3eb0: 28 61 6e 64 20 6b 65 65 70 67 6f 69 6e 67 0a 09 (and keepgoing..
3ec0: 09 09 09 28 6d 65 6d 62 65 72 20 28 74 65 73 74 ...(member (test
3ed0: 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 :get-status test
3ee0: 64 61 74 29 20 27 28 22 46 41 49 4c 22 29 29 29 dat) '("FAIL")))
3ef0: 0a 09 09 09 20 20 20 28 73 65 74 21 20 72 75 6e .... (set! run
3f00: 66 6c 61 67 20 23 66 29 29 0a 09 09 09 20 20 28 flag #f)).... (
3f10: 28 61 6e 64 20 28 6e 6f 74 20 72 65 72 75 6e 29 (and (not rerun)
3f20: 0a 09 09 09 09 28 6d 65 6d 62 65 72 20 28 74 65 .....(member (te
3f30: 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 st:get-status te
3f40: 73 74 64 61 74 29 20 27 28 22 46 41 49 4c 22 20 stdat) '("FAIL"
3f50: 22 6e 2f 61 22 29 29 29 0a 09 09 09 20 20 20 28 "n/a"))).... (
3f60: 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 74 29 set! runflag #t)
3f70: 29 0a 09 09 09 20 20 28 65 6c 73 65 20 28 73 65 ).... (else (se
3f80: 74 21 20 72 75 6e 66 6c 61 67 20 23 66 29 29 29 t! runflag #f)))
3f90: 0a 09 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e .... (debug:prin
3fa0: 74 20 36 20 22 52 55 4e 4e 49 4e 47 20 3d 3e 20 t 6 "RUNNING =>
3fb0: 72 75 6e 66 6c 61 67 3a 20 22 20 72 75 6e 66 6c runflag: " runfl
3fc0: 61 67 20 22 20 53 54 41 54 45 3a 20 22 20 28 74 ag " STATE: " (t
3fd0: 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 est:get-state te
3fe0: 73 74 64 61 74 29 20 22 20 53 54 41 54 55 53 3a stdat) " STATUS:
3ff0: 20 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 " (test:get-sta
4000: 74 75 73 20 74 65 73 74 64 61 74 29 29 0a 09 09 tus testdat))...
4010: 09 20 28 69 66 20 28 6e 6f 74 20 72 75 6e 66 6c . (if (not runfl
4020: 61 67 29 0a 09 09 09 20 20 20 20 20 28 69 66 20 ag).... (if
4030: 28 6e 6f 74 20 70 61 72 65 6e 74 2d 74 65 73 74 (not parent-test
4040: 29 0a 09 09 09 09 20 28 64 65 62 75 67 3a 70 72 )..... (debug:pr
4050: 69 6e 74 20 31 20 22 4e 4f 54 45 3a 20 4e 6f 74 int 1 "NOTE: Not
4060: 20 73 74 61 72 74 69 6e 67 20 74 65 73 74 20 22 starting test "
4070: 20 6e 65 77 2d 74 65 73 74 2d 6e 61 6d 65 20 22 new-test-name "
4080: 20 61 73 20 69 74 20 69 73 20 73 74 61 74 65 20 as it is state
4090: 5c 22 43 4f 4d 50 4c 45 54 45 44 5c 22 20 61 6e \"COMPLETED\" an
40a0: 64 20 73 74 61 74 75 73 20 5c 22 22 20 28 74 65 d status \"" (te
40b0: 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 st:get-status te
40c0: 73 74 64 61 74 29 20 22 5c 22 2c 20 75 73 65 20 stdat) "\", use
40d0: 2d 66 6f 72 63 65 20 74 6f 20 6f 76 65 72 72 69 -force to overri
40e0: 64 65 22 29 29 0a 09 09 09 20 20 20 20 20 28 6c de")).... (l
40f0: 65 74 2a 20 28 28 67 65 74 2d 70 72 65 72 65 71 et* ((get-prereq
4100: 73 2d 63 6d 64 20 28 6c 61 6d 62 64 61 20 28 29 s-cmd (lambda ()
4110: 0a 09 09 09 09 09 09 20 20 20 20 20 20 20 28 64 ....... (d
4120: 62 2d 67 65 74 2d 70 72 65 72 65 71 73 2d 6e 6f b-get-prereqs-no
4130: 74 2d 6d 65 74 20 64 62 20 72 75 6e 2d 69 64 20 t-met db run-id
4140: 77 61 69 74 6f 6e 29 29 29 20 3b 3b 20 63 68 65 waiton))) ;; che
4150: 63 6b 20 62 65 66 6f 72 65 20 72 75 6e 6e 69 6e ck before runnin
4160: 67 20 2e 2e 2e 2e 0a 09 09 09 09 20 20 20 20 28 g ......... (
4170: 6c 61 75 6e 63 68 2d 63 6d 64 20 20 20 20 20 20 launch-cmd
4180: 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 09 09 (lambda ()......
4190: 09 20 20 20 20 20 20 20 28 6c 61 75 6e 63 68 2d . (launch-
41a0: 74 65 73 74 20 64 62 20 72 75 6e 2d 69 64 20 72 test db run-id r
41b0: 75 6e 6e 61 6d 65 20 74 65 73 74 2d 63 6f 6e 66 unname test-conf
41c0: 20 6b 65 79 76 61 6c 6c 73 74 20 74 65 73 74 2d keyvallst test-
41d0: 6e 61 6d 65 20 74 65 73 74 2d 70 61 74 68 20 69 name test-path i
41e0: 74 65 6d 64 61 74 20 66 6c 61 67 73 29 29 29 0a temdat flags))).
41f0: 09 09 09 09 20 20 20 20 28 74 65 73 74 72 75 6e .... (testrun
4200: 64 61 74 20 20 20 20 20 20 28 6c 69 73 74 20 67 dat (list g
4210: 65 74 2d 70 72 65 72 65 71 73 2d 63 6d 64 20 6c et-prereqs-cmd l
4220: 61 75 6e 63 68 2d 63 6d 64 29 29 29 0a 09 09 09 aunch-cmd)))....
4230: 20 20 20 20 20 20 20 28 69 66 20 28 6f 72 20 66 (if (or f
4240: 6f 72 63 65 0a 09 09 09 09 20 20 20 20 20 20 20 orce.....
4250: 28 6c 65 74 20 28 28 70 72 65 71 73 2d 6e 6f 74 (let ((preqs-not
4260: 2d 79 65 74 2d 6d 65 74 20 28 28 63 61 72 20 74 -yet-met ((car t
4270: 65 73 74 72 75 6e 64 61 74 29 29 29 29 0a 09 09 estrundat))))...
4280: 09 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ... (debug:print
4290: 20 32 20 22 50 72 65 71 72 65 71 75 65 73 69 74 2 "Preqrequesit
42a0: 65 73 20 66 6f 72 20 22 20 74 65 73 74 2d 6e 61 es for " test-na
42b0: 6d 65 20 22 3a 20 22 20 70 72 65 71 73 2d 6e 6f me ": " preqs-no
42c0: 74 2d 79 65 74 2d 6d 65 74 29 0a 09 09 09 09 09 t-yet-met)......
42d0: 20 28 6e 75 6c 6c 3f 20 70 72 65 71 73 2d 6e 6f (null? preqs-no
42e0: 74 2d 79 65 74 2d 6d 65 74 29 29 29 20 3b 3b 20 t-yet-met))) ;;
42f0: 61 72 65 20 74 68 65 72 65 20 61 6e 79 20 74 65 are there any te
4300: 73 74 73 20 74 68 61 74 20 6d 75 73 74 20 62 65 sts that must be
4310: 20 72 75 6e 20 62 65 66 6f 72 65 20 74 68 69 73 run before this
4320: 20 6f 6e 65 2e 2e 2e 0a 09 09 09 09 20 20 20 28 one........ (
4330: 69 66 20 28 6e 6f 74 20 28 28 63 61 64 72 20 74 if (not ((cadr t
4340: 65 73 74 72 75 6e 64 61 74 29 29 29 20 3b 3b 20 estrundat))) ;;
4350: 74 68 69 73 20 69 73 20 74 68 65 20 6c 69 6e 65 this is the line
4360: 20 74 68 61 74 20 6c 61 75 6e 63 68 65 73 20 74 that launches t
4370: 68 65 20 74 65 73 74 20 74 6f 20 74 68 65 20 72 he test to the r
4380: 65 6d 6f 74 65 20 68 6f 73 74 0a 09 09 09 09 20 emote host.....
4390: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 (begin....
43a0: 09 09 20 28 70 72 69 6e 74 20 22 45 52 52 4f 52 .. (print "ERROR
43b0: 3a 20 46 61 69 6c 65 64 20 74 6f 20 6c 61 75 6e : Failed to laun
43c0: 63 68 20 74 68 65 20 74 65 73 74 2e 20 45 78 69 ch the test. Exi
43d0: 74 69 6e 67 20 61 73 20 73 6f 6f 6e 20 61 73 20 ting as soon as
43e0: 70 6f 73 73 69 62 6c 65 22 29 0a 09 09 09 09 09 possible")......
43f0: 20 28 73 65 74 21 20 2a 67 6c 6f 62 61 6c 65 78 (set! *globalex
4400: 69 74 73 74 61 74 75 73 2a 20 31 29 20 3b 3b 20 itstatus* 1) ;;
4410: 0a 09 09 09 09 09 20 28 70 72 6f 63 65 73 73 2d ...... (process-
4420: 73 69 67 6e 61 6c 20 28 63 75 72 72 65 6e 74 2d signal (current-
4430: 70 72 6f 63 65 73 73 2d 69 64 29 20 73 69 67 6e process-id) sign
4440: 61 6c 2f 6b 69 6c 6c 29 0a 09 09 09 09 09 20 3b al/kill)...... ;
4450: 28 65 78 69 74 20 31 29 0a 09 09 09 09 09 20 29 (exit 1)...... )
4460: 29 0a 09 09 09 09 20 20 20 28 69 66 20 28 6e 6f )..... (if (no
4470: 74 20 6b 65 65 70 67 6f 69 6e 67 29 0a 09 09 09 t keepgoing)....
4480: 09 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 . (hash-ta
4490: 62 6c 65 2d 73 65 74 21 20 2a 77 61 69 74 69 6e ble-set! *waitin
44a0: 67 2d 71 75 65 75 65 2a 20 6e 65 77 2d 74 65 73 g-queue* new-tes
44b0: 74 2d 6e 61 6d 65 20 74 65 73 74 72 75 6e 64 61 t-name testrunda
44c0: 74 29 29 29 29 29 29 29 0a 09 09 20 20 20 20 20 t)))))))...
44d0: 20 28 28 4b 49 4c 4c 45 44 29 20 0a 09 09 20 20 ((KILLED) ...
44e0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
44f0: 74 20 31 20 22 4e 4f 54 45 3a 20 22 20 6e 65 77 t 1 "NOTE: " new
4500: 2d 74 65 73 74 2d 6e 61 6d 65 20 22 20 69 73 20 -test-name " is
4510: 61 6c 72 65 61 64 79 20 72 75 6e 6e 69 6e 67 20 already running
4520: 6f 72 20 77 61 73 20 65 78 70 6c 69 63 74 6c 79 or was explictly
4530: 20 6b 69 6c 6c 65 64 2c 20 75 73 65 20 2d 66 6f killed, use -fo
4540: 72 63 65 20 74 6f 20 6c 61 75 6e 63 68 20 69 74 rce to launch it
4550: 2e 22 29 29 0a 09 09 20 20 20 20 20 20 28 28 4c ."))... ((L
4560: 41 55 4e 43 48 45 44 20 52 45 4d 4f 54 45 48 4f AUNCHED REMOTEHO
4570: 53 54 53 54 41 52 54 20 52 55 4e 4e 49 4e 47 29 STSTART RUNNING)
4580: 20 20 0a 09 09 20 20 20 20 20 20 20 28 69 66 20 ... (if
4590: 28 3e 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 (> (- (current-s
45a0: 65 63 6f 6e 64 73 29 28 2b 20 28 64 62 3a 74 65 econds)(+ (db:te
45b0: 73 74 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 6d st-get-event_tim
45c0: 65 20 74 65 73 74 64 61 74 29 0a 09 09 09 09 09 e testdat)......
45d0: 09 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 . (db:test-g
45e0: 65 74 2d 72 75 6e 5f 64 75 72 61 74 69 6f 6e 20 et-run_duration
45f0: 74 65 73 74 64 61 74 29 29 29 0a 09 09 09 20 20 testdat)))....
4600: 20 20 20 20 31 30 30 29 20 3b 3b 20 69 2e 65 2e 100) ;; i.e.
4610: 20 6e 6f 20 75 70 64 61 74 65 20 66 6f 72 20 6d no update for m
4620: 6f 72 65 20 74 68 61 6e 20 31 30 30 20 73 65 63 ore than 100 sec
4630: 6f 6e 64 73 0a 09 09 09 20 20 20 28 62 65 67 69 onds.... (begi
4640: 6e 0a 09 09 09 20 20 20 20 20 28 64 65 62 75 67 n.... (debug
4650: 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e :print 0 "WARNIN
4660: 47 3a 20 54 65 73 74 20 22 20 74 65 73 74 2d 6e G: Test " test-n
4670: 61 6d 65 20 22 20 61 70 70 65 61 72 73 20 74 6f ame " appears to
4680: 20 62 65 20 64 65 61 64 2e 20 46 6f 72 63 69 6e be dead. Forcin
4690: 67 20 69 74 20 74 6f 20 73 74 61 74 65 20 49 4e g it to state IN
46a0: 43 4f 4d 50 4c 45 54 45 20 61 6e 64 20 73 74 61 COMPLETE and sta
46b0: 74 75 73 20 53 54 55 43 4b 2f 44 45 41 44 22 29 tus STUCK/DEAD")
46c0: 0a 09 09 09 20 20 20 20 20 28 74 65 73 74 2d 73 .... (test-s
46d0: 65 74 2d 73 74 61 74 75 73 21 20 64 62 20 72 75 et-status! db ru
46e0: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 22 n-id test-name "
46f0: 49 4e 43 4f 4d 50 4c 45 54 45 22 20 22 53 54 55 INCOMPLETE" "STU
4700: 43 4b 2f 44 45 41 44 22 20 69 74 65 6d 64 61 74 CK/DEAD" itemdat
4710: 20 22 54 65 73 74 20 69 73 20 73 74 75 63 6b 20 "Test is stuck
4720: 6f 72 20 64 65 61 64 22 20 23 66 29 29 0a 09 09 or dead" #f))...
4730: 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 . (debug:print
4740: 20 32 20 22 4e 4f 54 45 3a 20 22 20 74 65 73 74 2 "NOTE: " test
4750: 2d 6e 61 6d 65 20 22 20 69 73 20 61 6c 72 65 61 -name " is alrea
4760: 64 79 20 72 75 6e 6e 69 6e 67 22 29 29 29 0a 09 dy running")))..
4770: 09 20 20 20 20 20 20 28 65 6c 73 65 20 20 20 20 . (else
4780: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
4790: 30 20 22 45 52 52 4f 52 3a 20 46 61 69 6c 65 64 0 "ERROR: Failed
47a0: 20 74 6f 20 6c 61 75 6e 63 68 20 74 65 73 74 20 to launch test
47b0: 22 20 6e 65 77 2d 74 65 73 74 2d 6e 61 6d 65 20 " new-test-name
47c0: 22 2e 20 55 6e 72 65 63 6f 67 6e 69 73 65 64 20 ". Unrecognised
47d0: 73 74 61 74 65 20 22 20 28 74 65 73 74 3a 67 65 state " (test:ge
47e0: 74 2d 73 74 61 74 65 20 74 65 73 74 64 61 74 29 t-state testdat)
47f0: 29 29 29 29 29 0a 09 20 20 20 20 20 20 28 69 66 ))))).. (if
4800: 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c (not (null? tal
4810: 29 29 0a 09 09 20 20 28 6c 6f 6f 70 20 28 63 61 ))... (loop (ca
4820: 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 29 r tal)(cdr tal))
4830: 29 29 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d )))))))..;;=====
4840: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4850: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4860: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4870: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4880: 3d 0a 3b 3b 20 45 4e 44 20 4f 46 20 4e 45 57 20 =.;; END OF NEW
4890: 53 54 55 46 46 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d STUFF.;;========
48a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
48b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
48c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
48d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
48e0: 28 64 65 66 69 6e 65 20 28 67 65 74 2d 64 69 72 (define (get-dir
48f0: 2d 75 70 2d 6e 20 64 69 72 20 2e 20 70 61 72 61 -up-n dir . para
4900: 6d 73 29 20 0a 20 20 28 6c 65 74 20 28 28 64 70 ms) . (let ((dp
4910: 61 72 74 73 20 20 28 73 74 72 69 6e 67 2d 73 70 arts (string-sp
4920: 6c 69 74 20 64 69 72 20 22 2f 22 29 29 0a 09 28 lit dir "/"))..(
4930: 63 6f 75 6e 74 20 20 20 28 69 66 20 28 6e 75 6c count (if (nul
4940: 6c 3f 20 70 61 72 61 6d 73 29 20 31 20 28 63 61 l? params) 1 (ca
4950: 72 20 70 61 72 61 6d 73 29 29 29 29 0a 20 20 20 r params)))).
4960: 20 28 63 6f 6e 63 20 22 2f 22 20 28 73 74 72 69 (conc "/" (stri
4970: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 0a ng-intersperse .
4980: 09 20 20 20 20 20 20 20 28 74 61 6b 65 20 64 70 . (take dp
4990: 61 72 74 73 20 28 2d 20 28 6c 65 6e 67 74 68 20 arts (- (length
49a0: 64 70 61 72 74 73 29 20 63 6f 75 6e 74 29 29 0a dparts) count)).
49b0: 09 20 20 20 20 20 20 20 22 2f 22 29 29 29 29 0a . "/")))).
49c0: 3b 3b 20 52 65 6d 6f 76 65 20 72 75 6e 73 0a 3b ;; Remove runs.;
49d0: 3b 20 66 69 65 6c 64 73 20 61 72 65 20 70 61 73 ; fields are pas
49e0: 73 69 6e 67 20 69 6e 20 74 68 72 6f 75 67 68 20 sing in through
49f0: 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 72 .(define (runs:r
4a00: 65 6d 6f 76 65 2d 72 75 6e 73 20 64 62 20 72 75 emove-runs db ru
4a10: 6e 6e 61 6d 65 70 61 74 74 20 74 65 73 74 70 61 nnamepatt testpa
4a20: 74 74 20 69 74 65 6d 70 61 74 74 29 0a 20 20 28 tt itempatt). (
4a30: 6c 65 74 2a 20 28 28 6b 65 79 73 20 20 20 20 20 let* ((keys
4a40: 20 20 20 28 64 62 2d 67 65 74 2d 6b 65 79 73 20 (db-get-keys
4a50: 64 62 29 29 0a 09 20 28 72 75 6e 64 61 74 20 20 db)).. (rundat
4a60: 20 20 20 20 28 72 75 6e 73 3a 67 65 74 2d 72 75 (runs:get-ru
4a70: 6e 73 2d 62 79 2d 70 61 74 74 20 64 62 20 6b 65 ns-by-patt db ke
4a80: 79 73 20 72 75 6e 6e 61 6d 65 70 61 74 74 29 29 ys runnamepatt))
4a90: 0a 09 20 28 68 65 61 64 65 72 20 20 20 20 20 20 .. (header
4aa0: 28 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 64 (vector-ref rund
4ab0: 61 74 20 30 29 29 0a 09 20 28 72 75 6e 73 20 20 at 0)).. (runs
4ac0: 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 (vector-re
4ad0: 66 20 72 75 6e 64 61 74 20 31 29 29 29 0a 20 20 f rundat 1))).
4ae0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 (debug:print 1
4af0: 20 22 48 65 61 64 65 72 3a 20 22 20 68 65 61 64 "Header: " head
4b00: 65 72 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 er). (for-eac
4b10: 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 h. (lambda (
4b20: 72 75 6e 29 0a 20 20 20 20 20 20 20 28 6c 65 74 run). (let
4b30: 20 28 28 72 75 6e 6b 65 79 20 28 73 74 72 69 6e ((runkey (strin
4b40: 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 6d g-intersperse (m
4b50: 61 70 20 28 6c 61 6d 62 64 61 20 28 6b 29 0a 09 ap (lambda (k)..
4b60: 09 09 09 09 09 28 64 62 3a 67 65 74 2d 76 61 6c .....(db:get-val
4b70: 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e ue-by-header run
4b80: 20 68 65 61 64 65 72 20 28 76 65 63 74 6f 72 2d header (vector-
4b90: 72 65 66 20 6b 20 30 29 29 29 20 6b 65 79 73 29 ref k 0))) keys)
4ba0: 20 22 2f 22 29 29 0a 09 20 20 20 20 20 28 64 69 "/")).. (di
4bb0: 72 73 2d 74 6f 2d 72 65 6d 6f 76 65 20 28 6d 61 rs-to-remove (ma
4bc0: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 ke-hash-table)))
4bd0: 0a 09 20 28 6c 65 74 2a 20 28 28 72 75 6e 2d 69 .. (let* ((run-i
4be0: 64 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d d (db:get-value-
4bf0: 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 by-header run he
4c00: 61 64 65 72 20 22 69 64 22 29 20 29 0a 09 09 28 ader "id") )...(
4c10: 74 65 73 74 73 20 20 28 64 62 2d 67 65 74 2d 74 tests (db-get-t
4c20: 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 64 62 20 ests-for-run db
4c30: 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 (db:get-value-by
4c40: 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 -header run head
4c50: 65 72 20 22 69 64 22 29 20 74 65 73 74 70 61 74 er "id") testpat
4c60: 74 20 69 74 65 6d 70 61 74 74 20 27 28 29 20 27 t itempatt '() '
4c70: 28 29 29 29 0a 09 09 28 6c 61 73 74 74 70 61 74 ()))...(lasttpat
4c80: 68 20 22 2f 64 6f 65 73 2f 6e 6f 74 2f 65 78 69 h "/does/not/exi
4c90: 73 74 2f 49 2f 68 6f 70 65 22 29 29 0a 0a 09 20 st/I/hope"))...
4ca0: 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c (if (not (null
4cb0: 3f 20 74 65 73 74 73 29 29 0a 09 20 20 20 20 20 ? tests))..
4cc0: 20 20 28 62 65 67 69 6e 0a 09 09 20 28 64 65 62 (begin... (deb
4cd0: 75 67 3a 70 72 69 6e 74 20 31 20 22 52 65 6d 6f ug:print 1 "Remo
4ce0: 76 69 6e 67 20 74 65 73 74 73 20 66 6f 72 20 72 ving tests for r
4cf0: 75 6e 3a 20 22 20 72 75 6e 6b 65 79 20 22 20 22 un: " runkey " "
4d00: 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 (db:get-value-b
4d10: 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 y-header run hea
4d20: 64 65 72 20 22 72 75 6e 6e 61 6d 65 22 29 29 0a der "runname")).
4d30: 09 09 20 28 66 6f 72 2d 65 61 63 68 0a 09 09 20 .. (for-each...
4d40: 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 29 0a (lambda (test).
4d50: 09 09 20 20 20 20 28 6c 65 74 2a 20 28 28 69 74 .. (let* ((it
4d60: 65 6d 2d 70 61 74 68 20 28 64 62 3a 74 65 73 74 em-path (db:test
4d70: 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 -get-item-path t
4d80: 65 73 74 29 29 0a 09 09 09 20 20 20 28 74 65 73 est)).... (tes
4d90: 74 2d 6e 61 6d 65 20 28 64 62 3a 74 65 73 74 2d t-name (db:test-
4da0: 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 get-testname tes
4db0: 74 29 29 0a 09 09 09 20 20 20 28 72 75 6e 2d 64 t)).... (run-d
4dc0: 69 72 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 ir (db:test-ge
4dd0: 74 2d 72 75 6e 64 69 72 20 74 65 73 74 29 29 29 t-rundir test)))
4de0: 0a 09 09 20 20 20 20 20 20 28 64 65 62 75 67 3a ... (debug:
4df0: 70 72 69 6e 74 20 31 20 22 20 20 22 20 28 64 62 print 1 " " (db
4e00: 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 :test-get-testna
4e10: 6d 65 20 74 65 73 74 29 20 22 20 69 64 3a 20 22 me test) " id: "
4e20: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 (db:test-get-id
4e30: 20 74 65 73 74 29 20 22 20 22 20 69 74 65 6d 2d test) " " item-
4e40: 70 61 74 68 29 0a 09 09 20 20 20 20 20 20 28 64 path)... (d
4e50: 62 3a 64 65 6c 65 74 65 2d 74 65 73 74 2d 72 65 b:delete-test-re
4e60: 63 6f 72 64 73 20 64 62 20 28 64 62 3a 74 65 73 cords db (db:tes
4e70: 74 2d 67 65 74 2d 69 64 20 74 65 73 74 29 29 0a t-get-id test)).
4e80: 09 09 20 20 20 20 20 20 28 69 66 20 28 3e 20 28 .. (if (> (
4e90: 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 72 75 string-length ru
4ea0: 6e 2d 64 69 72 29 20 35 29 20 3b 3b 20 62 61 64 n-dir) 5) ;; bad
4eb0: 20 68 65 75 72 69 73 74 69 63 20 62 75 74 20 73 heuristic but s
4ec0: 68 6f 75 6c 64 20 70 72 65 76 65 6e 74 20 2f 74 hould prevent /t
4ed0: 6d 70 20 2f 68 6f 6d 65 20 65 74 63 2e 0a 09 09 mp /home etc....
4ee0: 09 20 20 28 6c 65 74 20 28 28 66 75 6c 6c 70 61 . (let ((fullpa
4ef0: 74 68 20 72 75 6e 2d 64 69 72 29 29 20 3b 3b 20 th run-dir)) ;;
4f00: 22 2f 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 "/" (db:test-get
4f10: 2d 69 74 65 6d 2d 70 61 74 68 20 74 65 73 74 29 -item-path test)
4f20: 29 29 29 0a 09 09 09 20 20 20 20 28 73 65 74 21 ))).... (set!
4f30: 20 6c 61 73 74 74 70 61 74 68 20 66 75 6c 6c 70 lasttpath fullp
4f40: 61 74 68 29 0a 09 09 09 20 20 20 20 28 68 61 73 ath).... (has
4f50: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 64 69 72 h-table-set! dir
4f60: 73 2d 74 6f 2d 72 65 6d 6f 76 65 20 66 75 6c 6c s-to-remove full
4f70: 70 61 74 68 20 23 74 29 0a 09 09 09 20 20 20 20 path #t)....
4f80: 3b 3b 20 54 68 65 20 66 6f 6c 6c 6f 77 69 6e 67 ;; The following
4f90: 20 77 61 73 20 74 68 65 20 73 61 66 65 20 64 65 was the safe de
4fa0: 6c 65 74 65 20 63 6f 64 65 20 62 75 74 20 69 74 lete code but it
4fb0: 20 77 61 73 20 6e 6f 74 20 62 65 69 6e 67 20 65 was not being e
4fc0: 78 65 63 74 75 74 65 64 2e 0a 09 09 09 20 20 20 xectuted.....
4fd0: 20 3b 3b 20 28 6c 65 74 2a 20 28 28 64 69 72 73 ;; (let* ((dirs
4fe0: 2d 63 6f 75 6e 74 20 28 2b 20 31 20 28 6c 65 6e -count (+ 1 (len
4ff0: 67 74 68 20 6b 65 79 73 29 28 6c 65 6e 67 74 68 gth keys)(length
5000: 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 69 (string-split i
5010: 74 65 6d 2d 70 61 74 68 20 22 2f 22 29 29 29 29 tem-path "/"))))
5020: 0a 09 09 09 20 20 20 20 3b 3b 20 20 20 20 20 20 .... ;;
5030: 20 20 28 64 69 72 2d 74 6f 2d 72 65 6d 20 28 67 (dir-to-rem (g
5040: 65 74 2d 64 69 72 2d 75 70 2d 6e 20 66 75 6c 6c et-dir-up-n full
5050: 70 61 74 68 20 64 69 72 73 2d 63 6f 75 6e 74 29 path dirs-count)
5060: 29 0a 09 09 09 20 20 20 20 3b 3b 20 20 20 20 20 ).... ;;
5070: 20 20 20 28 72 65 6d 61 69 6e 69 6e 67 64 20 28 (remainingd (
5080: 73 74 72 69 6e 67 2d 73 75 62 73 74 69 74 75 74 string-substitut
5090: 65 20 28 72 65 67 65 78 70 20 28 63 6f 6e 63 20 e (regexp (conc
50a0: 22 5e 22 20 64 69 72 2d 74 6f 2d 72 65 6d 20 22 "^" dir-to-rem "
50b0: 2f 22 29 29 20 22 22 20 66 75 6c 6c 70 61 74 68 /")) "" fullpath
50c0: 29 29 0a 09 09 09 20 20 20 20 3b 3b 20 20 20 20 )).... ;;
50d0: 20 20 20 20 28 63 6d 64 20 28 63 6f 6e 63 20 22 (cmd (conc "
50e0: 63 64 20 22 20 64 69 72 2d 74 6f 2d 72 65 6d 20 cd " dir-to-rem
50f0: 22 3b 20 72 6d 64 69 72 20 2d 70 20 22 20 72 65 "; rmdir -p " re
5100: 6d 61 69 6e 69 6e 67 64 20 29 29 29 0a 09 09 09 mainingd )))....
5110: 20 20 20 20 3b 3b 20 20 20 28 69 66 20 28 66 69 ;; (if (fi
5120: 6c 65 2d 65 78 69 73 74 73 3f 20 66 75 6c 6c 70 le-exists? fullp
5130: 61 74 68 29 0a 09 09 09 20 20 20 20 3b 3b 20 20 ath).... ;;
5140: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 20 (begin....
5150: 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 28 64 ;; (d
5160: 65 62 75 67 3a 70 72 69 6e 74 20 31 20 63 6d 64 ebug:print 1 cmd
5170: 29 0a 09 09 09 20 20 20 20 3b 3b 20 20 20 20 20 ).... ;;
5180: 20 20 20 20 28 73 79 73 74 65 6d 20 63 6d 64 29 (system cmd)
5190: 29 29 0a 09 09 09 20 20 20 20 3b 3b 20 20 20 29 )).... ;; )
51a0: 29 0a 09 09 09 20 20 20 20 29 29 29 29 0a 09 09 ).... ))))...
51b0: 20 20 20 20 74 65 73 74 73 29 29 29 0a 0a 09 20 tests)))...
51c0: 20 20 3b 3b 20 6c 6f 6f 6b 20 74 68 6f 75 67 68 ;; look though
51d0: 20 74 68 65 20 64 69 72 73 2d 74 6f 2d 72 65 6d the dirs-to-rem
51e0: 6f 76 65 20 66 6f 72 20 63 61 6e 64 69 64 61 74 ove for candidat
51f0: 65 73 20 66 6f 72 20 72 65 6d 6f 76 61 6c 2e 20 es for removal.
5200: 44 6f 20 74 68 69 73 20 61 66 74 65 72 20 64 65 Do this after de
5210: 6c 65 74 69 6e 67 20 74 68 65 20 72 65 63 6f 72 leting the recor
5220: 64 73 0a 09 20 20 20 3b 3b 20 66 6f 72 20 65 61 ds.. ;; for ea
5230: 63 68 20 74 65 73 74 20 69 6e 20 63 61 73 65 20 ch test in case
5240: 77 65 20 67 65 74 20 6b 69 6c 6c 65 64 2e 20 54 we get killed. T
5250: 68 61 74 20 73 68 6f 75 6c 64 20 6d 69 6e 69 6d hat should minim
5260: 69 7a 65 20 74 68 65 20 64 65 74 72 69 74 75 73 ize the detritus
5270: 20 6c 65 66 74 20 6f 6e 20 64 69 73 6b 0a 09 20 left on disk..
5280: 20 20 3b 3b 20 70 72 6f 63 65 73 73 20 74 68 65 ;; process the
5290: 20 64 69 72 73 20 66 72 6f 6d 20 6c 6f 6e 67 65 dirs from longe
52a0: 73 74 20 73 74 72 69 6e 67 20 6c 65 6e 67 74 68 st string length
52b0: 20 74 6f 20 73 68 6f 72 74 65 73 74 0a 09 20 20 to shortest..
52c0: 20 28 66 6f 72 2d 65 61 63 68 20 0a 09 20 20 20 (for-each ..
52d0: 20 28 6c 61 6d 62 64 61 20 28 64 69 72 2d 74 6f (lambda (dir-to
52e0: 2d 72 65 6d 6f 76 65 29 0a 09 20 20 20 20 20 20 -remove)..
52f0: 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 (if (file-exists
5300: 3f 20 64 69 72 2d 74 6f 2d 72 65 6d 6f 76 65 29 ? dir-to-remove)
5310: 0a 09 09 20 20 28 6c 65 74 20 28 28 64 69 72 2d ... (let ((dir-
5320: 69 6e 2d 64 62 20 27 28 29 29 29 0a 09 09 20 20 in-db '()))...
5330: 20 20 28 73 71 6c 69 74 65 33 3a 66 6f 72 2d 65 (sqlite3:for-e
5340: 61 63 68 2d 72 6f 77 0a 09 09 20 20 20 20 20 28 ach-row... (
5350: 6c 61 6d 62 64 61 20 28 64 69 72 29 0a 09 09 20 lambda (dir)...
5360: 20 20 20 20 20 20 28 73 65 74 21 20 64 69 72 2d (set! dir-
5370: 69 6e 2d 64 62 20 28 63 6f 6e 73 20 64 69 72 20 in-db (cons dir
5380: 64 69 72 2d 69 6e 2d 64 62 29 29 29 0a 09 09 20 dir-in-db)))...
5390: 20 20 20 20 64 62 20 22 53 45 4c 45 43 54 20 72 db "SELECT r
53a0: 75 6e 64 69 72 20 46 52 4f 4d 20 74 65 73 74 73 undir FROM tests
53b0: 20 57 48 45 52 45 20 72 75 6e 64 69 72 20 4c 49 WHERE rundir LI
53c0: 4b 45 20 3f 3b 22 20 0a 09 09 20 20 20 20 20 28 KE ?;" ... (
53d0: 63 6f 6e 63 20 22 25 22 20 64 69 72 2d 74 6f 2d conc "%" dir-to-
53e0: 72 65 6d 6f 76 65 20 22 25 22 29 29 20 3b 3b 20 remove "%")) ;;
53f0: 79 65 73 2c 20 49 27 6d 20 67 6f 69 6e 67 20 74 yes, I'm going t
5400: 6f 20 62 61 69 6c 20 69 66 20 74 68 65 72 65 20 o bail if there
5410: 69 73 20 61 6e 79 74 68 69 6e 67 20 6c 69 6b 65 is anything like
5420: 20 74 68 69 73 20 64 69 72 20 69 6e 20 74 68 65 this dir in the
5430: 20 64 62 0a 09 09 20 20 20 20 28 69 66 20 28 6e db... (if (n
5440: 75 6c 6c 3f 20 64 69 72 2d 69 6e 2d 64 62 29 0a ull? dir-in-db).
5450: 09 09 09 28 62 65 67 69 6e 0a 09 09 09 20 20 28 ...(begin.... (
5460: 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 52 debug:print 2 "R
5470: 65 6d 6f 76 69 6e 67 20 64 69 72 65 63 74 6f 72 emoving director
5480: 79 20 77 69 74 68 20 7a 65 72 6f 20 64 62 20 72 y with zero db r
5490: 65 66 65 72 65 6e 63 65 73 3a 20 22 20 64 69 72 eferences: " dir
54a0: 2d 74 6f 2d 72 65 6d 6f 76 65 29 0a 09 09 09 20 -to-remove)....
54b0: 20 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 (system (conc "
54c0: 72 6d 20 2d 72 66 20 22 20 64 69 72 2d 74 6f 2d rm -rf " dir-to-
54d0: 72 65 6d 6f 76 65 29 29 0a 09 09 09 20 20 28 68 remove)).... (h
54e0: 61 73 68 2d 74 61 62 6c 65 2d 64 65 6c 65 74 65 ash-table-delete
54f0: 21 20 64 69 72 73 2d 74 6f 2d 72 65 6d 6f 76 65 ! dirs-to-remove
5500: 20 64 69 72 2d 74 6f 2d 72 65 6d 6f 76 65 29 29 dir-to-remove))
5510: 0a 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 ....(debug:print
5520: 20 32 20 22 53 6b 69 70 70 69 6e 67 20 72 65 6d 2 "Skipping rem
5530: 6f 76 61 6c 20 6f 66 20 22 20 64 69 72 2d 74 6f oval of " dir-to
5540: 2d 72 65 6d 6f 76 65 20 22 20 66 6f 72 20 6e 6f -remove " for no
5550: 77 20 61 73 20 69 74 20 73 74 69 6c 6c 20 68 61 w as it still ha
5560: 73 20 72 65 66 65 72 65 6e 63 65 73 20 69 6e 20 s references in
5570: 74 68 65 20 64 61 74 61 62 61 73 65 22 29 29 29 the database")))
5580: 29 29 0a 09 20 20 20 20 28 73 6f 72 74 20 28 68 )).. (sort (h
5590: 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 64 ash-table-keys d
55a0: 69 72 73 2d 74 6f 2d 72 65 6d 6f 76 65 29 20 28 irs-to-remove) (
55b0: 6c 61 6d 62 64 61 20 28 61 20 62 29 28 3e 20 28 lambda (a b)(> (
55c0: 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 61 29 string-length a)
55d0: 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 62 (string-length b
55e0: 29 29 29 29 29 0a 0a 09 20 20 20 3b 3b 20 72 65 )))))... ;; re
55f0: 6d 6f 76 65 20 74 68 65 20 72 75 6e 20 69 66 20 move the run if
5600: 7a 65 72 6f 20 74 65 73 74 73 20 72 65 6d 61 69 zero tests remai
5610: 6e 0a 09 20 20 20 28 6c 65 74 20 28 28 72 65 6d n.. (let ((rem
5620: 74 65 73 74 73 20 28 64 62 2d 67 65 74 2d 74 65 tests (db-get-te
5630: 73 74 73 2d 66 6f 72 2d 72 75 6e 20 64 62 20 28 sts-for-run db (
5640: 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d db:get-value-by-
5650: 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 header run heade
5660: 72 20 22 69 64 22 29 20 23 66 20 23 66 20 27 28 r "id") #f #f '(
5670: 29 20 27 28 29 29 29 29 0a 09 20 20 20 20 20 28 ) '()))).. (
5680: 69 66 20 28 6e 75 6c 6c 3f 20 72 65 6d 74 65 73 if (null? remtes
5690: 74 73 29 20 3b 3b 20 6e 6f 20 6d 6f 72 65 20 74 ts) ;; no more t
56a0: 65 73 74 73 20 72 65 6d 61 69 6e 69 6e 67 0a 09 ests remaining..
56b0: 09 20 28 6c 65 74 2a 20 28 28 64 70 61 72 74 73 . (let* ((dparts
56c0: 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 (string-split
56d0: 6c 61 73 74 74 70 61 74 68 20 22 2f 22 29 29 0a lasttpath "/")).
56e0: 09 09 09 28 72 75 6e 70 61 74 68 20 28 63 6f 6e ...(runpath (con
56f0: 63 20 22 2f 22 20 28 73 74 72 69 6e 67 2d 69 6e c "/" (string-in
5700: 74 65 72 73 70 65 72 73 65 20 0a 09 09 09 09 09 tersperse ......
5710: 20 20 20 20 28 74 61 6b 65 20 64 70 61 72 74 73 (take dparts
5720: 20 28 2d 20 28 6c 65 6e 67 74 68 20 64 70 61 72 (- (length dpar
5730: 74 73 29 20 31 29 29 0a 09 09 09 09 09 20 20 20 ts) 1))......
5740: 20 22 2f 22 29 29 29 29 0a 09 09 20 20 20 28 64 "/"))))... (d
5750: 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 52 65 ebug:print 1 "Re
5760: 6d 6f 76 69 6e 67 20 72 75 6e 3a 20 22 20 72 75 moving run: " ru
5770: 6e 6b 65 79 20 22 20 22 20 28 64 62 3a 67 65 74 nkey " " (db:get
5780: 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 -value-by-header
5790: 20 72 75 6e 20 68 65 61 64 65 72 20 22 72 75 6e run header "run
57a0: 6e 61 6d 65 22 29 29 0a 09 09 20 20 20 28 64 62 name"))... (db
57b0: 3a 64 65 6c 65 74 65 2d 72 75 6e 20 64 62 20 72 :delete-run db r
57c0: 75 6e 2d 69 64 29 0a 09 09 20 20 20 3b 3b 20 6e un-id)... ;; n
57d0: 65 65 64 20 74 6f 20 66 69 67 75 72 65 20 6f 75 eed to figure ou
57e0: 74 20 74 68 65 20 70 61 74 68 20 74 6f 20 74 68 t the path to th
57f0: 65 20 72 75 6e 20 64 69 72 20 61 6e 64 20 72 65 e run dir and re
5800: 6d 6f 76 65 20 69 74 20 69 66 20 65 6d 70 74 79 move it if empty
5810: 0a 09 09 20 20 20 3b 3b 20 20 20 20 28 69 66 20 ... ;; (if
5820: 28 6e 75 6c 6c 3f 20 28 67 6c 6f 62 20 28 63 6f (null? (glob (co
5830: 6e 63 20 72 75 6e 70 61 74 68 20 22 2f 2a 22 29 nc runpath "/*")
5840: 29 29 0a 09 09 20 20 20 3b 3b 20 20 20 20 20 20 ))... ;;
5850: 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 3b 3b (begin... ;;
5860: 20 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 . (debug:print
5870: 31 20 22 52 65 6d 6f 76 69 6e 67 20 72 75 6e 20 1 "Removing run
5880: 64 69 72 20 22 20 72 75 6e 70 61 74 68 29 0a 09 dir " runpath)..
5890: 09 20 20 20 3b 3b 20 09 20 28 73 79 73 74 65 6d . ;; . (system
58a0: 20 28 63 6f 6e 63 20 22 72 6d 64 69 72 20 2d 70 (conc "rmdir -p
58b0: 20 22 20 72 75 6e 70 61 74 68 29 29 29 29 0a 09 " runpath))))..
58c0: 09 20 20 20 29 29 29 29 0a 09 20 29 29 0a 20 20 . )))).. )).
58d0: 20 20 20 72 75 6e 73 29 29 29 0a 0a 3b 3b 3d 3d runs)))..;;==
58e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
58f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5900: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5910: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5920: 3d 3d 3d 3d 0a 3b 3b 20 52 6f 75 74 69 6e 65 73 ====.;; Routines
5930: 20 66 6f 72 20 6d 61 6e 69 70 75 6c 61 74 69 6e for manipulatin
5940: 67 20 72 75 6e 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d g runs.;;=======
5950: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5960: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5970: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5980: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
5990: 0a 3b 3b 20 53 69 6e 63 65 20 6d 61 6e 79 20 63 .;; Since many c
59a0: 61 6c 6c 73 20 74 6f 20 61 20 72 75 6e 20 72 65 alls to a run re
59b0: 71 75 69 72 65 20 70 72 65 74 74 79 20 6d 75 63 quire pretty muc
59c0: 68 20 74 68 65 20 73 61 6d 65 20 73 65 74 75 70 h the same setup
59d0: 20 0a 3b 3b 20 74 68 69 73 20 77 72 61 70 70 65 .;; this wrappe
59e0: 72 20 69 73 20 75 73 65 64 20 74 6f 20 72 65 64 r is used to red
59f0: 75 63 65 20 74 68 65 20 72 65 70 6c 69 63 61 74 uce the replicat
5a00: 69 6f 6e 20 6f 66 20 63 6f 64 65 0a 28 64 65 66 ion of code.(def
5a10: 69 6e 65 20 28 67 65 6e 65 72 61 6c 2d 72 75 6e ine (general-run
5a20: 2d 63 61 6c 6c 20 73 77 69 74 63 68 6e 61 6d 65 -call switchname
5a30: 20 61 63 74 69 6f 6e 2d 64 65 73 63 20 70 72 6f action-desc pro
5a40: 63 29 0a 20 20 28 69 66 20 28 6e 6f 74 20 28 61 c). (if (not (a
5a50: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 3a 72 75 rgs:get-arg ":ru
5a60: 6e 6e 61 6d 65 22 29 29 0a 20 20 20 20 20 20 28 nname")). (
5a70: 62 65 67 69 6e 0a 09 28 64 65 62 75 67 3a 70 72 begin..(debug:pr
5a80: 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 4d 69 int 0 "ERROR: Mi
5a90: 73 73 69 6e 67 20 72 65 71 75 69 72 65 64 20 70 ssing required p
5aa0: 61 72 61 6d 65 74 65 72 20 66 6f 72 20 22 20 73 arameter for " s
5ab0: 77 69 74 63 68 6e 61 6d 65 20 22 2c 20 79 6f 75 witchname ", you
5ac0: 20 6d 75 73 74 20 73 70 65 63 69 66 79 20 74 68 must specify th
5ad0: 65 20 72 75 6e 20 6e 61 6d 65 20 77 69 74 68 20 e run name with
5ae0: 3a 72 75 6e 6e 61 6d 65 20 72 75 6e 6e 61 6d 65 :runname runname
5af0: 22 29 0a 09 28 65 78 69 74 20 32 29 29 0a 20 20 ")..(exit 2)).
5b00: 20 20 20 20 28 6c 65 74 20 28 28 64 62 20 20 20 (let ((db
5b10: 23 66 29 0a 09 20 20 20 20 28 6b 65 79 73 20 23 #f).. (keys #
5b20: 66 29 29 0a 09 28 69 66 20 28 6e 6f 74 20 28 73 f))..(if (not (s
5b30: 65 74 75 70 2d 66 6f 72 2d 72 75 6e 29 29 0a 09 etup-for-run))..
5b40: 20 20 20 20 28 62 65 67 69 6e 20 0a 09 20 20 20 (begin ..
5b50: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
5b60: 30 20 22 46 61 69 6c 65 64 20 74 6f 20 73 65 74 0 "Failed to set
5b70: 75 70 2c 20 65 78 69 74 69 6e 67 22 29 0a 09 20 up, exiting")..
5b80: 20 20 20 20 20 28 65 78 69 74 20 31 29 29 29 0a (exit 1))).
5b90: 09 28 73 65 74 21 20 64 62 20 20 20 28 6f 70 65 .(set! db (ope
5ba0: 6e 2d 64 62 29 29 0a 09 28 73 65 74 21 20 6b 65 n-db))..(set! ke
5bb0: 79 73 20 28 64 62 2d 67 65 74 2d 6b 65 79 73 20 ys (db-get-keys
5bc0: 64 62 29 29 0a 09 3b 3b 20 68 61 76 65 20 65 6e db))..;; have en
5bd0: 6f 75 67 68 20 74 6f 20 70 72 6f 63 65 73 73 20 ough to process
5be0: 2d 74 61 72 67 65 74 20 6f 72 20 2d 72 65 71 74 -target or -reqt
5bf0: 61 72 67 20 68 65 72 65 0a 09 28 69 66 20 28 61 arg here..(if (a
5c00: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 rgs:get-arg "-re
5c10: 71 74 61 72 67 22 29 0a 09 20 20 20 20 28 6c 65 qtarg").. (le
5c20: 74 2a 20 28 28 72 75 6e 63 6f 6e 66 69 67 66 20 t* ((runconfigf
5c30: 28 63 6f 6e 63 20 20 2a 74 6f 70 70 61 74 68 2a (conc *toppath*
5c40: 20 22 2f 72 75 6e 63 6f 6e 66 69 67 73 2e 63 6f "/runconfigs.co
5c50: 6e 66 69 67 22 29 29 20 3b 3b 20 44 4f 20 4e 4f nfig")) ;; DO NO
5c60: 54 20 45 56 41 4c 55 41 54 45 20 41 4c 4c 20 0a T EVALUATE ALL .
5c70: 09 09 20 20 20 28 72 75 6e 63 6f 6e 66 69 67 20 .. (runconfig
5c80: 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 72 75 (read-config ru
5c90: 6e 63 6f 6e 66 69 67 66 20 23 66 20 23 66 20 65 nconfigf #f #f e
5ca0: 6e 76 69 72 6f 6e 2d 70 61 74 74 3a 20 23 66 29 nviron-patt: #f)
5cb0: 29 29 20 0a 09 20 20 20 20 20 20 28 69 66 20 28 )) .. (if (
5cc0: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
5cd0: 65 66 61 75 6c 74 20 72 75 6e 63 6f 6e 66 69 67 efault runconfig
5ce0: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
5cf0: 2d 72 65 71 74 61 72 67 22 29 20 23 66 29 0a 09 -reqtarg") #f)..
5d00: 09 20 20 28 6b 65 79 73 3a 74 61 72 67 65 74 2d . (keys:target-
5d10: 73 65 74 2d 61 72 67 73 20 6b 65 79 73 20 28 61 set-args keys (a
5d20: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 rgs:get-arg "-re
5d30: 71 74 61 72 67 22 29 20 61 72 67 73 3a 61 72 67 qtarg") args:arg
5d40: 2d 68 61 73 68 29 0a 09 09 20 20 28 62 65 67 69 -hash)... (begi
5d50: 6e 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 n... (debug:p
5d60: 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 5b rint 0 "ERROR: [
5d70: 22 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 " (args:get-arg
5d80: 22 2d 72 65 71 74 61 72 67 22 29 20 22 5d 20 6e "-reqtarg") "] n
5d90: 6f 74 20 66 6f 75 6e 64 20 69 6e 20 22 20 72 75 ot found in " ru
5da0: 6e 63 6f 6e 66 69 67 66 29 0a 09 09 20 20 20 20 nconfigf)...
5db0: 28 73 71 6c 69 74 65 33 3a 66 69 6e 61 6c 69 7a (sqlite3:finaliz
5dc0: 65 21 20 64 62 29 0a 09 09 20 20 20 20 28 65 78 e! db)... (ex
5dd0: 69 74 20 31 29 29 29 29 0a 09 20 20 20 20 28 69 it 1)))).. (i
5de0: 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 f (args:get-arg
5df0: 22 2d 74 61 72 67 65 74 22 29 0a 09 09 28 6b 65 "-target")...(ke
5e00: 79 73 3a 74 61 72 67 65 74 2d 73 65 74 2d 61 72 ys:target-set-ar
5e10: 67 73 20 6b 65 79 73 20 28 61 72 67 73 3a 67 65 gs keys (args:ge
5e20: 74 2d 61 72 67 20 22 2d 74 61 72 67 65 74 22 20 t-arg "-target"
5e30: 61 72 67 73 3a 61 72 67 2d 68 61 73 68 29 20 61 args:arg-hash) a
5e40: 72 67 73 3a 61 72 67 2d 68 61 73 68 29 29 29 0a rgs:arg-hash))).
5e50: 09 28 69 66 20 28 6e 6f 74 20 28 63 61 72 20 2a .(if (not (car *
5e60: 63 6f 6e 66 69 67 69 6e 66 6f 2a 29 29 0a 09 20 configinfo*))..
5e70: 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 (begin..
5e80: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
5e90: 22 45 52 52 4f 52 3a 20 41 74 74 65 6d 70 74 65 "ERROR: Attempte
5ea0: 64 20 74 6f 20 22 20 61 63 74 69 6f 6e 2d 64 65 d to " action-de
5eb0: 73 63 20 22 20 62 75 74 20 72 75 6e 20 61 72 65 sc " but run are
5ec0: 61 20 63 6f 6e 66 69 67 20 66 69 6c 65 20 6e 6f a config file no
5ed0: 74 20 66 6f 75 6e 64 22 29 0a 09 20 20 20 20 20 t found")..
5ee0: 20 28 65 78 69 74 20 31 29 29 0a 09 20 20 20 20 (exit 1))..
5ef0: 3b 3b 20 45 78 74 72 61 63 74 20 6f 75 74 20 73 ;; Extract out s
5f00: 74 75 66 66 20 6e 65 65 64 65 64 20 69 6e 20 6d tuff needed in m
5f10: 6f 73 74 20 6f 72 20 6d 61 6e 79 20 63 61 6c 6c ost or many call
5f20: 73 0a 09 20 20 20 20 3b 3b 20 68 65 72 65 20 74 s.. ;; here t
5f30: 68 65 6e 20 63 61 6c 6c 20 70 72 6f 63 0a 09 20 hen call proc..
5f40: 20 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 6e 61 (let* ((keyna
5f50: 6d 65 73 20 20 20 28 6d 61 70 20 6b 65 79 3a 67 mes (map key:g
5f60: 65 74 2d 66 69 65 6c 64 6e 61 6d 65 20 6b 65 79 et-fieldname key
5f70: 73 29 29 0a 09 09 20 20 20 28 6b 65 79 76 61 6c s))... (keyval
5f80: 6c 73 74 20 20 28 6b 65 79 73 2d 3e 76 61 6c 6c lst (keys->vall
5f90: 69 73 74 20 6b 65 79 73 20 23 74 29 29 29 0a 09 ist keys #t)))..
5fa0: 20 20 20 20 20 20 28 70 72 6f 63 20 64 62 20 6b (proc db k
5fb0: 65 79 73 20 6b 65 79 6e 61 6d 65 73 20 6b 65 79 eys keynames key
5fc0: 76 61 6c 6c 73 74 29 29 29 0a 09 28 73 71 6c 69 vallst)))..(sqli
5fd0: 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 64 62 te3:finalize! db
5fe0: 29 0a 09 28 73 65 74 21 20 2a 64 69 64 73 6f 6d )..(set! *didsom
5ff0: 65 74 68 69 6e 67 2a 20 23 74 29 29 29 29 0a 0a ething* #t))))..
6000: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
6010: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6020: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6030: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6040: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 52 6f 6c 6c ========.;; Roll
6050: 75 70 20 72 75 6e 73 0a 3b 3b 3d 3d 3d 3d 3d 3d up runs.;;======
6060: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6070: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6080: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6090: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
60a0: 0a 0a 3b 3b 20 55 70 64 61 74 65 20 74 68 65 20 ..;; Update the
60b0: 74 65 73 74 5f 6d 65 74 61 20 74 61 62 6c 65 20 test_meta table
60c0: 66 6f 72 20 74 68 69 73 20 74 65 73 74 0a 28 64 for this test.(d
60d0: 65 66 69 6e 65 20 28 72 75 6e 73 3a 75 70 64 61 efine (runs:upda
60e0: 74 65 2d 74 65 73 74 5f 6d 65 74 61 20 64 62 20 te-test_meta db
60f0: 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 63 test-name test-c
6100: 6f 6e 66 29 0a 20 20 28 6c 65 74 20 28 28 63 75 onf). (let ((cu
6110: 72 72 72 65 63 6f 72 64 20 28 64 62 3a 74 65 73 rrrecord (db:tes
6120: 74 6d 65 74 61 2d 67 65 74 2d 72 65 63 6f 72 64 tmeta-get-record
6130: 20 64 62 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 db test-name)))
6140: 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 63 75 . (if (not cu
6150: 72 72 72 65 63 6f 72 64 29 0a 09 28 62 65 67 69 rrrecord)..(begi
6160: 6e 0a 09 20 20 28 73 65 74 21 20 63 75 72 72 72 n.. (set! currr
6170: 65 63 6f 72 64 20 28 6d 61 6b 65 2d 76 65 63 74 ecord (make-vect
6180: 6f 72 20 31 30 20 23 66 29 29 0a 09 20 20 28 64 or 10 #f)).. (d
6190: 62 3a 74 65 73 74 6d 65 74 61 2d 61 64 64 2d 72 b:testmeta-add-r
61a0: 65 63 6f 72 64 20 64 62 20 74 65 73 74 2d 6e 61 ecord db test-na
61b0: 6d 65 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 me))). (for-e
61c0: 61 63 68 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 ach . (lambd
61d0: 61 20 28 6b 65 79 29 0a 20 20 20 20 20 20 20 28 a (key). (
61e0: 6c 65 74 2a 20 28 28 69 64 78 20 28 63 61 64 72 let* ((idx (cadr
61f0: 20 6b 65 79 29 29 0a 09 20 20 20 20 20 20 28 66 key)).. (f
6200: 6c 64 20 28 63 61 72 20 20 6b 65 79 29 29 0a 09 ld (car key))..
6210: 20 20 20 20 20 20 28 76 61 6c 20 28 63 6f 6e 66 (val (conf
6220: 69 67 2d 6c 6f 6f 6b 75 70 20 74 65 73 74 2d 63 ig-lookup test-c
6230: 6f 6e 66 20 22 74 65 73 74 5f 6d 65 74 61 22 20 onf "test_meta"
6240: 66 6c 64 29 29 29 0a 09 20 28 69 66 20 28 61 6e fld))).. (if (an
6250: 64 20 76 61 6c 20 28 6e 6f 74 20 28 65 71 75 61 d val (not (equa
6260: 6c 3f 20 28 76 65 63 74 6f 72 2d 72 65 66 20 63 l? (vector-ref c
6270: 75 72 72 72 65 63 6f 72 64 20 69 64 78 29 20 76 urrrecord idx) v
6280: 61 6c 29 29 29 0a 09 20 20 20 20 20 28 62 65 67 al))).. (beg
6290: 69 6e 0a 09 20 20 20 20 20 20 20 28 70 72 69 6e in.. (prin
62a0: 74 20 22 55 70 64 61 74 69 6e 67 20 22 20 74 65 t "Updating " te
62b0: 73 74 2d 6e 61 6d 65 20 22 20 22 20 66 6c 64 20 st-name " " fld
62c0: 22 20 74 6f 20 22 20 76 61 6c 29 0a 09 20 20 20 " to " val)..
62d0: 20 20 20 20 28 64 62 3a 74 65 73 74 6d 65 74 61 (db:testmeta
62e0: 2d 75 70 64 61 74 65 2d 66 69 65 6c 64 20 64 62 -update-field db
62f0: 20 74 65 73 74 2d 6e 61 6d 65 20 66 6c 64 20 76 test-name fld v
6300: 61 6c 29 29 29 29 29 0a 20 20 20 20 20 27 28 28 al))))). '((
6310: 22 61 75 74 68 6f 72 22 20 32 29 28 22 6f 77 6e "author" 2)("own
6320: 65 72 22 20 33 29 28 22 64 65 73 63 72 69 70 74 er" 3)("descript
6330: 69 6f 6e 22 20 34 29 28 22 72 65 76 69 65 77 65 ion" 4)("reviewe
6340: 64 22 20 35 29 28 22 74 61 67 73 22 20 39 29 29 d" 5)("tags" 9))
6350: 29 29 29 0a 0a 3b 3b 20 55 70 64 61 74 65 20 74 )))..;; Update t
6360: 65 73 74 5f 6d 65 74 61 20 66 6f 72 20 61 6c 6c est_meta for all
6370: 20 74 65 73 74 73 0a 28 64 65 66 69 6e 65 20 28 tests.(define (
6380: 72 75 6e 73 3a 75 70 64 61 74 65 2d 61 6c 6c 2d runs:update-all-
6390: 74 65 73 74 5f 6d 65 74 61 20 64 62 29 0a 20 20 test_meta db).
63a0: 28 6c 65 74 20 28 28 74 65 73 74 2d 6e 61 6d 65 (let ((test-name
63b0: 73 20 28 67 65 74 2d 61 6c 6c 2d 6c 65 67 61 6c s (get-all-legal
63c0: 2d 74 65 73 74 73 29 29 29 0a 20 20 20 20 28 66 -tests))). (f
63d0: 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 20 28 6c or-each . (l
63e0: 61 6d 62 64 61 20 28 74 65 73 74 2d 6e 61 6d 65 ambda (test-name
63f0: 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 ). (let* (
6400: 28 74 65 73 74 2d 70 61 74 68 20 20 20 20 28 63 (test-path (c
6410: 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f onc *toppath* "/
6420: 74 65 73 74 73 2f 22 20 74 65 73 74 2d 6e 61 6d tests/" test-nam
6430: 65 29 29 0a 09 20 20 20 20 20 20 28 74 65 73 74 e)).. (test
6440: 2d 63 6f 6e 66 69 67 66 20 28 63 6f 6e 63 20 74 -configf (conc t
6450: 65 73 74 2d 70 61 74 68 20 22 2f 74 65 73 74 63 est-path "/testc
6460: 6f 6e 66 69 67 22 29 29 0a 09 20 20 20 20 20 20 onfig"))..
6470: 28 74 65 73 74 65 78 69 73 74 73 20 20 20 28 61 (testexists (a
6480: 6e 64 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f nd (file-exists?
6490: 20 74 65 73 74 2d 63 6f 6e 66 69 67 66 29 28 66 test-configf)(f
64a0: 69 6c 65 2d 72 65 61 64 2d 61 63 63 65 73 73 3f ile-read-access?
64b0: 20 74 65 73 74 2d 63 6f 6e 66 69 67 66 29 29 29 test-configf)))
64c0: 0a 09 20 20 20 20 20 20 3b 3b 20 72 65 61 64 20 .. ;; read
64d0: 63 6f 6e 66 69 67 73 20 77 69 74 68 20 74 72 69 configs with tri
64e0: 63 6b 73 20 74 75 72 6e 65 64 20 6f 66 66 20 28 cks turned off (
64f0: 69 2e 65 2e 20 6e 6f 20 73 79 73 74 65 6d 29 0a i.e. no system).
6500: 09 20 20 20 20 20 20 28 74 65 73 74 2d 63 6f 6e . (test-con
6510: 66 20 20 20 20 28 69 66 20 74 65 73 74 65 78 69 f (if testexi
6520: 73 74 73 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 sts (read-config
6530: 20 74 65 73 74 2d 63 6f 6e 66 69 67 66 20 23 66 test-configf #f
6540: 20 23 66 29 28 6d 61 6b 65 2d 68 61 73 68 2d 74 #f)(make-hash-t
6550: 61 62 6c 65 29 29 29 29 0a 09 20 28 72 75 6e 73 able)))).. (runs
6560: 3a 75 70 64 61 74 65 2d 74 65 73 74 5f 6d 65 74 :update-test_met
6570: 61 20 64 62 20 74 65 73 74 2d 6e 61 6d 65 20 74 a db test-name t
6580: 65 73 74 2d 63 6f 6e 66 29 29 29 0a 20 20 20 20 est-conf))).
6590: 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 29 0a 0a test-names)))..
65a0: 3b 3b 20 54 68 69 73 20 63 6f 75 6c 64 20 70 72 ;; This could pr
65b0: 6f 62 61 62 6c 79 20 62 65 20 72 65 66 61 63 74 obably be refact
65c0: 6f 72 65 64 20 69 6e 74 6f 20 6f 6e 65 20 63 6f ored into one co
65d0: 6d 70 6c 65 78 20 71 75 65 72 79 20 2e 2e 2e 0a mplex query ....
65e0: 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 72 6f (define (runs:ro
65f0: 6c 6c 75 70 2d 72 75 6e 20 64 62 20 6b 65 79 73 llup-run db keys
6600: 20 6b 65 79 76 61 6c 6c 73 74 20 72 75 6e 6e 61 keyvallst runna
6610: 6d 65 20 75 73 65 72 29 20 3b 3b 20 77 61 73 20 me user) ;; was
6620: 74 61 72 67 65 74 2c 20 6e 6f 77 20 6b 65 79 76 target, now keyv
6630: 61 6c 6c 73 74 0a 20 20 28 64 65 62 75 67 3a 70 allst. (debug:p
6640: 72 69 6e 74 20 34 20 22 72 75 6e 73 3a 72 6f 6c rint 4 "runs:rol
6650: 6c 75 70 2d 72 75 6e 2c 20 6b 65 79 73 3a 20 22 lup-run, keys: "
6660: 20 6b 65 79 73 20 22 20 6b 65 79 76 61 6c 6c 73 keys " keyvalls
6670: 74 3a 20 22 20 6b 65 79 76 61 6c 6c 73 74 20 22 t: " keyvallst "
6680: 20 3a 72 75 6e 6e 61 6d 65 20 22 20 72 75 6e 6e :runname " runn
6690: 61 6d 65 20 22 20 75 73 65 72 3a 20 22 20 75 73 ame " user: " us
66a0: 65 72 29 0a 20 20 28 6c 65 74 2a 20 28 3b 20 28 er). (let* (; (
66b0: 6b 65 79 76 61 6c 6c 6c 73 74 20 20 20 20 20 20 keyvalllst
66c0: 28 6b 65 79 73 3a 74 61 72 67 65 74 2d 3e 6b 65 (keys:target->ke
66d0: 79 76 61 6c 20 6b 65 79 73 20 74 61 72 67 65 74 yval keys target
66e0: 29 29 0a 09 20 28 6e 65 77 2d 72 75 6e 2d 69 64 )).. (new-run-id
66f0: 20 20 20 20 20 20 28 72 75 6e 73 3a 72 65 67 69 (runs:regi
6700: 73 74 65 72 2d 72 75 6e 20 64 62 20 6b 65 79 73 ster-run db keys
6710: 20 6b 65 79 76 61 6c 6c 73 74 20 72 75 6e 6e 61 keyvallst runna
6720: 6d 65 20 22 6e 65 77 22 20 22 6e 2f 61 22 20 75 me "new" "n/a" u
6730: 73 65 72 29 29 0a 09 20 28 70 72 65 76 2d 74 65 ser)).. (prev-te
6740: 73 74 73 20 20 20 20 20 20 28 74 65 73 74 3a 67 sts (test:g
6750: 65 74 2d 6d 61 74 63 68 69 6e 67 2d 70 72 65 76 et-matching-prev
6760: 69 6f 75 73 2d 74 65 73 74 2d 72 75 6e 2d 72 65 ious-test-run-re
6770: 63 6f 72 64 73 20 64 62 20 6e 65 77 2d 72 75 6e cords db new-run
6780: 2d 69 64 20 22 25 22 20 22 25 22 29 29 0a 09 20 -id "%" "%"))..
6790: 28 63 75 72 72 2d 74 65 73 74 73 20 20 20 20 20 (curr-tests
67a0: 20 28 64 62 2d 67 65 74 2d 74 65 73 74 73 2d 66 (db-get-tests-f
67b0: 6f 72 2d 72 75 6e 20 64 62 20 6e 65 77 2d 72 75 or-run db new-ru
67c0: 6e 2d 69 64 20 22 25 22 20 22 25 22 20 27 28 29 n-id "%" "%" '()
67d0: 20 27 28 29 29 29 0a 09 20 28 63 75 72 72 2d 74 '())).. (curr-t
67e0: 65 73 74 73 2d 68 61 73 68 20 28 6d 61 6b 65 2d ests-hash (make-
67f0: 68 61 73 68 2d 74 61 62 6c 65 29 29 29 0a 20 20 hash-table))).
6800: 20 20 28 64 62 3a 75 70 64 61 74 65 2d 72 75 6e (db:update-run
6810: 2d 65 76 65 6e 74 5f 74 69 6d 65 20 64 62 20 6e -event_time db n
6820: 65 77 2d 72 75 6e 2d 69 64 29 0a 20 20 20 20 3b ew-run-id). ;
6830: 3b 20 69 6e 64 65 78 20 74 68 65 20 61 6c 72 65 ; index the alre
6840: 61 64 79 20 73 61 76 65 64 20 74 65 73 74 73 20 ady saved tests
6850: 62 79 20 74 65 73 74 6e 61 6d 65 20 61 6e 64 20 by testname and
6860: 69 74 65 6d 70 61 74 68 20 69 6e 20 63 75 72 72 itempath in curr
6870: 2d 74 65 73 74 73 2d 68 61 73 68 0a 20 20 20 20 -tests-hash.
6880: 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 (for-each. (
6890: 6c 61 6d 62 64 61 20 28 74 65 73 74 64 61 74 29 lambda (testdat)
68a0: 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 . (let* ((
68b0: 74 65 73 74 6e 61 6d 65 20 20 28 64 62 3a 74 65 testname (db:te
68c0: 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 st-get-testname
68d0: 74 65 73 74 64 61 74 29 29 0a 09 20 20 20 20 20 testdat))..
68e0: 20 28 69 74 65 6d 2d 70 61 74 68 20 28 64 62 3a (item-path (db:
68f0: 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 test-get-item-pa
6900: 74 68 20 74 65 73 74 64 61 74 29 29 0a 09 20 20 th testdat))..
6910: 20 20 20 20 28 66 75 6c 6c 2d 6e 61 6d 65 20 28 (full-name (
6920: 63 6f 6e 63 20 74 65 73 74 6e 61 6d 65 20 22 2f conc testname "/
6930: 22 20 69 74 65 6d 2d 70 61 74 68 29 29 29 0a 09 " item-path)))..
6940: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
6950: 21 20 63 75 72 72 2d 74 65 73 74 73 2d 68 61 73 ! curr-tests-has
6960: 68 20 66 75 6c 6c 2d 6e 61 6d 65 20 74 65 73 74 h full-name test
6970: 64 61 74 29 29 29 0a 20 20 20 20 20 63 75 72 72 dat))). curr
6980: 2d 74 65 73 74 73 29 0a 20 20 20 20 3b 3b 20 4e -tests). ;; N
6990: 4f 50 45 3a 20 4e 6f 6e 2d 6f 70 74 69 6d 61 6c OPE: Non-optimal
69a0: 20 61 70 70 72 6f 61 63 68 2e 20 54 72 79 20 74 approach. Try t
69b0: 68 69 73 20 69 6e 73 74 65 61 64 2e 0a 20 20 20 his instead..
69c0: 20 3b 3b 20 20 20 31 2e 20 74 65 73 74 73 20 61 ;; 1. tests a
69d0: 72 65 20 72 65 63 65 69 76 65 64 20 69 6e 20 61 re received in a
69e0: 20 6c 69 73 74 2c 20 6d 6f 73 74 20 72 65 63 65 list, most rece
69f0: 6e 74 20 66 69 72 73 74 0a 20 20 20 20 3b 3b 20 nt first. ;;
6a00: 20 20 32 2e 20 72 65 70 6c 61 63 65 20 74 68 65 2. replace the
6a10: 20 72 6f 6c 6c 75 70 20 74 65 73 74 20 77 69 74 rollup test wit
6a20: 68 20 74 68 65 20 6e 65 77 20 2a 61 6c 77 61 79 h the new *alway
6a30: 73 2a 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 s*. (for-each
6a40: 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 . (lambda (
6a50: 74 65 73 74 64 61 74 29 0a 20 20 20 20 20 20 20 testdat).
6a60: 28 6c 65 74 2a 20 28 28 74 65 73 74 6e 61 6d 65 (let* ((testname
6a70: 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 (db:test-get-t
6a80: 65 73 74 6e 61 6d 65 20 74 65 73 74 64 61 74 29 estname testdat)
6a90: 29 0a 09 20 20 20 20 20 20 28 69 74 65 6d 2d 70 ).. (item-p
6aa0: 61 74 68 20 28 64 62 3a 74 65 73 74 2d 67 65 74 ath (db:test-get
6ab0: 2d 69 74 65 6d 2d 70 61 74 68 20 74 65 73 74 64 -item-path testd
6ac0: 61 74 29 29 0a 09 20 20 20 20 20 20 28 66 75 6c at)).. (ful
6ad0: 6c 2d 6e 61 6d 65 20 28 63 6f 6e 63 20 74 65 73 l-name (conc tes
6ae0: 74 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 tname "/" item-p
6af0: 61 74 68 29 29 0a 09 20 20 20 20 20 20 28 70 72 ath)).. (pr
6b00: 65 76 2d 74 65 73 74 2d 64 61 74 20 28 68 61 73 ev-test-dat (has
6b10: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
6b20: 75 6c 74 20 63 75 72 72 2d 74 65 73 74 73 2d 68 ult curr-tests-h
6b30: 61 73 68 20 66 75 6c 6c 2d 6e 61 6d 65 20 23 66 ash full-name #f
6b40: 29 29 0a 09 20 20 20 20 20 20 28 74 65 73 74 2d )).. (test-
6b50: 73 74 65 70 73 20 20 20 20 20 20 28 64 62 3a 67 steps (db:g
6b60: 65 74 2d 73 74 65 70 73 2d 66 6f 72 2d 74 65 73 et-steps-for-tes
6b70: 74 20 64 62 20 28 64 62 3a 74 65 73 74 2d 67 65 t db (db:test-ge
6b80: 74 2d 69 64 20 74 65 73 74 64 61 74 29 29 29 0a t-id testdat))).
6b90: 09 20 20 20 20 20 20 28 6e 65 77 2d 74 65 73 74 . (new-test
6ba0: 2d 72 65 63 6f 72 64 20 23 66 29 29 0a 09 20 3b -record #f)).. ;
6bb0: 3b 20 72 65 70 6c 61 63 65 20 74 68 65 73 65 20 ; replace these
6bc0: 77 69 74 68 20 69 6e 73 65 72 74 20 2e 2e 2e 20 with insert ...
6bd0: 73 65 6c 65 63 74 0a 09 20 28 61 70 70 6c 79 20 select.. (apply
6be0: 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 sqlite3:execute
6bf0: 0a 09 09 64 62 20 0a 09 09 28 63 6f 6e 63 20 22 ...db ...(conc "
6c00: 49 4e 53 45 52 54 20 4f 52 20 52 45 50 4c 41 43 INSERT OR REPLAC
6c10: 45 20 49 4e 54 4f 20 74 65 73 74 73 20 28 72 75 E INTO tests (ru
6c20: 6e 5f 69 64 2c 74 65 73 74 6e 61 6d 65 2c 73 74 n_id,testname,st
6c30: 61 74 65 2c 73 74 61 74 75 73 2c 65 76 65 6e 74 ate,status,event
6c40: 5f 74 69 6d 65 2c 68 6f 73 74 2c 63 70 75 6c 6f _time,host,cpulo
6c50: 61 64 2c 64 69 73 6b 66 72 65 65 2c 75 6e 61 6d ad,diskfree,unam
6c60: 65 2c 72 75 6e 64 69 72 2c 69 74 65 6d 5f 70 61 e,rundir,item_pa
6c70: 74 68 2c 72 75 6e 5f 64 75 72 61 74 69 6f 6e 2c th,run_duration,
6c80: 66 69 6e 61 6c 5f 6c 6f 67 66 2c 63 6f 6d 6d 65 final_logf,comme
6c90: 6e 74 29 20 22 0a 09 09 20 20 20 20 20 20 22 56 nt) "... "V
6ca0: 41 4c 55 45 53 20 28 3f 2c 3f 2c 3f 2c 3f 2c 3f ALUES (?,?,?,?,?
6cb0: 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f ,?,?,?,?,?,?,?,?
6cc0: 2c 3f 29 3b 22 29 0a 09 09 6e 65 77 2d 72 75 6e ,?);")...new-run
6cd0: 2d 69 64 20 28 63 64 64 72 20 28 76 65 63 74 6f -id (cddr (vecto
6ce0: 72 2d 3e 6c 69 73 74 20 74 65 73 74 64 61 74 29 r->list testdat)
6cf0: 29 29 0a 09 20 28 73 65 74 21 20 6e 65 77 2d 74 )).. (set! new-t
6d00: 65 73 74 64 61 74 20 28 63 61 72 20 28 64 62 2d estdat (car (db-
6d10: 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 get-tests-for-ru
6d20: 6e 20 64 62 20 6e 65 77 2d 72 75 6e 2d 69 64 20 n db new-run-id
6d30: 74 65 73 74 6e 61 6d 65 20 69 74 65 6d 2d 70 61 testname item-pa
6d40: 74 68 20 27 28 29 20 27 28 29 29 29 29 0a 09 20 th '() '())))..
6d50: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
6d60: 20 63 75 72 72 2d 74 65 73 74 73 2d 68 61 73 68 curr-tests-hash
6d70: 20 66 75 6c 6c 2d 6e 61 6d 65 20 6e 65 77 2d 74 full-name new-t
6d80: 65 73 74 64 61 74 29 20 3b 3b 20 74 68 69 73 20 estdat) ;; this
6d90: 63 6f 75 6c 64 20 62 65 20 63 6f 6e 66 75 73 69 could be confusi
6da0: 6e 67 2c 20 77 68 69 63 68 20 72 65 63 6f 72 64 ng, which record
6db0: 20 73 68 6f 75 6c 64 20 67 6f 20 69 6e 74 6f 20 should go into
6dc0: 74 68 65 20 6c 6f 6f 6b 75 70 20 74 61 62 6c 65 the lookup table
6dd0: 3f 0a 09 20 3b 3b 20 4e 6f 77 20 64 75 70 6c 69 ?.. ;; Now dupli
6de0: 63 61 74 65 20 74 68 65 20 74 65 73 74 20 73 74 cate the test st
6df0: 65 70 73 0a 09 20 28 64 65 62 75 67 3a 70 72 69 eps.. (debug:pri
6e00: 6e 74 20 34 20 22 43 6f 70 79 69 6e 67 20 72 65 nt 4 "Copying re
6e10: 63 6f 72 64 73 20 69 6e 20 74 65 73 74 5f 73 74 cords in test_st
6e20: 65 70 73 20 66 72 6f 6d 20 74 65 73 74 5f 69 64 eps from test_id
6e30: 3d 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d =" (db:test-get-
6e40: 69 64 20 74 65 73 74 64 61 74 29 20 22 20 74 6f id testdat) " to
6e50: 20 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d " (db:test-get-
6e60: 69 64 20 6e 65 77 2d 74 65 73 74 64 61 74 29 29 id new-testdat))
6e70: 0a 09 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 .. (sqlite3:exec
6e80: 75 74 65 20 0a 09 20 20 64 62 20 0a 09 20 20 28 ute .. db .. (
6e90: 63 6f 6e 63 20 22 49 4e 53 45 52 54 20 4f 52 20 conc "INSERT OR
6ea0: 52 45 50 4c 41 43 45 20 49 4e 54 4f 20 74 65 73 REPLACE INTO tes
6eb0: 74 5f 73 74 65 70 73 20 28 74 65 73 74 5f 69 64 t_steps (test_id
6ec0: 2c 73 74 65 70 6e 61 6d 65 2c 73 74 61 74 65 2c ,stepname,state,
6ed0: 73 74 61 74 75 73 2c 65 76 65 6e 74 5f 74 69 6d status,event_tim
6ee0: 65 2c 63 6f 6d 6d 65 6e 74 29 20 22 0a 09 09 22 e,comment) "..."
6ef0: 53 45 4c 45 43 54 20 22 20 28 64 62 3a 74 65 73 SELECT " (db:tes
6f00: 74 2d 67 65 74 2d 69 64 20 6e 65 77 2d 74 65 73 t-get-id new-tes
6f10: 74 64 61 74 29 20 22 2c 73 74 65 70 6e 61 6d 65 tdat) ",stepname
6f20: 2c 73 74 61 74 65 2c 73 74 61 74 75 73 2c 65 76 ,state,status,ev
6f30: 65 6e 74 5f 74 69 6d 65 2c 63 6f 6d 6d 65 6e 74 ent_time,comment
6f40: 20 46 52 4f 4d 20 74 65 73 74 5f 73 74 65 70 73 FROM test_steps
6f50: 20 57 48 45 52 45 20 74 65 73 74 5f 69 64 3d 3f WHERE test_id=?
6f60: 3b 22 29 0a 09 20 20 28 64 62 3a 74 65 73 74 2d ;").. (db:test-
6f70: 67 65 74 2d 69 64 20 74 65 73 74 64 61 74 29 29 get-id testdat))
6f80: 0a 09 20 3b 3b 20 4e 6f 77 20 64 75 70 6c 69 63 .. ;; Now duplic
6f90: 61 74 65 20 74 68 65 20 74 65 73 74 20 64 61 74 ate the test dat
6fa0: 61 0a 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 a.. (debug:print
6fb0: 20 34 20 22 43 6f 70 79 69 6e 67 20 72 65 63 6f 4 "Copying reco
6fc0: 72 64 73 20 69 6e 20 74 65 73 74 5f 64 61 74 61 rds in test_data
6fd0: 20 66 72 6f 6d 20 74 65 73 74 5f 69 64 3d 22 20 from test_id="
6fe0: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 (db:test-get-id
6ff0: 74 65 73 74 64 61 74 29 20 22 20 74 6f 20 22 20 testdat) " to "
7000: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 (db:test-get-id
7010: 6e 65 77 2d 74 65 73 74 64 61 74 29 29 0a 09 20 new-testdat))..
7020: 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 (sqlite3:execute
7030: 20 0a 09 20 20 64 62 20 0a 09 20 20 28 63 6f 6e .. db .. (con
7040: 63 20 22 49 4e 53 45 52 54 20 4f 52 20 52 45 50 c "INSERT OR REP
7050: 4c 41 43 45 20 49 4e 54 4f 20 74 65 73 74 5f 64 LACE INTO test_d
7060: 61 74 61 20 28 74 65 73 74 5f 69 64 2c 63 61 74 ata (test_id,cat
7070: 65 67 6f 72 79 2c 76 61 72 69 61 62 6c 65 2c 76 egory,variable,v
7080: 61 6c 75 65 2c 65 78 70 65 63 74 65 64 2c 74 6f alue,expected,to
7090: 6c 2c 75 6e 69 74 73 2c 63 6f 6d 6d 65 6e 74 29 l,units,comment)
70a0: 20 22 0a 09 09 22 53 45 4c 45 43 54 20 22 20 28 "..."SELECT " (
70b0: 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 6e db:test-get-id n
70c0: 65 77 2d 74 65 73 74 64 61 74 29 20 22 2c 63 61 ew-testdat) ",ca
70d0: 74 65 67 6f 72 79 2c 76 61 72 69 61 62 6c 65 2c tegory,variable,
70e0: 76 61 6c 75 65 2c 65 78 70 65 63 74 65 64 2c 74 value,expected,t
70f0: 6f 6c 2c 75 6e 69 74 73 2c 63 6f 6d 6d 65 6e 74 ol,units,comment
7100: 20 46 52 4f 4d 20 74 65 73 74 5f 64 61 74 61 20 FROM test_data
7110: 57 48 45 52 45 20 74 65 73 74 5f 69 64 3d 3f 3b WHERE test_id=?;
7120: 22 29 0a 09 20 20 28 64 62 3a 74 65 73 74 2d 67 ").. (db:test-g
7130: 65 74 2d 69 64 20 74 65 73 74 64 61 74 29 29 0a et-id testdat)).
7140: 09 20 29 29 0a 20 20 20 20 20 70 72 65 76 2d 74 . )). prev-t
7150: 65 73 74 73 29 29 29 0a 09 20 0a 20 20 20 20 20 ests))).. .
7160: 0a .