0000: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
0010: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0020: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0030: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0040: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 43 6f 70 79 ========.;; Copy
0050: 72 69 67 68 74 20 32 30 31 37 2c 20 4d 61 74 74 right 2017, Matt
0060: 68 65 77 20 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 hew Welland..;;
0070: 0a 3b 3b 20 54 68 69 73 20 66 69 6c 65 20 69 73 .;; This file is
0080: 20 70 61 72 74 20 6f 66 20 4d 65 67 61 74 65 73 part of Megates
0090: 74 2e 0a 3b 3b 20 0a 3b 3b 20 20 20 20 20 4d 65 t..;; .;; Me
00a0: 67 61 74 65 73 74 20 69 73 20 66 72 65 65 20 73 gatest is free s
00b0: 6f 66 74 77 61 72 65 3a 20 79 6f 75 20 63 61 6e oftware: you can
00c0: 20 72 65 64 69 73 74 72 69 62 75 74 65 20 69 74 redistribute it
00d0: 20 61 6e 64 2f 6f 72 20 6d 6f 64 69 66 79 0a 3b and/or modify.;
00e0: 3b 20 20 20 20 20 69 74 20 75 6e 64 65 72 20 74 ; it under t
00f0: 68 65 20 74 65 72 6d 73 20 6f 66 20 74 68 65 20 he terms of the
0100: 47 4e 55 20 47 65 6e 65 72 61 6c 20 50 75 62 6c GNU General Publ
0110: 69 63 20 4c 69 63 65 6e 73 65 20 61 73 20 70 75 ic License as pu
0120: 62 6c 69 73 68 65 64 20 62 79 0a 3b 3b 20 20 20 blished by.;;
0130: 20 20 74 68 65 20 46 72 65 65 20 53 6f 66 74 77 the Free Softw
0140: 61 72 65 20 46 6f 75 6e 64 61 74 69 6f 6e 2c 20 are Foundation,
0150: 65 69 74 68 65 72 20 76 65 72 73 69 6f 6e 20 33 either version 3
0160: 20 6f 66 20 74 68 65 20 4c 69 63 65 6e 73 65 2c of the License,
0170: 20 6f 72 0a 3b 3b 20 20 20 20 20 28 61 74 20 79 or.;; (at y
0180: 6f 75 72 20 6f 70 74 69 6f 6e 29 20 61 6e 79 20 our option) any
0190: 6c 61 74 65 72 20 76 65 72 73 69 6f 6e 2e 0a 3b later version..;
01a0: 3b 20 0a 3b 3b 20 20 20 20 20 4d 65 67 61 74 65 ; .;; Megate
01b0: 73 74 20 69 73 20 64 69 73 74 72 69 62 75 74 65 st is distribute
01c0: 64 20 69 6e 20 74 68 65 20 68 6f 70 65 20 74 68 d in the hope th
01d0: 61 74 20 69 74 20 77 69 6c 6c 20 62 65 20 75 73 at it will be us
01e0: 65 66 75 6c 2c 0a 3b 3b 20 20 20 20 20 62 75 74 eful,.;; but
01f0: 20 57 49 54 48 4f 55 54 20 41 4e 59 20 57 41 52 WITHOUT ANY WAR
0200: 52 41 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 65 RANTY; without e
0210: 76 65 6e 20 74 68 65 20 69 6d 70 6c 69 65 64 20 ven the implied
0220: 77 61 72 72 61 6e 74 79 20 6f 66 0a 3b 3b 20 20 warranty of.;;
0230: 20 20 20 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 MERCHANTABILI
0240: 54 59 20 6f 72 20 46 49 54 4e 45 53 53 20 46 4f TY or FITNESS FO
0250: 52 20 41 20 50 41 52 54 49 43 55 4c 41 52 20 50 R A PARTICULAR P
0260: 55 52 50 4f 53 45 2e 20 20 53 65 65 20 74 68 65 URPOSE. See the
0270: 0a 3b 3b 20 20 20 20 20 47 4e 55 20 47 65 6e 65 .;; GNU Gene
0280: 72 61 6c 20 50 75 62 6c 69 63 20 4c 69 63 65 6e ral Public Licen
0290: 73 65 20 66 6f 72 20 6d 6f 72 65 20 64 65 74 61 se for more deta
02a0: 69 6c 73 2e 0a 3b 3b 20 0a 3b 3b 20 20 20 20 20 ils..;; .;;
02b0: 59 6f 75 20 73 68 6f 75 6c 64 20 68 61 76 65 20 You should have
02c0: 72 65 63 65 69 76 65 64 20 61 20 63 6f 70 79 20 received a copy
02d0: 6f 66 20 74 68 65 20 47 4e 55 20 47 65 6e 65 72 of the GNU Gener
02e0: 61 6c 20 50 75 62 6c 69 63 20 4c 69 63 65 6e 73 al Public Licens
02f0: 65 0a 3b 3b 20 20 20 20 20 61 6c 6f 6e 67 20 77 e.;; along w
0300: 69 74 68 20 4d 65 67 61 74 65 73 74 2e 20 20 49 ith Megatest. I
0310: 66 20 6e 6f 74 2c 20 73 65 65 20 3c 68 74 74 70 f not, see <http
0320: 3a 2f 2f 77 77 77 2e 67 6e 75 2e 6f 72 67 2f 6c ://www.gnu.org/l
0330: 69 63 65 6e 73 65 73 2f 3e 2e 0a 0a 3b 3b 3d 3d icenses/>...;;==
0340: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0350: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0360: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0370: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0380: 3d 3d 3d 3d 0a 0a 28 64 65 63 6c 61 72 65 20 28 ====..(declare (
0390: 75 6e 69 74 20 74 65 73 74 73 6d 6f 64 29 29 0a unit testsmod)).
03a0: 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 6d (declare (uses m
03b0: 74 61 72 67 73 29 29 0a 28 64 65 63 6c 61 72 65 targs)).(declare
03c0: 20 28 75 73 65 73 20 64 65 62 75 67 70 72 69 6e (uses debugprin
03d0: 74 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 t)).(declare (us
03e0: 65 73 20 63 6f 6d 6d 6f 6e 6d 6f 64 29 29 0a 28 es commonmod)).(
03f0: 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 63 6f declare (uses co
0400: 6e 66 69 67 66 6d 6f 64 29 29 0a 28 64 65 63 6c nfigfmod)).(decl
0410: 61 72 65 20 28 75 73 65 73 20 69 74 65 6d 73 6d are (uses itemsm
0420: 6f 64 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 od)).(declare (u
0430: 73 65 73 20 72 6d 74 6d 6f 64 29 29 0a 28 64 65 ses rmtmod)).(de
0440: 63 6c 61 72 65 20 28 75 73 65 73 20 73 74 6d 6c clare (uses stml
0450: 32 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 2)).(declare (us
0460: 65 73 20 64 62 6d 6f 64 29 29 0a 28 64 65 63 6c es dbmod)).(decl
0470: 61 72 65 20 28 75 73 65 73 20 74 61 73 6b 73 6d are (uses tasksm
0480: 6f 64 29 29 0a 0a 28 6d 6f 64 75 6c 65 20 74 65 od))..(module te
0490: 73 74 73 6d 6f 64 0a 09 2a 0a 09 0a 28 69 6d 70 stsmod..*...(imp
04a0: 6f 72 74 20 73 63 68 65 6d 65 0a 0a 09 63 68 69 ort scheme...chi
04b0: 63 6b 65 6e 2e 62 61 73 65 0a 09 63 68 69 63 6b cken.base..chick
04c0: 65 6e 2e 63 6f 6e 64 69 74 69 6f 6e 0a 09 63 68 en.condition..ch
04d0: 69 63 6b 65 6e 2e 66 69 6c 65 0a 09 63 68 69 63 icken.file..chic
04e0: 6b 65 6e 2e 69 6f 0a 09 63 68 69 63 6b 65 6e 2e ken.io..chicken.
04f0: 70 61 74 68 6e 61 6d 65 0a 09 63 68 69 63 6b 65 pathname..chicke
0500: 6e 2e 65 76 61 6c 0a 09 63 68 69 63 6b 65 6e 2e n.eval..chicken.
0510: 66 69 6c 65 2e 70 6f 73 69 78 0a 09 63 68 69 63 file.posix..chic
0520: 6b 65 6e 2e 70 72 6f 63 65 73 73 2d 63 6f 6e 74 ken.process-cont
0530: 65 78 74 2e 70 6f 73 69 78 0a 09 63 68 69 63 6b ext.posix..chick
0540: 65 6e 2e 66 6f 72 6d 61 74 0a 09 63 68 69 63 6b en.format..chick
0550: 65 6e 2e 70 6f 72 74 0a 09 63 68 69 63 6b 65 6e en.port..chicken
0560: 2e 70 72 65 74 74 79 2d 70 72 69 6e 74 0a 09 63 .pretty-print..c
0570: 68 69 63 6b 65 6e 2e 70 72 6f 63 65 73 73 0a 09 hicken.process..
0580: 63 68 69 63 6b 65 6e 2e 70 72 6f 63 65 73 73 2d chicken.process-
0590: 63 6f 6e 74 65 78 74 0a 09 63 68 69 63 6b 65 6e context..chicken
05a0: 2e 73 6f 72 74 0a 09 63 68 69 63 6b 65 6e 2e 73 .sort..chicken.s
05b0: 74 72 69 6e 67 0a 09 63 68 69 63 6b 65 6e 2e 74 tring..chicken.t
05c0: 69 6d 65 0a 09 63 68 69 63 6b 65 6e 2e 72 61 6e ime..chicken.ran
05d0: 64 6f 6d 0a 09 0a 09 28 70 72 65 66 69 78 20 62 dom....(prefix b
05e0: 61 73 65 36 34 20 62 61 73 65 36 34 3a 29 0a 09 ase64 base64:)..
05f0: 28 70 72 65 66 69 78 20 64 62 69 20 64 62 69 3a (prefix dbi dbi:
0600: 29 0a 09 28 70 72 65 66 69 78 20 73 71 6c 69 74 )..(prefix sqlit
0610: 65 33 20 73 71 6c 69 74 65 33 3a 29 0a 09 28 73 e3 sqlite3:)..(s
0620: 72 66 69 20 31 38 29 0a 09 64 69 72 65 63 74 6f rfi 18)..directo
0630: 72 79 2d 75 74 69 6c 73 0a 09 66 6f 72 6d 61 74 ry-utils..format
0640: 0a 09 6d 61 74 63 68 61 62 6c 65 0a 09 6d 64 35 ..matchable..md5
0650: 0a 09 6d 65 73 73 61 67 65 2d 64 69 67 65 73 74 ..message-digest
0660: 0a 09 72 65 67 65 78 0a 09 72 65 67 65 78 2d 63 ..regex..regex-c
0670: 61 73 65 0a 09 73 70 61 72 73 65 2d 76 65 63 74 ase..sparse-vect
0680: 6f 72 73 0a 09 73 79 73 74 65 6d 2d 69 6e 66 6f ors..system-info
0690: 72 6d 61 74 69 6f 6e 0a 09 73 72 66 69 2d 31 0a rmation..srfi-1.
06a0: 09 73 72 66 69 2d 31 33 0a 09 73 72 66 69 2d 36 .srfi-13..srfi-6
06b0: 39 0a 09 73 74 61 63 6b 0a 09 74 79 70 65 64 2d 9..stack..typed-
06c0: 72 65 63 6f 72 64 73 0a 09 7a 33 0a 09 0a 09 64 records..z3....d
06d0: 65 62 75 67 70 72 69 6e 74 0a 09 28 70 72 65 66 ebugprint..(pref
06e0: 69 78 20 6d 74 61 72 67 73 20 61 72 67 73 3a 29 ix mtargs args:)
06f0: 0a 09 63 6f 6d 6d 6f 6e 6d 6f 64 0a 09 70 6b 74 ..commonmod..pkt
0700: 73 0a 09 69 74 65 6d 73 6d 6f 64 0a 09 72 6d 74 s..itemsmod..rmt
0710: 6d 6f 64 0a 09 63 6f 6e 66 69 67 66 6d 6f 64 0a mod..configfmod.
0720: 09 73 74 6d 6c 32 0a 09 64 62 6d 6f 64 0a 09 74 .stml2..dbmod..t
0730: 61 73 6b 73 6d 6f 64 0a 09 0a 09 29 0a 0a 3b 3b asksmod....)..;;
0740: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0750: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0760: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0770: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0780: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 54 65 73 74 73 0a ======.;; Tests.
0790: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
07a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
07b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
07c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
07d0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 28 64 65 ========..;; (de
07e0: 63 6c 61 72 65 20 28 75 6e 69 74 20 74 65 73 74 clare (unit test
07f0: 73 29 29 0a 3b 3b 20 28 64 65 63 6c 61 72 65 20 s)).;; (declare
0800: 28 75 73 65 73 20 6c 6f 63 6b 2d 71 75 65 75 65 (uses lock-queue
0810: 29 29 0a 3b 3b 20 28 64 65 63 6c 61 72 65 20 28 )).;; (declare (
0820: 75 73 65 73 20 64 62 29 29 0a 3b 3b 20 28 64 65 uses db)).;; (de
0830: 63 6c 61 72 65 20 28 75 73 65 73 20 74 64 62 29 clare (uses tdb)
0840: 29 0a 3b 3b 20 28 64 65 63 6c 61 72 65 20 28 75 ).;; (declare (u
0850: 73 65 73 20 63 6f 6d 6d 6f 6e 29 29 0a 3b 3b 20 ses common)).;;
0860: 3b 3b 20 28 64 65 63 6c 61 72 65 20 28 75 73 65 ;; (declare (use
0870: 73 20 64 63 6f 6d 6d 6f 6e 29 29 20 3b 3b 20 6e s dcommon)) ;; n
0880: 65 65 64 65 64 20 66 6f 72 20 74 68 65 20 73 74 eeded for the st
0890: 65 70 73 20 70 72 6f 63 65 73 73 69 6e 67 0a 3b eps processing.;
08a0: 3b 20 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 ; (declare (uses
08b0: 20 69 74 65 6d 73 29 29 0a 3b 3b 20 28 64 65 63 items)).;; (dec
08c0: 6c 61 72 65 20 28 75 73 65 73 20 72 75 6e 63 6f lare (uses runco
08d0: 6e 66 69 67 29 29 0a 3b 3b 20 3b 3b 20 28 64 65 nfig)).;; ;; (de
08e0: 63 6c 61 72 65 20 28 75 73 65 73 20 73 64 62 29 clare (uses sdb)
08f0: 29 0a 3b 3b 20 28 64 65 63 6c 61 72 65 20 28 75 ).;; (declare (u
0900: 73 65 73 20 73 65 72 76 65 72 29 29 0a 3b 3b 20 ses server)).;;
0910: 3b 3b 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 ;;(declare (uses
0920: 20 73 74 6d 6c 32 29 29 0a 3b 3b 20 0a 3b 3b 20 stml2)).;; .;;
0930: 28 75 73 65 20 73 71 6c 69 74 65 33 20 73 72 66 (use sqlite3 srf
0940: 69 2d 31 20 70 6f 73 69 78 20 72 65 67 65 78 20 i-1 posix regex
0950: 72 65 67 65 78 2d 63 61 73 65 20 73 72 66 69 2d regex-case srfi-
0960: 36 39 20 64 6f 74 2d 6c 6f 63 6b 69 6e 67 20 74 69 dot-locking t
0970: 63 70 20 64 69 72 65 63 74 6f 72 79 2d 75 74 69 cp directory-uti
0980: 6c 73 29 0a 3b 3b 20 28 69 6d 70 6f 72 74 20 28 ls).;; (import (
0990: 70 72 65 66 69 78 20 73 71 6c 69 74 65 33 20 73 prefix sqlite3 s
09a0: 71 6c 69 74 65 33 3a 29 29 0a 3b 3b 20 28 72 65 qlite3:)).;; (re
09b0: 71 75 69 72 65 2d 6c 69 62 72 61 72 79 20 73 74 quire-library st
09c0: 6d 6c 29 0a 3b 3b 20 0a 3b 3b 20 28 69 6e 63 6c ml).;; .;; (incl
09d0: 75 64 65 20 22 63 6f 6d 6d 6f 6e 5f 72 65 63 6f ude "common_reco
09e0: 72 64 73 2e 73 63 6d 22 29 0a 3b 3b 20 28 69 6e rds.scm").;; (in
09f0: 63 6c 75 64 65 20 22 6b 65 79 5f 72 65 63 6f 72 clude "key_recor
0a00: 64 73 2e 73 63 6d 22 29 0a 3b 3b 20 28 69 6e 63 ds.scm").;; (inc
0a10: 6c 75 64 65 20 22 64 62 5f 72 65 63 6f 72 64 73 lude "db_records
0a20: 2e 73 63 6d 22 29 0a 28 69 6e 63 6c 75 64 65 20 .scm").(include
0a30: 22 72 75 6e 5f 72 65 63 6f 72 64 73 2e 73 63 6d "run_records.scm
0a40: 22 29 0a 28 69 6e 63 6c 75 64 65 20 22 74 65 73 ").(include "tes
0a50: 74 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a t_records.scm").
0a60: 28 69 6e 63 6c 75 64 65 20 22 6a 73 2d 70 61 74 (include "js-pat
0a70: 68 2e 73 63 6d 22 29 0a 0a 28 64 65 66 69 6e 65 h.scm")..(define
0a80: 20 28 69 6e 69 74 2d 6a 61 76 61 2d 73 63 72 69 (init-java-scri
0a90: 70 74 2d 6c 69 62 29 0a 20 20 28 73 65 74 21 20 pt-lib). (set!
0aa0: 2a 6a 61 76 61 2d 73 63 72 69 70 74 2d 6c 69 62 *java-script-lib
0ab0: 2a 20 28 63 6f 6e 63 20 20 28 63 6f 6d 6d 6f 6e * (conc (common
0ac0: 3a 67 65 74 2d 69 6e 73 74 61 6c 6c 2d 61 72 65 :get-install-are
0ad0: 61 29 20 22 2f 73 68 61 72 65 2f 6a 73 2f 6a 71 a) "/share/js/jq
0ae0: 75 65 72 79 2d 33 2e 31 2e 30 2e 73 6c 69 6d 2e uery-3.1.0.slim.
0af0: 6d 69 6e 2e 6a 73 22 29 29 0a 20 20 29 0a 0a 3b min.js")). )..;
0b00: 3b 20 70 75 6c 6c 65 64 20 66 72 6f 6d 20 63 6f ; pulled from co
0b10: 6d 6d 6f 6e 6d 6f 64 0a 3b 3b 0a 0a 3b 3b 20 72 mmonmod.;;..;; r
0b20: 65 74 75 72 6e 20 69 74 65 6d 73 20 67 69 76 65 eturn items give
0b30: 6e 20 63 6f 6e 66 69 67 0a 3b 3b 0a 28 64 65 66 n config.;;.(def
0b40: 69 6e 65 20 28 74 65 73 74 73 3a 67 65 74 2d 69 ine (tests:get-i
0b50: 74 65 6d 73 20 74 63 6f 6e 66 69 67 29 0a 20 20 tems tconfig).
0b60: 28 6c 65 74 20 28 28 69 74 65 6d 73 20 20 20 20 (let ((items
0b70: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 (hash-table-re
0b80: 66 2f 64 65 66 61 75 6c 74 20 74 63 6f 6e 66 69 f/default tconfi
0b90: 67 20 22 69 74 65 6d 73 22 20 23 66 29 29 20 3b g "items" #f)) ;
0ba0: 3b 20 69 74 65 6d 73 20 34 0a 09 28 69 74 65 6d ; items 4..(item
0bb0: 73 74 61 62 6c 65 20 28 68 61 73 68 2d 74 61 62 stable (hash-tab
0bc0: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 le-ref/default t
0bd0: 63 6f 6e 66 69 67 20 22 69 74 65 6d 73 74 61 62 config "itemstab
0be0: 6c 65 22 20 23 66 29 29 29 20 0a 20 20 20 20 3b le" #f))) . ;
0bf0: 3b 20 69 66 20 65 69 74 68 65 72 20 69 74 65 6d ; if either item
0c00: 73 20 6f 72 20 69 74 65 6d 73 20 74 61 62 6c 65 s or items table
0c10: 20 69 73 20 61 20 70 72 6f 63 20 72 65 74 75 72 is a proc retur
0c20: 6e 20 69 74 20 73 6f 20 74 65 73 74 20 72 75 6e n it so test run
0c30: 6e 69 6e 67 0a 20 20 20 20 3b 3b 20 70 72 6f 63 ning. ;; proc
0c40: 65 73 73 20 63 61 6e 20 6b 6e 6f 77 20 74 6f 20 ess can know to
0c50: 63 61 6c 6c 20 69 74 65 6d 73 3a 67 65 74 2d 69 call items:get-i
0c60: 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 tems-from-config
0c70: 0a 20 20 20 20 3b 3b 20 69 66 20 65 69 74 68 65 . ;; if eithe
0c80: 72 20 69 73 20 61 20 6c 69 73 74 20 61 6e 64 20 r is a list and
0c90: 6e 6f 6e 65 20 69 73 20 61 20 70 72 6f 63 20 67 none is a proc g
0ca0: 6f 20 61 68 65 61 64 20 61 6e 64 20 63 61 6c 6c o ahead and call
0cb0: 20 67 65 74 2d 69 74 65 6d 73 0a 20 20 20 20 3b get-items. ;
0cc0: 3b 20 6f 74 68 65 72 77 69 73 65 20 72 65 74 75 ; otherwise retu
0cd0: 72 6e 20 23 66 20 2d 20 74 68 69 73 20 69 73 20 rn #f - this is
0ce0: 6e 6f 74 20 61 6e 20 69 74 65 72 61 74 65 64 20 not an iterated
0cf0: 74 65 73 74 0a 20 20 20 20 28 63 6f 6e 64 0a 20 test. (cond.
0d00: 20 20 20 20 28 28 70 72 6f 63 65 64 75 72 65 3f ((procedure?
0d10: 20 69 74 65 6d 73 29 20 20 20 20 20 20 0a 20 20 items) .
0d20: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
0d30: 2d 69 6e 66 6f 20 34 20 2a 64 65 66 61 75 6c 74 -info 4 *default
0d40: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 69 74 65 6d -log-port* "item
0d50: 73 20 69 73 20 61 20 70 72 6f 63 65 64 75 72 65 s is a procedure
0d60: 2c 20 77 69 6c 6c 20 63 61 6c 63 20 6c 61 74 65 , will calc late
0d70: 72 22 29 0a 20 20 20 20 20 20 69 74 65 6d 73 29 r"). items)
0d80: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 63 ;; c
0d90: 61 6c 63 20 6c 61 74 65 72 0a 20 20 20 20 20 28 alc later. (
0da0: 28 70 72 6f 63 65 64 75 72 65 3f 20 69 74 65 6d (procedure? item
0db0: 73 74 61 62 6c 65 29 0a 20 20 20 20 20 20 28 64 stable). (d
0dc0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
0dd0: 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 4 *default-log-p
0de0: 6f 72 74 2a 20 22 69 74 65 6d 73 74 61 62 6c 65 ort* "itemstable
0df0: 20 69 73 20 61 20 70 72 6f 63 65 64 75 72 65 2c is a procedure,
0e00: 20 77 69 6c 6c 20 63 61 6c 63 20 6c 61 74 65 72 will calc later
0e10: 22 29 0a 20 20 20 20 20 20 69 74 65 6d 73 74 61 "). itemsta
0e20: 62 6c 65 29 20 20 20 20 20 20 20 3b 3b 20 63 61 ble) ;; ca
0e30: 6c 63 20 6c 61 74 65 72 0a 20 20 20 20 20 28 28 lc later. ((
0e40: 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 filter (lambda (
0e50: 78 29 0a 09 09 28 6c 65 74 20 28 28 76 61 6c 20 x)...(let ((val
0e60: 28 63 61 72 20 78 29 29 29 0a 09 09 20 20 28 69 (car x)))... (i
0e70: 66 20 28 70 72 6f 63 65 64 75 72 65 3f 20 76 61 f (procedure? va
0e80: 6c 29 20 76 61 6c 20 23 66 29 29 29 0a 09 20 20 l) val #f)))..
0e90: 20 20 20 20 28 61 70 70 65 6e 64 20 28 69 66 20 (append (if
0ea0: 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 20 69 74 (list? items) it
0eb0: 65 6d 73 20 27 28 29 29 0a 09 09 20 20 20 20 20 ems '())...
0ec0: 20 28 69 66 20 28 6c 69 73 74 3f 20 69 74 65 6d (if (list? item
0ed0: 73 74 61 62 6c 65 29 20 69 74 65 6d 73 74 61 62 stable) itemstab
0ee0: 6c 65 20 27 28 29 29 29 29 0a 20 20 20 20 20 20 le '()))).
0ef0: 27 68 61 76 65 2d 70 72 6f 63 65 64 75 72 65 29 'have-procedure)
0f00: 0a 20 20 20 20 20 28 28 6f 72 20 28 6c 69 73 74 . ((or (list
0f10: 3f 20 69 74 65 6d 73 29 28 6c 69 73 74 3f 20 69 ? items)(list? i
0f20: 74 65 6d 73 74 61 62 6c 65 29 29 20 3b 3b 20 63 temstable)) ;; c
0f30: 61 6c 63 20 6e 6f 77 0a 20 20 20 20 20 20 28 64 alc now. (d
0f40: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
0f50: 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 4 *default-log-p
0f60: 6f 72 74 2a 20 22 69 74 65 6d 73 20 61 6e 64 20 ort* "items and
0f70: 69 74 65 6d 73 74 61 62 6c 65 20 61 72 65 20 6c itemstable are l
0f80: 69 73 74 73 2c 20 63 61 6c 63 20 6e 6f 77 5c 6e ists, calc now\n
0f90: 22 0a 09 09 09 22 20 20 20 20 69 74 65 6d 73 3a "...." items:
0fa0: 20 22 20 69 74 65 6d 73 20 22 20 69 74 65 6d 73 " items " items
0fb0: 74 61 62 6c 65 3a 20 22 20 69 74 65 6d 73 74 61 table: " itemsta
0fc0: 62 6c 65 29 0a 20 20 20 20 20 20 28 69 74 65 6d ble). (item
0fd0: 73 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d s:get-items-from
0fe0: 2d 63 6f 6e 66 69 67 20 74 63 6f 6e 66 69 67 29 -config tconfig)
0ff0: 29 0a 20 20 20 20 20 28 65 6c 73 65 20 23 66 29 ). (else #f)
1000: 29 29 29 20 20 20 20 20 20 20 20 20 20 20 20 20 )))
1010: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b ;;
1020: 20 6e 6f 74 20 69 74 65 72 61 74 65 64 0a 0a 0a not iterated...
1030: 0a 3b 3b 20 43 61 6c 6c 20 74 68 69 73 20 6f 6e .;; Call this on
1040: 65 20 74 6f 20 64 6f 20 61 6c 6c 20 74 68 65 20 e to do all the
1050: 77 6f 72 6b 20 61 6e 64 20 67 65 74 20 61 20 73 work and get a s
1060: 74 61 6e 64 61 72 64 69 7a 65 64 20 6c 69 73 74 tandardized list
1070: 20 6f 66 20 74 65 73 74 73 0a 3b 3b 20 20 20 67 of tests.;; g
1080: 65 74 73 20 70 61 74 68 73 20 66 72 6f 6d 20 63 ets paths from c
1090: 6f 6e 66 69 67 73 20 61 6e 64 20 66 69 6e 64 73 onfigs and finds
10a0: 20 76 61 6c 69 64 20 74 65 73 74 73 20 0a 3b 3b valid tests .;;
10b0: 20 20 20 72 65 74 75 72 6e 73 20 68 61 73 68 20 returns hash
10c0: 6f 66 20 74 65 73 74 6e 61 6d 65 20 2d 2d 3e 20 of testname -->
10d0: 66 75 6c 6c 70 61 74 68 0a 3b 3b 0a 28 64 65 66 fullpath.;;.(def
10e0: 69 6e 65 20 28 74 65 73 74 73 3a 67 65 74 2d 61 ine (tests:get-a
10f0: 6c 6c 29 0a 20 20 28 6c 65 74 2a 20 28 28 74 65 ll). (let* ((te
1100: 73 74 2d 73 65 61 72 63 68 2d 70 61 74 68 20 20 st-search-path
1110: 20 28 74 65 73 74 73 3a 67 65 74 2d 74 65 73 74 (tests:get-test
1120: 73 2d 73 65 61 72 63 68 2d 70 61 74 68 20 2a 63 s-search-path *c
1130: 6f 6e 66 69 67 64 61 74 2a 29 29 29 0a 20 20 20 onfigdat*))).
1140: 20 28 74 65 73 74 73 3a 67 65 74 2d 76 61 6c 69 (tests:get-vali
1150: 64 2d 74 65 73 74 73 20 28 6d 61 6b 65 2d 68 61 d-tests (make-ha
1160: 73 68 2d 74 61 62 6c 65 29 20 74 65 73 74 2d 73 sh-table) test-s
1170: 65 61 72 63 68 2d 70 61 74 68 29 29 29 0a 0a 0a earch-path)))...
1180: 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 67 (define (tests:g
1190: 65 74 2d 76 61 6c 69 64 2d 74 65 73 74 73 20 74 et-valid-tests t
11a0: 65 73 74 2d 72 65 67 69 73 74 72 79 20 74 65 73 est-registry tes
11b0: 74 73 2d 70 61 74 68 73 29 0a 20 20 28 69 66 20 ts-paths). (if
11c0: 28 6e 75 6c 6c 3f 20 74 65 73 74 73 2d 70 61 74 (null? tests-pat
11d0: 68 73 29 20 0a 20 20 20 20 20 20 74 65 73 74 2d hs) . test-
11e0: 72 65 67 69 73 74 72 79 0a 20 20 20 20 20 20 28 registry. (
11f0: 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 let loop ((hed (
1200: 63 61 72 20 74 65 73 74 73 2d 70 61 74 68 73 29 car tests-paths)
1210: 29 0a 09 09 20 28 74 61 6c 20 28 63 64 72 20 74 )... (tal (cdr t
1220: 65 73 74 73 2d 70 61 74 68 73 29 29 29 0a 09 28 ests-paths)))..(
1230: 69 66 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d if (common:file-
1240: 65 78 69 73 74 73 3f 20 68 65 64 29 0a 09 20 20 exists? hed)..
1250: 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d (for-each (lam
1260: 62 64 61 20 28 74 65 73 74 2d 70 61 74 68 29 0a bda (test-path).
1270: 09 09 09 28 6c 65 74 2a 20 28 28 74 6e 61 6d 65 ...(let* ((tname
1280: 20 20 20 28 6c 61 73 74 20 28 73 74 72 69 6e 67 (last (string
1290: 2d 73 70 6c 69 74 20 74 65 73 74 2d 70 61 74 68 -split test-path
12a0: 20 22 2f 22 29 29 29 0a 09 09 09 20 20 20 20 20 "/")))....
12b0: 20 20 28 74 63 6f 6e 66 69 67 20 28 63 6f 6e 63 (tconfig (conc
12c0: 20 74 65 73 74 2d 70 61 74 68 20 22 2f 74 65 73 test-path "/tes
12d0: 74 63 6f 6e 66 69 67 22 29 29 29 0a 09 09 09 20 tconfig")))....
12e0: 20 28 69 66 20 28 61 6e 64 20 28 6e 6f 74 20 28 (if (and (not (
12f0: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
1300: 65 66 61 75 6c 74 20 74 65 73 74 2d 72 65 67 69 efault test-regi
1310: 73 74 72 79 20 74 6e 61 6d 65 20 23 66 29 29 0a stry tname #f)).
1320: 09 09 09 09 20 20 20 28 63 6f 6d 6d 6f 6e 3a 66 .... (common:f
1330: 69 6c 65 2d 65 78 69 73 74 73 3f 20 74 63 6f 6e ile-exists? tcon
1340: 66 69 67 29 29 0a 09 09 09 20 20 20 20 20 20 28 fig)).... (
1350: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
1360: 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 74 6e test-registry tn
1370: 61 6d 65 20 74 65 73 74 2d 70 61 74 68 29 29 29 ame test-path)))
1380: 29 0a 09 09 20 20 20 20 20 20 28 67 6c 6f 62 20 )... (glob
1390: 28 63 6f 6e 63 20 68 65 64 20 22 2f 2a 22 29 29 (conc hed "/*"))
13a0: 29 29 0a 09 28 69 66 20 28 6e 75 6c 6c 3f 20 74 ))..(if (null? t
13b0: 61 6c 29 0a 09 20 20 20 20 74 65 73 74 2d 72 65 al).. test-re
13c0: 67 69 73 74 72 79 0a 09 20 20 20 20 28 6c 6f 6f gistry.. (loo
13d0: 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 p (car tal)(cdr
13e0: 74 61 6c 29 29 29 29 29 29 0a 0a 28 64 65 66 69 tal))))))..(defi
13f0: 6e 65 20 28 74 65 73 74 73 3a 66 69 6c 74 65 72 ne (tests:filter
1400: 2d 74 65 73 74 2d 6e 61 6d 65 73 2d 6e 6f 74 2d -test-names-not-
1410: 6d 61 74 63 68 65 64 20 74 65 73 74 2d 6e 61 6d matched test-nam
1420: 65 73 20 74 65 73 74 2d 70 61 74 74 73 29 0a 20 es test-patts).
1430: 20 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 (delete-duplica
1440: 74 65 73 0a 20 20 20 28 66 69 6c 74 65 72 20 28 tes. (filter (
1450: 6c 61 6d 62 64 61 20 28 74 65 73 74 6e 61 6d 65 lambda (testname
1460: 29 0a 09 20 20 20 20 20 28 6e 6f 74 20 28 74 65 ).. (not (te
1470: 73 74 73 3a 6d 61 74 63 68 20 74 65 73 74 2d 70 sts:match test-p
1480: 61 74 74 73 20 74 65 73 74 6e 61 6d 65 20 23 66 atts testname #f
1490: 29 29 29 0a 09 20 20 20 74 65 73 74 2d 6e 61 6d ))).. test-nam
14a0: 65 73 29 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 es)))...(define
14b0: 28 74 65 73 74 73 3a 66 69 6c 74 65 72 2d 74 65 (tests:filter-te
14c0: 73 74 2d 6e 61 6d 65 73 20 74 65 73 74 2d 6e 61 st-names test-na
14d0: 6d 65 73 20 74 65 73 74 2d 70 61 74 74 73 29 0a mes test-patts).
14e0: 20 20 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 (delete-duplic
14f0: 61 74 65 73 0a 20 20 20 28 66 69 6c 74 65 72 20 ates. (filter
1500: 28 6c 61 6d 62 64 61 20 28 74 65 73 74 6e 61 6d (lambda (testnam
1510: 65 29 0a 09 20 20 20 20 20 28 74 65 73 74 73 3a e).. (tests:
1520: 6d 61 74 63 68 20 74 65 73 74 2d 70 61 74 74 73 match test-patts
1530: 20 74 65 73 74 6e 61 6d 65 20 23 66 29 29 0a 09 testname #f))..
1540: 20 20 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 29 test-names)))
1550: 0a 0a 0a 3b 3b 20 72 65 74 75 72 6e 73 20 77 61 ...;; returns wa
1560: 69 74 6f 6e 73 20 77 61 69 74 6f 72 73 20 74 63 itons waitors tc
1570: 6f 6e 66 69 67 64 61 74 0a 3b 3b 0a 28 64 65 66 onfigdat.;;.(def
1580: 69 6e 65 20 28 74 65 73 74 73 3a 67 65 74 2d 77 ine (tests:get-w
1590: 61 69 74 6f 6e 73 20 74 65 73 74 2d 6e 61 6d 65 aitons test-name
15a0: 20 61 6c 6c 2d 74 65 73 74 73 2d 72 65 67 69 73 all-tests-regis
15b0: 74 72 79 29 0a 20 20 20 28 6c 65 74 2a 20 28 28 try). (let* ((
15c0: 63 6f 6e 66 69 67 20 20 28 74 65 73 74 73 3a 67 config (tests:g
15d0: 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 74 65 et-testconfig te
15e0: 73 74 2d 6e 61 6d 65 20 23 66 20 61 6c 6c 2d 74 st-name #f all-t
15f0: 65 73 74 73 2d 72 65 67 69 73 74 72 79 20 27 72 ests-registry 'r
1600: 65 74 75 72 6e 2d 70 72 6f 63 73 29 29 29 20 3b eturn-procs))) ;
1610: 3b 20 61 73 73 75 6d 69 6e 67 20 6e 6f 20 70 72 ; assuming no pr
1620: 6f 62 6c 65 6d 73 20 77 69 74 68 20 69 6d 6d 65 oblems with imme
1630: 64 69 61 74 65 20 65 76 61 6c 75 61 74 69 6f 6e diate evaluation
1640: 2c 20 74 68 69 73 20 63 6f 75 6c 64 20 62 65 20 , this could be
1650: 73 69 6d 70 6c 69 66 69 65 64 20 28 27 72 65 74 simplified ('ret
1660: 75 72 6e 2d 70 72 6f 63 73 20 2d 3e 20 23 74 29 urn-procs -> #t)
1670: 0a 20 20 20 20 20 28 6c 65 74 20 28 28 69 6e 73 . (let ((ins
1680: 74 72 20 28 69 66 20 63 6f 6e 66 69 67 20 0a 09 tr (if config ..
1690: 09 20 20 20 20 20 20 28 63 6f 6e 66 69 67 66 3a . (configf:
16a0: 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 20 22 72 lookup config "r
16b0: 65 71 75 69 72 65 6d 65 6e 74 73 22 20 22 77 61 equirements" "wa
16c0: 69 74 6f 6e 22 29 0a 09 09 20 20 20 20 20 20 28 iton")... (
16d0: 62 65 67 69 6e 20 3b 3b 20 4e 6f 20 63 6f 6e 66 begin ;; No conf
16e0: 69 67 20 6d 65 61 6e 73 20 74 68 69 73 20 69 73 ig means this is
16f0: 20 61 20 6e 6f 6e 2d 65 78 69 73 74 61 6e 74 20 a non-existant
1700: 74 65 73 74 0a 09 09 09 28 64 65 62 75 67 3a 70 test....(debug:p
1710: 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 rint-error 0 *de
1720: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
1730: 22 6e 6f 6e 2d 65 78 69 73 74 65 6e 74 20 72 65 "non-existent re
1740: 71 75 69 72 65 64 20 74 65 73 74 20 5c 22 22 20 quired test \""
1750: 74 65 73 74 2d 6e 61 6d 65 20 22 5c 22 22 29 0a test-name "\"").
1760: 09 09 09 28 65 78 69 74 20 31 29 29 29 29 0a 09 ...(exit 1))))..
1770: 20 20 20 28 69 6e 73 74 72 32 20 28 69 66 20 63 (instr2 (if c
1780: 6f 6e 66 69 67 0a 09 09 20 20 20 20 20 20 20 28 onfig... (
1790: 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 63 configf:lookup c
17a0: 6f 6e 66 69 67 20 22 72 65 71 75 69 72 65 6d 65 onfig "requireme
17b0: 6e 74 73 22 20 22 77 61 69 74 6f 72 22 29 0a 09 nts" "waitor")..
17c0: 09 20 20 20 20 20 20 20 22 22 29 29 29 0a 20 20 . ""))).
17d0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
17e0: 74 2d 69 6e 66 6f 20 38 20 2a 64 65 66 61 75 6c t-info 8 *defaul
17f0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 77 61 69 t-log-port* "wai
1800: 74 6f 6e 73 20 73 74 72 69 6e 67 20 69 73 20 22 tons string is "
1810: 20 69 6e 73 74 72 20 22 2c 20 77 61 69 74 6f 72 instr ", waitor
1820: 73 20 73 74 72 69 6e 67 20 69 73 20 22 20 69 6e s string is " in
1830: 73 74 72 32 29 0a 20 20 20 20 20 20 20 28 6c 65 str2). (le
1840: 74 20 28 28 6e 65 77 77 61 69 74 6f 6e 73 0a 09 t ((newwaitons..
1850: 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 73 70 (string-sp
1860: 6c 69 74 20 28 63 6f 6e 64 0a 09 09 09 20 20 20 lit (cond....
1870: 20 20 28 28 70 72 6f 63 65 64 75 72 65 3f 20 69 ((procedure? i
1880: 6e 73 74 72 29 20 3b 3b 20 68 65 72 65 20 0a 09 nstr) ;; here ..
1890: 09 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 .. (let ((r
18a0: 65 73 20 28 69 6e 73 74 72 29 29 29 0a 09 09 09 es (instr)))....
18b0: 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e .(debug:print-in
18c0: 66 6f 20 38 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 8 *default-lo
18d0: 67 2d 70 6f 72 74 2a 20 22 77 61 69 74 6f 6e 20 g-port* "waiton
18e0: 70 72 6f 63 65 64 75 72 65 20 72 65 73 75 6c 74 procedure result
18f0: 73 20 69 6e 20 73 74 72 69 6e 67 20 22 20 72 65 s in string " re
1900: 73 20 22 20 66 6f 72 20 74 65 73 74 20 22 20 74 s " for test " t
1910: 65 73 74 2d 6e 61 6d 65 29 0a 09 09 09 09 72 65 est-name).....re
1920: 73 29 29 0a 09 09 09 20 20 20 20 20 28 28 73 74 s)).... ((st
1930: 72 69 6e 67 3f 20 69 6e 73 74 72 29 20 20 20 20 ring? instr)
1940: 20 69 6e 73 74 72 29 0a 09 09 09 20 20 20 20 20 instr)....
1950: 28 65 6c 73 65 20 0a 09 09 09 20 20 20 20 20 20 (else ....
1960: 3b 3b 20 4e 4f 54 45 3a 20 54 68 69 73 20 69 73 ;; NOTE: This is
1970: 20 61 63 74 75 61 6c 6c 79 20 74 68 65 20 63 61 actually the ca
1980: 73 65 20 6f 66 20 2a 6e 6f 2a 20 77 61 69 74 6f se of *no* waito
1990: 6e 73 21 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 ns! ;; (debug:pr
19a0: 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 int-error 0 *def
19b0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
19c0: 73 6f 6d 65 74 68 69 6e 67 20 77 65 6e 74 20 77 something went w
19d0: 72 6f 6e 67 20 69 6e 20 70 72 6f 63 65 73 73 69 rong in processi
19e0: 6e 67 20 77 61 69 74 6f 6e 73 20 66 6f 72 20 74 ng waitons for t
19f0: 65 73 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 29 est " test-name)
1a00: 0a 09 09 09 20 20 20 20 20 20 22 22 29 29 29 29 .... ""))))
1a10: 0a 09 20 20 20 20 20 28 6e 65 77 77 61 69 74 6f .. (newwaito
1a20: 72 73 0a 09 20 20 20 20 20 20 28 73 74 72 69 6e rs.. (strin
1a30: 67 2d 73 70 6c 69 74 20 28 63 6f 6e 64 0a 09 09 g-split (cond...
1a40: 09 20 20 20 20 20 28 28 70 72 6f 63 65 64 75 72 . ((procedur
1a50: 65 3f 20 69 6e 73 74 72 32 29 0a 09 09 09 20 20 e? instr2)....
1a60: 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 20 28 (let ((res (
1a70: 69 6e 73 74 72 32 29 29 29 0a 09 09 09 09 28 64 instr2))).....(d
1a80: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
1a90: 38 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 8 *default-log-p
1aa0: 6f 72 74 2a 20 22 77 61 69 74 6f 72 20 70 72 6f ort* "waitor pro
1ab0: 63 65 64 75 72 65 20 72 65 73 75 6c 74 73 20 69 cedure results i
1ac0: 6e 20 73 74 72 69 6e 67 20 22 20 72 65 73 20 22 n string " res "
1ad0: 20 66 6f 72 20 74 65 73 74 20 22 20 74 65 73 74 for test " test
1ae0: 2d 6e 61 6d 65 29 0a 09 09 09 09 72 65 73 29 29 -name).....res))
1af0: 0a 09 09 09 20 20 20 20 20 28 28 73 74 72 69 6e .... ((strin
1b00: 67 3f 20 69 6e 73 74 72 32 29 20 20 20 20 20 69 g? instr2) i
1b10: 6e 73 74 72 32 29 0a 09 09 09 20 20 20 20 20 28 nstr2).... (
1b20: 65 6c 73 65 20 0a 09 09 09 20 20 20 20 20 20 3b else .... ;
1b30: 3b 20 4e 4f 54 45 3a 20 54 68 69 73 20 69 73 20 ; NOTE: This is
1b40: 61 63 74 75 61 6c 6c 79 20 74 68 65 20 63 61 73 actually the cas
1b50: 65 20 6f 66 20 2a 6e 6f 2a 20 77 61 69 74 6f 6e e of *no* waiton
1b60: 73 21 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 s! ;; (debug:pri
1b70: 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 nt-error 0 *defa
1b80: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 ult-log-port* "s
1b90: 6f 6d 65 74 68 69 6e 67 20 77 65 6e 74 20 77 72 omething went wr
1ba0: 6f 6e 67 20 69 6e 20 70 72 6f 63 65 73 73 69 6e ong in processin
1bb0: 67 20 77 61 69 74 6f 6e 73 20 66 6f 72 20 74 65 g waitons for te
1bc0: 73 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 29 0a st " test-name).
1bd0: 09 09 09 20 20 20 20 20 20 22 22 29 29 29 29 29 ... "")))))
1be0: 0a 09 20 28 76 61 6c 75 65 73 0a 09 20 20 3b 3b .. (values.. ;;
1bf0: 20 74 68 65 20 77 61 69 74 6f 6e 73 0a 09 20 20 the waitons..
1c00: 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 (filter (lambda
1c10: 28 78 29 0a 09 09 20 20 20 20 28 69 66 20 28 68 (x)... (if (h
1c20: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
1c30: 66 61 75 6c 74 20 61 6c 6c 2d 74 65 73 74 73 2d fault all-tests-
1c40: 72 65 67 69 73 74 72 79 20 78 20 23 66 29 0a 09 registry x #f)..
1c50: 09 09 23 74 0a 09 09 09 28 62 65 67 69 6e 0a 09 ..#t....(begin..
1c60: 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
1c70: 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c -error 0 *defaul
1c80: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 74 65 73 t-log-port* "tes
1c90: 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 t " test-name "
1ca0: 68 61 73 20 75 6e 72 65 63 6f 67 6e 69 73 65 64 has unrecognised
1cb0: 20 77 61 69 74 6f 6e 20 74 65 73 74 6e 61 6d 65 waiton testname
1cc0: 20 22 20 78 29 0a 09 09 09 20 20 23 66 29 29 29 " x).... #f)))
1cd0: 0a 09 09 20 20 6e 65 77 77 61 69 74 6f 6e 73 29 ... newwaitons)
1ce0: 0a 09 20 20 28 66 69 6c 74 65 72 20 28 6c 61 6d .. (filter (lam
1cf0: 62 64 61 20 28 78 29 0a 09 09 20 20 20 20 28 69 bda (x)... (i
1d00: 66 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 f (hash-table-re
1d10: 66 2f 64 65 66 61 75 6c 74 20 61 6c 6c 2d 74 65 f/default all-te
1d20: 73 74 73 2d 72 65 67 69 73 74 72 79 20 78 20 23 sts-registry x #
1d30: 66 29 0a 09 09 09 23 74 0a 09 09 09 28 62 65 67 f)....#t....(beg
1d40: 69 6e 0a 09 09 09 20 20 28 64 65 62 75 67 3a 70 in.... (debug:p
1d50: 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 rint-error 0 *de
1d60: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
1d70: 22 74 65 73 74 20 22 20 74 65 73 74 2d 6e 61 6d "test " test-nam
1d80: 65 20 22 20 68 61 73 20 75 6e 72 65 63 6f 67 6e e " has unrecogn
1d90: 69 73 65 64 20 77 61 69 74 6f 6e 20 74 65 73 74 ised waiton test
1da0: 6e 61 6d 65 20 22 20 78 29 0a 09 09 09 20 20 23 name " x).... #
1db0: 66 29 29 29 0a 09 09 20 20 6e 65 77 77 61 69 74 f)))... newwait
1dc0: 6f 72 73 29 0a 09 20 20 63 6f 6e 66 69 67 29 29 ors).. config))
1dd0: 29 29 29 0a 09 09 09 09 09 20 20 20 20 20 0a 3b )))...... .;
1de0: 3b 20 67 69 76 65 6e 20 77 61 69 74 69 6e 67 2d ; given waiting-
1df0: 74 65 73 74 20 74 68 61 74 20 69 73 20 77 61 69 test that is wai
1e00: 74 69 6e 67 20 6f 6e 20 77 61 69 74 6f 6e 2d 74 ting on waiton-t
1e10: 65 73 74 20 65 78 74 65 6e 64 20 74 65 73 74 2d est extend test-
1e20: 70 61 74 74 20 61 70 70 72 6f 70 72 69 61 74 65 patt appropriate
1e30: 6c 79 0a 3b 3b 0a 3b 3b 20 20 67 65 6e 6c 69 62 ly.;;.;; genlib
1e40: 2f 74 65 73 74 63 6f 6e 66 69 67 20 20 20 20 20 /testconfig
1e50: 20 20 20 20 20 20 20 20 20 20 73 69 6d 2f 74 65 sim/te
1e60: 73 74 63 6f 6e 66 69 67 0a 3b 3b 20 20 67 65 6e stconfig.;; gen
1e70: 6c 69 62 2f 73 63 68 20 20 20 20 20 20 20 20 20 lib/sch
1e80: 20 20 20 20 20 20 20 20 20 20 20 20 20 73 69 6d sim
1e90: 2f 73 63 68 2f 63 65 6c 6c 31 0a 3b 3b 0a 3b 3b /sch/cell1.;;.;;
1ea0: 20 20 5b 72 65 71 75 69 72 65 6d 65 6e 74 73 5d [requirements]
1eb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1ec0: 20 20 5b 72 65 71 75 69 72 65 6d 65 6e 74 73 5d [requirements]
1ed0: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 .;;
1ee0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1ef0: 20 20 20 20 20 6d 6f 64 65 20 69 74 65 6d 77 61 mode itemwa
1f00: 69 74 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 it.;;
1f10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1f20: 20 20 20 20 20 20 20 23 20 74 72 69 6d 20 6f 66 # trim of
1f30: 66 20 74 68 65 20 63 65 6c 6c 20 74 6f 20 64 65 f the cell to de
1f40: 74 65 72 6d 69 6e 65 20 77 68 61 74 20 74 6f 20 termine what to
1f50: 72 75 6e 20 66 6f 72 20 67 65 6e 6c 69 62 0a 3b run for genlib.;
1f60: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;
1f70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1f80: 20 20 20 69 74 65 6d 6d 61 70 20 2f 2e 2a 0a 3b itemmap /.*.;
1f90: 3b 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 ;.;;
1fa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1fb0: 20 20 20 20 20 20 77 61 69 74 69 6e 67 2d 74 65 waiting-te
1fc0: 73 74 20 69 73 20 77 61 69 74 69 6e 67 20 6f 6e st is waiting on
1fd0: 20 77 61 69 74 6f 6e 2d 74 65 73 74 20 73 6f 20 waiton-test so
1fe0: 77 65 20 6e 65 65 64 20 74 6f 20 63 72 65 61 74 we need to creat
1ff0: 65 20 61 20 70 61 74 74 65 72 6e 20 66 6f 72 20 e a pattern for
2000: 77 61 69 74 6f 6e 2d 74 65 73 74 20 67 69 76 65 waiton-test give
2010: 6e 20 77 61 69 74 69 6e 67 2d 74 65 73 74 20 61 n waiting-test a
2020: 6e 64 20 69 74 65 6d 6d 61 70 0a 3b 3b 20 42 42 nd itemmap.;; BB
2030: 3e 20 28 74 65 73 74 73 3a 65 78 74 65 6e 64 2d > (tests:extend-
2040: 74 65 73 74 2d 70 61 74 74 73 20 22 6e 6f 72 6d test-patts "norm
2050: 61 6c 2d 73 65 63 6f 6e 64 2f 32 22 20 22 6e 6f al-second/2" "no
2060: 72 6d 61 6c 2d 73 65 63 6f 6e 64 22 20 22 6e 6f rmal-second" "no
2070: 72 6d 61 6c 2d 66 69 72 73 74 22 20 27 28 29 29 rmal-first" '())
2080: 0a 3b 3b 20 6f 62 73 65 72 76 65 64 20 2d 3e 20 .;; observed ->
2090: 22 6e 6f 72 6d 61 6c 2d 66 69 72 73 74 2f 32 2c "normal-first/2,
20a0: 6e 6f 72 6d 61 6c 2d 66 69 72 73 74 2f 2c 6e 6f normal-first/,no
20b0: 72 6d 61 6c 2d 73 65 63 6f 6e 64 2f 32 2c 6e 6f rmal-second/2,no
20c0: 72 6d 61 6c 2d 73 65 63 6f 6e 64 2f 22 0a 3b 3b rmal-second/".;;
20d0: 20 65 78 70 65 63 74 65 64 20 2d 3e 20 22 6e 6f expected -> "no
20e0: 72 6d 61 6c 2d 66 69 72 73 74 2c 6e 6f 72 6d 61 rmal-first,norma
20f0: 6c 2d 73 65 63 6f 6e 64 2f 32 2c 6e 6f 72 6d 61 l-second/2,norma
2100: 6c 2d 73 65 63 6f 6e 64 2f 22 0a 3b 3b 20 74 65 l-second/".;; te
2110: 73 74 70 61 74 74 20 3d 20 6e 6f 72 6d 61 6c 2d stpatt = normal-
2120: 73 65 63 6f 6e 64 2f 32 0a 3b 3b 20 77 61 69 74 second/2.;; wait
2130: 69 6e 67 2d 74 65 73 74 20 3d 20 6e 6f 72 6d 61 ing-test = norma
2140: 6c 2d 73 65 63 6f 6e 64 0a 3b 3b 20 77 61 69 74 l-second.;; wait
2150: 6f 6e 2d 74 65 73 74 20 3d 20 6e 6f 72 6d 61 6c on-test = normal
2160: 2d 66 69 72 73 74 0a 3b 3b 20 69 74 65 6d 6d 61 -first.;; itemma
2170: 70 73 20 3d 20 28 29 0a 0a 28 64 65 66 69 6e 65 ps = ()..(define
2180: 20 28 74 65 73 74 73 3a 65 78 74 65 6e 64 2d 74 (tests:extend-t
2190: 65 73 74 2d 70 61 74 74 73 20 74 65 73 74 2d 70 est-patts test-p
21a0: 61 74 74 20 77 61 69 74 69 6e 67 2d 74 65 73 74 att waiting-test
21b0: 20 77 61 69 74 6f 6e 2d 74 65 73 74 20 69 74 65 waiton-test ite
21c0: 6d 6d 61 70 73 20 69 74 65 6d 69 7a 65 64 2d 77 mmaps itemized-w
21d0: 61 69 74 6f 6e 29 0a 20 20 28 63 6f 6e 64 0a 20 aiton). (cond.
21e0: 20 20 28 69 74 65 6d 69 7a 65 64 2d 77 61 69 74 (itemized-wait
21f0: 6f 6e 0a 20 20 20 20 28 6c 65 74 2a 20 28 28 69 on. (let* ((i
2200: 74 65 6d 6d 61 70 20 20 20 20 20 20 20 20 20 20 temmap
2210: 28 74 65 73 74 73 3a 6c 6f 6f 6b 75 70 2d 69 74 (tests:lookup-it
2220: 65 6d 6d 61 70 20 69 74 65 6d 6d 61 70 73 20 77 emmap itemmaps w
2230: 61 69 74 6f 6e 2d 74 65 73 74 29 29 0a 20 20 20 aiton-test)).
2240: 20 20 20 20 20 20 20 20 28 70 61 74 74 73 20 20 (patts
2250: 20 20 20 20 20 20 20 20 20 20 28 73 74 72 69 6e (strin
2260: 67 2d 73 70 6c 69 74 20 74 65 73 74 2d 70 61 74 g-split test-pat
2270: 74 20 22 2c 22 29 29 0a 20 20 20 20 20 20 20 20 t ",")).
2280: 20 20 20 28 77 61 69 74 69 6e 67 2d 74 65 73 74 (waiting-test
2290: 2d 6c 65 6e 20 28 2b 20 28 73 74 72 69 6e 67 2d -len (+ (string-
22a0: 6c 65 6e 67 74 68 20 77 61 69 74 69 6e 67 2d 74 length waiting-t
22b0: 65 73 74 29 20 31 29 29 0a 20 20 20 20 20 20 20 est) 1)).
22c0: 20 20 20 20 28 70 61 74 74 73 2d 77 61 69 74 6f (patts-waito
22d0: 6e 20 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 n (map (lamb
22e0: 64 61 20 28 78 29 20 20 3b 3b 20 66 6f 72 20 65 da (x) ;; for e
22f0: 61 63 68 20 69 6e 63 6f 6d 69 6e 67 20 70 61 74 ach incoming pat
2300: 74 20 74 68 61 74 20 6d 61 74 63 68 65 73 20 74 t that matches t
2310: 68 65 20 77 61 69 74 69 6e 67 20 74 65 73 74 0a he waiting test.
2320: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2330: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2340: 20 20 20 20 28 6c 65 74 2a 20 28 28 6d 6f 64 70 (let* ((modp
2350: 61 74 74 20 28 69 66 20 69 74 65 6d 6d 61 70 20 att (if itemmap
2360: 28 64 62 3a 63 6f 6e 76 65 72 74 2d 74 65 73 74 (db:convert-test
2370: 2d 69 74 65 6d 70 61 74 68 20 78 20 69 74 65 6d -itempath x item
2380: 6d 61 70 29 20 78 29 29 20 0a 20 20 20 20 20 20 map) x)) .
2390: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
23a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
23b0: 20 20 20 20 20 28 6e 65 77 70 61 74 74 20 28 63 (newpatt (c
23c0: 6f 6e 63 20 77 61 69 74 6f 6e 2d 74 65 73 74 20 onc waiton-test
23d0: 22 2f 22 20 28 73 75 62 73 74 72 69 6e 67 20 6d "/" (substring m
23e0: 6f 64 70 61 74 74 20 77 61 69 74 69 6e 67 2d 74 odpatt waiting-t
23f0: 65 73 74 2d 6c 65 6e 20 28 73 74 72 69 6e 67 2d est-len (string-
2400: 6c 65 6e 67 74 68 20 6d 6f 64 70 61 74 74 29 29 length modpatt))
2410: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
2420: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2430: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 28 63 6f ;; (co
2440: 6e 63 20 77 61 69 74 69 6e 67 2d 74 65 73 74 20 nc waiting-test
2450: 22 2f 2c 22 20 77 61 69 74 69 6e 67 2d 74 65 73 "/," waiting-tes
2460: 74 20 22 2f 22 20 28 73 75 62 73 74 72 69 6e 67 t "/" (substring
2470: 20 6d 6f 64 70 61 74 74 20 77 61 69 74 6f 6e 2d modpatt waiton-
2480: 74 65 73 74 2d 6c 65 6e 20 28 73 74 72 69 6e 67 test-len (string
2490: 2d 6c 65 6e 67 74 68 20 6d 6f 64 70 61 74 74 29 -length modpatt)
24a0: 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 )))).
24b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
24c0: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 28 70 ;; (p
24d0: 72 69 6e 74 20 22 69 6e 20 6d 61 70 2c 20 78 3d rint "in map, x=
24e0: 22 20 78 20 22 2c 20 6e 65 77 70 61 74 74 3d 22 " x ", newpatt="
24f0: 20 6e 65 77 70 61 74 74 29 0a 20 20 20 20 20 20 newpatt).
2500: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2510: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2520: 6e 65 77 70 61 74 74 29 29 0a 20 20 20 20 20 20 newpatt)).
2530: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2540: 20 20 20 20 20 20 20 20 20 20 20 20 28 66 69 6c (fil
2550: 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 0a ter (lambda (x).
2560: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2570: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2580: 20 20 20 20 20 20 20 20 20 20 20 20 28 65 71 3f (eq?
2590: 20 28 73 75 62 73 74 72 69 6e 67 2d 69 6e 64 65 (substring-inde
25a0: 78 20 28 63 6f 6e 63 20 77 61 69 74 69 6e 67 2d x (conc waiting-
25b0: 74 65 73 74 20 22 2f 22 29 20 78 29 20 30 29 29 test "/") x) 0))
25c0: 20 3b 3b 20 69 73 20 74 68 69 73 20 70 61 74 74 ;; is this patt
25d0: 20 70 65 72 74 69 6e 65 6e 74 20 74 6f 20 74 68 pertinent to th
25e0: 65 20 77 61 69 74 69 6e 67 20 74 65 73 74 0a 20 e waiting test.
25f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2600: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2610: 20 20 20 20 20 20 20 20 20 70 61 74 74 73 29 29 patts))
2620: 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 65 78 ). (ex
2630: 74 65 6e 64 65 64 2d 74 65 73 74 2d 70 61 74 74 tended-test-patt
2640: 20 20 20 28 61 70 70 65 6e 64 20 70 61 74 74 73 (append patts
2650: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 70 61 74 74 (if (null? patt
2660: 73 2d 77 61 69 74 6f 6e 29 0a 20 20 20 20 20 20 s-waiton).
2670: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2680: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2690: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 69 (li
26a0: 73 74 20 28 63 6f 6e 63 20 77 61 69 74 6f 6e 2d st (conc waiton-
26b0: 74 65 73 74 20 22 2f 25 22 29 29 20 3b 3b 20 72 test "/%")) ;; r
26c0: 65 61 6c 6c 79 20 73 68 6f 75 6c 64 6e 27 74 20 eally shouldn't
26d0: 61 64 64 20 74 68 65 20 77 61 69 74 6f 6e 20 66 add the waiton f
26e0: 6f 72 63 65 66 75 6c 6c 79 20 6c 69 6b 65 20 74 orcefully like t
26f0: 68 69 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 his.
2700: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2710: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2720: 20 20 20 20 20 20 20 70 61 74 74 73 2d 77 61 69 patts-wai
2730: 74 6f 6e 29 29 29 0a 20 20 20 20 20 20 20 20 20 ton))).
2740: 20 20 28 65 78 74 65 6e 64 65 64 2d 74 65 73 74 (extended-test
2750: 2d 70 61 74 74 2d 77 69 74 68 2d 74 6f 70 6c 65 -patt-with-tople
2760: 76 65 6c 73 0a 20 20 20 20 20 20 20 20 20 20 20 vels.
2770: 20 28 66 6f 6c 64 20 28 6c 61 6d 62 64 61 20 28 (fold (lambda (
2780: 74 65 73 74 70 61 74 74 2d 69 74 65 6d 20 61 63 testpatt-item ac
2790: 63 75 6d 20 29 0a 20 20 20 20 20 20 20 20 20 20 cum ).
27a0: 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 (let (
27b0: 28 6d 79 2d 6d 61 74 63 68 20 28 73 74 72 69 6e (my-match (strin
27c0: 67 2d 6d 61 74 63 68 20 22 5e 28 5b 5e 25 5c 5c g-match "^([^%\\
27d0: 2f 5d 2b 29 5c 5c 2f 2e 2b 24 22 20 74 65 73 74 /]+)\\/.+$" test
27e0: 70 61 74 74 2d 69 74 65 6d 29 29 29 0a 20 20 20 patt-item))).
27f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2800: 20 20 20 28 63 6f 6e 73 20 74 65 73 74 70 61 74 (cons testpat
2810: 74 2d 69 74 65 6d 0a 20 20 20 20 20 20 20 20 20 t-item.
2820: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2830: 20 20 20 28 69 66 20 6d 79 2d 6d 61 74 63 68 0a (if my-match.
2840: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2850: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2860: 28 63 6f 6e 73 0a 20 20 20 20 20 20 20 20 20 20 (cons.
2870: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2880: 20 20 20 20 20 20 20 28 63 6f 6e 63 20 28 63 61 (conc (ca
2890: 64 72 20 6d 79 2d 6d 61 74 63 68 29 20 22 2f 22 dr my-match) "/"
28a0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
28b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
28c0: 20 20 20 61 63 63 75 6d 29 0a 20 20 20 20 20 20 accum).
28d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
28e0: 20 20 20 20 20 20 20 20 20 20 61 63 63 75 6d 29 accum)
28f0: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
2900: 20 20 20 20 20 20 27 28 29 0a 20 20 20 20 20 20 '().
2910: 20 20 20 20 20 20 20 20 20 20 20 20 65 78 74 65 exte
2920: 6e 64 65 64 2d 74 65 73 74 2d 70 61 74 74 29 29 nded-test-patt))
2930: 29 0a 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d ). (string-
2940: 69 6e 74 65 72 73 70 65 72 73 65 20 28 64 65 6c intersperse (del
2950: 65 74 65 2d 64 75 70 6c 69 63 61 74 65 73 20 65 ete-duplicates e
2960: 78 74 65 6e 64 65 64 2d 74 65 73 74 2d 70 61 74 xtended-test-pat
2970: 74 2d 77 69 74 68 2d 74 6f 70 6c 65 76 65 6c 73 t-with-toplevels
2980: 29 20 22 2c 22 29 29 29 0a 20 20 20 28 65 6c 73 ) ","))). (els
2990: 65 20 3b 3b 20 6e 6f 74 20 77 61 69 74 69 6e 67 e ;; not waiting
29a0: 20 6f 6e 20 69 74 65 6d 73 2c 20 77 61 69 74 69 on items, waiti
29b0: 6e 67 20 6f 6e 20 65 6e 74 69 72 65 20 77 61 69 ng on entire wai
29c0: 74 6f 6e 20 74 65 73 74 2e 0a 20 20 20 20 28 6c ton test.. (l
29d0: 65 74 2a 20 28 28 70 61 74 74 73 20 28 73 74 72 et* ((patts (str
29e0: 69 6e 67 2d 73 70 6c 69 74 20 74 65 73 74 2d 70 ing-split test-p
29f0: 61 74 74 20 22 2c 22 29 29 0a 20 20 20 20 20 20 att ",")).
2a00: 20 20 20 20 20 28 6e 65 77 2d 70 61 74 74 73 20 (new-patts
2a10: 28 69 66 20 28 6d 65 6d 62 65 72 20 77 61 69 74 (if (member wait
2a20: 6f 6e 2d 74 65 73 74 20 70 61 74 74 73 29 0a 20 on-test patts).
2a30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2a40: 20 20 20 20 20 20 20 20 20 70 61 74 74 73 0a 20 patts.
2a50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2a60: 20 20 20 20 20 20 20 20 20 28 63 6f 6e 73 20 77 (cons w
2a70: 61 69 74 6f 6e 2d 74 65 73 74 20 70 61 74 74 73 aiton-test patts
2a80: 29 29 29 29 0a 20 20 20 20 20 20 28 73 74 72 69 )))). (stri
2a90: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 ng-intersperse (
2aa0: 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 74 65 delete-duplicate
2ab0: 73 20 6e 65 77 2d 70 61 74 74 73 29 20 22 2c 22 s new-patts) ","
2ac0: 29 29 29 29 29 0a 0a 3b 3b 20 43 68 65 63 6b 20 )))))..;; Check
2ad0: 66 6f 72 20 77 61 69 76 65 72 20 65 6c 69 67 69 for waiver eligi
2ae0: 62 69 6c 69 74 79 0a 3b 3b 0a 28 64 65 66 69 6e bility.;;.(defin
2af0: 65 20 28 74 65 73 74 73 3a 63 68 65 63 6b 2d 77 e (tests:check-w
2b00: 61 69 76 65 72 2d 65 6c 69 67 69 62 69 6c 69 74 aiver-eligibilit
2b10: 79 20 74 65 73 74 64 61 74 20 70 72 65 76 2d 74 y testdat prev-t
2b20: 65 73 74 64 61 74 29 0a 20 20 28 6c 65 74 2a 20 estdat). (let*
2b30: 28 28 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 ((test-registry
2b40: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
2b50: 29 29 0a 09 20 28 74 65 73 74 63 6f 6e 66 69 67 )).. (testconfig
2b60: 20 20 28 74 65 73 74 73 3a 67 65 74 2d 74 65 73 (tests:get-tes
2b70: 74 63 6f 6e 66 69 67 20 28 64 62 3a 74 65 73 74 tconfig (db:test
2b80: 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 -get-testname te
2b90: 73 74 64 61 74 29 20 28 64 62 3a 74 65 73 74 2d stdat) (db:test-
2ba0: 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 65 get-item-path te
2bb0: 73 74 64 61 74 29 20 74 65 73 74 2d 72 65 67 69 stdat) test-regi
2bc0: 73 74 72 79 20 23 66 29 29 0a 09 20 28 74 65 73 stry #f)).. (tes
2bd0: 74 2d 72 75 6e 64 69 72 20 3b 3b 20 28 73 64 62 t-rundir ;; (sdb
2be0: 3a 71 72 79 20 27 70 61 73 73 73 74 72 20 0a 09 :qry 'passstr ..
2bf0: 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 (db:test-get-r
2c00: 75 6e 64 69 72 20 74 65 73 74 64 61 74 29 29 20 undir testdat))
2c10: 3b 3b 20 29 0a 09 20 28 70 72 65 76 2d 72 75 6e ;; ).. (prev-run
2c20: 64 69 72 20 3b 3b 20 28 73 64 62 3a 71 72 79 20 dir ;; (sdb:qry
2c30: 27 70 61 73 73 73 74 72 20 0a 09 20 20 28 64 62 'passstr .. (db
2c40: 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 :test-get-rundir
2c50: 20 70 72 65 76 2d 74 65 73 74 64 61 74 29 29 20 prev-testdat))
2c60: 3b 3b 20 29 0a 09 20 28 77 61 69 76 65 72 73 20 ;; ).. (waivers
2c70: 20 20 20 20 28 69 66 20 74 65 73 74 63 6f 6e 66 (if testconf
2c80: 69 67 20 28 63 6f 6e 66 69 67 66 3a 73 65 63 74 ig (configf:sect
2c90: 69 6f 6e 2d 76 61 72 73 20 74 65 73 74 63 6f 6e ion-vars testcon
2ca0: 66 69 67 20 22 77 61 69 76 65 72 73 22 29 20 27 fig "waivers") '
2cb0: 28 29 29 29 0a 09 20 28 77 61 69 76 65 72 2d 72 ())).. (waiver-r
2cc0: 78 20 20 20 28 72 65 67 65 78 70 20 22 5e 28 5c x (regexp "^(\
2cd0: 5c 53 2b 29 5c 5c 73 2b 28 2e 2a 29 24 22 29 29 \S+)\\s+(.*)$"))
2ce0: 0a 09 20 28 64 69 66 66 2d 72 75 6c 65 20 20 20 .. (diff-rule
2cf0: 22 64 69 66 66 20 25 66 69 6c 65 31 25 20 25 66 "diff %file1% %f
2d00: 69 6c 65 32 25 22 29 0a 09 20 28 6c 6f 67 70 72 ile2%").. (logpr
2d10: 6f 2d 72 75 6c 65 20 22 64 69 66 66 20 25 66 69 o-rule "diff %fi
2d20: 6c 65 31 25 20 25 66 69 6c 65 32 25 20 7c 20 6c le1% %file2% | l
2d30: 6f 67 70 72 6f 20 25 77 61 69 76 65 72 6e 61 6d ogpro %waivernam
2d40: 65 25 2e 6c 6f 67 70 72 6f 20 25 77 61 69 76 65 e%.logpro %waive
2d50: 72 6e 61 6d 65 25 2e 68 74 6d 6c 22 29 29 0a 20 rname%.html")).
2d60: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 63 6f 6d (if (not (com
2d70: 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f mon:file-exists?
2d80: 20 74 65 73 74 2d 72 75 6e 64 69 72 29 29 0a 09 test-rundir))..
2d90: 28 62 65 67 69 6e 0a 09 20 20 28 64 65 62 75 67 (begin.. (debug
2da0: 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a :print-error 0 *
2db0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
2dc0: 2a 20 22 74 65 73 74 20 72 75 6e 20 64 69 72 65 * "test run dire
2dd0: 63 74 6f 72 79 20 69 73 20 67 6f 6e 65 2c 20 63 ctory is gone, c
2de0: 61 6e 6e 6f 74 20 70 72 6f 70 61 67 61 74 65 20 annot propagate
2df0: 77 61 69 76 65 72 22 29 0a 09 20 20 23 66 29 0a waiver").. #f).
2e00: 09 28 62 65 67 69 6e 0a 09 20 20 28 70 75 73 68 .(begin.. (push
2e10: 2d 64 69 72 65 63 74 6f 72 79 20 74 65 73 74 2d -directory test-
2e20: 72 75 6e 64 69 72 29 0a 09 20 20 28 6c 65 74 20 rundir).. (let
2e30: 28 28 72 65 73 75 6c 74 20 28 69 66 20 28 6e 75 ((result (if (nu
2e40: 6c 6c 3f 20 77 61 69 76 65 72 73 29 0a 09 09 09 ll? waivers)....
2e50: 20 20 20 20 23 66 0a 09 09 09 20 20 20 20 28 6c #f.... (l
2e60: 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 et loop ((hed (c
2e70: 61 72 20 77 61 69 76 65 72 73 29 29 0a 09 09 09 ar waivers))....
2e80: 09 20 20 20 20 20 20 20 28 74 61 6c 20 28 63 64 . (tal (cd
2e90: 72 20 77 61 69 76 65 72 73 29 29 29 0a 09 09 09 r waivers)))....
2ea0: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
2eb0: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
2ec0: 67 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 41 g-port* "INFO: A
2ed0: 70 70 6c 79 69 6e 67 20 77 61 69 76 65 72 20 72 pplying waiver r
2ee0: 75 6c 65 20 5c 22 22 20 68 65 64 20 22 5c 22 22 ule \"" hed "\""
2ef0: 29 0a 09 09 09 20 20 20 20 20 20 28 6c 65 74 2a ).... (let*
2f00: 20 28 28 77 61 69 76 65 72 20 20 20 20 20 20 28 ((waiver (
2f10: 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 74 configf:lookup t
2f20: 65 73 74 63 6f 6e 66 69 67 20 22 77 61 69 76 65 estconfig "waive
2f30: 72 73 22 20 68 65 64 29 29 0a 09 09 09 09 20 20 rs" hed)).....
2f40: 20 20 20 28 77 70 61 72 74 73 20 20 20 20 20 20 (wparts
2f50: 28 69 66 20 77 61 69 76 65 72 20 28 73 74 72 69 (if waiver (stri
2f60: 6e 67 2d 6d 61 74 63 68 20 77 61 69 76 65 72 2d ng-match waiver-
2f70: 72 78 20 77 61 69 76 65 72 29 20 23 66 29 29 0a rx waiver) #f)).
2f80: 09 09 09 09 20 20 20 20 20 28 77 61 69 76 65 72 .... (waiver
2f90: 2d 72 75 6c 65 20 28 69 66 20 77 70 61 72 74 73 -rule (if wparts
2fa0: 20 28 63 61 64 72 20 77 70 61 72 74 73 29 20 20 (cadr wparts)
2fb0: 23 66 29 29 0a 09 09 09 09 20 20 20 20 20 28 77 #f))..... (w
2fc0: 61 69 76 65 72 2d 67 6c 6f 62 20 28 69 66 20 77 aiver-glob (if w
2fd0: 70 61 72 74 73 20 28 63 61 64 64 72 20 77 70 61 parts (caddr wpa
2fe0: 72 74 73 29 20 23 66 29 29 0a 09 09 09 09 20 20 rts) #f)).....
2ff0: 20 20 20 28 6c 6f 67 70 72 6f 2d 66 69 6c 65 20 (logpro-file
3000: 28 69 66 20 77 61 69 76 65 72 0a 09 09 09 09 09 (if waiver......
3010: 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 66 6e . (let ((fn
3020: 61 6d 65 20 28 63 6f 6e 63 20 68 65 64 20 22 2e ame (conc hed ".
3030: 6c 6f 67 70 72 6f 22 29 29 29 0a 09 09 09 09 09 logpro")))......
3040: 09 09 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 66 69 ..(if (common:fi
3050: 6c 65 2d 65 78 69 73 74 73 3f 20 66 6e 61 6d 65 le-exists? fname
3060: 29 0a 09 09 09 09 09 09 09 20 20 20 20 66 6e 61 )........ fna
3070: 6d 65 20 0a 09 09 09 09 09 09 09 20 20 20 20 28 me ........ (
3080: 62 65 67 69 6e 0a 09 09 09 09 09 09 09 20 20 20 begin........
3090: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
30a0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
30b0: 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 4e 6f 20 6c ort* "INFO: No l
30c0: 6f 67 70 72 6f 20 66 69 6c 65 20 22 20 66 6e 61 ogpro file " fna
30d0: 6d 65 20 22 20 66 61 6c 6c 69 6e 67 20 62 61 63 me " falling bac
30e0: 6b 20 74 6f 20 64 69 66 66 22 29 0a 09 09 09 09 k to diff").....
30f0: 09 09 09 20 20 20 20 20 20 23 66 29 29 29 0a 09 ... #f)))..
3100: 09 09 09 09 09 20 20 20 20 20 20 23 66 29 29 0a ..... #f)).
3110: 09 09 09 09 20 20 20 20 20 3b 3b 20 69 66 20 72 .... ;; if r
3120: 75 6c 65 20 62 79 20 6e 61 6d 65 20 6f 66 20 77 ule by name of w
3130: 61 69 76 65 72 2d 72 75 6c 65 20 69 73 20 66 6f aiver-rule is fo
3140: 75 6e 64 20 69 6e 20 74 65 73 74 63 6f 6e 66 69 und in testconfi
3150: 67 20 2d 20 75 73 65 20 69 74 0a 09 09 09 09 20 g - use it.....
3160: 20 20 20 20 3b 3b 20 65 6c 73 65 20 69 66 20 77 ;; else if w
3170: 61 69 76 65 72 6e 61 6d 65 2e 6c 6f 67 70 72 6f aivername.logpro
3180: 20 65 78 69 73 74 73 20 75 73 65 20 6c 6f 67 70 exists use logp
3190: 72 6f 2d 72 75 6c 65 0a 09 09 09 09 20 20 20 20 ro-rule.....
31a0: 20 3b 3b 20 65 6c 73 65 20 64 65 66 61 75 6c 74 ;; else default
31b0: 20 74 6f 20 64 69 66 66 2d 72 75 6c 65 0a 09 09 to diff-rule...
31c0: 09 09 20 20 20 20 20 28 72 75 6c 65 2d 73 74 72 .. (rule-str
31d0: 69 6e 67 20 28 6c 65 74 20 28 28 72 75 6c 65 20 ing (let ((rule
31e0: 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 (configf:lookup
31f0: 74 65 73 74 63 6f 6e 66 69 67 20 22 77 61 69 76 testconfig "waiv
3200: 65 72 5f 72 75 6c 65 73 22 20 77 61 69 76 65 72 er_rules" waiver
3210: 2d 72 75 6c 65 29 29 29 0a 09 09 09 09 09 09 20 -rule))).......
3220: 20 20 20 28 69 66 20 72 75 6c 65 0a 09 09 09 09 (if rule.....
3230: 09 09 09 72 75 6c 65 0a 09 09 09 09 09 09 09 28 ...rule........(
3240: 69 66 20 6c 6f 67 70 72 6f 2d 66 69 6c 65 0a 09 if logpro-file..
3250: 09 09 09 09 09 09 20 20 20 20 6c 6f 67 70 72 6f ...... logpro
3260: 2d 72 75 6c 65 0a 09 09 09 09 09 09 09 20 20 20 -rule........
3270: 20 28 62 65 67 69 6e 0a 09 09 09 09 09 09 09 20 (begin........
3280: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
3290: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
32a0: 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 4e 6f -port* "INFO: No
32b0: 20 6c 6f 67 70 72 6f 20 66 69 6c 65 20 22 20 6c logpro file " l
32c0: 6f 67 70 72 6f 2d 66 69 6c 65 20 22 20 66 6f 75 ogpro-file " fou
32d0: 6e 64 2c 20 75 73 69 6e 67 20 64 69 66 66 20 72 nd, using diff r
32e0: 75 6c 65 22 29 0a 09 09 09 09 09 09 09 20 20 20 ule")........
32f0: 20 20 20 64 69 66 66 2d 72 75 6c 65 29 29 29 29 diff-rule))))
3300: 29 0a 09 09 09 09 20 20 20 20 20 3b 3b 20 28 73 )..... ;; (s
3310: 74 72 69 6e 67 2d 73 75 62 73 74 69 74 75 74 65 tring-substitute
3320: 20 22 25 66 69 6c 65 31 25 22 20 22 66 6f 6f 66 "%file1%" "foof
3330: 6f 6f 2e 74 78 74 22 20 22 54 68 69 73 20 69 73 oo.txt" "This is
3340: 20 25 66 69 6c 65 31 25 20 61 6e 64 20 73 6f 20 %file1% and so
3350: 69 73 20 74 68 69 73 20 25 66 69 6c 65 31 25 2e is this %file1%.
3360: 22 20 23 74 29 0a 09 09 09 09 20 20 20 20 20 28 " #t)..... (
3370: 70 72 6f 63 65 73 73 65 64 2d 63 6d 64 20 28 73 processed-cmd (s
3380: 74 72 69 6e 67 2d 73 75 62 73 74 69 74 75 74 65 tring-substitute
3390: 20 0a 09 09 09 09 09 09 20 20 20 20 20 22 25 66 ....... "%f
33a0: 69 6c 65 31 25 22 20 28 63 6f 6e 63 20 74 65 73 ile1%" (conc tes
33b0: 74 2d 72 75 6e 64 69 72 20 22 2f 22 20 77 61 69 t-rundir "/" wai
33c0: 76 65 72 2d 67 6c 6f 62 29 0a 09 09 09 09 09 09 ver-glob).......
33d0: 20 20 20 20 20 28 73 74 72 69 6e 67 2d 73 75 62 (string-sub
33e0: 73 74 69 74 75 74 65 0a 09 09 09 09 09 09 20 20 stitute.......
33f0: 20 20 20 20 22 25 66 69 6c 65 32 25 22 20 28 63 "%file2%" (c
3400: 6f 6e 63 20 70 72 65 76 2d 72 75 6e 64 69 72 20 onc prev-rundir
3410: 22 2f 22 20 77 61 69 76 65 72 2d 67 6c 6f 62 29 "/" waiver-glob)
3420: 0a 09 09 09 09 09 09 20 20 20 20 20 20 28 73 74 ....... (st
3430: 72 69 6e 67 2d 73 75 62 73 74 69 74 75 74 65 0a ring-substitute.
3440: 09 09 09 09 09 09 20 20 20 20 20 20 20 22 25 77 ...... "%w
3450: 61 69 76 65 72 6e 61 6d 65 25 22 20 68 65 64 20 aivername%" hed
3460: 72 75 6c 65 2d 73 74 72 69 6e 67 20 23 74 29 20 rule-string #t)
3470: 23 74 29 20 23 74 29 29 0a 09 09 09 09 20 20 20 #t) #t)).....
3480: 20 20 28 72 65 73 20 20 20 20 20 20 20 20 20 20 (res
3490: 20 20 23 66 29 29 0a 09 09 09 09 28 64 65 62 75 #f)).....(debu
34a0: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
34b0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 4e lt-log-port* "IN
34c0: 46 4f 3a 20 77 61 69 76 65 72 20 63 6f 6d 6d 61 FO: waiver comma
34d0: 6e 64 20 69 73 20 5c 22 22 20 70 72 6f 63 65 73 nd is \"" proces
34e0: 73 65 64 2d 63 6d 64 20 22 5c 22 22 29 0a 09 09 sed-cmd "\"")...
34f0: 09 09 28 69 66 20 28 65 71 3f 20 28 73 79 73 74 ..(if (eq? (syst
3500: 65 6d 20 70 72 6f 63 65 73 73 65 64 2d 63 6d 64 em processed-cmd
3510: 29 20 30 29 0a 09 09 09 09 20 20 20 20 28 69 66 ) 0)..... (if
3520: 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 09 (null? tal)....
3530: 09 09 23 74 0a 09 09 09 09 09 28 6c 6f 6f 70 20 ..#t......(loop
3540: 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 (car tal)(cdr ta
3550: 6c 29 29 29 0a 09 09 09 09 20 20 20 20 23 66 29 l)))..... #f)
3560: 29 29 29 29 29 0a 09 20 20 20 20 28 70 6f 70 2d ))))).. (pop-
3570: 64 69 72 65 63 74 6f 72 79 29 0a 09 20 20 20 20 directory)..
3580: 72 65 73 75 6c 74 29 29 29 29 29 0a 0a 3b 3b 20 result)))))..;;
3590: 44 6f 20 6e 6f 74 20 72 70 63 20 74 68 69 73 20 Do not rpc this
35a0: 6f 6e 65 2c 20 64 6f 20 74 68 65 20 75 6e 64 65 one, do the unde
35b0: 72 6c 79 69 6e 67 20 63 61 6c 6c 73 21 21 21 0a rlying calls!!!.
35c0: 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 74 (define (tests:t
35d0: 65 73 74 2d 73 65 74 2d 73 74 61 74 75 73 21 20 est-set-status!
35e0: 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 73 run-id test-id s
35f0: 74 61 74 65 20 73 74 61 74 75 73 20 63 6f 6d 6d tate status comm
3600: 65 6e 74 20 64 61 74 20 23 21 6b 65 79 20 28 77 ent dat #!key (w
3610: 6f 72 6b 2d 61 72 65 61 20 23 66 29 29 0a 20 20 ork-area #f)).
3620: 28 6c 65 74 2a 20 28 28 72 65 61 6c 2d 73 74 61 (let* ((real-sta
3630: 74 75 73 20 73 74 61 74 75 73 29 0a 09 20 28 6f tus status).. (o
3640: 74 68 65 72 64 61 74 20 20 20 20 28 69 66 20 64 therdat (if d
3650: 61 74 20 64 61 74 20 28 6d 61 6b 65 2d 68 61 73 at dat (make-has
3660: 68 2d 74 61 62 6c 65 29 29 29 0a 09 20 28 74 65 h-table))).. (te
3670: 73 74 64 61 74 20 20 20 20 20 28 72 6d 74 3a 67 stdat (rmt:g
3680: 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d et-test-info-by-
3690: 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 id run-id test-i
36a0: 64 29 29 0a 09 20 28 74 65 73 74 2d 6e 61 6d 65 d)).. (test-name
36b0: 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d (db:test-get-
36c0: 74 65 73 74 6e 61 6d 65 20 20 74 65 73 74 64 61 testname testda
36d0: 74 29 29 0a 09 20 28 69 74 65 6d 2d 70 61 74 68 t)).. (item-path
36e0: 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d (db:test-get-
36f0: 69 74 65 6d 2d 70 61 74 68 20 74 65 73 74 64 61 item-path testda
3700: 74 29 29 0a 09 20 3b 3b 20 62 65 66 6f 72 65 20 t)).. ;; before
3710: 70 72 6f 63 65 65 64 69 6e 67 20 77 65 20 6d 75 proceeding we mu
3720: 73 74 20 66 69 6e 64 20 6f 75 74 20 69 66 20 74 st find out if t
3730: 68 65 20 70 72 65 76 69 6f 75 73 20 74 65 73 74 he previous test
3740: 20 28 77 68 65 72 65 20 61 6c 6c 20 6b 65 79 73 (where all keys
3750: 20 6d 61 74 63 68 65 64 20 65 78 63 65 70 74 20 matched except
3760: 72 75 6e 6e 61 6d 65 29 0a 09 20 3b 3b 20 77 61 runname).. ;; wa
3770: 73 20 57 41 49 56 45 44 20 69 66 20 74 68 69 73 s WAIVED if this
3780: 20 74 65 73 74 20 69 73 20 46 41 49 4c 0a 0a 09 test is FAIL...
3790: 20 3b 3b 20 4e 4f 54 45 53 3a 0a 09 20 3b 3b 20 ;; NOTES:.. ;;
37a0: 20 31 2e 20 49 73 20 74 68 65 20 63 61 6c 6c 20 1. Is the call
37b0: 74 6f 20 74 65 73 74 3a 67 65 74 2d 70 72 65 76 to test:get-prev
37c0: 69 6f 75 73 2d 72 75 6e 2d 72 65 63 6f 72 64 20 ious-run-record
37d0: 72 65 6d 6f 74 69 66 69 65 64 3f 0a 09 20 3b 3b remotified?.. ;;
37e0: 20 20 32 2e 20 41 64 64 20 74 65 73 74 20 66 6f 2. Add test fo
37f0: 72 20 74 65 73 74 63 6f 6e 66 69 67 20 77 61 69 r testconfig wai
3800: 76 65 72 20 70 72 6f 70 61 67 61 74 69 6f 6e 20 ver propagation
3810: 63 6f 6e 74 72 6f 6c 20 68 65 72 65 0a 09 20 3b control here.. ;
3820: 3b 0a 09 20 28 70 72 65 76 2d 74 65 73 74 20 20 ;.. (prev-test
3830: 20 28 69 66 20 28 65 71 75 61 6c 3f 20 73 74 61 (if (equal? sta
3840: 74 75 73 20 22 46 41 49 4c 22 29 0a 09 09 09 20 tus "FAIL")....
3850: 20 28 72 6d 74 3a 67 65 74 2d 70 72 65 76 69 6f (rmt:get-previo
3860: 75 73 2d 74 65 73 74 2d 72 75 6e 2d 72 65 63 6f us-test-run-reco
3870: 72 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e rd run-id test-n
3880: 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 0a 09 ame item-path)..
3890: 09 09 20 20 23 66 29 29 0a 09 20 28 77 61 69 76 .. #f)).. (waiv
38a0: 65 64 20 20 20 28 69 66 20 70 72 65 76 2d 74 65 ed (if prev-te
38b0: 73 74 0a 09 09 20 20 20 20 20 20 20 28 69 66 20 st... (if
38c0: 70 72 65 76 2d 74 65 73 74 20 3b 3b 20 74 72 75 prev-test ;; tru
38d0: 65 20 69 66 20 77 65 20 66 6f 75 6e 64 20 61 20 e if we found a
38e0: 70 72 65 76 69 6f 75 73 20 74 65 73 74 20 69 6e previous test in
38f0: 20 74 68 69 73 20 72 75 6e 20 73 65 72 69 65 73 this run series
3900: 0a 09 09 09 20 20 20 28 6c 65 74 20 28 28 70 72 .... (let ((pr
3910: 65 76 2d 73 74 61 74 75 73 20 20 28 64 62 3a 74 ev-status (db:t
3920: 65 73 74 2d 67 65 74 2d 73 74 61 74 75 73 20 20 est-get-status
3930: 70 72 65 76 2d 74 65 73 74 29 29 0a 09 09 09 09 prev-test)).....
3940: 20 28 70 72 65 76 2d 73 74 61 74 65 20 20 20 28 (prev-state (
3950: 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 db:test-get-stat
3960: 65 20 20 20 70 72 65 76 2d 74 65 73 74 29 29 0a e prev-test)).
3970: 09 09 09 09 20 28 70 72 65 76 2d 63 6f 6d 6d 65 .... (prev-comme
3980: 6e 74 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d nt (db:test-get-
3990: 63 6f 6d 6d 65 6e 74 20 70 72 65 76 2d 74 65 73 comment prev-tes
39a0: 74 29 29 29 0a 09 09 09 20 20 20 20 20 28 64 65 t))).... (de
39b0: 62 75 67 3a 70 72 69 6e 74 20 34 20 2a 64 65 66 bug:print 4 *def
39c0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
39d0: 70 72 65 76 2d 73 74 61 74 75 73 20 22 20 70 72 prev-status " pr
39e0: 65 76 2d 73 74 61 74 75 73 20 22 2c 20 70 72 65 ev-status ", pre
39f0: 76 2d 73 74 61 74 65 20 22 20 70 72 65 76 2d 73 v-state " prev-s
3a00: 74 61 74 65 20 22 2c 20 70 72 65 76 2d 63 6f 6d tate ", prev-com
3a10: 6d 65 6e 74 20 22 20 70 72 65 76 2d 63 6f 6d 6d ment " prev-comm
3a20: 65 6e 74 29 0a 09 09 09 20 20 20 20 20 28 69 66 ent).... (if
3a30: 20 28 61 6e 64 20 28 65 71 75 61 6c 3f 20 70 72 (and (equal? pr
3a40: 65 76 2d 73 74 61 74 65 20 20 22 43 4f 4d 50 4c ev-state "COMPL
3a50: 45 54 45 44 22 29 0a 09 09 09 09 20 20 20 20 20 ETED").....
3a60: 20 28 65 71 75 61 6c 3f 20 70 72 65 76 2d 73 74 (equal? prev-st
3a70: 61 74 75 73 20 22 57 41 49 56 45 44 22 29 29 0a atus "WAIVED")).
3a80: 09 09 09 09 20 28 69 66 20 63 6f 6d 6d 65 6e 74 .... (if comment
3a90: 0a 09 09 09 09 20 20 20 20 20 63 6f 6d 6d 65 6e ..... commen
3aa0: 74 0a 09 09 09 09 20 20 20 20 20 70 72 65 76 2d t..... prev-
3ab0: 63 6f 6d 6d 65 6e 74 29 20 3b 3b 20 77 61 69 76 comment) ;; waiv
3ac0: 65 64 20 69 73 20 65 69 74 68 65 72 20 74 68 65 ed is either the
3ad0: 20 63 6f 6d 6d 65 6e 74 20 6f 72 20 23 66 0a 09 comment or #f..
3ae0: 09 09 09 20 23 66 29 29 0a 09 09 09 20 20 20 23 ... #f)).... #
3af0: 66 29 0a 09 09 20 20 20 20 20 20 20 23 66 29 29 f)... #f))
3b00: 29 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 77 ). (if (and w
3b10: 61 69 76 65 64 20 0a 09 20 20 20 20 20 28 74 65 aived .. (te
3b20: 73 74 73 3a 63 68 65 63 6b 2d 77 61 69 76 65 72 sts:check-waiver
3b30: 2d 65 6c 69 67 69 62 69 6c 69 74 79 20 74 65 73 -eligibility tes
3b40: 74 64 61 74 20 70 72 65 76 2d 74 65 73 74 29 29 tdat prev-test))
3b50: 0a 09 28 73 65 74 21 20 72 65 61 6c 2d 73 74 61 ..(set! real-sta
3b60: 74 75 73 20 22 57 41 49 56 45 44 22 29 29 0a 0a tus "WAIVED"))..
3b70: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
3b80: 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 4 *default-log-
3b90: 70 6f 72 74 2a 20 22 72 65 61 6c 2d 73 74 61 74 port* "real-stat
3ba0: 75 73 20 22 20 72 65 61 6c 2d 73 74 61 74 75 73 us " real-status
3bb0: 20 22 2c 20 77 61 69 76 65 64 20 22 20 77 61 69 ", waived " wai
3bc0: 76 65 64 20 22 2c 20 73 74 61 74 75 73 20 22 20 ved ", status "
3bd0: 73 74 61 74 75 73 29 0a 0a 20 20 20 20 3b 3b 20 status).. ;;
3be0: 75 70 64 61 74 65 20 74 68 65 20 70 72 69 6d 61 update the prima
3bf0: 72 79 20 72 65 63 6f 72 64 20 49 46 20 73 74 61 ry record IF sta
3c00: 74 65 20 41 4e 44 20 73 74 61 74 75 73 20 61 72 te AND status ar
3c10: 65 20 64 65 66 69 6e 65 64 0a 20 20 20 20 28 69 e defined. (i
3c20: 66 20 28 61 6e 64 20 73 74 61 74 65 20 73 74 61 f (and state sta
3c30: 74 75 73 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 tus)..(begin..
3c40: 28 72 6d 74 3a 73 65 74 2d 73 74 61 74 65 2d 73 (rmt:set-state-s
3c50: 74 61 74 75 73 2d 61 6e 64 2d 72 6f 6c 6c 2d 75 tatus-and-roll-u
3c60: 70 2d 69 74 65 6d 73 20 72 75 6e 2d 69 64 20 74 p-items run-id t
3c70: 65 73 74 2d 69 64 20 69 74 65 6d 2d 70 61 74 68 est-id item-path
3c80: 20 73 74 61 74 65 20 72 65 61 6c 2d 73 74 61 74 state real-stat
3c90: 75 73 20 28 69 66 20 77 61 69 76 65 64 20 77 61 us (if waived wa
3ca0: 69 76 65 64 20 63 6f 6d 6d 65 6e 74 29 29 0a 09 ived comment))..
3cb0: 20 20 3b 3b 20 28 6d 74 3a 70 72 6f 63 65 73 73 ;; (mt:process
3cc0: 2d 74 72 69 67 67 65 72 73 20 72 75 6e 2d 69 64 -triggers run-id
3cd0: 20 74 65 73 74 2d 69 64 20 73 74 61 74 65 20 72 test-id state r
3ce0: 65 61 6c 2d 73 74 61 74 75 73 29 20 3b 3b 20 74 eal-status) ;; t
3cf0: 72 69 67 67 65 72 73 20 61 72 65 20 63 61 6c 6c riggers are call
3d00: 65 64 20 69 6e 20 74 65 73 74 2d 73 65 74 2d 73 ed in test-set-s
3d10: 74 61 74 65 2d 73 74 61 74 75 73 0a 09 20 20 29 tate-status.. )
3d20: 29 0a 20 20 20 20 0a 20 20 20 20 3b 3b 20 69 66 ). . ;; if
3d30: 20 73 74 61 74 75 73 20 69 73 20 22 41 55 54 4f status is "AUTO
3d40: 22 20 74 68 65 6e 20 63 61 6c 6c 20 72 6f 6c 6c " then call roll
3d50: 75 70 20 28 6e 6f 74 65 2c 20 74 68 69 73 20 6f up (note, this o
3d60: 6e 65 20 6d 6f 64 69 66 69 65 73 20 64 61 74 61 ne modifies data
3d70: 20 69 6e 20 74 65 73 74 0a 20 20 20 20 3b 3b 20 in test. ;;
3d80: 72 75 6e 20 61 72 65 61 2c 20 69 74 20 64 6f 65 run area, it doe
3d90: 73 20 72 65 6d 6f 74 65 20 63 61 6c 6c 73 20 75 s remote calls u
3da0: 6e 64 65 72 20 74 68 65 20 68 6f 6f 64 2e 0a 20 nder the hood..
3db0: 20 20 20 3b 3b 20 28 69 66 20 28 61 6e 64 20 74 ;; (if (and t
3dc0: 65 73 74 2d 69 64 20 73 74 61 74 65 20 73 74 61 est-id state sta
3dd0: 74 75 73 20 28 65 71 75 61 6c 3f 20 73 74 61 74 tus (equal? stat
3de0: 75 73 20 22 41 55 54 4f 22 29 29 20 0a 20 20 20 us "AUTO")) .
3df0: 20 3b 3b 20 09 28 72 6d 74 3a 74 65 73 74 2d 64 ;; .(rmt:test-d
3e00: 61 74 61 2d 72 6f 6c 6c 75 70 20 72 75 6e 2d 69 ata-rollup run-i
3e10: 64 20 74 65 73 74 2d 69 64 20 73 74 61 74 75 73 d test-id status
3e20: 29 29 0a 0a 20 20 20 20 3b 3b 20 61 64 64 20 6d )).. ;; add m
3e30: 65 74 61 64 61 74 61 20 28 6e 65 65 64 20 74 6f etadata (need to
3e40: 20 64 6f 20 74 68 69 73 20 77 61 79 20 74 6f 20 do this way to
3e50: 61 76 6f 69 64 20 53 51 4c 20 69 6e 6a 65 63 74 avoid SQL inject
3e60: 69 6f 6e 20 69 73 73 75 65 73 29 0a 0a 20 20 20 ion issues)..
3e70: 20 3b 3b 20 3a 66 69 72 73 74 5f 65 72 72 0a 20 ;; :first_err.
3e80: 20 20 20 3b 3b 20 28 6c 65 74 20 28 28 76 61 6c ;; (let ((val
3e90: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
3ea0: 2f 64 65 66 61 75 6c 74 20 6f 74 68 65 72 64 61 /default otherda
3eb0: 74 20 22 3a 66 69 72 73 74 5f 65 72 72 22 20 23 t ":first_err" #
3ec0: 66 29 29 29 0a 20 20 20 20 3b 3b 20 20 20 28 69 f))). ;; (i
3ed0: 66 20 76 61 6c 0a 20 20 20 20 3b 3b 20 20 20 20 f val. ;;
3ee0: 20 20 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 (sqlite3:exec
3ef0: 75 74 65 20 64 62 20 22 55 50 44 41 54 45 20 74 ute db "UPDATE t
3f00: 65 73 74 73 20 53 45 54 20 66 69 72 73 74 5f 65 ests SET first_e
3f10: 72 72 3d 3f 20 57 48 45 52 45 20 72 75 6e 5f 69 rr=? WHERE run_i
3f20: 64 3d 3f 20 41 4e 44 20 74 65 73 74 6e 61 6d 65 d=? AND testname
3f30: 3d 3f 20 41 4e 44 20 69 74 65 6d 5f 70 61 74 68 =? AND item_path
3f40: 3d 3f 3b 22 20 76 61 6c 20 72 75 6e 2d 69 64 20 =?;" val run-id
3f50: 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 test-name item-p
3f60: 61 74 68 29 29 29 0a 20 20 20 20 3b 3b 20 0a 20 ath))). ;; .
3f70: 20 20 20 3b 3b 20 3b 3b 20 3a 66 69 72 73 74 5f ;; ;; :first_
3f80: 77 61 72 6e 0a 20 20 20 20 3b 3b 20 28 6c 65 74 warn. ;; (let
3f90: 20 28 28 76 61 6c 20 28 68 61 73 68 2d 74 61 62 ((val (hash-tab
3fa0: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 6f le-ref/default o
3fb0: 74 68 65 72 64 61 74 20 22 3a 66 69 72 73 74 5f therdat ":first_
3fc0: 77 61 72 6e 22 20 23 66 29 29 29 0a 20 20 20 20 warn" #f))).
3fd0: 3b 3b 20 20 20 28 69 66 20 76 61 6c 0a 20 20 20 ;; (if val.
3fe0: 20 3b 3b 20 20 20 20 20 20 20 28 73 71 6c 69 74 ;; (sqlit
3ff0: 65 33 3a 65 78 65 63 75 74 65 20 64 62 20 22 55 e3:execute db "U
4000: 50 44 41 54 45 20 74 65 73 74 73 20 53 45 54 20 PDATE tests SET
4010: 66 69 72 73 74 5f 77 61 72 6e 3d 3f 20 57 48 45 first_warn=? WHE
4020: 52 45 20 72 75 6e 5f 69 64 3d 3f 20 41 4e 44 20 RE run_id=? AND
4030: 74 65 73 74 6e 61 6d 65 3d 3f 20 41 4e 44 20 69 testname=? AND i
4040: 74 65 6d 5f 70 61 74 68 3d 3f 3b 22 20 76 61 6c tem_path=?;" val
4050: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
4060: 65 20 69 74 65 6d 2d 70 61 74 68 29 29 29 0a 0a e item-path)))..
4070: 20 20 20 20 28 6c 65 74 20 28 28 63 61 74 65 67 (let ((categ
4080: 6f 72 79 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ory (hash-table-
4090: 72 65 66 2f 64 65 66 61 75 6c 74 20 6f 74 68 65 ref/default othe
40a0: 72 64 61 74 20 22 3a 63 61 74 65 67 6f 72 79 22 rdat ":category"
40b0: 20 22 22 29 29 0a 09 20 20 28 76 61 72 69 61 62 "")).. (variab
40c0: 6c 65 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 le (hash-table-r
40d0: 65 66 2f 64 65 66 61 75 6c 74 20 6f 74 68 65 72 ef/default other
40e0: 64 61 74 20 22 3a 76 61 72 69 61 62 6c 65 22 20 dat ":variable"
40f0: 22 22 29 29 0a 09 20 20 28 76 61 6c 75 65 20 20 "")).. (value
4100: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 (hash-table-re
4110: 66 2f 64 65 66 61 75 6c 74 20 6f 74 68 65 72 64 f/default otherd
4120: 61 74 20 22 3a 76 61 6c 75 65 22 20 20 20 20 23 at ":value" #
4130: 66 29 29 0a 09 20 20 28 65 78 70 65 63 74 65 64 f)).. (expected
4140: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
4150: 2f 64 65 66 61 75 6c 74 20 6f 74 68 65 72 64 61 /default otherda
4160: 74 20 22 3a 65 78 70 65 63 74 65 64 22 20 22 6e t ":expected" "n
4170: 2f 61 22 29 29 0a 09 20 20 28 74 6f 6c 20 20 20 /a")).. (tol
4180: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 (hash-table-r
4190: 65 66 2f 64 65 66 61 75 6c 74 20 6f 74 68 65 72 ef/default other
41a0: 64 61 74 20 22 3a 74 6f 6c 22 20 20 20 20 20 20 dat ":tol"
41b0: 22 6e 2f 61 22 29 29 0a 09 20 20 28 75 6e 69 74 "n/a")).. (unit
41c0: 73 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 s (hash-table
41d0: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 6f 74 68 -ref/default oth
41e0: 65 72 64 61 74 20 22 3a 75 6e 69 74 73 22 20 20 erdat ":units"
41f0: 20 20 22 22 29 29 0a 09 20 20 28 74 79 70 65 20 "")).. (type
4200: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
4210: 72 65 66 2f 64 65 66 61 75 6c 74 20 6f 74 68 65 ref/default othe
4220: 72 64 61 74 20 22 3a 74 79 70 65 22 20 20 20 20 rdat ":type"
4230: 20 22 22 29 29 0a 09 20 20 28 64 63 6f 6d 6d 65 "")).. (dcomme
4240: 6e 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 nt (hash-table-r
4250: 65 66 2f 64 65 66 61 75 6c 74 20 6f 74 68 65 72 ef/default other
4260: 64 61 74 20 22 3a 63 6f 6d 6d 65 6e 74 22 20 20 dat ":comment"
4270: 22 22 29 29 29 0a 20 20 20 20 20 20 28 64 65 62 ""))). (deb
4280: 75 67 3a 70 72 69 6e 74 20 34 20 2a 64 65 66 61 ug:print 4 *defa
4290: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 0a 09 ult-log-port* ..
42a0: 09 20 20 20 22 63 61 74 65 67 6f 72 79 3a 20 22 . "category: "
42b0: 20 63 61 74 65 67 6f 72 79 20 22 2c 20 76 61 72 category ", var
42c0: 69 61 62 6c 65 3a 20 22 20 76 61 72 69 61 62 6c iable: " variabl
42d0: 65 20 22 2c 20 76 61 6c 75 65 3a 20 22 20 76 61 e ", value: " va
42e0: 6c 75 65 0a 09 09 20 20 20 22 2c 20 65 78 70 65 lue... ", expe
42f0: 63 74 65 64 3a 20 22 20 65 78 70 65 63 74 65 64 cted: " expected
4300: 20 22 2c 20 74 6f 6c 3a 20 22 20 74 6f 6c 20 22 ", tol: " tol "
4310: 2c 20 75 6e 69 74 73 3a 20 22 20 75 6e 69 74 73 , units: " units
4320: 29 0a 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 ). (if (and
4330: 20 76 61 6c 75 65 29 20 3b 3b 20 72 65 71 75 69 value) ;; requi
4340: 72 65 20 6f 6e 6c 79 20 76 61 6c 75 65 3b 20 42 re only value; B
4350: 42 20 77 61 73 2d 20 61 6c 6c 20 74 68 72 65 65 B was- all three
4360: 20 72 65 71 75 69 72 65 64 0a 09 20 20 28 6c 65 required.. (le
4370: 74 20 28 28 64 61 74 20 28 63 6f 6e 63 20 63 61 t ((dat (conc ca
4380: 74 65 67 6f 72 79 20 22 2c 22 0a 09 09 09 20 20 tegory ","....
4390: 20 76 61 72 69 61 62 6c 65 20 22 2c 22 0a 09 09 variable ","...
43a0: 09 20 20 20 76 61 6c 75 65 20 20 20 20 22 2c 22 . value ","
43b0: 0a 09 09 09 20 20 20 65 78 70 65 63 74 65 64 20 .... expected
43c0: 22 2c 22 0a 09 09 09 20 20 20 74 6f 6c 20 20 20 ",".... tol
43d0: 20 20 20 22 2c 22 0a 09 09 09 20 20 20 75 6e 69 ",".... uni
43e0: 74 73 20 20 20 20 22 2c 22 0a 09 09 09 20 20 20 ts ","....
43f0: 64 63 6f 6d 6d 65 6e 74 20 22 2c 2c 22 20 3b 3b dcomment ",," ;;
4400: 20 65 78 74 72 61 20 63 6f 6d 6d 61 20 66 6f 72 extra comma for
4410: 20 73 74 61 74 75 73 0a 09 09 09 20 20 20 74 79 status.... ty
4420: 70 65 20 20 20 20 20 29 29 29 0a 09 20 20 20 20 pe )))..
4430: 3b 3b 20 54 68 69 73 20 77 61 73 20 72 75 6e 20 ;; This was run
4440: 72 65 6d 6f 74 65 2c 20 64 6f 6e 27 74 20 74 68 remote, don't th
4450: 69 6e 6b 20 74 68 61 74 20 6d 61 6b 65 73 20 73 ink that makes s
4460: 65 6e 73 65 2e 20 50 65 72 68 61 70 73 20 6e 6f ense. Perhaps no
4470: 74 2c 20 62 75 74 20 74 68 61 74 20 69 73 20 74 t, but that is t
4480: 68 65 20 65 61 73 69 65 73 74 20 70 61 74 68 20 he easiest path
4490: 66 6f 72 20 74 68 65 20 6d 6f 6d 65 6e 74 2e 0a for the moment..
44a0: 09 20 20 20 20 28 72 6d 74 3a 63 73 76 2d 3e 74 . (rmt:csv->t
44b0: 65 73 74 2d 64 61 74 61 20 72 75 6e 2d 69 64 20 est-data run-id
44c0: 74 65 73 74 2d 69 64 0a 09 09 09 09 64 61 74 29 test-id.....dat)
44d0: 0a 09 20 20 20 20 3b 3b 20 54 68 69 73 20 77 61 .. ;; This wa
44e0: 73 20 61 64 64 65 64 20 69 6e 20 63 68 65 63 6b s added in check
44f0: 2d 69 6e 20 61 35 61 64 66 61 33 66 39 61 2e 20 -in a5adfa3f9a.
4500: 4d 65 73 73 61 67 65 20 77 61 73 3a 20 22 2e 2e Message was: "..
4510: 2e 61 64 64 65 64 20 64 65 6c 61 79 20 69 6e 20 .added delay in
4520: 73 65 74 2d 76 61 6c 75 65 73 20 74 6f 20 61 6c set-values to al
4530: 6c 6f 77 20 66 6f 72 20 64 65 6c 61 79 65 64 20 low for delayed
4540: 77 72 69 74 65 20 6f 6e 20 73 65 72 76 65 72 20 write on server
4550: 73 74 61 72 74 22 0a 09 20 20 20 20 3b 3b 20 49 start".. ;; I
4560: 27 6d 20 69 6e 73 65 72 74 69 6e 67 20 61 6e 20 'm inserting an
4570: 61 72 62 69 74 72 61 72 79 20 72 6d 74 3a 20 63 arbitrary rmt: c
4580: 61 6c 6c 20 74 6f 20 66 6f 72 63 65 2f 65 6e 73 all to force/ens
4590: 75 72 65 20 74 68 61 74 20 74 68 65 20 73 65 72 ure that the ser
45a0: 76 65 72 20 69 73 20 61 76 61 69 6c 61 62 6c 65 ver is available
45b0: 20 74 6f 20 28 68 6f 70 65 66 75 6c 6c 79 29 20 to (hopefully)
45c0: 70 72 65 76 65 6e 74 20 61 20 63 6f 6d 6d 75 6e prevent a commun
45d0: 69 63 61 74 69 6f 6e 20 69 73 73 75 65 2e 0a 09 ication issue...
45e0: 20 20 20 20 3b 3b 20 28 72 6d 74 3a 67 65 74 2d ;; (rmt:get-
45f0: 76 61 72 20 22 4d 45 47 41 54 45 53 54 5f 56 45 var "MEGATEST_VE
4600: 52 53 49 4f 4e 22 29 20 3b 3b 20 74 68 69 73 20 RSION") ;; this
4610: 64 6f 65 73 20 4e 4f 54 48 49 4e 47 20 62 75 74 does NOTHING but
4620: 20 65 6e 73 75 72 65 20 74 68 65 20 73 65 72 76 ensure the serv
4630: 65 72 20 69 73 20 72 65 61 63 68 61 62 6c 65 2e er is reachable.
4640: 20 54 68 69 73 20 69 73 20 61 6c 6d 6f 73 74 20 This is almost
4650: 63 65 72 74 61 69 6e 6c 79 20 4e 4f 54 20 6e 65 certainly NOT ne
4660: 65 64 65 64 20 3a 29 0a 20 20 20 20 20 20 20 20 eded :).
4670: 20 20 20 20 3b 3b 20 42 42 20 2d 20 63 6f 6d 6d ;; BB - comm
4680: 65 6e 74 69 6f 6e 67 20 6f 75 74 20 61 72 62 69 entiong out arbi
4690: 74 72 61 72 79 20 31 30 20 73 65 63 6f 6e 64 20 trary 10 second
46a0: 77 61 69 74 20 28 74 68 72 65 61 64 2d 73 6c 65 wait (thread-sle
46b0: 65 70 21 20 31 30 29 20 3b 3b 20 61 64 64 20 31 ep! 10) ;; add 1
46c0: 30 20 73 65 63 6f 6e 64 20 64 65 6c 61 79 20 62 0 second delay b
46d0: 65 66 6f 72 65 20 71 75 69 74 20 69 6e 63 61 73 efore quit incas
46e0: 65 20 72 6d 74 20 6e 65 65 64 73 20 74 69 6d 65 e rmt needs time
46f0: 20 74 6f 20 73 74 61 72 74 20 61 20 73 65 72 76 to start a serv
4700: 65 72 2e 0a 20 20 20 20 20 20 20 20 20 20 20 20 er..
4710: 29 29 29 0a 20 20 20 20 20 20 0a 20 20 20 20 3b ))). . ;
4720: 3b 20 6e 65 65 64 20 74 6f 20 75 70 64 61 74 65 ; need to update
4730: 20 74 68 65 20 74 6f 70 20 74 65 73 74 20 72 65 the top test re
4740: 63 6f 72 64 20 69 66 20 50 41 53 53 20 6f 72 20 cord if PASS or
4750: 46 41 49 4c 20 61 6e 64 20 74 68 69 73 20 69 73 FAIL and this is
4760: 20 61 20 73 75 62 74 65 73 74 0a 20 20 20 20 3b a subtest. ;
4770: 3b 3b 3b 3b 3b 20 28 69 66 20 28 6e 6f 74 20 28 ;;;;; (if (not (
4780: 65 71 75 61 6c 3f 20 69 74 65 6d 2d 70 61 74 68 equal? item-path
4790: 20 22 22 29 29 0a 20 20 20 20 3b 3b 3b 3b 3b 3b "")). ;;;;;;
47a0: 20 20 20 20 20 28 72 6d 74 3a 73 65 74 2d 73 74 (rmt:set-st
47b0: 61 74 65 2d 73 74 61 74 75 73 2d 61 6e 64 2d 72 ate-status-and-r
47c0: 6f 6c 6c 2d 75 70 2d 69 74 65 6d 73 20 72 75 6e oll-up-items run
47d0: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 -id test-name it
47e0: 65 6d 2d 70 61 74 68 20 73 74 61 74 65 20 73 74 em-path state st
47f0: 61 74 75 73 20 23 66 29 20 3b 3b 3b 3b 3b 29 0a atus #f) ;;;;;).
4800: 0a 20 20 20 20 28 69 66 20 28 6f 72 20 28 61 6e . (if (or (an
4810: 64 20 28 73 74 72 69 6e 67 3f 20 63 6f 6d 6d 65 d (string? comme
4820: 6e 74 29 0a 09 09 20 28 73 74 72 69 6e 67 2d 6d nt)... (string-m
4830: 61 74 63 68 20 28 72 65 67 65 78 70 20 22 5c 5c atch (regexp "\\
4840: 53 2b 22 29 20 63 6f 6d 6d 65 6e 74 29 29 0a 09 S+") comment))..
4850: 20 20 20 20 77 61 69 76 65 64 29 0a 09 28 6c 65 waived)..(le
4860: 74 20 28 28 63 6d 74 20 20 28 69 66 20 77 61 69 t ((cmt (if wai
4870: 76 65 64 20 77 61 69 76 65 64 20 63 6f 6d 6d 65 ved waived comme
4880: 6e 74 29 29 29 0a 09 20 20 28 72 6d 74 3a 67 65 nt))).. (rmt:ge
4890: 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 73 65 74 2d neral-call 'set-
48a0: 74 65 73 74 2d 63 6f 6d 6d 65 6e 74 20 72 75 6e test-comment run
48b0: 2d 69 64 20 63 6d 74 20 74 65 73 74 2d 69 64 29 -id cmt test-id)
48c0: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 ))))..(define (t
48d0: 65 73 74 73 3a 74 65 73 74 2d 73 65 74 2d 74 6f ests:test-set-to
48e0: 70 6c 6f 67 21 20 72 75 6e 2d 69 64 20 74 65 73 plog! run-id tes
48f0: 74 2d 6e 61 6d 65 20 6c 6f 67 66 29 20 0a 20 20 t-name logf) .
4900: 28 72 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 61 6c (rmt:general-cal
4910: 6c 20 27 74 65 73 74 73 3a 74 65 73 74 2d 73 65 l 'tests:test-se
4920: 74 2d 74 6f 70 6c 6f 67 20 72 75 6e 2d 69 64 20 t-toplog run-id
4930: 6c 6f 67 66 20 72 75 6e 2d 69 64 20 74 65 73 74 logf run-id test
4940: 2d 6e 61 6d 65 29 29 0a 0a 28 64 65 66 69 6e 65 -name))..(define
4950: 20 28 74 65 73 74 73 3a 73 75 6d 6d 61 72 69 7a (tests:summariz
4960: 65 2d 69 74 65 6d 73 20 72 75 6e 2d 69 64 20 74 e-items run-id t
4970: 65 73 74 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 est-id test-name
4980: 20 66 6f 72 63 65 29 0a 20 20 3b 3b 20 69 66 20 force). ;; if
4990: 6e 6f 74 20 66 6f 72 63 65 20 74 68 65 6e 20 6f not force then o
49a0: 6e 6c 79 20 75 70 64 61 74 65 20 74 68 65 20 72 nly update the r
49b0: 65 63 6f 72 64 20 69 66 20 6f 6e 65 20 6f 66 20 ecord if one of
49c0: 74 68 65 73 65 20 69 73 20 74 72 75 65 3a 0a 20 these is true:.
49d0: 20 3b 3b 20 20 20 31 2e 20 6c 6f 67 66 20 69 73 ;; 1. logf is
49e0: 20 22 6c 6f 67 2f 66 69 6e 61 6c 2e 6c 6f 67 0a "log/final.log.
49f0: 20 20 3b 3b 20 20 20 32 2e 20 6c 6f 67 66 20 69 ;; 2. logf i
4a00: 73 20 73 61 6d 65 20 61 73 20 6f 75 74 70 75 74 s same as output
4a10: 66 69 6c 65 6e 61 6d 65 0a 20 20 28 6c 65 74 2a filename. (let*
4a20: 20 28 28 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d ((outputfilenam
4a30: 65 20 28 63 6f 6e 63 20 22 6d 65 67 61 74 65 73 e (conc "megates
4a40: 74 2d 72 6f 6c 6c 75 70 2d 22 20 74 65 73 74 2d t-rollup-" test-
4a50: 6e 61 6d 65 20 22 2e 68 74 6d 6c 22 29 29 0a 09 name ".html"))..
4a60: 20 28 6f 72 69 67 2d 64 69 72 20 20 20 20 20 20 (orig-dir
4a70: 20 28 63 75 72 72 65 6e 74 2d 64 69 72 65 63 74 (current-direct
4a80: 6f 72 79 29 29 0a 09 20 28 6c 6f 67 66 2d 69 6e ory)).. (logf-in
4a90: 66 6f 20 20 20 20 20 20 28 72 6d 74 3a 74 65 73 fo (rmt:tes
4aa0: 74 2d 67 65 74 2d 6c 6f 67 66 69 6c 65 2d 69 6e t-get-logfile-in
4ab0: 66 6f 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e fo run-id test-n
4ac0: 61 6d 65 29 29 0a 09 20 28 6c 6f 67 66 20 20 20 ame)).. (logf
4ad0: 20 20 20 20 20 20 20 20 28 69 66 20 6c 6f 67 66 (if logf
4ae0: 2d 69 6e 66 6f 20 28 63 61 64 72 20 6c 6f 67 66 -info (cadr logf
4af0: 2d 69 6e 66 6f 29 20 23 66 29 29 0a 09 20 28 70 -info) #f)).. (p
4b00: 61 74 68 20 20 20 20 20 20 20 20 20 20 20 28 69 ath (i
4b10: 66 20 6c 6f 67 66 2d 69 6e 66 6f 20 28 63 61 72 f logf-info (car
4b20: 20 20 6c 6f 67 66 2d 69 6e 66 6f 29 20 23 66 29 logf-info) #f)
4b30: 29 29 0a 20 20 20 20 3b 3b 20 54 68 69 73 20 71 )). ;; This q
4b40: 75 65 72 79 20 66 69 6e 64 73 20 74 68 65 20 70 uery finds the p
4b50: 61 74 68 20 61 6e 64 20 63 68 61 6e 67 65 73 20 ath and changes
4b60: 74 68 65 20 64 69 72 65 63 74 6f 72 79 20 74 6f the directory to
4b70: 20 69 74 20 66 6f 72 20 74 68 65 20 74 65 73 74 it for the test
4b80: 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 73 . (if (and (s
4b90: 74 72 69 6e 67 3f 20 70 61 74 68 29 0a 09 20 20 tring? path)..
4ba0: 20 20 20 28 64 69 72 65 63 74 6f 72 79 3f 20 70 (directory? p
4bb0: 61 74 68 29 29 20 3b 3b 20 63 61 6e 20 67 65 74 ath)) ;; can get
4bc0: 20 23 66 20 68 65 72 65 20 75 6e 64 65 72 20 73 #f here under s
4bd0: 6f 6d 65 20 77 69 65 72 64 20 63 6f 6e 64 69 74 ome wierd condit
4be0: 69 6f 6e 73 2e 20 77 68 79 2c 20 75 6e 6b 6e 6f ions. why, unkno
4bf0: 77 6e 20 2e 2e 2e 0a 09 28 62 65 67 69 6e 0a 09 wn .....(begin..
4c00: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 (debug:print 4
4c10: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
4c20: 72 74 2a 20 22 46 6f 75 6e 64 20 70 61 74 68 3a rt* "Found path:
4c30: 20 22 20 70 61 74 68 29 0a 09 20 20 28 63 68 61 " path).. (cha
4c40: 6e 67 65 2d 64 69 72 65 63 74 6f 72 79 20 70 61 nge-directory pa
4c50: 74 68 29 29 0a 09 3b 3b 20 28 73 65 74 21 20 6f th))..;; (set! o
4c60: 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 20 28 63 utputfilename (c
4c70: 6f 6e 63 20 70 61 74 68 20 22 2f 22 20 6f 75 74 onc path "/" out
4c80: 70 75 74 66 69 6c 65 6e 61 6d 65 29 29 29 0a 09 putfilename)))..
4c90: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 (debug:print-err
4ca0: 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f or 0 *default-lo
4cb0: 67 2d 70 6f 72 74 2a 20 22 73 75 6d 6d 61 72 69 g-port* "summari
4cc0: 7a 65 2d 69 74 65 6d 73 20 66 6f 72 20 72 75 6e ze-items for run
4cd0: 2d 69 64 3d 22 20 72 75 6e 2d 69 64 20 22 2c 20 -id=" run-id ",
4ce0: 74 65 73 74 2d 6e 61 6d 65 3d 22 20 74 65 73 74 test-name=" test
4cf0: 2d 6e 61 6d 65 20 22 2c 20 6e 6f 20 73 75 63 68 -name ", no such
4d00: 20 70 61 74 68 3a 20 22 20 70 61 74 68 29 29 0a path: " path)).
4d10: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
4d20: 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 4 *default-log-
4d30: 70 6f 72 74 2a 20 22 73 75 6d 6d 61 72 69 7a 65 port* "summarize
4d40: 2d 69 74 65 6d 73 20 77 69 74 68 20 6c 6f 67 66 -items with logf
4d50: 20 22 20 6c 6f 67 66 20 22 2c 20 6f 75 74 70 75 " logf ", outpu
4d60: 74 66 69 6c 65 6e 61 6d 65 20 22 20 6f 75 74 70 tfilename " outp
4d70: 75 74 66 69 6c 65 6e 61 6d 65 20 22 20 61 6e 64 utfilename " and
4d80: 20 66 6f 72 63 65 20 22 20 66 6f 72 63 65 29 0a force " force).
4d90: 20 20 20 20 28 69 66 20 28 6f 72 20 28 65 71 75 (if (or (equ
4da0: 61 6c 3f 20 6c 6f 67 66 20 22 6c 6f 67 73 2f 66 al? logf "logs/f
4db0: 69 6e 61 6c 2e 6c 6f 67 22 29 0a 09 20 20 20 20 inal.log")..
4dc0: 28 65 71 75 61 6c 3f 20 6c 6f 67 66 20 6f 75 74 (equal? logf out
4dd0: 70 75 74 66 69 6c 65 6e 61 6d 65 29 0a 09 20 20 putfilename)..
4de0: 20 20 66 6f 72 63 65 29 0a 09 28 6c 65 74 20 28 force)..(let (
4df0: 28 6d 79 2d 73 74 61 72 74 2d 74 69 6d 65 20 28 (my-start-time (
4e00: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
4e10: 29 0a 09 20 20 20 20 20 20 28 6c 6f 63 6b 66 20 ).. (lockf
4e20: 20 20 20 20 20 20 20 20 28 63 6f 6e 63 20 6f 75 (conc ou
4e30: 74 70 75 74 66 69 6c 65 6e 61 6d 65 20 22 2e 6c tputfilename ".l
4e40: 6f 63 6b 22 29 29 29 0a 09 20 20 28 6c 65 74 20 ock"))).. (let
4e50: 6c 6f 6f 70 20 28 28 68 61 76 65 2d 6c 6f 63 6b loop ((have-lock
4e60: 20 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 (common:simple
4e70: 2d 66 69 6c 65 2d 6c 6f 63 6b 20 6c 6f 63 6b 66 -file-lock lockf
4e80: 29 29 29 0a 09 20 20 20 20 28 69 66 20 68 61 76 ))).. (if hav
4e90: 65 2d 6c 6f 63 6b 0a 09 09 28 6c 65 74 20 28 28 e-lock...(let ((
4ea0: 73 63 72 69 70 74 20 28 63 6f 6e 66 69 67 66 3a script (configf:
4eb0: 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 lookup *configda
4ec0: 74 2a 20 22 74 65 73 74 72 6f 6c 6c 75 70 22 20 t* "testrollup"
4ed0: 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a 09 09 20 test-name)))...
4ee0: 20 28 70 72 69 6e 74 20 22 4f 62 74 61 69 6e 65 (print "Obtaine
4ef0: 64 20 6c 6f 63 6b 20 66 6f 72 20 22 20 6f 75 74 d lock for " out
4f00: 70 75 74 66 69 6c 65 6e 61 6d 65 29 0a 09 09 20 putfilename)...
4f10: 20 28 72 6d 74 3a 73 65 74 2d 73 74 61 74 65 2d (rmt:set-state-
4f20: 73 74 61 74 75 73 2d 61 6e 64 2d 72 6f 6c 6c 2d status-and-roll-
4f30: 75 70 2d 69 74 65 6d 73 20 72 75 6e 2d 69 64 20 up-items run-id
4f40: 74 65 73 74 2d 6e 61 6d 65 20 22 22 20 23 66 20 test-name "" #f
4f50: 23 66 20 23 66 29 0a 09 09 20 20 28 69 66 20 73 #f #f)... (if s
4f60: 63 72 69 70 74 0a 09 09 20 20 20 20 20 20 28 73 cript... (s
4f70: 79 73 74 65 6d 20 28 63 6f 6e 63 20 73 63 72 69 ystem (conc scri
4f80: 70 74 20 22 20 3e 20 22 20 6f 75 74 70 75 74 66 pt " > " outputf
4f90: 69 6c 65 6e 61 6d 65 20 22 20 26 20 22 29 29 0a ilename " & ")).
4fa0: 09 09 20 20 20 20 20 20 28 74 65 73 74 73 3a 67 .. (tests:g
4fb0: 65 6e 65 72 61 74 65 2d 68 74 6d 6c 2d 73 75 6d enerate-html-sum
4fc0: 6d 61 72 79 2d 66 6f 72 2d 69 74 65 72 61 74 65 mary-for-iterate
4fd0: 64 2d 74 65 73 74 20 72 75 6e 2d 69 64 20 74 65 d-test run-id te
4fe0: 73 74 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 st-id test-name
4ff0: 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 29 29 outputfilename))
5000: 0a 09 09 20 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d ... (common:sim
5010: 70 6c 65 2d 66 69 6c 65 2d 72 65 6c 65 61 73 65 ple-file-release
5020: 2d 6c 6f 63 6b 20 6c 6f 63 6b 66 29 0a 09 09 20 -lock lockf)...
5030: 20 28 63 68 61 6e 67 65 2d 64 69 72 65 63 74 6f (change-directo
5040: 72 79 20 6f 72 69 67 2d 64 69 72 29 0a 09 09 20 ry orig-dir)...
5050: 20 3b 3b 20 4e 42 2f 2f 20 74 65 73 74 73 3a 74 ;; NB// tests:t
5060: 65 73 74 2d 73 65 74 2d 74 6f 70 6c 6f 67 21 20 est-set-toplog!
5070: 69 73 20 72 65 6d 6f 74 65 20 69 6e 74 65 72 6e is remote intern
5080: 61 6c 2e 2e 2e 0a 09 09 20 20 28 74 65 73 74 73 al...... (tests
5090: 3a 74 65 73 74 2d 73 65 74 2d 74 6f 70 6c 6f 67 :test-set-toplog
50a0: 21 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 ! run-id test-na
50b0: 6d 65 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d me outputfilenam
50c0: 65 29 29 0a 09 09 3b 3b 20 64 69 64 6e 27 74 20 e))...;; didn't
50d0: 67 65 74 20 74 68 65 20 6c 6f 63 6b 2c 20 63 68 get the lock, ch
50e0: 65 63 6b 20 74 6f 20 73 65 65 20 69 66 20 63 75 eck to see if cu
50f0: 72 72 65 6e 74 20 75 70 64 61 74 65 20 73 74 61 rrent update sta
5100: 72 74 65 64 20 6c 61 74 65 72 20 74 68 61 6e 20 rted later than
5110: 74 68 69 73 20 0a 09 09 3b 3b 20 75 70 64 61 74 this ...;; updat
5120: 65 2c 20 69 66 20 73 6f 20 77 65 20 63 61 6e 20 e, if so we can
5130: 65 78 69 74 20 77 69 74 68 6f 75 74 20 64 6f 69 exit without doi
5140: 6e 67 20 61 6e 79 20 77 6f 72 6b 0a 09 09 28 69 ng any work...(i
5150: 66 20 28 3e 20 6d 79 2d 73 74 61 72 74 2d 74 69 f (> my-start-ti
5160: 6d 65 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 me (handle-excep
5170: 74 69 6f 6e 73 0a 09 09 09 09 09 20 65 78 6e 0a tions...... exn.
5180: 09 09 09 09 20 20 20 20 20 20 20 28 62 65 67 69 .... (begi
5190: 6e 0a 09 09 09 09 09 20 28 70 72 69 6e 74 20 22 n...... (print "
51a0: 66 61 69 6c 65 64 20 74 6f 20 67 65 74 20 6d 6f failed to get mo
51b0: 64 20 74 69 6d 65 20 6f 6e 20 22 20 6c 6f 63 6b d time on " lock
51c0: 66 20 22 2c 20 65 78 6e 3d 22 20 65 78 6e 29 0a f ", exn=" exn).
51d0: 09 09 09 09 09 20 30 29 0a 09 09 09 09 20 20 20 ..... 0).....
51e0: 20 20 20 20 28 66 69 6c 65 2d 6d 6f 64 69 66 69 (file-modifi
51f0: 63 61 74 69 6f 6e 2d 74 69 6d 65 20 6c 6f 63 6b cation-time lock
5200: 66 29 29 29 0a 09 09 20 20 20 20 3b 3b 20 77 65 f)))... ;; we
5210: 20 73 74 61 72 74 65 64 20 73 69 6e 63 65 20 63 started since c
5220: 75 72 72 65 6e 74 20 72 65 2d 67 65 6e 20 69 6e urrent re-gen in
5230: 20 66 6c 69 67 68 74 2c 20 64 65 6c 61 79 20 61 flight, delay a
5240: 20 6c 69 74 74 6c 65 20 61 6e 64 20 74 72 79 20 little and try
5250: 61 67 61 69 6e 0a 09 09 20 20 20 20 28 62 65 67 again... (beg
5260: 69 6e 0a 09 09 20 20 20 20 20 20 28 64 65 62 75 in... (debu
5270: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 2a g:print-info 1 *
5280: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
5290: 2a 20 22 57 61 69 74 69 6e 67 20 74 6f 20 75 70 * "Waiting to up
52a0: 64 61 74 65 20 22 20 6f 75 74 70 75 74 66 69 6c date " outputfil
52b0: 65 6e 61 6d 65 20 22 2c 20 61 6e 6f 74 68 65 72 ename ", another
52c0: 20 74 65 73 74 20 63 75 72 72 65 6e 74 6c 79 20 test currently
52d0: 75 70 64 61 74 69 6e 67 20 69 74 22 29 0a 09 09 updating it")...
52e0: 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c (thread-sl
52f0: 65 65 70 21 20 28 2b 20 35 20 28 70 73 65 75 64 eep! (+ 5 (pseud
5300: 6f 2d 72 61 6e 64 6f 6d 2d 69 6e 74 65 67 65 72 o-random-integer
5310: 20 35 29 29 29 20 3b 3b 20 64 65 6c 61 79 20 62 5))) ;; delay b
5320: 65 74 77 65 65 6e 20 35 20 61 6e 64 20 31 30 20 etween 5 and 10
5330: 73 65 63 6f 6e 64 73 0a 09 09 20 20 20 20 20 20 seconds...
5340: 28 6c 6f 6f 70 20 28 63 6f 6d 6d 6f 6e 3a 73 69 (loop (common:si
5350: 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 20 6c mple-file-lock l
5360: 6f 63 6b 66 29 29 29 29 29 29 29 29 29 29 0a 0a ockf))))))))))..
5370: 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 67 (define (tests:g
5380: 65 6e 65 72 61 74 65 2d 68 74 6d 6c 2d 73 75 6d enerate-html-sum
5390: 6d 61 72 79 2d 66 6f 72 2d 69 74 65 72 61 74 65 mary-for-iterate
53a0: 64 2d 74 65 73 74 20 72 75 6e 2d 69 64 20 74 65 d-test run-id te
53b0: 73 74 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 st-id test-name
53c0: 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 29 0a outputfilename).
53d0: 20 20 28 6c 65 74 20 28 28 63 6f 75 6e 74 73 20 (let ((counts
53e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 (ma
53f0: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
5400: 09 28 73 74 61 74 65 63 6f 75 6e 74 73 20 20 20 .(statecounts
5410: 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 (make-hash
5420: 2d 74 61 62 6c 65 29 29 0a 09 28 6f 75 74 74 78 -table))..(outtx
5430: 74 20 20 20 20 20 20 20 20 20 20 20 20 20 20 22 t "
5440: 22 29 0a 09 28 74 6f 74 20 20 20 20 20 20 20 20 ")..(tot
5450: 20 20 20 20 20 20 20 20 20 30 29 0a 09 28 74 65 0)..(te
5460: 73 74 64 61 74 20 20 20 20 20 20 20 20 20 20 20 stdat
5470: 20 20 28 72 6d 74 3a 74 65 73 74 2d 67 65 74 2d (rmt:test-get-
5480: 72 65 63 6f 72 64 73 2d 66 6f 72 2d 69 6e 64 65 records-for-inde
5490: 78 2d 66 69 6c 65 20 72 75 6e 2d 69 64 20 74 65 x-file run-id te
54a0: 73 74 2d 6e 61 6d 65 29 29 29 0a 20 20 20 20 28 st-name))). (
54b0: 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 66 with-output-to-f
54c0: 69 6c 65 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 ile outputfilena
54d0: 6d 65 0a 20 20 20 20 20 20 28 6c 61 6d 62 64 61 me. (lambda
54e0: 20 28 29 0a 09 28 73 65 74 21 20 6f 75 74 74 78 ()..(set! outtx
54f0: 74 20 28 63 6f 6e 63 20 6f 75 74 74 78 74 20 22 t (conc outtxt "
5500: 3c 68 74 6d 6c 3e 3c 74 69 74 6c 65 3e 53 75 6d <html><title>Sum
5510: 6d 61 72 79 3a 20 22 20 74 65 73 74 2d 6e 61 6d mary: " test-nam
5520: 65 20 0a 09 09 09 20 20 20 22 3c 2f 74 69 74 6c e .... "</titl
5530: 65 3e 3c 62 6f 64 79 3e 3c 68 32 3e 53 75 6d 6d e><body><h2>Summ
5540: 61 72 79 20 66 6f 72 20 22 20 74 65 73 74 2d 6e ary for " test-n
5550: 61 6d 65 20 22 3c 2f 68 32 3e 22 29 29 0a 09 28 ame "</h2>"))..(
5560: 66 6f 72 2d 65 61 63 68 0a 09 20 28 6c 61 6d 62 for-each.. (lamb
5570: 64 61 20 28 74 65 73 74 72 65 63 6f 72 64 29 0a da (testrecord).
5580: 09 20 20 20 28 6c 65 74 20 28 28 69 64 20 20 20 . (let ((id
5590: 20 20 20 20 20 20 20 20 20 20 28 76 65 63 74 6f (vecto
55a0: 72 2d 72 65 66 20 74 65 73 74 72 65 63 6f 72 64 r-ref testrecord
55b0: 20 30 29 29 0a 09 09 20 28 69 74 65 6d 70 61 74 0))... (itempat
55c0: 68 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d h (vector-
55d0: 72 65 66 20 74 65 73 74 72 65 63 6f 72 64 20 31 ref testrecord 1
55e0: 29 29 0a 09 09 20 28 73 74 61 74 65 20 20 20 20 ))... (state
55f0: 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 (vector-re
5600: 66 20 74 65 73 74 72 65 63 6f 72 64 20 32 29 29 f testrecord 2))
5610: 0a 09 09 20 28 73 74 61 74 75 73 20 20 20 20 20 ... (status
5620: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
5630: 74 65 73 74 72 65 63 6f 72 64 20 33 29 29 0a 09 testrecord 3))..
5640: 09 20 28 72 75 6e 5f 64 75 72 61 74 69 6f 6e 20 . (run_duration
5650: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 65 (vector-ref te
5660: 73 74 72 65 63 6f 72 64 20 34 29 29 0a 09 09 20 strecord 4))...
5670: 28 6c 6f 67 66 20 20 20 20 20 20 20 20 20 20 20 (logf
5680: 28 76 65 63 74 6f 72 2d 72 65 66 20 74 65 73 74 (vector-ref test
5690: 72 65 63 6f 72 64 20 35 29 29 0a 09 09 20 28 63 record 5))... (c
56a0: 6f 6d 6d 65 6e 74 20 20 20 20 20 20 20 20 28 76 omment (v
56b0: 65 63 74 6f 72 2d 72 65 66 20 74 65 73 74 72 65 ector-ref testre
56c0: 63 6f 72 64 20 36 29 29 29 0a 09 20 20 20 20 20 cord 6)))..
56d0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
56e0: 20 63 6f 75 6e 74 73 20 73 74 61 74 75 73 20 28 counts status (
56f0: 2b 20 31 20 28 68 61 73 68 2d 74 61 62 6c 65 2d + 1 (hash-table-
5700: 72 65 66 2f 64 65 66 61 75 6c 74 20 63 6f 75 6e ref/default coun
5710: 74 73 20 73 74 61 74 75 73 20 30 29 29 29 0a 09 ts status 0)))..
5720: 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
5730: 2d 73 65 74 21 20 73 74 61 74 65 63 6f 75 6e 74 -set! statecount
5740: 73 20 73 74 61 74 65 20 28 2b 20 31 20 28 68 61 s state (+ 1 (ha
5750: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
5760: 61 75 6c 74 20 73 74 61 74 65 63 6f 75 6e 74 73 ault statecounts
5770: 20 73 74 61 74 65 20 30 29 29 29 0a 09 20 20 20 state 0)))..
5780: 20 20 28 73 65 74 21 20 6f 75 74 74 78 74 20 28 (set! outtxt (
5790: 63 6f 6e 63 20 6f 75 74 74 78 74 20 22 3c 74 72 conc outtxt "<tr
57a0: 3e 22 0a 09 09 09 09 3b 3b 20 22 3c 74 64 3e 3c >".....;; "<td><
57b0: 61 20 68 72 65 66 3d 5c 22 22 20 69 74 65 6d 70 a href=\"" itemp
57c0: 61 74 68 20 22 2f 22 20 6c 6f 67 66 20 22 5c 22 ath "/" logf "\"
57d0: 3e 20 22 20 69 74 65 6d 70 61 74 68 20 22 3c 2f > " itempath "</
57e0: 61 3e 3c 2f 74 64 3e 22 20 0a 09 09 09 09 22 3c a></td>" ....."<
57f0: 74 64 3e 3c 61 20 68 72 65 66 3d 5c 22 22 20 69 td><a href=\"" i
5800: 74 65 6d 70 61 74 68 20 22 2f 74 65 73 74 2d 73 tempath "/test-s
5810: 75 6d 6d 61 72 79 2e 68 74 6d 6c 5c 22 3e 20 22 ummary.html\"> "
5820: 20 69 74 65 6d 70 61 74 68 20 22 3c 2f 61 3e 3c itempath "</a><
5830: 2f 74 64 3e 22 20 0a 09 09 09 09 22 3c 74 64 3e /td>" ....."<td>
5840: 22 20 73 74 61 74 65 20 20 20 20 22 3c 2f 74 64 " state "</td
5850: 3e 22 20 0a 09 09 09 09 22 3c 74 64 3e 3c 66 6f >" ....."<td><fo
5860: 6e 74 20 63 6f 6c 6f 72 3d 22 20 28 63 6f 6d 6d nt color=" (comm
5870: 6f 6e 3a 67 65 74 2d 63 6f 6c 6f 72 2d 66 72 6f on:get-color-fro
5880: 6d 2d 73 74 61 74 75 73 20 73 74 61 74 75 73 29 m-status status)
5890: 0a 09 09 09 09 22 3e 22 20 20 20 73 74 61 74 75 .....">" statu
58a0: 73 20 20 20 22 3c 2f 66 6f 6e 74 3e 3c 2f 74 64 s "</font></td
58b0: 3e 22 0a 09 09 09 09 22 3c 74 64 3e 22 20 28 69 >"....."<td>" (i
58c0: 66 20 28 65 71 75 61 6c 3f 20 63 6f 6d 6d 65 6e f (equal? commen
58d0: 74 20 22 22 29 0a 09 09 09 09 09 20 20 20 22 26 t "")...... "&
58e0: 6e 62 73 70 3b 22 0a 09 09 09 09 09 20 20 20 63 nbsp;"...... c
58f0: 6f 6d 6d 65 6e 74 29 20 22 3c 2f 74 64 3e 22 0a omment) "</td>".
5900: 09 09 09 09 09 20 20 20 22 3c 2f 74 72 3e 22 29 ..... "</tr>")
5910: 29 29 29 0a 09 20 28 69 66 20 28 6c 69 73 74 3f ))).. (if (list?
5920: 20 74 65 73 74 64 61 74 29 0a 09 20 20 20 20 20 testdat)..
5930: 74 65 73 74 64 61 74 0a 09 20 20 20 20 20 28 62 testdat.. (b
5940: 65 67 69 6e 0a 09 20 20 20 20 20 20 20 28 70 72 egin.. (pr
5950: 69 6e 74 20 22 45 52 52 4f 52 3a 20 66 61 69 6c int "ERROR: fail
5960: 65 64 20 74 6f 20 67 65 74 20 72 65 63 6f 72 64 ed to get record
5970: 73 20 77 69 74 68 20 72 6d 74 3a 74 65 73 74 2d s with rmt:test-
5980: 67 65 74 2d 72 65 63 6f 72 64 73 2d 66 6f 72 2d get-records-for-
5990: 69 6e 64 65 78 2d 66 69 6c 65 20 72 75 6e 2d 69 index-file run-i
59a0: 64 3d 22 20 72 75 6e 2d 69 64 20 22 74 65 73 74 d=" run-id "test
59b0: 2d 6e 61 6d 65 3d 22 20 74 65 73 74 2d 6e 61 6d -name=" test-nam
59c0: 65 29 0a 09 20 20 20 20 20 20 20 27 28 29 29 29 e).. '()))
59d0: 29 0a 09 0a 09 28 70 72 69 6e 74 20 22 3c 74 61 )....(print "<ta
59e0: 62 6c 65 3e 3c 74 72 3e 3c 74 64 20 76 61 6c 69 ble><tr><td vali
59f0: 67 6e 3d 5c 22 74 6f 70 5c 22 3e 22 29 0a 09 3b gn=\"top\">")..;
5a00: 3b 20 50 72 69 6e 74 20 6f 75 74 20 73 74 61 74 ; Print out stat
5a10: 73 20 66 6f 72 20 73 74 61 74 75 73 0a 09 28 73 s for status..(s
5a20: 65 74 21 20 74 6f 74 20 30 29 0a 09 28 70 72 69 et! tot 0)..(pri
5a30: 6e 74 20 22 3c 74 61 62 6c 65 20 63 65 6c 6c 73 nt "<table cells
5a40: 70 61 63 69 6e 67 3d 5c 22 30 5c 22 20 62 6f 72 pacing=\"0\" bor
5a50: 64 65 72 3d 5c 22 31 5c 22 3e 3c 74 72 3e 3c 74 der=\"1\"><tr><t
5a60: 64 20 63 6f 6c 73 70 61 6e 3d 5c 22 32 5c 22 3e d colspan=\"2\">
5a70: 3c 68 32 3e 53 74 61 74 65 20 73 74 61 74 73 3c <h2>State stats<
5a80: 2f 68 32 3e 3c 2f 74 64 3e 3c 2f 74 72 3e 22 29 /h2></td></tr>")
5a90: 0a 09 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d ..(for-each (lam
5aa0: 62 64 61 20 28 73 74 61 74 65 29 0a 09 09 20 20 bda (state)...
5ab0: 20 20 28 73 65 74 21 20 74 6f 74 20 28 2b 20 74 (set! tot (+ t
5ac0: 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 ot (hash-table-r
5ad0: 65 66 20 73 74 61 74 65 63 6f 75 6e 74 73 20 73 ef statecounts s
5ae0: 74 61 74 65 29 29 29 0a 09 09 20 20 20 20 28 70 tate)))... (p
5af0: 72 69 6e 74 20 22 3c 74 72 3e 3c 74 64 3e 22 20 rint "<tr><td>"
5b00: 73 74 61 74 65 20 22 3c 2f 74 64 3e 3c 74 64 3e state "</td><td>
5b10: 22 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 " (hash-table-re
5b20: 66 20 73 74 61 74 65 63 6f 75 6e 74 73 20 73 74 f statecounts st
5b30: 61 74 65 29 20 22 3c 2f 74 64 3e 3c 2f 74 72 3e ate) "</td></tr>
5b40: 22 29 29 0a 09 09 20 20 28 68 61 73 68 2d 74 61 "))... (hash-ta
5b50: 62 6c 65 2d 6b 65 79 73 20 73 74 61 74 65 63 6f ble-keys stateco
5b60: 75 6e 74 73 29 29 0a 09 28 70 72 69 6e 74 20 22 unts))..(print "
5b70: 3c 74 72 3e 3c 74 64 3e 54 6f 74 61 6c 3c 2f 74 <tr><td>Total</t
5b80: 64 3e 3c 74 64 3e 22 20 74 6f 74 20 22 3c 2f 74 d><td>" tot "</t
5b90: 64 3e 3c 2f 74 72 3e 3c 2f 74 61 62 6c 65 3e 22 d></tr></table>"
5ba0: 29 0a 09 28 70 72 69 6e 74 20 22 3c 2f 74 64 3e )..(print "</td>
5bb0: 3c 74 64 20 76 61 6c 69 67 6e 3d 5c 22 74 6f 70 <td valign=\"top
5bc0: 5c 22 3e 22 29 0a 09 3b 3b 20 50 72 69 6e 74 20 \">")..;; Print
5bd0: 6f 75 74 20 73 74 61 74 73 20 66 6f 72 20 73 74 out stats for st
5be0: 61 74 65 0a 09 28 73 65 74 21 20 74 6f 74 20 30 ate..(set! tot 0
5bf0: 29 0a 09 28 70 72 69 6e 74 20 22 3c 74 61 62 6c )..(print "<tabl
5c00: 65 20 63 65 6c 6c 73 70 61 63 69 6e 67 3d 5c 22 e cellspacing=\"
5c10: 30 5c 22 20 62 6f 72 64 65 72 3d 5c 22 31 5c 22 0\" border=\"1\"
5c20: 3e 3c 74 72 3e 3c 74 64 20 63 6f 6c 73 70 61 6e ><tr><td colspan
5c30: 3d 5c 22 32 5c 22 3e 3c 68 32 3e 53 74 61 74 75 =\"2\"><h2>Statu
5c40: 73 20 73 74 61 74 73 3c 2f 68 32 3e 3c 2f 74 64 s stats</h2></td
5c50: 3e 3c 2f 74 72 3e 22 29 0a 09 28 66 6f 72 2d 65 ></tr>")..(for-e
5c60: 61 63 68 20 28 6c 61 6d 62 64 61 20 28 73 74 61 ach (lambda (sta
5c70: 74 75 73 29 0a 09 09 20 20 20 20 28 73 65 74 21 tus)... (set!
5c80: 20 74 6f 74 20 28 2b 20 74 6f 74 20 28 68 61 73 tot (+ tot (has
5c90: 68 2d 74 61 62 6c 65 2d 72 65 66 20 63 6f 75 6e h-table-ref coun
5ca0: 74 73 20 73 74 61 74 75 73 29 29 29 0a 09 09 20 ts status)))...
5cb0: 20 20 20 28 70 72 69 6e 74 20 22 3c 74 72 3e 3c (print "<tr><
5cc0: 74 64 3e 3c 66 6f 6e 74 20 63 6f 6c 6f 72 3d 5c td><font color=\
5cd0: 22 22 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 "" (common:get-c
5ce0: 6f 6c 6f 72 2d 66 72 6f 6d 2d 73 74 61 74 75 73 olor-from-status
5cf0: 20 73 74 61 74 75 73 29 20 22 5c 22 3e 22 20 73 status) "\">" s
5d00: 74 61 74 75 73 0a 09 09 09 20 20 20 22 3c 2f 66 tatus.... "</f
5d10: 6f 6e 74 3e 3c 2f 74 64 3e 3c 74 64 3e 22 20 28 ont></td><td>" (
5d20: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 63 hash-table-ref c
5d30: 6f 75 6e 74 73 20 73 74 61 74 75 73 29 20 22 3c ounts status) "<
5d40: 2f 74 64 3e 3c 2f 74 72 3e 22 29 29 0a 09 09 20 /td></tr>"))...
5d50: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 (hash-table-key
5d60: 73 20 63 6f 75 6e 74 73 29 29 0a 09 28 70 72 69 s counts))..(pri
5d70: 6e 74 20 22 3c 74 72 3e 3c 74 64 3e 54 6f 74 61 nt "<tr><td>Tota
5d80: 6c 3c 2f 74 64 3e 3c 74 64 3e 22 20 74 6f 74 20 l</td><td>" tot
5d90: 22 3c 2f 74 64 3e 3c 2f 74 72 3e 3c 2f 74 61 62 "</td></tr></tab
5da0: 6c 65 3e 22 29 0a 09 28 70 72 69 6e 74 20 22 3c le>")..(print "<
5db0: 2f 74 64 3e 3c 2f 74 64 3e 3c 2f 74 72 3e 3c 2f /td></td></tr></
5dc0: 74 61 62 6c 65 3e 22 29 0a 09 0a 09 28 70 72 69 table>")....(pri
5dd0: 6e 74 20 22 3c 74 61 62 6c 65 20 63 65 6c 6c 73 nt "<table cells
5de0: 70 61 63 69 6e 67 3d 5c 22 30 5c 22 20 62 6f 72 pacing=\"0\" bor
5df0: 64 65 72 3d 5c 22 31 5c 22 3e 22 20 0a 09 20 20 der=\"1\">" ..
5e00: 20 20 20 20 20 22 3c 74 72 3e 3c 74 64 3e 49 74 "<tr><td>It
5e10: 65 6d 3c 2f 74 64 3e 3c 74 64 3e 53 74 61 74 65 em</td><td>State
5e20: 3c 2f 74 64 3e 3c 74 64 3e 53 74 61 74 75 73 3c </td><td>Status<
5e30: 2f 74 64 3e 3c 74 64 3e 43 6f 6d 6d 65 6e 74 3c /td><td>Comment<
5e40: 2f 74 64 3e 22 0a 09 20 20 20 20 20 20 20 6f 75 /td>".. ou
5e50: 74 74 78 74 20 22 3c 2f 74 61 62 6c 65 3e 3c 2f ttxt "</table></
5e60: 62 6f 64 79 3e 3c 2f 68 74 6d 6c 3e 22 29 0a 09 body></html>")..
5e70: 3b 3b 20 28 72 65 6c 65 61 73 65 2d 64 6f 74 2d ;; (release-dot-
5e80: 6c 6f 63 6b 20 6f 75 74 70 75 74 66 69 6c 65 6e lock outputfilen
5e90: 61 6d 65 29 0a 09 3b 3b 28 72 6d 74 3a 75 70 64 ame)..;;(rmt:upd
5ea0: 61 74 65 2d 72 75 6e 2d 73 74 61 74 73 20 0a 09 ate-run-stats ..
5eb0: 3b 3b 20 72 75 6e 2d 69 64 0a 09 3b 3b 20 28 68 ;; run-id..;; (h
5ec0: 61 73 68 2d 74 61 62 6c 65 2d 6d 61 70 0a 09 3b ash-table-map..;
5ed0: 3b 20 20 73 74 61 74 65 2d 73 74 61 74 75 73 2d ; state-status-
5ee0: 63 6f 75 6e 74 73 0a 09 3b 3b 20 20 28 6c 61 6d counts..;; (lam
5ef0: 62 64 61 20 28 6b 65 79 20 76 61 6c 29 0a 09 3b bda (key val)..;
5f00: 3b 09 28 61 70 70 65 6e 64 20 6b 65 79 20 28 6c ;.(append key (l
5f10: 69 73 74 20 76 61 6c 29 29 29 29 29 0a 09 29 29 ist val)))))..))
5f20: 29 29 0a 0a 28 64 65 66 69 6e 65 20 74 65 73 74 ))..(define test
5f30: 73 3a 63 73 73 2d 6a 73 63 72 69 70 74 2d 62 6c s:css-jscript-bl
5f40: 6f 63 6b 0a 23 3c 3c 45 4f 46 0a 3c 73 74 79 6c ock.#<<EOF.<styl
5f50: 65 20 74 79 70 65 3d 22 74 65 78 74 2f 63 73 73 e type="text/css
5f60: 22 3e 0a 75 6c 2e 4c 69 6e 6b 65 64 4c 69 73 74 ">.ul.LinkedList
5f70: 20 7b 20 64 69 73 70 6c 61 79 3a 20 62 6c 6f 63 { display: bloc
5f80: 6b 3b 20 7d 0a 2f 2a 20 75 6c 2e 4c 69 6e 6b 65 k; }./* ul.Linke
5f90: 64 4c 69 73 74 20 75 6c 20 7b 20 64 69 73 70 6c dList ul { displ
5fa0: 61 79 3a 20 6e 6f 6e 65 3b 20 7d 20 2a 2f 0a 2e ay: none; } */..
5fb0: 48 61 6e 64 43 75 72 73 6f 72 53 74 79 6c 65 20 HandCursorStyle
5fc0: 7b 20 63 75 72 73 6f 72 3a 20 70 6f 69 6e 74 65 { cursor: pointe
5fd0: 72 3b 20 63 75 72 73 6f 72 3a 20 68 61 6e 64 3b r; cursor: hand;
5fe0: 20 7d 20 20 2f 2a 20 46 6f 72 20 49 45 20 2a 2f } /* For IE */
5ff0: 0a 74 68 20 7b 62 61 63 6b 67 72 6f 75 6e 64 2d .th {background-
6000: 63 6f 6c 6f 72 3a 20 23 38 63 38 63 38 63 3b 7d color: #8c8c8c;}
6010: 0a 74 64 2e 74 65 73 74 20 7b 62 61 63 6b 67 72 .td.test {backgr
6020: 6f 75 6e 64 2d 63 6f 6c 6f 72 3a 20 23 64 39 64 ound-color: #d9d
6030: 62 64 64 3b 7d 0a 74 64 2e 50 41 53 53 20 7b 62 bdd;}.td.PASS {b
6040: 61 63 6b 67 72 6f 75 6e 64 2d 63 6f 6c 6f 72 3a ackground-color:
6050: 20 23 33 34 37 35 33 33 3b 7d 0a 74 64 2e 46 41 #347533;}.td.FA
6060: 49 4c 20 7b 62 61 63 6b 67 72 6f 75 6e 64 2d 63 IL {background-c
6070: 6f 6c 6f 72 3a 20 23 63 63 32 38 31 32 3b 7d 0a olor: #cc2812;}.
6080: 74 64 2e 53 4b 49 50 7b 62 61 63 6b 67 72 6f 75 td.SKIP{backgrou
6090: 6e 64 2d 63 6f 6c 6f 72 3a 20 23 46 46 44 37 33 nd-color: #FFD73
60a0: 33 3b 7d 0a 74 64 2e 57 41 52 4e 20 7b 62 61 63 3;}.td.WARN {bac
60b0: 6b 67 72 6f 75 6e 64 2d 63 6f 6c 6f 72 3a 20 23 kground-color: #
60c0: 45 41 38 37 32 34 3b 7d 0a 74 64 2e 57 41 49 56 EA8724;}.td.WAIV
60d0: 45 44 20 7b 62 61 63 6b 67 72 6f 75 6e 64 2d 63 ED {background-c
60e0: 6f 6c 6f 72 3a 20 23 38 33 38 41 31 32 3b 7d 0a olor: #838A12;}.
60f0: 74 64 2e 41 42 4f 52 54 7b 62 61 63 6b 67 72 6f td.ABORT{backgro
6100: 75 6e 64 2d 63 6f 6c 6f 72 3a 20 23 45 41 32 34 und-color: #EA24
6110: 42 37 3b 7d 0a 2e 50 41 53 53 20 2e 6c 69 6e 6b B7;}..PASS .link
6120: 2c 20 2e 53 4b 49 50 20 2e 6c 69 6e 6b 2c 20 2e , .SKIP .link, .
6130: 57 41 52 4e 20 2e 6c 69 6e 6b 2c 2e 57 41 49 56 WARN .link,.WAIV
6140: 45 44 20 2e 6c 69 6e 6b 2c 2e 41 42 4f 52 54 20 ED .link,.ABORT
6150: 2e 6c 69 6e 6b 2c 20 2e 46 41 49 4c 20 2e 6c 69 .link, .FAIL .li
6160: 6e 6b 7b 63 6f 6c 6f 72 3a 20 23 46 46 46 46 46 nk{color: #FFFFF
6170: 46 3b 7d 0a 0a 0a 3c 2f 73 74 79 6c 65 3e 0a 0a F;}...</style>..
6180: 0a 20 20 3c 73 63 72 69 70 74 20 74 79 70 65 3d . <script type=
6190: 22 74 65 78 74 2f 4a 61 76 61 53 63 72 69 70 74 "text/JavaScript
61a0: 22 3e 0a 0a 20 20 20 20 66 75 6e 63 74 69 6f 6e ">.. function
61b0: 20 66 69 6c 74 65 72 73 6f 6d 65 28 29 20 7b 0a filtersome() {.
61c0: 20 20 24 28 22 74 72 22 29 2e 73 68 6f 77 28 29 $("tr").show()
61d0: 3b 0a 20 20 24 28 22 2e 74 65 73 74 22 29 2e 66 ;. $(".test").f
61e0: 69 6c 74 65 72 28 0a 20 20 20 20 66 75 6e 63 74 ilter(. funct
61f0: 69 6f 6e 28 29 20 7b 0a 20 20 20 20 20 20 76 61 ion() {. va
6200: 72 20 6e 61 6d 65 73 20 3d 20 24 28 27 23 74 65 r names = $('#te
6210: 73 74 6e 61 6d 65 27 29 2e 76 61 6c 28 29 2e 73 stname').val().s
6220: 70 6c 69 74 28 27 2c 27 29 3b 0a 20 20 20 20 20 plit(',');.
6230: 20 76 61 72 20 67 6f 6f 64 3d 31 3b 0a 20 20 20 var good=1;.
6240: 20 20 20 66 6f 72 20 28 76 61 72 20 69 3d 30 2c for (var i=0,
6250: 20 6c 65 6e 3d 6e 61 6d 65 73 2e 6c 65 6e 67 74 len=names.lengt
6260: 68 3b 20 69 3c 6c 65 6e 3b 20 69 2b 2b 29 20 7b h; i<len; i++) {
6270: 0a 20 20 20 20 20 20 20 20 76 61 72 20 75 6e 61 . var una
6280: 6d 65 3d 6e 61 6d 65 73 5b 69 5d 3b 0a 20 20 20 me=names[i];.
6290: 20 20 20 20 20 63 6f 6e 73 6f 6c 65 2e 6c 6f 67 console.log
62a0: 28 22 54 72 79 69 6e 67 20 74 6f 20 63 68 65 63 ("Trying to chec
62b0: 6b 20 66 6f 72 20 22 20 2b 20 75 6e 61 6d 65 29 k for " + uname)
62c0: 3b 20 0a 20 20 20 20 20 20 20 20 69 66 28 24 28 ; . if($(
62d0: 74 68 69 73 29 2e 74 65 78 74 28 29 2e 69 6e 64 this).text().ind
62e0: 65 78 4f 66 28 75 6e 61 6d 65 29 20 21 3d 20 2d exOf(uname) != -
62f0: 31 29 20 7b 0a 20 20 20 20 20 20 20 20 20 20 67 1) {. g
6300: 6f 6f 64 3d 20 30 3b 0a 20 20 20 20 20 20 20 20 ood= 0;.
6310: 20 20 63 6f 6e 73 6f 6c 65 2e 6c 6f 67 28 22 46 console.log("F
6320: 6f 75 6e 64 20 22 2b 75 6e 61 6d 65 29 3b 0a 20 ound "+uname);.
6330: 20 20 20 20 20 20 20 7d 0a 20 20 20 20 20 20 7d }. }
6340: 0a 20 20 20 20 20 20 72 65 74 75 72 6e 20 67 6f . return go
6350: 6f 64 3b 20 0a 20 20 20 20 7d 0a 20 20 29 2e 70 od; . }. ).p
6360: 61 72 65 6e 74 28 29 2e 68 69 64 65 28 29 3b 0a arent().hide();.
6370: 2f 2f 20 20 24 28 22 2e 73 75 6d 22 29 2e 73 68 // $(".sum").sh
6380: 6f 77 28 29 3b 0a 7d 0a 20 20 0a 20 20 20 20 2f ow();.}. . /
6390: 2f 20 41 64 64 20 74 68 69 73 20 74 6f 20 74 68 / Add this to th
63a0: 65 20 6f 6e 6c 6f 61 64 20 65 76 65 6e 74 20 6f e onload event o
63b0: 66 20 74 68 65 20 42 4f 44 59 20 65 6c 65 6d 65 f the BODY eleme
63c0: 6e 74 0a 20 20 20 20 66 75 6e 63 74 69 6f 6e 20 nt. function
63d0: 61 64 64 45 76 65 6e 74 73 28 29 20 7b 0a 20 20 addEvents() {.
63e0: 20 20 20 20 61 63 74 69 76 61 74 65 54 72 65 65 activateTree
63f0: 28 64 6f 63 75 6d 65 6e 74 2e 67 65 74 45 6c 65 (document.getEle
6400: 6d 65 6e 74 42 79 49 64 28 22 4c 69 6e 6b 65 64 mentById("Linked
6410: 4c 69 73 74 31 22 29 29 3b 0a 20 20 20 20 7d 0a List1"));. }.
6420: 0a 20 20 20 20 2f 2f 20 54 68 69 73 20 66 75 6e . // This fun
6430: 63 74 69 6f 6e 20 74 72 61 76 65 72 73 65 73 20 ction traverses
6440: 74 68 65 20 6c 69 73 74 20 61 6e 64 20 61 64 64 the list and add
6450: 20 6c 69 6e 6b 73 20 0a 20 20 20 20 2f 2f 20 74 links . // t
6460: 6f 20 6e 65 73 74 65 64 20 6c 69 73 74 20 69 74 o nested list it
6470: 65 6d 73 0a 20 20 20 20 66 75 6e 63 74 69 6f 6e ems. function
6480: 20 61 63 74 69 76 61 74 65 54 72 65 65 28 6f 4c activateTree(oL
6490: 69 73 74 29 20 7b 0a 20 20 20 20 20 20 2f 2f 20 ist) {. //
64a0: 43 6f 6c 6c 61 70 73 65 20 74 68 65 20 74 72 65 Collapse the tre
64b0: 65 0a 20 20 20 20 20 20 66 6f 72 20 28 76 61 72 e. for (var
64c0: 20 69 3d 30 3b 20 69 20 3c 20 6f 4c 69 73 74 2e i=0; i < oList.
64d0: 67 65 74 45 6c 65 6d 65 6e 74 73 42 79 54 61 67 getElementsByTag
64e0: 4e 61 6d 65 28 22 75 6c 22 29 2e 6c 65 6e 67 74 Name("ul").lengt
64f0: 68 3b 20 69 2b 2b 29 20 7b 0a 20 20 20 20 20 20 h; i++) {.
6500: 20 20 6f 4c 69 73 74 2e 67 65 74 45 6c 65 6d 65 oList.getEleme
6510: 6e 74 73 42 79 54 61 67 4e 61 6d 65 28 22 75 6c ntsByTagName("ul
6520: 22 29 5b 69 5d 2e 73 74 79 6c 65 2e 64 69 73 70 ")[i].style.disp
6530: 6c 61 79 3d 22 6e 6f 6e 65 22 3b 20 20 20 20 20 lay="none";
6540: 20 20 20 20 20 20 20 0a 20 20 20 20 20 20 7d 20 . }
6550: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6560: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6570: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6580: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6590: 20 0a 20 20 20 20 20 20 2f 2f 20 41 64 64 20 74 . // Add t
65a0: 68 65 20 63 6c 69 63 6b 2d 65 76 65 6e 74 20 68 he click-event h
65b0: 61 6e 64 6c 65 72 20 74 6f 20 74 68 65 20 6c 69 andler to the li
65c0: 73 74 20 69 74 65 6d 73 0a 20 20 20 20 20 20 69 st items. i
65d0: 66 20 28 6f 4c 69 73 74 2e 61 64 64 45 76 65 6e f (oList.addEven
65e0: 74 4c 69 73 74 65 6e 65 72 29 20 7b 0a 20 20 20 tListener) {.
65f0: 20 20 20 20 20 6f 4c 69 73 74 2e 61 64 64 45 76 oList.addEv
6600: 65 6e 74 4c 69 73 74 65 6e 65 72 28 22 63 6c 69 entListener("cli
6610: 63 6b 22 2c 20 74 6f 67 67 6c 65 42 72 61 6e 63 ck", toggleBranc
6620: 68 2c 20 66 61 6c 73 65 29 3b 0a 20 20 20 20 20 h, false);.
6630: 20 7d 20 65 6c 73 65 20 69 66 20 28 6f 4c 69 73 } else if (oLis
6640: 74 2e 61 74 74 61 63 68 45 76 65 6e 74 29 20 7b t.attachEvent) {
6650: 20 2f 2f 20 46 6f 72 20 49 45 0a 20 20 20 20 20 // For IE.
6660: 20 20 20 6f 4c 69 73 74 2e 61 74 74 61 63 68 45 oList.attachE
6670: 76 65 6e 74 28 22 6f 6e 63 6c 69 63 6b 22 2c 20 vent("onclick",
6680: 74 6f 67 67 6c 65 42 72 61 6e 63 68 29 3b 0a 20 toggleBranch);.
6690: 20 20 20 20 20 7d 0a 20 20 20 20 20 20 2f 2f 20 }. //
66a0: 4d 61 6b 65 20 74 68 65 20 6e 65 73 74 65 64 20 Make the nested
66b0: 69 74 65 6d 73 20 6c 6f 6f 6b 20 6c 69 6b 65 20 items look like
66c0: 6c 69 6e 6b 73 0a 20 20 20 20 20 20 61 64 64 4c links. addL
66d0: 69 6e 6b 73 54 6f 42 72 61 6e 63 68 65 73 28 6f inksToBranches(o
66e0: 4c 69 73 74 29 3b 0a 20 20 20 20 7d 0a 0a 20 20 List);. }..
66f0: 20 20 2f 2f 20 54 68 69 73 20 69 73 20 74 68 65 // This is the
6700: 20 63 6c 69 63 6b 2d 65 76 65 6e 74 20 68 61 6e click-event han
6710: 64 6c 65 72 0a 20 20 20 20 66 75 6e 63 74 69 6f dler. functio
6720: 6e 20 74 6f 67 67 6c 65 42 72 61 6e 63 68 28 65 n toggleBranch(e
6730: 76 65 6e 74 29 20 7b 0a 20 20 20 20 20 20 76 61 vent) {. va
6740: 72 20 6f 42 72 61 6e 63 68 2c 20 63 53 75 62 42 r oBranch, cSubB
6750: 72 61 6e 63 68 65 73 3b 0a 20 20 20 20 20 20 69 ranches;. i
6760: 66 20 28 65 76 65 6e 74 2e 74 61 72 67 65 74 29 f (event.target)
6770: 20 7b 0a 20 20 20 20 20 20 20 20 6f 42 72 61 6e {. oBran
6780: 63 68 20 3d 20 65 76 65 6e 74 2e 74 61 72 67 65 ch = event.targe
6790: 74 3b 0a 20 20 20 20 20 20 7d 20 65 6c 73 65 20 t;. } else
67a0: 69 66 20 28 65 76 65 6e 74 2e 73 72 63 45 6c 65 if (event.srcEle
67b0: 6d 65 6e 74 29 20 7b 20 2f 2f 20 46 6f 72 20 49 ment) { // For I
67c0: 45 0a 20 20 20 20 20 20 20 20 6f 42 72 61 6e 63 E. oBranc
67d0: 68 20 3d 20 65 76 65 6e 74 2e 73 72 63 45 6c 65 h = event.srcEle
67e0: 6d 65 6e 74 3b 0a 20 20 20 20 20 20 7d 0a 20 20 ment;. }.
67f0: 20 20 20 20 63 53 75 62 42 72 61 6e 63 68 65 73 cSubBranches
6800: 20 3d 20 6f 42 72 61 6e 63 68 2e 67 65 74 45 6c = oBranch.getEl
6810: 65 6d 65 6e 74 73 42 79 54 61 67 4e 61 6d 65 28 ementsByTagName(
6820: 22 75 6c 22 29 3b 0a 20 20 20 20 20 20 69 66 20 "ul");. if
6830: 28 63 53 75 62 42 72 61 6e 63 68 65 73 2e 6c 65 (cSubBranches.le
6840: 6e 67 74 68 20 3e 20 30 29 20 7b 0a 20 20 20 20 ngth > 0) {.
6850: 20 20 20 20 69 66 20 28 63 53 75 62 42 72 61 6e if (cSubBran
6860: 63 68 65 73 5b 30 5d 2e 73 74 79 6c 65 2e 64 69 ches[0].style.di
6870: 73 70 6c 61 79 20 3d 3d 20 22 62 6c 6f 63 6b 22 splay == "block"
6880: 29 20 7b 0a 20 20 20 20 20 20 20 20 20 20 63 53 ) {. cS
6890: 75 62 42 72 61 6e 63 68 65 73 5b 30 5d 2e 73 74 ubBranches[0].st
68a0: 79 6c 65 2e 64 69 73 70 6c 61 79 20 3d 20 22 6e yle.display = "n
68b0: 6f 6e 65 22 3b 0a 20 20 20 20 20 20 20 20 7d 20 one";. }
68c0: 65 6c 73 65 20 7b 0a 20 20 20 20 20 20 20 20 20 else {.
68d0: 20 63 53 75 62 42 72 61 6e 63 68 65 73 5b 30 5d cSubBranches[0]
68e0: 2e 73 74 79 6c 65 2e 64 69 73 70 6c 61 79 20 3d .style.display =
68f0: 20 22 62 6c 6f 63 6b 22 3b 0a 20 20 20 20 20 20 "block";.
6900: 20 20 7d 0a 20 20 20 20 20 20 7d 0a 20 20 20 20 }. }.
6910: 7d 0a 0a 20 20 20 20 2f 2f 20 54 68 69 73 20 66 }.. // This f
6920: 75 6e 63 74 69 6f 6e 20 6d 61 6b 65 73 20 6e 65 unction makes ne
6930: 73 74 65 64 20 6c 69 73 74 20 69 74 65 6d 73 20 sted list items
6940: 6c 6f 6f 6b 20 6c 69 6b 65 20 6c 69 6e 6b 73 0a look like links.
6950: 20 20 20 20 66 75 6e 63 74 69 6f 6e 20 61 64 64 function add
6960: 4c 69 6e 6b 73 54 6f 42 72 61 6e 63 68 65 73 28 LinksToBranches(
6970: 6f 4c 69 73 74 29 20 7b 0a 20 20 20 20 20 20 76 oList) {. v
6980: 61 72 20 63 42 72 61 6e 63 68 65 73 20 3d 20 6f ar cBranches = o
6990: 4c 69 73 74 2e 67 65 74 45 6c 65 6d 65 6e 74 73 List.getElements
69a0: 42 79 54 61 67 4e 61 6d 65 28 22 6c 69 22 29 3b ByTagName("li");
69b0: 0a 20 20 20 20 20 20 76 61 72 20 69 2c 20 6e 2c . var i, n,
69c0: 20 63 53 75 62 42 72 61 6e 63 68 65 73 3b 0a 20 cSubBranches;.
69d0: 20 20 20 20 20 69 66 20 28 63 42 72 61 6e 63 68 if (cBranch
69e0: 65 73 2e 6c 65 6e 67 74 68 20 3e 20 30 29 20 7b es.length > 0) {
69f0: 0a 20 20 20 20 20 20 20 20 66 6f 72 20 28 69 3d . for (i=
6a00: 30 2c 20 6e 20 3d 20 63 42 72 61 6e 63 68 65 73 0, n = cBranches
6a10: 2e 6c 65 6e 67 74 68 3b 20 69 20 3c 20 6e 3b 20 .length; i < n;
6a20: 69 2b 2b 29 20 7b 0a 20 20 20 20 20 20 20 20 20 i++) {.
6a30: 20 63 53 75 62 42 72 61 6e 63 68 65 73 20 3d 20 cSubBranches =
6a40: 63 42 72 61 6e 63 68 65 73 5b 69 5d 2e 67 65 74 cBranches[i].get
6a50: 45 6c 65 6d 65 6e 74 73 42 79 54 61 67 4e 61 6d ElementsByTagNam
6a60: 65 28 22 75 6c 22 29 3b 0a 20 20 20 20 20 20 20 e("ul");.
6a70: 20 20 20 69 66 20 28 63 53 75 62 42 72 61 6e 63 if (cSubBranc
6a80: 68 65 73 2e 6c 65 6e 67 74 68 20 3e 20 30 29 20 hes.length > 0)
6a90: 7b 0a 20 20 20 20 20 20 20 20 20 20 20 20 61 64 {. ad
6aa0: 64 4c 69 6e 6b 73 54 6f 42 72 61 6e 63 68 65 73 dLinksToBranches
6ab0: 28 63 53 75 62 42 72 61 6e 63 68 65 73 5b 30 5d (cSubBranches[0]
6ac0: 29 3b 0a 20 20 20 20 20 20 20 20 20 20 20 20 63 );. c
6ad0: 42 72 61 6e 63 68 65 73 5b 69 5d 2e 63 6c 61 73 Branches[i].clas
6ae0: 73 4e 61 6d 65 20 3d 20 22 48 61 6e 64 43 75 72 sName = "HandCur
6af0: 73 6f 72 53 74 79 6c 65 22 3b 0a 20 20 20 20 20 sorStyle";.
6b00: 20 20 20 20 20 20 20 63 42 72 61 6e 63 68 65 73 cBranches
6b10: 5b 69 5d 2e 73 74 79 6c 65 2e 63 6f 6c 6f 72 20 [i].style.color
6b20: 3d 20 22 62 6c 75 65 22 3b 0a 20 20 20 20 20 20 = "blue";.
6b30: 20 20 20 20 20 20 63 53 75 62 42 72 61 6e 63 68 cSubBranch
6b40: 65 73 5b 30 5d 2e 73 74 79 6c 65 2e 63 6f 6c 6f es[0].style.colo
6b50: 72 20 3d 20 22 62 6c 61 63 6b 22 3b 0a 20 20 20 r = "black";.
6b60: 20 20 20 20 20 20 20 20 20 63 53 75 62 42 72 61 cSubBra
6b70: 6e 63 68 65 73 5b 30 5d 2e 73 74 79 6c 65 2e 63 nches[0].style.c
6b80: 75 72 73 6f 72 20 3d 20 22 61 75 74 6f 22 3b 0a ursor = "auto";.
6b90: 20 20 20 20 20 20 20 20 20 20 7d 0a 20 20 20 20 }.
6ba0: 20 20 20 20 7d 0a 20 20 20 20 20 20 7d 0a 20 20 }. }.
6bb0: 20 20 7d 0a 20 20 3c 2f 73 63 72 69 70 74 3e 0a }. </script>.
6bc0: 45 4f 46 0a 29 0a 0a 28 64 65 66 69 6e 65 20 74 EOF.)..(define t
6bd0: 65 73 74 73 3a 63 73 73 2d 6a 73 63 72 69 70 74 ests:css-jscript
6be0: 2d 62 6c 6f 63 6b 2d 64 79 6e 61 6d 69 63 20 0a -block-dynamic .
6bf0: 23 3c 3c 45 4f 46 0a 20 20 20 20 20 20 20 20 20 #<<EOF.
6c00: 20 20 3c 73 63 72 69 70 74 20 73 72 63 3d 20 2e <script src= .
6c10: 2f 6a 71 75 65 72 79 33 2e 31 2e 30 2e 6a 73 3e /jquery3.1.0.js>
6c20: 3c 2f 73 63 72 69 70 74 3e 20 0a 45 4f 46 0a 29 </script> .EOF.)
6c30: 0a 0a 28 64 65 66 69 6e 65 20 20 28 74 65 73 74 ..(define (test
6c40: 3a 6a 73 2d 62 6c 6f 63 6b 20 6a 61 76 61 73 63 :js-block javasc
6c50: 72 69 70 74 2d 6c 69 62 29 0a 20 20 20 28 63 6f ript-lib). (co
6c60: 6e 63 20 20 22 3c 73 63 72 69 70 74 20 73 72 63 nc "<script src
6c70: 3d 22 20 6a 61 76 61 73 63 72 69 70 74 2d 6c 69 =" javascript-li
6c80: 62 20 22 3e 3c 2f 73 63 72 69 70 74 3e 22 20 29 b "></script>" )
6c90: 29 0a 0a 0a 28 64 65 66 69 6e 65 20 74 65 73 74 )...(define test
6ca0: 73 3a 63 73 73 2d 6a 73 63 72 69 70 74 2d 62 6c s:css-jscript-bl
6cb0: 6f 63 6b 2d 73 74 61 74 69 63 20 28 74 65 73 74 ock-static (test
6cc0: 3a 6a 73 2d 62 6c 6f 63 6b 20 2a 6a 61 76 61 2d :js-block *java-
6cd0: 73 63 72 69 70 74 2d 6c 69 62 2a 29 29 0a 0a 28 script-lib*))..(
6ce0: 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 63 73 define (tests:cs
6cf0: 73 2d 6a 73 63 72 69 70 74 2d 62 6c 6f 63 6b 2d s-jscript-block-
6d00: 63 6f 6e 64 20 64 79 6e 61 6d 69 63 29 20 0a 20 cond dynamic) .
6d10: 20 20 20 20 20 28 69 66 20 28 65 71 75 61 6c 3f (if (equal?
6d20: 20 64 79 6e 61 6d 69 63 20 20 23 74 29 0a 20 20 dynamic #t).
6d30: 20 20 20 20 20 74 65 73 74 73 3a 63 73 73 2d 6a tests:css-j
6d40: 73 63 72 69 70 74 2d 62 6c 6f 63 6b 2d 64 79 6e script-block-dyn
6d50: 61 6d 69 63 0a 20 20 20 20 20 20 20 74 65 73 74 amic. test
6d60: 73 3a 63 73 73 2d 6a 73 63 72 69 70 74 2d 62 6c s:css-jscript-bl
6d70: 6f 63 6b 2d 73 74 61 74 69 63 29 29 0a 0a 20 20 ock-static))..
6d80: 20 20 20 20 20 0a 28 64 65 66 69 6e 65 20 28 74 .(define (t
6d90: 65 73 74 73 3a 72 75 6e 2d 72 65 63 6f 72 64 2d ests:run-record-
6da0: 3e 74 65 73 74 2d 70 61 74 68 20 72 75 6e 20 6e >test-path run n
6db0: 75 6d 6b 65 79 73 29 0a 20 20 20 28 61 70 70 65 umkeys). (appe
6dc0: 6e 64 20 28 74 61 6b 65 20 28 76 65 63 74 6f 72 nd (take (vector
6dd0: 2d 3e 6c 69 73 74 20 72 75 6e 29 20 6e 75 6d 6b ->list run) numk
6de0: 65 79 73 29 0a 09 20 20 20 28 6c 69 73 74 20 28 eys).. (list (
6df0: 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 20 28 vector-ref run (
6e00: 2b 20 31 20 6e 75 6d 6b 65 79 73 29 29 29 29 29 + 1 numkeys)))))
6e10: 0a 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 ...(define (test
6e20: 73 3a 67 65 74 2d 72 65 73 74 2d 64 61 74 61 20 s:get-rest-data
6e30: 72 75 6e 73 20 68 65 61 64 65 72 20 6e 75 6d 6b runs header numk
6e40: 65 79 73 29 0a 20 20 20 28 6c 65 74 20 28 28 72 eys). (let ((r
6e50: 65 73 68 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 esh (make-hash-t
6e60: 61 62 6c 65 29 29 29 0a 20 20 20 28 66 6f 72 2d able))). (for-
6e70: 65 61 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 each. (lambd
6e80: 61 20 28 72 75 6e 29 0a 20 20 20 20 20 20 20 20 a (run).
6e90: 28 6c 65 74 2a 20 28 28 72 75 6e 2d 69 64 20 28 (let* ((run-id (
6ea0: 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d db:get-value-by-
6eb0: 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 header run heade
6ec0: 72 20 22 69 64 22 29 29 0a 20 20 20 20 20 20 20 r "id")).
6ed0: 20 20 20 20 20 20 20 20 28 72 75 6e 2d 64 69 72 (run-dir
6ee0: 20 20 20 20 20 20 28 74 65 73 74 73 3a 72 75 6e (tests:run
6ef0: 2d 72 65 63 6f 72 64 2d 3e 74 65 73 74 2d 70 61 -record->test-pa
6f00: 74 68 20 72 75 6e 20 6e 75 6d 6b 65 79 73 29 29 th run numkeys))
6f10: 0a 09 20 20 20 20 20 20 20 28 74 65 73 74 2d 64 .. (test-d
6f20: 61 74 61 20 20 20 20 28 72 6d 74 3a 67 65 74 2d ata (rmt:get-
6f30: 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 0a 09 09 tests-for-run...
6f40: 09 09 20 20 20 72 75 6e 2d 69 64 0a 20 20 20 20 .. run-id.
6f50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6f60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 22 "
6f70: 25 22 20 20 20 20 20 20 20 3b 3b 20 74 65 73 74 %" ;; test
6f80: 6e 61 6d 65 70 61 74 74 0a 09 09 09 09 20 20 20 namepatt.....
6f90: 27 28 29 20 20 20 20 20 20 20 20 3b 3b 20 73 74 '() ;; st
6fa0: 61 74 65 73 0a 09 09 09 09 20 20 20 27 28 29 20 ates..... '()
6fb0: 20 20 20 20 20 20 20 3b 3b 20 73 74 61 74 75 73 ;; status
6fc0: 65 73 0a 09 09 09 09 20 20 20 23 66 20 20 20 20 es..... #f
6fd0: 20 20 20 20 20 3b 3b 20 6f 66 66 73 65 74 0a 09 ;; offset..
6fe0: 09 09 09 20 20 20 23 66 20 20 20 20 20 20 20 20 ... #f
6ff0: 20 3b 3b 20 6e 75 6d 2d 74 6f 2d 67 65 74 0a 09 ;; num-to-get..
7000: 09 09 09 20 20 20 23 66 20 20 20 20 20 20 20 20 ... #f
7010: 20 3b 3b 20 68 69 64 65 2f 6e 6f 74 2d 68 69 64 ;; hide/not-hid
7020: 65 0a 09 09 09 09 20 20 20 23 66 20 20 20 20 20 e..... #f
7030: 20 20 20 20 3b 3b 20 73 6f 72 74 2d 62 79 0a 09 ;; sort-by..
7040: 09 09 09 20 20 20 23 66 20 20 20 20 20 20 20 20 ... #f
7050: 20 3b 3b 20 73 6f 72 74 2d 6f 72 64 65 72 0a 09 ;; sort-order..
7060: 09 09 09 20 20 20 23 66 20 20 20 20 20 20 20 20 ... #f
7070: 20 3b 3b 20 27 73 68 6f 72 74 6c 69 73 74 20 20 ;; 'shortlist
7080: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7090: 20 20 20 20 20 20 20 20 20 3b 3b 20 71 72 79 74 ;; qryt
70a0: 79 70 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 ype.
70b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
70c0: 20 20 20 20 20 20 20 30 20 20 20 20 20 20 20 20 0
70d0: 20 3b 3b 20 6c 61 73 74 20 75 70 64 61 74 65 0a ;; last update.
70e0: 09 09 09 09 20 20 20 23 66 29 29 29 0a 20 20 20 .... #f))).
70f0: 20 20 20 20 20 20 20 20 20 0a 20 20 20 20 20 20 .
7100: 20 20 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 (map (lamb
7110: 64 61 20 28 74 65 73 74 29 0a 20 20 20 20 20 20 da (test).
7120: 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 2a (let*
7130: 20 28 28 74 65 73 74 2d 6e 61 6d 65 20 28 76 65 ((test-name (ve
7140: 63 74 6f 72 2d 72 65 66 20 74 65 73 74 20 32 29 ctor-ref test 2)
7150: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
7160: 20 20 20 20 20 20 20 20 20 20 28 74 65 73 74 2d (test-
7170: 68 74 6d 6c 2d 70 61 74 68 20 28 63 6f 6e 63 20 html-path (conc
7180: 28 76 65 63 74 6f 72 2d 72 65 66 20 74 65 73 74 (vector-ref test
7190: 20 31 30 29 20 22 2f 22 20 28 76 65 63 74 6f 72 10) "/" (vector
71a0: 2d 72 65 66 20 74 65 73 74 20 31 33 29 29 29 0a -ref test 13))).
71b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
71c0: 20 20 20 20 20 20 20 20 28 74 65 73 74 2d 69 74 (test-it
71d0: 65 6d 20 28 63 6f 6e 63 20 74 65 73 74 2d 6e 61 em (conc test-na
71e0: 6d 65 20 22 3a 22 20 28 76 65 63 74 6f 72 2d 72 me ":" (vector-r
71f0: 65 66 20 74 65 73 74 20 31 31 29 29 29 0a 20 20 ef test 11))).
7200: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7210: 20 20 20 20 20 20 28 74 65 73 74 2d 73 74 61 74 (test-stat
7220: 75 73 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 us (vector-ref t
7230: 65 73 74 20 34 29 29 29 0a 20 20 20 20 20 20 20 est 4))).
7240: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7250: 20 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 .
7260: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 68 61 73 (if (not (has
7270: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
7280: 75 6c 74 20 72 65 73 68 20 74 65 73 74 2d 6e 61 ult resh test-na
7290: 6d 65 20 20 23 66 29 29 0a 20 20 20 20 20 20 20 me #f)).
72a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
72b0: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
72c0: 72 65 73 68 20 74 65 73 74 2d 6e 61 6d 65 20 20 resh test-name
72d0: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
72e0: 65 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 e))).
72f0: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 68 (if (not (h
7300: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
7310: 66 61 75 6c 74 20 28 68 61 73 68 2d 74 61 62 6c fault (hash-tabl
7320: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 72 65 e-ref/default re
7330: 73 68 20 74 65 73 74 2d 6e 61 6d 65 20 20 23 66 sh test-name #f
7340: 29 20 20 74 65 73 74 2d 69 74 65 6d 20 20 23 66 ) test-item #f
7350: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
7360: 20 20 20 20 20 20 20 20 20 20 28 68 61 73 68 2d (hash-
7370: 74 61 62 6c 65 2d 73 65 74 21 20 28 68 61 73 68 table-set! (hash
7380: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
7390: 6c 74 20 72 65 73 68 20 74 65 73 74 2d 6e 61 6d lt resh test-nam
73a0: 65 20 20 23 66 29 20 74 65 73 74 2d 69 74 65 6d e #f) test-item
73b0: 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 (make-hash-ta
73c0: 62 6c 65 29 29 29 20 0a 20 20 20 20 20 20 20 20 ble))) .
73d0: 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 (hash-tab
73e0: 6c 65 2d 73 65 74 21 20 20 28 68 61 73 68 2d 74 le-set! (hash-t
73f0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
7400: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
7410: 2f 64 65 66 61 75 6c 74 20 72 65 73 68 20 74 65 /default resh te
7420: 73 74 2d 6e 61 6d 65 20 20 23 66 29 20 74 65 73 st-name #f) tes
7430: 74 2d 69 74 65 6d 20 23 66 29 20 72 75 6e 2d 69 t-item #f) run-i
7440: 64 20 28 6c 69 73 74 20 74 65 73 74 2d 73 74 61 d (list test-sta
7450: 74 75 73 20 74 65 73 74 2d 68 74 6d 6c 2d 70 61 tus test-html-pa
7460: 74 68 29 29 29 29 20 0a 20 20 20 20 20 20 20 20 th)))) .
7470: 74 65 73 74 2d 64 61 74 61 29 29 29 0a 20 20 20 test-data))).
7480: 20 20 20 72 75 6e 73 29 0a 20 20 20 72 65 73 68 runs). resh
7490: 29 29 0a 0a 0a 3b 3b 20 74 65 73 74 73 3a 67 65 ))...;; tests:ge
74a0: 6e 72 61 74 65 20 64 61 73 68 62 6f 61 72 64 20 nrate dashboard
74b0: 62 6f 64 79 20 0a 3b 3b 0a 0a 28 64 65 66 69 6e body .;;..(defin
74c0: 65 20 28 74 65 73 74 73 3a 64 61 73 68 62 6f 61 e (tests:dashboa
74d0: 72 64 2d 62 6f 64 79 20 70 61 67 65 20 70 67 2d rd-body page pg-
74e0: 73 69 7a 65 20 6b 65 79 73 20 6e 75 6d 6b 65 79 size keys numkey
74f0: 73 20 20 74 6f 74 61 6c 2d 72 75 6e 73 20 6c 69 s total-runs li
7500: 6e 6b 74 72 65 65 20 61 72 65 61 2d 6e 61 6d 65 nktree area-name
7510: 20 67 65 74 2d 70 72 65 76 2d 6c 69 6e 6b 73 20 get-prev-links
7520: 67 65 74 2d 6e 65 78 74 2d 6c 69 6e 6b 73 20 66 get-next-links f
7530: 6c 61 67 20 72 75 6e 2d 70 61 74 74 20 74 61 72 lag run-patt tar
7540: 67 65 74 2d 70 61 74 74 29 0a 20 20 28 6c 65 74 get-patt). (let
7550: 2a 20 28 28 73 74 61 72 74 20 28 2a 20 70 61 67 * ((start (* pag
7560: 65 20 70 67 2d 73 69 7a 65 29 29 20 0a 09 09 09 e pg-size)) ....
7570: 09 09 3b 28 72 75 6e 73 64 61 74 20 20 20 28 72 ..;(runsdat (r
7580: 6d 74 3a 67 65 74 2d 72 75 6e 73 20 22 25 22 20 mt:get-runs "%"
7590: 70 67 2d 73 69 7a 65 20 73 74 61 72 74 20 28 6d pg-size start (m
75a0: 61 70 20 28 6c 61 6d 62 64 61 20 28 78 29 28 6c ap (lambda (x)(l
75b0: 69 73 74 20 78 20 22 25 22 29 29 20 6b 65 79 73 ist x "%")) keys
75c0: 29 29 29 0a 20 20 20 20 20 20 20 20 20 28 72 75 ))). (ru
75d0: 6e 73 64 61 74 20 20 20 28 72 6d 74 3a 67 65 74 nsdat (rmt:get
75e0: 2d 72 75 6e 73 2d 62 79 2d 70 61 74 74 20 20 6b -runs-by-patt k
75f0: 65 79 73 20 72 75 6e 2d 70 61 74 74 20 74 61 72 eys run-patt tar
7600: 67 65 74 2d 70 61 74 74 20 73 74 61 72 74 20 70 get-patt start p
7610: 67 2d 73 69 7a 65 20 23 66 20 30 20 73 6f 72 74 g-size #f 0 sort
7620: 2d 6f 72 64 65 72 3a 20 22 64 65 73 63 22 29 29 -order: "desc"))
7630: 0a 09 09 09 09 09 3b 20 64 62 3a 67 65 74 2d 72 ......; db:get-r
7640: 75 6e 73 2d 62 79 2d 70 61 74 74 20 20 20 6b 65 uns-by-patt ke
7650: 79 73 20 72 75 6e 6e 61 6d 65 70 61 74 74 20 74 ys runnamepatt t
7660: 61 72 67 70 61 74 74 20 6f 66 66 73 65 74 20 6c argpatt offset l
7670: 69 6d 69 74 20 66 69 65 6c 64 73 20 6c 61 73 74 imit fields last
7680: 2d 75 70 64 61 74 65 20 20 20 0a 09 20 28 68 65 -update .. (he
7690: 61 64 65 72 20 20 20 20 28 76 65 63 74 6f 72 2d ader (vector-
76a0: 72 65 66 20 72 75 6e 73 64 61 74 20 30 29 29 0a ref runsdat 0)).
76b0: 09 20 28 72 75 6e 73 20 20 20 20 20 20 28 76 65 . (runs (ve
76c0: 63 74 6f 72 2d 72 65 66 20 72 75 6e 73 64 61 74 ctor-ref runsdat
76d0: 20 31 29 29 0a 20 20 20 20 20 20 20 20 20 28 63 1)). (c
76e0: 74 72 20 30 29 0a 20 20 20 20 20 20 20 20 20 28 tr 0). (
76f0: 74 65 73 74 2d 72 75 6e 73 2d 68 61 73 68 20 28 test-runs-hash (
7700: 74 65 73 74 73 3a 67 65 74 2d 72 65 73 74 2d 64 tests:get-rest-d
7710: 61 74 61 20 72 75 6e 73 20 68 65 61 64 65 72 20 ata runs header
7720: 6e 75 6d 6b 65 79 73 29 29 0a 20 20 20 20 20 20 numkeys)).
7730: 20 20 20 28 74 65 73 74 2d 6c 69 73 74 20 28 68 (test-list (h
7740: 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 74 ash-table-keys t
7750: 65 73 74 2d 72 75 6e 73 2d 68 61 73 68 29 29 29 est-runs-hash)))
7760: 20 0a 20 20 20 20 0a 20 20 20 20 28 73 3a 68 74 . . (s:ht
7770: 6d 6c 20 74 65 73 74 73 3a 63 73 73 2d 6a 73 63 ml tests:css-jsc
7780: 72 69 70 74 2d 62 6c 6f 63 6b 20 28 74 65 73 74 ript-block (test
7790: 73 3a 63 73 73 2d 6a 73 63 72 69 70 74 2d 62 6c s:css-jscript-bl
77a0: 6f 63 6b 2d 63 6f 6e 64 20 66 6c 61 67 29 0a 09 ock-cond flag)..
77b0: 20 20 20 20 28 73 3a 74 69 74 6c 65 20 22 53 75 (s:title "Su
77c0: 6d 6d 61 72 79 20 66 6f 72 20 22 20 61 72 65 61 mmary for " area
77d0: 2d 6e 61 6d 65 29 0a 09 20 20 20 20 28 73 3a 62 -name).. (s:b
77e0: 6f 64 79 20 27 6f 6e 6c 6f 61 64 20 22 61 64 64 ody 'onload "add
77f0: 45 76 65 6e 74 73 28 29 3b 22 0a 09 09 20 20 20 Events();"...
7800: 20 28 67 65 74 2d 70 72 65 76 2d 6c 69 6e 6b 73 (get-prev-links
7810: 20 70 61 67 65 20 6c 69 6e 6b 74 72 65 65 29 0a page linktree).
7820: 09 09 20 20 20 20 28 67 65 74 2d 6e 65 78 74 2d .. (get-next-
7830: 6c 69 6e 6b 73 20 70 61 67 65 20 6c 69 6e 6b 74 links page linkt
7840: 72 65 65 20 74 6f 74 61 6c 2d 72 75 6e 73 29 0a ree total-runs).
7850: 09 09 20 20 20 20 0a 09 09 20 20 20 20 28 73 3a .. ... (s:
7860: 68 31 20 22 53 75 6d 6d 61 72 79 20 66 6f 72 20 h1 "Summary for
7870: 22 20 61 72 65 61 2d 6e 61 6d 65 29 0a 09 09 20 " area-name)...
7880: 20 20 20 28 73 3a 68 33 20 22 46 69 6c 74 65 72 (s:h3 "Filter
7890: 22 20 29 0a 09 09 20 20 20 20 28 73 3a 69 6e 70 " )... (s:inp
78a0: 75 74 20 27 74 79 70 65 20 22 74 65 78 74 22 20 ut 'type "text"
78b0: 20 27 6e 61 6d 65 20 22 74 65 73 74 6e 61 6d 65 'name "testname
78c0: 22 20 27 69 64 20 22 74 65 73 74 6e 61 6d 65 22 " 'id "testname"
78d0: 20 27 6c 65 6e 67 74 68 20 22 33 30 22 20 27 6f 'length "30" 'o
78e0: 6e 6b 65 79 75 70 20 22 66 69 6c 74 65 72 73 6f nkeyup "filterso
78f0: 6d 65 28 29 22 29 0a 09 09 20 20 20 20 3b 3b 20 me()")... ;;
7900: 74 6f 70 20 6c 69 73 74 0a 09 09 20 20 20 20 0a top list... .
7910: 09 09 20 20 20 20 28 73 3a 74 61 62 6c 65 20 27 .. (s:table '
7920: 69 64 20 22 4c 69 6e 6b 65 64 4c 69 73 74 31 22 id "LinkedList1"
7930: 20 27 62 6f 72 64 65 72 20 22 31 22 20 27 63 65 'border "1" 'ce
7940: 6c 6c 73 70 61 63 69 6e 67 20 30 0a 09 09 09 20 llspacing 0....
7950: 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 (map (lambda
7960: 20 28 6b 65 79 29 0a 09 09 09 09 20 20 20 20 28 (key)..... (
7970: 6c 65 74 2a 20 28 28 72 65 73 20 28 73 3a 74 72 let* ((res (s:tr
7980: 20 27 63 6c 61 73 73 20 22 73 6f 6d 65 74 68 69 'class "somethi
7990: 6e 67 22 20 0a 09 09 09 09 09 09 20 20 20 20 20 ng" .......
79a0: 20 28 73 3a 74 68 20 6b 65 79 20 29 0a 09 09 09 (s:th key )....
79b0: 09 09 09 20 20 20 20 20 20 28 6d 61 70 20 28 6c ... (map (l
79c0: 61 6d 62 64 61 20 28 72 75 6e 29 0a 09 09 09 09 ambda (run).....
79d0: 09 09 09 20 20 20 20 20 28 73 3a 74 68 20 20 28 ... (s:th (
79e0: 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 20 63 vector-ref run c
79f0: 74 72 29 29 29 0a 09 09 09 09 09 09 09 20 20 20 tr)))........
7a00: 72 75 6e 73 29 29 29 29 0a 09 09 09 09 20 20 20 runs)))).....
7a10: 20 20 20 28 73 65 74 21 20 63 74 72 20 28 2b 20 (set! ctr (+
7a20: 63 74 72 20 31 29 29 0a 09 09 09 09 20 20 20 20 ctr 1)).....
7a30: 20 20 72 65 73 29 29 0a 09 09 09 09 20 20 6b 65 res))..... ke
7a40: 79 73 29 0a 09 09 09 20 20 20 20 20 28 73 3a 74 ys).... (s:t
7a50: 72 0a 09 09 09 20 20 20 20 20 20 28 73 3a 74 68 r.... (s:th
7a60: 20 22 52 75 6e 20 4e 61 6d 65 22 29 0a 09 09 09 "Run Name")....
7a70: 20 20 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 (map (lamb
7a80: 64 61 20 28 72 75 6e 29 0a 09 09 09 09 20 20 20 da (run).....
7a90: 20 20 28 73 3a 74 68 20 28 64 62 3a 67 65 74 2d (s:th (db:get-
7aa0: 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 value-by-header
7ab0: 72 75 6e 20 68 65 61 64 65 72 20 22 72 75 6e 6e run header "runn
7ac0: 61 6d 65 22 29 29 29 0a 09 09 09 09 20 20 20 72 ame")))..... r
7ad0: 75 6e 73 29 29 0a 09 09 09 20 20 20 20 20 0a 09 uns)).... ..
7ae0: 09 09 20 20 20 20 20 28 6d 61 70 20 28 6c 61 6d .. (map (lam
7af0: 62 64 61 20 28 74 65 73 74 2d 6e 61 6d 65 29 0a bda (test-name).
7b00: 09 09 09 09 20 20 20 20 28 6c 65 74 2a 20 28 28 .... (let* ((
7b10: 69 74 65 6d 2d 68 61 73 68 20 28 68 61 73 68 2d item-hash (hash-
7b20: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
7b30: 74 20 74 65 73 74 2d 72 75 6e 73 2d 68 61 73 68 t test-runs-hash
7b40: 20 74 65 73 74 2d 6e 61 6d 65 20 20 23 66 29 29 test-name #f))
7b50: 0a 09 09 09 09 09 20 20 20 28 69 74 65 6d 2d 6b ...... (item-k
7b60: 65 79 73 20 28 73 6f 72 74 20 28 68 61 73 68 2d eys (sort (hash-
7b70: 74 61 62 6c 65 2d 6b 65 79 73 20 69 74 65 6d 2d table-keys item-
7b80: 68 61 73 68 29 20 73 74 72 69 6e 67 3c 3d 3f 29 hash) string<=?)
7b90: 29 29 20 0a 09 09 09 09 20 20 20 20 20 20 28 6d )) ..... (m
7ba0: 61 70 20 28 6c 61 6d 62 64 61 20 28 69 74 65 6d ap (lambda (item
7bb0: 2d 6e 61 6d 65 29 20 20 0a 20 20 09 09 20 20 20 -name) . ..
7bc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7bd0: 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 (let*
7be0: 28 28 72 65 73 20 28 73 3a 74 72 20 20 27 63 6c ((res (s:tr 'cl
7bf0: 61 73 73 20 69 74 65 6d 2d 6e 61 6d 65 0a 09 09 ass item-name...
7c00: 09 09 09 09 09 09 28 73 3a 74 64 20 20 69 74 65 ......(s:td ite
7c10: 6d 2d 6e 61 6d 65 20 27 63 6c 61 73 73 20 22 74 m-name 'class "t
7c20: 65 73 74 22 20 29 0a 09 09 09 09 09 09 09 09 28 est" ).........(
7c30: 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 72 75 6e map (lambda (run
7c40: 29 0a 09 09 09 09 09 09 09 09 20 20 20 20 20 20 ).........
7c50: 20 28 6c 65 74 2a 20 28 28 72 75 6e 2d 74 65 73 (let* ((run-tes
7c60: 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 t (hash-table-re
7c70: 66 2f 64 65 66 61 75 6c 74 20 69 74 65 6d 2d 68 f/default item-h
7c80: 61 73 68 20 69 74 65 6d 2d 6e 61 6d 65 20 20 23 ash item-name #
7c90: 66 29 29 0a 09 09 09 09 09 09 09 09 09 20 20 20 f))..........
7ca0: 20 20 20 28 72 75 6e 2d 69 64 20 28 64 62 3a 67 (run-id (db:g
7cb0: 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 et-value-by-head
7cc0: 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 69 er run header "i
7cd0: 64 22 29 29 0a 09 09 09 09 09 09 09 09 09 20 20 d"))..........
7ce0: 20 20 20 20 28 72 65 73 75 6c 74 20 28 68 61 73 (result (has
7cf0: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
7d00: 75 6c 74 20 72 75 6e 2d 74 65 73 74 20 72 75 6e ult run-test run
7d10: 2d 69 64 20 22 6e 2f 61 22 29 29 0a 09 09 09 09 -id "n/a")).....
7d20: 09 3b 28 72 65 6c 61 74 69 76 65 2d 70 61 74 68 .;(relative-path
7d30: 20 28 67 65 74 2d 72 65 6c 61 74 69 76 65 2d 70 (get-relative-p
7d40: 61 74 68 29 29 20 0a 09 09 09 09 09 09 09 09 09 ath)) ..........
7d50: 20 20 20 20 20 20 28 73 74 61 74 75 73 20 28 69 (status (i
7d60: 66 20 28 73 74 72 69 6e 67 3f 20 72 65 73 75 6c f (string? resul
7d70: 74 29 0a 09 09 09 09 09 09 09 09 09 09 09 20 20 t)............
7d80: 72 65 73 75 6c 74 0a 09 09 09 09 09 09 09 09 09 result..........
7d90: 09 09 20 20 28 63 61 72 20 72 65 73 75 6c 74 29 .. (car result)
7da0: 29 29 0a 09 09 09 09 09 09 09 09 09 20 20 20 20 ))..........
7db0: 20 20 28 6c 69 6e 6b 20 28 69 66 20 28 73 74 72 (link (if (str
7dc0: 69 6e 67 3f 20 72 65 73 75 6c 74 29 0a 09 09 09 ing? result)....
7dd0: 09 09 09 09 09 09 09 09 72 65 73 75 6c 74 0a 09 ........result..
7de0: 09 09 09 09 09 09 09 09 09 09 28 69 66 20 28 65 ..........(if (e
7df0: 71 75 61 6c 3f 20 66 6c 61 67 20 23 74 29 20 0a qual? flag #t) .
7e00: 09 09 09 09 09 09 09 09 09 09 09 20 20 20 20 28 ........... (
7e10: 73 3a 61 20 28 63 61 72 20 72 65 73 75 6c 74 29 s:a (car result)
7e20: 20 27 68 72 65 66 20 28 63 6f 6e 63 20 22 2e 2f 'href (conc "./
7e30: 74 65 73 74 5f 6c 6f 67 3f 72 75 6e 69 64 3d 22 test_log?runid="
7e40: 20 72 75 6e 2d 69 64 20 22 26 74 65 73 74 6e 61 run-id "&testna
7e50: 6d 65 3d 22 20 20 69 74 65 6d 2d 6e 61 6d 65 20 me=" item-name
7e60: 29 29 0a 09 09 09 09 09 09 09 09 09 09 09 20 20 ))............
7e70: 20 20 28 73 3a 61 20 28 63 61 72 20 72 65 73 75 (s:a (car resu
7e80: 6c 74 29 20 27 68 72 65 66 20 28 73 74 72 69 6e lt) 'href (strin
7e90: 67 2d 73 75 62 73 74 69 74 75 74 65 20 20 28 63 g-substitute (c
7ea0: 6f 6e 63 20 6c 69 6e 6b 74 72 65 65 20 22 2f 22 onc linktree "/"
7eb0: 29 20 20 22 22 20 28 63 61 64 72 20 72 65 73 75 ) "" (cadr resu
7ec0: 6c 74 29 20 20 22 2d 22 29 29 29 29 29 29 0a 09 lt) "-"))))))..
7ed0: 09 09 09 09 09 09 09 09 20 28 73 3a 74 64 20 20 ........ (s:td
7ee0: 6c 69 6e 6b 20 27 63 6c 61 73 73 20 73 74 61 74 link 'class stat
7ef0: 75 73 29 29 29 0a 09 09 09 09 09 09 09 09 20 20 us))).........
7f00: 20 20 20 72 75 6e 73 29 29 29 29 0a 09 09 09 09 runs)))).....
7f10: 09 20 20 20 20 20 20 20 72 65 73 29 29 0a 09 09 . res))...
7f20: 09 09 09 20 20 20 69 74 65 6d 2d 6b 65 79 73 29 ... item-keys)
7f30: 29 29 0a 09 09 09 09 20 20 74 65 73 74 2d 6c 69 ))..... test-li
7f40: 73 74 29 29 29 29 29 29 20 0a 0a 3b 3b 20 28 74 st)))))) ..;; (t
7f50: 65 73 74 73 3a 63 72 65 61 74 65 2d 68 74 6d 6c ests:create-html
7f60: 2d 74 72 65 65 20 22 74 65 73 74 2d 69 6e 64 65 -tree "test-inde
7f70: 78 2e 68 74 6d 6c 22 29 0a 3b 3b 0a 28 64 65 66 x.html").;;.(def
7f80: 69 6e 65 20 28 74 65 73 74 73 3a 63 72 65 61 74 ine (tests:creat
7f90: 65 2d 68 74 6d 6c 2d 74 72 65 65 20 6f 75 74 66 e-html-tree outf
7fa0: 29 0a 20 20 28 6c 65 74 2a 20 28 28 6c 6f 63 6b ). (let* ((lock
7fb0: 66 69 6c 65 20 20 28 63 6f 6e 63 20 6f 75 74 66 file (conc outf
7fc0: 20 22 2e 6c 6f 63 6b 22 29 29 0a 09 20 28 72 75 ".lock")).. (ru
7fd0: 6e 73 2d 74 6f 2d 70 72 6f 63 65 73 73 20 27 28 ns-to-process '(
7fe0: 29 29 0a 20 20 20 20 20 20 20 20 20 28 6c 69 6e )). (lin
7ff0: 6b 74 72 65 65 20 20 28 63 6f 6d 6d 6f 6e 3a 67 ktree (common:g
8000: 65 74 2d 6c 69 6e 6b 74 72 65 65 29 29 0a 20 20 et-linktree)).
8010: 20 20 20 20 20 20 20 28 61 72 65 61 2d 6e 61 6d (area-nam
8020: 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 61 72 e (common:get-ar
8030: 65 61 2d 6e 61 6d 65 29 29 0a 09 20 28 6b 65 79 ea-name)).. (key
8040: 73 20 20 20 20 20 20 28 72 6d 74 3a 67 65 74 2d s (rmt:get-
8050: 6b 65 79 73 29 29 0a 09 20 28 6e 75 6d 6b 65 79 keys)).. (numkey
8060: 73 20 20 20 28 6c 65 6e 67 74 68 20 6b 65 79 73 s (length keys
8070: 29 29 0a 20 20 20 20 20 20 20 20 20 28 72 75 6e )). (run
8080: 2d 70 61 74 74 20 28 6f 72 20 28 61 72 67 73 3a -patt (or (args:
8090: 67 65 74 2d 61 72 67 20 22 2d 72 75 6e 2d 70 61 get-arg "-run-pa
80a0: 74 74 22 29 0a 09 09 20 20 20 20 20 20 20 28 61 tt")... (a
80b0: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 75 rgs:get-arg "-ru
80c0: 6e 6e 61 6d 65 22 29 0a 09 09 20 20 20 20 20 20 nname")...
80d0: 20 22 25 22 29 29 0a 20 20 20 20 20 20 20 20 20 "%")).
80e0: 28 74 61 72 67 65 74 20 28 6f 72 20 20 28 61 72 (target (or (ar
80f0: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 72 gs:get-arg "-tar
8100: 67 65 74 2d 70 61 74 74 22 29 20 0a 09 09 20 20 get-patt") ...
8110: 20 20 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (args:get-ar
8120: 67 20 22 2d 74 61 72 67 65 74 22 29 0a 20 20 20 g "-target").
8130: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8140: 20 20 20 22 25 22 29 29 0a 20 20 20 20 20 20 20 "%")).
8150: 20 20 28 74 61 72 67 6c 69 73 74 20 28 73 74 72 (targlist (str
8160: 69 6e 67 2d 73 70 6c 69 74 20 74 61 72 67 65 74 ing-split target
8170: 20 22 2f 22 29 29 0a 20 20 20 20 20 20 20 20 20 "/")).
8180: 28 6e 75 6d 74 61 72 67 20 20 28 6c 65 6e 67 74 (numtarg (lengt
8190: 68 20 74 61 72 67 6c 69 73 74 29 29 20 20 0a 20 h targlist)) .
81a0: 20 20 20 20 20 20 20 20 28 74 61 72 67 74 77 65 (targtwe
81b0: 61 6b 65 64 20 28 69 66 20 28 3e 20 6e 75 6d 6b aked (if (> numk
81c0: 65 79 73 20 6e 75 6d 74 61 72 67 29 0a 09 09 09 eys numtarg)....
81d0: 20 20 28 61 70 70 65 6e 64 20 74 61 72 67 6c 69 (append targli
81e0: 73 74 20 28 6d 61 6b 65 2d 6c 69 73 74 20 28 2d st (make-list (-
81f0: 20 6e 75 6d 6b 65 79 73 20 6e 75 6d 74 61 72 67 numkeys numtarg
8200: 29 20 22 25 22 29 29 0a 09 09 09 20 20 74 61 72 ) "%")).... tar
8210: 67 6c 69 73 74 29 29 0a 20 20 20 20 20 20 20 20 glist)).
8220: 20 28 74 61 72 67 65 74 2d 70 61 74 74 20 28 73 (target-patt (s
8230: 74 72 69 6e 67 2d 6a 6f 69 6e 20 74 61 72 67 74 tring-join targt
8240: 77 65 61 6b 65 64 20 22 2f 22 29 29 0a 09 09 09 weaked "/"))....
8250: 09 09 3b 28 74 6f 74 61 6c 2d 72 75 6e 73 20 20 ..;(total-runs
8260: 28 72 6d 74 3a 67 65 74 2d 6e 75 6d 2d 72 75 6e (rmt:get-num-run
8270: 73 20 22 25 22 29 29 20 3b 3b 74 68 69 73 20 6e s "%")) ;;this n
8280: 65 65 64 73 20 74 6f 20 62 65 20 63 68 61 6e 67 eeds to be chang
8290: 65 64 20 74 6f 20 66 69 6c 74 65 72 20 62 79 20 ed to filter by
82a0: 74 61 72 67 65 74 0a 09 20 28 74 6f 74 61 6c 2d target.. (total-
82b0: 72 75 6e 73 20 28 72 6d 74 3a 67 65 74 2d 72 75 runs (rmt:get-ru
82c0: 6e 73 2d 63 6e 74 2d 62 79 2d 70 61 74 74 20 72 ns-cnt-by-patt r
82d0: 75 6e 2d 70 61 74 74 20 74 61 72 67 65 74 2d 70 un-patt target-p
82e0: 61 74 74 20 6b 65 79 73 20 29 29 20 0a 20 20 20 att keys )) .
82f0: 20 20 20 20 20 20 28 70 67 2d 73 69 7a 65 20 31 (pg-size 1
8300: 30 29 29 0a 20 20 20 20 28 69 66 20 28 63 6f 6d 0)). (if (com
8310: 6d 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d mon:simple-file-
8320: 6c 6f 63 6b 20 6c 6f 63 6b 66 69 6c 65 29 0a 20 lock lockfile).
8330: 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 (begin...
8340: 09 09 09 3b 28 70 72 69 6e 74 20 74 6f 74 61 6c ...;(print total
8350: 2d 72 75 6e 73 29 20 20 20 20 0a 09 20 20 28 6c -runs) .. (l
8360: 65 74 20 6c 6f 6f 70 20 28 28 70 61 67 65 20 30 et loop ((page 0
8370: 29 29 0a 09 20 20 20 20 28 6c 65 74 2a 20 28 28 )).. (let* ((
8380: 6f 75 70 20 20 20 20 20 20 20 20 20 20 20 20 28 oup (
8390: 6f 70 65 6e 2d 6f 75 74 70 75 74 2d 66 69 6c 65 open-output-file
83a0: 20 28 6f 72 20 6f 75 74 66 20 28 63 6f 6e 63 20 (or outf (conc
83b0: 6c 69 6e 6b 74 72 65 65 20 22 2f 70 61 67 65 22 linktree "/page"
83c0: 20 70 61 67 65 20 22 2e 68 74 6d 6c 22 29 29 29 page ".html")))
83d0: 29 0a 09 09 20 20 20 28 67 65 74 2d 70 72 65 76 )... (get-prev
83e0: 2d 6c 69 6e 6b 73 20 28 6c 61 6d 62 64 61 20 28 -links (lambda (
83f0: 70 61 67 65 20 6c 69 6e 6b 74 72 65 65 20 29 20 page linktree )
8400: 20 20 0a 09 09 09 09 20 20 20 20 20 28 6c 65 74 ..... (let
8410: 2a 20 28 28 6c 69 6e 6b 20 20 28 69 66 20 28 6e * ((link (if (n
8420: 6f 74 20 28 65 71 3f 20 70 61 67 65 20 30 29 29 ot (eq? page 0))
8430: 0a 09 09 09 09 09 09 20 20 20 20 20 20 20 28 73 ....... (s
8440: 3a 61 20 22 26 6c 74 3b 26 6c 74 3b 70 72 65 76 :a "<<prev
8450: 22 20 27 68 72 65 66 20 28 63 6f 6e 63 20 20 22 " 'href (conc "
8460: 70 61 67 65 22 20 28 2d 20 70 61 67 65 20 31 29 page" (- page 1)
8470: 20 22 2e 68 74 6d 6c 22 29 29 0a 09 09 09 09 09 ".html"))......
8480: 09 20 20 20 20 20 20 20 28 73 3a 61 20 22 22 20 . (s:a ""
8490: 27 68 72 65 66 20 28 63 6f 6e 63 20 20 20 22 70 'href (conc "p
84a0: 61 67 65 22 20 20 70 61 67 65 20 22 2e 68 74 6d age" page ".htm
84b0: 6c 22 29 29 29 29 29 0a 09 09 09 09 20 20 20 20 l"))))).....
84c0: 20 20 20 6c 69 6e 6b 29 29 29 0a 09 09 20 20 20 link)))...
84d0: 28 67 65 74 2d 6e 65 78 74 2d 6c 69 6e 6b 73 20 (get-next-links
84e0: 28 6c 61 6d 62 64 61 20 28 70 61 67 65 20 6c 69 (lambda (page li
84f0: 6e 6b 74 72 65 65 20 74 6f 74 61 6c 2d 72 75 6e nktree total-run
8500: 73 29 20 20 20 0a 09 09 09 09 20 20 20 20 20 28 s) ..... (
8510: 6c 65 74 2a 20 28 28 6c 69 6e 6b 20 20 28 69 66 let* ((link (if
8520: 20 28 3e 20 74 6f 74 61 6c 2d 72 75 6e 73 20 28 (> total-runs (
8530: 2b 20 31 30 20 28 2a 20 70 61 67 65 20 70 67 2d + 10 (* page pg-
8540: 73 69 7a 65 29 29 29 0a 09 09 09 09 09 09 20 20 size))).......
8550: 20 20 20 20 20 28 73 3a 61 20 22 6e 65 78 74 26 (s:a "next&
8560: 67 74 3b 26 67 74 3b 22 20 27 68 72 65 66 20 28 gt;>" 'href (
8570: 63 6f 6e 63 20 20 22 70 61 67 65 22 20 20 28 2b conc "page" (+
8580: 20 70 61 67 65 20 31 29 20 22 2e 68 74 6d 6c 22 page 1) ".html"
8590: 29 29 0a 09 09 09 09 09 09 20 20 20 20 20 20 20 )).......
85a0: 28 73 3a 61 20 22 22 20 27 68 72 65 66 20 28 63 (s:a "" 'href (c
85b0: 6f 6e 63 20 20 20 22 70 61 67 65 22 20 70 61 67 onc "page" pag
85c0: 65 20 20 22 2e 68 74 6d 6c 22 29 29 29 29 29 0a e ".html"))))).
85d0: 09 09 09 09 20 20 20 20 20 20 20 6c 69 6e 6b 29 .... link)
85e0: 29 29 20 29 0a 09 20 20 20 20 20 20 28 70 72 69 )) ).. (pri
85f0: 6e 74 20 22 74 6f 74 61 6c 20 72 75 6e 73 3a 20 nt "total runs:
8600: 22 20 74 6f 74 61 6c 2d 72 75 6e 73 29 20 0a 09 " total-runs) ..
8610: 20 20 20 20 20 20 28 73 3a 6f 75 74 70 75 74 2d (s:output-
8620: 6e 65 77 0a 09 20 20 20 20 20 20 20 6f 75 70 0a new.. oup.
8630: 09 20 20 20 20 20 20 20 28 74 65 73 74 73 3a 64 . (tests:d
8640: 61 73 68 62 6f 61 72 64 2d 62 6f 64 79 20 70 61 ashboard-body pa
8650: 67 65 20 70 67 2d 73 69 7a 65 20 6b 65 79 73 20 ge pg-size keys
8660: 6e 75 6d 6b 65 79 73 20 74 6f 74 61 6c 2d 72 75 numkeys total-ru
8670: 6e 73 20 6c 69 6e 6b 74 72 65 65 20 61 72 65 61 ns linktree area
8680: 2d 6e 61 6d 65 20 67 65 74 2d 70 72 65 76 2d 6c -name get-prev-l
8690: 69 6e 6b 73 20 67 65 74 2d 6e 65 78 74 2d 6c 69 inks get-next-li
86a0: 6e 6b 73 20 23 66 20 72 75 6e 2d 70 61 74 74 20 nks #f run-patt
86b0: 74 61 72 67 65 74 2d 70 61 74 74 29 29 20 3b 3b target-patt)) ;;
86c0: 20 75 70 64 61 74 65 20 74 68 69 73 20 66 75 6e update this fun
86d0: 63 74 69 6f 6e 0a 09 20 20 20 20 20 20 28 63 6c ction.. (cl
86e0: 6f 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 ose-output-port
86f0: 6f 75 70 29 0a 09 09 09 09 09 3b 20 28 73 65 74 oup)......; (set
8700: 21 20 70 61 67 65 20 28 2b 20 31 20 70 61 67 65 ! page (+ 1 page
8710: 29 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 3e )).. (if (>
8720: 20 74 6f 74 61 6c 2d 72 75 6e 73 20 28 2a 20 28 total-runs (* (
8730: 2b 20 31 20 70 61 67 65 29 20 70 67 2d 73 69 7a + 1 page) pg-siz
8740: 65 29 29 0a 09 09 20 20 28 6c 6f 6f 70 20 28 2b e))... (loop (+
8750: 20 31 20 20 70 61 67 65 29 29 29 29 29 0a 09 20 1 page)))))..
8760: 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 2d (common:simple-
8770: 66 69 6c 65 2d 72 65 6c 65 61 73 65 2d 6c 6f 63 file-release-loc
8780: 6b 20 6c 6f 63 6b 66 69 6c 65 29 29 0a 09 28 62 k lockfile))..(b
8790: 65 67 69 6e 0a 09 20 20 28 64 65 62 75 67 3a 70 egin.. (debug:p
87a0: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
87b0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 46 61 69 6c 65 log-port* "Faile
87c0: 64 20 74 6f 20 67 65 74 20 6c 6f 63 6b 20 6f 6e d to get lock on
87d0: 20 66 69 6c 65 20 6f 75 74 66 2c 20 6c 6f 63 6b file outf, lock
87e0: 66 69 6c 65 3a 20 22 20 6c 6f 63 6b 66 69 6c 65 file: " lockfile
87f0: 29 20 23 66 29 29 29 29 0a 0a 0a 3b 3b 20 43 48 ) #f))))...;; CH
8800: 45 43 4b 20 2d 20 57 41 53 20 54 48 49 53 20 41 ECK - WAS THIS A
8810: 44 44 45 44 20 4f 52 20 52 45 4d 4f 56 45 44 3f DDED OR REMOVED?
8820: 20 4d 41 4e 55 41 4c 20 4d 45 52 47 45 20 57 49 MANUAL MERGE WI
8830: 54 48 20 41 50 49 20 53 54 55 46 46 21 21 21 0a TH API STUFF!!!.
8840: 3b 3b 0a 3b 3b 20 67 65 74 20 61 20 70 72 65 74 ;;.;; get a pret
8850: 74 79 20 74 61 62 6c 65 20 74 6f 20 73 75 6d 6d ty table to summ
8860: 61 72 69 7a 65 20 73 74 65 70 73 0a 3b 3b 0a 3b arize steps.;;.;
8870: 3b 20 28 64 65 66 69 6e 65 20 28 64 63 6f 6d 6d ; (define (dcomm
8880: 6f 6e 3a 70 72 6f 63 65 73 73 2d 73 74 65 70 73 on:process-steps
8890: 2d 74 61 62 6c 65 20 73 74 65 70 73 29 3b 3b 20 -table steps);;
88a0: 64 62 20 74 65 73 74 2d 69 64 20 23 21 6b 65 79 db test-id #!key
88b0: 20 28 77 6f 72 6b 2d 61 72 65 61 20 23 66 29 29 (work-area #f))
88c0: 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a .(define (tests:
88d0: 70 72 6f 63 65 73 73 2d 73 74 65 70 73 2d 74 61 process-steps-ta
88e0: 62 6c 65 20 73 74 65 70 73 29 3b 3b 20 64 62 20 ble steps);; db
88f0: 74 65 73 74 2d 69 64 20 23 21 6b 65 79 20 28 77 test-id #!key (w
8900: 6f 72 6b 2d 61 72 65 61 20 23 66 29 29 0a 3b 3b ork-area #f)).;;
8910: 20 20 28 6c 65 74 20 28 28 73 74 65 70 73 20 20 (let ((steps
8920: 20 28 64 62 3a 67 65 74 2d 73 74 65 70 73 2d 66 (db:get-steps-f
8930: 6f 72 2d 74 65 73 74 20 64 62 20 74 65 73 74 2d or-test db test-
8940: 69 64 20 77 6f 72 6b 2d 61 72 65 61 3a 20 77 6f id work-area: wo
8950: 72 6b 2d 61 72 65 61 29 29 29 0a 20 20 20 20 3b rk-area))). ;
8960: 3b 20 6f 72 67 61 6e 69 73 65 20 74 68 65 20 73 ; organise the s
8970: 74 65 70 73 20 66 6f 72 20 62 65 74 74 65 72 20 teps for better
8980: 72 65 61 64 61 62 69 6c 69 74 79 0a 20 20 20 20 readability.
8990: 28 6c 65 74 20 28 28 72 65 73 20 28 6d 61 6b 65 (let ((res (make
89a0: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 0a 20 -hash-table))).
89b0: 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a (for-each .
89c0: 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 (lambda (
89d0: 73 74 65 70 29 0a 09 20 28 64 65 62 75 67 3a 70 step).. (debug:p
89e0: 72 69 6e 74 20 36 20 2a 64 65 66 61 75 6c 74 2d rint 6 *default-
89f0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 74 65 70 3d log-port* "step=
8a00: 22 20 73 74 65 70 29 0a 09 20 28 6c 65 74 20 28 " step).. (let (
8a10: 28 72 65 63 6f 72 64 20 28 68 61 73 68 2d 74 61 (record (hash-ta
8a20: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
8a30: 0a 09 09 09 72 65 73 20 0a 09 09 09 28 74 64 62 ....res ....(tdb
8a40: 3a 73 74 65 70 2d 67 65 74 2d 73 74 65 70 6e 61 :step-get-stepna
8a50: 6d 65 20 73 74 65 70 29 0a 09 09 09 3b 3b 20 20 me step)....;;
8a60: 20 20 20 20 20 20 20 20 20 30 20 20 20 20 20 20 0
8a70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8a80: 31 20 20 20 20 32 20 20 20 20 33 20 20 20 20 20 1 2 3
8a90: 20 20 34 20 20 20 20 20 20 20 20 20 35 20 20 20 4 5
8aa0: 20 20 20 20 36 20 20 20 20 20 20 20 37 0a 09 09 6 7...
8ab0: 09 3b 3b 20 20 20 20 20 20 20 20 73 74 65 70 6e .;; stepn
8ac0: 61 6d 65 20 20 20 20 20 20 20 20 20 20 20 20 20 ame
8ad0: 20 20 20 73 74 61 72 74 20 65 6e 64 20 73 74 61 start end sta
8ae0: 74 75 73 20 44 75 72 61 74 69 6f 6e 20 20 4c 6f tus Duration Lo
8af0: 67 66 69 6c 65 20 43 6f 6d 6d 65 6e 74 20 20 66 gfile Comment f
8b00: 69 72 73 74 2d 69 64 0a 09 09 09 28 76 65 63 74 irst-id....(vect
8b10: 6f 72 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 or (tdb:step-get
8b20: 2d 73 74 65 70 6e 61 6d 65 20 73 74 65 70 29 20 -stepname step)
8b30: 22 22 20 20 20 22 22 20 22 22 20 20 20 20 20 22 "" "" "" "
8b40: 22 20 20 20 20 20 20 20 20 22 22 20 20 20 20 20 " ""
8b50: 22 22 20 20 20 20 20 20 20 23 66 29 29 29 29 0a "" #f)))).
8b60: 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 . (debug:print
8b70: 20 36 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 6 *default-log-
8b80: 70 6f 72 74 2a 20 22 72 65 63 6f 72 64 28 62 65 port* "record(be
8b90: 66 6f 72 65 29 20 3d 20 22 20 72 65 63 6f 72 64 fore) = " record
8ba0: 20 0a 09 09 09 22 5c 6e 69 64 3a 20 20 20 20 20 ...."\nid:
8bb0: 20 20 22 20 28 74 64 62 3a 73 74 65 70 2d 67 65 " (tdb:step-ge
8bc0: 74 2d 69 64 20 73 74 65 70 29 0a 09 09 09 22 5c t-id step)...."\
8bd0: 6e 73 74 65 70 6e 61 6d 65 3a 20 22 20 28 74 64 nstepname: " (td
8be0: 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 65 70 6e b:step-get-stepn
8bf0: 61 6d 65 20 73 74 65 70 29 0a 09 09 09 22 5c 6e ame step)...."\n
8c00: 73 74 61 74 65 3a 20 20 20 20 22 20 28 74 64 62 state: " (tdb
8c10: 3a 73 74 65 70 2d 67 65 74 2d 73 74 61 74 65 20 :step-get-state
8c20: 73 74 65 70 29 0a 09 09 09 22 5c 6e 73 74 61 74 step)...."\nstat
8c30: 75 73 3a 20 20 20 22 20 28 74 64 62 3a 73 74 65 us: " (tdb:ste
8c40: 70 2d 67 65 74 2d 73 74 61 74 75 73 20 73 74 65 p-get-status ste
8c50: 70 29 0a 09 09 09 22 5c 6e 74 69 6d 65 3a 20 20 p)...."\ntime:
8c60: 20 20 20 22 20 28 74 64 62 3a 73 74 65 70 2d 67 " (tdb:step-g
8c70: 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 73 74 et-event_time st
8c80: 65 70 29 29 0a 09 20 20 20 28 69 66 20 28 6e 6f ep)).. (if (no
8c90: 74 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 65 t (vector-ref re
8ca0: 63 6f 72 64 20 37 29 29 28 76 65 63 74 6f 72 2d cord 7))(vector-
8cb0: 73 65 74 21 20 72 65 63 6f 72 64 20 37 20 28 74 set! record 7 (t
8cc0: 64 62 3a 73 74 65 70 2d 67 65 74 2d 69 64 20 73 db:step-get-id s
8cd0: 74 65 70 29 29 29 20 3b 3b 20 64 6f 20 6e 6f 74 tep))) ;; do not
8ce0: 20 63 6c 6f 62 62 65 72 20 74 68 65 20 69 64 20 clobber the id
8cf0: 69 66 20 70 72 65 76 69 6f 75 73 6c 79 20 73 65 if previously se
8d00: 74 0a 09 20 20 20 28 63 61 73 65 20 28 73 74 72 t.. (case (str
8d10: 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 74 64 62 ing->symbol (tdb
8d20: 3a 73 74 65 70 2d 67 65 74 2d 73 74 61 74 65 20 :step-get-state
8d30: 73 74 65 70 29 29 0a 09 20 20 20 20 20 28 28 73 step)).. ((s
8d40: 74 61 72 74 29 28 76 65 63 74 6f 72 2d 73 65 74 tart)(vector-set
8d50: 21 20 72 65 63 6f 72 64 20 31 20 28 74 64 62 3a ! record 1 (tdb:
8d60: 73 74 65 70 2d 67 65 74 2d 65 76 65 6e 74 5f 74 step-get-event_t
8d70: 69 6d 65 20 73 74 65 70 29 29 0a 09 20 20 20 20 ime step))..
8d80: 20 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 72 (vector-set! r
8d90: 65 63 6f 72 64 20 33 20 28 69 66 20 28 65 71 75 ecord 3 (if (equ
8da0: 61 6c 3f 20 28 76 65 63 74 6f 72 2d 72 65 66 20 al? (vector-ref
8db0: 72 65 63 6f 72 64 20 33 29 20 22 22 29 0a 09 09 record 3) "")...
8dc0: 09 09 09 28 74 64 62 3a 73 74 65 70 2d 67 65 74 ...(tdb:step-get
8dd0: 2d 73 74 61 74 75 73 20 73 74 65 70 29 29 29 0a -status step))).
8de0: 09 20 20 20 20 20 20 28 69 66 20 28 3e 20 28 73 . (if (> (s
8df0: 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 28 74 64 tring-length (td
8e00: 62 3a 73 74 65 70 2d 67 65 74 2d 6c 6f 67 66 69 b:step-get-logfi
8e10: 6c 65 20 73 74 65 70 29 29 0a 09 09 20 20 20 20 le step))...
8e20: 20 30 29 0a 09 09 20 20 28 76 65 63 74 6f 72 2d 0)... (vector-
8e30: 73 65 74 21 20 72 65 63 6f 72 64 20 35 20 28 74 set! record 5 (t
8e40: 64 62 3a 73 74 65 70 2d 67 65 74 2d 6c 6f 67 66 db:step-get-logf
8e50: 69 6c 65 20 73 74 65 70 29 29 29 29 0a 09 20 20 ile step))))..
8e60: 20 20 20 28 28 65 6e 64 29 20 20 0a 09 20 20 20 ((end) ..
8e70: 20 20 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 (vector-set!
8e80: 72 65 63 6f 72 64 20 32 20 28 61 6e 79 2d 3e 6e record 2 (any->n
8e90: 75 6d 62 65 72 20 28 74 64 62 3a 73 74 65 70 2d umber (tdb:step-
8ea0: 67 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 73 get-event_time s
8eb0: 74 65 70 29 29 29 0a 09 20 20 20 20 20 20 28 76 tep))).. (v
8ec0: 65 63 74 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 ector-set! recor
8ed0: 64 20 33 20 28 74 64 62 3a 73 74 65 70 2d 67 65 d 3 (tdb:step-ge
8ee0: 74 2d 73 74 61 74 75 73 20 73 74 65 70 29 29 0a t-status step)).
8ef0: 09 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 73 . (vector-s
8f00: 65 74 21 20 72 65 63 6f 72 64 20 34 20 28 6c 65 et! record 4 (le
8f10: 74 20 28 28 73 74 61 72 74 74 20 28 61 6e 79 2d t ((startt (any-
8f20: 3e 6e 75 6d 62 65 72 20 28 76 65 63 74 6f 72 2d >number (vector-
8f30: 72 65 66 20 72 65 63 6f 72 64 20 31 29 29 29 0a ref record 1))).
8f40: 09 09 09 09 09 20 20 28 65 6e 64 74 20 20 20 28 ..... (endt (
8f50: 61 6e 79 2d 3e 6e 75 6d 62 65 72 20 28 76 65 63 any->number (vec
8f60: 74 6f 72 2d 72 65 66 20 72 65 63 6f 72 64 20 32 tor-ref record 2
8f70: 29 29 29 29 0a 09 09 09 09 20 20 20 20 20 20 28 ))))..... (
8f80: 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 2a 64 debug:print 4 *d
8f90: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
8fa0: 20 22 72 65 63 6f 72 64 5b 31 5d 3d 22 20 28 76 "record[1]=" (v
8fb0: 65 63 74 6f 72 2d 72 65 66 20 72 65 63 6f 72 64 ector-ref record
8fc0: 20 31 29 20 0a 09 09 09 09 09 09 20 20 20 22 2c 1) ....... ",
8fd0: 20 73 74 61 72 74 74 3d 22 20 73 74 61 72 74 74 startt=" startt
8fe0: 20 22 2c 20 65 6e 64 74 3d 22 20 65 6e 64 74 0a ", endt=" endt.
8ff0: 09 09 09 09 09 09 20 20 20 22 2c 20 67 65 74 2d ...... ", get-
9000: 73 74 61 74 75 73 3a 20 22 20 28 74 64 62 3a 73 status: " (tdb:s
9010: 74 65 70 2d 67 65 74 2d 73 74 61 74 75 73 20 73 tep-get-status s
9020: 74 65 70 29 29 0a 09 09 09 09 20 20 20 20 20 20 tep)).....
9030: 28 69 66 20 28 61 6e 64 20 28 6e 75 6d 62 65 72 (if (and (number
9040: 3f 20 73 74 61 72 74 74 29 28 6e 75 6d 62 65 72 ? startt)(number
9050: 3f 20 65 6e 64 74 29 29 0a 09 09 09 09 09 20 20 ? endt))......
9060: 28 73 65 63 6f 6e 64 73 2d 3e 68 72 2d 6d 69 6e (seconds->hr-min
9070: 2d 73 65 63 20 28 2d 20 65 6e 64 74 20 73 74 61 -sec (- endt sta
9080: 72 74 74 29 29 20 22 2d 31 22 29 29 29 0a 09 20 rtt)) "-1")))..
9090: 20 20 20 20 20 28 69 66 20 28 3e 20 28 73 74 72 (if (> (str
90a0: 69 6e 67 2d 6c 65 6e 67 74 68 20 28 74 64 62 3a ing-length (tdb:
90b0: 73 74 65 70 2d 67 65 74 2d 6c 6f 67 66 69 6c 65 step-get-logfile
90c0: 20 73 74 65 70 29 29 0a 09 09 20 20 20 20 20 30 step))... 0
90d0: 29 0a 09 09 20 20 28 76 65 63 74 6f 72 2d 73 65 )... (vector-se
90e0: 74 21 20 72 65 63 6f 72 64 20 35 20 28 74 64 62 t! record 5 (tdb
90f0: 3a 73 74 65 70 2d 67 65 74 2d 6c 6f 67 66 69 6c :step-get-logfil
9100: 65 20 73 74 65 70 29 29 29 0a 09 20 20 20 20 20 e step)))..
9110: 20 28 69 66 20 28 3e 20 28 73 74 72 69 6e 67 2d (if (> (string-
9120: 6c 65 6e 67 74 68 20 28 74 64 62 3a 73 74 65 70 length (tdb:step
9130: 2d 67 65 74 2d 63 6f 6d 6d 65 6e 74 20 73 74 65 -get-comment ste
9140: 70 29 29 0a 09 09 20 20 20 20 20 30 29 0a 09 09 p))... 0)...
9150: 20 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 72 (vector-set! r
9160: 65 63 6f 72 64 20 36 20 28 74 64 62 3a 73 74 65 ecord 6 (tdb:ste
9170: 70 2d 67 65 74 2d 63 6f 6d 6d 65 6e 74 20 73 74 p-get-comment st
9180: 65 70 29 29 29 29 0a 09 20 20 20 20 20 28 65 6c ep)))).. (el
9190: 73 65 0a 09 20 20 20 20 20 20 28 76 65 63 74 6f se.. (vecto
91a0: 72 2d 73 65 74 21 20 72 65 63 6f 72 64 20 32 20 r-set! record 2
91b0: 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 (tdb:step-get-st
91c0: 61 74 65 20 73 74 65 70 29 29 0a 09 20 20 20 20 ate step))..
91d0: 20 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 72 (vector-set! r
91e0: 65 63 6f 72 64 20 33 20 28 74 64 62 3a 73 74 65 ecord 3 (tdb:ste
91f0: 70 2d 67 65 74 2d 73 74 61 74 75 73 20 73 74 65 p-get-status ste
9200: 70 29 29 0a 09 20 20 20 20 20 20 28 76 65 63 74 p)).. (vect
9210: 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 64 20 34 or-set! record 4
9220: 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 65 (tdb:step-get-e
9230: 76 65 6e 74 5f 74 69 6d 65 20 73 74 65 70 29 29 vent_time step))
9240: 0a 09 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d .. (vector-
9250: 73 65 74 21 20 72 65 63 6f 72 64 20 36 20 28 74 set! record 6 (t
9260: 64 62 3a 73 74 65 70 2d 67 65 74 2d 63 6f 6d 6d db:step-get-comm
9270: 65 6e 74 20 73 74 65 70 29 29 29 29 0a 09 20 20 ent step))))..
9280: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
9290: 21 20 72 65 73 20 28 74 64 62 3a 73 74 65 70 2d ! res (tdb:step-
92a0: 67 65 74 2d 73 74 65 70 6e 61 6d 65 20 73 74 65 get-stepname ste
92b0: 70 29 20 72 65 63 6f 72 64 29 0a 09 20 20 20 28 p) record).. (
92c0: 64 65 62 75 67 3a 70 72 69 6e 74 20 36 20 2a 64 debug:print 6 *d
92d0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
92e0: 20 22 72 65 63 6f 72 64 28 61 66 74 65 72 29 20 "record(after)
92f0: 20 3d 20 22 20 72 65 63 6f 72 64 20 0a 09 09 09 = " record ....
9300: 22 5c 6e 69 64 3a 20 20 20 20 20 20 20 22 20 28 "\nid: " (
9310: 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 69 64 20 tdb:step-get-id
9320: 73 74 65 70 29 0a 09 09 09 22 5c 6e 73 74 65 70 step)...."\nstep
9330: 6e 61 6d 65 3a 20 22 20 28 74 64 62 3a 73 74 65 name: " (tdb:ste
9340: 70 2d 67 65 74 2d 73 74 65 70 6e 61 6d 65 20 73 p-get-stepname s
9350: 74 65 70 29 0a 09 09 09 22 5c 6e 73 74 61 74 65 tep)...."\nstate
9360: 3a 20 20 20 20 22 20 28 74 64 62 3a 73 74 65 70 : " (tdb:step
9370: 2d 67 65 74 2d 73 74 61 74 65 20 73 74 65 70 29 -get-state step)
9380: 0a 09 09 09 22 5c 6e 73 74 61 74 75 73 3a 20 20 ...."\nstatus:
9390: 20 22 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 " (tdb:step-get
93a0: 2d 73 74 61 74 75 73 20 73 74 65 70 29 0a 09 09 -status step)...
93b0: 09 22 5c 6e 74 69 6d 65 3a 20 20 20 20 20 22 20 ."\ntime: "
93c0: 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 65 76 (tdb:step-get-ev
93d0: 65 6e 74 5f 74 69 6d 65 20 73 74 65 70 29 29 29 ent_time step)))
93e0: 29 0a 20 20 20 20 20 20 20 3b 3b 20 28 65 6c 73 ). ;; (els
93f0: 65 20 20 20 28 76 65 63 74 6f 72 2d 73 65 74 21 e (vector-set!
9400: 20 72 65 63 6f 72 64 20 31 20 28 74 64 62 3a 73 record 1 (tdb:s
9410: 74 65 70 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 tep-get-event_ti
9420: 6d 65 20 73 74 65 70 29 29 29 0a 20 20 20 20 20 me step))).
9430: 20 20 28 73 6f 72 74 20 73 74 65 70 73 20 28 6c (sort steps (l
9440: 61 6d 62 64 61 20 28 61 20 62 29 0a 09 09 20 20 ambda (a b)...
9450: 20 20 20 28 63 6f 6e 64 0a 09 09 20 20 20 20 20 (cond...
9460: 20 28 28 3c 20 20 20 28 74 64 62 3a 73 74 65 70 ((< (tdb:step
9470: 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 -get-event_time
9480: 61 29 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d a)(tdb:step-get-
9490: 65 76 65 6e 74 5f 74 69 6d 65 20 62 29 29 20 23 event_time b)) #
94a0: 74 29 0a 09 09 20 20 20 20 20 20 28 28 65 71 3f t)... ((eq?
94b0: 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 65 (tdb:step-get-e
94c0: 76 65 6e 74 5f 74 69 6d 65 20 61 29 28 74 64 62 vent_time a)(tdb
94d0: 3a 73 74 65 70 2d 67 65 74 2d 65 76 65 6e 74 5f :step-get-event_
94e0: 74 69 6d 65 20 62 29 29 20 0a 09 09 20 20 20 20 time b)) ...
94f0: 20 20 20 28 3c 20 20 20 28 74 64 62 3a 73 74 65 (< (tdb:ste
9500: 70 2d 67 65 74 2d 69 64 20 61 29 20 20 20 20 20 p-get-id a)
9510: 20 20 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 (tdb:step-get
9520: 2d 69 64 20 62 29 29 29 0a 09 09 20 20 20 20 20 -id b)))...
9530: 20 28 65 6c 73 65 20 23 66 29 29 29 29 29 0a 20 (else #f))))).
9540: 20 20 20 20 20 72 65 73 29 29 0a 0a 3b 3b 20 0a res))..;; .
9550: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 ;;.(define (test
9560: 73 3a 67 65 74 2d 63 6f 6d 70 72 65 73 73 65 64 s:get-compressed
9570: 2d 73 74 65 70 73 20 72 75 6e 2d 69 64 20 74 65 -steps run-id te
9580: 73 74 2d 69 64 29 0a 20 20 28 6c 65 74 2a 20 28 st-id). (let* (
9590: 28 73 74 65 70 73 2d 64 61 74 61 20 20 28 72 6d (steps-data (rm
95a0: 74 3a 67 65 74 2d 73 74 65 70 73 2d 66 6f 72 2d t:get-steps-for-
95b0: 74 65 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 test run-id test
95c0: 2d 69 64 29 29 20 3b 3b 20 20 20 20 20 20 30 20 -id)) ;; 0
95d0: 20 20 20 20 20 20 31 20 20 20 20 32 20 20 20 20 1 2
95e0: 33 20 20 20 20 20 20 20 34 20 20 20 20 20 20 20 3 4
95f0: 35 20 20 20 20 20 20 20 36 20 20 20 20 20 20 37 5 6 7
9600: 20 20 20 20 20 20 20 0a 09 20 28 63 6f 6d 70 72 .. (compr
9610: 73 74 65 70 73 20 20 28 74 65 73 74 73 3a 70 72 steps (tests:pr
9620: 6f 63 65 73 73 2d 73 74 65 70 73 2d 74 61 62 6c ocess-steps-tabl
9630: 65 20 73 74 65 70 73 2d 64 61 74 61 29 29 29 20 e steps-data)))
9640: 3b 3b 20 23 3c 73 74 65 70 6e 61 6d 65 20 73 74 ;; #<stepname st
9650: 61 72 74 20 65 6e 64 20 73 74 61 74 75 73 20 44 art end status D
9660: 75 72 61 74 69 6f 6e 20 4c 6f 67 66 69 6c 65 20 uration Logfile
9670: 43 6f 6d 6d 65 6e 74 20 69 64 3e 0a 20 20 20 20 Comment id>.
9680: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 78 29 (map (lambda (x)
9690: 0a 09 20 20 20 3b 3b 20 74 61 6b 65 20 61 64 76 .. ;; take adv
96a0: 61 6e 74 61 67 65 20 6f 66 20 74 68 65 20 5c 6e antage of the \n
96b0: 20 6f 6e 20 74 69 6d 65 2d 3e 73 74 72 69 6e 67 on time->string
96c0: 0a 09 20 20 20 28 76 65 63 74 6f 72 20 20 20 20 .. (vector
96d0: 3b 3b 20 77 65 20 61 72 65 20 63 6f 6e 73 74 72 ;; we are constr
96e0: 75 63 74 69 6e 67 20 62 61 73 69 63 61 6c 6c 79 ucting basically
96f0: 20 74 68 65 20 6f 72 69 67 69 6e 61 6c 20 76 65 the original ve
9700: 63 74 6f 72 20 62 75 74 20 63 6f 6c 6c 61 70 73 ctor but collaps
9710: 69 6e 67 20 73 74 61 72 74 20 65 6e 64 20 72 65 ing start end re
9720: 63 6f 72 64 73 0a 09 20 20 20 20 28 76 65 63 74 cords.. (vect
9730: 6f 72 2d 72 65 66 20 78 20 30 29 20 20 20 20 20 or-ref x 0)
9740: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9750: 20 20 20 20 20 20 20 20 20 3b 3b 20 69 64 20 20 ;; id
9760: 20 20 20 20 20 20 30 0a 09 20 20 20 20 28 6c 65 0.. (le
9770: 74 20 28 28 73 20 28 76 65 63 74 6f 72 2d 72 65 t ((s (vector-re
9780: 66 20 78 20 31 29 29 29 0a 09 20 20 20 20 20 20 f x 1)))..
9790: 28 69 66 20 28 6e 75 6d 62 65 72 3f 20 73 29 28 (if (number? s)(
97a0: 73 65 63 6f 6e 64 73 2d 3e 74 69 6d 65 2d 73 74 seconds->time-st
97b0: 72 69 6e 67 20 73 29 20 73 29 29 20 3b 3b 20 73 ring s) s)) ;; s
97c0: 74 61 72 74 74 69 6d 65 20 31 0a 09 20 20 20 20 tarttime 1..
97d0: 28 6c 65 74 20 28 28 73 20 28 76 65 63 74 6f 72 (let ((s (vector
97e0: 2d 72 65 66 20 78 20 32 29 29 29 0a 09 20 20 20 -ref x 2)))..
97f0: 20 20 20 28 69 66 20 28 6e 75 6d 62 65 72 3f 20 (if (number?
9800: 73 29 28 73 65 63 6f 6e 64 73 2d 3e 74 69 6d 65 s)(seconds->time
9810: 2d 73 74 72 69 6e 67 20 73 29 20 73 29 29 20 3b -string s) s)) ;
9820: 3b 20 65 6e 64 74 69 6d 65 20 20 20 32 0a 09 20 ; endtime 2..
9830: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 78 (vector-ref x
9840: 20 33 29 20 20 20 20 20 20 20 20 20 20 20 20 20 3)
9850: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9860: 20 3b 3b 20 73 74 61 74 75 73 20 20 20 20 33 20 ;; status 3
9870: 20 20 20 0a 09 20 20 20 20 28 76 65 63 74 6f 72 .. (vector
9880: 2d 72 65 66 20 78 20 34 29 20 20 20 20 20 20 20 -ref x 4)
9890: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
98a0: 20 20 20 20 20 20 20 3b 3b 20 64 75 72 61 74 69 ;; durati
98b0: 6f 6e 20 20 34 0a 09 20 20 20 20 28 76 65 63 74 on 4.. (vect
98c0: 6f 72 2d 72 65 66 20 78 20 35 29 20 20 20 20 20 or-ref x 5)
98d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
98e0: 20 20 20 20 20 20 20 20 20 3b 3b 20 6c 6f 67 66 ;; logf
98f0: 69 6c 65 20 20 20 35 0a 09 20 20 20 20 28 76 65 ile 5.. (ve
9900: 63 74 6f 72 2d 72 65 66 20 78 20 36 29 20 20 20 ctor-ref x 6)
9910: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9920: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 63 6f ;; co
9930: 6d 6d 65 6e 74 20 20 20 36 0a 09 20 20 20 20 28 mment 6.. (
9940: 76 65 63 74 6f 72 2d 72 65 66 20 78 20 37 29 29 vector-ref x 7))
9950: 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 )
9960: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ;;
9970: 69 64 20 20 20 20 20 20 20 20 37 0a 09 20 28 73 id 7.. (s
9980: 6f 72 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ort (hash-table-
9990: 76 61 6c 75 65 73 20 63 6f 6d 70 72 73 74 65 70 values comprstep
99a0: 73 29 0a 09 20 20 20 20 20 20 20 28 6c 61 6d 62 s).. (lamb
99b0: 64 61 20 28 61 20 62 29 0a 09 09 20 28 6c 65 74 da (a b)... (let
99c0: 20 28 28 74 69 6d 65 2d 61 20 28 76 65 63 74 6f ((time-a (vecto
99d0: 72 2d 72 65 66 20 61 20 31 29 29 0a 09 09 20 20 r-ref a 1))...
99e0: 20 20 20 20 20 28 74 69 6d 65 2d 62 20 28 76 65 (time-b (ve
99f0: 63 74 6f 72 2d 72 65 66 20 62 20 31 29 29 0a 09 ctor-ref b 1))..
9a00: 09 20 20 20 20 20 20 20 28 69 64 2d 61 20 20 20 . (id-a
9a10: 28 76 65 63 74 6f 72 2d 72 65 66 20 61 20 37 29 (vector-ref a 7)
9a20: 29 0a 09 09 20 20 20 20 20 20 20 28 69 64 2d 62 )... (id-b
9a30: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 62 (vector-ref b
9a40: 20 37 29 29 29 0a 09 09 20 20 20 28 69 66 20 28 7)))... (if (
9a50: 61 6e 64 20 28 6e 75 6d 62 65 72 3f 20 74 69 6d and (number? tim
9a60: 65 2d 61 29 28 6e 75 6d 62 65 72 3f 20 74 69 6d e-a)(number? tim
9a70: 65 2d 62 29 29 0a 09 09 20 20 20 20 20 20 20 28 e-b))... (
9a80: 69 66 20 28 3c 20 74 69 6d 65 2d 61 20 74 69 6d if (< time-a tim
9a90: 65 2d 62 29 0a 09 09 09 20 20 20 23 74 0a 09 09 e-b).... #t...
9aa0: 09 20 20 20 28 69 66 20 28 65 71 3f 20 74 69 6d . (if (eq? tim
9ab0: 65 2d 61 20 74 69 6d 65 2d 62 29 0a 09 09 09 20 e-a time-b)....
9ac0: 20 20 20 20 20 20 28 3c 20 69 64 2d 61 20 69 64 (< id-a id
9ad0: 2d 62 29 0a 09 09 09 20 20 20 20 20 20 20 3b 3b -b).... ;;
9ae0: 20 28 73 74 72 69 6e 67 3c 3f 20 28 63 6f 6e 63 (string<? (conc
9af0: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 61 20 32 (vector-ref a 2
9b00: 29 29 0a 09 09 09 20 20 20 20 20 20 20 3b 3b 09 )).... ;;.
9b10: 20 20 20 20 28 63 6f 6e 63 20 28 76 65 63 74 6f (conc (vecto
9b20: 72 2d 72 65 66 20 62 20 32 29 29 29 0a 09 09 09 r-ref b 2)))....
9b30: 20 20 20 20 20 20 20 23 66 29 29 0a 09 09 20 20 #f))...
9b40: 20 20 20 20 20 28 73 74 72 69 6e 67 3c 3f 20 28 (string<? (
9b50: 63 6f 6e 63 20 74 69 6d 65 2d 61 29 28 63 6f 6e conc time-a)(con
9b60: 63 20 74 69 6d 65 2d 62 29 29 29 29 29 29 29 29 c time-b))))))))
9b70: 29 0a 0a 0a 3b 3b 20 53 61 76 65 20 74 65 73 74 )...;; Save test
9b80: 20 73 74 61 74 65 20 61 6e 64 20 73 74 61 74 75 state and statu
9b90: 73 20 69 6e 20 74 6f 20 61 20 66 69 6c 65 20 2e s in to a file .
9ba0: 66 69 6e 61 6c 2d 73 74 61 74 75 73 20 69 6e 20 final-status in
9bb0: 74 68 65 20 74 65 73 74 20 64 69 72 65 63 74 6f the test directo
9bc0: 72 79 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 ry.;;.(define (t
9bd0: 65 73 74 73 3a 73 61 76 65 2d 66 69 6e 61 6c 2d ests:save-final-
9be0: 73 74 61 74 75 73 20 72 75 6e 2d 69 64 20 74 65 status run-id te
9bf0: 73 74 2d 69 64 29 0a 20 20 28 6c 65 74 2a 20 28 st-id). (let* (
9c00: 28 74 65 73 74 2d 64 61 74 20 20 28 72 6d 74 3a (test-dat (rmt:
9c10: 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 get-test-info-by
9c20: 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d -id run-id test-
9c30: 69 64 29 29 0a 09 20 28 6f 75 74 2d 64 69 72 20 id)).. (out-dir
9c40: 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 (db:test-get-r
9c50: 75 6e 64 69 72 20 74 65 73 74 2d 64 61 74 29 29 undir test-dat))
9c60: 0a 09 20 28 73 74 61 74 75 73 2d 66 69 6c 65 20 .. (status-file
9c70: 20 28 63 6f 6e 63 20 6f 75 74 2d 64 69 72 20 22 (conc out-dir "
9c80: 2f 2e 66 69 6e 61 6c 2d 73 74 61 74 75 73 22 29 /.final-status")
9c90: 29 0a 20 20 20 29 0a 20 20 20 20 3b 3b 20 66 69 ). ). ;; fi
9ca0: 72 73 74 20 76 65 72 69 66 79 20 77 65 20 61 72 rst verify we ar
9cb0: 65 20 61 62 6c 65 20 74 6f 20 77 72 69 74 65 20 e able to write
9cc0: 74 68 65 20 6f 75 74 70 75 74 20 66 69 6c 65 0a the output file.
9cd0: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 66 69 (if (not (fi
9ce0: 6c 65 2d 77 72 69 74 61 62 6c 65 3f 20 6f 75 74 le-writable? out
9cf0: 2d 64 69 72 29 29 0a 09 20 20 20 20 28 64 65 62 -dir)).. (deb
9d00: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
9d10: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 ult-log-port* "E
9d20: 52 52 4f 52 3a 20 63 61 6e 6e 6f 74 20 77 72 69 RROR: cannot wri
9d30: 74 65 20 2e 66 69 6e 61 6c 2d 73 74 61 74 75 73 te .final-status
9d40: 20 74 6f 20 22 20 6f 75 74 2d 64 69 72 29 0a 09 to " out-dir)..
9d50: 20 20 20 20 28 6c 65 74 2a 20 0a 20 20 20 20 20 (let* .
9d60: 20 20 20 20 28 28 6f 75 74 70 20 20 20 20 20 20 ((outp
9d70: 28 6f 70 65 6e 2d 6f 75 74 70 75 74 2d 66 69 6c (open-output-fil
9d80: 65 20 73 74 61 74 75 73 2d 66 69 6c 65 29 29 0a e status-file)).
9d90: 09 20 20 20 20 20 20 20 28 73 74 61 74 75 73 20 . (status
9da0: 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d (db:test-get-
9db0: 73 74 61 74 75 73 20 20 20 74 65 73 74 2d 64 61 status test-da
9dc0: 74 29 29 0a 20 20 20 20 20 20 20 20 20 28 73 74 t)). (st
9dd0: 61 74 65 20 20 20 20 20 28 64 62 3a 74 65 73 74 ate (db:test
9de0: 2d 67 65 74 2d 73 74 61 74 65 20 20 20 20 74 65 -get-state te
9df0: 73 74 2d 64 61 74 29 29 29 0a 20 20 20 20 20 20 st-dat))).
9e00: 20 20 28 66 70 72 69 6e 74 66 20 6f 75 74 70 20 (fprintf outp
9e10: 22 7e 53 5c 6e 22 20 73 74 61 74 65 29 20 0a 20 "~S\n" state) .
9e20: 20 20 20 20 20 20 20 28 66 70 72 69 6e 74 66 20 (fprintf
9e30: 6f 75 74 70 20 22 7e 53 5c 6e 22 20 73 74 61 74 outp "~S\n" stat
9e40: 75 73 29 20 0a 20 20 20 20 20 20 20 20 28 63 6c us) . (cl
9e50: 6f 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 ose-output-port
9e60: 6f 75 74 70 29 29 29 29 29 0a 0a 0a 3b 3b 20 4d outp)))))...;; M
9e70: 55 53 54 20 42 45 20 43 41 4c 4c 45 44 20 6c 6f UST BE CALLED lo
9e80: 63 61 6c 21 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 cal!.;;.(define
9e90: 28 74 65 73 74 73 3a 74 65 73 74 2d 67 65 74 2d (tests:test-get-
9ea0: 70 61 74 68 73 2d 6d 61 74 63 68 69 6e 67 20 6b paths-matching k
9eb0: 65 79 6e 61 6d 65 73 20 74 61 72 67 65 74 20 66 eynames target f
9ec0: 6e 61 6d 65 70 61 74 74 20 23 21 6b 65 79 20 28 namepatt #!key (
9ed0: 72 65 73 20 27 28 29 29 29 0a 20 20 3b 3b 20 42 res '())). ;; B
9ee0: 55 47 3a 20 4d 6f 76 65 20 74 68 65 20 76 61 6c UG: Move the val
9ef0: 75 65 73 20 64 65 72 69 76 65 64 20 66 72 6f 6d ues derived from
9f00: 20 61 72 67 73 20 74 6f 20 70 61 72 61 6d 65 74 args to paramet
9f10: 65 72 73 20 61 6e 64 20 70 75 73 68 20 74 6f 20 ers and push to
9f20: 6d 65 67 61 74 65 73 74 2e 73 63 6d 0a 20 20 28 megatest.scm. (
9f30: 6c 65 74 2a 20 28 28 74 65 73 74 70 61 74 74 20 let* ((testpatt
9f40: 20 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d (or (args:get-
9f50: 61 72 67 20 22 2d 74 65 73 74 70 61 74 74 22 29 arg "-testpatt")
9f60: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
9f70: 74 65 73 74 70 61 74 74 22 29 20 22 25 22 29 29 testpatt") "%"))
9f80: 0a 09 20 28 73 74 61 74 65 70 61 74 74 20 20 28 .. (statepatt (
9f90: 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 or (args:get-arg
9fa0: 20 22 2d 73 74 61 74 65 22 29 20 20 20 28 61 72 "-state") (ar
9fb0: 67 73 3a 67 65 74 2d 61 72 67 20 22 3a 73 74 61 gs:get-arg ":sta
9fc0: 74 65 22 29 20 20 20 20 22 25 22 29 29 0a 09 20 te") "%"))..
9fd0: 28 73 74 61 74 75 73 70 61 74 74 20 28 6f 72 20 (statuspatt (or
9fe0: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
9ff0: 73 74 61 74 75 73 22 29 20 20 28 61 72 67 73 3a status") (args:
a000: 67 65 74 2d 61 72 67 20 22 3a 73 74 61 74 75 73 get-arg ":status
a010: 22 29 20 20 20 22 25 22 29 29 0a 09 20 28 72 75 ") "%")).. (ru
a020: 6e 6e 61 6d 65 20 20 20 20 28 6f 72 20 28 61 72 nname (or (ar
a030: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 75 6e gs:get-arg "-run
a040: 6e 61 6d 65 22 29 20 28 61 72 67 73 3a 67 65 74 name") (args:get
a050: 2d 61 72 67 20 22 3a 72 75 6e 6e 61 6d 65 22 29 -arg ":runname")
a060: 20 20 22 25 22 29 29 0a 09 20 28 70 61 74 68 73 "%")).. (paths
a070: 2d 66 72 6f 6d 2d 64 62 20 28 72 6d 74 3a 74 65 -from-db (rmt:te
a080: 73 74 2d 67 65 74 2d 70 61 74 68 73 2d 6d 61 74 st-get-paths-mat
a090: 63 68 69 6e 67 2d 6b 65 79 6e 61 6d 65 73 2d 74 ching-keynames-t
a0a0: 61 72 67 65 74 2d 6e 65 77 20 6b 65 79 6e 61 6d arget-new keynam
a0b0: 65 73 20 74 61 72 67 65 74 20 72 65 73 0a 09 09 es target res...
a0c0: 09 09 09 74 65 73 74 70 61 74 74 0a 09 09 09 09 ...testpatt.....
a0d0: 09 73 74 61 74 65 70 61 74 74 0a 09 09 09 09 09 .statepatt......
a0e0: 73 74 61 74 75 73 70 61 74 74 0a 09 09 09 09 09 statuspatt......
a0f0: 72 75 6e 6e 61 6d 65 29 29 29 0a 20 20 20 20 28 runname))). (
a100: 69 66 20 66 6e 61 6d 65 70 61 74 74 0a 09 28 61 if fnamepatt..(a
a110: 70 70 6c 79 20 61 70 70 65 6e 64 20 0a 09 20 20 pply append ..
a120: 20 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 (map (lambd
a130: 61 20 28 70 29 0a 09 09 20 20 20 20 20 20 28 69 a (p)... (i
a140: 66 20 28 64 69 72 65 63 74 6f 72 79 2d 65 78 69 f (directory-exi
a150: 73 74 73 3f 20 70 29 0a 09 09 09 20 20 28 6c 65 sts? p).... (le
a160: 74 20 28 28 67 6c 6f 62 2d 71 75 65 72 79 20 28 t ((glob-query (
a170: 63 6f 6e 63 20 70 20 22 2f 22 20 66 6e 61 6d 65 conc p "/" fname
a180: 70 61 74 74 29 29 29 0a 09 09 09 20 20 20 20 28 patt))).... (
a190: 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e handle-exception
a1a0: 73 0a 09 09 09 09 65 78 6e 0a 09 09 09 20 20 20 s.....exn....
a1b0: 20 20 20 28 62 65 67 69 6e 0a 09 09 09 09 28 70 (begin.....(p
a1c0: 72 69 6e 74 20 22 62 75 69 6c 74 2d 69 6e 20 67 rint "built-in g
a1d0: 6c 6f 62 20 6f 6e 20 22 20 67 6c 6f 62 2d 71 75 lob on " glob-qu
a1e0: 65 72 79 20 22 2c 20 66 61 69 6c 65 64 2c 20 74 ery ", failed, t
a1f0: 72 79 20 75 73 69 6e 67 20 74 68 65 20 73 68 65 ry using the she
a200: 6c 6c 2e 20 65 78 6e 3d 22 20 65 78 6e 29 0a 09 ll. exn=" exn)..
a210: 09 09 09 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 ...(with-input-f
a220: 72 6f 6d 2d 70 69 70 65 0a 09 09 09 09 20 28 63 rom-pipe..... (c
a230: 6f 6e 63 20 22 65 63 68 6f 20 22 20 67 6c 6f 62 onc "echo " glob
a240: 2d 71 75 65 72 79 29 0a 09 09 09 09 20 72 65 61 -query)..... rea
a250: 64 2d 6c 69 6e 65 73 29 29 20 20 3b 3b 20 77 65 d-lines)) ;; we
a260: 20 61 72 65 6e 27 74 20 67 6f 69 6e 67 20 74 6f aren't going to
a270: 20 74 72 79 20 74 6f 6f 20 68 61 72 64 2e 20 49 try too hard. I
a280: 66 20 67 6c 6f 62 20 62 72 65 61 6b 73 20 69 74 f glob breaks it
a290: 20 69 73 20 6c 69 6b 65 6c 79 20 62 65 63 61 75 is likely becau
a2a0: 73 65 20 73 6f 6d 65 6f 6e 65 20 74 72 69 65 64 se someone tried
a2b0: 20 74 6f 20 64 6f 20 2a 2f 2a 2f 2a 2e 6c 6f 67 to do */*/*.log
a2c0: 20 6f 72 20 73 69 6d 69 6c 61 72 0a 09 09 09 20 or similar....
a2d0: 20 20 20 20 20 28 67 6c 6f 62 20 67 6c 6f 62 2d (glob glob-
a2e0: 71 75 65 72 79 29 29 29 0a 09 09 09 20 20 27 28 query))).... '(
a2f0: 29 29 29 0a 09 09 20 20 20 20 70 61 74 68 73 2d )))... paths-
a300: 66 72 6f 6d 2d 64 62 29 29 0a 09 70 61 74 68 73 from-db))..paths
a310: 2d 66 72 6f 6d 2d 64 62 29 29 29 0a 0a 09 09 09 -from-db))).....
a320: 20 20 20 20 20 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d .;;=======
a330: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a340: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a350: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a360: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
a370: 3b 3b 20 47 61 74 68 65 72 20 64 61 74 61 20 66 ;; Gather data f
a380: 72 6f 6d 20 74 65 73 74 2f 74 61 73 6b 20 73 70 rom test/task sp
a390: 65 63 69 66 69 63 61 74 69 6f 6e 73 0a 3b 3b 3d ecifications.;;=
a3a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a3b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a3c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a3d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a3e0: 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 28 64 65 66 69 6e =====..;; (defin
a3f0: 65 20 28 74 65 73 74 73 3a 67 65 74 2d 76 61 6c e (tests:get-val
a400: 69 64 2d 74 65 73 74 73 20 74 65 73 74 73 64 69 id-tests testsdi
a410: 72 20 74 65 73 74 2d 70 61 74 74 73 29 20 3b 3b r test-patts) ;;
a420: 20 20 23 21 6b 65 79 20 28 74 65 73 74 2d 6e 61 #!key (test-na
a430: 6d 65 73 20 27 28 29 29 29 0a 3b 3b 20 20 20 28 mes '())).;; (
a440: 6c 65 74 20 28 28 74 65 73 74 73 20 28 67 6c 6f let ((tests (glo
a450: 62 20 28 63 6f 6e 63 20 74 65 73 74 73 64 69 72 b (conc testsdir
a460: 20 22 2f 74 65 73 74 73 2f 2a 22 29 29 29 29 20 "/tests/*"))))
a470: 3b 3b 20 22 20 28 73 74 72 69 6e 67 2d 74 72 61 ;; " (string-tra
a480: 6e 73 6c 61 74 65 20 70 61 74 74 20 22 25 22 20 nslate patt "%"
a490: 22 2a 22 29 29 29 29 29 0a 3b 3b 20 20 20 20 20 "*"))))).;;
a4a0: 28 73 65 74 21 20 74 65 73 74 73 20 28 66 69 6c (set! tests (fil
a4b0: 74 65 72 20 28 6c 61 6d 62 64 61 20 28 74 65 73 ter (lambda (tes
a4c0: 74 29 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 t)(common:file-e
a4d0: 78 69 73 74 73 3f 20 28 63 6f 6e 63 20 74 65 73 xists? (conc tes
a4e0: 74 20 22 2f 74 65 73 74 63 6f 6e 66 69 67 22 29 t "/testconfig")
a4f0: 29 29 20 74 65 73 74 73 29 29 0a 3b 3b 20 20 20 )) tests)).;;
a500: 20 20 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 (delete-duplic
a510: 61 74 65 73 0a 3b 3b 20 20 20 20 20 20 28 66 69 ates.;; (fi
a520: 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 74 65 lter (lambda (te
a530: 73 74 6e 61 6d 65 29 0a 3b 3b 20 09 20 20 20 20 stname).;; .
a540: 20 20 20 28 74 65 73 74 73 3a 6d 61 74 63 68 20 (tests:match
a550: 74 65 73 74 2d 70 61 74 74 73 20 74 65 73 74 6e test-patts testn
a560: 61 6d 65 20 23 66 29 29 0a 3b 3b 20 09 20 20 20 ame #f)).;; .
a570: 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 (map (lambda (
a580: 74 65 73 74 70 29 0a 3b 3b 20 09 09 20 20 20 20 testp).;; ..
a590: 28 6c 61 73 74 20 28 73 74 72 69 6e 67 2d 73 70 (last (string-sp
a5a0: 6c 69 74 20 74 65 73 74 70 20 22 2f 22 29 29 29 lit testp "/")))
a5b0: 0a 3b 3b 20 09 09 20 20 74 65 73 74 73 29 29 29 .;; .. tests)))
a5c0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 ))..(define (tes
a5d0: 74 73 3a 67 65 74 2d 74 65 73 74 2d 70 61 74 68 ts:get-test-path
a5e0: 2d 66 72 6f 6d 2d 65 6e 76 69 72 6f 6e 6d 65 6e -from-environmen
a5f0: 74 29 0a 20 20 28 69 66 20 28 61 6e 64 20 28 67 t). (if (and (g
a600: 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 et-environment-v
a610: 61 72 69 61 62 6c 65 20 22 4d 54 5f 4c 49 4e 4b ariable "MT_LINK
a620: 54 52 45 45 22 29 0a 09 20 20 20 28 67 65 74 2d TREE").. (get-
a630: 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 environment-vari
a640: 61 62 6c 65 20 22 4d 54 5f 54 41 52 47 45 54 22 able "MT_TARGET"
a650: 29 0a 09 20 20 20 28 67 65 74 2d 65 6e 76 69 72 ).. (get-envir
a660: 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 onment-variable
a670: 22 4d 54 5f 52 55 4e 4e 41 4d 45 22 29 0a 09 20 "MT_RUNNAME")..
a680: 20 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 (get-environme
a690: 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 4d 54 5f nt-variable "MT_
a6a0: 54 45 53 54 5f 4e 41 4d 45 22 29 0a 09 20 20 20 TEST_NAME")..
a6b0: 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 (get-environment
a6c0: 2d 76 61 72 69 61 62 6c 65 20 22 4d 54 5f 49 54 -variable "MT_IT
a6d0: 45 4d 50 41 54 48 22 29 29 0a 20 20 20 20 20 20 EMPATH")).
a6e0: 28 63 6f 6e 63 20 28 67 65 74 2d 65 6e 76 69 72 (conc (get-envir
a6f0: 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 onment-variable
a700: 22 4d 54 5f 4c 49 4e 4b 54 52 45 45 22 29 20 20 "MT_LINKTREE")
a710: 22 2f 22 0a 09 20 20 20 20 28 67 65 74 2d 65 6e "/".. (get-en
a720: 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 vironment-variab
a730: 6c 65 20 22 4d 54 5f 54 41 52 47 45 54 22 29 20 le "MT_TARGET")
a740: 20 20 20 22 2f 22 0a 09 20 20 20 20 28 67 65 74 "/".. (get
a750: 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 -environment-var
a760: 69 61 62 6c 65 20 22 4d 54 5f 52 55 4e 4e 41 4d iable "MT_RUNNAM
a770: 45 22 29 20 20 20 22 2f 22 0a 09 20 20 20 20 28 E") "/".. (
a780: 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d get-environment-
a790: 76 61 72 69 61 62 6c 65 20 22 4d 54 5f 54 45 53 variable "MT_TES
a7a0: 54 5f 4e 41 4d 45 22 29 0a 09 20 20 20 20 28 69 T_NAME").. (i
a7b0: 66 20 28 61 6e 64 20 28 67 65 74 2d 65 6e 76 69 f (and (get-envi
a7c0: 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 ronment-variable
a7d0: 20 22 4d 54 5f 49 54 45 4d 50 41 54 48 22 29 0a "MT_ITEMPATH").
a7e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a7f0: 20 20 20 20 20 28 6e 6f 74 20 28 73 74 72 69 6e (not (strin
a800: 67 3d 3f 20 22 22 20 28 67 65 74 2d 65 6e 76 69 g=? "" (get-envi
a810: 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 ronment-variable
a820: 20 22 4d 54 5f 49 54 45 4d 50 41 54 48 22 29 29 "MT_ITEMPATH"))
a830: 29 29 0a 09 09 28 63 6f 6e 63 20 22 2f 22 20 28 ))...(conc "/" (
a840: 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d get-environment-
a850: 76 61 72 69 61 62 6c 65 20 22 4d 54 5f 49 54 45 variable "MT_ITE
a860: 4d 50 41 54 48 22 29 29 0a 20 20 20 20 20 20 20 MPATH")).
a870: 20 20 20 20 20 20 20 20 20 22 22 29 29 0a 20 20 "")).
a880: 20 20 20 20 23 66 29 29 0a 0a 3b 3b 20 69 66 20 #f))..;; if
a890: 2e 74 65 73 74 63 6f 6e 66 69 67 20 65 78 69 73 .testconfig exis
a8a0: 74 73 20 69 6e 20 74 65 73 74 20 64 69 72 65 63 ts in test direc
a8b0: 74 6f 72 79 20 72 65 61 64 20 61 6e 64 20 72 65 tory read and re
a8c0: 74 75 72 6e 20 69 74 0a 3b 3b 20 65 6c 73 65 20 turn it.;; else
a8d0: 69 66 20 68 61 76 65 20 63 61 63 68 65 64 20 63 if have cached c
a8e0: 6f 70 79 20 69 6e 20 2a 74 65 73 74 63 6f 6e 66 opy in *testconf
a8f0: 69 67 73 2a 20 72 65 74 75 72 6e 20 69 74 20 49 igs* return it I
a900: 46 46 20 74 68 65 72 65 20 69 73 20 61 20 73 65 FF there is a se
a910: 63 74 69 6f 6e 20 22 68 61 76 65 20 66 75 6c 6c ction "have full
a920: 64 61 74 61 22 0a 3b 3b 20 65 6c 73 65 20 72 65 data".;; else re
a930: 61 64 20 74 68 65 20 74 65 73 74 63 6f 6e 66 69 ad the testconfi
a940: 67 20 66 69 6c 65 0a 3b 3b 20 20 20 69 66 20 68 g file.;; if h
a950: 61 76 65 20 70 61 74 68 20 74 6f 20 74 65 73 74 ave path to test
a960: 20 64 69 72 65 63 74 6f 72 79 20 73 61 76 65 20 directory save
a970: 74 68 65 20 63 6f 6e 66 69 67 20 61 73 20 2e 74 the config as .t
a980: 65 73 74 63 6f 6e 66 69 67 20 61 6e 64 20 72 65 estconfig and re
a990: 74 75 72 6e 20 69 74 0a 3b 3b 0a 28 64 65 66 69 turn it.;;.(defi
a9a0: 6e 65 20 28 74 65 73 74 73 3a 67 65 74 2d 74 65 ne (tests:get-te
a9b0: 73 74 63 6f 6e 66 69 67 20 74 65 73 74 2d 6e 61 stconfig test-na
a9c0: 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 74 65 73 me item-path tes
a9d0: 74 2d 72 65 67 69 73 74 72 79 20 73 79 73 74 65 t-registry syste
a9e0: 6d 2d 61 6c 6c 6f 77 65 64 20 23 21 6b 65 79 20 m-allowed #!key
a9f0: 28 66 6f 72 63 65 2d 63 72 65 61 74 65 20 23 66 (force-create #f
aa00: 29 28 61 6c 6c 6f 77 2d 77 72 69 74 65 2d 63 61 )(allow-write-ca
aa10: 63 68 65 20 23 74 29 28 77 61 69 74 2d 61 2d 6d che #t)(wait-a-m
aa20: 69 6e 75 74 65 20 23 66 29 29 0a 20 20 28 6c 65 inute #f)). (le
aa30: 74 2a 20 28 28 75 73 65 2d 63 61 63 68 65 20 20 t* ((use-cache
aa40: 20 20 28 63 6f 6d 6d 6f 6e 3a 75 73 65 2d 63 61 (common:use-ca
aa50: 63 68 65 3f 29 29 0a 09 20 28 63 61 63 68 65 2d che?)).. (cache-
aa60: 70 61 74 68 20 20 20 28 74 65 73 74 73 3a 67 65 path (tests:ge
aa70: 74 2d 74 65 73 74 2d 70 61 74 68 2d 66 72 6f 6d t-test-path-from
aa80: 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 29 29 0a 09 -environment))..
aa90: 20 28 63 61 63 68 65 2d 66 69 6c 65 20 20 20 28 (cache-file (
aaa0: 61 6e 64 20 63 61 63 68 65 2d 70 61 74 68 20 28 and cache-path (
aab0: 63 6f 6e 63 20 63 61 63 68 65 2d 70 61 74 68 20 conc cache-path
aac0: 22 2f 2e 74 65 73 74 63 6f 6e 66 69 67 22 29 29 "/.testconfig"))
aad0: 29 0a 09 20 28 63 61 63 68 65 2d 65 78 69 73 74 ).. (cache-exist
aae0: 73 20 28 61 6e 64 20 63 61 63 68 65 2d 66 69 6c s (and cache-fil
aaf0: 65 0a 09 09 09 20 20 20 20 28 6e 6f 74 20 66 6f e.... (not fo
ab00: 72 63 65 2d 63 72 65 61 74 65 29 20 20 3b 3b 20 rce-create) ;;
ab10: 69 66 20 66 6f 72 63 65 2d 63 72 65 61 74 65 20 if force-create
ab20: 74 68 65 6e 20 70 72 65 74 65 6e 64 20 74 68 65 then pretend the
ab30: 72 65 20 69 73 20 6e 6f 20 63 61 63 68 65 20 74 re is no cache t
ab40: 6f 20 72 65 61 64 0a 09 09 09 20 20 20 20 28 63 o read.... (c
ab50: 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 ommon:file-exist
ab60: 73 3f 20 63 61 63 68 65 2d 66 69 6c 65 29 29 29 s? cache-file)))
ab70: 0a 09 20 28 63 61 63 68 65 64 2d 64 61 74 20 20 .. (cached-dat
ab80: 20 28 69 66 20 28 61 6e 64 20 28 6e 6f 74 20 66 (if (and (not f
ab90: 6f 72 63 65 2d 63 72 65 61 74 65 29 0a 09 09 09 orce-create)....
aba0: 09 63 61 63 68 65 2d 65 78 69 73 74 73 0a 09 09 .cache-exists...
abb0: 09 09 75 73 65 2d 63 61 63 68 65 29 0a 09 09 09 ..use-cache)....
abc0: 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 (handle-excep
abd0: 74 69 6f 6e 73 0a 09 09 09 20 20 20 20 20 20 20 tions....
abe0: 65 78 6e 0a 09 09 09 20 20 20 20 20 28 62 65 67 exn.... (beg
abf0: 69 6e 0a 09 09 09 20 20 20 20 20 20 20 28 64 65 in.... (de
ac00: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
ac10: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
ac20: 66 61 69 6c 65 64 20 74 6f 20 72 65 61 64 20 22 failed to read "
ac30: 20 63 61 63 68 65 2d 66 69 6c 65 20 22 2c 20 65 cache-file ", e
ac40: 78 6e 3d 22 20 65 78 6e 29 0a 09 09 09 20 20 20 xn=" exn)....
ac50: 20 20 20 20 23 66 29 20 3b 3b 20 61 6e 79 20 69 #f) ;; any i
ac60: 73 73 75 65 73 2c 20 6a 75 73 74 20 67 69 76 65 ssues, just give
ac70: 20 75 70 20 77 69 74 68 20 74 68 65 20 63 61 63 up with the cac
ac80: 68 65 64 20 76 65 72 73 69 6f 6e 20 61 6e 64 20 hed version and
ac90: 72 65 2d 72 65 61 64 0a 09 09 09 20 20 20 20 20 re-read....
aca0: 28 63 6f 6e 66 69 67 66 3a 72 65 61 64 2d 61 6c (configf:read-al
acb0: 69 73 74 20 63 61 63 68 65 2d 66 69 6c 65 29 29 ist cache-file))
acc0: 0a 09 09 09 20 20 20 23 66 29 29 0a 20 20 20 20 .... #f)).
acd0: 20 20 20 20 20 28 74 65 73 74 2d 66 75 6c 6c 2d (test-full-
ace0: 6e 61 6d 65 20 28 69 66 20 28 61 6e 64 20 69 74 name (if (and it
acf0: 65 6d 2d 70 61 74 68 20 28 6e 6f 74 20 28 73 74 em-path (not (st
ad00: 72 69 6e 67 2d 6e 75 6c 6c 3f 20 69 74 65 6d 2d ring-null? item-
ad10: 70 61 74 68 29 29 29 0a 20 20 20 20 20 20 20 20 path))).
ad20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ad30: 20 20 20 20 20 28 63 6f 6e 63 20 74 65 73 74 2d (conc test-
ad40: 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 name "/" item-pa
ad50: 74 68 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 th).
ad60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ad70: 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a 20 20 test-name))).
ad80: 20 20 28 69 66 20 63 61 63 68 65 64 2d 64 61 74 (if cached-dat
ad90: 0a 09 63 61 63 68 65 64 2d 64 61 74 0a 09 28 6c ..cached-dat..(l
ada0: 65 74 20 28 28 64 61 74 20 28 68 61 73 68 2d 74 et ((dat (hash-t
adb0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
adc0: 20 2a 74 65 73 74 63 6f 6e 66 69 67 73 2a 20 74 *testconfigs* t
add0: 65 73 74 2d 66 75 6c 6c 2d 6e 61 6d 65 20 23 66 est-full-name #f
ade0: 29 29 29 0a 09 20 20 28 69 66 20 28 61 6e 64 20 ))).. (if (and
adf0: 20 64 61 74 20 3b 3b 20 68 61 76 65 20 61 20 6c dat ;; have a l
ae00: 6f 63 61 6c 6c 79 20 63 61 63 68 65 64 20 76 65 ocally cached ve
ae10: 72 73 69 6f 6e 0a 09 09 20 20 20 20 28 68 61 73 rsion... (has
ae20: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
ae30: 75 6c 74 20 64 61 74 20 22 68 61 76 65 20 66 75 ult dat "have fu
ae40: 6c 6c 64 61 74 61 22 20 23 66 29 29 20 3b 3b 20 lldata" #f)) ;;
ae50: 6d 61 72 6b 65 64 20 61 73 20 67 6f 6f 64 20 64 marked as good d
ae60: 61 74 61 3f 0a 09 20 20 20 20 20 20 64 61 74 0a ata?.. dat.
ae70: 09 20 20 20 20 20 20 3b 3b 20 6e 6f 20 63 61 63 . ;; no cac
ae80: 68 65 64 20 64 61 74 61 20 61 76 61 69 6c 61 62 hed data availab
ae90: 6c 65 0a 09 20 20 20 20 20 20 28 6c 65 74 2a 20 le.. (let*
aea0: 28 28 74 72 65 67 20 20 20 20 20 20 20 20 20 28 ((treg (
aeb0: 6f 72 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 or test-registry
aec0: 0a 09 09 09 09 20 20 20 20 20 20 20 28 74 65 73 ..... (tes
aed0: 74 73 3a 67 65 74 2d 61 6c 6c 29 29 29 0a 09 09 ts:get-all)))...
aee0: 20 20 20 20 20 28 74 65 73 74 2d 70 61 74 68 20 (test-path
aef0: 20 20 20 28 6f 72 20 28 68 61 73 68 2d 74 61 62 (or (hash-tab
af00: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 le-ref/default t
af10: 72 65 67 20 74 65 73 74 2d 6e 61 6d 65 20 23 66 reg test-name #f
af20: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
af30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
af40: 20 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 (let* (
af50: 28 6c 6f 63 61 6c 2d 74 63 64 69 72 20 28 63 6f (local-tcdir (co
af60: 6e 63 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d nc (get-environm
af70: 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 4d 54 ent-variable "MT
af80: 5f 4c 49 4e 4b 54 52 45 45 22 29 20 22 2f 22 0a _LINKTREE") "/".
af90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
afa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
afb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
afc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
afd0: 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e (get-environmen
afe0: 74 2d 76 61 72 69 61 62 6c 65 20 22 4d 54 5f 54 t-variable "MT_T
aff0: 41 52 47 45 54 22 29 20 22 2f 22 0a 20 20 20 20 ARGET") "/".
b000: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b010: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b020: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b030: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 67 65 (ge
b040: 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 t-environment-va
b050: 72 69 61 62 6c 65 20 22 4d 54 5f 52 55 4e 4e 41 riable "MT_RUNNA
b060: 4d 45 22 29 20 22 2f 22 0a 20 20 20 20 20 20 20 ME") "/".
b070: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b080: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b090: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b0a0: 20 20 20 20 20 20 20 20 20 20 74 65 73 74 2d 6e test-n
b0b0: 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 ame "/" item-pat
b0c0: 68 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 h)).
b0d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b0e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b0f0: 20 20 28 6c 6f 63 61 6c 2d 74 63 66 67 20 28 63 (local-tcfg (c
b100: 6f 6e 63 20 6c 6f 63 61 6c 2d 74 63 64 69 72 20 onc local-tcdir
b110: 22 2f 74 65 73 74 63 6f 6e 66 69 67 22 29 29 29 "/testconfig")))
b120: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
b130: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b140: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 63 (if (c
b150: 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 ommon:file-exist
b160: 73 3f 20 6c 6f 63 61 6c 2d 74 63 66 67 29 0a 20 s? local-tcfg).
b170: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b180: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b190: 20 20 20 20 20 20 20 20 20 20 20 20 6c 6f 63 61 loca
b1a0: 6c 2d 74 63 64 69 72 0a 20 20 20 20 20 20 20 20 l-tcdir.
b1b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b1c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b1d0: 20 20 20 20 20 23 66 29 29 0a 09 09 09 09 20 20 #f)).....
b1e0: 20 20 20 20 20 28 63 6f 6e 63 20 2a 74 6f 70 70 (conc *topp
b1f0: 61 74 68 2a 20 22 2f 74 65 73 74 73 2f 22 20 74 ath* "/tests/" t
b200: 65 73 74 2d 6e 61 6d 65 29 29 29 0a 09 09 20 20 est-name)))...
b210: 20 20 20 28 74 65 73 74 2d 63 6f 6e 66 69 67 66 (test-configf
b220: 20 28 63 6f 6e 63 20 74 65 73 74 2d 70 61 74 68 (conc test-path
b230: 20 22 2f 74 65 73 74 63 6f 6e 66 69 67 22 29 29 "/testconfig"))
b240: 0a 09 09 20 20 20 20 20 28 74 65 73 74 65 78 69 ... (testexi
b250: 73 74 73 20 20 20 28 6c 65 74 20 6c 6f 6f 70 61 sts (let loopa
b260: 20 28 28 74 72 69 65 73 2d 6c 65 66 74 20 33 30 ((tries-left 30
b270: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
b280: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b290: 20 20 20 20 20 20 20 20 28 63 6f 6e 64 0a 20 20 (cond.
b2a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b2b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b2c0: 20 20 20 20 28 0a 20 20 20 20 20 20 20 20 20 20 (.
b2d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b2e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 61 6e (an
b2f0: 64 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 d (common:file-e
b300: 78 69 73 74 73 3f 20 74 65 73 74 2d 63 6f 6e 66 xists? test-conf
b310: 69 67 66 29 28 66 69 6c 65 2d 72 65 61 64 61 62 igf)(file-readab
b320: 6c 65 3f 20 74 65 73 74 2d 63 6f 6e 66 69 67 66 le? test-configf
b330: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
b340: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b350: 20 20 20 20 20 20 20 20 20 20 23 74 29 0a 20 20 #t).
b360: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b370: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b380: 20 20 20 20 28 0a 20 20 20 20 20 20 20 20 20 20 (.
b390: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b3a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f (co
b3b0: 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 mmon:file-exists
b3c0: 3f 20 74 65 73 74 2d 63 6f 6e 66 69 67 66 29 0a ? test-configf).
b3d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b3e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b3f0: 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 (debug:pr
b400: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
b410: 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e og-port* "WARNIN
b420: 47 3a 20 43 61 6e 6e 6f 74 20 72 65 61 64 20 74 G: Cannot read t
b430: 65 73 74 63 6f 6e 66 69 67 20 66 69 6c 65 3a 20 estconfig file:
b440: 22 74 65 73 74 2d 63 6f 6e 66 69 67 66 29 0a 20 "test-configf).
b450: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b460: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b470: 20 20 20 20 20 20 23 66 29 0a 20 20 20 20 20 20 #f).
b480: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b490: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b4a0: 28 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 (.
b4b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b4c0: 20 20 20 20 20 20 20 20 20 28 61 6e 64 20 77 61 (and wa
b4d0: 69 74 2d 61 2d 6d 69 6e 75 74 65 20 28 3e 20 74 it-a-minute (> t
b4e0: 72 69 65 73 2d 6c 65 66 74 20 30 29 29 0a 20 20 ries-left 0)).
b4f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b500: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b510: 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 (thread-sle
b520: 65 70 21 20 31 30 29 0a 20 20 20 20 20 20 20 20 ep! 10).
b530: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b540: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
b550: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
b560: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
b570: 20 22 57 41 52 4e 49 4e 47 3a 20 74 65 73 74 63 "WARNING: testc
b580: 6f 6e 66 69 67 20 66 69 6c 65 20 64 6f 65 73 20 onfig file does
b590: 6e 6f 74 20 65 78 69 73 74 3a 20 22 74 65 73 74 not exist: "test
b5a0: 2d 63 6f 6e 66 69 67 66 22 20 77 69 6c 6c 20 72 -configf" will r
b5b0: 65 74 72 79 20 69 6e 20 31 30 20 73 65 63 6f 6e etry in 10 secon
b5c0: 64 73 2e 20 20 54 72 69 65 73 20 6c 65 66 74 3a ds. Tries left:
b5d0: 20 22 74 72 69 65 73 2d 6c 65 66 74 29 20 3b 3b "tries-left) ;;
b5e0: 20 42 42 3a 20 74 68 69 73 20 66 69 72 65 73 0a BB: this fires.
b5f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b600: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b610: 20 20 20 20 20 20 20 28 6c 6f 6f 70 61 20 28 73 (loopa (s
b620: 75 62 31 20 74 72 69 65 73 2d 6c 65 66 74 29 29 ub1 tries-left))
b630: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
b640: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b650: 20 20 20 20 20 20 20 20 28 65 6c 73 65 0a 20 20 (else.
b660: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b670: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b680: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
b690: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
b6a0: 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a -port* "WARNING:
b6b0: 20 74 65 73 74 63 6f 6e 66 69 67 20 66 69 6c 65 testconfig file
b6c0: 20 64 6f 65 73 20 6e 6f 74 20 65 78 69 73 74 3a does not exist:
b6d0: 20 22 74 65 73 74 2d 63 6f 6e 66 69 67 66 29 20 "test-configf)
b6e0: 3b 3b 20 42 42 3a 20 74 68 69 73 20 66 69 72 65 ;; BB: this fire
b6f0: 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 s.
b700: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b710: 20 20 20 20 20 20 20 20 20 23 66 29 29 29 29 0a #f)))).
b720: 09 09 20 20 20 20 20 28 74 63 66 67 20 20 20 20 .. (tcfg
b730: 20 20 20 20 20 28 69 66 20 74 65 73 74 65 78 69 (if testexi
b740: 73 74 73 0a 09 09 09 09 20 20 20 20 20 20 20 28 sts..... (
b750: 63 6f 6e 66 69 67 66 3a 72 65 61 64 2d 63 6f 6e configf:read-con
b760: 66 69 67 20 74 65 73 74 2d 63 6f 6e 66 69 67 66 fig test-configf
b770: 20 23 66 20 73 79 73 74 65 6d 2d 61 6c 6c 6f 77 #f system-allow
b780: 65 64 0a 09 09 09 09 09 09 20 20 20 20 65 6e 76 ed....... env
b790: 69 72 6f 6e 2d 70 61 74 74 3a 20 28 69 66 20 73 iron-patt: (if s
b7a0: 79 73 74 65 6d 2d 61 6c 6c 6f 77 65 64 0a 09 09 ystem-allowed...
b7b0: 09 09 09 09 09 09 20 20 20 20 20 20 22 70 72 65 ...... "pre
b7c0: 2d 6c 61 75 6e 63 68 2d 65 6e 76 2d 76 61 72 73 -launch-env-vars
b7d0: 22 0a 09 09 09 09 09 09 09 09 20 20 20 20 20 20 ".........
b7e0: 23 66 29 0a 09 09 09 09 09 09 20 20 20 20 65 6e #f)....... en
b7f0: 76 2d 74 6f 2d 75 73 65 3a 20 28 6d 6f 64 75 6c v-to-use: (modul
b800: 65 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 20 27 62 e-environment 'b
b810: 69 67 6d 6f 64 29 29 0a 09 09 09 09 20 20 20 20 igmod)).....
b820: 20 20 20 23 66 29 29 29 0a 09 09 28 69 66 20 28 #f)))...(if (
b830: 61 6e 64 20 74 63 66 67 20 63 61 63 68 65 2d 66 and tcfg cache-f
b840: 69 6c 65 29 20 28 68 61 73 68 2d 74 61 62 6c 65 ile) (hash-table
b850: 2d 73 65 74 21 20 74 63 66 67 20 22 68 61 76 65 -set! tcfg "have
b860: 20 66 75 6c 6c 64 61 74 61 22 20 23 74 29 29 20 fulldata" #t))
b870: 3b 3b 20 6d 61 72 6b 20 74 68 69 73 20 61 73 20 ;; mark this as
b880: 66 75 6c 6c 79 20 72 65 61 64 20 64 61 74 61 0a fully read data.
b890: 09 09 28 69 66 20 74 63 66 67 20 28 68 61 73 68 ..(if tcfg (hash
b8a0: 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a 74 65 73 -table-set! *tes
b8b0: 74 63 6f 6e 66 69 67 73 2a 20 74 65 73 74 2d 66 tconfigs* test-f
b8c0: 75 6c 6c 2d 6e 61 6d 65 20 74 63 66 67 29 29 0a ull-name tcfg)).
b8d0: 09 09 28 69 66 20 28 61 6e 64 20 74 65 73 74 65 ..(if (and teste
b8e0: 78 69 73 74 73 0a 09 09 09 20 63 61 63 68 65 2d xists.... cache-
b8f0: 66 69 6c 65 0a 09 09 09 20 28 61 6e 64 20 28 66 file.... (and (f
b900: 69 6c 65 2d 65 78 69 73 74 73 3f 20 63 61 63 68 ile-exists? cach
b910: 65 2d 70 61 74 68 29 0a 09 09 09 20 20 20 20 20 e-path)....
b920: 20 28 66 69 6c 65 2d 77 72 69 74 61 62 6c 65 3f (file-writable?
b930: 20 63 61 63 68 65 2d 70 61 74 68 29 29 0a 09 09 cache-path))...
b940: 09 20 61 6c 6c 6f 77 2d 77 72 69 74 65 2d 63 61 . allow-write-ca
b950: 63 68 65 29 0a 09 09 20 20 20 20 28 6c 65 74 20 che)... (let
b960: 28 28 74 70 61 74 68 20 28 63 6f 6e 63 20 63 61 ((tpath (conc ca
b970: 63 68 65 2d 70 61 74 68 20 22 2f 2e 74 65 73 74 che-path "/.test
b980: 63 6f 6e 66 69 67 22 29 29 29 0a 09 09 20 20 20 config")))...
b990: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
b9a0: 69 6e 66 6f 20 31 20 2a 64 65 66 61 75 6c 74 2d info 1 *default-
b9b0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 43 61 63 68 69 log-port* "Cachi
b9c0: 6e 67 20 74 65 73 74 63 6f 6e 66 69 67 20 66 6f ng testconfig fo
b9d0: 72 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 r " test-name "
b9e0: 69 6e 20 22 20 74 70 61 74 68 29 0a 20 20 20 20 in " tpath).
b9f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ba00: 20 20 28 69 66 20 28 61 6e 64 20 74 63 66 67 20 (if (and tcfg
ba10: 28 6e 6f 74 20 28 63 6f 6d 6d 6f 6e 3a 69 6e 2d (not (common:in-
ba20: 72 75 6e 6e 69 6e 67 2d 74 65 73 74 3f 29 29 29 running-test?)))
ba30: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
ba40: 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 66 (conf
ba50: 69 67 66 3a 77 72 69 74 65 2d 61 6c 69 73 74 20 igf:write-alist
ba60: 74 63 66 67 20 74 70 61 74 68 29 29 29 29 0a 09 tcfg tpath))))..
ba70: 09 74 63 66 67 29 29 29 29 29 29 0a 20 20 0a 3b .tcfg)))))). .;
ba80: 3b 20 73 6f 72 74 20 74 65 73 74 73 20 62 79 20 ; sort tests by
ba90: 70 72 69 6f 72 69 74 79 20 61 6e 64 20 77 61 69 priority and wai
baa0: 74 6f 6e 0a 3b 3b 20 4d 6f 76 65 20 74 65 73 74 ton.;; Move test
bab0: 20 73 70 65 63 69 66 69 63 20 73 74 75 66 66 20 specific stuff
bac0: 74 6f 20 61 20 74 65 73 74 20 75 6e 69 74 20 46 to a test unit F
bad0: 49 58 4d 45 20 6f 6e 65 20 6f 66 20 74 68 65 73 IXME one of thes
bae0: 65 20 64 61 79 73 0a 28 64 65 66 69 6e 65 20 28 e days.(define (
baf0: 74 65 73 74 73 3a 73 6f 72 74 2d 62 79 2d 70 72 tests:sort-by-pr
bb00: 69 6f 72 69 74 79 2d 61 6e 64 2d 77 61 69 74 6f iority-and-waito
bb10: 6e 20 74 65 73 74 2d 72 65 63 6f 72 64 73 29 0a n test-records).
bb20: 20 20 28 69 66 20 28 65 71 3f 20 28 68 61 73 68 (if (eq? (hash
bb30: 2d 74 61 62 6c 65 2d 73 69 7a 65 20 74 65 73 74 -table-size test
bb40: 2d 72 65 63 6f 72 64 73 29 20 30 29 0a 20 20 20 -records) 0).
bb50: 20 20 20 27 28 29 0a 20 20 20 20 20 20 28 6c 65 '(). (le
bb60: 74 2a 20 28 28 6d 75 6e 67 65 70 72 69 6f 72 69 t* ((mungepriori
bb70: 74 79 20 28 6c 61 6d 62 64 61 20 28 70 72 69 6f ty (lambda (prio
bb80: 72 69 74 79 29 0a 09 09 09 20 20 20 20 20 20 28 rity).... (
bb90: 69 66 20 70 72 69 6f 72 69 74 79 0a 09 09 09 09 if priority.....
bba0: 20 20 28 6c 65 74 20 28 28 74 6d 70 20 28 61 6e (let ((tmp (an
bbb0: 79 2d 3e 6e 75 6d 62 65 72 20 70 72 69 6f 72 69 y->number priori
bbc0: 74 79 29 29 29 0a 09 09 09 09 20 20 20 20 28 69 ty)))..... (i
bbd0: 66 20 74 6d 70 20 74 6d 70 20 28 62 65 67 69 6e f tmp tmp (begin
bbe0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 (debug:print-er
bbf0: 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c ror 0 *default-l
bc00: 6f 67 2d 70 6f 72 74 2a 20 22 62 61 64 20 70 72 og-port* "bad pr
bc10: 69 6f 72 69 74 79 20 76 61 6c 75 65 20 22 20 70 iority value " p
bc20: 72 69 6f 72 69 74 79 20 22 2c 20 75 73 69 6e 67 riority ", using
bc30: 20 30 22 29 20 30 29 29 29 0a 09 09 09 09 20 20 0") 0))).....
bc40: 30 29 29 29 0a 09 20 20 20 20 20 28 61 6c 6c 2d 0))).. (all-
bc50: 74 65 73 74 73 20 20 20 20 20 20 28 68 61 73 68 tests (hash
bc60: 2d 74 61 62 6c 65 2d 6b 65 79 73 20 74 65 73 74 -table-keys test
bc70: 2d 72 65 63 6f 72 64 73 29 29 0a 09 20 20 20 20 -records))..
bc80: 20 28 61 6c 6c 2d 77 61 69 74 65 64 2d 6f 6e 20 (all-waited-on
bc90: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 (let loop ((hed
bca0: 20 28 63 61 72 20 61 6c 6c 2d 74 65 73 74 73 29 (car all-tests)
bcb0: 29 0a 09 09 09 09 09 28 74 61 6c 20 28 63 64 72 )......(tal (cdr
bcc0: 20 61 6c 6c 2d 74 65 73 74 73 29 29 0a 09 09 09 all-tests))....
bcd0: 09 09 28 72 65 73 20 27 28 29 29 29 0a 09 09 09 ..(res '()))....
bce0: 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 (let* ((t
bcf0: 72 65 63 20 20 20 20 28 68 61 73 68 2d 74 61 62 rec (hash-tab
bd00: 6c 65 2d 72 65 66 20 74 65 73 74 2d 72 65 63 6f le-ref test-reco
bd10: 72 64 73 20 68 65 64 29 29 0a 09 09 09 09 20 20 rds hed)).....
bd20: 20 20 20 20 28 77 61 69 74 6f 6e 73 20 28 6f 72 (waitons (or
bd30: 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 (tests:testqueu
bd40: 65 2d 67 65 74 2d 77 61 69 74 6f 6e 73 20 74 72 e-get-waitons tr
bd50: 65 63 29 20 27 28 29 29 29 29 0a 09 09 09 09 20 ec) '()))).....
bd60: 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a (if (null? tal).
bd70: 09 09 09 09 20 20 20 20 20 28 61 70 70 65 6e 64 .... (append
bd80: 20 72 65 73 20 77 61 69 74 6f 6e 73 29 0a 09 09 res waitons)...
bd90: 09 09 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 .. (loop (ca
bda0: 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 28 r tal)(cdr tal)(
bdb0: 61 70 70 65 6e 64 20 72 65 73 20 77 61 69 74 6f append res waito
bdc0: 6e 73 29 29 29 29 29 29 0a 09 20 20 20 20 20 28 ns)))))).. (
bdd0: 73 6f 72 74 2d 66 6e 31 20 0a 09 20 20 20 20 20 sort-fn1 ..
bde0: 20 28 6c 61 6d 62 64 61 20 28 61 20 62 29 0a 09 (lambda (a b)..
bdf0: 09 28 6c 65 74 2a 20 28 28 61 2d 72 65 63 6f 72 .(let* ((a-recor
be00: 64 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d d (hash-table-
be10: 72 65 66 20 74 65 73 74 2d 72 65 63 6f 72 64 73 ref test-records
be20: 20 61 29 29 0a 09 09 20 20 20 20 20 20 20 28 62 a))... (b
be30: 2d 72 65 63 6f 72 64 20 20 20 28 68 61 73 68 2d -record (hash-
be40: 74 61 62 6c 65 2d 72 65 66 20 74 65 73 74 2d 72 table-ref test-r
be50: 65 63 6f 72 64 73 20 62 29 29 0a 09 09 20 20 20 ecords b))...
be60: 20 20 20 20 28 61 2d 77 61 69 74 6f 6e 73 20 20 (a-waitons
be70: 28 6f 72 20 28 74 65 73 74 73 3a 74 65 73 74 71 (or (tests:testq
be80: 75 65 75 65 2d 67 65 74 2d 77 61 69 74 6f 6e 73 ueue-get-waitons
be90: 20 61 2d 72 65 63 6f 72 64 29 20 27 28 29 29 29 a-record) '()))
bea0: 0a 09 09 20 20 20 20 20 20 20 28 62 2d 77 61 69 ... (b-wai
beb0: 74 6f 6e 73 20 20 28 6f 72 20 28 74 65 73 74 73 tons (or (tests
bec0: 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 77 :testqueue-get-w
bed0: 61 69 74 6f 6e 73 20 62 2d 72 65 63 6f 72 64 29 aitons b-record)
bee0: 20 27 28 29 29 29 0a 09 09 20 20 20 20 20 20 20 '()))...
bef0: 28 61 2d 63 6f 6e 66 69 67 20 20 20 28 74 65 73 (a-config (tes
bf00: 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 ts:testqueue-get
bf10: 2d 74 65 73 74 63 6f 6e 66 69 67 20 20 61 2d 72 -testconfig a-r
bf20: 65 63 6f 72 64 29 29 0a 09 09 20 20 20 20 20 20 ecord))...
bf30: 20 28 62 2d 63 6f 6e 66 69 67 20 20 20 28 74 65 (b-config (te
bf40: 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 sts:testqueue-ge
bf50: 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 20 62 2d t-testconfig b-
bf60: 72 65 63 6f 72 64 29 29 0a 09 09 20 20 20 20 20 record))...
bf70: 20 20 28 61 2d 72 61 77 2d 70 72 69 20 20 28 63 (a-raw-pri (c
bf80: 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 61 2d onfigf:lookup a-
bf90: 63 6f 6e 66 69 67 20 22 72 65 71 75 69 72 65 6d config "requirem
bfa0: 65 6e 74 73 22 20 22 70 72 69 6f 72 69 74 79 22 ents" "priority"
bfb0: 29 29 0a 09 09 20 20 20 20 20 20 20 28 62 2d 72 ))... (b-r
bfc0: 61 77 2d 70 72 69 20 20 28 63 6f 6e 66 69 67 66 aw-pri (configf
bfd0: 3a 6c 6f 6f 6b 75 70 20 62 2d 63 6f 6e 66 69 67 :lookup b-config
bfe0: 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 22 20 "requirements"
bff0: 22 70 72 69 6f 72 69 74 79 22 29 29 0a 09 09 20 "priority"))...
c000: 20 20 20 20 20 20 28 61 2d 70 72 69 6f 72 69 74 (a-priorit
c010: 79 20 28 6d 75 6e 67 65 70 72 69 6f 72 69 74 79 y (mungepriority
c020: 20 61 2d 72 61 77 2d 70 72 69 29 29 0a 09 09 20 a-raw-pri))...
c030: 20 20 20 20 20 20 28 62 2d 70 72 69 6f 72 69 74 (b-priorit
c040: 79 20 28 6d 75 6e 67 65 70 72 69 6f 72 69 74 79 y (mungepriority
c050: 20 62 2d 72 61 77 2d 70 72 69 29 29 29 0a 09 09 b-raw-pri)))...
c060: 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 (tests:testque
c070: 75 65 2d 73 65 74 2d 70 72 69 6f 72 69 74 79 21 ue-set-priority!
c080: 20 61 2d 72 65 63 6f 72 64 20 61 2d 70 72 69 6f a-record a-prio
c090: 72 69 74 79 29 0a 09 09 20 20 28 74 65 73 74 73 rity)... (tests
c0a0: 3a 74 65 73 74 71 75 65 75 65 2d 73 65 74 2d 70 :testqueue-set-p
c0b0: 72 69 6f 72 69 74 79 21 20 62 2d 72 65 63 6f 72 riority! b-recor
c0c0: 64 20 62 2d 70 72 69 6f 72 69 74 79 29 0a 09 09 d b-priority)...
c0d0: 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e ;; (debug:prin
c0e0: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
c0f0: 2d 70 6f 72 74 2a 20 22 61 3d 22 20 61 20 22 2c -port* "a=" a ",
c100: 20 62 3d 22 20 62 20 22 2c 20 61 2d 77 61 69 74 b=" b ", a-wait
c110: 6f 6e 73 3d 22 20 61 2d 77 61 69 74 6f 6e 73 20 ons=" a-waitons
c120: 22 2c 20 62 2d 77 61 69 74 6f 6e 73 3d 22 20 62 ", b-waitons=" b
c130: 2d 77 61 69 74 6f 6e 73 29 0a 09 09 20 20 28 63 -waitons)... (c
c140: 6f 6e 64 0a 09 09 20 20 20 3b 3b 20 69 73 20 0a ond... ;; is .
c150: 09 09 20 20 20 28 28 6d 65 6d 62 65 72 20 61 20 .. ((member a
c160: 62 2d 77 61 69 74 6f 6e 73 29 20 20 20 20 20 20 b-waitons)
c170: 20 20 20 20 3b 3b 20 69 73 20 62 20 77 61 69 74 ;; is b wait
c180: 69 6e 67 20 6f 6e 20 61 3f 0a 09 09 20 20 20 20 ing on a?...
c190: 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 ;; (debug:print
c1a0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
c1b0: 6f 72 74 2a 20 22 63 61 73 65 31 22 29 0a 09 09 ort* "case1")...
c1c0: 20 20 20 20 23 74 29 0a 09 09 20 20 20 28 28 6d #t)... ((m
c1d0: 65 6d 62 65 72 20 62 20 61 2d 77 61 69 74 6f 6e ember b a-waiton
c1e0: 73 29 20 20 20 20 20 20 20 20 20 20 3b 3b 20 69 s) ;; i
c1f0: 73 20 61 20 77 61 69 74 69 6e 67 20 6f 6e 20 62 s a waiting on b
c200: 3f 0a 09 09 20 20 20 20 3b 3b 20 28 64 65 62 75 ?... ;; (debu
c210: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
c220: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 63 61 lt-log-port* "ca
c230: 73 65 32 22 29 0a 09 09 20 20 20 20 23 66 29 0a se2")... #f).
c240: 09 09 20 20 20 28 28 61 6e 64 20 28 6e 6f 74 20 .. ((and (not
c250: 28 6e 75 6c 6c 3f 20 61 2d 77 61 69 74 6f 6e 73 (null? a-waitons
c260: 29 29 20 20 3b 3b 20 62 6f 74 68 20 68 61 76 65 )) ;; both have
c270: 20 77 61 69 74 6f 6e 73 20 2d 20 64 6f 20 6e 6f waitons - do no
c280: 74 20 64 69 73 74 75 72 62 0a 09 09 09 20 28 6e t disturb.... (n
c290: 6f 74 20 28 6e 75 6c 6c 3f 20 62 2d 77 61 69 74 ot (null? b-wait
c2a0: 6f 6e 73 29 29 29 0a 09 09 20 20 20 20 3b 3b 20 ons)))... ;;
c2b0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
c2c0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
c2d0: 2a 20 22 63 61 73 65 32 2e 31 22 29 0a 09 09 20 * "case2.1")...
c2e0: 20 20 20 23 74 29 0a 09 09 20 20 20 28 28 61 6e #t)... ((an
c2f0: 64 20 28 6e 75 6c 6c 3f 20 61 2d 77 61 69 74 6f d (null? a-waito
c300: 6e 73 29 20 20 20 20 20 20 20 20 3b 3b 20 6e 6f ns) ;; no
c310: 20 77 61 69 74 6f 6e 73 20 66 6f 72 20 61 20 62 waitons for a b
c320: 75 74 20 62 20 68 61 73 20 77 61 69 74 6f 6e 73 ut b has waitons
c330: 0a 09 09 09 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f .... (not (null?
c340: 20 62 2d 77 61 69 74 6f 6e 73 29 29 29 0a 09 09 b-waitons)))...
c350: 20 20 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 ;; (debug:pr
c360: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
c370: 6f 67 2d 70 6f 72 74 2a 20 22 63 61 73 65 33 22 og-port* "case3"
c380: 29 0a 09 09 20 20 20 20 23 66 29 0a 09 09 20 20 )... #f)...
c390: 20 28 28 61 6e 64 20 28 6e 6f 74 20 28 6e 75 6c ((and (not (nul
c3a0: 6c 3f 20 61 2d 77 61 69 74 6f 6e 73 29 29 20 20 l? a-waitons))
c3b0: 3b 3b 20 61 20 68 61 73 20 77 61 69 74 6f 6e 73 ;; a has waitons
c3c0: 20 62 75 74 20 62 20 64 6f 65 73 20 6e 6f 74 0a but b does not.
c3d0: 09 09 09 20 28 6e 75 6c 6c 3f 20 62 2d 77 61 69 ... (null? b-wai
c3e0: 74 6f 6e 73 29 29 20 0a 09 09 20 20 20 20 3b 3b tons)) ... ;;
c3f0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
c400: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
c410: 74 2a 20 22 63 61 73 65 34 22 29 0a 09 09 20 20 t* "case4")...
c420: 20 20 23 74 29 0a 09 09 20 20 20 28 28 6e 6f 74 #t)... ((not
c430: 20 28 65 71 3f 20 61 2d 70 72 69 6f 72 69 74 79 (eq? a-priority
c440: 20 62 2d 70 72 69 6f 72 69 74 79 29 29 20 3b 3b b-priority)) ;;
c450: 20 75 73 65 0a 09 09 20 20 20 20 28 3e 20 61 2d use... (> a-
c460: 70 72 69 6f 72 69 74 79 20 62 2d 70 72 69 6f 72 priority b-prior
c470: 69 74 79 29 29 0a 09 09 20 20 20 28 65 6c 73 65 ity))... (else
c480: 0a 09 09 20 20 20 20 3b 3b 20 28 64 65 62 75 67 ... ;; (debug
c490: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
c4a0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 63 61 73 t-log-port* "cas
c4b0: 65 35 22 29 0a 09 09 20 20 20 20 28 73 74 72 69 e5")... (stri
c4c0: 6e 67 3e 3f 20 61 20 62 29 29 29 29 29 29 0a 09 ng>? a b))))))..
c4d0: 20 20 20 20 20 0a 09 20 20 20 20 20 28 73 6f 72 .. (sor
c4e0: 74 2d 66 6e 32 0a 09 20 20 20 20 20 20 28 6c 61 t-fn2.. (la
c4f0: 6d 62 64 61 20 28 61 20 62 29 0a 09 09 28 3e 20 mbda (a b)...(>
c500: 28 6d 75 6e 67 65 70 72 69 6f 72 69 74 79 20 28 (mungepriority (
c510: 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d tests:testqueue-
c520: 67 65 74 2d 70 72 69 6f 72 69 74 79 20 28 68 61 get-priority (ha
c530: 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 74 65 73 sh-table-ref tes
c540: 74 2d 72 65 63 6f 72 64 73 20 61 29 29 29 0a 09 t-records a)))..
c550: 09 20 20 20 28 6d 75 6e 67 65 70 72 69 6f 72 69 . (mungepriori
c560: 74 79 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 ty (tests:testqu
c570: 65 75 65 2d 67 65 74 2d 70 72 69 6f 72 69 74 79 eue-get-priority
c580: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
c590: 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 62 29 test-records b)
c5a0: 29 29 29 29 29 29 0a 09 3b 3b 20 28 6c 65 74 20 ))))))..;; (let
c5b0: 28 28 64 6f 74 2d 72 65 73 20 28 74 65 73 74 73 ((dot-res (tests
c5c0: 3a 72 75 6e 2d 64 6f 74 20 28 74 65 73 74 73 3a :run-dot (tests:
c5d0: 74 65 73 74 73 2d 3e 64 6f 74 20 74 65 73 74 2d tests->dot test-
c5e0: 72 65 63 6f 72 64 73 29 20 22 70 6c 61 69 6e 22 records) "plain"
c5f0: 29 29 29 0a 09 3b 3b 20 20 20 28 64 65 62 75 67 )))..;; (debug
c600: 3a 70 72 69 6e 74 20 22 64 6f 74 2d 72 65 73 3d :print "dot-res=
c610: 22 20 64 6f 74 2d 72 65 73 29 29 0a 09 3b 3b 20 " dot-res))..;;
c620: 28 6c 65 74 20 28 28 64 61 74 61 20 28 6d 61 70 (let ((data (map
c630: 20 63 64 72 20 28 66 69 6c 74 65 72 0a 09 3b 3b cdr (filter..;;
c640: 20 20 20 20 20 09 09 20 20 28 6c 61 6d 62 64 61 .. (lambda
c650: 20 28 78 29 28 65 71 75 61 6c 3f 20 22 6e 6f 64 (x)(equal? "nod
c660: 65 22 20 28 63 61 72 20 78 29 29 29 0a 09 3b 3b e" (car x)))..;;
c670: 20 20 20 20 20 09 09 20 20 28 6d 61 70 20 73 74 .. (map st
c680: 72 69 6e 67 2d 73 70 6c 69 74 20 28 74 65 73 74 ring-split (test
c690: 73 3a 65 61 73 79 2d 64 6f 74 20 74 65 73 74 2d s:easy-dot test-
c6a0: 72 65 63 6f 72 64 73 20 22 70 6c 61 69 6e 22 29 records "plain")
c6b0: 29 29 29 29 29 0a 09 3b 3b 20 20 20 28 6d 61 70 )))))..;; (map
c6c0: 20 63 61 72 20 28 73 6f 72 74 20 64 61 74 61 20 car (sort data
c6d0: 28 6c 61 6d 62 64 61 20 28 61 20 62 29 0a 09 3b (lambda (a b)..;
c6e0: 3b 20 20 20 20 20 09 09 20 20 20 20 28 3e 20 28 ; .. (> (
c6f0: 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 string->number (
c700: 63 61 64 64 72 20 61 29 29 28 73 74 72 69 6e 67 caddr a))(string
c710: 2d 3e 6e 75 6d 62 65 72 20 28 63 61 64 64 72 20 ->number (caddr
c720: 62 29 29 29 29 29 29 29 0a 09 3b 3b 20 29 29 0a b)))))))..;; )).
c730: 09 28 73 6f 72 74 20 61 6c 6c 2d 74 65 73 74 73 .(sort all-tests
c740: 20 73 6f 72 74 2d 66 6e 31 29 29 29 29 20 3b 3b sort-fn1)))) ;;
c750: 20 61 76 6f 69 64 20 64 65 61 6c 69 6e 67 20 77 avoid dealing w
c760: 69 74 68 20 64 65 6c 65 74 65 64 20 74 65 73 74 ith deleted test
c770: 73 2c 20 6c 6f 6f 6b 20 61 74 20 74 68 65 20 68 s, look at the h
c780: 61 73 68 20 74 61 62 6c 65 0a 0a 28 64 65 66 69 ash table..(defi
c790: 6e 65 20 28 74 65 73 74 73 3a 65 61 73 79 2d 64 ne (tests:easy-d
c7a0: 6f 74 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 ot test-records
c7b0: 6f 75 74 74 79 70 65 29 0a 20 20 28 6c 65 74 2d outtype). (let-
c7c0: 76 61 6c 75 65 73 20 28 28 28 66 64 20 74 65 6d values (((fd tem
c7d0: 70 2d 70 61 74 68 29 20 28 66 69 6c 65 2d 6d 6b p-path) (file-mk
c7e0: 73 74 65 6d 70 20 28 63 6f 6e 63 20 22 2f 74 6d stemp (conc "/tm
c7f0: 70 2f 22 20 28 63 75 72 72 65 6e 74 2d 75 73 65 p/" (current-use
c800: 72 2d 6e 61 6d 65 29 20 22 2e 58 58 58 58 58 58 r-name) ".XXXXXX
c810: 22 29 29 29 29 0a 20 20 20 20 28 6c 65 74 20 28 ")))). (let (
c820: 28 61 6c 6c 2d 74 65 73 74 6e 61 6d 65 73 20 28 (all-testnames (
c830: 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 hash-table-keys
c840: 74 65 73 74 2d 72 65 63 6f 72 64 73 29 29 0a 09 test-records))..
c850: 20 20 28 74 65 6d 70 2d 70 6f 72 74 20 20 20 20 (temp-port
c860: 20 28 6f 70 65 6e 2d 6f 75 74 70 75 74 2d 66 69 (open-output-fi
c870: 6c 65 2a 20 66 64 29 29 29 0a 20 20 20 20 20 20 le* fd))).
c880: 3b 3b 20 28 63 68 69 63 6b 65 6e 2e 66 6f 72 6d ;; (chicken.form
c890: 61 74 23 66 6f 72 6d 61 74 20 74 65 6d 70 2d 70 at#format temp-p
c8a0: 6f 72 74 20 22 54 68 69 73 20 66 69 6c 65 20 69 ort "This file i
c8b0: 73 20 7e 41 2e 7e 25 22 20 74 65 6d 70 2d 70 61 s ~A.~%" temp-pa
c8c0: 74 68 29 0a 20 20 20 20 20 20 28 63 68 69 63 6b th). (chick
c8d0: 65 6e 2e 66 6f 72 6d 61 74 23 66 6f 72 6d 61 74 en.format#format
c8e0: 20 74 65 6d 70 2d 70 6f 72 74 20 22 64 69 67 72 temp-port "digr
c8f0: 61 70 68 20 74 65 73 74 73 20 7b 5c 6e 22 29 0a aph tests {\n").
c900: 20 20 20 20 20 20 28 63 68 69 63 6b 65 6e 2e 66 (chicken.f
c910: 6f 72 6d 61 74 23 66 6f 72 6d 61 74 20 74 65 6d ormat#format tem
c920: 70 2d 70 6f 72 74 20 22 20 20 73 69 7a 65 3d 34 p-port " size=4
c930: 2c 38 5c 6e 22 29 0a 20 20 20 20 20 20 3b 3b 20 ,8\n"). ;;
c940: 28 63 68 69 63 6b 65 6e 2e 66 6f 72 6d 61 74 23 (chicken.format#
c950: 66 6f 72 6d 61 74 20 74 65 6d 70 2d 70 6f 72 74 format temp-port
c960: 20 22 20 20 20 73 70 6c 69 6e 65 73 3d 6e 6f 6e " splines=non
c970: 65 5c 6e 22 29 0a 20 20 20 20 20 20 28 66 6f 72 e\n"). (for
c980: 2d 65 61 63 68 0a 20 20 20 20 20 20 20 28 6c 61 -each. (la
c990: 6d 62 64 61 20 28 74 65 73 74 6e 61 6d 65 29 0a mbda (testname).
c9a0: 09 20 28 6c 65 74 2a 20 28 28 74 65 73 74 72 65 . (let* ((testre
c9b0: 63 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 c (hash-table-re
c9c0: 66 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 74 f test-records t
c9d0: 65 73 74 6e 61 6d 65 29 29 0a 09 09 28 77 61 69 estname))...(wai
c9e0: 74 6f 6e 73 20 28 6f 72 20 28 74 65 73 74 73 3a tons (or (tests:
c9f0: 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 77 61 testqueue-get-wa
ca00: 69 74 6f 6e 73 20 74 65 73 74 72 65 63 29 20 27 itons testrec) '
ca10: 28 29 29 29 29 0a 09 20 20 20 28 66 6f 72 2d 65 ()))).. (for-e
ca20: 61 63 68 0a 09 20 20 20 20 28 6c 61 6d 62 64 61 ach.. (lambda
ca30: 20 28 77 61 69 74 6f 6e 29 0a 09 20 20 20 20 20 (waiton)..
ca40: 20 28 63 68 69 63 6b 65 6e 2e 66 6f 72 6d 61 74 (chicken.format
ca50: 23 66 6f 72 6d 61 74 20 74 65 6d 70 2d 70 6f 72 #format temp-por
ca60: 74 20 28 63 6f 6e 63 20 22 20 20 20 22 20 77 61 t (conc " " wa
ca70: 69 74 6f 6e 20 22 20 2d 3e 20 22 20 74 65 73 74 iton " -> " test
ca80: 6e 61 6d 65 20 22 20 5b 73 70 6c 69 6e 65 73 3d name " [splines=
ca90: 6f 72 74 68 6f 5d 5c 6e 22 29 29 29 0a 09 20 20 ortho]\n")))..
caa0: 20 20 77 61 69 74 6f 6e 73 29 29 29 0a 20 20 20 waitons))).
cab0: 20 20 20 20 61 6c 6c 2d 74 65 73 74 6e 61 6d 65 all-testname
cac0: 73 29 0a 20 20 20 20 20 20 28 63 68 69 63 6b 65 s). (chicke
cad0: 6e 2e 66 6f 72 6d 61 74 23 66 6f 72 6d 61 74 20 n.format#format
cae0: 74 65 6d 70 2d 70 6f 72 74 20 22 7d 5c 6e 22 29 temp-port "}\n")
caf0: 0a 20 20 20 20 20 20 28 63 6c 6f 73 65 2d 6f 75 . (close-ou
cb00: 74 70 75 74 2d 70 6f 72 74 20 74 65 6d 70 2d 70 tput-port temp-p
cb10: 6f 72 74 29 0a 20 20 20 20 20 20 28 77 69 74 68 ort). (with
cb20: 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 -input-from-pipe
cb30: 0a 20 20 20 20 20 20 20 28 63 6f 6e 63 20 22 65 . (conc "e
cb40: 6e 76 20 2d 69 20 50 41 54 48 3d 24 50 41 54 48 nv -i PATH=$PATH
cb50: 20 64 6f 74 20 2d 54 22 20 6f 75 74 74 79 70 65 dot -T" outtype
cb60: 20 22 20 3c 20 22 20 74 65 6d 70 2d 70 61 74 68 " < " temp-path
cb70: 29 0a 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 ). (lambda
cb80: 20 28 29 0a 09 20 28 6c 65 74 20 28 28 72 65 73 ().. (let ((res
cb90: 20 28 72 65 61 64 2d 6c 69 6e 65 73 29 29 29 0a (read-lines))).
cba0: 09 20 20 20 3b 3b 20 28 64 65 6c 65 74 65 2d 66 . ;; (delete-f
cbb0: 69 6c 65 20 74 65 6d 70 2d 70 61 74 68 29 0a 09 ile temp-path)..
cbc0: 20 20 20 72 65 73 29 29 29 29 29 29 0a 0a 28 64 res))))))..(d
cbd0: 65 66 69 6e 65 20 28 74 65 73 74 73 3a 77 72 69 efine (tests:wri
cbe0: 74 65 2d 64 6f 74 2d 66 69 6c 65 20 74 65 73 74 te-dot-file test
cbf0: 2d 72 65 63 6f 72 64 73 20 66 6e 61 6d 65 20 73 -records fname s
cc00: 69 7a 65 78 20 73 69 7a 65 79 29 0a 20 20 28 69 izex sizey). (i
cc10: 66 20 28 66 69 6c 65 2d 77 72 69 74 61 62 6c 65 f (file-writable
cc20: 3f 20 28 70 61 74 68 6e 61 6d 65 2d 64 69 72 65 ? (pathname-dire
cc30: 63 74 6f 72 79 20 66 6e 61 6d 65 29 29 0a 20 20 ctory fname)).
cc40: 20 20 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 (with-output
cc50: 2d 74 6f 2d 66 69 6c 65 20 66 6e 61 6d 65 0a 09 -to-file fname..
cc60: 28 6c 61 6d 62 64 61 20 28 29 0a 09 20 20 28 6d (lambda ().. (m
cc70: 61 70 20 70 72 69 6e 74 20 28 74 65 73 74 73 3a ap print (tests:
cc80: 74 65 73 74 73 2d 3e 64 6f 74 20 74 65 73 74 2d tests->dot test-
cc90: 72 65 63 6f 72 64 73 20 73 69 7a 65 78 20 73 69 records sizex si
cca0: 7a 65 79 29 29 29 29 29 29 0a 0a 28 64 65 66 69 zey))))))..(defi
ccb0: 6e 65 20 28 74 65 73 74 73 3a 74 65 73 74 73 2d ne (tests:tests-
ccc0: 3e 64 6f 74 20 74 65 73 74 2d 72 65 63 6f 72 64 >dot test-record
ccd0: 73 20 73 69 7a 65 78 20 73 69 7a 65 79 29 0a 20 s sizex sizey).
cce0: 20 28 6c 65 74 20 28 28 61 6c 6c 2d 74 65 73 74 (let ((all-test
ccf0: 6e 61 6d 65 73 20 28 68 61 73 68 2d 74 61 62 6c names (hash-tabl
cd00: 65 2d 6b 65 79 73 20 74 65 73 74 2d 72 65 63 6f e-keys test-reco
cd10: 72 64 73 29 29 29 0a 20 20 20 20 28 69 66 20 28 rds))). (if (
cd20: 6e 75 6c 6c 3f 20 61 6c 6c 2d 74 65 73 74 6e 61 null? all-testna
cd30: 6d 65 73 29 0a 09 27 28 29 0a 09 28 6c 65 74 20 mes)..'()..(let
cd40: 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 61 72 20 loop ((hed (car
cd50: 61 6c 6c 2d 74 65 73 74 6e 61 6d 65 73 29 29 0a all-testnames)).
cd60: 09 09 20 20 20 28 74 61 6c 20 28 63 64 72 20 61 .. (tal (cdr a
cd70: 6c 6c 2d 74 65 73 74 6e 61 6d 65 73 29 29 0a 09 ll-testnames))..
cd80: 09 20 20 20 28 72 65 73 20 28 6c 69 73 74 20 22 . (res (list "
cd90: 64 69 67 72 61 70 68 20 74 65 73 74 73 20 7b 22 digraph tests {"
cda0: 0a 09 09 09 20 20 20 20 20 20 28 63 6f 6e 63 20 .... (conc
cdb0: 22 20 73 69 7a 65 3d 5c 22 22 20 28 6f 72 20 73 " size=\"" (or s
cdc0: 69 7a 65 78 20 31 31 29 20 22 2c 22 20 28 6f 72 izex 11) "," (or
cdd0: 20 73 69 7a 65 79 20 31 31 29 20 22 5c 22 3b 22 sizey 11) "\";"
cde0: 29 0a 09 09 09 20 20 20 20 20 20 22 20 72 61 74 ).... " rat
cdf0: 69 6f 3d 30 2e 39 35 3b 22 0a 09 09 09 20 20 20 io=0.95;"....
ce00: 20 20 20 29 29 29 0a 09 20 20 28 6c 65 74 2a 20 ))).. (let*
ce10: 28 28 74 65 73 74 72 65 63 20 28 68 61 73 68 2d ((testrec (hash-
ce20: 74 61 62 6c 65 2d 72 65 66 20 74 65 73 74 2d 72 table-ref test-r
ce30: 65 63 6f 72 64 73 20 68 65 64 29 29 0a 09 09 20 ecords hed))...
ce40: 28 77 61 69 74 6f 6e 73 20 28 6f 72 20 28 74 65 (waitons (or (te
ce50: 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 sts:testqueue-ge
ce60: 74 2d 77 61 69 74 6f 6e 73 20 74 65 73 74 72 65 t-waitons testre
ce70: 63 29 20 27 28 29 29 29 0a 09 09 20 28 6e 65 77 c) '()))... (new
ce80: 72 65 73 20 20 28 61 70 70 65 6e 64 20 72 65 73 res (append res
ce90: 0a 09 09 09 09 20 20 28 69 66 20 28 6e 75 6c 6c ..... (if (null
cea0: 3f 20 77 61 69 74 6f 6e 73 29 0a 09 09 09 09 20 ? waitons).....
ceb0: 20 20 20 20 20 28 6c 69 73 74 20 28 63 6f 6e 63 (list (conc
cec0: 20 22 20 20 20 5c 22 22 20 68 65 64 20 22 5c 22 " \"" hed "\"
ced0: 20 5b 73 68 61 70 65 3d 62 6f 78 5d 3b 22 29 29 [shape=box];"))
cee0: 0a 09 09 09 09 20 20 20 20 20 20 28 6d 61 70 20 ..... (map
cef0: 28 6c 61 6d 62 64 61 20 28 77 61 69 74 6f 6e 29 (lambda (waiton)
cf00: 0a 09 09 09 09 09 20 20 20 20 20 28 63 6f 6e 63 ...... (conc
cf10: 20 22 20 20 20 5c 22 22 20 77 61 69 74 6f 6e 20 " \"" waiton
cf20: 22 5c 22 20 2d 3e 20 5c 22 22 20 68 65 64 20 22 "\" -> \"" hed "
cf30: 5c 22 20 5b 73 68 61 70 65 3d 62 6f 78 5d 3b 22 \" [shape=box];"
cf40: 29 29 0a 09 09 09 09 09 20 20 20 77 61 69 74 6f ))...... waito
cf50: 6e 73 29 0a 09 09 09 09 20 20 20 20 20 20 29 29 ns)..... ))
cf60: 29 29 0a 09 20 20 20 20 28 69 66 20 28 6e 75 6c )).. (if (nul
cf70: 6c 3f 20 74 61 6c 29 0a 09 09 28 61 70 70 65 6e l? tal)...(appen
cf80: 64 20 6e 65 77 72 65 73 20 28 6c 69 73 74 20 22 d newres (list "
cf90: 7d 22 29 29 0a 09 09 28 6c 6f 6f 70 20 28 63 61 }"))...(loop (ca
cfa0: 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 20 r tal)(cdr tal)
cfb0: 6e 65 77 72 65 73 29 0a 09 09 29 29 29 29 29 29 newres)...))))))
cfc0: 0a 0a 3b 3b 20 28 74 65 73 74 73 3a 72 75 6e 2d ..;; (tests:run-
cfd0: 64 6f 74 20 28 6c 69 73 74 20 22 64 69 67 72 61 dot (list "digra
cfe0: 70 68 20 74 65 73 74 73 20 7b 22 20 22 61 20 2d ph tests {" "a -
cff0: 3e 20 62 22 20 22 7d 22 29 20 22 70 6c 61 69 6e > b" "}") "plain
d000: 22 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 ")..(define (tes
d010: 74 73 3a 72 75 6e 2d 64 6f 74 20 69 6e 64 61 74 ts:run-dot indat
d020: 20 6f 75 74 74 79 70 65 29 20 3b 3b 20 6f 75 74 outtype) ;; out
d030: 74 79 70 65 20 69 73 20 70 6c 61 69 6e 2c 20 66 type is plain, f
d040: 69 67 2c 20 64 6f 74 2c 20 65 74 63 2e 20 68 74 ig, dot, etc. ht
d050: 74 70 3a 2f 2f 77 77 77 2e 67 72 61 70 68 76 69 tp://www.graphvi
d060: 7a 2e 6f 72 67 2f 63 6f 6e 74 65 6e 74 2f 6f 75 z.org/content/ou
d070: 74 70 75 74 2d 66 6f 72 6d 61 74 73 0a 20 20 28 tput-formats. (
d080: 6c 65 74 2d 76 61 6c 75 65 73 20 28 28 28 69 6e let-values (((in
d090: 70 20 6f 75 70 20 70 69 64 29 28 70 72 6f 63 65 p oup pid)(proce
d0a0: 73 73 20 22 65 6e 76 20 2d 69 20 50 41 54 48 3d ss "env -i PATH=
d0b0: 24 50 41 54 48 20 64 6f 74 22 20 28 6c 69 73 74 $PATH dot" (list
d0c0: 20 22 2d 54 22 20 6f 75 74 74 79 70 65 29 29 29 "-T" outtype)))
d0d0: 29 0a 20 20 20 20 28 77 69 74 68 2d 6f 75 74 70 ). (with-outp
d0e0: 75 74 2d 74 6f 2d 70 6f 72 74 20 6f 75 70 0a 20 ut-to-port oup.
d0f0: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a (lambda ().
d100: 09 28 6d 61 70 20 70 72 69 6e 74 20 69 6e 64 61 .(map print inda
d110: 74 29 29 29 0a 20 20 20 20 28 63 6c 6f 73 65 2d t))). (close-
d120: 6f 75 74 70 75 74 2d 70 6f 72 74 20 6f 75 70 29 output-port oup)
d130: 0a 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 20 . (let ((res
d140: 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d (with-input-from
d150: 2d 70 6f 72 74 20 69 6e 70 0a 09 09 20 28 6c 61 -port inp... (la
d160: 6d 62 64 61 20 28 29 0a 09 09 20 20 20 28 72 65 mbda ()... (re
d170: 61 64 2d 6c 69 6e 65 73 29 29 29 29 29 0a 20 20 ad-lines))))).
d180: 20 20 20 20 28 63 6c 6f 73 65 2d 69 6e 70 75 74 (close-input
d190: 2d 70 6f 72 74 20 69 6e 70 29 0a 20 20 20 20 20 -port inp).
d1a0: 20 72 65 73 29 29 29 0a 0a 3b 3b 20 72 65 61 64 res)))..;; read
d1b0: 20 64 61 74 61 20 66 72 6f 6d 20 74 6d 70 20 66 data from tmp f
d1c0: 69 6c 65 20 6f 72 20 63 72 65 61 74 65 20 69 66 ile or create if
d1d0: 20 6e 6f 74 20 65 78 69 73 74 73 0a 3b 3b 20 69 not exists.;; i
d1e0: 66 20 65 78 69 73 74 73 20 72 65 67 65 6e 20 69 f exists regen i
d1f0: 6e 20 62 61 63 6b 67 72 6f 75 6e 64 0a 3b 3b 0a n background.;;.
d200: 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 6c (define (tests:l
d210: 61 7a 79 2d 64 6f 74 20 74 65 73 74 72 65 63 6f azy-dot testreco
d220: 72 64 73 20 20 6f 75 74 74 79 70 65 20 73 69 7a rds outtype siz
d230: 65 78 20 73 69 7a 65 79 29 0a 20 20 28 6c 65 74 ex sizey). (let
d240: 20 28 28 64 66 69 6c 65 20 28 63 6f 6e 63 20 22 ((dfile (conc "
d250: 2f 74 6d 70 2f 2e 22 20 28 63 75 72 72 65 6e 74 /tmp/." (current
d260: 2d 75 73 65 72 2d 6e 61 6d 65 29 20 22 2d 22 20 -user-name) "-"
d270: 28 72 6d 74 3a 6d 6b 2d 73 69 67 6e 61 74 75 72 (rmt:mk-signatur
d280: 65 29 20 22 2e 64 6f 74 22 29 29 0a 09 28 66 6e e) ".dot"))..(fn
d290: 61 6d 65 20 28 63 6f 6e 63 20 22 2f 74 6d 70 2f ame (conc "/tmp/
d2a0: 2e 22 20 28 63 75 72 72 65 6e 74 2d 75 73 65 72 ." (current-user
d2b0: 2d 6e 61 6d 65 29 20 22 2d 22 20 28 72 6d 74 3a -name) "-" (rmt:
d2c0: 6d 6b 2d 73 69 67 6e 61 74 75 72 65 29 20 22 2e mk-signature) ".
d2d0: 64 6f 74 64 61 74 22 29 29 29 0a 20 20 20 20 28 dotdat"))). (
d2e0: 74 65 73 74 73 3a 77 72 69 74 65 2d 64 6f 74 2d tests:write-dot-
d2f0: 66 69 6c 65 20 74 65 73 74 72 65 63 6f 72 64 73 file testrecords
d300: 20 64 66 69 6c 65 20 73 69 7a 65 78 20 73 69 7a dfile sizex siz
d310: 65 79 29 0a 20 20 20 20 28 69 66 20 28 63 6f 6d ey). (if (com
d320: 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f mon:file-exists?
d330: 20 66 6e 61 6d 65 29 0a 09 28 6c 65 74 20 28 28 fname)..(let ((
d340: 72 65 73 20 28 77 69 74 68 2d 69 6e 70 75 74 2d res (with-input-
d350: 66 72 6f 6d 2d 66 69 6c 65 20 66 6e 61 6d 65 0a from-file fname.
d360: 09 09 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 .. (lambda (
d370: 29 0a 09 09 20 20 20 20 20 20 20 28 72 65 61 64 )... (read
d380: 2d 6c 69 6e 65 73 29 29 29 29 29 0a 09 20 20 28 -lines))))).. (
d390: 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 65 6e system (conc "en
d3a0: 76 20 2d 69 20 50 41 54 48 3d 24 50 41 54 48 20 v -i PATH=$PATH
d3b0: 64 6f 74 20 2d 54 20 22 20 6f 75 74 74 79 70 65 dot -T " outtype
d3c0: 20 22 20 3c 20 22 20 64 66 69 6c 65 20 22 20 3e " < " dfile " >
d3d0: 20 22 20 66 6e 61 6d 65 20 22 26 22 29 29 0a 09 " fname "&"))..
d3e0: 20 20 72 65 73 29 0a 09 28 62 65 67 69 6e 0a 09 res)..(begin..
d3f0: 20 20 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 (system (conc
d400: 22 65 6e 76 20 2d 69 20 50 41 54 48 3d 24 50 41 "env -i PATH=$PA
d410: 54 48 20 64 6f 74 20 2d 54 20 22 20 6f 75 74 74 TH dot -T " outt
d420: 79 70 65 20 22 20 3c 20 22 20 64 66 69 6c 65 20 ype " < " dfile
d430: 22 20 3e 20 22 20 66 6e 61 6d 65 29 29 0a 09 20 " > " fname))..
d440: 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f (with-input-fro
d450: 6d 2d 66 69 6c 65 20 66 6e 61 6d 65 0a 09 20 20 m-file fname..
d460: 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 20 20 (lambda ()..
d470: 20 20 20 20 28 72 65 61 64 2d 6c 69 6e 65 73 29 (read-lines)
d480: 29 29 29 29 29 29 0a 09 20 20 0a 0a 3b 3b 3d 3d )))))).. ..;;==
d490: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d4a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d4b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d4c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d4d0: 3d 3d 3d 3d 0a 3b 3b 20 72 65 66 61 63 74 6f 72 ====.;; refactor
d4e0: 69 6e 67 20 74 68 69 73 20 62 6c 6f 63 6b 20 69 ing this block i
d4f0: 6e 74 6f 20 74 65 73 74 73 3a 67 65 74 2d 66 75 nto tests:get-fu
d500: 6c 6c 2d 64 61 74 61 20 66 72 6f 6d 20 6c 69 6e ll-data from lin
d510: 65 20 32 36 33 20 6f 66 20 72 75 6e 73 2e 73 63 e 263 of runs.sc
d520: 6d 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d m.;;============
d530: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d540: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d550: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d560: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 68 65 ==========.;; he
d570: 64 20 69 73 20 74 68 65 20 74 65 73 74 20 6e 61 d is the test na
d580: 6d 65 0a 3b 3b 20 74 65 73 74 2d 72 65 63 6f 72 me.;; test-recor
d590: 64 73 20 69 73 20 61 20 68 61 73 68 20 6f 66 20 ds is a hash of
d5a0: 74 65 73 74 2d 6e 61 6d 65 20 3d 3e 20 74 65 73 test-name => tes
d5b0: 74 20 72 65 63 6f 72 64 0a 28 64 65 66 69 6e 65 t record.(define
d5c0: 20 28 74 65 73 74 73 3a 67 65 74 2d 66 75 6c 6c (tests:get-full
d5d0: 2d 64 61 74 61 20 74 65 73 74 2d 6e 61 6d 65 73 -data test-names
d5e0: 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 72 65 test-records re
d5f0: 71 75 69 72 65 64 2d 74 65 73 74 73 20 61 6c 6c quired-tests all
d600: 2d 74 65 73 74 73 2d 72 65 67 69 73 74 72 79 29 -tests-registry)
d610: 0a 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c . (if (not (nul
d620: 6c 3f 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 0a l? test-names)).
d630: 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 (let loop
d640: 28 28 68 65 64 20 28 63 61 72 20 74 65 73 74 2d ((hed (car test-
d650: 6e 61 6d 65 73 29 29 0a 09 09 20 28 74 61 6c 20 names))... (tal
d660: 28 63 64 72 20 74 65 73 74 2d 6e 61 6d 65 73 29 (cdr test-names)
d670: 29 29 20 20 20 20 20 20 20 20 20 3b 3b 20 27 72 )) ;; 'r
d680: 65 74 75 72 6e 2d 70 72 6f 63 73 20 74 65 6c 6c eturn-procs tell
d690: 73 20 74 68 65 20 63 6f 6e 66 69 67 20 72 65 61 s the config rea
d6a0: 64 65 72 20 74 6f 20 70 72 65 70 20 72 75 6e 6e der to prep runn
d6b0: 69 6e 67 20 73 79 73 74 65 6d 20 62 75 74 20 72 ing system but r
d6c0: 65 74 75 72 6e 20 61 20 70 72 6f 63 0a 09 28 64 eturn a proc..(d
d6d0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
d6e0: 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 4 *default-log-p
d6f0: 6f 72 74 2a 20 22 68 65 64 3d 22 20 68 65 64 20 ort* "hed=" hed
d700: 22 20 61 74 20 74 6f 70 20 6f 66 20 6c 6f 6f 70 " at top of loop
d710: 22 29 0a 20 20 20 20 20 20 20 20 3b 3b 20 64 6f "). ;; do
d720: 6e 27 74 20 6b 6e 6f 77 20 69 74 65 6d 2d 70 61 n't know item-pa
d730: 74 68 20 61 74 20 74 68 69 73 20 74 69 6d 65 2c th at this time,
d740: 20 6c 65 74 20 74 68 65 20 74 65 73 74 63 6f 6e let the testcon
d750: 66 69 67 20 67 65 74 20 74 68 65 20 74 6f 70 20 fig get the top
d760: 6c 65 76 65 6c 20 74 65 73 74 63 6f 6e 66 69 67 level testconfig
d770: 0a 09 28 6c 65 74 2a 20 28 28 63 6f 6e 66 69 67 ..(let* ((config
d780: 20 20 28 74 65 73 74 73 3a 67 65 74 2d 74 65 73 (tests:get-tes
d790: 74 63 6f 6e 66 69 67 20 68 65 64 20 23 66 20 61 tconfig hed #f a
d7a0: 6c 6c 2d 74 65 73 74 73 2d 72 65 67 69 73 74 72 ll-tests-registr
d7b0: 79 20 27 72 65 74 75 72 6e 2d 70 72 6f 63 73 29 y 'return-procs)
d7c0: 29 0a 09 20 20 20 20 20 20 20 28 77 61 69 74 6f ).. (waito
d7d0: 6e 73 20 28 6c 65 74 20 28 28 69 6e 73 74 72 20 ns (let ((instr
d7e0: 28 69 66 20 63 6f 6e 66 69 67 20 0a 09 09 09 09 (if config .....
d7f0: 09 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 . (configf:looku
d800: 70 20 63 6f 6e 66 69 67 20 22 72 65 71 75 69 72 p config "requir
d810: 65 6d 65 6e 74 73 22 20 22 77 61 69 74 6f 6e 22 ements" "waiton"
d820: 29 0a 09 09 09 09 09 20 28 62 65 67 69 6e 20 3b )...... (begin ;
d830: 3b 20 4e 6f 20 63 6f 6e 66 69 67 20 6d 65 61 6e ; No config mean
d840: 73 20 74 68 69 73 20 69 73 20 61 20 6e 6f 6e 2d s this is a non-
d850: 65 78 69 73 74 61 6e 74 20 74 65 73 74 0a 09 09 existant test...
d860: 09 09 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 ... (debug:pri
d870: 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 nt-error 0 *defa
d880: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 6e ult-log-port* "n
d890: 6f 6e 2d 65 78 69 73 74 65 6e 74 20 72 65 71 75 on-existent requ
d8a0: 69 72 65 64 20 74 65 73 74 20 5c 22 22 20 68 65 ired test \"" he
d8b0: 64 20 22 5c 22 2c 20 67 72 65 70 20 74 68 72 6f d "\", grep thro
d8c0: 75 67 68 20 79 6f 75 72 20 74 65 73 74 63 6f 6e ugh your testcon
d8d0: 66 69 67 73 20 74 6f 20 66 69 6e 64 20 61 6e 64 figs to find and
d8e0: 20 72 65 6d 6f 76 65 20 6f 72 20 63 72 65 61 74 remove or creat
d8f0: 65 20 74 68 65 20 74 65 73 74 2e 20 44 69 73 63 e the test. Disc
d900: 61 72 64 69 6e 67 20 61 6e 64 20 63 6f 6e 74 69 arding and conti
d910: 6e 75 69 6e 67 2e 22 29 0a 09 09 09 09 09 20 20 nuing.")......
d920: 20 20 20 22 22 29 29 29 29 0a 09 09 09 20 20 28 "")))).... (
d930: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
d940: 20 38 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 8 *default-log-
d950: 70 6f 72 74 2a 20 22 77 61 69 74 6f 6e 73 20 73 port* "waitons s
d960: 74 72 69 6e 67 20 69 73 20 22 20 69 6e 73 74 72 tring is " instr
d970: 29 0a 09 09 09 20 20 28 73 74 72 69 6e 67 2d 73 ).... (string-s
d980: 70 6c 69 74 20 28 63 6f 6e 64 0a 09 09 09 09 09 plit (cond......
d990: 20 28 28 70 72 6f 63 65 64 75 72 65 3f 20 69 6e ((procedure? in
d9a0: 73 74 72 29 0a 09 09 09 09 09 20 20 28 6c 65 74 str)...... (let
d9b0: 20 28 28 72 65 73 20 28 69 6e 73 74 72 29 29 29 ((res (instr)))
d9c0: 0a 09 09 09 09 09 20 20 20 20 28 64 65 62 75 67 ...... (debug
d9d0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 38 20 2a 64 :print-info 8 *d
d9e0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
d9f0: 20 22 77 61 69 74 6f 6e 20 70 72 6f 63 65 64 75 "waiton procedu
da00: 72 65 20 72 65 73 75 6c 74 73 20 69 6e 20 73 74 re results in st
da10: 72 69 6e 67 20 22 20 72 65 73 20 22 20 66 6f 72 ring " res " for
da20: 20 74 65 73 74 20 22 20 68 65 64 29 0a 09 09 09 test " hed)....
da30: 09 09 20 20 20 20 72 65 73 29 29 0a 09 09 09 09 .. res)).....
da40: 09 20 28 28 73 74 72 69 6e 67 3f 20 69 6e 73 74 . ((string? inst
da50: 72 29 20 20 20 20 20 69 6e 73 74 72 29 0a 09 09 r) instr)...
da60: 09 09 09 20 28 65 6c 73 65 20 0a 09 09 09 09 09 ... (else ......
da70: 20 20 3b 3b 20 4e 4f 54 45 3a 20 54 68 69 73 20 ;; NOTE: This
da80: 69 73 20 61 63 74 75 61 6c 6c 79 20 74 68 65 20 is actually the
da90: 63 61 73 65 20 6f 66 20 2a 6e 6f 2a 20 77 61 69 case of *no* wai
daa0: 74 6f 6e 73 21 20 3b 3b 20 28 64 65 62 75 67 3a tons! ;; (debug:
dab0: 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 print-error 0 *d
dac0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
dad0: 20 22 73 6f 6d 65 74 68 69 6e 67 20 77 65 6e 74 "something went
dae0: 20 77 72 6f 6e 67 20 69 6e 20 70 72 6f 63 65 73 wrong in proces
daf0: 73 69 6e 67 20 77 61 69 74 6f 6e 73 20 66 6f 72 sing waitons for
db00: 20 74 65 73 74 20 22 20 68 65 64 29 0a 09 09 09 test " hed)....
db10: 09 09 20 20 22 22 29 29 29 29 29 29 0a 09 20 20 .. ""))))))..
db20: 28 69 66 20 28 6e 6f 74 20 63 6f 6e 66 69 67 29 (if (not config)
db30: 20 3b 3b 20 74 68 69 73 20 69 73 20 61 20 6e 6f ;; this is a no
db40: 6e 2d 65 78 69 73 74 61 6e 74 20 74 65 73 74 20 n-existant test
db50: 63 61 6c 6c 65 64 20 69 6e 20 61 20 77 61 69 74 called in a wait
db60: 6f 6e 2e 20 0a 09 20 20 20 20 20 20 28 69 66 20 on. .. (if
db70: 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 20 20 (null? tal)...
db80: 74 65 73 74 2d 72 65 63 6f 72 64 73 0a 09 09 20 test-records...
db90: 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 (loop (car tal)
dba0: 28 63 64 72 20 74 61 6c 29 29 29 0a 09 20 20 20 (cdr tal)))..
dbb0: 20 20 20 28 62 65 67 69 6e 0a 09 09 28 64 65 62 (begin...(deb
dbc0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 38 20 ug:print-info 8
dbd0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
dbe0: 74 2a 20 22 77 61 69 74 6f 6e 73 3a 20 22 20 77 t* "waitons: " w
dbf0: 61 69 74 6f 6e 73 29 0a 09 09 3b 3b 20 63 68 65 aitons)...;; che
dc00: 63 6b 20 66 6f 72 20 68 65 64 20 69 6e 20 77 61 ck for hed in wa
dc10: 69 74 6f 6e 73 20 3d 3e 20 74 68 69 73 20 77 6f itons => this wo
dc20: 75 6c 64 20 62 65 20 63 69 72 63 75 6c 61 72 2c uld be circular,
dc30: 20 72 65 6d 6f 76 65 20 69 74 20 61 6e 64 20 69 remove it and i
dc40: 73 73 75 65 20 61 6e 0a 09 09 3b 3b 20 65 72 72 ssue an...;; err
dc50: 6f 72 0a 09 09 28 69 66 20 28 6d 65 6d 62 65 72 or...(if (member
dc60: 20 68 65 64 20 77 61 69 74 6f 6e 73 29 0a 09 09 hed waitons)...
dc70: 20 20 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 (begin...
dc80: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
dc90: 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 error 0 *default
dca0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 74 65 73 74 -log-port* "test
dcb0: 20 22 20 68 65 64 20 22 20 68 61 73 20 6c 69 73 " hed " has lis
dcc0: 74 65 64 20 69 74 73 65 6c 66 20 61 73 20 61 20 ted itself as a
dcd0: 77 61 69 74 6f 6e 2c 20 70 6c 65 61 73 65 20 63 waiton, please c
dce0: 6f 72 72 65 63 74 20 74 68 69 73 21 22 29 0a 09 orrect this!")..
dcf0: 09 20 20 20 20 20 20 28 73 65 74 21 20 77 61 69 . (set! wai
dd00: 74 6f 6e 73 20 28 66 69 6c 74 65 72 20 28 6c 61 tons (filter (la
dd10: 6d 62 64 61 20 28 78 29 28 6e 6f 74 20 28 65 71 mbda (x)(not (eq
dd20: 75 61 6c 3f 20 78 20 68 65 64 29 29 29 20 77 61 ual? x hed))) wa
dd30: 69 74 6f 6e 73 29 29 29 29 0a 09 09 0a 09 09 3b itons))))......;
dd40: 3b 20 28 69 74 65 6d 73 20 20 20 28 69 74 65 6d ; (items (item
dd50: 73 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d s:get-items-from
dd60: 2d 63 6f 6e 66 69 67 20 63 6f 6e 66 69 67 29 29 -config config))
dd70: 29 0a 09 09 28 69 66 20 28 6e 6f 74 20 28 68 61 )...(if (not (ha
dd80: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
dd90: 61 75 6c 74 20 74 65 73 74 2d 72 65 63 6f 72 64 ault test-record
dda0: 73 20 68 65 64 20 23 66 29 29 0a 09 09 20 20 20 s hed #f))...
ddb0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
ddc0: 21 20 74 65 73 74 2d 72 65 63 6f 72 64 73 0a 09 ! test-records..
ddd0: 09 09 09 20 20 20 20 20 68 65 64 20 28 76 65 63 ... hed (vec
dde0: 74 6f 72 20 68 65 64 20 20 20 20 20 3b 3b 20 30 tor hed ;; 0
ddf0: 0a 09 09 09 09 09 09 20 63 6f 6e 66 69 67 20 20 ....... config
de00: 3b 3b 20 31 0a 09 09 09 09 09 09 20 77 61 69 74 ;; 1....... wait
de10: 6f 6e 73 20 3b 3b 20 32 0a 09 09 09 09 09 09 20 ons ;; 2.......
de20: 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 (configf:lookup
de30: 63 6f 6e 66 69 67 20 22 72 65 71 75 69 72 65 6d config "requirem
de40: 65 6e 74 73 22 20 22 70 72 69 6f 72 69 74 79 22 ents" "priority"
de50: 29 20 20 20 20 20 3b 3b 20 70 72 69 6f 72 69 74 ) ;; priorit
de60: 79 20 33 0a 09 09 09 09 09 09 20 28 6c 65 74 20 y 3....... (let
de70: 28 28 69 74 65 6d 73 20 20 20 20 20 20 28 68 61 ((items (ha
de80: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
de90: 61 75 6c 74 20 63 6f 6e 66 69 67 20 22 69 74 65 ault config "ite
dea0: 6d 73 22 20 23 66 29 29 20 3b 3b 20 69 74 65 6d ms" #f)) ;; item
deb0: 73 20 34 0a 09 09 09 09 09 09 20 20 20 20 20 20 s 4.......
dec0: 20 28 69 74 65 6d 73 74 61 62 6c 65 20 28 68 61 (itemstable (ha
ded0: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
dee0: 61 75 6c 74 20 63 6f 6e 66 69 67 20 22 69 74 65 ault config "ite
def0: 6d 73 74 61 62 6c 65 22 20 23 66 29 29 29 20 0a mstable" #f))) .
df00: 09 09 09 09 09 09 20 20 20 3b 3b 20 69 66 20 65 ...... ;; if e
df10: 69 74 68 65 72 20 69 74 65 6d 73 20 6f 72 20 69 ither items or i
df20: 74 65 6d 73 20 74 61 62 6c 65 20 69 73 20 61 20 tems table is a
df30: 70 72 6f 63 20 72 65 74 75 72 6e 20 69 74 20 73 proc return it s
df40: 6f 20 74 65 73 74 20 72 75 6e 6e 69 6e 67 0a 09 o test running..
df50: 09 09 09 09 09 20 20 20 3b 3b 20 70 72 6f 63 65 ..... ;; proce
df60: 73 73 20 63 61 6e 20 6b 6e 6f 77 20 74 6f 20 63 ss can know to c
df70: 61 6c 6c 20 69 74 65 6d 73 3a 67 65 74 2d 69 74 all items:get-it
df80: 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 0a ems-from-config.
df90: 09 09 09 09 09 09 20 20 20 3b 3b 20 69 66 20 65 ...... ;; if e
dfa0: 69 74 68 65 72 20 69 73 20 61 20 6c 69 73 74 20 ither is a list
dfb0: 61 6e 64 20 6e 6f 6e 65 20 69 73 20 61 20 70 72 and none is a pr
dfc0: 6f 63 20 67 6f 20 61 68 65 61 64 20 61 6e 64 20 oc go ahead and
dfd0: 63 61 6c 6c 20 67 65 74 2d 69 74 65 6d 73 0a 09 call get-items..
dfe0: 09 09 09 09 09 20 20 20 3b 3b 20 6f 74 68 65 72 ..... ;; other
dff0: 77 69 73 65 20 72 65 74 75 72 6e 20 23 66 20 2d wise return #f -
e000: 20 74 68 69 73 20 69 73 20 6e 6f 74 20 61 6e 20 this is not an
e010: 69 74 65 72 61 74 65 64 20 74 65 73 74 0a 09 09 iterated test...
e020: 09 09 09 09 20 20 20 28 63 6f 6e 64 0a 09 09 09 .... (cond....
e030: 09 09 09 20 20 20 20 28 28 70 72 6f 63 65 64 75 ... ((procedu
e040: 72 65 3f 20 69 74 65 6d 73 29 20 20 20 20 20 20 re? items)
e050: 0a 09 09 09 09 09 09 20 20 20 20 20 28 64 65 62 ....... (deb
e060: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 ug:print-info 4
e070: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
e080: 74 2a 20 22 69 74 65 6d 73 20 69 73 20 61 20 70 t* "items is a p
e090: 72 6f 63 65 64 75 72 65 2c 20 77 69 6c 6c 20 63 rocedure, will c
e0a0: 61 6c 63 20 6c 61 74 65 72 22 29 0a 09 09 09 09 alc later").....
e0b0: 09 09 20 20 20 20 20 69 74 65 6d 73 29 20 20 20 .. items)
e0c0: 20 20 20 20 20 20 20 20 20 3b 3b 20 63 61 6c 63 ;; calc
e0d0: 20 6c 61 74 65 72 0a 09 09 09 09 09 09 20 20 20 later.......
e0e0: 20 28 28 70 72 6f 63 65 64 75 72 65 3f 20 69 74 ((procedure? it
e0f0: 65 6d 73 74 61 62 6c 65 29 0a 09 09 09 09 09 09 emstable).......
e100: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
e110: 74 2d 69 6e 66 6f 20 34 20 2a 64 65 66 61 75 6c t-info 4 *defaul
e120: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 69 74 65 t-log-port* "ite
e130: 6d 73 74 61 62 6c 65 20 69 73 20 61 20 70 72 6f mstable is a pro
e140: 63 65 64 75 72 65 2c 20 77 69 6c 6c 20 63 61 6c cedure, will cal
e150: 63 20 6c 61 74 65 72 22 29 0a 09 09 09 09 09 09 c later").......
e160: 20 20 20 20 20 69 74 65 6d 73 74 61 62 6c 65 29 itemstable)
e170: 20 20 20 20 20 20 20 3b 3b 20 63 61 6c 63 20 6c ;; calc l
e180: 61 74 65 72 0a 09 09 09 09 09 09 20 20 20 20 28 ater....... (
e190: 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 (filter (lambda
e1a0: 28 78 29 0a 09 09 09 09 09 09 09 20 20 20 20 20 (x)........
e1b0: 20 20 28 6c 65 74 20 28 28 76 61 6c 20 28 63 61 (let ((val (ca
e1c0: 72 20 78 29 29 29 0a 09 09 09 09 09 09 09 09 20 r x))).........
e1d0: 28 69 66 20 28 70 72 6f 63 65 64 75 72 65 3f 20 (if (procedure?
e1e0: 76 61 6c 29 20 76 61 6c 20 23 66 29 29 29 0a 09 val) val #f)))..
e1f0: 09 09 09 09 09 09 20 20 20 20 20 28 61 70 70 65 ...... (appe
e200: 6e 64 20 28 69 66 20 28 6c 69 73 74 3f 20 69 74 nd (if (list? it
e210: 65 6d 73 29 20 69 74 65 6d 73 20 27 28 29 29 0a ems) items '()).
e220: 09 09 09 09 09 09 09 09 20 20 20 20 20 28 69 66 ........ (if
e230: 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 74 61 62 (list? itemstab
e240: 6c 65 29 20 69 74 65 6d 73 74 61 62 6c 65 20 27 le) itemstable '
e250: 28 29 29 29 29 0a 09 09 09 09 09 09 20 20 20 20 ()))).......
e260: 20 27 68 61 76 65 2d 70 72 6f 63 65 64 75 72 65 'have-procedure
e270: 29 0a 09 09 09 09 09 09 20 20 20 20 28 28 6f 72 )....... ((or
e280: 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 28 6c (list? items)(l
e290: 69 73 74 3f 20 69 74 65 6d 73 74 61 62 6c 65 29 ist? itemstable)
e2a0: 29 20 3b 3b 20 63 61 6c 63 20 6e 6f 77 0a 09 09 ) ;; calc now...
e2b0: 09 09 09 09 20 20 20 20 20 28 64 65 62 75 67 3a .... (debug:
e2c0: 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 2a 64 65 print-info 4 *de
e2d0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
e2e0: 22 69 74 65 6d 73 20 61 6e 64 20 69 74 65 6d 73 "items and items
e2f0: 74 61 62 6c 65 20 61 72 65 20 6c 69 73 74 73 2c table are lists,
e300: 20 63 61 6c 63 20 6e 6f 77 5c 6e 22 0a 09 09 09 calc now\n"....
e310: 09 09 09 09 09 20 20 20 20 20 20 20 22 20 20 20 ..... "
e320: 20 69 74 65 6d 73 3a 20 22 20 69 74 65 6d 73 20 items: " items
e330: 22 20 69 74 65 6d 73 74 61 62 6c 65 3a 20 22 20 " itemstable: "
e340: 69 74 65 6d 73 74 61 62 6c 65 29 0a 09 09 09 09 itemstable).....
e350: 09 09 20 20 20 20 20 28 69 74 65 6d 73 3a 67 65 .. (items:ge
e360: 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e t-items-from-con
e370: 66 69 67 20 63 6f 6e 66 69 67 29 29 0a 09 09 09 fig config))....
e380: 09 09 09 20 20 20 20 28 65 6c 73 65 20 23 66 29 ... (else #f)
e390: 29 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ))
e3a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ;;
e3b0: 6e 6f 74 20 69 74 65 72 61 74 65 64 0a 09 09 09 not iterated....
e3c0: 09 09 09 20 23 66 20 20 20 20 20 20 3b 3b 20 69 ... #f ;; i
e3d0: 74 65 6d 73 64 61 74 20 35 0a 09 09 09 09 09 09 temsdat 5.......
e3e0: 20 23 66 20 20 20 20 20 20 3b 3b 20 73 70 61 72 #f ;; spar
e3f0: 65 20 2d 20 75 73 65 64 20 66 6f 72 20 69 74 65 e - used for ite
e400: 6d 2d 70 61 74 68 0a 09 09 09 09 09 09 20 29 29 m-path....... ))
e410: 29 0a 09 09 28 66 6f 72 2d 65 61 63 68 20 0a 09 )...(for-each ..
e420: 09 20 28 6c 61 6d 62 64 61 20 28 77 61 69 74 6f . (lambda (waito
e430: 6e 29 0a 09 09 20 20 20 28 69 66 20 28 61 6e 64 n)... (if (and
e440: 20 77 61 69 74 6f 6e 20 28 6e 6f 74 20 28 6d 65 waiton (not (me
e450: 6d 62 65 72 20 77 61 69 74 6f 6e 20 74 65 73 74 mber waiton test
e460: 2d 6e 61 6d 65 73 29 29 29 0a 09 09 20 20 20 20 -names)))...
e470: 20 20 20 28 62 65 67 69 6e 0a 09 09 09 20 28 73 (begin.... (s
e480: 65 74 21 20 72 65 71 75 69 72 65 64 2d 74 65 73 et! required-tes
e490: 74 73 20 28 63 6f 6e 73 20 77 61 69 74 6f 6e 20 ts (cons waiton
e4a0: 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 29 29 required-tests))
e4b0: 0a 09 09 09 20 28 73 65 74 21 20 74 65 73 74 2d .... (set! test-
e4c0: 6e 61 6d 65 73 20 28 63 6f 6e 73 20 77 61 69 74 names (cons wait
e4d0: 6f 6e 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 29 on test-names)))
e4e0: 29 29 20 3b 3b 20 77 61 73 20 61 6e 20 61 70 70 )) ;; was an app
e4f0: 65 6e 64 2c 20 6e 6f 77 20 61 20 63 6f 6e 73 0a end, now a cons.
e500: 09 09 20 77 61 69 74 6f 6e 73 29 0a 09 09 28 6c .. waitons)...(l
e510: 65 74 20 28 28 72 65 6d 74 65 73 74 73 20 28 64 et ((remtests (d
e520: 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 74 65 73 elete-duplicates
e530: 20 28 61 70 70 65 6e 64 20 77 61 69 74 6f 6e 73 (append waitons
e540: 20 74 61 6c 29 29 29 29 0a 09 09 20 20 28 69 66 tal))))... (if
e550: 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 6d (not (null? rem
e560: 74 65 73 74 73 29 29 0a 09 09 20 20 20 20 20 20 tests))...
e570: 28 6c 6f 6f 70 20 28 63 61 72 20 72 65 6d 74 65 (loop (car remte
e580: 73 74 73 29 28 63 64 72 20 72 65 6d 74 65 73 74 sts)(cdr remtest
e590: 73 29 29 0a 09 09 20 20 20 20 20 20 74 65 73 74 s))... test
e5a0: 2d 72 65 63 6f 72 64 73 29 29 29 29 29 29 29 29 -records))))))))
e5b0: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
e5c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e5d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e5e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e5f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 74 65 ==========.;; te
e600: 73 74 20 73 74 65 70 73 0a 3b 3b 3d 3d 3d 3d 3d st steps.;;=====
e610: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e620: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e630: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e640: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e650: 3d 0a 0a 3b 3b 20 74 65 73 74 73 74 65 70 2d 73 =..;; teststep-s
e660: 65 74 2d 73 74 61 74 75 73 21 20 75 73 65 64 20 et-status! used
e670: 74 6f 20 62 65 20 68 65 72 65 0a 0a 28 64 65 66 to be here..(def
e680: 69 6e 65 20 28 74 65 73 74 2d 67 65 74 2d 6b 69 ine (test-get-ki
e690: 6c 6c 2d 72 65 71 75 65 73 74 20 72 75 6e 2d 69 ll-request run-i
e6a0: 64 20 74 65 73 74 2d 69 64 29 20 3b 3b 20 72 75 d test-id) ;; ru
e6b0: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 n-id test-name i
e6c0: 74 65 6d 64 61 74 29 0a 20 20 28 6c 65 74 2a 20 temdat). (let*
e6d0: 28 28 74 65 73 74 64 61 74 20 20 20 28 72 6d 74 ((testdat (rmt
e6e0: 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 :get-test-info-b
e6f0: 79 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 y-id run-id test
e700: 2d 69 64 29 29 29 0a 20 20 20 20 28 61 6e 64 20 -id))). (and
e710: 74 65 73 74 64 61 74 0a 09 20 28 65 71 75 61 6c testdat.. (equal
e720: 3f 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 ? (test:get-stat
e730: 65 20 74 65 73 74 64 61 74 29 20 22 4b 49 4c 4c e testdat) "KILL
e740: 52 45 51 22 29 29 29 29 0a 0a 28 64 65 66 69 6e REQ"))))..(defin
e750: 65 20 28 74 65 73 74 3a 74 64 62 2d 67 65 74 2d e (test:tdb-get-
e760: 72 75 6e 64 61 74 2d 63 6f 75 6e 74 20 74 64 62 rundat-count tdb
e770: 29 0a 20 20 28 69 66 20 74 64 62 0a 20 20 20 20 ). (if tdb.
e780: 20 20 28 6c 65 74 20 28 28 72 65 73 20 30 29 29 (let ((res 0))
e790: 0a 09 28 73 71 6c 69 74 65 33 3a 66 6f 72 2d 65 ..(sqlite3:for-e
e7a0: 61 63 68 2d 72 6f 77 0a 09 20 28 6c 61 6d 62 64 ach-row.. (lambd
e7b0: 61 20 28 63 6f 75 6e 74 29 0a 09 20 20 20 28 73 a (count).. (s
e7c0: 65 74 21 20 72 65 73 20 63 6f 75 6e 74 29 29 0a et! res count)).
e7d0: 09 20 74 64 62 0a 09 20 22 53 45 4c 45 43 54 20 . tdb.. "SELECT
e7e0: 63 6f 75 6e 74 28 69 64 29 20 46 52 4f 4d 20 74 count(id) FROM t
e7f0: 65 73 74 5f 72 75 6e 64 61 74 3b 22 29 0a 09 72 est_rundat;")..r
e800: 65 73 29 29 0a 20 20 30 29 0a 0a 28 64 65 66 69 es)). 0)..(defi
e810: 6e 65 20 28 74 65 73 74 73 3a 75 70 64 61 74 65 ne (tests:update
e820: 2d 63 65 6e 74 72 61 6c 2d 6d 65 74 61 2d 69 6e -central-meta-in
e830: 66 6f 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 fo run-id test-i
e840: 64 20 63 70 75 6c 6f 61 64 20 64 69 73 6b 66 72 d cpuload diskfr
e850: 65 65 20 6d 69 6e 75 74 65 73 20 75 6e 61 6d 65 ee minutes uname
e860: 20 68 6f 73 74 6e 61 6d 65 29 0a 20 20 28 72 6d hostname). (rm
e870: 74 3a 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 t:general-call '
e880: 75 70 64 61 74 65 2d 74 65 73 74 2d 72 75 6e 64 update-test-rund
e890: 61 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 at run-id test-i
e8a0: 64 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e d (current-secon
e8b0: 64 73 29 20 28 6f 72 20 63 70 75 6c 6f 61 64 20 ds) (or cpuload
e8c0: 2d 31 29 28 6f 72 20 64 69 73 6b 66 72 65 65 20 -1)(or diskfree
e8d0: 2d 31 29 20 2d 31 20 28 6f 72 20 6d 69 6e 75 74 -1) -1 (or minut
e8e0: 65 73 20 2d 31 29 29 0a 20 20 28 69 66 20 28 61 es -1)). (if (a
e8f0: 6e 64 20 63 70 75 6c 6f 61 64 20 64 69 73 6b 66 nd cpuload diskf
e900: 72 65 65 29 0a 20 20 20 20 20 20 28 72 6d 74 3a ree). (rmt:
e910: 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 75 70 general-call 'up
e920: 64 61 74 65 2d 63 70 75 6c 6f 61 64 2d 64 69 73 date-cpuload-dis
e930: 6b 66 72 65 65 20 72 75 6e 2d 69 64 20 63 70 75 kfree run-id cpu
e940: 6c 6f 61 64 20 64 69 73 6b 66 72 65 65 20 74 65 load diskfree te
e950: 73 74 2d 69 64 29 29 0a 20 20 28 69 66 20 6d 69 st-id)). (if mi
e960: 6e 75 74 65 73 20 0a 20 20 20 20 20 20 28 72 6d nutes . (rm
e970: 74 3a 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 t:general-call '
e980: 75 70 64 61 74 65 2d 72 75 6e 2d 64 75 72 61 74 update-run-durat
e990: 69 6f 6e 20 72 75 6e 2d 69 64 20 6d 69 6e 75 74 ion run-id minut
e9a0: 65 73 20 74 65 73 74 2d 69 64 29 29 0a 20 20 28 es test-id)). (
e9b0: 69 66 20 28 61 6e 64 20 75 6e 61 6d 65 20 68 6f if (and uname ho
e9c0: 73 74 6e 61 6d 65 29 0a 20 20 20 20 20 20 28 72 stname). (r
e9d0: 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 mt:general-call
e9e0: 27 75 70 64 61 74 65 2d 75 6e 61 6d 65 2d 68 6f 'update-uname-ho
e9f0: 73 74 20 72 75 6e 2d 69 64 20 75 6e 61 6d 65 20 st run-id uname
ea00: 68 6f 73 74 6e 61 6d 65 20 74 65 73 74 2d 69 64 hostname test-id
ea10: 29 29 29 0a 20 20 0a 3b 3b 20 54 68 69 73 20 6f ))). .;; This o
ea20: 6e 65 20 69 73 20 66 6f 72 20 72 75 6e 6e 69 6e ne is for runnin
ea30: 67 20 77 69 74 68 20 6e 6f 20 64 62 20 61 63 63 g with no db acc
ea40: 65 73 73 20 28 69 2e 65 2e 20 76 69 61 20 72 6d ess (i.e. via rm
ea50: 74 3a 20 69 6e 74 65 72 6e 61 6c 6c 79 29 0a 28 t: internally).(
ea60: 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 73 65 define (tests:se
ea70: 74 2d 66 75 6c 6c 2d 6d 65 74 61 2d 69 6e 66 6f t-full-meta-info
ea80: 20 64 62 20 74 65 73 74 2d 69 64 20 72 75 6e 2d db test-id run-
ea90: 69 64 20 6d 69 6e 75 74 65 73 20 77 6f 72 6b 2d id minutes work-
eaa0: 61 72 65 61 20 72 65 6d 74 72 69 65 73 29 0a 3b area remtries).;
eab0: 3b 20 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 ; (define (tests
eac0: 3a 73 65 74 2d 66 75 6c 6c 2d 6d 65 74 61 2d 69 :set-full-meta-i
ead0: 6e 66 6f 20 74 65 73 74 2d 69 64 20 72 75 6e 2d nfo test-id run-
eae0: 69 64 20 6d 69 6e 75 74 65 73 20 77 6f 72 6b 2d id minutes work-
eaf0: 61 72 65 61 29 0a 3b 3b 20 20 28 6c 65 74 20 28 area).;; (let (
eb00: 28 72 65 6d 74 72 69 65 73 20 31 30 29 29 0a 20 (remtries 10)).
eb10: 20 28 6c 65 74 2a 20 28 28 63 70 75 6c 6f 61 64 (let* ((cpuload
eb20: 20 20 28 67 65 74 2d 63 70 75 2d 6c 6f 61 64 29 (get-cpu-load)
eb30: 29 0a 09 20 28 64 69 73 6b 66 72 65 65 20 28 67 ).. (diskfree (g
eb40: 65 74 2d 64 66 20 28 63 75 72 72 65 6e 74 2d 64 et-df (current-d
eb50: 69 72 65 63 74 6f 72 79 29 29 29 0a 09 20 28 75 irectory))).. (u
eb60: 6e 61 6d 65 20 20 20 20 28 67 65 74 2d 75 6e 61 name (get-una
eb70: 6d 65 20 22 2d 73 72 76 70 69 6f 22 29 29 0a 09 me "-srvpio"))..
eb80: 20 28 68 6f 73 74 6e 61 6d 65 20 28 67 65 74 2d (hostname (get-
eb90: 68 6f 73 74 2d 6e 61 6d 65 29 29 29 0a 20 20 20 host-name))).
eba0: 20 28 74 65 73 74 73 3a 75 70 64 61 74 65 2d 63 (tests:update-c
ebb0: 65 6e 74 72 61 6c 2d 6d 65 74 61 2d 69 6e 66 6f entral-meta-info
ebc0: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 run-id test-id
ebd0: 63 70 75 6c 6f 61 64 20 64 69 73 6b 66 72 65 65 cpuload diskfree
ebe0: 20 6d 69 6e 75 74 65 73 20 75 6e 61 6d 65 20 68 minutes uname h
ebf0: 6f 73 74 6e 61 6d 65 29 29 29 0a 20 20 20 20 0a ostname))). .
ec00: 3b 3b 20 28 64 65 66 69 6e 65 20 28 74 65 73 74 ;; (define (test
ec10: 73 3a 73 65 74 2d 70 61 72 74 69 61 6c 2d 6d 65 s:set-partial-me
ec20: 74 61 2d 69 6e 66 6f 20 74 65 73 74 2d 69 64 20 ta-info test-id
ec30: 72 75 6e 2d 69 64 20 6d 69 6e 75 74 65 73 20 77 run-id minutes w
ec40: 6f 72 6b 2d 61 72 65 61 29 0a 23 3b 28 64 65 66 ork-area).#;(def
ec50: 69 6e 65 20 28 74 65 73 74 73 3a 73 65 74 2d 70 ine (tests:set-p
ec60: 61 72 74 69 61 6c 2d 6d 65 74 61 2d 69 6e 66 6f artial-meta-info
ec70: 20 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 test-id run-id
ec80: 6d 69 6e 75 74 65 73 20 77 6f 72 6b 2d 61 72 65 minutes work-are
ec90: 61 20 72 65 6d 74 72 69 65 73 29 0a 20 20 28 6c a remtries). (l
eca0: 65 74 2a 20 28 28 63 70 75 6c 6f 61 64 20 20 28 et* ((cpuload (
ecb0: 67 65 74 2d 63 70 75 2d 6c 6f 61 64 29 29 0a 09 get-cpu-load))..
ecc0: 20 28 64 69 73 6b 66 72 65 65 20 28 67 65 74 2d (diskfree (get-
ecd0: 64 66 20 28 63 75 72 72 65 6e 74 2d 64 69 72 65 df (current-dire
ece0: 63 74 6f 72 79 29 29 29 0a 09 20 28 72 65 6d 74 ctory))).. (remt
ecf0: 72 69 65 73 20 31 30 29 29 0a 20 20 20 20 28 68 ries 10)). (h
ed00: 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 andle-exceptions
ed10: 0a 20 20 20 20 20 65 78 6e 0a 20 20 20 20 20 28 . exn. (
ed20: 69 66 20 28 3e 20 72 65 6d 74 72 69 65 73 20 30 if (> remtries 0
ed30: 29 0a 09 20 28 62 65 67 69 6e 0a 09 20 20 20 28 ).. (begin.. (
ed40: 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e print-call-chain
ed50: 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d (current-error-
ed60: 70 6f 72 74 29 29 0a 09 20 20 20 28 64 65 62 75 port)).. (debu
ed70: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a g:print-info 0 *
ed80: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
ed90: 2a 20 22 57 41 52 4e 49 4e 47 3a 20 66 61 69 6c * "WARNING: fail
eda0: 65 64 20 74 6f 20 73 65 74 20 6d 65 74 61 20 69 ed to set meta i
edb0: 6e 66 6f 2e 20 57 69 6c 6c 20 74 72 79 20 22 20 nfo. Will try "
edc0: 72 65 6d 74 72 69 65 73 20 22 20 6d 6f 72 65 20 remtries " more
edd0: 74 69 6d 65 73 22 29 0a 09 20 20 20 28 73 65 74 times").. (set
ede0: 21 20 72 65 6d 74 72 69 65 73 20 28 2d 20 72 65 ! remtries (- re
edf0: 6d 74 72 69 65 73 20 31 29 29 0a 09 20 20 20 28 mtries 1)).. (
ee00: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 30 thread-sleep! 10
ee10: 29 0a 09 20 20 20 28 74 65 73 74 73 3a 73 65 74 ).. (tests:set
ee20: 2d 66 75 6c 6c 2d 6d 65 74 61 2d 69 6e 66 6f 20 -full-meta-info
ee30: 64 62 20 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 db test-id run-i
ee40: 64 20 6d 69 6e 75 74 65 73 20 77 6f 72 6b 2d 61 d minutes work-a
ee50: 72 65 61 20 28 2d 20 72 65 6d 74 72 69 65 73 20 rea (- remtries
ee60: 31 29 29 29 0a 09 20 28 6c 65 74 20 28 28 65 72 1))).. (let ((er
ee70: 72 2d 73 74 61 74 75 73 20 28 28 63 6f 6e 64 69 r-status ((condi
ee80: 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 tion-property-ac
ee90: 63 65 73 73 6f 72 20 27 73 71 6c 69 74 65 33 20 cessor 'sqlite3
eea0: 27 73 74 61 74 75 73 20 23 66 29 20 65 78 6e 29 'status #f) exn)
eeb0: 29 29 0a 09 20 20 20 28 64 65 62 75 67 3a 70 72 )).. (debug:pr
eec0: 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 int-error 0 *def
eed0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
eee0: 74 72 69 65 64 20 66 6f 72 20 6f 76 65 72 20 61 tried for over a
eef0: 20 6d 69 6e 75 74 65 20 74 6f 20 75 70 64 61 74 minute to updat
ef00: 65 20 6d 65 74 61 20 69 6e 66 6f 20 61 6e 64 20 e meta info and
ef10: 66 61 69 6c 65 64 2e 20 47 69 76 69 6e 67 20 75 failed. Giving u
ef20: 70 22 29 0a 09 20 20 20 28 64 65 62 75 67 3a 70 p").. (debug:p
ef30: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
ef40: 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 58 43 45 50 log-port* "EXCEP
ef50: 54 49 4f 4e 3a 20 64 61 74 61 62 61 73 65 20 70 TION: database p
ef60: 72 6f 62 61 62 6c 79 20 6f 76 65 72 6c 6f 61 64 robably overload
ef70: 65 64 20 6f 72 20 75 6e 72 65 61 64 61 62 6c 65 ed or unreadable
ef80: 2e 22 29 0a 09 20 20 20 28 64 65 62 75 67 3a 70 .").. (debug:p
ef90: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
efa0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 6d 65 73 73 log-port* " mess
efb0: 61 67 65 3a 20 22 20 28 28 63 6f 6e 64 69 74 69 age: " ((conditi
efc0: 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 on-property-acce
efd0: 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 ssor 'exn 'messa
efe0: 67 65 29 20 65 78 6e 29 29 0a 09 20 20 20 28 64 ge) exn)).. (d
eff0: 65 62 75 67 3a 70 72 69 6e 74 20 35 20 2a 64 65 ebug:print 5 *de
f000: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
f010: 22 65 78 6e 3d 22 20 28 63 6f 6e 64 69 74 69 6f "exn=" (conditio
f020: 6e 2d 3e 6c 69 73 74 20 65 78 6e 29 29 0a 09 20 n->list exn))..
f030: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
f040: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
f050: 72 74 2a 20 22 20 73 74 61 74 75 73 3a 20 20 22 rt* " status: "
f060: 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f ((condition-pro
f070: 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 perty-accessor '
f080: 73 71 6c 69 74 65 33 20 27 73 74 61 74 75 73 29 sqlite3 'status)
f090: 20 65 78 6e 29 29 0a 09 20 20 20 28 70 72 69 6e exn)).. (prin
f0a0: 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 20 28 63 75 t-call-chain (cu
f0b0: 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 rrent-error-port
f0c0: 29 29 29 29 0a 20 20 20 20 20 28 74 65 73 74 73 )))). (tests
f0d0: 3a 75 70 64 61 74 65 2d 74 65 73 74 64 61 74 2d :update-testdat-
f0e0: 6d 65 74 61 2d 69 6e 66 6f 20 64 62 20 74 65 73 meta-info db tes
f0f0: 74 2d 69 64 20 77 6f 72 6b 2d 61 72 65 61 20 63 t-id work-area c
f100: 70 75 6c 6f 61 64 20 64 69 73 6b 66 72 65 65 20 puload diskfree
f110: 6d 69 6e 75 74 65 73 29 0a 20 20 29 29 29 0a 09 minutes). )))..
f120: 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;============
f130: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f140: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f150: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f160: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 41 20 ==========.;; A
f170: 52 20 43 20 48 20 49 20 56 20 49 20 4e 20 47 0a R C H I V I N G.
f180: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
f190: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f1a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f1b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f1c0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e ========..(defin
f1d0: 65 20 28 74 65 73 74 3a 61 72 63 68 69 76 65 20 e (test:archive
f1e0: 64 62 20 74 65 73 74 2d 69 64 29 0a 20 20 23 66 db test-id). #f
f1f0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 )..(define (test
f200: 3a 61 72 63 68 69 76 65 2d 74 65 73 74 73 20 64 :archive-tests d
f210: 62 20 6b 65 79 6e 61 6d 65 73 20 74 61 72 67 65 b keynames targe
f220: 74 29 0a 20 20 23 66 29 0a 0a 0a 3b 3b 20 73 75 t). #f)...;; su
f230: 6d 6d 61 72 69 7a 65 20 74 65 73 74 20 69 6e 20 mmarize test in
f240: 74 6f 20 61 20 66 69 6c 65 20 74 65 73 74 2d 73 to a file test-s
f250: 75 6d 6d 61 72 79 2e 68 74 6d 6c 20 69 6e 20 74 ummary.html in t
f260: 68 65 20 74 65 73 74 20 64 69 72 65 63 74 6f 72 he test director
f270: 79 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 65 y.;;.(define (te
f280: 73 74 73 3a 73 75 6d 6d 61 72 69 7a 65 2d 74 65 sts:summarize-te
f290: 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 st run-id test-i
f2a0: 64 29 0a 20 20 28 6c 65 74 2a 20 28 28 74 65 73 d). (let* ((tes
f2b0: 74 2d 64 61 74 20 20 28 72 6d 74 3a 67 65 74 2d t-dat (rmt:get-
f2c0: 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 test-info-by-id
f2d0: 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 29 run-id test-id))
f2e0: 0a 09 20 28 6f 75 74 2d 64 69 72 20 20 20 28 64 .. (out-dir (d
f2f0: 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 b:test-get-rundi
f300: 72 20 74 65 73 74 2d 64 61 74 29 29 0a 09 20 28 r test-dat)).. (
f310: 6f 75 74 2d 66 69 6c 65 20 20 28 63 6f 6e 63 20 out-file (conc
f320: 6f 75 74 2d 64 69 72 20 22 2f 74 65 73 74 2d 73 out-dir "/test-s
f330: 75 6d 6d 61 72 79 2e 68 74 6d 6c 22 29 29 29 0a ummary.html"))).
f340: 20 20 20 20 3b 3b 20 66 69 72 73 74 20 76 65 72 ;; first ver
f350: 69 66 79 20 77 65 20 61 72 65 20 61 62 6c 65 20 ify we are able
f360: 74 6f 20 77 72 69 74 65 20 74 68 65 20 6f 75 74 to write the out
f370: 70 75 74 20 66 69 6c 65 0a 20 20 20 20 28 69 66 put file. (if
f380: 20 28 6e 6f 74 20 28 66 69 6c 65 2d 77 72 69 74 (not (file-writ
f390: 61 62 6c 65 3f 20 6f 75 74 2d 64 69 72 29 29 0a able? out-dir)).
f3a0: 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 .(debug:print 0
f3b0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
f3c0: 74 2a 20 22 45 52 52 4f 52 3a 20 63 61 6e 6e 6f t* "ERROR: canno
f3d0: 74 20 77 72 69 74 65 20 74 65 73 74 2d 73 75 6d t write test-sum
f3e0: 6d 61 72 79 2e 68 74 6d 6c 20 74 6f 20 22 20 6f mary.html to " o
f3f0: 75 74 2d 64 69 72 29 0a 09 28 6c 65 74 2a 20 28 ut-dir)..(let* (
f400: 3b 3b 20 28 73 74 65 70 73 2d 64 61 74 20 28 72 ;; (steps-dat (r
f410: 6d 74 3a 67 65 74 2d 73 74 65 70 73 2d 66 6f 72 mt:get-steps-for
f420: 2d 74 65 73 74 20 72 75 6e 2d 69 64 20 74 65 73 -test run-id tes
f430: 74 2d 69 64 29 29 0a 09 20 20 20 20 20 20 20 28 t-id)).. (
f440: 74 65 73 74 2d 6e 61 6d 65 20 28 64 62 3a 74 65 test-name (db:te
f450: 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 st-get-testname
f460: 74 65 73 74 2d 64 61 74 29 29 0a 09 20 20 20 20 test-dat))..
f470: 20 20 20 28 69 74 65 6d 2d 70 61 74 68 20 28 64 (item-path (d
f480: 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d b:test-get-item-
f490: 70 61 74 68 20 74 65 73 74 2d 64 61 74 29 29 0a path test-dat)).
f4a0: 09 20 20 20 20 20 20 20 28 66 75 6c 6c 2d 6e 61 . (full-na
f4b0: 6d 65 20 28 64 62 3a 74 65 73 74 2d 6d 61 6b 65 me (db:test-make
f4c0: 2d 66 75 6c 6c 2d 6e 61 6d 65 20 74 65 73 74 2d -full-name test-
f4d0: 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 name item-path))
f4e0: 0a 09 20 20 20 20 20 20 20 28 6f 75 70 20 20 20 .. (oup
f4f0: 20 20 20 20 28 6f 70 65 6e 2d 6f 75 74 70 75 74 (open-output
f500: 2d 66 69 6c 65 20 6f 75 74 2d 66 69 6c 65 29 29 -file out-file))
f510: 0a 09 20 20 20 20 20 20 20 28 73 74 61 74 75 73 .. (status
f520: 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 (db:test-get
f530: 2d 73 74 61 74 75 73 20 20 20 74 65 73 74 2d 64 -status test-d
f540: 61 74 29 29 0a 09 20 20 20 20 20 20 20 28 63 6f at)).. (co
f550: 6c 6f 72 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a lor (common:
f560: 67 65 74 2d 63 6f 6c 6f 72 2d 66 72 6f 6d 2d 73 get-color-from-s
f570: 74 61 74 75 73 20 73 74 61 74 75 73 29 29 0a 09 tatus status))..
f580: 20 20 20 20 20 20 20 28 6c 6f 67 66 20 20 20 20 (logf
f590: 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 66 (db:test-get-f
f5a0: 69 6e 61 6c 5f 6c 6f 67 66 20 74 65 73 74 2d 64 inal_logf test-d
f5b0: 61 74 29 29 0a 09 20 20 20 20 20 20 20 28 73 74 at)).. (st
f5c0: 65 70 73 2d 64 61 74 20 28 74 65 73 74 73 3a 67 eps-dat (tests:g
f5d0: 65 74 2d 63 6f 6d 70 72 65 73 73 65 64 2d 73 74 et-compressed-st
f5e0: 65 70 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d eps run-id test-
f5f0: 69 64 29 29 29 0a 09 20 20 3b 3b 20 28 64 63 6f id))).. ;; (dco
f600: 6d 6d 6f 6e 3a 67 65 74 2d 63 6f 6d 70 72 65 73 mmon:get-compres
f610: 73 65 64 2d 73 74 65 70 73 20 23 66 20 31 20 33 sed-steps #f 1 3
f620: 30 30 34 35 29 0a 09 20 20 3b 3b 20 28 23 28 22 0045).. ;; (#("
f630: 77 61 73 74 69 6e 67 5f 74 69 6d 65 22 20 22 32 wasting_time" "2
f640: 33 3a 33 36 3a 31 33 22 20 22 32 33 3a 33 36 3a 3:36:13" "23:36:
f650: 32 31 22 20 22 30 22 20 22 38 2e 30 73 22 20 22 21" "0" "8.0s" "
f660: 77 61 73 74 69 6e 67 5f 74 69 6d 65 2e 6c 6f 67 wasting_time.log
f670: 22 29 29 0a 09 0a 09 20 20 28 73 3a 6f 75 74 70 ")).... (s:outp
f680: 75 74 2d 6e 65 77 0a 09 20 20 20 6f 75 70 0a 09 ut-new.. oup..
f690: 20 20 20 28 73 3a 68 74 6d 6c 0a 09 20 20 20 20 (s:html..
f6a0: 28 73 3a 74 69 74 6c 65 20 22 53 75 6d 6d 61 72 (s:title "Summar
f6b0: 79 20 66 6f 72 20 22 20 66 75 6c 6c 2d 6e 61 6d y for " full-nam
f6c0: 65 29 0a 09 20 20 20 20 28 73 3a 62 6f 64 79 20 e).. (s:body
f6d0: 0a 09 20 20 20 20 20 28 73 3a 68 32 20 22 53 75 .. (s:h2 "Su
f6e0: 6d 6d 61 72 79 20 66 6f 72 20 22 20 66 75 6c 6c mmary for " full
f6f0: 2d 6e 61 6d 65 29 0a 09 20 20 20 20 20 28 73 3a -name).. (s:
f700: 74 61 62 6c 65 20 27 63 65 6c 6c 73 70 61 63 69 table 'cellspaci
f710: 6e 67 20 22 30 22 20 27 62 6f 72 64 65 72 20 22 ng "0" 'border "
f720: 31 22 0a 09 09 20 20 20 20 20 20 28 73 3a 74 72 1"... (s:tr
f730: 20 28 73 3a 74 64 20 22 72 75 6e 20 69 64 22 29 (s:td "run id")
f740: 20 20 20 28 73 3a 74 64 20 28 64 62 3a 74 65 73 (s:td (db:tes
f750: 74 2d 67 65 74 2d 72 75 6e 5f 69 64 20 20 20 74 t-get-run_id t
f760: 65 73 74 2d 64 61 74 29 29 0a 09 09 09 20 20 20 est-dat))....
f770: 20 28 73 3a 74 64 20 22 74 65 73 74 20 69 64 22 (s:td "test id"
f780: 29 20 20 28 73 3a 74 64 20 28 64 62 3a 74 65 73 ) (s:td (db:tes
f790: 74 2d 67 65 74 2d 69 64 20 20 20 20 20 20 20 74 t-get-id t
f7a0: 65 73 74 2d 64 61 74 29 29 29 0a 09 09 20 20 20 est-dat)))...
f7b0: 20 20 20 28 73 3a 74 72 20 28 73 3a 74 64 20 22 (s:tr (s:td "
f7c0: 74 65 73 74 6e 61 6d 65 22 29 20 28 73 3a 74 64 testname") (s:td
f7d0: 20 74 65 73 74 2d 6e 61 6d 65 29 0a 09 09 09 20 test-name)....
f7e0: 20 20 20 28 73 3a 74 64 20 22 69 74 65 6d 70 61 (s:td "itempa
f7f0: 74 68 22 29 20 28 73 3a 74 64 20 69 74 65 6d 2d th") (s:td item-
f800: 70 61 74 68 29 29 0a 09 09 20 20 20 20 20 20 28 path))... (
f810: 73 3a 74 72 20 28 73 3a 74 64 20 22 73 74 61 74 s:tr (s:td "stat
f820: 65 22 29 20 20 20 20 28 73 3a 74 64 20 28 64 62 e") (s:td (db
f830: 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 :test-get-state
f840: 20 20 20 74 65 73 74 2d 64 61 74 29 29 0a 09 09 test-dat))...
f850: 09 20 20 20 20 28 73 3a 74 64 20 22 73 74 61 74 . (s:td "stat
f860: 75 73 22 29 20 20 20 28 73 3a 74 64 20 28 73 3a us") (s:td (s:
f870: 61 20 27 68 72 65 66 20 6c 6f 67 66 20 28 73 3a a 'href logf (s:
f880: 66 6f 6e 74 20 27 63 6f 6c 6f 72 20 63 6f 6c 6f font 'color colo
f890: 72 20 73 74 61 74 75 73 29 29 29 29 0a 09 09 20 r status))))...
f8a0: 20 20 20 20 20 28 73 3a 74 72 20 28 73 3a 74 64 (s:tr (s:td
f8b0: 20 22 54 65 73 74 44 61 74 65 22 29 20 28 73 3a "TestDate") (s:
f8c0: 74 64 20 28 73 65 63 6f 6e 64 73 2d 3e 77 6f 72 td (seconds->wor
f8d0: 6b 2d 77 65 65 6b 2f 64 61 79 2d 74 69 6d 65 20 k-week/day-time
f8e0: 0a 09 09 09 09 09 09 20 20 20 20 20 28 64 62 3a ....... (db:
f8f0: 74 65 73 74 2d 67 65 74 2d 65 76 65 6e 74 5f 74 test-get-event_t
f900: 69 6d 65 20 74 65 73 74 2d 64 61 74 29 29 29 0a ime test-dat))).
f910: 09 09 09 20 20 20 20 28 73 3a 74 64 20 22 44 75 ... (s:td "Du
f920: 72 61 74 69 6f 6e 22 29 20 28 73 3a 74 64 20 28 ration") (s:td (
f930: 73 65 63 6f 6e 64 73 2d 3e 68 72 2d 6d 69 6e 2d seconds->hr-min-
f940: 73 65 63 20 28 64 62 3a 74 65 73 74 2d 67 65 74 sec (db:test-get
f950: 2d 72 75 6e 5f 64 75 72 61 74 69 6f 6e 20 74 65 -run_duration te
f960: 73 74 2d 64 61 74 29 29 29 29 29 0a 09 20 20 20 st-dat)))))..
f970: 20 20 28 73 3a 68 33 20 22 4c 6f 67 20 66 69 6c (s:h3 "Log fil
f980: 65 73 22 29 0a 09 20 20 20 20 20 28 73 3a 74 61 es").. (s:ta
f990: 62 6c 65 20 0a 09 20 20 20 20 20 20 27 63 65 6c ble .. 'cel
f9a0: 6c 73 70 61 63 69 6e 67 20 22 30 22 20 27 62 6f lspacing "0" 'bo
f9b0: 72 64 65 72 20 22 31 22 0a 09 20 20 20 20 20 20 rder "1"..
f9c0: 28 73 3a 74 72 20 28 73 3a 74 64 20 22 46 69 6e (s:tr (s:td "Fin
f9d0: 61 6c 20 6c 6f 67 22 29 28 73 3a 74 64 20 28 73 al log")(s:td (s
f9e0: 3a 61 20 27 68 72 65 66 20 6c 6f 67 66 20 6c 6f :a 'href logf lo
f9f0: 67 66 29 29 29 29 0a 09 20 20 20 20 20 28 73 3a gf)))).. (s:
fa00: 74 61 62 6c 65 0a 09 20 20 20 20 20 20 27 63 65 table.. 'ce
fa10: 6c 6c 73 70 61 63 69 6e 67 20 22 30 22 20 27 62 llspacing "0" 'b
fa20: 6f 72 64 65 72 20 22 31 22 0a 09 20 20 20 20 20 order "1"..
fa30: 20 28 73 3a 74 72 20 28 73 3a 74 64 20 22 53 74 (s:tr (s:td "St
fa40: 65 70 20 4e 61 6d 65 22 29 28 73 3a 74 64 20 22 ep Name")(s:td "
fa50: 53 74 61 72 74 22 29 28 73 3a 74 64 20 22 45 6e Start")(s:td "En
fa60: 64 22 29 28 73 3a 74 64 20 22 53 74 61 74 75 73 d")(s:td "Status
fa70: 22 29 28 73 3a 74 64 20 22 44 75 72 61 74 69 6f ")(s:td "Duratio
fa80: 6e 22 29 28 73 3a 74 64 20 22 4c 6f 67 20 46 69 n")(s:td "Log Fi
fa90: 6c 65 22 29 29 0a 09 20 20 20 20 20 20 28 6d 61 le")).. (ma
faa0: 70 20 28 6c 61 6d 62 64 61 20 28 73 74 65 70 2d p (lambda (step-
fab0: 64 61 74 29 0a 09 09 20 20 20 20 20 28 73 3a 74 dat)... (s:t
fac0: 72 20 28 73 3a 74 64 20 28 74 64 62 3a 73 74 65 r (s:td (tdb:ste
fad0: 70 73 2d 74 61 62 6c 65 2d 67 65 74 2d 73 74 65 ps-table-get-ste
fae0: 70 6e 61 6d 65 20 73 74 65 70 2d 64 61 74 29 29 pname step-dat))
faf0: 0a 09 09 09 20 20 20 28 73 3a 74 64 20 28 74 64 .... (s:td (td
fb00: 62 3a 73 74 65 70 73 2d 74 61 62 6c 65 2d 67 65 b:steps-table-ge
fb10: 74 2d 73 74 61 72 74 20 20 20 20 73 74 65 70 2d t-start step-
fb20: 64 61 74 29 29 0a 09 09 09 20 20 20 28 73 3a 74 dat)).... (s:t
fb30: 64 20 28 74 64 62 3a 73 74 65 70 73 2d 74 61 62 d (tdb:steps-tab
fb40: 6c 65 2d 67 65 74 2d 65 6e 64 20 20 20 20 20 20 le-get-end
fb50: 73 74 65 70 2d 64 61 74 29 29 0a 09 09 09 20 20 step-dat))....
fb60: 20 28 73 3a 74 64 20 28 74 64 62 3a 73 74 65 70 (s:td (tdb:step
fb70: 73 2d 74 61 62 6c 65 2d 67 65 74 2d 73 74 61 74 s-table-get-stat
fb80: 75 73 20 20 20 73 74 65 70 2d 64 61 74 29 29 0a us step-dat)).
fb90: 09 09 09 20 20 20 28 73 3a 74 64 20 28 74 64 62 ... (s:td (tdb
fba0: 3a 73 74 65 70 73 2d 74 61 62 6c 65 2d 67 65 74 :steps-table-get
fbb0: 2d 72 75 6e 74 69 6d 65 20 20 73 74 65 70 2d 64 -runtime step-d
fbc0: 61 74 29 29 0a 09 09 09 20 20 20 28 73 3a 74 64 at)).... (s:td
fbd0: 20 28 6c 65 74 20 28 28 73 74 65 70 2d 6c 6f 67 (let ((step-log
fbe0: 20 28 74 64 62 3a 73 74 65 70 73 2d 74 61 62 6c (tdb:steps-tabl
fbf0: 65 2d 67 65 74 2d 6c 6f 67 2d 66 69 6c 65 20 73 e-get-log-file s
fc00: 74 65 70 2d 64 61 74 29 29 29 0a 09 09 09 09 20 tep-dat))).....
fc10: 20 20 28 73 3a 61 20 27 68 72 65 66 20 73 74 65 (s:a 'href ste
fc20: 70 2d 6c 6f 67 20 73 74 65 70 2d 6c 6f 67 29 29 p-log step-log))
fc30: 29 29 29 0a 09 09 20 20 20 73 74 65 70 73 2d 64 )))... steps-d
fc40: 61 74 29 29 0a 09 20 20 20 20 20 29 29 29 0a 09 at)).. )))..
fc50: 20 20 28 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d (close-output-
fc60: 70 6f 72 74 20 6f 75 70 29 29 29 29 29 0a 09 20 port oup)))))..
fc70: 20 0a 3b 3b 20 66 6f 72 20 65 61 63 68 20 74 65 .;; for each te
fc80: 73 74 3a 0a 3b 3b 20 20 20 0a 28 64 65 66 69 6e st:.;; .(defin
fc90: 65 20 28 74 65 73 74 73 3a 66 69 6c 74 65 72 2d e (tests:filter-
fca0: 6e 6f 6e 2d 72 75 6e 6e 61 62 6c 65 20 72 75 6e non-runnable run
fcb0: 2d 69 64 20 74 65 73 74 6b 65 79 6e 61 6d 65 73 -id testkeynames
fcc0: 20 74 65 73 74 72 65 63 6f 72 64 73 68 61 73 68 testrecordshash
fcd0: 29 0a 20 20 28 6c 65 74 20 28 28 72 75 6e 6e 61 ). (let ((runna
fce0: 62 6c 65 73 20 27 28 29 29 29 0a 20 20 20 20 28 bles '())). (
fcf0: 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 6c for-each. (l
fd00: 61 6d 62 64 61 20 28 74 65 73 74 6b 65 79 6e 61 ambda (testkeyna
fd10: 6d 65 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a me). (let*
fd20: 20 28 28 74 65 73 74 2d 72 65 63 6f 72 64 20 28 ((test-record (
fd30: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 74 hash-table-ref t
fd40: 65 73 74 72 65 63 6f 72 64 73 68 61 73 68 20 74 estrecordshash t
fd50: 65 73 74 6b 65 79 6e 61 6d 65 29 29 0a 09 20 20 estkeyname))..
fd60: 20 20 20 20 28 74 65 73 74 2d 6e 61 6d 65 20 20 (test-name
fd70: 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 (tests:testqueu
fd80: 65 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 20 e-get-testname
fd90: 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 test-record))..
fda0: 20 20 20 20 20 28 69 74 65 6d 64 61 74 20 20 20 (itemdat
fdb0: 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 (tests:testque
fdc0: 75 65 2d 67 65 74 2d 69 74 65 6d 64 61 74 20 20 ue-get-itemdat
fdd0: 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 test-record))..
fde0: 20 20 20 20 20 20 28 69 74 65 6d 2d 70 61 74 68 (item-path
fdf0: 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 (tests:testqu
fe00: 65 75 65 2d 67 65 74 2d 69 74 65 6d 5f 70 61 74 eue-get-item_pat
fe10: 68 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a h test-record)).
fe20: 09 20 20 20 20 20 20 28 77 61 69 74 6f 6e 73 20 . (waitons
fe30: 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 (tests:testq
fe40: 75 65 75 65 2d 67 65 74 2d 77 61 69 74 6f 6e 73 ueue-get-waitons
fe50: 20 20 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 test-record))
fe60: 0a 09 20 20 20 20 20 20 28 6b 65 65 70 2d 74 65 .. (keep-te
fe70: 73 74 20 20 20 23 74 29 0a 09 20 20 20 20 20 20 st #t)..
fe80: 28 74 65 73 74 2d 69 64 20 20 20 20 20 28 72 6d (test-id (rm
fe90: 74 3a 67 65 74 2d 74 65 73 74 2d 69 64 20 72 75 t:get-test-id ru
fea0: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 n-id test-name i
feb0: 74 65 6d 2d 70 61 74 68 29 29 0a 09 20 20 20 20 tem-path))..
fec0: 20 20 28 74 64 61 74 20 20 20 20 20 20 20 20 28 (tdat (
fed0: 72 6d 74 3a 67 65 74 2d 74 65 73 74 69 6e 66 6f rmt:get-testinfo
fee0: 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 72 75 -state-status ru
fef0: 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 29 29 20 n-id test-id)))
ff00: 3b 3b 20 28 63 64 62 3a 67 65 74 2d 74 65 73 74 ;; (cdb:get-test
ff10: 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 2a 72 75 6e -info-by-id *run
ff20: 72 65 6d 6f 74 65 2a 20 74 65 73 74 2d 69 64 29 remote* test-id)
ff30: 29 29 0a 09 20 28 69 66 20 74 64 61 74 0a 09 20 )).. (if tdat..
ff40: 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 (begin..
ff50: 20 20 20 3b 3b 20 4c 6f 6f 6b 20 61 74 20 74 68 ;; Look at th
ff60: 65 20 74 65 73 74 20 73 74 61 74 65 20 61 6e 64 e test state and
ff70: 20 73 74 61 74 75 73 0a 09 20 20 20 20 20 20 20 status..
ff80: 28 69 66 20 28 6f 72 20 28 61 6e 64 20 28 6d 65 (if (or (and (me
ff90: 6d 62 65 72 20 28 64 62 3a 74 65 73 74 2d 67 65 mber (db:test-ge
ffa0: 74 2d 73 74 61 74 75 73 20 74 64 61 74 29 20 0a t-status tdat) .
ffb0: 09 09 09 09 20 20 20 20 27 28 22 50 41 53 53 22 .... '("PASS"
ffc0: 20 22 57 41 52 4e 22 20 22 57 41 49 56 45 44 22 "WARN" "WAIVED"
ffd0: 20 22 43 48 45 43 4b 22 20 22 53 4b 49 50 22 29 "CHECK" "SKIP")
ffe0: 29 0a 09 09 09 20 20 20 20 28 65 71 75 61 6c 3f ).... (equal?
fff0: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 (db:test-get-st
10000 61 74 65 20 74 64 61 74 29 20 22 43 4f 4d 50 4c ate tdat) "COMPL
10010 45 54 45 44 22 29 29 0a 09 09 20 20 20 20 20 20 ETED"))...
10020 20 28 6d 65 6d 62 65 72 20 28 64 62 3a 74 65 73 (member (db:tes
10030 74 2d 67 65 74 2d 73 74 61 74 65 20 74 64 61 74 t-get-state tdat
10040 29 0a 09 09 09 09 20 20 20 20 27 28 22 49 4e 43 )..... '("INC
10050 4f 4d 50 4c 45 54 45 22 20 22 4b 49 4c 4c 45 44 OMPLETE" "KILLED
10060 22 29 29 29 0a 09 09 20 20 20 28 73 65 74 21 20 ")))... (set!
10070 6b 65 65 70 2d 74 65 73 74 20 23 66 29 29 0a 0a keep-test #f))..
10080 09 20 20 20 20 20 20 20 3b 3b 20 65 78 61 6d 69 . ;; exami
10090 6e 65 20 77 61 69 74 6f 6e 73 20 66 6f 72 20 61 ne waitons for a
100a0 6e 79 20 66 61 69 6c 73 2e 20 49 66 20 69 74 20 ny fails. If it
100b0 69 73 20 46 41 49 4c 20 6f 72 20 49 4e 43 4f 4d is FAIL or INCOM
100c0 50 4c 45 54 45 20 74 68 65 6e 20 65 6c 69 6d 69 PLETE then elimi
100d0 6e 61 74 65 20 74 68 69 73 20 74 65 73 74 0a 09 nate this test..
100e0 20 20 20 20 20 20 20 3b 3b 20 66 72 6f 6d 20 74 ;; from t
100f0 68 65 20 72 75 6e 6e 61 62 6c 65 20 6c 69 73 74 he runnable list
10100 0a 09 20 20 20 20 20 20 20 28 69 66 20 6b 65 65 .. (if kee
10110 70 2d 74 65 73 74 0a 09 09 20 20 20 28 66 6f 72 p-test... (for
10120 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 77 -each (lambda (w
10130 61 69 74 6f 6e 29 0a 09 09 09 20 20 20 20 20 20 aiton)....
10140 20 3b 3b 20 66 6f 72 20 6e 6f 77 20 77 65 20 61 ;; for now we a
10150 72 65 20 77 61 69 74 69 6e 67 20 6f 6e 6c 79 20 re waiting only
10160 6f 6e 20 74 68 65 20 70 61 72 65 6e 74 20 74 65 on the parent te
10170 73 74 0a 09 09 09 20 20 20 20 20 20 20 28 6c 65 st.... (le
10180 74 2a 20 28 28 70 61 72 65 6e 74 2d 74 65 73 74 t* ((parent-test
10190 2d 69 64 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 -id (rmt:get-tes
101a0 74 2d 69 64 20 72 75 6e 2d 69 64 20 77 61 69 74 t-id run-id wait
101b0 6f 6e 20 22 22 29 29 0a 09 09 09 09 20 20 20 20 on "")).....
101c0 20 20 28 77 74 64 61 74 20 20 20 20 20 20 20 20 (wtdat
101d0 20 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 69 (rmt:get-testi
101e0 6e 66 6f 2d 73 74 61 74 65 2d 73 74 61 74 75 73 nfo-state-status
101f0 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 run-id test-id)
10200 29 29 20 3b 3b 20 28 63 64 62 3a 67 65 74 2d 74 )) ;; (cdb:get-t
10210 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 2a est-info-by-id *
10220 72 75 6e 72 65 6d 6f 74 65 2a 20 74 65 73 74 2d runremote* test-
10230 69 64 29 29 29 0a 09 09 09 09 20 28 69 66 20 28 id)))..... (if (
10240 6f 72 20 28 61 6e 64 20 28 65 71 75 61 6c 3f 20 or (and (equal?
10250 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 (db:test-get-sta
10260 74 65 20 77 74 64 61 74 29 20 22 43 4f 4d 50 4c te wtdat) "COMPL
10270 45 54 45 44 22 29 0a 09 09 09 09 09 20 20 20 20 ETED")......
10280 20 20 28 6d 65 6d 62 65 72 20 28 64 62 3a 74 65 (member (db:te
10290 73 74 2d 67 65 74 2d 73 74 61 74 75 73 20 77 74 st-get-status wt
102a0 64 61 74 29 20 27 28 22 46 41 49 4c 22 20 22 41 dat) '("FAIL" "A
102b0 42 4f 52 54 22 29 29 29 0a 09 09 09 09 09 20 28 BORT")))...... (
102c0 6d 65 6d 62 65 72 20 28 64 62 3a 74 65 73 74 2d member (db:test-
102d0 67 65 74 2d 73 74 61 74 75 73 20 77 74 64 61 74 get-status wtdat
102e0 29 20 20 27 28 22 4b 49 4c 4c 45 44 22 29 29 0a ) '("KILLED")).
102f0 09 09 09 09 09 20 28 6d 65 6d 62 65 72 20 28 64 ..... (member (d
10300 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 b:test-get-state
10310 20 77 74 64 61 74 29 20 20 20 27 28 22 49 4e 43 wtdat) '("INC
10320 4f 4d 50 45 54 45 22 29 29 29 0a 09 09 09 09 20 OMPETE"))).....
10330 3b 3b 20 28 69 66 20 28 6f 72 20 28 6d 65 6d 62 ;; (if (or (memb
10340 65 72 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d er (db:test-get-
10350 73 74 61 74 75 73 20 77 74 64 61 74 29 0a 09 09 status wtdat)...
10360 09 09 20 3b 3b 20 20 20 20 20 20 20 20 09 20 27 .. ;; . '
10370 28 22 46 41 49 4c 22 20 22 4b 49 4c 4c 45 44 22 ("FAIL" "KILLED"
10380 29 29 0a 09 09 09 09 20 3b 3b 20 20 20 20 20 20 ))..... ;;
10390 20 20 20 28 6d 65 6d 62 65 72 20 28 64 62 3a 74 (member (db:t
103a0 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 77 74 est-get-state wt
103b0 64 61 74 29 0a 09 09 09 09 20 3b 3b 20 20 20 20 dat)..... ;;
103c0 20 20 20 20 09 20 27 28 22 49 4e 43 4f 4d 50 45 . '("INCOMPE
103d0 54 45 22 29 29 29 0a 09 09 09 09 20 20 20 20 20 TE"))).....
103e0 28 73 65 74 21 20 6b 65 65 70 2d 74 65 73 74 20 (set! keep-test
103f0 23 66 29 29 29 29 20 3b 3b 20 6e 6f 20 70 6f 69 #f)))) ;; no poi
10400 6e 74 20 69 6e 20 72 75 6e 6e 69 6e 67 20 74 68 nt in running th
10410 69 73 20 6f 6e 65 20 61 67 61 69 6e 0a 09 09 09 is one again....
10420 20 20 20 20 20 77 61 69 74 6f 6e 73 29 29 29 29 waitons))))
10430 0a 09 20 28 69 66 20 6b 65 65 70 2d 74 65 73 74 .. (if keep-test
10440 20 28 73 65 74 21 20 72 75 6e 6e 61 62 6c 65 73 (set! runnables
10450 20 28 63 6f 6e 73 20 74 65 73 74 6b 65 79 6e 61 (cons testkeyna
10460 6d 65 20 72 75 6e 6e 61 62 6c 65 73 29 29 29 29 me runnables))))
10470 29 0a 20 20 20 20 20 74 65 73 74 6b 65 79 6e 61 ). testkeyna
10480 6d 65 73 29 0a 20 20 20 20 72 75 6e 6e 61 62 6c mes). runnabl
10490 65 73 29 29 0a 0a 0a 0a 0a 29 0a es)).....).