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 30 36 2d 32 30 31 33 2c right 2006-2013,
0060: 20 4d 61 74 74 68 65 77 20 57 65 6c 6c 61 6e 64 Matthew Welland
0070: 2e 0a 3b 3b 20 0a 3b 3b 20 54 68 69 73 20 66 69 ..;; .;; This fi
0080: 6c 65 20 69 73 20 70 61 72 74 20 6f 66 20 4d 65 le is part of Me
0090: 67 61 74 65 73 74 2e 0a 3b 3b 20 0a 3b 3b 20 20 gatest..;; .;;
00a0: 20 20 20 4d 65 67 61 74 65 73 74 20 69 73 20 66 Megatest is f
00b0: 72 65 65 20 73 6f 66 74 77 61 72 65 3a 20 79 6f ree software: yo
00c0: 75 20 63 61 6e 20 72 65 64 69 73 74 72 69 62 75 u can redistribu
00d0: 74 65 20 69 74 20 61 6e 64 2f 6f 72 20 6d 6f 64 te it and/or mod
00e0: 69 66 79 0a 3b 3b 20 20 20 20 20 69 74 20 75 6e ify.;; it un
00f0: 64 65 72 20 74 68 65 20 74 65 72 6d 73 20 6f 66 der the terms of
0100: 20 74 68 65 20 47 4e 55 20 47 65 6e 65 72 61 6c the GNU General
0110: 20 50 75 62 6c 69 63 20 4c 69 63 65 6e 73 65 20 Public License
0120: 61 73 20 70 75 62 6c 69 73 68 65 64 20 62 79 0a as published by.
0130: 3b 3b 20 20 20 20 20 74 68 65 20 46 72 65 65 20 ;; the Free
0140: 53 6f 66 74 77 61 72 65 20 46 6f 75 6e 64 61 74 Software Foundat
0150: 69 6f 6e 2c 20 65 69 74 68 65 72 20 76 65 72 73 ion, either vers
0160: 69 6f 6e 20 33 20 6f 66 20 74 68 65 20 4c 69 63 ion 3 of the Lic
0170: 65 6e 73 65 2c 20 6f 72 0a 3b 3b 20 20 20 20 20 ense, or.;;
0180: 28 61 74 20 79 6f 75 72 20 6f 70 74 69 6f 6e 29 (at your option)
0190: 20 61 6e 79 20 6c 61 74 65 72 20 76 65 72 73 69 any later versi
01a0: 6f 6e 2e 0a 3b 3b 20 0a 3b 3b 20 20 20 20 20 4d on..;; .;; M
01b0: 65 67 61 74 65 73 74 20 69 73 20 64 69 73 74 72 egatest is distr
01c0: 69 62 75 74 65 64 20 69 6e 20 74 68 65 20 68 6f ibuted in the ho
01d0: 70 65 20 74 68 61 74 20 69 74 20 77 69 6c 6c 20 pe that it will
01e0: 62 65 20 75 73 65 66 75 6c 2c 0a 3b 3b 20 20 20 be useful,.;;
01f0: 20 20 62 75 74 20 57 49 54 48 4f 55 54 20 41 4e but WITHOUT AN
0200: 59 20 57 41 52 52 41 4e 54 59 3b 20 77 69 74 68 Y WARRANTY; with
0210: 6f 75 74 20 65 76 65 6e 20 74 68 65 20 69 6d 70 out even the imp
0220: 6c 69 65 64 20 77 61 72 72 61 6e 74 79 20 6f 66 lied warranty of
0230: 0a 3b 3b 20 20 20 20 20 4d 45 52 43 48 41 4e 54 .;; MERCHANT
0240: 41 42 49 4c 49 54 59 20 6f 72 20 46 49 54 4e 45 ABILITY or FITNE
0250: 53 53 20 46 4f 52 20 41 20 50 41 52 54 49 43 55 SS FOR A PARTICU
0260: 4c 41 52 20 50 55 52 50 4f 53 45 2e 20 20 53 65 LAR PURPOSE. Se
0270: 65 20 74 68 65 0a 3b 3b 20 20 20 20 20 47 4e 55 e the.;; GNU
0280: 20 47 65 6e 65 72 61 6c 20 50 75 62 6c 69 63 20 General Public
0290: 4c 69 63 65 6e 73 65 20 66 6f 72 20 6d 6f 72 65 License for more
02a0: 20 64 65 74 61 69 6c 73 2e 0a 3b 3b 20 0a 3b 3b details..;; .;;
02b0: 20 20 20 20 20 59 6f 75 20 73 68 6f 75 6c 64 20 You should
02c0: 68 61 76 65 20 72 65 63 65 69 76 65 64 20 61 20 have received a
02d0: 63 6f 70 79 20 6f 66 20 74 68 65 20 47 4e 55 20 copy of the GNU
02e0: 47 65 6e 65 72 61 6c 20 50 75 62 6c 69 63 20 4c General Public L
02f0: 69 63 65 6e 73 65 0a 3b 3b 20 20 20 20 20 61 6c icense.;; al
0300: 6f 6e 67 20 77 69 74 68 20 4d 65 67 61 74 65 73 ong with Megates
0310: 74 2e 20 20 49 66 20 6e 6f 74 2c 20 73 65 65 20 t. If not, see
0320: 3c 68 74 74 70 3a 2f 2f 77 77 77 2e 67 6e 75 2e <http://www.gnu.
0330: 6f 72 67 2f 6c 69 63 65 6e 73 65 73 2f 3e 2e 0a org/licenses/>..
0340: 3b 3b 0a 3b 3b 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 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 3d ===========..;;=
0390: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
03a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
03b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
03c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
03d0: 3d 3d 3d 3d 3d 0a 3b 3b 20 54 65 73 74 73 0a 3b =====.;; Tests.;
03e0: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
03f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0400: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0410: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0420: 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 63 6c 61 72 =======..(declar
0430: 65 20 28 75 6e 69 74 20 74 65 73 74 73 29 29 0a e (unit tests)).
0440: 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 6c (declare (uses l
0450: 6f 63 6b 2d 71 75 65 75 65 29 29 0a 28 64 65 63 ock-queue)).(dec
0460: 6c 61 72 65 20 28 75 73 65 73 20 64 62 29 29 0a lare (uses db)).
0470: 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 74 (declare (uses t
0480: 64 62 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 db)).(declare (u
0490: 73 65 73 20 63 6f 6d 6d 6f 6e 29 29 0a 3b 3b 20 ses common)).;;
04a0: 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 64 (declare (uses d
04b0: 63 6f 6d 6d 6f 6e 29 29 20 3b 3b 20 6e 65 65 64 common)) ;; need
04c0: 65 64 20 66 6f 72 20 74 68 65 20 73 74 65 70 73 ed for the steps
04d0: 20 70 72 6f 63 65 73 73 69 6e 67 0a 28 64 65 63 processing.(dec
04e0: 6c 61 72 65 20 28 75 73 65 73 20 69 74 65 6d 73 lare (uses items
04f0: 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 )).(declare (use
0500: 73 20 72 75 6e 63 6f 6e 66 69 67 29 29 0a 3b 3b s runconfig)).;;
0510: 20 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 (declare (uses
0520: 73 64 62 29 29 0a 28 64 65 63 6c 61 72 65 20 28 sdb)).(declare (
0530: 75 73 65 73 20 73 65 72 76 65 72 29 29 0a 28 64 uses server)).(d
0540: 65 63 6c 61 72 65 20 28 75 73 65 73 20 73 74 6d eclare (uses stm
0550: 6c 32 29 29 0a 0a 28 75 73 65 20 73 71 6c 69 74 l2))..(use sqlit
0560: 65 33 20 73 72 66 69 2d 31 20 70 6f 73 69 78 20 e3 srfi-1 posix
0570: 72 65 67 65 78 20 72 65 67 65 78 2d 63 61 73 65 regex regex-case
0580: 20 73 72 66 69 2d 36 39 20 64 6f 74 2d 6c 6f 63 srfi-69 dot-loc
0590: 6b 69 6e 67 20 74 63 70 20 64 69 72 65 63 74 6f king tcp directo
05a0: 72 79 2d 75 74 69 6c 73 29 0a 28 69 6d 70 6f 72 ry-utils).(impor
05b0: 74 20 28 70 72 65 66 69 78 20 73 71 6c 69 74 65 t (prefix sqlite
05c0: 33 20 73 71 6c 69 74 65 33 3a 29 29 0a 28 69 6d 3 sqlite3:)).(im
05d0: 70 6f 72 74 20 73 74 6d 6c 32 29 0a 0a 28 69 6e port stml2)..(in
05e0: 63 6c 75 64 65 20 22 63 6f 6d 6d 6f 6e 5f 72 65 clude "common_re
05f0: 63 6f 72 64 73 2e 73 63 6d 22 29 0a 28 69 6e 63 cords.scm").(inc
0600: 6c 75 64 65 20 22 6b 65 79 5f 72 65 63 6f 72 64 lude "key_record
0610: 73 2e 73 63 6d 22 29 0a 28 69 6e 63 6c 75 64 65 s.scm").(include
0620: 20 22 64 62 5f 72 65 63 6f 72 64 73 2e 73 63 6d "db_records.scm
0630: 22 29 0a 28 69 6e 63 6c 75 64 65 20 22 72 75 6e ").(include "run
0640: 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a 28 _records.scm").(
0650: 69 6e 63 6c 75 64 65 20 22 74 65 73 74 5f 72 65 include "test_re
0660: 63 6f 72 64 73 2e 73 63 6d 22 29 0a 28 69 6e 63 cords.scm").(inc
0670: 6c 75 64 65 20 22 6a 73 2d 70 61 74 68 2e 73 63 lude "js-path.sc
0680: 6d 22 29 0a 0a 28 64 65 66 69 6e 65 20 28 69 6e m")..(define (in
0690: 69 74 2d 6a 61 76 61 2d 73 63 72 69 70 74 2d 6c it-java-script-l
06a0: 69 62 29 0a 20 20 28 73 65 74 21 20 2a 6a 61 76 ib). (set! *jav
06b0: 61 2d 73 63 72 69 70 74 2d 6c 69 62 2a 20 28 63 a-script-lib* (c
06c0: 6f 6e 63 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 onc (common:get
06d0: 2d 69 6e 73 74 61 6c 6c 2d 61 72 65 61 29 20 22 -install-area) "
06e0: 2f 73 68 61 72 65 2f 6a 73 2f 6a 71 75 65 72 79 /share/js/jquery
06f0: 2d 33 2e 31 2e 30 2e 73 6c 69 6d 2e 6d 69 6e 2e -3.1.0.slim.min.
0700: 6a 73 22 29 29 0a 20 20 29 0a 0a 3b 3b 20 43 61 js")). )..;; Ca
0710: 6c 6c 20 74 68 69 73 20 6f 6e 65 20 74 6f 20 64 ll this one to d
0720: 6f 20 61 6c 6c 20 74 68 65 20 77 6f 72 6b 20 61 o all the work a
0730: 6e 64 20 67 65 74 20 61 20 73 74 61 6e 64 61 72 nd get a standar
0740: 64 69 7a 65 64 20 6c 69 73 74 20 6f 66 20 74 65 dized list of te
0750: 73 74 73 0a 3b 3b 20 20 20 67 65 74 73 20 70 61 sts.;; gets pa
0760: 74 68 73 20 66 72 6f 6d 20 63 6f 6e 66 69 67 73 ths from configs
0770: 20 61 6e 64 20 66 69 6e 64 73 20 76 61 6c 69 64 and finds valid
0780: 20 74 65 73 74 73 20 0a 3b 3b 20 20 20 72 65 74 tests .;; ret
0790: 75 72 6e 73 20 68 61 73 68 20 6f 66 20 74 65 73 urns hash of tes
07a0: 74 6e 61 6d 65 20 2d 2d 3e 20 66 75 6c 6c 70 61 tname --> fullpa
07b0: 74 68 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 th.;;.(define (t
07c0: 65 73 74 73 3a 67 65 74 2d 61 6c 6c 29 0a 20 20 ests:get-all).
07d0: 28 6c 65 74 2a 20 28 28 74 65 73 74 2d 73 65 61 (let* ((test-sea
07e0: 72 63 68 2d 70 61 74 68 20 20 20 28 74 65 73 74 rch-path (test
07f0: 73 3a 67 65 74 2d 74 65 73 74 73 2d 73 65 61 72 s:get-tests-sear
0800: 63 68 2d 70 61 74 68 20 2a 63 6f 6e 66 69 67 64 ch-path *configd
0810: 61 74 2a 29 29 29 0a 20 20 20 20 28 64 65 62 75 at*))). (debu
0820: 67 3a 70 72 69 6e 74 20 38 20 2a 64 65 66 61 75 g:print 8 *defau
0830: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 74 65 lt-log-port* "te
0840: 73 74 2d 73 65 61 72 63 68 2d 70 61 74 68 3a 20 st-search-path:
0850: 22 20 74 65 73 74 2d 73 65 61 72 63 68 2d 70 61 " test-search-pa
0860: 74 68 29 0a 20 20 20 20 28 74 65 73 74 73 3a 67 th). (tests:g
0870: 65 74 2d 76 61 6c 69 64 2d 74 65 73 74 73 20 28 et-valid-tests (
0880: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
0890: 20 74 65 73 74 2d 73 65 61 72 63 68 2d 70 61 74 test-search-pat
08a0: 68 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 h)))..(define (t
08b0: 65 73 74 73 3a 67 65 74 2d 74 65 73 74 73 2d 73 ests:get-tests-s
08c0: 65 61 72 63 68 2d 70 61 74 68 20 63 66 67 64 61 earch-path cfgda
08d0: 74 29 0a 20 20 28 6c 65 74 20 28 28 70 61 74 68 t). (let ((path
08e0: 73 20 28 6c 65 74 20 28 28 73 65 63 74 69 6f 6e s (let ((section
08f0: 20 28 69 66 20 63 66 67 64 61 74 0a 09 09 09 09 (if cfgdat.....
0900: 20 20 28 63 6f 6e 66 69 67 66 3a 67 65 74 2d 73 (configf:get-s
0910: 65 63 74 69 6f 6e 20 63 66 67 64 61 74 20 22 74 ection cfgdat "t
0920: 65 73 74 73 2d 70 61 74 68 73 22 29 0a 09 09 09 ests-paths")....
0930: 09 20 20 23 66 29 29 29 0a 09 09 20 28 69 66 20 . #f)))... (if
0940: 73 65 63 74 69 6f 6e 0a 09 09 20 20 20 20 20 28 section... (
0950: 6d 61 70 20 63 61 64 72 20 73 65 63 74 69 6f 6e map cadr section
0960: 29 0a 09 09 20 20 20 20 20 27 28 29 29 29 29 29 )... '()))))
0970: 0a 20 20 20 20 28 66 69 6c 74 65 72 20 28 6c 61 . (filter (la
0980: 6d 62 64 61 20 28 64 29 0a 09 20 20 20 20 20 20 mbda (d)..
0990: 28 69 66 20 28 64 69 72 65 63 74 6f 72 79 2d 65 (if (directory-e
09a0: 78 69 73 74 73 3f 20 64 29 0a 09 09 20 20 64 0a xists? d)... d.
09b0: 09 09 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 .. (begin...
09c0: 20 3b 3b 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a ;; (if (common:
09d0: 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 20 low-noise-print
09e0: 36 30 20 22 74 65 73 74 73 3a 67 65 74 2d 74 65 60 "tests:get-te
09f0: 73 74 73 2d 73 65 61 72 63 68 2d 70 61 74 68 22 sts-search-path"
0a00: 20 64 29 0a 09 09 20 20 20 20 3b 3b 09 28 64 65 d)... ;;.(de
0a10: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
0a20: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
0a30: 57 41 52 4e 49 4e 47 3a 20 70 72 6f 62 6c 65 6d WARNING: problem
0a40: 20 77 69 74 68 20 64 69 72 65 63 74 6f 72 79 20 with directory
0a50: 22 20 64 20 22 2c 20 64 72 6f 70 70 69 6e 67 20 " d ", dropping
0a60: 69 74 20 66 72 6f 6d 20 74 65 73 74 73 20 70 61 it from tests pa
0a70: 74 68 22 29 29 0a 09 09 20 20 20 20 23 66 29 29 th"))... #f))
0a80: 29 0a 09 20 20 20 20 28 61 70 70 65 6e 64 20 70 ).. (append p
0a90: 61 74 68 73 20 28 6c 69 73 74 20 28 63 6f 6e 63 aths (list (conc
0aa0: 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 74 65 73 *toppath* "/tes
0ab0: 74 73 22 29 29 29 29 29 29 0a 0a 28 64 65 66 69 ts"))))))..(defi
0ac0: 6e 65 20 28 74 65 73 74 73 3a 67 65 74 2d 76 61 ne (tests:get-va
0ad0: 6c 69 64 2d 74 65 73 74 73 20 74 65 73 74 2d 72 lid-tests test-r
0ae0: 65 67 69 73 74 72 79 20 74 65 73 74 73 2d 70 61 egistry tests-pa
0af0: 74 68 73 29 0a 20 20 28 69 66 20 28 6e 75 6c 6c ths). (if (null
0b00: 3f 20 74 65 73 74 73 2d 70 61 74 68 73 29 20 0a ? tests-paths) .
0b10: 20 20 20 20 20 20 74 65 73 74 2d 72 65 67 69 73 test-regis
0b20: 74 72 79 0a 20 20 20 20 20 20 28 6c 65 74 20 6c try. (let l
0b30: 6f 6f 70 20 28 28 68 65 64 20 28 63 61 72 20 74 oop ((hed (car t
0b40: 65 73 74 73 2d 70 61 74 68 73 29 29 0a 09 09 20 ests-paths))...
0b50: 28 74 61 6c 20 28 63 64 72 20 74 65 73 74 73 2d (tal (cdr tests-
0b60: 70 61 74 68 73 29 29 29 0a 09 28 69 66 20 28 63 paths)))..(if (c
0b70: 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 ommon:file-exist
0b80: 73 3f 20 68 65 64 29 0a 09 20 20 20 20 28 66 6f s? hed).. (fo
0b90: 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 r-each (lambda (
0ba0: 74 65 73 74 2d 70 61 74 68 29 0a 09 09 09 28 6c test-path)....(l
0bb0: 65 74 2a 20 28 28 74 6e 61 6d 65 20 20 20 28 6c et* ((tname (l
0bc0: 61 73 74 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 ast (string-spli
0bd0: 74 20 74 65 73 74 2d 70 61 74 68 20 22 2f 22 29 t test-path "/")
0be0: 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 74 63 )).... (tc
0bf0: 6f 6e 66 69 67 20 28 63 6f 6e 63 20 74 65 73 74 onfig (conc test
0c00: 2d 70 61 74 68 20 22 2f 74 65 73 74 63 6f 6e 66 -path "/testconf
0c10: 69 67 22 29 29 29 0a 09 09 09 20 20 28 69 66 20 ig"))).... (if
0c20: 28 61 6e 64 20 28 6e 6f 74 20 28 68 61 73 68 2d (and (not (hash-
0c30: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
0c40: 74 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 t test-registry
0c50: 74 6e 61 6d 65 20 23 66 29 29 0a 09 09 09 09 20 tname #f)).....
0c60: 20 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 (common:file-e
0c70: 78 69 73 74 73 3f 20 74 63 6f 6e 66 69 67 29 29 xists? tconfig))
0c80: 0a 09 09 09 20 20 20 20 20 20 28 68 61 73 68 2d .... (hash-
0c90: 74 61 62 6c 65 2d 73 65 74 21 20 74 65 73 74 2d table-set! test-
0ca0: 72 65 67 69 73 74 72 79 20 74 6e 61 6d 65 20 74 registry tname t
0cb0: 65 73 74 2d 70 61 74 68 29 29 29 29 0a 09 09 20 est-path))))...
0cc0: 20 20 20 20 20 28 67 6c 6f 62 20 28 63 6f 6e 63 (glob (conc
0cd0: 20 68 65 64 20 22 2f 2a 22 29 29 29 29 0a 09 28 hed "/*"))))..(
0ce0: 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 if (null? tal)..
0cf0: 20 20 20 20 74 65 73 74 2d 72 65 67 69 73 74 72 test-registr
0d00: 79 0a 09 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 y.. (loop (ca
0d10: 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 29 r tal)(cdr tal))
0d20: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 ))))..(define (t
0d30: 65 73 74 73 3a 66 69 6c 74 65 72 2d 74 65 73 74 ests:filter-test
0d40: 2d 6e 61 6d 65 73 2d 6e 6f 74 2d 6d 61 74 63 68 -names-not-match
0d50: 65 64 20 74 65 73 74 2d 6e 61 6d 65 73 20 74 65 ed test-names te
0d60: 73 74 2d 70 61 74 74 73 29 0a 20 20 28 64 65 6c st-patts). (del
0d70: 65 74 65 2d 64 75 70 6c 69 63 61 74 65 73 0a 20 ete-duplicates.
0d80: 20 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 (filter (lambd
0d90: 61 20 28 74 65 73 74 6e 61 6d 65 29 0a 09 20 20 a (testname)..
0da0: 20 20 20 28 6e 6f 74 20 28 74 65 73 74 73 3a 6d (not (tests:m
0db0: 61 74 63 68 20 74 65 73 74 2d 70 61 74 74 73 20 atch test-patts
0dc0: 74 65 73 74 6e 61 6d 65 20 23 66 29 29 29 0a 09 testname #f)))..
0dd0: 20 20 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 29 test-names)))
0de0: 0a 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 ...(define (test
0df0: 73 3a 66 69 6c 74 65 72 2d 74 65 73 74 2d 6e 61 s:filter-test-na
0e00: 6d 65 73 20 74 65 73 74 2d 6e 61 6d 65 73 20 74 mes test-names t
0e10: 65 73 74 2d 70 61 74 74 73 29 0a 20 20 28 64 65 est-patts). (de
0e20: 6c 65 74 65 2d 64 75 70 6c 69 63 61 74 65 73 0a lete-duplicates.
0e30: 20 20 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 (filter (lamb
0e40: 64 61 20 28 74 65 73 74 6e 61 6d 65 29 0a 09 20 da (testname)..
0e50: 20 20 20 20 28 74 65 73 74 73 3a 6d 61 74 63 68 (tests:match
0e60: 20 74 65 73 74 2d 70 61 74 74 73 20 74 65 73 74 test-patts test
0e70: 6e 61 6d 65 20 23 66 29 29 0a 09 20 20 20 74 65 name #f)).. te
0e80: 73 74 2d 6e 61 6d 65 73 29 29 29 0a 0a 3b 3b 20 st-names)))..;;
0e90: 69 74 65 6d 6d 61 70 20 69 73 20 61 20 6c 69 73 itemmap is a lis
0ea0: 74 20 6f 66 20 74 65 73 74 6e 61 6d 65 20 70 61 t of testname pa
0eb0: 74 74 65 72 6e 73 20 74 6f 20 6d 61 70 73 0a 3b tterns to maps.;
0ec0: 3b 20 20 20 20 20 74 65 73 74 31 20 2e 2a 2f 62 ; test1 .*/b
0ed0: 61 72 2f 28 5c 64 2b 29 20 66 6f 6f 2f 5c 31 0a ar/(\d+) foo/\1.
0ee0: 3b 3b 20 20 20 20 20 25 20 20 20 20 20 66 6f 6f ;; % foo
0ef0: 2f 28 5b 5e 2f 5d 2b 29 20 20 5c 31 2f 62 61 72 /([^/]+) \1/bar
0f00: 0a 3b 3b 0a 3b 3b 20 23 20 4e 4f 54 45 3a 20 74 .;;.;; # NOTE: t
0f10: 68 65 20 6c 69 6e 65 20 77 69 74 68 20 74 68 65 he line with the
0f20: 20 73 69 6e 67 6c 65 20 25 20 63 6f 75 6c 64 20 single % could
0f30: 62 65 20 74 68 65 20 72 65 73 75 6c 74 20 6f 66 be the result of
0f40: 0a 3b 3b 20 23 20 20 20 20 20 20 20 69 74 65 6d .;; # item
0f50: 6d 61 70 20 65 6e 74 72 79 20 69 6e 20 72 65 71 map entry in req
0f60: 75 69 72 65 6d 65 6e 74 73 20 28 6c 65 67 61 63 uirements (legac
0f70: 79 29 2e 20 54 68 65 20 69 74 65 6d 6d 61 70 0a y). The itemmap.
0f80: 3b 3b 20 23 20 20 20 20 20 20 20 72 65 71 75 69 ;; # requi
0f90: 72 65 6d 65 6e 74 73 20 65 6e 74 72 79 20 69 73 rements entry is
0fa0: 20 64 65 70 72 65 63 61 74 65 64 0a 3b 3b 0a 28 deprecated.;;.(
0fb0: 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 67 65 define (tests:ge
0fc0: 74 2d 69 74 65 6d 6d 61 70 73 20 74 63 6f 6e 66 t-itemmaps tconf
0fd0: 69 67 29 0a 20 20 28 6c 65 74 20 28 28 62 61 73 ig). (let ((bas
0fe0: 65 2d 69 74 65 6d 6d 61 70 20 20 28 63 6f 6e 66 e-itemmap (conf
0ff0: 69 67 66 3a 6c 6f 6f 6b 75 70 20 74 63 6f 6e 66 igf:lookup tconf
1000: 69 67 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 ig "requirements
1010: 22 20 22 69 74 65 6d 6d 61 70 22 29 29 0a 09 28 " "itemmap"))..(
1020: 69 74 65 6d 6d 61 70 2d 74 61 62 6c 65 20 28 63 itemmap-table (c
1030: 6f 6e 66 69 67 66 3a 67 65 74 2d 73 65 63 74 69 onfigf:get-secti
1040: 6f 6e 20 74 63 6f 6e 66 69 67 20 22 69 74 65 6d on tconfig "item
1050: 6d 61 70 22 29 29 29 0a 20 20 20 20 28 61 70 70 map"))). (app
1060: 65 6e 64 20 28 69 66 20 62 61 73 65 2d 69 74 65 end (if base-ite
1070: 6d 6d 61 70 0a 09 09 28 6c 69 73 74 20 28 6c 69 mmap...(list (li
1080: 73 74 20 22 25 22 20 62 61 73 65 2d 69 74 65 6d st "%" base-item
1090: 6d 61 70 29 29 0a 09 09 27 28 29 29 0a 09 20 20 map))...'())..
10a0: 20 20 28 69 66 20 69 74 65 6d 6d 61 70 2d 74 61 (if itemmap-ta
10b0: 62 6c 65 0a 09 09 69 74 65 6d 6d 61 70 2d 74 61 ble...itemmap-ta
10c0: 62 6c 65 0a 09 09 27 28 29 29 29 29 29 0a 0a 3b ble...'()))))..;
10d0: 3b 20 67 69 76 65 6e 20 61 20 6c 69 73 74 20 6f ; given a list o
10e0: 66 20 69 74 65 6d 6d 61 70 73 20 28 74 65 73 74 f itemmaps (test
10f0: 6e 61 6d 65 20 2e 20 6d 61 70 29 2c 20 72 65 74 name . map), ret
1100: 75 72 6e 20 74 68 65 20 66 69 72 73 74 20 6d 61 urn the first ma
1110: 74 63 68 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 tch.;;.(define (
1120: 74 65 73 74 73 3a 6c 6f 6f 6b 75 70 2d 69 74 65 tests:lookup-ite
1130: 6d 6d 61 70 20 69 74 65 6d 6d 61 70 73 20 74 65 mmap itemmaps te
1140: 73 74 6e 61 6d 65 29 0a 20 20 28 6c 65 74 20 28 stname). (let (
1150: 28 62 65 73 74 2d 6d 61 74 63 68 65 73 20 28 66 (best-matches (f
1160: 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 69 ilter (lambda (i
1170: 74 65 6d 6d 61 70 29 0a 09 09 09 09 28 74 65 73 temmap).....(tes
1180: 74 73 3a 6d 61 74 63 68 20 28 63 61 72 20 69 74 ts:match (car it
1190: 65 6d 6d 61 70 29 20 74 65 73 74 6e 61 6d 65 20 emmap) testname
11a0: 23 66 29 29 0a 09 09 09 20 20 20 20 20 20 69 74 #f)).... it
11b0: 65 6d 6d 61 70 73 29 29 29 0a 20 20 20 20 28 69 emmaps))). (i
11c0: 66 20 28 6e 75 6c 6c 3f 20 62 65 73 74 2d 6d 61 f (null? best-ma
11d0: 74 63 68 65 73 29 0a 09 23 66 0a 09 28 6c 65 74 tches)..#f..(let
11e0: 20 28 28 72 65 73 20 28 63 61 72 20 62 65 73 74 ((res (car best
11f0: 2d 6d 61 74 63 68 65 73 29 29 29 0a 09 20 20 3b -matches))).. ;
1200: 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 ; (debug:print 0
1210: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
1220: 72 74 2a 20 22 72 65 73 3d 22 20 72 65 73 29 0a rt* "res=" res).
1230: 09 20 20 28 63 6f 6e 64 0a 09 20 20 20 28 28 73 . (cond.. ((s
1240: 74 72 69 6e 67 3f 20 72 65 73 29 20 72 65 73 29 tring? res) res)
1250: 20 3b 3b 3b 20 46 49 58 20 54 48 45 20 52 4f 4f ;;; FIX THE ROO
1260: 54 20 43 41 55 53 45 20 48 45 52 45 20 2e 2e 2e T CAUSE HERE ...
1270: 2e 0a 09 20 20 20 28 28 6e 75 6c 6c 3f 20 72 65 ... ((null? re
1280: 73 29 20 20 20 23 66 29 0a 09 20 20 20 28 28 73 s) #f).. ((s
1290: 74 72 69 6e 67 3f 20 28 63 64 72 20 72 65 73 29 tring? (cdr res)
12a0: 29 20 28 63 64 72 20 72 65 73 29 29 20 20 3b 3b ) (cdr res)) ;;
12b0: 20 69 74 20 69 73 20 61 20 70 61 69 72 0a 09 20 it is a pair..
12c0: 20 20 28 28 73 74 72 69 6e 67 3f 20 28 63 61 64 ((string? (cad
12d0: 72 20 72 65 73 29 29 28 63 61 64 72 20 72 65 73 r res))(cadr res
12e0: 29 29 20 3b 3b 20 69 74 20 69 73 20 61 20 6c 69 )) ;; it is a li
12f0: 73 74 0a 09 20 20 20 28 65 6c 73 65 20 63 61 64 st.. (else cad
1300: 72 20 72 65 73 29 29 29 29 29 29 0a 0a 3b 3b 20 r res))))))..;;
1310: 72 65 74 75 72 6e 20 69 74 65 6d 73 20 67 69 76 return items giv
1320: 65 6e 20 63 6f 6e 66 69 67 0a 3b 3b 0a 28 64 65 en config.;;.(de
1330: 66 69 6e 65 20 28 74 65 73 74 73 3a 67 65 74 2d fine (tests:get-
1340: 69 74 65 6d 73 20 74 63 6f 6e 66 69 67 29 0a 20 items tconfig).
1350: 20 28 6c 65 74 20 28 28 69 74 65 6d 73 20 20 20 (let ((items
1360: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 (hash-table-r
1370: 65 66 2f 64 65 66 61 75 6c 74 20 74 63 6f 6e 66 ef/default tconf
1380: 69 67 20 22 69 74 65 6d 73 22 20 23 66 29 29 20 ig "items" #f))
1390: 3b 3b 20 69 74 65 6d 73 20 34 0a 09 28 69 74 65 ;; items 4..(ite
13a0: 6d 73 74 61 62 6c 65 20 28 68 61 73 68 2d 74 61 mstable (hash-ta
13b0: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
13c0: 74 63 6f 6e 66 69 67 20 22 69 74 65 6d 73 74 61 tconfig "itemsta
13d0: 62 6c 65 22 20 23 66 29 29 29 20 0a 20 20 20 20 ble" #f))) .
13e0: 3b 3b 20 69 66 20 65 69 74 68 65 72 20 69 74 65 ;; if either ite
13f0: 6d 73 20 6f 72 20 69 74 65 6d 73 20 74 61 62 6c ms or items tabl
1400: 65 20 69 73 20 61 20 70 72 6f 63 20 72 65 74 75 e is a proc retu
1410: 72 6e 20 69 74 20 73 6f 20 74 65 73 74 20 72 75 rn it so test ru
1420: 6e 6e 69 6e 67 0a 20 20 20 20 3b 3b 20 70 72 6f nning. ;; pro
1430: 63 65 73 73 20 63 61 6e 20 6b 6e 6f 77 20 74 6f cess can know to
1440: 20 63 61 6c 6c 20 69 74 65 6d 73 3a 67 65 74 2d call items:get-
1450: 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 items-from-confi
1460: 67 0a 20 20 20 20 3b 3b 20 69 66 20 65 69 74 68 g. ;; if eith
1470: 65 72 20 69 73 20 61 20 6c 69 73 74 20 61 6e 64 er is a list and
1480: 20 6e 6f 6e 65 20 69 73 20 61 20 70 72 6f 63 20 none is a proc
1490: 67 6f 20 61 68 65 61 64 20 61 6e 64 20 63 61 6c go ahead and cal
14a0: 6c 20 67 65 74 2d 69 74 65 6d 73 0a 20 20 20 20 l get-items.
14b0: 3b 3b 20 6f 74 68 65 72 77 69 73 65 20 72 65 74 ;; otherwise ret
14c0: 75 72 6e 20 23 66 20 2d 20 74 68 69 73 20 69 73 urn #f - this is
14d0: 20 6e 6f 74 20 61 6e 20 69 74 65 72 61 74 65 64 not an iterated
14e0: 20 74 65 73 74 0a 20 20 20 20 28 63 6f 6e 64 0a test. (cond.
14f0: 20 20 20 20 20 28 28 70 72 6f 63 65 64 75 72 65 ((procedure
1500: 3f 20 69 74 65 6d 73 29 20 20 20 20 20 20 0a 20 ? items) .
1510: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
1520: 74 2d 69 6e 66 6f 20 34 20 2a 64 65 66 61 75 6c t-info 4 *defaul
1530: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 69 74 65 t-log-port* "ite
1540: 6d 73 20 69 73 20 61 20 70 72 6f 63 65 64 75 72 ms is a procedur
1550: 65 2c 20 77 69 6c 6c 20 63 61 6c 63 20 6c 61 74 e, will calc lat
1560: 65 72 22 29 0a 20 20 20 20 20 20 69 74 65 6d 73 er"). items
1570: 29 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ) ;;
1580: 63 61 6c 63 20 6c 61 74 65 72 0a 20 20 20 20 20 calc later.
1590: 28 28 70 72 6f 63 65 64 75 72 65 3f 20 69 74 65 ((procedure? ite
15a0: 6d 73 74 61 62 6c 65 29 0a 20 20 20 20 20 20 28 mstable). (
15b0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
15c0: 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 4 *default-log-
15d0: 70 6f 72 74 2a 20 22 69 74 65 6d 73 74 61 62 6c port* "itemstabl
15e0: 65 20 69 73 20 61 20 70 72 6f 63 65 64 75 72 65 e is a procedure
15f0: 2c 20 77 69 6c 6c 20 63 61 6c 63 20 6c 61 74 65 , will calc late
1600: 72 22 29 0a 20 20 20 20 20 20 69 74 65 6d 73 74 r"). itemst
1610: 61 62 6c 65 29 20 20 20 20 20 20 20 3b 3b 20 63 able) ;; c
1620: 61 6c 63 20 6c 61 74 65 72 0a 20 20 20 20 20 28 alc later. (
1630: 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 (filter (lambda
1640: 28 78 29 0a 09 09 28 6c 65 74 20 28 28 76 61 6c (x)...(let ((val
1650: 20 28 63 61 72 20 78 29 29 29 0a 09 09 20 20 28 (car x)))... (
1660: 69 66 20 28 70 72 6f 63 65 64 75 72 65 3f 20 76 if (procedure? v
1670: 61 6c 29 20 76 61 6c 20 23 66 29 29 29 0a 09 20 al) val #f)))..
1680: 20 20 20 20 20 28 61 70 70 65 6e 64 20 28 69 66 (append (if
1690: 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 20 69 (list? items) i
16a0: 74 65 6d 73 20 27 28 29 29 0a 09 09 20 20 20 20 tems '())...
16b0: 20 20 28 69 66 20 28 6c 69 73 74 3f 20 69 74 65 (if (list? ite
16c0: 6d 73 74 61 62 6c 65 29 20 69 74 65 6d 73 74 61 mstable) itemsta
16d0: 62 6c 65 20 27 28 29 29 29 29 0a 20 20 20 20 20 ble '()))).
16e0: 20 27 68 61 76 65 2d 70 72 6f 63 65 64 75 72 65 'have-procedure
16f0: 29 0a 20 20 20 20 20 28 28 6f 72 20 28 6c 69 73 ). ((or (lis
1700: 74 3f 20 69 74 65 6d 73 29 28 6c 69 73 74 3f 20 t? items)(list?
1710: 69 74 65 6d 73 74 61 62 6c 65 29 29 20 3b 3b 20 itemstable)) ;;
1720: 63 61 6c 63 20 6e 6f 77 0a 20 20 20 20 20 20 28 calc now. (
1730: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
1740: 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 4 *default-log-
1750: 70 6f 72 74 2a 20 22 69 74 65 6d 73 20 61 6e 64 port* "items and
1760: 20 69 74 65 6d 73 74 61 62 6c 65 20 61 72 65 20 itemstable are
1770: 6c 69 73 74 73 2c 20 63 61 6c 63 20 6e 6f 77 5c lists, calc now\
1780: 6e 22 0a 09 09 09 22 20 20 20 20 69 74 65 6d 73 n"...." items
1790: 3a 20 22 20 69 74 65 6d 73 20 22 20 69 74 65 6d : " items " item
17a0: 73 74 61 62 6c 65 3a 20 22 20 69 74 65 6d 73 74 stable: " itemst
17b0: 61 62 6c 65 29 0a 20 20 20 20 20 20 28 69 74 65 able). (ite
17c0: 6d 73 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f ms:get-items-fro
17d0: 6d 2d 63 6f 6e 66 69 67 20 74 63 6f 6e 66 69 67 m-config tconfig
17e0: 29 29 0a 20 20 20 20 20 28 65 6c 73 65 20 23 66 )). (else #f
17f0: 29 29 29 29 20 20 20 20 20 20 20 20 20 20 20 20 ))))
1800: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
1810: 3b 20 6e 6f 74 20 69 74 65 72 61 74 65 64 0a 0a ; not iterated..
1820: 0a 3b 3b 20 72 65 74 75 72 6e 73 20 77 61 69 74 .;; returns wait
1830: 6f 6e 73 20 77 61 69 74 6f 72 73 20 74 63 6f 6e ons waitors tcon
1840: 66 69 67 64 61 74 0a 3b 3b 0a 28 64 65 66 69 6e figdat.;;.(defin
1850: 65 20 28 74 65 73 74 73 3a 67 65 74 2d 77 61 69 e (tests:get-wai
1860: 74 6f 6e 73 20 74 65 73 74 2d 6e 61 6d 65 20 61 tons test-name a
1870: 6c 6c 2d 74 65 73 74 73 2d 72 65 67 69 73 74 72 ll-tests-registr
1880: 79 29 0a 20 20 20 28 6c 65 74 2a 20 28 28 63 6f y). (let* ((co
1890: 6e 66 69 67 20 20 28 74 65 73 74 73 3a 67 65 74 nfig (tests:get
18a0: 2d 74 65 73 74 63 6f 6e 66 69 67 20 74 65 73 74 -testconfig test
18b0: 2d 6e 61 6d 65 20 23 66 20 61 6c 6c 2d 74 65 73 -name #f all-tes
18c0: 74 73 2d 72 65 67 69 73 74 72 79 20 27 72 65 74 ts-registry 'ret
18d0: 75 72 6e 2d 70 72 6f 63 73 29 29 29 20 3b 3b 20 urn-procs))) ;;
18e0: 61 73 73 75 6d 69 6e 67 20 6e 6f 20 70 72 6f 62 assuming no prob
18f0: 6c 65 6d 73 20 77 69 74 68 20 69 6d 6d 65 64 69 lems with immedi
1900: 61 74 65 20 65 76 61 6c 75 61 74 69 6f 6e 2c 20 ate evaluation,
1910: 74 68 69 73 20 63 6f 75 6c 64 20 62 65 20 73 69 this could be si
1920: 6d 70 6c 69 66 69 65 64 20 28 27 72 65 74 75 72 mplified ('retur
1930: 6e 2d 70 72 6f 63 73 20 2d 3e 20 23 74 29 0a 20 n-procs -> #t).
1940: 20 20 20 20 28 6c 65 74 20 28 28 69 6e 73 74 72 (let ((instr
1950: 20 28 69 66 20 63 6f 6e 66 69 67 20 0a 09 09 20 (if config ...
1960: 20 20 20 20 20 28 63 6f 6e 66 69 67 66 3a 6c 6f (configf:lo
1970: 6f 6b 75 70 20 63 6f 6e 66 69 67 20 22 72 65 71 okup config "req
1980: 75 69 72 65 6d 65 6e 74 73 22 20 22 77 61 69 74 uirements" "wait
1990: 6f 6e 22 29 0a 09 09 20 20 20 20 20 20 28 62 65 on")... (be
19a0: 67 69 6e 20 3b 3b 20 4e 6f 20 63 6f 6e 66 69 67 gin ;; No config
19b0: 20 6d 65 61 6e 73 20 74 68 69 73 20 69 73 20 61 means this is a
19c0: 20 6e 6f 6e 2d 65 78 69 73 74 61 6e 74 20 74 65 non-existant te
19d0: 73 74 0a 09 09 09 28 64 65 62 75 67 3a 70 72 69 st....(debug:pri
19e0: 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 nt-error 0 *defa
19f0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 6e ult-log-port* "n
1a00: 6f 6e 2d 65 78 69 73 74 65 6e 74 20 72 65 71 75 on-existent requ
1a10: 69 72 65 64 20 74 65 73 74 20 5c 22 22 20 74 65 ired test \"" te
1a20: 73 74 2d 6e 61 6d 65 20 22 5c 22 22 29 0a 09 09 st-name "\"")...
1a30: 09 28 65 78 69 74 20 31 29 29 29 29 0a 09 20 20 .(exit 1))))..
1a40: 20 28 69 6e 73 74 72 32 20 28 69 66 20 63 6f 6e (instr2 (if con
1a50: 66 69 67 0a 09 09 20 20 20 20 20 20 20 28 63 6f fig... (co
1a60: 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 63 6f 6e nfigf:lookup con
1a70: 66 69 67 20 22 72 65 71 75 69 72 65 6d 65 6e 74 fig "requirement
1a80: 73 22 20 22 77 61 69 74 6f 72 22 29 0a 09 09 20 s" "waitor")...
1a90: 20 20 20 20 20 20 22 22 29 29 29 0a 20 20 20 20 ""))).
1aa0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
1ab0: 69 6e 66 6f 20 38 20 2a 64 65 66 61 75 6c 74 2d info 8 *default-
1ac0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 77 61 69 74 6f log-port* "waito
1ad0: 6e 73 20 73 74 72 69 6e 67 20 69 73 20 22 20 69 ns string is " i
1ae0: 6e 73 74 72 20 22 2c 20 77 61 69 74 6f 72 73 20 nstr ", waitors
1af0: 73 74 72 69 6e 67 20 69 73 20 22 20 69 6e 73 74 string is " inst
1b00: 72 32 29 0a 20 20 20 20 20 20 20 28 6c 65 74 20 r2). (let
1b10: 28 28 6e 65 77 77 61 69 74 6f 6e 73 0a 09 20 20 ((newwaitons..
1b20: 20 20 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 (string-spli
1b30: 74 20 28 63 6f 6e 64 0a 09 09 09 20 20 20 20 20 t (cond....
1b40: 28 28 70 72 6f 63 65 64 75 72 65 3f 20 69 6e 73 ((procedure? ins
1b50: 74 72 29 20 3b 3b 20 68 65 72 65 20 0a 09 09 09 tr) ;; here ....
1b60: 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 (let ((res
1b70: 20 28 69 6e 73 74 72 29 29 29 0a 09 09 09 09 28 (instr))).....(
1b80: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
1b90: 20 38 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 8 *default-log-
1ba0: 70 6f 72 74 2a 20 22 77 61 69 74 6f 6e 20 70 72 port* "waiton pr
1bb0: 6f 63 65 64 75 72 65 20 72 65 73 75 6c 74 73 20 ocedure results
1bc0: 69 6e 20 73 74 72 69 6e 67 20 22 20 72 65 73 20 in string " res
1bd0: 22 20 66 6f 72 20 74 65 73 74 20 22 20 74 65 73 " for test " tes
1be0: 74 2d 6e 61 6d 65 29 0a 09 09 09 09 72 65 73 29 t-name).....res)
1bf0: 29 0a 09 09 09 20 20 20 20 20 28 28 73 74 72 69 ).... ((stri
1c00: 6e 67 3f 20 69 6e 73 74 72 29 20 20 20 20 20 69 ng? instr) i
1c10: 6e 73 74 72 29 0a 09 09 09 20 20 20 20 20 28 65 nstr).... (e
1c20: 6c 73 65 20 0a 09 09 09 20 20 20 20 20 20 3b 3b lse .... ;;
1c30: 20 4e 4f 54 45 3a 20 54 68 69 73 20 69 73 20 61 NOTE: This is a
1c40: 63 74 75 61 6c 6c 79 20 74 68 65 20 63 61 73 65 ctually the case
1c50: 20 6f 66 20 2a 6e 6f 2a 20 77 61 69 74 6f 6e 73 of *no* waitons
1c60: 21 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e ! ;; (debug:prin
1c70: 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 t-error 0 *defau
1c80: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 6f lt-log-port* "so
1c90: 6d 65 74 68 69 6e 67 20 77 65 6e 74 20 77 72 6f mething went wro
1ca0: 6e 67 20 69 6e 20 70 72 6f 63 65 73 73 69 6e 67 ng in processing
1cb0: 20 77 61 69 74 6f 6e 73 20 66 6f 72 20 74 65 73 waitons for tes
1cc0: 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 29 0a 09 t " test-name)..
1cd0: 09 09 20 20 20 20 20 20 22 22 29 29 29 29 0a 09 .. ""))))..
1ce0: 20 20 20 20 20 28 6e 65 77 77 61 69 74 6f 72 73 (newwaitors
1cf0: 0a 09 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d .. (string-
1d00: 73 70 6c 69 74 20 28 63 6f 6e 64 0a 09 09 09 20 split (cond....
1d10: 20 20 20 20 28 28 70 72 6f 63 65 64 75 72 65 3f ((procedure?
1d20: 20 69 6e 73 74 72 32 29 0a 09 09 09 20 20 20 20 instr2)....
1d30: 20 20 28 6c 65 74 20 28 28 72 65 73 20 28 69 6e (let ((res (in
1d40: 73 74 72 32 29 29 29 0a 09 09 09 09 28 64 65 62 str2))).....(deb
1d50: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 38 20 ug:print-info 8
1d60: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
1d70: 74 2a 20 22 77 61 69 74 6f 72 20 70 72 6f 63 65 t* "waitor proce
1d80: 64 75 72 65 20 72 65 73 75 6c 74 73 20 69 6e 20 dure results in
1d90: 73 74 72 69 6e 67 20 22 20 72 65 73 20 22 20 66 string " res " f
1da0: 6f 72 20 74 65 73 74 20 22 20 74 65 73 74 2d 6e or test " test-n
1db0: 61 6d 65 29 0a 09 09 09 09 72 65 73 29 29 0a 09 ame).....res))..
1dc0: 09 09 20 20 20 20 20 28 28 73 74 72 69 6e 67 3f .. ((string?
1dd0: 20 69 6e 73 74 72 32 29 20 20 20 20 20 69 6e 73 instr2) ins
1de0: 74 72 32 29 0a 09 09 09 20 20 20 20 20 28 65 6c tr2).... (el
1df0: 73 65 20 0a 09 09 09 20 20 20 20 20 20 3b 3b 20 se .... ;;
1e00: 4e 4f 54 45 3a 20 54 68 69 73 20 69 73 20 61 63 NOTE: This is ac
1e10: 74 75 61 6c 6c 79 20 74 68 65 20 63 61 73 65 20 tually the case
1e20: 6f 66 20 2a 6e 6f 2a 20 77 61 69 74 6f 6e 73 21 of *no* waitons!
1e30: 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ;; (debug:print
1e40: 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c -error 0 *defaul
1e50: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 6f 6d t-log-port* "som
1e60: 65 74 68 69 6e 67 20 77 65 6e 74 20 77 72 6f 6e ething went wron
1e70: 67 20 69 6e 20 70 72 6f 63 65 73 73 69 6e 67 20 g in processing
1e80: 77 61 69 74 6f 6e 73 20 66 6f 72 20 74 65 73 74 waitons for test
1e90: 20 22 20 74 65 73 74 2d 6e 61 6d 65 29 0a 09 09 " test-name)...
1ea0: 09 20 20 20 20 20 20 22 22 29 29 29 29 29 0a 09 . "")))))..
1eb0: 20 28 76 61 6c 75 65 73 0a 09 20 20 3b 3b 20 74 (values.. ;; t
1ec0: 68 65 20 77 61 69 74 6f 6e 73 0a 09 20 20 28 66 he waitons.. (f
1ed0: 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 ilter (lambda (x
1ee0: 29 0a 09 09 20 20 20 20 28 69 66 20 28 68 61 73 )... (if (has
1ef0: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
1f00: 75 6c 74 20 61 6c 6c 2d 74 65 73 74 73 2d 72 65 ult all-tests-re
1f10: 67 69 73 74 72 79 20 78 20 23 66 29 0a 09 09 09 gistry x #f)....
1f20: 23 74 0a 09 09 09 28 62 65 67 69 6e 0a 09 09 09 #t....(begin....
1f30: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 (debug:print-e
1f40: 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d rror 0 *default-
1f50: 6c 6f 67 2d 70 6f 72 74 2a 20 22 74 65 73 74 20 log-port* "test
1f60: 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 68 61 " test-name " ha
1f70: 73 20 75 6e 72 65 63 6f 67 6e 69 73 65 64 20 77 s unrecognised w
1f80: 61 69 74 6f 6e 20 74 65 73 74 6e 61 6d 65 20 22 aiton testname "
1f90: 20 78 29 0a 09 09 09 20 20 23 66 29 29 29 0a 09 x).... #f)))..
1fa0: 09 20 20 6e 65 77 77 61 69 74 6f 6e 73 29 0a 09 . newwaitons)..
1fb0: 20 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 (filter (lambd
1fc0: 61 20 28 78 29 0a 09 09 20 20 20 20 28 69 66 20 a (x)... (if
1fd0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
1fe0: 64 65 66 61 75 6c 74 20 61 6c 6c 2d 74 65 73 74 default all-test
1ff0: 73 2d 72 65 67 69 73 74 72 79 20 78 20 23 66 29 s-registry x #f)
2000: 0a 09 09 09 23 74 0a 09 09 09 28 62 65 67 69 6e ....#t....(begin
2010: 0a 09 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 .... (debug:pri
2020: 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 nt-error 0 *defa
2030: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 74 ult-log-port* "t
2040: 65 73 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 est " test-name
2050: 22 20 68 61 73 20 75 6e 72 65 63 6f 67 6e 69 73 " has unrecognis
2060: 65 64 20 77 61 69 74 6f 6e 20 74 65 73 74 6e 61 ed waiton testna
2070: 6d 65 20 22 20 78 29 0a 09 09 09 20 20 23 66 29 me " x).... #f)
2080: 29 29 0a 09 09 20 20 6e 65 77 77 61 69 74 6f 72 ))... newwaitor
2090: 73 29 0a 09 20 20 63 6f 6e 66 69 67 29 29 29 29 s).. config))))
20a0: 29 0a 09 09 09 09 09 20 20 20 20 20 0a 3b 3b 20 )...... .;;
20b0: 67 69 76 65 6e 20 77 61 69 74 69 6e 67 2d 74 65 given waiting-te
20c0: 73 74 20 74 68 61 74 20 69 73 20 77 61 69 74 69 st that is waiti
20d0: 6e 67 20 6f 6e 20 77 61 69 74 6f 6e 2d 74 65 73 ng on waiton-tes
20e0: 74 20 65 78 74 65 6e 64 20 74 65 73 74 2d 70 61 t extend test-pa
20f0: 74 74 20 61 70 70 72 6f 70 72 69 61 74 65 6c 79 tt appropriately
2100: 0a 3b 3b 0a 3b 3b 20 20 67 65 6e 6c 69 62 2f 74 .;;.;; genlib/t
2110: 65 73 74 63 6f 6e 66 69 67 20 20 20 20 20 20 20 estconfig
2120: 20 20 20 20 20 20 20 20 73 69 6d 2f 74 65 73 74 sim/test
2130: 63 6f 6e 66 69 67 0a 3b 3b 20 20 67 65 6e 6c 69 config.;; genli
2140: 62 2f 73 63 68 20 20 20 20 20 20 20 20 20 20 20 b/sch
2150: 20 20 20 20 20 20 20 20 20 20 20 73 69 6d 2f 73 sim/s
2160: 63 68 2f 63 65 6c 6c 31 0a 3b 3b 0a 3b 3b 20 20 ch/cell1.;;.;;
2170: 5b 72 65 71 75 69 72 65 6d 65 6e 74 73 5d 20 20 [requirements]
2180: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2190: 5b 72 65 71 75 69 72 65 6d 65 6e 74 73 5d 0a 3b [requirements].;
21a0: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;
21b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
21c0: 20 20 20 6d 6f 64 65 20 69 74 65 6d 77 61 69 74 mode itemwait
21d0: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 .;;
21e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
21f0: 20 20 20 20 20 23 20 74 72 69 6d 20 6f 66 66 20 # trim off
2200: 74 68 65 20 63 65 6c 6c 20 74 6f 20 64 65 74 65 the cell to dete
2210: 72 6d 69 6e 65 20 77 68 61 74 20 74 6f 20 72 75 rmine what to ru
2220: 6e 20 66 6f 72 20 67 65 6e 6c 69 62 0a 3b 3b 20 n for genlib.;;
2230: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2240: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2250: 20 69 74 65 6d 6d 61 70 20 2f 2e 2a 0a 3b 3b 0a itemmap /.*.;;.
2260: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
2270: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2280: 20 20 20 20 77 61 69 74 69 6e 67 2d 74 65 73 74 waiting-test
2290: 20 69 73 20 77 61 69 74 69 6e 67 20 6f 6e 20 77 is waiting on w
22a0: 61 69 74 6f 6e 2d 74 65 73 74 20 73 6f 20 77 65 aiton-test so we
22b0: 20 6e 65 65 64 20 74 6f 20 63 72 65 61 74 65 20 need to create
22c0: 61 20 70 61 74 74 65 72 6e 20 66 6f 72 20 77 61 a pattern for wa
22d0: 69 74 6f 6e 2d 74 65 73 74 20 67 69 76 65 6e 20 iton-test given
22e0: 77 61 69 74 69 6e 67 2d 74 65 73 74 20 61 6e 64 waiting-test and
22f0: 20 69 74 65 6d 6d 61 70 0a 3b 3b 20 42 42 3e 20 itemmap.;; BB>
2300: 28 74 65 73 74 73 3a 65 78 74 65 6e 64 2d 74 65 (tests:extend-te
2310: 73 74 2d 70 61 74 74 73 20 22 6e 6f 72 6d 61 6c st-patts "normal
2320: 2d 73 65 63 6f 6e 64 2f 32 22 20 22 6e 6f 72 6d -second/2" "norm
2330: 61 6c 2d 73 65 63 6f 6e 64 22 20 22 6e 6f 72 6d al-second" "norm
2340: 61 6c 2d 66 69 72 73 74 22 20 27 28 29 29 0a 3b al-first" '()).;
2350: 3b 20 6f 62 73 65 72 76 65 64 20 2d 3e 20 22 6e ; observed -> "n
2360: 6f 72 6d 61 6c 2d 66 69 72 73 74 2f 32 2c 6e 6f ormal-first/2,no
2370: 72 6d 61 6c 2d 66 69 72 73 74 2f 2c 6e 6f 72 6d rmal-first/,norm
2380: 61 6c 2d 73 65 63 6f 6e 64 2f 32 2c 6e 6f 72 6d al-second/2,norm
2390: 61 6c 2d 73 65 63 6f 6e 64 2f 22 0a 3b 3b 20 65 al-second/".;; e
23a0: 78 70 65 63 74 65 64 20 2d 3e 20 22 6e 6f 72 6d xpected -> "norm
23b0: 61 6c 2d 66 69 72 73 74 2c 6e 6f 72 6d 61 6c 2d al-first,normal-
23c0: 73 65 63 6f 6e 64 2f 32 2c 6e 6f 72 6d 61 6c 2d second/2,normal-
23d0: 73 65 63 6f 6e 64 2f 22 0a 3b 3b 20 74 65 73 74 second/".;; test
23e0: 70 61 74 74 20 3d 20 6e 6f 72 6d 61 6c 2d 73 65 patt = normal-se
23f0: 63 6f 6e 64 2f 32 0a 3b 3b 20 77 61 69 74 69 6e cond/2.;; waitin
2400: 67 2d 74 65 73 74 20 3d 20 6e 6f 72 6d 61 6c 2d g-test = normal-
2410: 73 65 63 6f 6e 64 0a 3b 3b 20 77 61 69 74 6f 6e second.;; waiton
2420: 2d 74 65 73 74 20 3d 20 6e 6f 72 6d 61 6c 2d 66 -test = normal-f
2430: 69 72 73 74 0a 3b 3b 20 69 74 65 6d 6d 61 70 73 irst.;; itemmaps
2440: 20 3d 20 28 29 0a 0a 28 64 65 66 69 6e 65 20 28 = ()..(define (
2450: 74 65 73 74 73 3a 65 78 74 65 6e 64 2d 74 65 73 tests:extend-tes
2460: 74 2d 70 61 74 74 73 20 74 65 73 74 2d 70 61 74 t-patts test-pat
2470: 74 20 77 61 69 74 69 6e 67 2d 74 65 73 74 20 77 t waiting-test w
2480: 61 69 74 6f 6e 2d 74 65 73 74 20 69 74 65 6d 6d aiton-test itemm
2490: 61 70 73 20 69 74 65 6d 69 7a 65 64 2d 77 61 69 aps itemized-wai
24a0: 74 6f 6e 29 0a 20 20 28 63 6f 6e 64 0a 20 20 20 ton). (cond.
24b0: 28 69 74 65 6d 69 7a 65 64 2d 77 61 69 74 6f 6e (itemized-waiton
24c0: 0a 20 20 20 20 28 6c 65 74 2a 20 28 28 69 74 65 . (let* ((ite
24d0: 6d 6d 61 70 20 20 20 20 20 20 20 20 20 20 28 74 mmap (t
24e0: 65 73 74 73 3a 6c 6f 6f 6b 75 70 2d 69 74 65 6d ests:lookup-item
24f0: 6d 61 70 20 69 74 65 6d 6d 61 70 73 20 77 61 69 map itemmaps wai
2500: 74 6f 6e 2d 74 65 73 74 29 29 0a 20 20 20 20 20 ton-test)).
2510: 20 20 20 20 20 20 28 70 61 74 74 73 20 20 20 20 (patts
2520: 20 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d (string-
2530: 73 70 6c 69 74 20 74 65 73 74 2d 70 61 74 74 20 split test-patt
2540: 22 2c 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 ",")).
2550: 20 28 77 61 69 74 69 6e 67 2d 74 65 73 74 2d 6c (waiting-test-l
2560: 65 6e 20 28 2b 20 28 73 74 72 69 6e 67 2d 6c 65 en (+ (string-le
2570: 6e 67 74 68 20 77 61 69 74 69 6e 67 2d 74 65 73 ngth waiting-tes
2580: 74 29 20 31 29 29 0a 20 20 20 20 20 20 20 20 20 t) 1)).
2590: 20 20 28 70 61 74 74 73 2d 77 61 69 74 6f 6e 20 (patts-waiton
25a0: 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 (map (lambda
25b0: 20 28 78 29 20 20 3b 3b 20 66 6f 72 20 65 61 63 (x) ;; for eac
25c0: 68 20 69 6e 63 6f 6d 69 6e 67 20 70 61 74 74 20 h incoming patt
25d0: 74 68 61 74 20 6d 61 74 63 68 65 73 20 74 68 65 that matches the
25e0: 20 77 61 69 74 69 6e 67 20 74 65 73 74 0a 20 20 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 28 6c 65 74 2a 20 28 28 6d 6f 64 70 61 74 (let* ((modpat
2620: 74 20 28 69 66 20 69 74 65 6d 6d 61 70 20 28 64 t (if itemmap (d
2630: 62 3a 63 6f 6e 76 65 72 74 2d 74 65 73 74 2d 69 b:convert-test-i
2640: 74 65 6d 70 61 74 68 20 78 20 69 74 65 6d 6d 61 tempath x itemma
2650: 70 29 20 78 29 29 20 0a 20 20 20 20 20 20 20 20 p) x)) .
2660: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2670: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2680: 20 20 20 28 6e 65 77 70 61 74 74 20 28 63 6f 6e (newpatt (con
2690: 63 20 77 61 69 74 6f 6e 2d 74 65 73 74 20 22 2f c waiton-test "/
26a0: 22 20 28 73 75 62 73 74 72 69 6e 67 20 6d 6f 64 " (substring mod
26b0: 70 61 74 74 20 77 61 69 74 69 6e 67 2d 74 65 73 patt waiting-tes
26c0: 74 2d 6c 65 6e 20 28 73 74 72 69 6e 67 2d 6c 65 t-len (string-le
26d0: 6e 67 74 68 20 6d 6f 64 70 61 74 74 29 29 29 29 ngth modpatt))))
26e0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
26f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2700: 20 20 20 20 20 20 20 20 3b 3b 20 28 63 6f 6e 63 ;; (conc
2710: 20 77 61 69 74 69 6e 67 2d 74 65 73 74 20 22 2f waiting-test "/
2720: 2c 22 20 77 61 69 74 69 6e 67 2d 74 65 73 74 20 ," waiting-test
2730: 22 2f 22 20 28 73 75 62 73 74 72 69 6e 67 20 6d "/" (substring m
2740: 6f 64 70 61 74 74 20 77 61 69 74 6f 6e 2d 74 65 odpatt waiton-te
2750: 73 74 2d 6c 65 6e 20 28 73 74 72 69 6e 67 2d 6c st-len (string-l
2760: 65 6e 67 74 68 20 6d 6f 64 70 61 74 74 29 29 29 ength modpatt)))
2770: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
2780: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2790: 20 20 20 20 20 20 20 20 20 3b 3b 20 28 70 72 69 ;; (pri
27a0: 6e 74 20 22 69 6e 20 6d 61 70 2c 20 78 3d 22 20 nt "in map, x="
27b0: 78 20 22 2c 20 6e 65 77 70 61 74 74 3d 22 20 6e x ", newpatt=" n
27c0: 65 77 70 61 74 74 29 0a 20 20 20 20 20 20 20 20 ewpatt).
27d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
27e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 6e 65 ne
27f0: 77 70 61 74 74 29 29 0a 20 20 20 20 20 20 20 20 wpatt)).
2800: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2810: 20 20 20 20 20 20 20 20 20 20 28 66 69 6c 74 65 (filte
2820: 72 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 20 20 r (lambda (x).
2830: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
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 28 65 71 3f 20 28 (eq? (
2860: 73 75 62 73 74 72 69 6e 67 2d 69 6e 64 65 78 20 substring-index
2870: 28 63 6f 6e 63 20 77 61 69 74 69 6e 67 2d 74 65 (conc waiting-te
2880: 73 74 20 22 2f 22 29 20 78 29 20 30 29 29 20 3b st "/") x) 0)) ;
2890: 3b 20 69 73 20 74 68 69 73 20 70 61 74 74 20 70 ; is this patt p
28a0: 65 72 74 69 6e 65 6e 74 20 74 6f 20 74 68 65 20 ertinent to the
28b0: 77 61 69 74 69 6e 67 20 74 65 73 74 0a 20 20 20 waiting test.
28c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
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 70 61 74 74 73 29 29 29 0a patts))).
28f0: 20 20 20 20 20 20 20 20 20 20 20 28 65 78 74 65 (exte
2900: 6e 64 65 64 2d 74 65 73 74 2d 70 61 74 74 20 20 nded-test-patt
2910: 20 28 61 70 70 65 6e 64 20 70 61 74 74 73 20 28 (append patts (
2920: 69 66 20 28 6e 75 6c 6c 3f 20 70 61 74 74 73 2d if (null? patts-
2930: 77 61 69 74 6f 6e 29 0a 20 20 20 20 20 20 20 20 waiton).
2940: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2950: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2960: 20 20 20 20 20 20 20 20 20 20 20 28 6c 69 73 74 (list
2970: 20 28 63 6f 6e 63 20 77 61 69 74 6f 6e 2d 74 65 (conc waiton-te
2980: 73 74 20 22 2f 25 22 29 29 20 3b 3b 20 72 65 61 st "/%")) ;; rea
2990: 6c 6c 79 20 73 68 6f 75 6c 64 6e 27 74 20 61 64 lly shouldn't ad
29a0: 64 20 74 68 65 20 77 61 69 74 6f 6e 20 66 6f 72 d the waiton for
29b0: 63 65 66 75 6c 6c 79 20 6c 69 6b 65 20 74 68 69 cefully like thi
29c0: 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 s.
29d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
29e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
29f0: 20 20 20 20 20 70 61 74 74 73 2d 77 61 69 74 6f patts-waito
2a00: 6e 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 n))).
2a10: 28 65 78 74 65 6e 64 65 64 2d 74 65 73 74 2d 70 (extended-test-p
2a20: 61 74 74 2d 77 69 74 68 2d 74 6f 70 6c 65 76 65 att-with-topleve
2a30: 6c 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 ls. (
2a40: 66 6f 6c 64 20 28 6c 61 6d 62 64 61 20 28 74 65 fold (lambda (te
2a50: 73 74 70 61 74 74 2d 69 74 65 6d 20 61 63 63 75 stpatt-item accu
2a60: 6d 20 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 m ).
2a70: 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 6d (let ((m
2a80: 79 2d 6d 61 74 63 68 20 28 73 74 72 69 6e 67 2d y-match (string-
2a90: 6d 61 74 63 68 20 22 5e 28 5b 5e 25 5c 5c 2f 5d match "^([^%\\/]
2aa0: 2b 29 5c 5c 2f 2e 2b 24 22 20 74 65 73 74 70 61 +)\\/.+$" testpa
2ab0: 74 74 2d 69 74 65 6d 29 29 29 0a 20 20 20 20 20 tt-item))).
2ac0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2ad0: 20 28 63 6f 6e 73 20 74 65 73 74 70 61 74 74 2d (cons testpatt-
2ae0: 69 74 65 6d 0a 20 20 20 20 20 20 20 20 20 20 20 item.
2af0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2b00: 20 28 69 66 20 6d 79 2d 6d 61 74 63 68 0a 20 20 (if my-match.
2b10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2b20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c
2b30: 6f 6e 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 ons.
2b40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2b50: 20 20 20 20 20 28 63 6f 6e 63 20 28 63 61 64 72 (conc (cadr
2b60: 20 6d 79 2d 6d 61 74 63 68 29 20 22 2f 22 29 0a my-match) "/").
2b70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2b80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2b90: 20 61 63 63 75 6d 29 0a 20 20 20 20 20 20 20 20 accum).
2ba0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2bb0: 20 20 20 20 20 20 20 20 61 63 63 75 6d 29 29 29 accum)))
2bc0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
2bd0: 20 20 20 20 27 28 29 0a 20 20 20 20 20 20 20 20 '().
2be0: 20 20 20 20 20 20 20 20 20 20 65 78 74 65 6e 64 extend
2bf0: 65 64 2d 74 65 73 74 2d 70 61 74 74 29 29 29 0a ed-test-patt))).
2c00: 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 69 6e (string-in
2c10: 74 65 72 73 70 65 72 73 65 20 28 64 65 6c 65 74 tersperse (delet
2c20: 65 2d 64 75 70 6c 69 63 61 74 65 73 20 65 78 74 e-duplicates ext
2c30: 65 6e 64 65 64 2d 74 65 73 74 2d 70 61 74 74 2d ended-test-patt-
2c40: 77 69 74 68 2d 74 6f 70 6c 65 76 65 6c 73 29 20 with-toplevels)
2c50: 22 2c 22 29 29 29 0a 20 20 20 28 65 6c 73 65 20 ","))). (else
2c60: 3b 3b 20 6e 6f 74 20 77 61 69 74 69 6e 67 20 6f ;; not waiting o
2c70: 6e 20 69 74 65 6d 73 2c 20 77 61 69 74 69 6e 67 n items, waiting
2c80: 20 6f 6e 20 65 6e 74 69 72 65 20 77 61 69 74 6f on entire waito
2c90: 6e 20 74 65 73 74 2e 0a 20 20 20 20 28 6c 65 74 n test.. (let
2ca0: 2a 20 28 28 70 61 74 74 73 20 28 73 74 72 69 6e * ((patts (strin
2cb0: 67 2d 73 70 6c 69 74 20 74 65 73 74 2d 70 61 74 g-split test-pat
2cc0: 74 20 22 2c 22 29 29 0a 20 20 20 20 20 20 20 20 t ",")).
2cd0: 20 20 20 28 6e 65 77 2d 70 61 74 74 73 20 28 69 (new-patts (i
2ce0: 66 20 28 6d 65 6d 62 65 72 20 77 61 69 74 6f 6e f (member waiton
2cf0: 2d 74 65 73 74 20 70 61 74 74 73 29 0a 20 20 20 -test patts).
2d00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2d10: 20 20 20 20 20 20 20 70 61 74 74 73 0a 20 20 20 patts.
2d20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2d30: 20 20 20 20 20 20 20 28 63 6f 6e 73 20 77 61 69 (cons wai
2d40: 74 6f 6e 2d 74 65 73 74 20 70 61 74 74 73 29 29 ton-test patts))
2d50: 29 29 0a 20 20 20 20 20 20 28 73 74 72 69 6e 67 )). (string
2d60: 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 64 65 -intersperse (de
2d70: 6c 65 74 65 2d 64 75 70 6c 69 63 61 74 65 73 20 lete-duplicates
2d80: 6e 65 77 2d 70 61 74 74 73 29 20 22 2c 22 29 29 new-patts) ","))
2d90: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 2a 67 6c )))..(define *gl
2da0: 6f 62 2d 6c 69 6b 65 2d 6d 61 74 63 68 2d 63 61 ob-like-match-ca
2db0: 63 68 65 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d che* (make-hash-
2dc0: 74 61 62 6c 65 29 29 0a 28 64 65 66 69 6e 65 20 table)).(define
2dd0: 28 74 65 73 74 73 3a 63 61 63 68 65 2d 72 65 67 (tests:cache-reg
2de0: 65 78 70 20 73 74 72 2d 69 6e 20 66 6c 61 67 29 exp str-in flag)
2df0: 0a 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 20 28 . (let* ((key (
2e00: 63 6f 6e 63 20 73 74 72 2d 69 6e 20 66 6c 61 67 conc str-in flag
2e10: 29 29 29 0a 20 20 20 20 28 6f 72 20 28 68 61 73 ))). (or (has
2e20: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
2e30: 75 6c 74 20 2a 67 6c 6f 62 2d 6c 69 6b 65 2d 6d ult *glob-like-m
2e40: 61 74 63 68 2d 63 61 63 68 65 2a 20 6b 65 79 20 atch-cache* key
2e50: 23 66 29 0a 09 28 6c 65 74 2a 20 28 28 6e 65 77 #f)..(let* ((new
2e60: 72 78 20 28 72 65 67 65 78 70 20 73 74 72 2d 69 rx (regexp str-i
2e70: 6e 20 66 6c 61 67 29 29 29 0a 09 20 20 28 68 61 n flag))).. (ha
2e80: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a 67 sh-table-set! *g
2e90: 6c 6f 62 2d 6c 69 6b 65 2d 6d 61 74 63 68 2d 63 lob-like-match-c
2ea0: 61 63 68 65 2a 20 6b 65 79 20 6e 65 77 72 78 29 ache* key newrx)
2eb0: 0a 09 20 20 6e 65 77 72 78 29 29 29 29 0a 0a 3b .. newrx))))..;
2ec0: 3b 20 74 65 73 74 73 3a 67 6c 6f 62 2d 6c 69 6b ; tests:glob-lik
2ed0: 65 2d 6d 61 74 63 68 20 0a 28 64 65 66 69 6e 65 e-match .(define
2ee0: 20 28 74 65 73 74 73 3a 67 6c 6f 62 2d 6c 69 6b (tests:glob-lik
2ef0: 65 2d 6d 61 74 63 68 20 70 61 74 74 20 73 74 72 e-match patt str
2f00: 29 20 0a 20 20 28 6c 65 74 2a 20 28 28 6c 69 6b ) . (let* ((lik
2f10: 65 20 20 20 20 20 28 73 75 62 73 74 72 69 6e 67 e (substring
2f20: 2d 69 6e 64 65 78 20 22 25 22 20 70 61 74 74 29 -index "%" patt)
2f30: 29 0a 09 20 28 6e 6f 74 70 61 74 74 20 20 28 65 ).. (notpatt (e
2f40: 71 75 61 6c 3f 20 28 73 75 62 73 74 72 69 6e 67 qual? (substring
2f50: 2d 69 6e 64 65 78 20 22 7e 22 20 70 61 74 74 29 -index "~" patt)
2f60: 20 30 29 29 0a 09 20 28 6e 65 77 70 61 74 74 20 0)).. (newpatt
2f70: 20 28 69 66 20 6e 6f 74 70 61 74 74 20 28 73 75 (if notpatt (su
2f80: 62 73 74 72 69 6e 67 20 70 61 74 74 20 31 29 20 bstring patt 1)
2f90: 70 61 74 74 29 29 0a 09 20 28 66 69 6e 70 61 74 patt)).. (finpat
2fa0: 74 20 20 28 69 66 20 6c 69 6b 65 0a 09 09 20 20 t (if like...
2fb0: 20 20 20 20 20 28 73 74 72 69 6e 67 2d 73 75 62 (string-sub
2fc0: 73 74 69 74 75 74 65 20 28 72 65 67 65 78 70 20 stitute (regexp
2fd0: 22 25 22 29 20 22 2e 2a 22 20 6e 65 77 70 61 74 "%") ".*" newpat
2fe0: 74 20 23 66 29 0a 09 09 20 20 20 20 20 20 20 28 t #f)... (
2ff0: 73 74 72 69 6e 67 2d 73 75 62 73 74 69 74 75 74 string-substitut
3000: 65 20 28 72 65 67 65 78 70 20 22 5c 5c 2a 22 29 e (regexp "\\*")
3010: 20 22 2e 2a 22 20 6e 65 77 70 61 74 74 20 23 66 ".*" newpatt #f
3020: 29 29 29 0a 09 20 28 72 78 20 20 20 20 20 20 20 ))).. (rx
3030: 28 74 65 73 74 73 3a 63 61 63 68 65 2d 72 65 67 (tests:cache-reg
3040: 65 78 70 20 66 69 6e 70 61 74 74 20 28 69 66 20 exp finpatt (if
3050: 6c 69 6b 65 20 23 74 20 23 66 29 29 29 0a 09 20 like #t #f)))..
3060: 28 72 65 73 20 20 20 20 20 20 28 73 74 72 69 6e (res (strin
3070: 67 2d 6d 61 74 63 68 20 72 78 20 73 74 72 29 29 g-match rx str))
3080: 29 0a 20 20 20 20 28 69 66 20 6e 6f 74 70 61 74 ). (if notpat
3090: 74 20 28 6e 6f 74 20 72 65 73 29 20 72 65 73 29 t (not res) res)
30a0: 29 29 0a 0a 3b 3b 20 69 66 20 69 74 65 6d 70 61 ))..;; if itempa
30b0: 74 68 20 69 73 20 23 66 20 74 68 65 6e 20 6c 6f th is #f then lo
30c0: 6f 6b 20 6f 6e 6c 79 20 61 74 20 74 68 65 20 74 ok only at the t
30d0: 65 73 74 6e 61 6d 65 20 70 61 72 74 0a 3b 3b 0a estname part.;;.
30e0: 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 6d (define (tests:m
30f0: 61 74 63 68 20 70 61 74 74 65 72 6e 73 20 74 65 atch patterns te
3100: 73 74 6e 61 6d 65 20 69 74 65 6d 70 61 74 68 20 stname itempath
3110: 23 21 6b 65 79 20 28 72 65 71 75 69 72 65 64 20 #!key (required
3120: 27 28 29 29 29 0a 20 20 28 69 66 20 28 73 74 72 '())). (if (str
3130: 69 6e 67 3f 20 70 61 74 74 65 72 6e 73 29 0a 20 ing? patterns).
3140: 20 20 20 20 20 28 6c 65 74 20 28 28 70 61 74 74 (let ((patt
3150: 73 20 28 61 70 70 65 6e 64 20 28 73 74 72 69 6e s (append (strin
3160: 67 2d 73 70 6c 69 74 20 70 61 74 74 65 72 6e 73 g-split patterns
3170: 20 22 2c 22 29 20 72 65 71 75 69 72 65 64 29 29 ",") required))
3180: 29 0a 09 28 69 66 20 28 6e 75 6c 6c 3f 20 70 61 )..(if (null? pa
3190: 74 74 73 29 20 3b 3b 3b 20 6e 6f 20 70 61 74 74 tts) ;;; no patt
31a0: 65 72 6e 28 73 29 20 6d 65 61 6e 73 20 6e 6f 20 ern(s) means no
31b0: 6d 61 74 63 68 0a 09 20 20 20 20 23 66 0a 09 20 match.. #f..
31c0: 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 70 (let loop ((p
31d0: 61 74 74 20 28 63 61 72 20 70 61 74 74 73 29 29 att (car patts))
31e0: 0a 09 09 20 20 20 20 20 20 20 28 74 61 6c 20 20 ... (tal
31f0: 28 63 64 72 20 70 61 74 74 73 29 29 29 0a 09 20 (cdr patts)))..
3200: 20 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 ;; (print "
3210: 6c 6f 6f 70 3a 20 70 61 74 74 3a 20 22 20 70 61 loop: patt: " pa
3220: 74 74 20 22 2c 20 74 61 6c 20 22 20 74 61 6c 29 tt ", tal " tal)
3230: 0a 09 20 20 20 20 20 20 28 69 66 20 28 73 74 72 .. (if (str
3240: 69 6e 67 3d 3f 20 70 61 74 74 20 22 22 29 0a 09 ing=? patt "")..
3250: 09 20 20 23 66 20 3b 3b 20 6e 6f 74 68 69 6e 67 . #f ;; nothing
3260: 20 65 76 65 72 20 6d 61 74 63 68 65 73 20 65 6d ever matches em
3270: 70 74 79 20 73 74 72 69 6e 67 20 2d 20 70 6f 6c pty string - pol
3280: 69 63 79 0a 09 09 20 20 28 6c 65 74 2a 20 28 28 icy... (let* ((
3290: 70 61 74 74 2d 70 61 72 74 73 20 28 73 74 72 69 patt-parts (stri
32a0: 6e 67 2d 6d 61 74 63 68 20 28 72 65 67 65 78 70 ng-match (regexp
32b0: 20 22 5e 28 5b 5e 5c 5c 2f 5d 2a 29 28 5c 5c 2f "^([^\\/]*)(\\/
32c0: 28 2e 2a 29 7c 29 24 22 29 20 70 61 74 74 29 29 (.*)|)$") patt))
32d0: 0a 09 09 09 20 28 74 65 73 74 2d 70 61 74 74 20 .... (test-patt
32e0: 20 28 63 61 64 72 20 70 61 74 74 2d 70 61 72 74 (cadr patt-part
32f0: 73 29 29 0a 09 09 09 20 28 69 74 65 6d 2d 70 61 s)).... (item-pa
3300: 74 74 20 20 28 63 61 64 64 64 72 20 70 61 74 74 tt (cadddr patt
3310: 2d 70 61 72 74 73 29 29 29 0a 09 09 20 20 20 20 -parts)))...
3320: 3b 3b 20 73 70 65 63 69 61 6c 20 63 61 73 65 3a ;; special case:
3330: 20 74 65 73 74 20 76 73 2e 20 74 65 73 74 2f 0a test vs. test/.
3340: 09 09 20 20 20 20 3b 3b 20 20 20 74 65 73 74 20 .. ;; test
3350: 20 3d 3e 20 22 74 65 73 74 22 20 22 25 22 0a 09 => "test" "%"..
3360: 09 20 20 20 20 3b 3b 20 20 20 74 65 73 74 2f 20 . ;; test/
3370: 3d 3e 20 22 74 65 73 74 22 20 22 22 0a 09 09 20 => "test" ""...
3380: 20 20 20 28 69 66 20 28 61 6e 64 20 28 6e 6f 74 (if (and (not
3390: 20 28 73 75 62 73 74 72 69 6e 67 2d 69 6e 64 65 (substring-inde
33a0: 78 20 22 2f 22 20 70 61 74 74 29 29 20 3b 3b 20 x "/" patt)) ;;
33b0: 6e 6f 20 73 6c 61 73 68 20 69 6e 20 74 68 65 20 no slash in the
33c0: 6f 72 69 67 69 6e 61 6c 0a 09 09 09 20 20 20 20 original....
33d0: 20 28 6f 72 20 28 6e 6f 74 20 69 74 65 6d 2d 70 (or (not item-p
33e0: 61 74 74 29 0a 09 09 09 09 20 28 65 71 75 61 6c att)..... (equal
33f0: 3f 20 69 74 65 6d 2d 70 61 74 74 20 22 22 29 29 ? item-patt ""))
3400: 29 20 20 20 20 20 20 3b 3b 20 73 68 6f 75 6c 64 ) ;; should
3410: 20 61 6c 77 61 79 73 20 62 65 20 74 72 75 65 20 always be true
3420: 74 68 61 74 20 69 74 65 6d 2d 70 61 74 74 20 69 that item-patt i
3430: 73 20 22 22 0a 09 09 09 28 73 65 74 21 20 69 74 s ""....(set! it
3440: 65 6d 2d 70 61 74 74 20 22 25 22 29 29 0a 09 09 em-patt "%"))...
3450: 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 74 ;; (print "t
3460: 65 73 74 73 3a 6d 61 74 63 68 20 3d 3e 20 70 61 ests:match => pa
3470: 74 74 2d 70 61 72 74 73 3a 20 22 20 70 61 74 74 tt-parts: " patt
3480: 2d 70 61 72 74 73 20 22 2c 20 74 65 73 74 2d 70 -parts ", test-p
3490: 61 74 74 3a 20 22 20 74 65 73 74 2d 70 61 74 74 att: " test-patt
34a0: 20 22 2c 20 69 74 65 6d 2d 70 61 74 74 3a 20 22 ", item-patt: "
34b0: 20 69 74 65 6d 2d 70 61 74 74 29 0a 09 09 20 20 item-patt)...
34c0: 20 20 28 69 66 20 28 61 6e 64 20 28 74 65 73 74 (if (and (test
34d0: 73 3a 67 6c 6f 62 2d 6c 69 6b 65 2d 6d 61 74 63 s:glob-like-matc
34e0: 68 20 74 65 73 74 2d 70 61 74 74 20 74 65 73 74 h test-patt test
34f0: 6e 61 6d 65 29 0a 09 09 09 20 20 20 20 20 28 6f name).... (o
3500: 72 20 28 6e 6f 74 20 69 74 65 6d 70 61 74 68 29 r (not itempath)
3510: 0a 09 09 09 09 20 28 74 65 73 74 73 3a 67 6c 6f ..... (tests:glo
3520: 62 2d 6c 69 6b 65 2d 6d 61 74 63 68 20 28 69 66 b-like-match (if
3530: 20 69 74 65 6d 2d 70 61 74 74 20 69 74 65 6d 2d item-patt item-
3540: 70 61 74 74 20 22 22 29 20 69 74 65 6d 70 61 74 patt "") itempat
3550: 68 29 29 29 0a 09 09 09 23 74 0a 09 09 09 28 69 h)))....#t....(i
3560: 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 f (null? tal)...
3570: 09 20 20 20 20 23 66 0a 09 09 09 20 20 20 20 28 . #f.... (
3580: 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 loop (car tal)(c
3590: 64 72 20 74 61 6c 29 29 29 29 29 29 29 29 29 29 dr tal))))))))))
35a0: 29 0a 0a 3b 3b 20 69 66 20 69 74 65 6d 70 61 74 )..;; if itempat
35b0: 68 20 69 73 20 23 66 20 74 68 65 6e 20 6c 6f 6f h is #f then loo
35c0: 6b 20 6f 6e 6c 79 20 61 74 20 74 68 65 20 74 65 k only at the te
35d0: 73 74 6e 61 6d 65 20 70 61 72 74 0a 3b 3b 0a 28 stname part.;;.(
35e0: 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 6d 61 define (tests:ma
35f0: 74 63 68 2d 3e 73 71 6c 71 72 79 20 70 61 74 74 tch->sqlqry patt
3600: 65 72 6e 73 29 0a 20 20 28 69 66 20 28 73 74 72 erns). (if (str
3610: 69 6e 67 3f 20 70 61 74 74 65 72 6e 73 29 0a 20 ing? patterns).
3620: 20 20 20 20 20 28 6c 65 74 20 28 28 70 61 74 74 (let ((patt
3630: 73 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 s (string-split
3640: 70 61 74 74 65 72 6e 73 20 22 2c 22 29 29 29 0a patterns ","))).
3650: 09 28 69 66 20 28 6e 75 6c 6c 3f 20 70 61 74 74 .(if (null? patt
3660: 73 29 20 3b 3b 3b 20 6e 6f 20 70 61 74 74 65 72 s) ;;; no patter
3670: 6e 28 73 29 20 6d 65 61 6e 73 20 6e 6f 20 6d 61 n(s) means no ma
3680: 74 63 68 2c 20 77 65 20 77 69 6c 6c 20 64 6f 20 tch, we will do
3690: 6e 6f 20 71 75 65 72 79 0a 09 20 20 20 20 23 66 no query.. #f
36a0: 0a 09 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 .. (let loop
36b0: 28 28 70 61 74 74 20 28 63 61 72 20 70 61 74 74 ((patt (car patt
36c0: 73 29 29 0a 09 09 20 20 20 20 20 20 20 28 74 61 s))... (ta
36d0: 6c 20 20 28 63 64 72 20 70 61 74 74 73 29 29 0a l (cdr patts)).
36e0: 09 09 20 20 20 20 20 20 20 28 72 65 73 20 20 27 .. (res '
36f0: 28 29 29 29 0a 09 20 20 20 20 20 20 3b 3b 20 28 ())).. ;; (
3700: 70 72 69 6e 74 20 22 6c 6f 6f 70 3a 20 70 61 74 print "loop: pat
3710: 74 3a 20 22 20 70 61 74 74 20 22 2c 20 74 61 6c t: " patt ", tal
3720: 20 22 20 74 61 6c 29 0a 09 20 20 20 20 20 20 28 " tal).. (
3730: 6c 65 74 2a 20 28 28 70 61 74 74 2d 70 61 72 74 let* ((patt-part
3740: 73 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 s (string-match
3750: 28 72 65 67 65 78 70 20 22 5e 28 5b 5e 5c 5c 2f (regexp "^([^\\/
3760: 5d 2a 29 28 5c 5c 2f 28 2e 2a 29 7c 29 24 22 29 ]*)(\\/(.*)|)$")
3770: 20 70 61 74 74 29 29 0a 09 09 20 20 20 20 20 28 patt))... (
3780: 74 65 73 74 2d 70 61 74 74 20 20 28 63 61 64 72 test-patt (cadr
3790: 20 70 61 74 74 2d 70 61 72 74 73 29 29 0a 09 09 patt-parts))...
37a0: 20 20 20 20 20 28 69 74 65 6d 2d 70 61 74 74 20 (item-patt
37b0: 20 28 63 61 64 64 64 72 20 70 61 74 74 2d 70 61 (cadddr patt-pa
37c0: 72 74 73 29 29 0a 09 09 20 20 20 20 20 28 74 65 rts))... (te
37d0: 73 74 2d 71 72 79 20 20 20 28 64 62 3a 70 61 74 st-qry (db:pat
37e0: 74 2d 3e 6c 69 6b 65 20 22 74 65 73 74 6e 61 6d t->like "testnam
37f0: 65 22 20 74 65 73 74 2d 70 61 74 74 29 29 0a 09 e" test-patt))..
3800: 09 20 20 20 20 20 28 69 74 65 6d 2d 71 72 79 20 . (item-qry
3810: 20 20 28 64 62 3a 70 61 74 74 2d 3e 6c 69 6b 65 (db:patt->like
3820: 20 22 69 74 65 6d 5f 70 61 74 68 22 20 69 74 65 "item_path" ite
3830: 6d 2d 70 61 74 74 29 29 0a 09 09 20 20 20 20 20 m-patt))...
3840: 28 71 72 79 20 20 20 20 20 20 20 20 28 63 6f 6e (qry (con
3850: 63 20 22 28 22 20 74 65 73 74 2d 71 72 79 20 22 c "(" test-qry "
3860: 20 41 4e 44 20 22 20 69 74 65 6d 2d 71 72 79 20 AND " item-qry
3870: 22 29 22 29 29 29 0a 09 09 3b 3b 20 28 70 72 69 ")")))...;; (pri
3880: 6e 74 20 22 74 65 73 74 73 3a 6d 61 74 63 68 20 nt "tests:match
3890: 3d 3e 20 70 61 74 74 2d 70 61 72 74 73 3a 20 22 => patt-parts: "
38a0: 20 70 61 74 74 2d 70 61 72 74 73 20 22 2c 20 74 patt-parts ", t
38b0: 65 73 74 2d 70 61 74 74 3a 20 22 20 74 65 73 74 est-patt: " test
38c0: 2d 70 61 74 74 20 22 2c 20 69 74 65 6d 2d 70 61 -patt ", item-pa
38d0: 74 74 3a 20 22 20 69 74 65 6d 2d 70 61 74 74 29 tt: " item-patt)
38e0: 0a 09 09 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 ...(if (null? ta
38f0: 6c 29 0a 09 09 20 20 20 20 28 73 74 72 69 6e 67 l)... (string
3900: 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 61 70 -intersperse (ap
3910: 70 65 6e 64 20 28 72 65 76 65 72 73 65 20 72 65 pend (reverse re
3920: 73 29 28 6c 69 73 74 20 71 72 79 29 29 20 22 20 s)(list qry)) "
3930: 4f 52 20 22 29 0a 09 09 20 20 20 20 28 6c 6f 6f OR ")... (loo
3940: 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 p (car tal)(cdr
3950: 74 61 6c 29 28 63 6f 6e 73 20 71 72 79 20 72 65 tal)(cons qry re
3960: 73 29 29 29 29 29 29 29 0a 20 20 20 20 20 20 23 s))))))). #
3970: 66 29 29 0a 0a 3b 3b 20 43 68 65 63 6b 20 66 6f f))..;; Check fo
3980: 72 20 77 61 69 76 65 72 20 65 6c 69 67 69 62 69 r waiver eligibi
3990: 6c 69 74 79 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 lity.;;.(define
39a0: 28 74 65 73 74 73 3a 63 68 65 63 6b 2d 77 61 69 (tests:check-wai
39b0: 76 65 72 2d 65 6c 69 67 69 62 69 6c 69 74 79 20 ver-eligibility
39c0: 74 65 73 74 64 61 74 20 70 72 65 76 2d 74 65 73 testdat prev-tes
39d0: 74 64 61 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 tdat). (let* ((
39e0: 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 28 6d test-registry (m
39f0: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
3a00: 0a 09 20 28 74 65 73 74 63 6f 6e 66 69 67 20 20 .. (testconfig
3a10: 28 74 65 73 74 73 3a 67 65 74 2d 74 65 73 74 63 (tests:get-testc
3a20: 6f 6e 66 69 67 20 28 64 62 3a 74 65 73 74 2d 67 onfig (db:test-g
3a30: 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 et-testname test
3a40: 64 61 74 29 20 28 64 62 3a 74 65 73 74 2d 67 65 dat) (db:test-ge
3a50: 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 65 73 74 t-item-path test
3a60: 64 61 74 29 20 74 65 73 74 2d 72 65 67 69 73 74 dat) test-regist
3a70: 72 79 20 23 66 29 29 0a 09 20 28 74 65 73 74 2d ry #f)).. (test-
3a80: 72 75 6e 64 69 72 20 3b 3b 20 28 73 64 62 3a 71 rundir ;; (sdb:q
3a90: 72 79 20 27 70 61 73 73 73 74 72 20 0a 09 20 20 ry 'passstr ..
3aa0: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e (db:test-get-run
3ab0: 64 69 72 20 74 65 73 74 64 61 74 29 29 20 3b 3b dir testdat)) ;;
3ac0: 20 29 0a 09 20 28 70 72 65 76 2d 72 75 6e 64 69 ).. (prev-rundi
3ad0: 72 20 3b 3b 20 28 73 64 62 3a 71 72 79 20 27 70 r ;; (sdb:qry 'p
3ae0: 61 73 73 73 74 72 20 0a 09 20 20 28 64 62 3a 74 assstr .. (db:t
3af0: 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 20 70 est-get-rundir p
3b00: 72 65 76 2d 74 65 73 74 64 61 74 29 29 20 3b 3b rev-testdat)) ;;
3b10: 20 29 0a 09 20 28 77 61 69 76 65 72 73 20 20 20 ).. (waivers
3b20: 20 20 28 69 66 20 74 65 73 74 63 6f 6e 66 69 67 (if testconfig
3b30: 20 28 63 6f 6e 66 69 67 66 3a 73 65 63 74 69 6f (configf:sectio
3b40: 6e 2d 76 61 72 73 20 74 65 73 74 63 6f 6e 66 69 n-vars testconfi
3b50: 67 20 22 77 61 69 76 65 72 73 22 29 20 27 28 29 g "waivers") '()
3b60: 29 29 0a 09 20 28 77 61 69 76 65 72 2d 72 78 20 )).. (waiver-rx
3b70: 20 20 28 72 65 67 65 78 70 20 22 5e 28 5c 5c 53 (regexp "^(\\S
3b80: 2b 29 5c 5c 73 2b 28 2e 2a 29 24 22 29 29 0a 09 +)\\s+(.*)$"))..
3b90: 20 28 64 69 66 66 2d 72 75 6c 65 20 20 20 22 64 (diff-rule "d
3ba0: 69 66 66 20 25 66 69 6c 65 31 25 20 25 66 69 6c iff %file1% %fil
3bb0: 65 32 25 22 29 0a 09 20 28 6c 6f 67 70 72 6f 2d e2%").. (logpro-
3bc0: 72 75 6c 65 20 22 64 69 66 66 20 25 66 69 6c 65 rule "diff %file
3bd0: 31 25 20 25 66 69 6c 65 32 25 20 7c 20 6c 6f 67 1% %file2% | log
3be0: 70 72 6f 20 25 77 61 69 76 65 72 6e 61 6d 65 25 pro %waivername%
3bf0: 2e 6c 6f 67 70 72 6f 20 25 77 61 69 76 65 72 6e .logpro %waivern
3c00: 61 6d 65 25 2e 68 74 6d 6c 22 29 29 0a 20 20 20 ame%.html")).
3c10: 20 28 69 66 20 28 6e 6f 74 20 28 63 6f 6d 6d 6f (if (not (commo
3c20: 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 74 n:file-exists? t
3c30: 65 73 74 2d 72 75 6e 64 69 72 29 29 0a 09 28 62 est-rundir))..(b
3c40: 65 67 69 6e 0a 09 20 20 28 64 65 62 75 67 3a 70 egin.. (debug:p
3c50: 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 rint-error 0 *de
3c60: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
3c70: 22 74 65 73 74 20 72 75 6e 20 64 69 72 65 63 74 "test run direct
3c80: 6f 72 79 20 69 73 20 67 6f 6e 65 2c 20 63 61 6e ory is gone, can
3c90: 6e 6f 74 20 70 72 6f 70 61 67 61 74 65 20 77 61 not propagate wa
3ca0: 69 76 65 72 22 29 0a 09 20 20 23 66 29 0a 09 28 iver").. #f)..(
3cb0: 62 65 67 69 6e 0a 09 20 20 28 70 75 73 68 2d 64 begin.. (push-d
3cc0: 69 72 65 63 74 6f 72 79 20 74 65 73 74 2d 72 75 irectory test-ru
3cd0: 6e 64 69 72 29 0a 09 20 20 28 6c 65 74 20 28 28 ndir).. (let ((
3ce0: 72 65 73 75 6c 74 20 28 69 66 20 28 6e 75 6c 6c result (if (null
3cf0: 3f 20 77 61 69 76 65 72 73 29 0a 09 09 09 20 20 ? waivers)....
3d00: 20 20 23 66 0a 09 09 09 20 20 20 20 28 6c 65 74 #f.... (let
3d10: 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 61 72 loop ((hed (car
3d20: 20 77 61 69 76 65 72 73 29 29 0a 09 09 09 09 20 waivers)).....
3d30: 20 20 20 20 20 20 28 74 61 6c 20 28 63 64 72 20 (tal (cdr
3d40: 77 61 69 76 65 72 73 29 29 29 0a 09 09 09 20 20 waivers)))....
3d50: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
3d60: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
3d70: 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 41 70 70 port* "INFO: App
3d80: 6c 79 69 6e 67 20 77 61 69 76 65 72 20 72 75 6c lying waiver rul
3d90: 65 20 5c 22 22 20 68 65 64 20 22 5c 22 22 29 0a e \"" hed "\"").
3da0: 09 09 09 20 20 20 20 20 20 28 6c 65 74 2a 20 28 ... (let* (
3db0: 28 77 61 69 76 65 72 20 20 20 20 20 20 28 63 6f (waiver (co
3dc0: 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 74 65 73 nfigf:lookup tes
3dd0: 74 63 6f 6e 66 69 67 20 22 77 61 69 76 65 72 73 tconfig "waivers
3de0: 22 20 68 65 64 29 29 0a 09 09 09 09 20 20 20 20 " hed)).....
3df0: 20 28 77 70 61 72 74 73 20 20 20 20 20 20 28 69 (wparts (i
3e00: 66 20 77 61 69 76 65 72 20 28 73 74 72 69 6e 67 f waiver (string
3e10: 2d 6d 61 74 63 68 20 77 61 69 76 65 72 2d 72 78 -match waiver-rx
3e20: 20 77 61 69 76 65 72 29 20 23 66 29 29 0a 09 09 waiver) #f))...
3e30: 09 09 20 20 20 20 20 28 77 61 69 76 65 72 2d 72 .. (waiver-r
3e40: 75 6c 65 20 28 69 66 20 77 70 61 72 74 73 20 28 ule (if wparts (
3e50: 63 61 64 72 20 77 70 61 72 74 73 29 20 20 23 66 cadr wparts) #f
3e60: 29 29 0a 09 09 09 09 20 20 20 20 20 28 77 61 69 ))..... (wai
3e70: 76 65 72 2d 67 6c 6f 62 20 28 69 66 20 77 70 61 ver-glob (if wpa
3e80: 72 74 73 20 28 63 61 64 64 72 20 77 70 61 72 74 rts (caddr wpart
3e90: 73 29 20 23 66 29 29 0a 09 09 09 09 20 20 20 20 s) #f)).....
3ea0: 20 28 6c 6f 67 70 72 6f 2d 66 69 6c 65 20 28 69 (logpro-file (i
3eb0: 66 20 77 61 69 76 65 72 0a 09 09 09 09 09 09 20 f waiver.......
3ec0: 20 20 20 20 20 28 6c 65 74 20 28 28 66 6e 61 6d (let ((fnam
3ed0: 65 20 28 63 6f 6e 63 20 68 65 64 20 22 2e 6c 6f e (conc hed ".lo
3ee0: 67 70 72 6f 22 29 29 29 0a 09 09 09 09 09 09 09 gpro")))........
3ef0: 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 (if (common:file
3f00: 2d 65 78 69 73 74 73 3f 20 66 6e 61 6d 65 29 0a -exists? fname).
3f10: 09 09 09 09 09 09 09 20 20 20 20 66 6e 61 6d 65 ....... fname
3f20: 20 0a 09 09 09 09 09 09 09 20 20 20 20 28 62 65 ........ (be
3f30: 67 69 6e 0a 09 09 09 09 09 09 09 20 20 20 20 20 gin........
3f40: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
3f50: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
3f60: 74 2a 20 22 49 4e 46 4f 3a 20 4e 6f 20 6c 6f 67 t* "INFO: No log
3f70: 70 72 6f 20 66 69 6c 65 20 22 20 66 6e 61 6d 65 pro file " fname
3f80: 20 22 20 66 61 6c 6c 69 6e 67 20 62 61 63 6b 20 " falling back
3f90: 74 6f 20 64 69 66 66 22 29 0a 09 09 09 09 09 09 to diff").......
3fa0: 09 20 20 20 20 20 20 23 66 29 29 29 0a 09 09 09 . #f)))....
3fb0: 09 09 09 20 20 20 20 20 20 23 66 29 29 0a 09 09 ... #f))...
3fc0: 09 09 20 20 20 20 20 3b 3b 20 69 66 20 72 75 6c .. ;; if rul
3fd0: 65 20 62 79 20 6e 61 6d 65 20 6f 66 20 77 61 69 e by name of wai
3fe0: 76 65 72 2d 72 75 6c 65 20 69 73 20 66 6f 75 6e ver-rule is foun
3ff0: 64 20 69 6e 20 74 65 73 74 63 6f 6e 66 69 67 20 d in testconfig
4000: 2d 20 75 73 65 20 69 74 0a 09 09 09 09 20 20 20 - use it.....
4010: 20 20 3b 3b 20 65 6c 73 65 20 69 66 20 77 61 69 ;; else if wai
4020: 76 65 72 6e 61 6d 65 2e 6c 6f 67 70 72 6f 20 65 vername.logpro e
4030: 78 69 73 74 73 20 75 73 65 20 6c 6f 67 70 72 6f xists use logpro
4040: 2d 72 75 6c 65 0a 09 09 09 09 20 20 20 20 20 3b -rule..... ;
4050: 3b 20 65 6c 73 65 20 64 65 66 61 75 6c 74 20 74 ; else default t
4060: 6f 20 64 69 66 66 2d 72 75 6c 65 0a 09 09 09 09 o diff-rule.....
4070: 20 20 20 20 20 28 72 75 6c 65 2d 73 74 72 69 6e (rule-strin
4080: 67 20 28 6c 65 74 20 28 28 72 75 6c 65 20 28 63 g (let ((rule (c
4090: 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 74 65 onfigf:lookup te
40a0: 73 74 63 6f 6e 66 69 67 20 22 77 61 69 76 65 72 stconfig "waiver
40b0: 5f 72 75 6c 65 73 22 20 77 61 69 76 65 72 2d 72 _rules" waiver-r
40c0: 75 6c 65 29 29 29 0a 09 09 09 09 09 09 20 20 20 ule))).......
40d0: 20 28 69 66 20 72 75 6c 65 0a 09 09 09 09 09 09 (if rule.......
40e0: 09 72 75 6c 65 0a 09 09 09 09 09 09 09 28 69 66 .rule........(if
40f0: 20 6c 6f 67 70 72 6f 2d 66 69 6c 65 0a 09 09 09 logpro-file....
4100: 09 09 09 09 20 20 20 20 6c 6f 67 70 72 6f 2d 72 .... logpro-r
4110: 75 6c 65 0a 09 09 09 09 09 09 09 20 20 20 20 28 ule........ (
4120: 62 65 67 69 6e 0a 09 09 09 09 09 09 09 20 20 20 begin........
4130: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
4140: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
4150: 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 4e 6f 20 6c ort* "INFO: No l
4160: 6f 67 70 72 6f 20 66 69 6c 65 20 22 20 6c 6f 67 ogpro file " log
4170: 70 72 6f 2d 66 69 6c 65 20 22 20 66 6f 75 6e 64 pro-file " found
4180: 2c 20 75 73 69 6e 67 20 64 69 66 66 20 72 75 6c , using diff rul
4190: 65 22 29 0a 09 09 09 09 09 09 09 20 20 20 20 20 e")........
41a0: 20 64 69 66 66 2d 72 75 6c 65 29 29 29 29 29 0a diff-rule))))).
41b0: 09 09 09 09 20 20 20 20 20 3b 3b 20 28 73 74 72 .... ;; (str
41c0: 69 6e 67 2d 73 75 62 73 74 69 74 75 74 65 20 22 ing-substitute "
41d0: 25 66 69 6c 65 31 25 22 20 22 66 6f 6f 66 6f 6f %file1%" "foofoo
41e0: 2e 74 78 74 22 20 22 54 68 69 73 20 69 73 20 25 .txt" "This is %
41f0: 66 69 6c 65 31 25 20 61 6e 64 20 73 6f 20 69 73 file1% and so is
4200: 20 74 68 69 73 20 25 66 69 6c 65 31 25 2e 22 20 this %file1%."
4210: 23 74 29 0a 09 09 09 09 20 20 20 20 20 28 70 72 #t)..... (pr
4220: 6f 63 65 73 73 65 64 2d 63 6d 64 20 28 73 74 72 ocessed-cmd (str
4230: 69 6e 67 2d 73 75 62 73 74 69 74 75 74 65 20 0a ing-substitute .
4240: 09 09 09 09 09 09 20 20 20 20 20 22 25 66 69 6c ...... "%fil
4250: 65 31 25 22 20 28 63 6f 6e 63 20 74 65 73 74 2d e1%" (conc test-
4260: 72 75 6e 64 69 72 20 22 2f 22 20 77 61 69 76 65 rundir "/" waive
4270: 72 2d 67 6c 6f 62 29 0a 09 09 09 09 09 09 20 20 r-glob).......
4280: 20 20 20 28 73 74 72 69 6e 67 2d 73 75 62 73 74 (string-subst
4290: 69 74 75 74 65 0a 09 09 09 09 09 09 20 20 20 20 itute.......
42a0: 20 20 22 25 66 69 6c 65 32 25 22 20 28 63 6f 6e "%file2%" (con
42b0: 63 20 70 72 65 76 2d 72 75 6e 64 69 72 20 22 2f c prev-rundir "/
42c0: 22 20 77 61 69 76 65 72 2d 67 6c 6f 62 29 0a 09 " waiver-glob)..
42d0: 09 09 09 09 09 20 20 20 20 20 20 28 73 74 72 69 ..... (stri
42e0: 6e 67 2d 73 75 62 73 74 69 74 75 74 65 0a 09 09 ng-substitute...
42f0: 09 09 09 09 20 20 20 20 20 20 20 22 25 77 61 69 .... "%wai
4300: 76 65 72 6e 61 6d 65 25 22 20 68 65 64 20 72 75 vername%" hed ru
4310: 6c 65 2d 73 74 72 69 6e 67 20 23 74 29 20 23 74 le-string #t) #t
4320: 29 20 23 74 29 29 0a 09 09 09 09 20 20 20 20 20 ) #t)).....
4330: 28 72 65 73 20 20 20 20 20 20 20 20 20 20 20 20 (res
4340: 23 66 29 29 0a 09 09 09 09 28 64 65 62 75 67 3a #f)).....(debug:
4350: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
4360: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 4e 46 4f -log-port* "INFO
4370: 3a 20 77 61 69 76 65 72 20 63 6f 6d 6d 61 6e 64 : waiver command
4380: 20 69 73 20 5c 22 22 20 70 72 6f 63 65 73 73 65 is \"" processe
4390: 64 2d 63 6d 64 20 22 5c 22 22 29 0a 09 09 09 09 d-cmd "\"").....
43a0: 28 69 66 20 28 65 71 3f 20 28 73 79 73 74 65 6d (if (eq? (system
43b0: 20 70 72 6f 63 65 73 73 65 64 2d 63 6d 64 29 20 processed-cmd)
43c0: 30 29 0a 09 09 09 09 20 20 20 20 28 69 66 20 28 0)..... (if (
43d0: 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 09 09 09 null? tal)......
43e0: 23 74 0a 09 09 09 09 09 28 6c 6f 6f 70 20 28 63 #t......(loop (c
43f0: 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 ar tal)(cdr tal)
4400: 29 29 0a 09 09 09 09 20 20 20 20 23 66 29 29 29 ))..... #f)))
4410: 29 29 29 0a 09 20 20 20 20 28 70 6f 70 2d 64 69 ))).. (pop-di
4420: 72 65 63 74 6f 72 79 29 0a 09 20 20 20 20 72 65 rectory).. re
4430: 73 75 6c 74 29 29 29 29 29 0a 0a 3b 3b 20 44 6f sult)))))..;; Do
4440: 20 6e 6f 74 20 72 70 63 20 74 68 69 73 20 6f 6e not rpc this on
4450: 65 2c 20 64 6f 20 74 68 65 20 75 6e 64 65 72 6c e, do the underl
4460: 79 69 6e 67 20 63 61 6c 6c 73 21 21 21 0a 28 64 ying calls!!!.(d
4470: 65 66 69 6e 65 20 28 74 65 73 74 73 3a 74 65 73 efine (tests:tes
4480: 74 2d 73 65 74 2d 73 74 61 74 75 73 21 20 72 75 t-set-status! ru
4490: 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 73 74 61 n-id test-id sta
44a0: 74 65 20 73 74 61 74 75 73 20 63 6f 6d 6d 65 6e te status commen
44b0: 74 20 64 61 74 20 23 21 6b 65 79 20 28 77 6f 72 t dat #!key (wor
44c0: 6b 2d 61 72 65 61 20 23 66 29 29 0a 20 20 28 6c k-area #f)). (l
44d0: 65 74 2a 20 28 28 72 65 61 6c 2d 73 74 61 74 75 et* ((real-statu
44e0: 73 20 73 74 61 74 75 73 29 0a 09 20 28 6f 74 68 s status).. (oth
44f0: 65 72 64 61 74 20 20 20 20 28 69 66 20 64 61 74 erdat (if dat
4500: 20 64 61 74 20 28 6d 61 6b 65 2d 68 61 73 68 2d dat (make-hash-
4510: 74 61 62 6c 65 29 29 29 0a 09 20 28 74 65 73 74 table))).. (test
4520: 64 61 74 20 20 20 20 20 28 72 6d 74 3a 67 65 74 dat (rmt:get
4530: 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 -test-info-by-id
4540: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 run-id test-id)
4550: 29 0a 09 20 28 74 65 73 74 2d 6e 61 6d 65 20 20 ).. (test-name
4560: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 (db:test-get-te
4570: 73 74 6e 61 6d 65 20 20 74 65 73 74 64 61 74 29 stname testdat)
4580: 29 0a 09 20 28 69 74 65 6d 2d 70 61 74 68 20 20 ).. (item-path
4590: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 (db:test-get-it
45a0: 65 6d 2d 70 61 74 68 20 74 65 73 74 64 61 74 29 em-path testdat)
45b0: 29 0a 09 20 3b 3b 20 62 65 66 6f 72 65 20 70 72 ).. ;; before pr
45c0: 6f 63 65 65 64 69 6e 67 20 77 65 20 6d 75 73 74 oceeding we must
45d0: 20 66 69 6e 64 20 6f 75 74 20 69 66 20 74 68 65 find out if the
45e0: 20 70 72 65 76 69 6f 75 73 20 74 65 73 74 20 28 previous test (
45f0: 77 68 65 72 65 20 61 6c 6c 20 6b 65 79 73 20 6d where all keys m
4600: 61 74 63 68 65 64 20 65 78 63 65 70 74 20 72 75 atched except ru
4610: 6e 6e 61 6d 65 29 0a 09 20 3b 3b 20 77 61 73 20 nname).. ;; was
4620: 57 41 49 56 45 44 20 69 66 20 74 68 69 73 20 74 WAIVED if this t
4630: 65 73 74 20 69 73 20 46 41 49 4c 0a 0a 09 20 3b est is FAIL... ;
4640: 3b 20 4e 4f 54 45 53 3a 0a 09 20 3b 3b 20 20 31 ; NOTES:.. ;; 1
4650: 2e 20 49 73 20 74 68 65 20 63 61 6c 6c 20 74 6f . Is the call to
4660: 20 74 65 73 74 3a 67 65 74 2d 70 72 65 76 69 6f test:get-previo
4670: 75 73 2d 72 75 6e 2d 72 65 63 6f 72 64 20 72 65 us-run-record re
4680: 6d 6f 74 69 66 69 65 64 3f 0a 09 20 3b 3b 20 20 motified?.. ;;
4690: 32 2e 20 41 64 64 20 74 65 73 74 20 66 6f 72 20 2. Add test for
46a0: 74 65 73 74 63 6f 6e 66 69 67 20 77 61 69 76 65 testconfig waive
46b0: 72 20 70 72 6f 70 61 67 61 74 69 6f 6e 20 63 6f r propagation co
46c0: 6e 74 72 6f 6c 20 68 65 72 65 0a 09 20 3b 3b 0a ntrol here.. ;;.
46d0: 09 20 28 70 72 65 76 2d 74 65 73 74 20 20 20 28 . (prev-test (
46e0: 69 66 20 28 65 71 75 61 6c 3f 20 73 74 61 74 75 if (equal? statu
46f0: 73 20 22 46 41 49 4c 22 29 0a 09 09 09 20 20 28 s "FAIL").... (
4700: 72 6d 74 3a 67 65 74 2d 70 72 65 76 69 6f 75 73 rmt:get-previous
4710: 2d 74 65 73 74 2d 72 75 6e 2d 72 65 63 6f 72 64 -test-run-record
4720: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
4730: 65 20 69 74 65 6d 2d 70 61 74 68 29 0a 09 09 09 e item-path)....
4740: 20 20 23 66 29 29 0a 09 20 28 77 61 69 76 65 64 #f)).. (waived
4750: 20 20 20 28 69 66 20 70 72 65 76 2d 74 65 73 74 (if prev-test
4760: 0a 09 09 20 20 20 20 20 20 20 28 69 66 20 70 72 ... (if pr
4770: 65 76 2d 74 65 73 74 20 3b 3b 20 74 72 75 65 20 ev-test ;; true
4780: 69 66 20 77 65 20 66 6f 75 6e 64 20 61 20 70 72 if we found a pr
4790: 65 76 69 6f 75 73 20 74 65 73 74 20 69 6e 20 74 evious test in t
47a0: 68 69 73 20 72 75 6e 20 73 65 72 69 65 73 0a 09 his run series..
47b0: 09 09 20 20 20 28 6c 65 74 20 28 28 70 72 65 76 .. (let ((prev
47c0: 2d 73 74 61 74 75 73 20 20 28 64 62 3a 74 65 73 -status (db:tes
47d0: 74 2d 67 65 74 2d 73 74 61 74 75 73 20 20 70 72 t-get-status pr
47e0: 65 76 2d 74 65 73 74 29 29 0a 09 09 09 09 20 28 ev-test))..... (
47f0: 70 72 65 76 2d 73 74 61 74 65 20 20 20 28 64 62 prev-state (db
4800: 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 :test-get-state
4810: 20 20 70 72 65 76 2d 74 65 73 74 29 29 0a 09 09 prev-test))...
4820: 09 09 20 28 70 72 65 76 2d 63 6f 6d 6d 65 6e 74 .. (prev-comment
4830: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 63 6f (db:test-get-co
4840: 6d 6d 65 6e 74 20 70 72 65 76 2d 74 65 73 74 29 mment prev-test)
4850: 29 29 0a 09 09 09 20 20 20 20 20 28 64 65 62 75 )).... (debu
4860: 67 3a 70 72 69 6e 74 20 34 20 2a 64 65 66 61 75 g:print 4 *defau
4870: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 70 72 lt-log-port* "pr
4880: 65 76 2d 73 74 61 74 75 73 20 22 20 70 72 65 76 ev-status " prev
4890: 2d 73 74 61 74 75 73 20 22 2c 20 70 72 65 76 2d -status ", prev-
48a0: 73 74 61 74 65 20 22 20 70 72 65 76 2d 73 74 61 state " prev-sta
48b0: 74 65 20 22 2c 20 70 72 65 76 2d 63 6f 6d 6d 65 te ", prev-comme
48c0: 6e 74 20 22 20 70 72 65 76 2d 63 6f 6d 6d 65 6e nt " prev-commen
48d0: 74 29 0a 09 09 09 20 20 20 20 20 28 69 66 20 28 t).... (if (
48e0: 61 6e 64 20 28 65 71 75 61 6c 3f 20 70 72 65 76 and (equal? prev
48f0: 2d 73 74 61 74 65 20 20 22 43 4f 4d 50 4c 45 54 -state "COMPLET
4900: 45 44 22 29 0a 09 09 09 09 20 20 20 20 20 20 28 ED")..... (
4910: 65 71 75 61 6c 3f 20 70 72 65 76 2d 73 74 61 74 equal? prev-stat
4920: 75 73 20 22 57 41 49 56 45 44 22 29 29 0a 09 09 us "WAIVED"))...
4930: 09 09 20 28 69 66 20 63 6f 6d 6d 65 6e 74 0a 09 .. (if comment..
4940: 09 09 09 20 20 20 20 20 63 6f 6d 6d 65 6e 74 0a ... comment.
4950: 09 09 09 09 20 20 20 20 20 70 72 65 76 2d 63 6f .... prev-co
4960: 6d 6d 65 6e 74 29 20 3b 3b 20 77 61 69 76 65 64 mment) ;; waived
4970: 20 69 73 20 65 69 74 68 65 72 20 74 68 65 20 63 is either the c
4980: 6f 6d 6d 65 6e 74 20 6f 72 20 23 66 0a 09 09 09 omment or #f....
4990: 09 20 23 66 29 29 0a 09 09 09 20 20 20 23 66 29 . #f)).... #f)
49a0: 0a 09 09 20 20 20 20 20 20 20 23 66 29 29 29 0a ... #f))).
49b0: 20 20 20 20 28 69 66 20 28 61 6e 64 20 77 61 69 (if (and wai
49c0: 76 65 64 20 0a 09 20 20 20 20 20 28 74 65 73 74 ved .. (test
49d0: 73 3a 63 68 65 63 6b 2d 77 61 69 76 65 72 2d 65 s:check-waiver-e
49e0: 6c 69 67 69 62 69 6c 69 74 79 20 74 65 73 74 64 ligibility testd
49f0: 61 74 20 70 72 65 76 2d 74 65 73 74 29 29 0a 09 at prev-test))..
4a00: 28 73 65 74 21 20 72 65 61 6c 2d 73 74 61 74 75 (set! real-statu
4a10: 73 20 22 57 41 49 56 45 44 22 29 29 0a 0a 20 20 s "WAIVED"))..
4a20: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 (debug:print 4
4a30: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
4a40: 72 74 2a 20 22 72 65 61 6c 2d 73 74 61 74 75 73 rt* "real-status
4a50: 20 22 20 72 65 61 6c 2d 73 74 61 74 75 73 20 22 " real-status "
4a60: 2c 20 77 61 69 76 65 64 20 22 20 77 61 69 76 65 , waived " waive
4a70: 64 20 22 2c 20 73 74 61 74 75 73 20 22 20 73 74 d ", status " st
4a80: 61 74 75 73 29 0a 0a 20 20 20 20 3b 3b 20 75 70 atus).. ;; up
4a90: 64 61 74 65 20 74 68 65 20 70 72 69 6d 61 72 79 date the primary
4aa0: 20 72 65 63 6f 72 64 20 49 46 20 73 74 61 74 65 record IF state
4ab0: 20 41 4e 44 20 73 74 61 74 75 73 20 61 72 65 20 AND status are
4ac0: 64 65 66 69 6e 65 64 0a 20 20 20 20 28 69 66 20 defined. (if
4ad0: 28 61 6e 64 20 73 74 61 74 65 20 73 74 61 74 75 (and state statu
4ae0: 73 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 72 s)..(begin.. (r
4af0: 6d 74 3a 73 65 74 2d 73 74 61 74 65 2d 73 74 61 mt:set-state-sta
4b00: 74 75 73 2d 61 6e 64 2d 72 6f 6c 6c 2d 75 70 2d tus-and-roll-up-
4b10: 69 74 65 6d 73 20 72 75 6e 2d 69 64 20 74 65 73 items run-id tes
4b20: 74 2d 69 64 20 69 74 65 6d 2d 70 61 74 68 20 73 t-id item-path s
4b30: 74 61 74 65 20 72 65 61 6c 2d 73 74 61 74 75 73 tate real-status
4b40: 20 28 69 66 20 77 61 69 76 65 64 20 77 61 69 76 (if waived waiv
4b50: 65 64 20 63 6f 6d 6d 65 6e 74 29 29 0a 09 20 20 ed comment))..
4b60: 3b 3b 20 28 6d 74 3a 70 72 6f 63 65 73 73 2d 74 ;; (mt:process-t
4b70: 72 69 67 67 65 72 73 20 72 75 6e 2d 69 64 20 74 riggers run-id t
4b80: 65 73 74 2d 69 64 20 73 74 61 74 65 20 72 65 61 est-id state rea
4b90: 6c 2d 73 74 61 74 75 73 29 20 3b 3b 20 74 72 69 l-status) ;; tri
4ba0: 67 67 65 72 73 20 61 72 65 20 63 61 6c 6c 65 64 ggers are called
4bb0: 20 69 6e 20 74 65 73 74 2d 73 65 74 2d 73 74 61 in test-set-sta
4bc0: 74 65 2d 73 74 61 74 75 73 0a 09 20 20 29 29 0a te-status.. )).
4bd0: 20 20 20 20 0a 20 20 20 20 3b 3b 20 69 66 20 73 . ;; if s
4be0: 74 61 74 75 73 20 69 73 20 22 41 55 54 4f 22 20 tatus is "AUTO"
4bf0: 74 68 65 6e 20 63 61 6c 6c 20 72 6f 6c 6c 75 70 then call rollup
4c00: 20 28 6e 6f 74 65 2c 20 74 68 69 73 20 6f 6e 65 (note, this one
4c10: 20 6d 6f 64 69 66 69 65 73 20 64 61 74 61 20 69 modifies data i
4c20: 6e 20 74 65 73 74 0a 20 20 20 20 3b 3b 20 72 75 n test. ;; ru
4c30: 6e 20 61 72 65 61 2c 20 69 74 20 64 6f 65 73 20 n area, it does
4c40: 72 65 6d 6f 74 65 20 63 61 6c 6c 73 20 75 6e 64 remote calls und
4c50: 65 72 20 74 68 65 20 68 6f 6f 64 2e 0a 20 20 20 er the hood..
4c60: 20 3b 3b 20 28 69 66 20 28 61 6e 64 20 74 65 73 ;; (if (and tes
4c70: 74 2d 69 64 20 73 74 61 74 65 20 73 74 61 74 75 t-id state statu
4c80: 73 20 28 65 71 75 61 6c 3f 20 73 74 61 74 75 73 s (equal? status
4c90: 20 22 41 55 54 4f 22 29 29 20 0a 20 20 20 20 3b "AUTO")) . ;
4ca0: 3b 20 09 28 72 6d 74 3a 74 65 73 74 2d 64 61 74 ; .(rmt:test-dat
4cb0: 61 2d 72 6f 6c 6c 75 70 20 72 75 6e 2d 69 64 20 a-rollup run-id
4cc0: 74 65 73 74 2d 69 64 20 73 74 61 74 75 73 29 29 test-id status))
4cd0: 0a 0a 20 20 20 20 3b 3b 20 61 64 64 20 6d 65 74 .. ;; add met
4ce0: 61 64 61 74 61 20 28 6e 65 65 64 20 74 6f 20 64 adata (need to d
4cf0: 6f 20 74 68 69 73 20 77 61 79 20 74 6f 20 61 76 o this way to av
4d00: 6f 69 64 20 53 51 4c 20 69 6e 6a 65 63 74 69 6f oid SQL injectio
4d10: 6e 20 69 73 73 75 65 73 29 0a 0a 20 20 20 20 3b n issues).. ;
4d20: 3b 20 3a 66 69 72 73 74 5f 65 72 72 0a 20 20 20 ; :first_err.
4d30: 20 3b 3b 20 28 6c 65 74 20 28 28 76 61 6c 20 28 ;; (let ((val (
4d40: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
4d50: 65 66 61 75 6c 74 20 6f 74 68 65 72 64 61 74 20 efault otherdat
4d60: 22 3a 66 69 72 73 74 5f 65 72 72 22 20 23 66 29 ":first_err" #f)
4d70: 29 29 0a 20 20 20 20 3b 3b 20 20 20 28 69 66 20 )). ;; (if
4d80: 76 61 6c 0a 20 20 20 20 3b 3b 20 20 20 20 20 20 val. ;;
4d90: 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 (sqlite3:execut
4da0: 65 20 64 62 20 22 55 50 44 41 54 45 20 74 65 73 e db "UPDATE tes
4db0: 74 73 20 53 45 54 20 66 69 72 73 74 5f 65 72 72 ts SET first_err
4dc0: 3d 3f 20 57 48 45 52 45 20 72 75 6e 5f 69 64 3d =? WHERE run_id=
4dd0: 3f 20 41 4e 44 20 74 65 73 74 6e 61 6d 65 3d 3f ? AND testname=?
4de0: 20 41 4e 44 20 69 74 65 6d 5f 70 61 74 68 3d 3f AND item_path=?
4df0: 3b 22 20 76 61 6c 20 72 75 6e 2d 69 64 20 74 65 ;" val run-id te
4e00: 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 st-name item-pat
4e10: 68 29 29 29 0a 20 20 20 20 3b 3b 20 0a 20 20 20 h))). ;; .
4e20: 20 3b 3b 20 3b 3b 20 3a 66 69 72 73 74 5f 77 61 ;; ;; :first_wa
4e30: 72 6e 0a 20 20 20 20 3b 3b 20 28 6c 65 74 20 28 rn. ;; (let (
4e40: 28 76 61 6c 20 28 68 61 73 68 2d 74 61 62 6c 65 (val (hash-table
4e50: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 6f 74 68 -ref/default oth
4e60: 65 72 64 61 74 20 22 3a 66 69 72 73 74 5f 77 61 erdat ":first_wa
4e70: 72 6e 22 20 23 66 29 29 29 0a 20 20 20 20 3b 3b rn" #f))). ;;
4e80: 20 20 20 28 69 66 20 76 61 6c 0a 20 20 20 20 3b (if val. ;
4e90: 3b 20 20 20 20 20 20 20 28 73 71 6c 69 74 65 33 ; (sqlite3
4ea0: 3a 65 78 65 63 75 74 65 20 64 62 20 22 55 50 44 :execute db "UPD
4eb0: 41 54 45 20 74 65 73 74 73 20 53 45 54 20 66 69 ATE tests SET fi
4ec0: 72 73 74 5f 77 61 72 6e 3d 3f 20 57 48 45 52 45 rst_warn=? WHERE
4ed0: 20 72 75 6e 5f 69 64 3d 3f 20 41 4e 44 20 74 65 run_id=? AND te
4ee0: 73 74 6e 61 6d 65 3d 3f 20 41 4e 44 20 69 74 65 stname=? AND ite
4ef0: 6d 5f 70 61 74 68 3d 3f 3b 22 20 76 61 6c 20 72 m_path=?;" val r
4f00: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 un-id test-name
4f10: 69 74 65 6d 2d 70 61 74 68 29 29 29 0a 0a 20 20 item-path)))..
4f20: 20 20 28 6c 65 74 20 28 28 63 61 74 65 67 6f 72 (let ((categor
4f30: 79 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 y (hash-table-re
4f40: 66 2f 64 65 66 61 75 6c 74 20 6f 74 68 65 72 64 f/default otherd
4f50: 61 74 20 22 3a 63 61 74 65 67 6f 72 79 22 20 22 at ":category" "
4f60: 22 29 29 0a 09 20 20 28 76 61 72 69 61 62 6c 65 ")).. (variable
4f70: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
4f80: 2f 64 65 66 61 75 6c 74 20 6f 74 68 65 72 64 61 /default otherda
4f90: 74 20 22 3a 76 61 72 69 61 62 6c 65 22 20 22 22 t ":variable" ""
4fa0: 29 29 0a 09 20 20 28 76 61 6c 75 65 20 20 20 20 )).. (value
4fb0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
4fc0: 64 65 66 61 75 6c 74 20 6f 74 68 65 72 64 61 74 default otherdat
4fd0: 20 22 3a 76 61 6c 75 65 22 20 20 20 20 23 66 29 ":value" #f)
4fe0: 29 0a 09 20 20 28 65 78 70 65 63 74 65 64 20 28 ).. (expected (
4ff0: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
5000: 65 66 61 75 6c 74 20 6f 74 68 65 72 64 61 74 20 efault otherdat
5010: 22 3a 65 78 70 65 63 74 65 64 22 20 22 6e 2f 61 ":expected" "n/a
5020: 22 29 29 0a 09 20 20 28 74 6f 6c 20 20 20 20 20 ")).. (tol
5030: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
5040: 2f 64 65 66 61 75 6c 74 20 6f 74 68 65 72 64 61 /default otherda
5050: 74 20 22 3a 74 6f 6c 22 20 20 20 20 20 20 22 6e t ":tol" "n
5060: 2f 61 22 29 29 0a 09 20 20 28 75 6e 69 74 73 20 /a")).. (units
5070: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 (hash-table-r
5080: 65 66 2f 64 65 66 61 75 6c 74 20 6f 74 68 65 72 ef/default other
5090: 64 61 74 20 22 3a 75 6e 69 74 73 22 20 20 20 20 dat ":units"
50a0: 22 22 29 29 0a 09 20 20 28 74 79 70 65 20 20 20 "")).. (type
50b0: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 (hash-table-re
50c0: 66 2f 64 65 66 61 75 6c 74 20 6f 74 68 65 72 64 f/default otherd
50d0: 61 74 20 22 3a 74 79 70 65 22 20 20 20 20 20 22 at ":type" "
50e0: 22 29 29 0a 09 20 20 28 64 63 6f 6d 6d 65 6e 74 ")).. (dcomment
50f0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
5100: 2f 64 65 66 61 75 6c 74 20 6f 74 68 65 72 64 61 /default otherda
5110: 74 20 22 3a 63 6f 6d 6d 65 6e 74 22 20 20 22 22 t ":comment" ""
5120: 29 29 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 ))). (debug
5130: 3a 70 72 69 6e 74 20 34 20 2a 64 65 66 61 75 6c :print 4 *defaul
5140: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 0a 09 09 20 t-log-port* ...
5150: 20 20 22 63 61 74 65 67 6f 72 79 3a 20 22 20 63 "category: " c
5160: 61 74 65 67 6f 72 79 20 22 2c 20 76 61 72 69 61 ategory ", varia
5170: 62 6c 65 3a 20 22 20 76 61 72 69 61 62 6c 65 20 ble: " variable
5180: 22 2c 20 76 61 6c 75 65 3a 20 22 20 76 61 6c 75 ", value: " valu
5190: 65 0a 09 09 20 20 20 22 2c 20 65 78 70 65 63 74 e... ", expect
51a0: 65 64 3a 20 22 20 65 78 70 65 63 74 65 64 20 22 ed: " expected "
51b0: 2c 20 74 6f 6c 3a 20 22 20 74 6f 6c 20 22 2c 20 , tol: " tol ",
51c0: 75 6e 69 74 73 3a 20 22 20 75 6e 69 74 73 29 0a units: " units).
51d0: 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 76 (if (and v
51e0: 61 6c 75 65 29 20 3b 3b 20 72 65 71 75 69 72 65 alue) ;; require
51f0: 20 6f 6e 6c 79 20 76 61 6c 75 65 3b 20 42 42 20 only value; BB
5200: 77 61 73 2d 20 61 6c 6c 20 74 68 72 65 65 20 72 was- all three r
5210: 65 71 75 69 72 65 64 0a 09 20 20 28 6c 65 74 20 equired.. (let
5220: 28 28 64 61 74 20 28 63 6f 6e 63 20 63 61 74 65 ((dat (conc cate
5230: 67 6f 72 79 20 22 2c 22 0a 09 09 09 20 20 20 76 gory ",".... v
5240: 61 72 69 61 62 6c 65 20 22 2c 22 0a 09 09 09 20 ariable ","....
5250: 20 20 76 61 6c 75 65 20 20 20 20 22 2c 22 0a 09 value ","..
5260: 09 09 20 20 20 65 78 70 65 63 74 65 64 20 22 2c .. expected ",
5270: 22 0a 09 09 09 20 20 20 74 6f 6c 20 20 20 20 20 ".... tol
5280: 20 22 2c 22 0a 09 09 09 20 20 20 75 6e 69 74 73 ",".... units
5290: 20 20 20 20 22 2c 22 0a 09 09 09 20 20 20 64 63 ",".... dc
52a0: 6f 6d 6d 65 6e 74 20 22 2c 2c 22 20 3b 3b 20 65 omment ",," ;; e
52b0: 78 74 72 61 20 63 6f 6d 6d 61 20 66 6f 72 20 73 xtra comma for s
52c0: 74 61 74 75 73 0a 09 09 09 20 20 20 74 79 70 65 tatus.... type
52d0: 20 20 20 20 20 29 29 29 0a 09 20 20 20 20 3b 3b ))).. ;;
52e0: 20 54 68 69 73 20 77 61 73 20 72 75 6e 20 72 65 This was run re
52f0: 6d 6f 74 65 2c 20 64 6f 6e 27 74 20 74 68 69 6e mote, don't thin
5300: 6b 20 74 68 61 74 20 6d 61 6b 65 73 20 73 65 6e k that makes sen
5310: 73 65 2e 20 50 65 72 68 61 70 73 20 6e 6f 74 2c se. Perhaps not,
5320: 20 62 75 74 20 74 68 61 74 20 69 73 20 74 68 65 but that is the
5330: 20 65 61 73 69 65 73 74 20 70 61 74 68 20 66 6f easiest path fo
5340: 72 20 74 68 65 20 6d 6f 6d 65 6e 74 2e 0a 09 20 r the moment...
5350: 20 20 20 28 72 6d 74 3a 63 73 76 2d 3e 74 65 73 (rmt:csv->tes
5360: 74 2d 64 61 74 61 20 72 75 6e 2d 69 64 20 74 65 t-data run-id te
5370: 73 74 2d 69 64 0a 09 09 09 09 64 61 74 29 0a 09 st-id.....dat)..
5380: 20 20 20 20 3b 3b 20 54 68 69 73 20 77 61 73 20 ;; This was
5390: 61 64 64 65 64 20 69 6e 20 63 68 65 63 6b 2d 69 added in check-i
53a0: 6e 20 61 35 61 64 66 61 33 66 39 61 2e 20 4d 65 n a5adfa3f9a. Me
53b0: 73 73 61 67 65 20 77 61 73 3a 20 22 2e 2e 2e 61 ssage was: "...a
53c0: 64 64 65 64 20 64 65 6c 61 79 20 69 6e 20 73 65 dded delay in se
53d0: 74 2d 76 61 6c 75 65 73 20 74 6f 20 61 6c 6c 6f t-values to allo
53e0: 77 20 66 6f 72 20 64 65 6c 61 79 65 64 20 77 72 w for delayed wr
53f0: 69 74 65 20 6f 6e 20 73 65 72 76 65 72 20 73 74 ite on server st
5400: 61 72 74 22 0a 09 20 20 20 20 3b 3b 20 49 27 6d art".. ;; I'm
5410: 20 69 6e 73 65 72 74 69 6e 67 20 61 6e 20 61 72 inserting an ar
5420: 62 69 74 72 61 72 79 20 72 6d 74 3a 20 63 61 6c bitrary rmt: cal
5430: 6c 20 74 6f 20 66 6f 72 63 65 2f 65 6e 73 75 72 l to force/ensur
5440: 65 20 74 68 61 74 20 74 68 65 20 73 65 72 76 65 e that the serve
5450: 72 20 69 73 20 61 76 61 69 6c 61 62 6c 65 20 74 r is available t
5460: 6f 20 28 68 6f 70 65 66 75 6c 6c 79 29 20 70 72 o (hopefully) pr
5470: 65 76 65 6e 74 20 61 20 63 6f 6d 6d 75 6e 69 63 event a communic
5480: 61 74 69 6f 6e 20 69 73 73 75 65 2e 0a 09 20 20 ation issue...
5490: 20 20 28 72 6d 74 3a 67 65 74 2d 76 61 72 20 22 (rmt:get-var "
54a0: 4d 45 47 41 54 45 53 54 5f 56 45 52 53 49 4f 4e MEGATEST_VERSION
54b0: 22 29 20 3b 3b 20 74 68 69 73 20 64 6f 65 73 20 ") ;; this does
54c0: 4e 4f 54 48 49 4e 47 20 62 75 74 20 65 6e 73 75 NOTHING but ensu
54d0: 72 65 20 74 68 65 20 73 65 72 76 65 72 20 69 73 re the server is
54e0: 20 72 65 61 63 68 61 62 6c 65 2e 20 54 68 69 73 reachable. This
54f0: 20 69 73 20 61 6c 6d 6f 73 74 20 63 65 72 74 61 is almost certa
5500: 69 6e 6c 79 20 4e 4f 54 20 6e 65 65 64 65 64 20 inly NOT needed
5510: 3a 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 3b :). ;
5520: 3b 20 42 42 20 2d 20 63 6f 6d 6d 65 6e 74 69 6f ; BB - commentio
5530: 6e 67 20 6f 75 74 20 61 72 62 69 74 72 61 72 79 ng out arbitrary
5540: 20 31 30 20 73 65 63 6f 6e 64 20 77 61 69 74 20 10 second wait
5550: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 (thread-sleep! 1
5560: 30 29 20 3b 3b 20 61 64 64 20 31 30 20 73 65 63 0) ;; add 10 sec
5570: 6f 6e 64 20 64 65 6c 61 79 20 62 65 66 6f 72 65 ond delay before
5580: 20 71 75 69 74 20 69 6e 63 61 73 65 20 72 6d 74 quit incase rmt
5590: 20 6e 65 65 64 73 20 74 69 6d 65 20 74 6f 20 73 needs time to s
55a0: 74 61 72 74 20 61 20 73 65 72 76 65 72 2e 0a 20 tart a server..
55b0: 20 20 20 20 20 20 20 20 20 20 20 29 29 29 0a 20 ))).
55c0: 20 20 20 20 20 0a 20 20 20 20 3b 3b 20 6e 65 65 . ;; nee
55d0: 64 20 74 6f 20 75 70 64 61 74 65 20 74 68 65 20 d to update the
55e0: 74 6f 70 20 74 65 73 74 20 72 65 63 6f 72 64 20 top test record
55f0: 69 66 20 50 41 53 53 20 6f 72 20 46 41 49 4c 20 if PASS or FAIL
5600: 61 6e 64 20 74 68 69 73 20 69 73 20 61 20 73 75 and this is a su
5610: 62 74 65 73 74 0a 20 20 20 20 3b 3b 3b 3b 3b 3b btest. ;;;;;;
5620: 20 28 69 66 20 28 6e 6f 74 20 28 65 71 75 61 6c (if (not (equal
5630: 3f 20 69 74 65 6d 2d 70 61 74 68 20 22 22 29 29 ? item-path ""))
5640: 0a 20 20 20 20 3b 3b 3b 3b 3b 3b 20 20 20 20 20 . ;;;;;;
5650: 28 72 6d 74 3a 73 65 74 2d 73 74 61 74 65 2d 73 (rmt:set-state-s
5660: 74 61 74 75 73 2d 61 6e 64 2d 72 6f 6c 6c 2d 75 tatus-and-roll-u
5670: 70 2d 69 74 65 6d 73 20 72 75 6e 2d 69 64 20 74 p-items run-id t
5680: 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 est-name item-pa
5690: 74 68 20 73 74 61 74 65 20 73 74 61 74 75 73 20 th state status
56a0: 23 66 29 20 3b 3b 3b 3b 3b 29 0a 0a 20 20 20 20 #f) ;;;;;)..
56b0: 28 69 66 20 28 6f 72 20 28 61 6e 64 20 28 73 74 (if (or (and (st
56c0: 72 69 6e 67 3f 20 63 6f 6d 6d 65 6e 74 29 0a 09 ring? comment)..
56d0: 09 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 . (string-match
56e0: 28 72 65 67 65 78 70 20 22 5c 5c 53 2b 22 29 20 (regexp "\\S+")
56f0: 63 6f 6d 6d 65 6e 74 29 29 0a 09 20 20 20 20 77 comment)).. w
5700: 61 69 76 65 64 29 0a 09 28 6c 65 74 20 28 28 63 aived)..(let ((c
5710: 6d 74 20 20 28 69 66 20 77 61 69 76 65 64 20 77 mt (if waived w
5720: 61 69 76 65 64 20 63 6f 6d 6d 65 6e 74 29 29 29 aived comment)))
5730: 0a 09 20 20 28 72 6d 74 3a 67 65 6e 65 72 61 6c .. (rmt:general
5740: 2d 63 61 6c 6c 20 27 73 65 74 2d 74 65 73 74 2d -call 'set-test-
5750: 63 6f 6d 6d 65 6e 74 20 72 75 6e 2d 69 64 20 63 comment run-id c
5760: 6d 74 20 74 65 73 74 2d 69 64 29 29 29 29 29 0a mt test-id))))).
5770: 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a .(define (tests:
5780: 74 65 73 74 2d 73 65 74 2d 74 6f 70 6c 6f 67 21 test-set-toplog!
5790: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
57a0: 65 20 6c 6f 67 66 29 20 0a 20 20 28 72 6d 74 3a e logf) . (rmt:
57b0: 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 74 65 general-call 'te
57c0: 73 74 73 3a 74 65 73 74 2d 73 65 74 2d 74 6f 70 sts:test-set-top
57d0: 6c 6f 67 20 72 75 6e 2d 69 64 20 6c 6f 67 66 20 log run-id logf
57e0: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
57f0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 ))..(define (tes
5800: 74 73 3a 73 75 6d 6d 61 72 69 7a 65 2d 69 74 65 ts:summarize-ite
5810: 6d 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 ms run-id test-i
5820: 64 20 74 65 73 74 2d 6e 61 6d 65 20 66 6f 72 63 d test-name forc
5830: 65 29 0a 20 20 3b 3b 20 69 66 20 6e 6f 74 20 66 e). ;; if not f
5840: 6f 72 63 65 20 74 68 65 6e 20 6f 6e 6c 79 20 75 orce then only u
5850: 70 64 61 74 65 20 74 68 65 20 72 65 63 6f 72 64 pdate the record
5860: 20 69 66 20 6f 6e 65 20 6f 66 20 74 68 65 73 65 if one of these
5870: 20 69 73 20 74 72 75 65 3a 0a 20 20 3b 3b 20 20 is true:. ;;
5880: 20 31 2e 20 6c 6f 67 66 20 69 73 20 22 6c 6f 67 1. logf is "log
5890: 2f 66 69 6e 61 6c 2e 6c 6f 67 0a 20 20 3b 3b 20 /final.log. ;;
58a0: 20 20 32 2e 20 6c 6f 67 66 20 69 73 20 73 61 6d 2. logf is sam
58b0: 65 20 61 73 20 6f 75 74 70 75 74 66 69 6c 65 6e e as outputfilen
58c0: 61 6d 65 0a 20 20 28 6c 65 74 2a 20 28 28 6f 75 ame. (let* ((ou
58d0: 74 70 75 74 66 69 6c 65 6e 61 6d 65 20 28 63 6f tputfilename (co
58e0: 6e 63 20 22 6d 65 67 61 74 65 73 74 2d 72 6f 6c nc "megatest-rol
58f0: 6c 75 70 2d 22 20 74 65 73 74 2d 6e 61 6d 65 20 lup-" test-name
5900: 22 2e 68 74 6d 6c 22 29 29 0a 09 20 28 6f 72 69 ".html")).. (ori
5910: 67 2d 64 69 72 20 20 20 20 20 20 20 28 63 75 72 g-dir (cur
5920: 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 79 29 29 rent-directory))
5930: 0a 09 20 28 6c 6f 67 66 2d 69 6e 66 6f 20 20 20 .. (logf-info
5940: 20 20 20 28 72 6d 74 3a 74 65 73 74 2d 67 65 74 (rmt:test-get
5950: 2d 6c 6f 67 66 69 6c 65 2d 69 6e 66 6f 20 72 75 -logfile-info ru
5960: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 29 29 n-id test-name))
5970: 0a 09 20 28 6c 6f 67 66 20 20 20 20 20 20 20 20 .. (logf
5980: 20 20 20 28 69 66 20 6c 6f 67 66 2d 69 6e 66 6f (if logf-info
5990: 20 28 63 61 64 72 20 6c 6f 67 66 2d 69 6e 66 6f (cadr logf-info
59a0: 29 20 23 66 29 29 0a 09 20 28 70 61 74 68 20 20 ) #f)).. (path
59b0: 20 20 20 20 20 20 20 20 20 28 69 66 20 6c 6f 67 (if log
59c0: 66 2d 69 6e 66 6f 20 28 63 61 72 20 20 6c 6f 67 f-info (car log
59d0: 66 2d 69 6e 66 6f 29 20 23 66 29 29 29 0a 20 20 f-info) #f))).
59e0: 20 20 3b 3b 20 54 68 69 73 20 71 75 65 72 79 20 ;; This query
59f0: 66 69 6e 64 73 20 74 68 65 20 70 61 74 68 20 61 finds the path a
5a00: 6e 64 20 63 68 61 6e 67 65 73 20 74 68 65 20 64 nd changes the d
5a10: 69 72 65 63 74 6f 72 79 20 74 6f 20 69 74 20 66 irectory to it f
5a20: 6f 72 20 74 68 65 20 74 65 73 74 0a 20 20 20 20 or the test.
5a30: 28 69 66 20 28 61 6e 64 20 28 73 74 72 69 6e 67 (if (and (string
5a40: 3f 20 70 61 74 68 29 0a 09 20 20 20 20 20 28 64 ? path).. (d
5a50: 69 72 65 63 74 6f 72 79 3f 20 70 61 74 68 29 29 irectory? path))
5a60: 20 3b 3b 20 63 61 6e 20 67 65 74 20 23 66 20 68 ;; can get #f h
5a70: 65 72 65 20 75 6e 64 65 72 20 73 6f 6d 65 20 77 ere under some w
5a80: 69 65 72 64 20 63 6f 6e 64 69 74 69 6f 6e 73 2e ierd conditions.
5a90: 20 77 68 79 2c 20 75 6e 6b 6e 6f 77 6e 20 2e 2e why, unknown ..
5aa0: 2e 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 64 65 ...(begin.. (de
5ab0: 62 75 67 3a 70 72 69 6e 74 20 34 20 2a 64 65 66 bug:print 4 *def
5ac0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
5ad0: 46 6f 75 6e 64 20 70 61 74 68 3a 20 22 20 70 61 Found path: " pa
5ae0: 74 68 29 0a 09 20 20 28 63 68 61 6e 67 65 2d 64 th).. (change-d
5af0: 69 72 65 63 74 6f 72 79 20 70 61 74 68 29 29 0a irectory path)).
5b00: 09 3b 3b 20 28 73 65 74 21 20 6f 75 74 70 75 74 .;; (set! output
5b10: 66 69 6c 65 6e 61 6d 65 20 28 63 6f 6e 63 20 70 filename (conc p
5b20: 61 74 68 20 22 2f 22 20 6f 75 74 70 75 74 66 69 ath "/" outputfi
5b30: 6c 65 6e 61 6d 65 29 29 29 0a 09 28 64 65 62 75 lename)))..(debu
5b40: 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 g:print-error 0
5b50: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
5b60: 74 2a 20 22 73 75 6d 6d 61 72 69 7a 65 2d 69 74 t* "summarize-it
5b70: 65 6d 73 20 66 6f 72 20 72 75 6e 2d 69 64 3d 22 ems for run-id="
5b80: 20 72 75 6e 2d 69 64 20 22 2c 20 74 65 73 74 2d run-id ", test-
5b90: 6e 61 6d 65 3d 22 20 74 65 73 74 2d 6e 61 6d 65 name=" test-name
5ba0: 20 22 2c 20 6e 6f 20 73 75 63 68 20 70 61 74 68 ", no such path
5bb0: 3a 20 22 20 70 61 74 68 29 29 0a 20 20 20 20 28 : " path)). (
5bc0: 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 2a 64 debug:print 4 *d
5bd0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
5be0: 20 22 73 75 6d 6d 61 72 69 7a 65 2d 69 74 65 6d "summarize-item
5bf0: 73 20 77 69 74 68 20 6c 6f 67 66 20 22 20 6c 6f s with logf " lo
5c00: 67 66 20 22 2c 20 6f 75 74 70 75 74 66 69 6c 65 gf ", outputfile
5c10: 6e 61 6d 65 20 22 20 6f 75 74 70 75 74 66 69 6c name " outputfil
5c20: 65 6e 61 6d 65 20 22 20 61 6e 64 20 66 6f 72 63 ename " and forc
5c30: 65 20 22 20 66 6f 72 63 65 29 0a 20 20 20 20 28 e " force). (
5c40: 69 66 20 28 6f 72 20 28 65 71 75 61 6c 3f 20 6c if (or (equal? l
5c50: 6f 67 66 20 22 6c 6f 67 73 2f 66 69 6e 61 6c 2e ogf "logs/final.
5c60: 6c 6f 67 22 29 0a 09 20 20 20 20 28 65 71 75 61 log").. (equa
5c70: 6c 3f 20 6c 6f 67 66 20 6f 75 74 70 75 74 66 69 l? logf outputfi
5c80: 6c 65 6e 61 6d 65 29 0a 09 20 20 20 20 66 6f 72 lename).. for
5c90: 63 65 29 0a 09 28 6c 65 74 20 28 28 6d 79 2d 73 ce)..(let ((my-s
5ca0: 74 61 72 74 2d 74 69 6d 65 20 28 63 75 72 72 65 tart-time (curre
5cb0: 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 20 20 nt-seconds))..
5cc0: 20 20 20 20 28 6c 6f 63 6b 66 20 20 20 20 20 20 (lockf
5cd0: 20 20 20 28 63 6f 6e 63 20 6f 75 74 70 75 74 66 (conc outputf
5ce0: 69 6c 65 6e 61 6d 65 20 22 2e 6c 6f 63 6b 22 29 ilename ".lock")
5cf0: 29 29 0a 09 20 20 28 6c 65 74 20 6c 6f 6f 70 20 )).. (let loop
5d00: 28 28 68 61 76 65 2d 6c 6f 63 6b 20 20 28 63 6f ((have-lock (co
5d10: 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 mmon:simple-file
5d20: 2d 6c 6f 63 6b 20 6c 6f 63 6b 66 29 29 29 0a 09 -lock lockf)))..
5d30: 20 20 20 20 28 69 66 20 68 61 76 65 2d 6c 6f 63 (if have-loc
5d40: 6b 0a 09 09 28 6c 65 74 20 28 28 73 63 72 69 70 k...(let ((scrip
5d50: 74 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 t (configf:looku
5d60: 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 74 p *configdat* "t
5d70: 65 73 74 72 6f 6c 6c 75 70 22 20 74 65 73 74 2d estrollup" test-
5d80: 6e 61 6d 65 29 29 29 0a 09 09 20 20 28 70 72 69 name)))... (pri
5d90: 6e 74 20 22 4f 62 74 61 69 6e 65 64 20 6c 6f 63 nt "Obtained loc
5da0: 6b 20 66 6f 72 20 22 20 6f 75 74 70 75 74 66 69 k for " outputfi
5db0: 6c 65 6e 61 6d 65 29 0a 09 09 20 20 28 72 6d 74 lename)... (rmt
5dc0: 3a 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 :set-state-statu
5dd0: 73 2d 61 6e 64 2d 72 6f 6c 6c 2d 75 70 2d 69 74 s-and-roll-up-it
5de0: 65 6d 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d ems run-id test-
5df0: 6e 61 6d 65 20 22 22 20 23 66 20 23 66 20 23 66 name "" #f #f #f
5e00: 29 0a 09 09 20 20 28 69 66 20 73 63 72 69 70 74 )... (if script
5e10: 0a 09 09 20 20 20 20 20 20 28 73 79 73 74 65 6d ... (system
5e20: 20 28 63 6f 6e 63 20 73 63 72 69 70 74 20 22 20 (conc script "
5e30: 3e 20 22 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 > " outputfilena
5e40: 6d 65 20 22 20 26 20 22 29 29 0a 09 09 20 20 20 me " & "))...
5e50: 20 20 20 28 74 65 73 74 73 3a 67 65 6e 65 72 61 (tests:genera
5e60: 74 65 2d 68 74 6d 6c 2d 73 75 6d 6d 61 72 79 2d te-html-summary-
5e70: 66 6f 72 2d 69 74 65 72 61 74 65 64 2d 74 65 73 for-iterated-tes
5e80: 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 t run-id test-id
5e90: 20 74 65 73 74 2d 6e 61 6d 65 20 6f 75 74 70 75 test-name outpu
5ea0: 74 66 69 6c 65 6e 61 6d 65 29 29 0a 09 09 20 20 tfilename))...
5eb0: 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 2d 66 (common:simple-f
5ec0: 69 6c 65 2d 72 65 6c 65 61 73 65 2d 6c 6f 63 6b ile-release-lock
5ed0: 20 6c 6f 63 6b 66 29 0a 09 09 20 20 28 63 68 61 lockf)... (cha
5ee0: 6e 67 65 2d 64 69 72 65 63 74 6f 72 79 20 6f 72 nge-directory or
5ef0: 69 67 2d 64 69 72 29 0a 09 09 20 20 3b 3b 20 4e ig-dir)... ;; N
5f00: 42 2f 2f 20 74 65 73 74 73 3a 74 65 73 74 2d 73 B// tests:test-s
5f10: 65 74 2d 74 6f 70 6c 6f 67 21 20 69 73 20 72 65 et-toplog! is re
5f20: 6d 6f 74 65 20 69 6e 74 65 72 6e 61 6c 2e 2e 2e mote internal...
5f30: 0a 09 09 20 20 28 74 65 73 74 73 3a 74 65 73 74 ... (tests:test
5f40: 2d 73 65 74 2d 74 6f 70 6c 6f 67 21 20 72 75 6e -set-toplog! run
5f50: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 6f 75 -id test-name ou
5f60: 74 70 75 74 66 69 6c 65 6e 61 6d 65 29 29 0a 09 tputfilename))..
5f70: 09 3b 3b 20 64 69 64 6e 27 74 20 67 65 74 20 74 .;; didn't get t
5f80: 68 65 20 6c 6f 63 6b 2c 20 63 68 65 63 6b 20 74 he lock, check t
5f90: 6f 20 73 65 65 20 69 66 20 63 75 72 72 65 6e 74 o see if current
5fa0: 20 75 70 64 61 74 65 20 73 74 61 72 74 65 64 20 update started
5fb0: 6c 61 74 65 72 20 74 68 61 6e 20 74 68 69 73 20 later than this
5fc0: 0a 09 09 3b 3b 20 75 70 64 61 74 65 2c 20 69 66 ...;; update, if
5fd0: 20 73 6f 20 77 65 20 63 61 6e 20 65 78 69 74 20 so we can exit
5fe0: 77 69 74 68 6f 75 74 20 64 6f 69 6e 67 20 61 6e without doing an
5ff0: 79 20 77 6f 72 6b 0a 09 09 28 69 66 20 28 3e 20 y work...(if (>
6000: 6d 79 2d 73 74 61 72 74 2d 74 69 6d 65 20 28 68 my-start-time (h
6010: 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 andle-exceptions
6020: 0a 09 09 09 09 09 20 65 78 6e 0a 09 09 09 09 20 ...... exn.....
6030: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 (begin....
6040: 09 09 20 28 70 72 69 6e 74 20 22 66 61 69 6c 65 .. (print "faile
6050: 64 20 74 6f 20 67 65 74 20 6d 6f 64 20 74 69 6d d to get mod tim
6060: 65 20 6f 6e 20 22 20 6c 6f 63 6b 66 20 22 2c 20 e on " lockf ",
6070: 65 78 6e 3d 22 20 65 78 6e 29 0a 09 09 09 09 09 exn=" exn)......
6080: 20 30 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 0)..... (
6090: 66 69 6c 65 2d 6d 6f 64 69 66 69 63 61 74 69 6f file-modificatio
60a0: 6e 2d 74 69 6d 65 20 6c 6f 63 6b 66 29 29 29 0a n-time lockf))).
60b0: 09 09 20 20 20 20 3b 3b 20 77 65 20 73 74 61 72 .. ;; we star
60c0: 74 65 64 20 73 69 6e 63 65 20 63 75 72 72 65 6e ted since curren
60d0: 74 20 72 65 2d 67 65 6e 20 69 6e 20 66 6c 69 67 t re-gen in flig
60e0: 68 74 2c 20 64 65 6c 61 79 20 61 20 6c 69 74 74 ht, delay a litt
60f0: 6c 65 20 61 6e 64 20 74 72 79 20 61 67 61 69 6e le and try again
6100: 0a 09 09 20 20 20 20 28 62 65 67 69 6e 0a 09 09 ... (begin...
6110: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
6120: 6e 74 2d 69 6e 66 6f 20 31 20 2a 64 65 66 61 75 nt-info 1 *defau
6130: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 61 lt-log-port* "Wa
6140: 69 74 69 6e 67 20 74 6f 20 75 70 64 61 74 65 20 iting to update
6150: 22 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 " outputfilename
6160: 20 22 2c 20 61 6e 6f 74 68 65 72 20 74 65 73 74 ", another test
6170: 20 63 75 72 72 65 6e 74 6c 79 20 75 70 64 61 74 currently updat
6180: 69 6e 67 20 69 74 22 29 0a 09 09 20 20 20 20 20 ing it")...
6190: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
61a0: 28 2b 20 35 20 28 72 61 6e 64 6f 6d 20 35 29 29 (+ 5 (random 5))
61b0: 29 20 3b 3b 20 64 65 6c 61 79 20 62 65 74 77 65 ) ;; delay betwe
61c0: 65 6e 20 35 20 61 6e 64 20 31 30 20 73 65 63 6f en 5 and 10 seco
61d0: 6e 64 73 0a 09 09 20 20 20 20 20 20 28 6c 6f 6f nds... (loo
61e0: 70 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 p (common:simple
61f0: 2d 66 69 6c 65 2d 6c 6f 63 6b 20 6c 6f 63 6b 66 -file-lock lockf
6200: 29 29 29 29 29 29 29 29 29 29 0a 0a 28 64 65 66 ))))))))))..(def
6210: 69 6e 65 20 28 74 65 73 74 73 3a 67 65 6e 65 72 ine (tests:gener
6220: 61 74 65 2d 68 74 6d 6c 2d 73 75 6d 6d 61 72 79 ate-html-summary
6230: 2d 66 6f 72 2d 69 74 65 72 61 74 65 64 2d 74 65 -for-iterated-te
6240: 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 st run-id test-i
6250: 64 20 74 65 73 74 2d 6e 61 6d 65 20 6f 75 74 70 d test-name outp
6260: 75 74 66 69 6c 65 6e 61 6d 65 29 0a 20 20 28 6c utfilename). (l
6270: 65 74 20 28 28 63 6f 75 6e 74 73 20 20 20 20 20 et ((counts
6280: 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 (make-h
6290: 61 73 68 2d 74 61 62 6c 65 29 29 0a 09 28 73 74 ash-table))..(st
62a0: 61 74 65 63 6f 75 6e 74 73 20 20 20 20 20 20 20 atecounts
62b0: 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 (make-hash-tab
62c0: 6c 65 29 29 0a 09 28 6f 75 74 74 78 74 20 20 20 le))..(outtxt
62d0: 20 20 20 20 20 20 20 20 20 20 20 22 22 29 0a 09 "")..
62e0: 28 74 6f 74 20 20 20 20 20 20 20 20 20 20 20 20 (tot
62f0: 20 20 20 20 20 30 29 0a 09 28 74 65 73 74 64 61 0)..(testda
6300: 74 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 t (r
6310: 6d 74 3a 74 65 73 74 2d 67 65 74 2d 72 65 63 6f mt:test-get-reco
6320: 72 64 73 2d 66 6f 72 2d 69 6e 64 65 78 2d 66 69 rds-for-index-fi
6330: 6c 65 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e le run-id test-n
6340: 61 6d 65 29 29 29 0a 20 20 20 20 28 77 69 74 68 ame))). (with
6350: 2d 6f 75 74 70 75 74 2d 74 6f 2d 66 69 6c 65 20 -output-to-file
6360: 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 0a 20 outputfilename.
6370: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a (lambda ().
6380: 09 28 73 65 74 21 20 6f 75 74 74 78 74 20 28 63 .(set! outtxt (c
6390: 6f 6e 63 20 6f 75 74 74 78 74 20 22 3c 68 74 6d onc outtxt "<htm
63a0: 6c 3e 3c 74 69 74 6c 65 3e 53 75 6d 6d 61 72 79 l><title>Summary
63b0: 3a 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 0a 09 : " test-name ..
63c0: 09 09 20 20 20 22 3c 2f 74 69 74 6c 65 3e 3c 62 .. "</title><b
63d0: 6f 64 79 3e 3c 68 32 3e 53 75 6d 6d 61 72 79 20 ody><h2>Summary
63e0: 66 6f 72 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 for " test-name
63f0: 22 3c 2f 68 32 3e 22 29 29 0a 09 28 66 6f 72 2d "</h2>"))..(for-
6400: 65 61 63 68 0a 09 20 28 6c 61 6d 62 64 61 20 28 each.. (lambda (
6410: 74 65 73 74 72 65 63 6f 72 64 29 0a 09 20 20 20 testrecord)..
6420: 28 6c 65 74 20 28 28 69 64 20 20 20 20 20 20 20 (let ((id
6430: 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 (vector-re
6440: 66 20 74 65 73 74 72 65 63 6f 72 64 20 30 29 29 f testrecord 0))
6450: 0a 09 09 20 28 69 74 65 6d 70 61 74 68 20 20 20 ... (itempath
6460: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
6470: 74 65 73 74 72 65 63 6f 72 64 20 31 29 29 0a 09 testrecord 1))..
6480: 09 20 28 73 74 61 74 65 20 20 20 20 20 20 20 20 . (state
6490: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 65 (vector-ref te
64a0: 73 74 72 65 63 6f 72 64 20 32 29 29 0a 09 09 20 strecord 2))...
64b0: 28 73 74 61 74 75 73 20 20 20 20 20 20 20 20 20 (status
64c0: 28 76 65 63 74 6f 72 2d 72 65 66 20 74 65 73 74 (vector-ref test
64d0: 72 65 63 6f 72 64 20 33 29 29 0a 09 09 20 28 72 record 3))... (r
64e0: 75 6e 5f 64 75 72 61 74 69 6f 6e 20 20 20 28 76 un_duration (v
64f0: 65 63 74 6f 72 2d 72 65 66 20 74 65 73 74 72 65 ector-ref testre
6500: 63 6f 72 64 20 34 29 29 0a 09 09 20 28 6c 6f 67 cord 4))... (log
6510: 66 20 20 20 20 20 20 20 20 20 20 20 28 76 65 63 f (vec
6520: 74 6f 72 2d 72 65 66 20 74 65 73 74 72 65 63 6f tor-ref testreco
6530: 72 64 20 35 29 29 0a 09 09 20 28 63 6f 6d 6d 65 rd 5))... (comme
6540: 6e 74 20 20 20 20 20 20 20 20 28 76 65 63 74 6f nt (vecto
6550: 72 2d 72 65 66 20 74 65 73 74 72 65 63 6f 72 64 r-ref testrecord
6560: 20 36 29 29 29 0a 09 20 20 20 20 20 28 68 61 73 6))).. (has
6570: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 63 6f 75 h-table-set! cou
6580: 6e 74 73 20 73 74 61 74 75 73 20 28 2b 20 31 20 nts status (+ 1
6590: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
65a0: 64 65 66 61 75 6c 74 20 63 6f 75 6e 74 73 20 73 default counts s
65b0: 74 61 74 75 73 20 30 29 29 29 0a 09 20 20 20 20 tatus 0)))..
65c0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
65d0: 21 20 73 74 61 74 65 63 6f 75 6e 74 73 20 73 74 ! statecounts st
65e0: 61 74 65 20 28 2b 20 31 20 28 68 61 73 68 2d 74 ate (+ 1 (hash-t
65f0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
6600: 20 73 74 61 74 65 63 6f 75 6e 74 73 20 73 74 61 statecounts sta
6610: 74 65 20 30 29 29 29 0a 09 20 20 20 20 20 28 73 te 0))).. (s
6620: 65 74 21 20 6f 75 74 74 78 74 20 28 63 6f 6e 63 et! outtxt (conc
6630: 20 6f 75 74 74 78 74 20 22 3c 74 72 3e 22 0a 09 outtxt "<tr>"..
6640: 09 09 09 3b 3b 20 22 3c 74 64 3e 3c 61 20 68 72 ...;; "<td><a hr
6650: 65 66 3d 5c 22 22 20 69 74 65 6d 70 61 74 68 20 ef=\"" itempath
6660: 22 2f 22 20 6c 6f 67 66 20 22 5c 22 3e 20 22 20 "/" logf "\"> "
6670: 69 74 65 6d 70 61 74 68 20 22 3c 2f 61 3e 3c 2f itempath "</a></
6680: 74 64 3e 22 20 0a 09 09 09 09 22 3c 74 64 3e 3c td>" ....."<td><
6690: 61 20 68 72 65 66 3d 5c 22 22 20 69 74 65 6d 70 a href=\"" itemp
66a0: 61 74 68 20 22 2f 74 65 73 74 2d 73 75 6d 6d 61 ath "/test-summa
66b0: 72 79 2e 68 74 6d 6c 5c 22 3e 20 22 20 69 74 65 ry.html\"> " ite
66c0: 6d 70 61 74 68 20 22 3c 2f 61 3e 3c 2f 74 64 3e mpath "</a></td>
66d0: 22 20 0a 09 09 09 09 22 3c 74 64 3e 22 20 73 74 " ....."<td>" st
66e0: 61 74 65 20 20 20 20 22 3c 2f 74 64 3e 22 20 0a ate "</td>" .
66f0: 09 09 09 09 22 3c 74 64 3e 3c 66 6f 6e 74 20 63 ...."<td><font c
6700: 6f 6c 6f 72 3d 22 20 28 63 6f 6d 6d 6f 6e 3a 67 olor=" (common:g
6710: 65 74 2d 63 6f 6c 6f 72 2d 66 72 6f 6d 2d 73 74 et-color-from-st
6720: 61 74 75 73 20 73 74 61 74 75 73 29 0a 09 09 09 atus status)....
6730: 09 22 3e 22 20 20 20 73 74 61 74 75 73 20 20 20 .">" status
6740: 22 3c 2f 66 6f 6e 74 3e 3c 2f 74 64 3e 22 0a 09 "</font></td>"..
6750: 09 09 09 22 3c 74 64 3e 22 20 28 69 66 20 28 65 ..."<td>" (if (e
6760: 71 75 61 6c 3f 20 63 6f 6d 6d 65 6e 74 20 22 22 qual? comment ""
6770: 29 0a 09 09 09 09 09 20 20 20 22 26 6e 62 73 70 )...... " 
6780: 3b 22 0a 09 09 09 09 09 20 20 20 63 6f 6d 6d 65 ;"...... comme
6790: 6e 74 29 20 22 3c 2f 74 64 3e 22 0a 09 09 09 09 nt) "</td>".....
67a0: 09 20 20 20 22 3c 2f 74 72 3e 22 29 29 29 29 0a . "</tr>")))).
67b0: 09 20 28 69 66 20 28 6c 69 73 74 3f 20 74 65 73 . (if (list? tes
67c0: 74 64 61 74 29 0a 09 20 20 20 20 20 74 65 73 74 tdat).. test
67d0: 64 61 74 0a 09 20 20 20 20 20 28 62 65 67 69 6e dat.. (begin
67e0: 0a 09 20 20 20 20 20 20 20 28 70 72 69 6e 74 20 .. (print
67f0: 22 45 52 52 4f 52 3a 20 66 61 69 6c 65 64 20 74 "ERROR: failed t
6800: 6f 20 67 65 74 20 72 65 63 6f 72 64 73 20 77 69 o get records wi
6810: 74 68 20 72 6d 74 3a 74 65 73 74 2d 67 65 74 2d th rmt:test-get-
6820: 72 65 63 6f 72 64 73 2d 66 6f 72 2d 69 6e 64 65 records-for-inde
6830: 78 2d 66 69 6c 65 20 72 75 6e 2d 69 64 3d 22 20 x-file run-id="
6840: 72 75 6e 2d 69 64 20 22 74 65 73 74 2d 6e 61 6d run-id "test-nam
6850: 65 3d 22 20 74 65 73 74 2d 6e 61 6d 65 29 0a 09 e=" test-name)..
6860: 20 20 20 20 20 20 20 27 28 29 29 29 29 0a 09 0a '())))...
6870: 09 28 70 72 69 6e 74 20 22 3c 74 61 62 6c 65 3e .(print "<table>
6880: 3c 74 72 3e 3c 74 64 20 76 61 6c 69 67 6e 3d 5c <tr><td valign=\
6890: 22 74 6f 70 5c 22 3e 22 29 0a 09 3b 3b 20 50 72 "top\">")..;; Pr
68a0: 69 6e 74 20 6f 75 74 20 73 74 61 74 73 20 66 6f int out stats fo
68b0: 72 20 73 74 61 74 75 73 0a 09 28 73 65 74 21 20 r status..(set!
68c0: 74 6f 74 20 30 29 0a 09 28 70 72 69 6e 74 20 22 tot 0)..(print "
68d0: 3c 74 61 62 6c 65 20 63 65 6c 6c 73 70 61 63 69 <table cellspaci
68e0: 6e 67 3d 5c 22 30 5c 22 20 62 6f 72 64 65 72 3d ng=\"0\" border=
68f0: 5c 22 31 5c 22 3e 3c 74 72 3e 3c 74 64 20 63 6f \"1\"><tr><td co
6900: 6c 73 70 61 6e 3d 5c 22 32 5c 22 3e 3c 68 32 3e lspan=\"2\"><h2>
6910: 53 74 61 74 65 20 73 74 61 74 73 3c 2f 68 32 3e State stats</h2>
6920: 3c 2f 74 64 3e 3c 2f 74 72 3e 22 29 0a 09 28 66 </td></tr>")..(f
6930: 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 or-each (lambda
6940: 28 73 74 61 74 65 29 0a 09 09 20 20 20 20 28 73 (state)... (s
6950: 65 74 21 20 74 6f 74 20 28 2b 20 74 6f 74 20 28 et! tot (+ tot (
6960: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 73 hash-table-ref s
6970: 74 61 74 65 63 6f 75 6e 74 73 20 73 74 61 74 65 tatecounts state
6980: 29 29 29 0a 09 09 20 20 20 20 28 70 72 69 6e 74 )))... (print
6990: 20 22 3c 74 72 3e 3c 74 64 3e 22 20 73 74 61 74 "<tr><td>" stat
69a0: 65 20 22 3c 2f 74 64 3e 3c 74 64 3e 22 20 28 68 e "</td><td>" (h
69b0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 73 74 ash-table-ref st
69c0: 61 74 65 63 6f 75 6e 74 73 20 73 74 61 74 65 29 atecounts state)
69d0: 20 22 3c 2f 74 64 3e 3c 2f 74 72 3e 22 29 29 0a "</td></tr>")).
69e0: 09 09 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d .. (hash-table-
69f0: 6b 65 79 73 20 73 74 61 74 65 63 6f 75 6e 74 73 keys statecounts
6a00: 29 29 0a 09 28 70 72 69 6e 74 20 22 3c 74 72 3e ))..(print "<tr>
6a10: 3c 74 64 3e 54 6f 74 61 6c 3c 2f 74 64 3e 3c 74 <td>Total</td><t
6a20: 64 3e 22 20 74 6f 74 20 22 3c 2f 74 64 3e 3c 2f d>" tot "</td></
6a30: 74 72 3e 3c 2f 74 61 62 6c 65 3e 22 29 0a 09 28 tr></table>")..(
6a40: 70 72 69 6e 74 20 22 3c 2f 74 64 3e 3c 74 64 20 print "</td><td
6a50: 76 61 6c 69 67 6e 3d 5c 22 74 6f 70 5c 22 3e 22 valign=\"top\">"
6a60: 29 0a 09 3b 3b 20 50 72 69 6e 74 20 6f 75 74 20 )..;; Print out
6a70: 73 74 61 74 73 20 66 6f 72 20 73 74 61 74 65 0a stats for state.
6a80: 09 28 73 65 74 21 20 74 6f 74 20 30 29 0a 09 28 .(set! tot 0)..(
6a90: 70 72 69 6e 74 20 22 3c 74 61 62 6c 65 20 63 65 print "<table ce
6aa0: 6c 6c 73 70 61 63 69 6e 67 3d 5c 22 30 5c 22 20 llspacing=\"0\"
6ab0: 62 6f 72 64 65 72 3d 5c 22 31 5c 22 3e 3c 74 72 border=\"1\"><tr
6ac0: 3e 3c 74 64 20 63 6f 6c 73 70 61 6e 3d 5c 22 32 ><td colspan=\"2
6ad0: 5c 22 3e 3c 68 32 3e 53 74 61 74 75 73 20 73 74 \"><h2>Status st
6ae0: 61 74 73 3c 2f 68 32 3e 3c 2f 74 64 3e 3c 2f 74 ats</h2></td></t
6af0: 72 3e 22 29 0a 09 28 66 6f 72 2d 65 61 63 68 20 r>")..(for-each
6b00: 28 6c 61 6d 62 64 61 20 28 73 74 61 74 75 73 29 (lambda (status)
6b10: 0a 09 09 20 20 20 20 28 73 65 74 21 20 74 6f 74 ... (set! tot
6b20: 20 28 2b 20 74 6f 74 20 28 68 61 73 68 2d 74 61 (+ tot (hash-ta
6b30: 62 6c 65 2d 72 65 66 20 63 6f 75 6e 74 73 20 73 ble-ref counts s
6b40: 74 61 74 75 73 29 29 29 0a 09 09 20 20 20 20 28 tatus)))... (
6b50: 70 72 69 6e 74 20 22 3c 74 72 3e 3c 74 64 3e 3c print "<tr><td><
6b60: 66 6f 6e 74 20 63 6f 6c 6f 72 3d 5c 22 22 20 28 font color=\"" (
6b70: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 6f 6c 6f 72 common:get-color
6b80: 2d 66 72 6f 6d 2d 73 74 61 74 75 73 20 73 74 61 -from-status sta
6b90: 74 75 73 29 20 22 5c 22 3e 22 20 73 74 61 74 75 tus) "\">" statu
6ba0: 73 0a 09 09 09 20 20 20 22 3c 2f 66 6f 6e 74 3e s.... "</font>
6bb0: 3c 2f 74 64 3e 3c 74 64 3e 22 20 28 68 61 73 68 </td><td>" (hash
6bc0: 2d 74 61 62 6c 65 2d 72 65 66 20 63 6f 75 6e 74 -table-ref count
6bd0: 73 20 73 74 61 74 75 73 29 20 22 3c 2f 74 64 3e s status) "</td>
6be0: 3c 2f 74 72 3e 22 29 29 0a 09 09 20 20 28 68 61 </tr>"))... (ha
6bf0: 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 63 6f sh-table-keys co
6c00: 75 6e 74 73 29 29 0a 09 28 70 72 69 6e 74 20 22 unts))..(print "
6c10: 3c 74 72 3e 3c 74 64 3e 54 6f 74 61 6c 3c 2f 74 <tr><td>Total</t
6c20: 64 3e 3c 74 64 3e 22 20 74 6f 74 20 22 3c 2f 74 d><td>" tot "</t
6c30: 64 3e 3c 2f 74 72 3e 3c 2f 74 61 62 6c 65 3e 22 d></tr></table>"
6c40: 29 0a 09 28 70 72 69 6e 74 20 22 3c 2f 74 64 3e )..(print "</td>
6c50: 3c 2f 74 64 3e 3c 2f 74 72 3e 3c 2f 74 61 62 6c </td></tr></tabl
6c60: 65 3e 22 29 0a 09 0a 09 28 70 72 69 6e 74 20 22 e>")....(print "
6c70: 3c 74 61 62 6c 65 20 63 65 6c 6c 73 70 61 63 69 <table cellspaci
6c80: 6e 67 3d 5c 22 30 5c 22 20 62 6f 72 64 65 72 3d ng=\"0\" border=
6c90: 5c 22 31 5c 22 3e 22 20 0a 09 20 20 20 20 20 20 \"1\">" ..
6ca0: 20 22 3c 74 72 3e 3c 74 64 3e 49 74 65 6d 3c 2f "<tr><td>Item</
6cb0: 74 64 3e 3c 74 64 3e 53 74 61 74 65 3c 2f 74 64 td><td>State</td
6cc0: 3e 3c 74 64 3e 53 74 61 74 75 73 3c 2f 74 64 3e ><td>Status</td>
6cd0: 3c 74 64 3e 43 6f 6d 6d 65 6e 74 3c 2f 74 64 3e <td>Comment</td>
6ce0: 22 0a 09 20 20 20 20 20 20 20 6f 75 74 74 78 74 ".. outtxt
6cf0: 20 22 3c 2f 74 61 62 6c 65 3e 3c 2f 62 6f 64 79 "</table></body
6d00: 3e 3c 2f 68 74 6d 6c 3e 22 29 0a 09 3b 3b 20 28 ></html>")..;; (
6d10: 72 65 6c 65 61 73 65 2d 64 6f 74 2d 6c 6f 63 6b release-dot-lock
6d20: 20 6f 75 74 70 75 74 66 69 6c 65 6e 61 6d 65 29 outputfilename)
6d30: 0a 09 3b 3b 28 72 6d 74 3a 75 70 64 61 74 65 2d ..;;(rmt:update-
6d40: 72 75 6e 2d 73 74 61 74 73 20 0a 09 3b 3b 20 72 run-stats ..;; r
6d50: 75 6e 2d 69 64 0a 09 3b 3b 20 28 68 61 73 68 2d un-id..;; (hash-
6d60: 74 61 62 6c 65 2d 6d 61 70 0a 09 3b 3b 20 20 73 table-map..;; s
6d70: 74 61 74 65 2d 73 74 61 74 75 73 2d 63 6f 75 6e tate-status-coun
6d80: 74 73 0a 09 3b 3b 20 20 28 6c 61 6d 62 64 61 20 ts..;; (lambda
6d90: 28 6b 65 79 20 76 61 6c 29 0a 09 3b 3b 09 28 61 (key val)..;;.(a
6da0: 70 70 65 6e 64 20 6b 65 79 20 28 6c 69 73 74 20 ppend key (list
6db0: 76 61 6c 29 29 29 29 29 0a 09 29 29 29 29 0a 0a val)))))..))))..
6dc0: 28 64 65 66 69 6e 65 20 74 65 73 74 73 3a 63 73 (define tests:cs
6dd0: 73 2d 6a 73 63 72 69 70 74 2d 62 6c 6f 63 6b 0a s-jscript-block.
6de0: 23 3c 3c 45 4f 46 0a 3c 73 74 79 6c 65 20 74 79 #<<EOF.<style ty
6df0: 70 65 3d 22 74 65 78 74 2f 63 73 73 22 3e 0a 75 pe="text/css">.u
6e00: 6c 2e 4c 69 6e 6b 65 64 4c 69 73 74 20 7b 20 64 l.LinkedList { d
6e10: 69 73 70 6c 61 79 3a 20 62 6c 6f 63 6b 3b 20 7d isplay: block; }
6e20: 0a 2f 2a 20 75 6c 2e 4c 69 6e 6b 65 64 4c 69 73 ./* ul.LinkedLis
6e30: 74 20 75 6c 20 7b 20 64 69 73 70 6c 61 79 3a 20 t ul { display:
6e40: 6e 6f 6e 65 3b 20 7d 20 2a 2f 0a 2e 48 61 6e 64 none; } */..Hand
6e50: 43 75 72 73 6f 72 53 74 79 6c 65 20 7b 20 63 75 CursorStyle { cu
6e60: 72 73 6f 72 3a 20 70 6f 69 6e 74 65 72 3b 20 63 rsor: pointer; c
6e70: 75 72 73 6f 72 3a 20 68 61 6e 64 3b 20 7d 20 20 ursor: hand; }
6e80: 2f 2a 20 46 6f 72 20 49 45 20 2a 2f 0a 74 68 20 /* For IE */.th
6e90: 7b 62 61 63 6b 67 72 6f 75 6e 64 2d 63 6f 6c 6f {background-colo
6ea0: 72 3a 20 23 38 63 38 63 38 63 3b 7d 0a 74 64 2e r: #8c8c8c;}.td.
6eb0: 74 65 73 74 20 7b 62 61 63 6b 67 72 6f 75 6e 64 test {background
6ec0: 2d 63 6f 6c 6f 72 3a 20 23 64 39 64 62 64 64 3b -color: #d9dbdd;
6ed0: 7d 0a 74 64 2e 50 41 53 53 20 7b 62 61 63 6b 67 }.td.PASS {backg
6ee0: 72 6f 75 6e 64 2d 63 6f 6c 6f 72 3a 20 23 33 34 round-color: #34
6ef0: 37 35 33 33 3b 7d 0a 74 64 2e 46 41 49 4c 20 7b 7533;}.td.FAIL {
6f00: 62 61 63 6b 67 72 6f 75 6e 64 2d 63 6f 6c 6f 72 background-color
6f10: 3a 20 23 63 63 32 38 31 32 3b 7d 0a 74 64 2e 53 : #cc2812;}.td.S
6f20: 4b 49 50 7b 62 61 63 6b 67 72 6f 75 6e 64 2d 63 KIP{background-c
6f30: 6f 6c 6f 72 3a 20 23 46 46 44 37 33 33 3b 7d 0a olor: #FFD733;}.
6f40: 74 64 2e 57 41 52 4e 20 7b 62 61 63 6b 67 72 6f td.WARN {backgro
6f50: 75 6e 64 2d 63 6f 6c 6f 72 3a 20 23 45 41 38 37 und-color: #EA87
6f60: 32 34 3b 7d 0a 74 64 2e 57 41 49 56 45 44 20 7b 24;}.td.WAIVED {
6f70: 62 61 63 6b 67 72 6f 75 6e 64 2d 63 6f 6c 6f 72 background-color
6f80: 3a 20 23 38 33 38 41 31 32 3b 7d 0a 74 64 2e 41 : #838A12;}.td.A
6f90: 42 4f 52 54 7b 62 61 63 6b 67 72 6f 75 6e 64 2d BORT{background-
6fa0: 63 6f 6c 6f 72 3a 20 23 45 41 32 34 42 37 3b 7d color: #EA24B7;}
6fb0: 0a 2e 50 41 53 53 20 2e 6c 69 6e 6b 2c 20 2e 53 ..PASS .link, .S
6fc0: 4b 49 50 20 2e 6c 69 6e 6b 2c 20 2e 57 41 52 4e KIP .link, .WARN
6fd0: 20 2e 6c 69 6e 6b 2c 2e 57 41 49 56 45 44 20 2e .link,.WAIVED .
6fe0: 6c 69 6e 6b 2c 2e 41 42 4f 52 54 20 2e 6c 69 6e link,.ABORT .lin
6ff0: 6b 2c 20 2e 46 41 49 4c 20 2e 6c 69 6e 6b 7b 63 k, .FAIL .link{c
7000: 6f 6c 6f 72 3a 20 23 46 46 46 46 46 46 3b 7d 0a olor: #FFFFFF;}.
7010: 0a 0a 3c 2f 73 74 79 6c 65 3e 0a 0a 0a 20 20 3c ..</style>... <
7020: 73 63 72 69 70 74 20 74 79 70 65 3d 22 74 65 78 script type="tex
7030: 74 2f 4a 61 76 61 53 63 72 69 70 74 22 3e 0a 0a t/JavaScript">..
7040: 20 20 20 20 66 75 6e 63 74 69 6f 6e 20 66 69 6c function fil
7050: 74 65 72 73 6f 6d 65 28 29 20 7b 0a 20 20 24 28 tersome() {. $(
7060: 22 74 72 22 29 2e 73 68 6f 77 28 29 3b 0a 20 20 "tr").show();.
7070: 24 28 22 2e 74 65 73 74 22 29 2e 66 69 6c 74 65 $(".test").filte
7080: 72 28 0a 20 20 20 20 66 75 6e 63 74 69 6f 6e 28 r(. function(
7090: 29 20 7b 0a 20 20 20 20 20 20 76 61 72 20 6e 61 ) {. var na
70a0: 6d 65 73 20 3d 20 24 28 27 23 74 65 73 74 6e 61 mes = $('#testna
70b0: 6d 65 27 29 2e 76 61 6c 28 29 2e 73 70 6c 69 74 me').val().split
70c0: 28 27 2c 27 29 3b 0a 20 20 20 20 20 20 76 61 72 (',');. var
70d0: 20 67 6f 6f 64 3d 31 3b 0a 20 20 20 20 20 20 66 good=1;. f
70e0: 6f 72 20 28 76 61 72 20 69 3d 30 2c 20 6c 65 6e or (var i=0, len
70f0: 3d 6e 61 6d 65 73 2e 6c 65 6e 67 74 68 3b 20 69 =names.length; i
7100: 3c 6c 65 6e 3b 20 69 2b 2b 29 20 7b 0a 20 20 20 <len; i++) {.
7110: 20 20 20 20 20 76 61 72 20 75 6e 61 6d 65 3d 6e var uname=n
7120: 61 6d 65 73 5b 69 5d 3b 0a 20 20 20 20 20 20 20 ames[i];.
7130: 20 63 6f 6e 73 6f 6c 65 2e 6c 6f 67 28 22 54 72 console.log("Tr
7140: 79 69 6e 67 20 74 6f 20 63 68 65 63 6b 20 66 6f ying to check fo
7150: 72 20 22 20 2b 20 75 6e 61 6d 65 29 3b 20 0a 20 r " + uname); .
7160: 20 20 20 20 20 20 20 69 66 28 24 28 74 68 69 73 if($(this
7170: 29 2e 74 65 78 74 28 29 2e 69 6e 64 65 78 4f 66 ).text().indexOf
7180: 28 75 6e 61 6d 65 29 20 21 3d 20 2d 31 29 20 7b (uname) != -1) {
7190: 0a 20 20 20 20 20 20 20 20 20 20 67 6f 6f 64 3d . good=
71a0: 20 30 3b 0a 20 20 20 20 20 20 20 20 20 20 63 6f 0;. co
71b0: 6e 73 6f 6c 65 2e 6c 6f 67 28 22 46 6f 75 6e 64 nsole.log("Found
71c0: 20 22 2b 75 6e 61 6d 65 29 3b 0a 20 20 20 20 20 "+uname);.
71d0: 20 20 20 7d 0a 20 20 20 20 20 20 7d 0a 20 20 20 }. }.
71e0: 20 20 20 72 65 74 75 72 6e 20 67 6f 6f 64 3b 20 return good;
71f0: 0a 20 20 20 20 7d 0a 20 20 29 2e 70 61 72 65 6e . }. ).paren
7200: 74 28 29 2e 68 69 64 65 28 29 3b 0a 2f 2f 20 20 t().hide();.//
7210: 24 28 22 2e 73 75 6d 22 29 2e 73 68 6f 77 28 29 $(".sum").show()
7220: 3b 0a 7d 0a 20 20 0a 20 20 20 20 2f 2f 20 41 64 ;.}. . // Ad
7230: 64 20 74 68 69 73 20 74 6f 20 74 68 65 20 6f 6e d this to the on
7240: 6c 6f 61 64 20 65 76 65 6e 74 20 6f 66 20 74 68 load event of th
7250: 65 20 42 4f 44 59 20 65 6c 65 6d 65 6e 74 0a 20 e BODY element.
7260: 20 20 20 66 75 6e 63 74 69 6f 6e 20 61 64 64 45 function addE
7270: 76 65 6e 74 73 28 29 20 7b 0a 20 20 20 20 20 20 vents() {.
7280: 61 63 74 69 76 61 74 65 54 72 65 65 28 64 6f 63 activateTree(doc
7290: 75 6d 65 6e 74 2e 67 65 74 45 6c 65 6d 65 6e 74 ument.getElement
72a0: 42 79 49 64 28 22 4c 69 6e 6b 65 64 4c 69 73 74 ById("LinkedList
72b0: 31 22 29 29 3b 0a 20 20 20 20 7d 0a 0a 20 20 20 1"));. }..
72c0: 20 2f 2f 20 54 68 69 73 20 66 75 6e 63 74 69 6f // This functio
72d0: 6e 20 74 72 61 76 65 72 73 65 73 20 74 68 65 20 n traverses the
72e0: 6c 69 73 74 20 61 6e 64 20 61 64 64 20 6c 69 6e list and add lin
72f0: 6b 73 20 0a 20 20 20 20 2f 2f 20 74 6f 20 6e 65 ks . // to ne
7300: 73 74 65 64 20 6c 69 73 74 20 69 74 65 6d 73 0a sted list items.
7310: 20 20 20 20 66 75 6e 63 74 69 6f 6e 20 61 63 74 function act
7320: 69 76 61 74 65 54 72 65 65 28 6f 4c 69 73 74 29 ivateTree(oList)
7330: 20 7b 0a 20 20 20 20 20 20 2f 2f 20 43 6f 6c 6c {. // Coll
7340: 61 70 73 65 20 74 68 65 20 74 72 65 65 0a 20 20 apse the tree.
7350: 20 20 20 20 66 6f 72 20 28 76 61 72 20 69 3d 30 for (var i=0
7360: 3b 20 69 20 3c 20 6f 4c 69 73 74 2e 67 65 74 45 ; i < oList.getE
7370: 6c 65 6d 65 6e 74 73 42 79 54 61 67 4e 61 6d 65 lementsByTagName
7380: 28 22 75 6c 22 29 2e 6c 65 6e 67 74 68 3b 20 69 ("ul").length; i
7390: 2b 2b 29 20 7b 0a 20 20 20 20 20 20 20 20 6f 4c ++) {. oL
73a0: 69 73 74 2e 67 65 74 45 6c 65 6d 65 6e 74 73 42 ist.getElementsB
73b0: 79 54 61 67 4e 61 6d 65 28 22 75 6c 22 29 5b 69 yTagName("ul")[i
73c0: 5d 2e 73 74 79 6c 65 2e 64 69 73 70 6c 61 79 3d ].style.display=
73d0: 22 6e 6f 6e 65 22 3b 20 20 20 20 20 20 20 20 20 "none";
73e0: 20 20 20 0a 20 20 20 20 20 20 7d 20 20 20 20 20 . }
73f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7400: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7410: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7420: 20 20 20 20 20 20 20 20 20 20 20 20 20 0a 20 20 .
7430: 20 20 20 20 2f 2f 20 41 64 64 20 74 68 65 20 63 // Add the c
7440: 6c 69 63 6b 2d 65 76 65 6e 74 20 68 61 6e 64 6c lick-event handl
7450: 65 72 20 74 6f 20 74 68 65 20 6c 69 73 74 20 69 er to the list i
7460: 74 65 6d 73 0a 20 20 20 20 20 20 69 66 20 28 6f tems. if (o
7470: 4c 69 73 74 2e 61 64 64 45 76 65 6e 74 4c 69 73 List.addEventLis
7480: 74 65 6e 65 72 29 20 7b 0a 20 20 20 20 20 20 20 tener) {.
7490: 20 6f 4c 69 73 74 2e 61 64 64 45 76 65 6e 74 4c oList.addEventL
74a0: 69 73 74 65 6e 65 72 28 22 63 6c 69 63 6b 22 2c istener("click",
74b0: 20 74 6f 67 67 6c 65 42 72 61 6e 63 68 2c 20 66 toggleBranch, f
74c0: 61 6c 73 65 29 3b 0a 20 20 20 20 20 20 7d 20 65 alse);. } e
74d0: 6c 73 65 20 69 66 20 28 6f 4c 69 73 74 2e 61 74 lse if (oList.at
74e0: 74 61 63 68 45 76 65 6e 74 29 20 7b 20 2f 2f 20 tachEvent) { //
74f0: 46 6f 72 20 49 45 0a 20 20 20 20 20 20 20 20 6f For IE. o
7500: 4c 69 73 74 2e 61 74 74 61 63 68 45 76 65 6e 74 List.attachEvent
7510: 28 22 6f 6e 63 6c 69 63 6b 22 2c 20 74 6f 67 67 ("onclick", togg
7520: 6c 65 42 72 61 6e 63 68 29 3b 0a 20 20 20 20 20 leBranch);.
7530: 20 7d 0a 20 20 20 20 20 20 2f 2f 20 4d 61 6b 65 }. // Make
7540: 20 74 68 65 20 6e 65 73 74 65 64 20 69 74 65 6d the nested item
7550: 73 20 6c 6f 6f 6b 20 6c 69 6b 65 20 6c 69 6e 6b s look like link
7560: 73 0a 20 20 20 20 20 20 61 64 64 4c 69 6e 6b 73 s. addLinks
7570: 54 6f 42 72 61 6e 63 68 65 73 28 6f 4c 69 73 74 ToBranches(oList
7580: 29 3b 0a 20 20 20 20 7d 0a 0a 20 20 20 20 2f 2f );. }.. //
7590: 20 54 68 69 73 20 69 73 20 74 68 65 20 63 6c 69 This is the cli
75a0: 63 6b 2d 65 76 65 6e 74 20 68 61 6e 64 6c 65 72 ck-event handler
75b0: 0a 20 20 20 20 66 75 6e 63 74 69 6f 6e 20 74 6f . function to
75c0: 67 67 6c 65 42 72 61 6e 63 68 28 65 76 65 6e 74 ggleBranch(event
75d0: 29 20 7b 0a 20 20 20 20 20 20 76 61 72 20 6f 42 ) {. var oB
75e0: 72 61 6e 63 68 2c 20 63 53 75 62 42 72 61 6e 63 ranch, cSubBranc
75f0: 68 65 73 3b 0a 20 20 20 20 20 20 69 66 20 28 65 hes;. if (e
7600: 76 65 6e 74 2e 74 61 72 67 65 74 29 20 7b 0a 20 vent.target) {.
7610: 20 20 20 20 20 20 20 6f 42 72 61 6e 63 68 20 3d oBranch =
7620: 20 65 76 65 6e 74 2e 74 61 72 67 65 74 3b 0a 20 event.target;.
7630: 20 20 20 20 20 7d 20 65 6c 73 65 20 69 66 20 28 } else if (
7640: 65 76 65 6e 74 2e 73 72 63 45 6c 65 6d 65 6e 74 event.srcElement
7650: 29 20 7b 20 2f 2f 20 46 6f 72 20 49 45 0a 20 20 ) { // For IE.
7660: 20 20 20 20 20 20 6f 42 72 61 6e 63 68 20 3d 20 oBranch =
7670: 65 76 65 6e 74 2e 73 72 63 45 6c 65 6d 65 6e 74 event.srcElement
7680: 3b 0a 20 20 20 20 20 20 7d 0a 20 20 20 20 20 20 ;. }.
7690: 63 53 75 62 42 72 61 6e 63 68 65 73 20 3d 20 6f cSubBranches = o
76a0: 42 72 61 6e 63 68 2e 67 65 74 45 6c 65 6d 65 6e Branch.getElemen
76b0: 74 73 42 79 54 61 67 4e 61 6d 65 28 22 75 6c 22 tsByTagName("ul"
76c0: 29 3b 0a 20 20 20 20 20 20 69 66 20 28 63 53 75 );. if (cSu
76d0: 62 42 72 61 6e 63 68 65 73 2e 6c 65 6e 67 74 68 bBranches.length
76e0: 20 3e 20 30 29 20 7b 0a 20 20 20 20 20 20 20 20 > 0) {.
76f0: 69 66 20 28 63 53 75 62 42 72 61 6e 63 68 65 73 if (cSubBranches
7700: 5b 30 5d 2e 73 74 79 6c 65 2e 64 69 73 70 6c 61 [0].style.displa
7710: 79 20 3d 3d 20 22 62 6c 6f 63 6b 22 29 20 7b 0a y == "block") {.
7720: 20 20 20 20 20 20 20 20 20 20 63 53 75 62 42 72 cSubBr
7730: 61 6e 63 68 65 73 5b 30 5d 2e 73 74 79 6c 65 2e anches[0].style.
7740: 64 69 73 70 6c 61 79 20 3d 20 22 6e 6f 6e 65 22 display = "none"
7750: 3b 0a 20 20 20 20 20 20 20 20 7d 20 65 6c 73 65 ;. } else
7760: 20 7b 0a 20 20 20 20 20 20 20 20 20 20 63 53 75 {. cSu
7770: 62 42 72 61 6e 63 68 65 73 5b 30 5d 2e 73 74 79 bBranches[0].sty
7780: 6c 65 2e 64 69 73 70 6c 61 79 20 3d 20 22 62 6c le.display = "bl
7790: 6f 63 6b 22 3b 0a 20 20 20 20 20 20 20 20 7d 0a ock";. }.
77a0: 20 20 20 20 20 20 7d 0a 20 20 20 20 7d 0a 0a 20 }. }..
77b0: 20 20 20 2f 2f 20 54 68 69 73 20 66 75 6e 63 74 // This funct
77c0: 69 6f 6e 20 6d 61 6b 65 73 20 6e 65 73 74 65 64 ion makes nested
77d0: 20 6c 69 73 74 20 69 74 65 6d 73 20 6c 6f 6f 6b list items look
77e0: 20 6c 69 6b 65 20 6c 69 6e 6b 73 0a 20 20 20 20 like links.
77f0: 66 75 6e 63 74 69 6f 6e 20 61 64 64 4c 69 6e 6b function addLink
7800: 73 54 6f 42 72 61 6e 63 68 65 73 28 6f 4c 69 73 sToBranches(oLis
7810: 74 29 20 7b 0a 20 20 20 20 20 20 76 61 72 20 63 t) {. var c
7820: 42 72 61 6e 63 68 65 73 20 3d 20 6f 4c 69 73 74 Branches = oList
7830: 2e 67 65 74 45 6c 65 6d 65 6e 74 73 42 79 54 61 .getElementsByTa
7840: 67 4e 61 6d 65 28 22 6c 69 22 29 3b 0a 20 20 20 gName("li");.
7850: 20 20 20 76 61 72 20 69 2c 20 6e 2c 20 63 53 75 var i, n, cSu
7860: 62 42 72 61 6e 63 68 65 73 3b 0a 20 20 20 20 20 bBranches;.
7870: 20 69 66 20 28 63 42 72 61 6e 63 68 65 73 2e 6c if (cBranches.l
7880: 65 6e 67 74 68 20 3e 20 30 29 20 7b 0a 20 20 20 ength > 0) {.
7890: 20 20 20 20 20 66 6f 72 20 28 69 3d 30 2c 20 6e for (i=0, n
78a0: 20 3d 20 63 42 72 61 6e 63 68 65 73 2e 6c 65 6e = cBranches.len
78b0: 67 74 68 3b 20 69 20 3c 20 6e 3b 20 69 2b 2b 29 gth; i < n; i++)
78c0: 20 7b 0a 20 20 20 20 20 20 20 20 20 20 63 53 75 {. cSu
78d0: 62 42 72 61 6e 63 68 65 73 20 3d 20 63 42 72 61 bBranches = cBra
78e0: 6e 63 68 65 73 5b 69 5d 2e 67 65 74 45 6c 65 6d nches[i].getElem
78f0: 65 6e 74 73 42 79 54 61 67 4e 61 6d 65 28 22 75 entsByTagName("u
7900: 6c 22 29 3b 0a 20 20 20 20 20 20 20 20 20 20 69 l");. i
7910: 66 20 28 63 53 75 62 42 72 61 6e 63 68 65 73 2e f (cSubBranches.
7920: 6c 65 6e 67 74 68 20 3e 20 30 29 20 7b 0a 20 20 length > 0) {.
7930: 20 20 20 20 20 20 20 20 20 20 61 64 64 4c 69 6e addLin
7940: 6b 73 54 6f 42 72 61 6e 63 68 65 73 28 63 53 75 ksToBranches(cSu
7950: 62 42 72 61 6e 63 68 65 73 5b 30 5d 29 3b 0a 20 bBranches[0]);.
7960: 20 20 20 20 20 20 20 20 20 20 20 63 42 72 61 6e cBran
7970: 63 68 65 73 5b 69 5d 2e 63 6c 61 73 73 4e 61 6d ches[i].classNam
7980: 65 20 3d 20 22 48 61 6e 64 43 75 72 73 6f 72 53 e = "HandCursorS
7990: 74 79 6c 65 22 3b 0a 20 20 20 20 20 20 20 20 20 tyle";.
79a0: 20 20 20 63 42 72 61 6e 63 68 65 73 5b 69 5d 2e cBranches[i].
79b0: 73 74 79 6c 65 2e 63 6f 6c 6f 72 20 3d 20 22 62 style.color = "b
79c0: 6c 75 65 22 3b 0a 20 20 20 20 20 20 20 20 20 20 lue";.
79d0: 20 20 63 53 75 62 42 72 61 6e 63 68 65 73 5b 30 cSubBranches[0
79e0: 5d 2e 73 74 79 6c 65 2e 63 6f 6c 6f 72 20 3d 20 ].style.color =
79f0: 22 62 6c 61 63 6b 22 3b 0a 20 20 20 20 20 20 20 "black";.
7a00: 20 20 20 20 20 63 53 75 62 42 72 61 6e 63 68 65 cSubBranche
7a10: 73 5b 30 5d 2e 73 74 79 6c 65 2e 63 75 72 73 6f s[0].style.curso
7a20: 72 20 3d 20 22 61 75 74 6f 22 3b 0a 20 20 20 20 r = "auto";.
7a30: 20 20 20 20 20 20 7d 0a 20 20 20 20 20 20 20 20 }.
7a40: 7d 0a 20 20 20 20 20 20 7d 0a 20 20 20 20 7d 0a }. }. }.
7a50: 20 20 3c 2f 73 63 72 69 70 74 3e 0a 45 4f 46 0a </script>.EOF.
7a60: 29 0a 0a 28 64 65 66 69 6e 65 20 74 65 73 74 73 )..(define tests
7a70: 3a 63 73 73 2d 6a 73 63 72 69 70 74 2d 62 6c 6f :css-jscript-blo
7a80: 63 6b 2d 64 79 6e 61 6d 69 63 20 0a 23 3c 3c 45 ck-dynamic .#<<E
7a90: 4f 46 0a 20 20 20 20 20 20 20 20 20 20 20 3c 73 OF. <s
7aa0: 63 72 69 70 74 20 73 72 63 3d 20 2e 2f 6a 71 75 cript src= ./jqu
7ab0: 65 72 79 33 2e 31 2e 30 2e 6a 73 3e 3c 2f 73 63 ery3.1.0.js></sc
7ac0: 72 69 70 74 3e 20 0a 45 4f 46 0a 29 0a 0a 28 64 ript> .EOF.)..(d
7ad0: 65 66 69 6e 65 20 20 28 74 65 73 74 3a 6a 73 2d efine (test:js-
7ae0: 62 6c 6f 63 6b 20 6a 61 76 61 73 63 72 69 70 74 block javascript
7af0: 2d 6c 69 62 29 0a 20 20 20 28 63 6f 6e 63 20 20 -lib). (conc
7b00: 22 3c 73 63 72 69 70 74 20 73 72 63 3d 22 20 6a "<script src=" j
7b10: 61 76 61 73 63 72 69 70 74 2d 6c 69 62 20 22 3e avascript-lib ">
7b20: 3c 2f 73 63 72 69 70 74 3e 22 20 29 29 0a 0a 0a </script>" ))...
7b30: 28 64 65 66 69 6e 65 20 74 65 73 74 73 3a 63 73 (define tests:cs
7b40: 73 2d 6a 73 63 72 69 70 74 2d 62 6c 6f 63 6b 2d s-jscript-block-
7b50: 73 74 61 74 69 63 20 28 74 65 73 74 3a 6a 73 2d static (test:js-
7b60: 62 6c 6f 63 6b 20 2a 6a 61 76 61 2d 73 63 72 69 block *java-scri
7b70: 70 74 2d 6c 69 62 2a 29 29 0a 0a 28 64 65 66 69 pt-lib*))..(defi
7b80: 6e 65 20 28 74 65 73 74 73 3a 63 73 73 2d 6a 73 ne (tests:css-js
7b90: 63 72 69 70 74 2d 62 6c 6f 63 6b 2d 63 6f 6e 64 cript-block-cond
7ba0: 20 64 79 6e 61 6d 69 63 29 20 0a 20 20 20 20 20 dynamic) .
7bb0: 20 28 69 66 20 28 65 71 75 61 6c 3f 20 64 79 6e (if (equal? dyn
7bc0: 61 6d 69 63 20 20 23 74 29 0a 20 20 20 20 20 20 amic #t).
7bd0: 20 74 65 73 74 73 3a 63 73 73 2d 6a 73 63 72 69 tests:css-jscri
7be0: 70 74 2d 62 6c 6f 63 6b 2d 64 79 6e 61 6d 69 63 pt-block-dynamic
7bf0: 0a 20 20 20 20 20 20 20 74 65 73 74 73 3a 63 73 . tests:cs
7c00: 73 2d 6a 73 63 72 69 70 74 2d 62 6c 6f 63 6b 2d s-jscript-block-
7c10: 73 74 61 74 69 63 29 29 0a 0a 20 20 20 20 20 20 static))..
7c20: 20 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 .(define (tests
7c30: 3a 72 75 6e 2d 72 65 63 6f 72 64 2d 3e 74 65 73 :run-record->tes
7c40: 74 2d 70 61 74 68 20 72 75 6e 20 6e 75 6d 6b 65 t-path run numke
7c50: 79 73 29 0a 20 20 20 28 61 70 70 65 6e 64 20 28 ys). (append (
7c60: 74 61 6b 65 20 28 76 65 63 74 6f 72 2d 3e 6c 69 take (vector->li
7c70: 73 74 20 72 75 6e 29 20 6e 75 6d 6b 65 79 73 29 st run) numkeys)
7c80: 0a 09 20 20 20 28 6c 69 73 74 20 28 76 65 63 74 .. (list (vect
7c90: 6f 72 2d 72 65 66 20 72 75 6e 20 28 2b 20 31 20 or-ref run (+ 1
7ca0: 6e 75 6d 6b 65 79 73 29 29 29 29 29 0a 0a 0a 28 numkeys)))))...(
7cb0: 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 67 65 define (tests:ge
7cc0: 74 2d 72 65 73 74 2d 64 61 74 61 20 72 75 6e 73 t-rest-data runs
7cd0: 20 68 65 61 64 65 72 20 6e 75 6d 6b 65 79 73 29 header numkeys)
7ce0: 0a 20 20 20 28 6c 65 74 20 28 28 72 65 73 68 20 . (let ((resh
7cf0: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
7d00: 29 29 29 0a 20 20 20 28 66 6f 72 2d 65 61 63 68 ))). (for-each
7d10: 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 72 . (lambda (r
7d20: 75 6e 29 0a 20 20 20 20 20 20 20 20 28 6c 65 74 un). (let
7d30: 2a 20 28 28 72 75 6e 2d 69 64 20 28 64 62 3a 67 * ((run-id (db:g
7d40: 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 et-value-by-head
7d50: 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 69 er run header "i
7d60: 64 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 d")).
7d70: 20 20 20 20 28 72 75 6e 2d 64 69 72 20 20 20 20 (run-dir
7d80: 20 20 28 74 65 73 74 73 3a 72 75 6e 2d 72 65 63 (tests:run-rec
7d90: 6f 72 64 2d 3e 74 65 73 74 2d 70 61 74 68 20 72 ord->test-path r
7da0: 75 6e 20 6e 75 6d 6b 65 79 73 29 29 0a 09 20 20 un numkeys))..
7db0: 20 20 20 20 20 28 74 65 73 74 2d 64 61 74 61 20 (test-data
7dc0: 20 20 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 (rmt:get-test
7dd0: 73 2d 66 6f 72 2d 72 75 6e 0a 09 09 09 09 20 20 s-for-run.....
7de0: 20 72 75 6e 2d 69 64 0a 20 20 20 20 20 20 20 20 run-id.
7df0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7e00: 20 20 20 20 20 20 20 20 20 20 20 22 25 22 20 20 "%"
7e10: 20 20 20 20 20 3b 3b 20 74 65 73 74 6e 61 6d 65 ;; testname
7e20: 70 61 74 74 0a 09 09 09 09 20 20 20 27 28 29 20 patt..... '()
7e30: 20 20 20 20 20 20 20 3b 3b 20 73 74 61 74 65 73 ;; states
7e40: 0a 09 09 09 09 20 20 20 27 28 29 20 20 20 20 20 ..... '()
7e50: 20 20 20 3b 3b 20 73 74 61 74 75 73 65 73 0a 09 ;; statuses..
7e60: 09 09 09 20 20 20 23 66 20 20 20 20 20 20 20 20 ... #f
7e70: 20 3b 3b 20 6f 66 66 73 65 74 0a 09 09 09 09 20 ;; offset.....
7e80: 20 20 23 66 20 20 20 20 20 20 20 20 20 3b 3b 20 #f ;;
7e90: 6e 75 6d 2d 74 6f 2d 67 65 74 0a 09 09 09 09 20 num-to-get.....
7ea0: 20 20 23 66 20 20 20 20 20 20 20 20 20 3b 3b 20 #f ;;
7eb0: 68 69 64 65 2f 6e 6f 74 2d 68 69 64 65 0a 09 09 hide/not-hide...
7ec0: 09 09 20 20 20 23 66 20 20 20 20 20 20 20 20 20 .. #f
7ed0: 3b 3b 20 73 6f 72 74 2d 62 79 0a 09 09 09 09 20 ;; sort-by.....
7ee0: 20 20 23 66 20 20 20 20 20 20 20 20 20 3b 3b 20 #f ;;
7ef0: 73 6f 72 74 2d 6f 72 64 65 72 0a 09 09 09 09 20 sort-order.....
7f00: 20 20 23 66 20 20 20 20 20 20 20 20 20 3b 3b 20 #f ;;
7f10: 27 73 68 6f 72 74 6c 69 73 74 20 20 20 20 20 20 'shortlist
7f20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7f30: 20 20 20 20 20 3b 3b 20 71 72 79 74 79 70 65 0a ;; qrytype.
7f40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7f50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7f60: 20 20 20 30 20 20 20 20 20 20 20 20 20 3b 3b 20 0 ;;
7f70: 6c 61 73 74 20 75 70 64 61 74 65 0a 09 09 09 09 last update.....
7f80: 20 20 20 23 66 29 29 29 0a 20 20 20 20 20 20 20 #f))).
7f90: 20 20 20 20 20 0a 20 20 20 20 20 20 20 20 20 20 .
7fa0: 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 (map (lambda (
7fb0: 74 65 73 74 29 0a 20 20 20 20 20 20 20 20 20 20 test).
7fc0: 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 (let* ((t
7fd0: 65 73 74 2d 6e 61 6d 65 20 28 76 65 63 74 6f 72 est-name (vector
7fe0: 2d 72 65 66 20 74 65 73 74 20 32 29 29 0a 20 20 -ref test 2)).
7ff0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8000: 20 20 20 20 20 20 28 74 65 73 74 2d 68 74 6d 6c (test-html
8010: 2d 70 61 74 68 20 28 63 6f 6e 63 20 28 76 65 63 -path (conc (vec
8020: 74 6f 72 2d 72 65 66 20 74 65 73 74 20 31 30 29 tor-ref test 10)
8030: 20 22 2f 22 20 28 76 65 63 74 6f 72 2d 72 65 66 "/" (vector-ref
8040: 20 74 65 73 74 20 31 33 29 29 29 0a 20 20 20 20 test 13))).
8050: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8060: 20 20 20 20 28 74 65 73 74 2d 69 74 65 6d 20 28 (test-item (
8070: 63 6f 6e 63 20 74 65 73 74 2d 6e 61 6d 65 20 22 conc test-name "
8080: 3a 22 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 :" (vector-ref t
8090: 65 73 74 20 31 31 29 29 29 0a 20 20 20 20 20 20 est 11))).
80a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
80b0: 20 20 28 74 65 73 74 2d 73 74 61 74 75 73 20 28 (test-status (
80c0: 76 65 63 74 6f 72 2d 72 65 66 20 74 65 73 74 20 vector-ref test
80d0: 34 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 4))).
80e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0a 20 .
80f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
8100: 69 66 20 28 6e 6f 74 20 28 68 61 73 68 2d 74 61 if (not (hash-ta
8110: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
8120: 72 65 73 68 20 74 65 73 74 2d 6e 61 6d 65 20 20 resh test-name
8130: 23 66 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 #f)).
8140: 20 20 20 20 20 20 20 20 20 20 20 28 68 61 73 68 (hash
8150: 2d 74 61 62 6c 65 2d 73 65 74 21 20 72 65 73 68 -table-set! resh
8160: 20 74 65 73 74 2d 6e 61 6d 65 20 20 20 28 6d 61 test-name (ma
8170: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 ke-hash-table)))
8180: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
8190: 20 28 69 66 20 28 6e 6f 74 20 28 68 61 73 68 2d (if (not (hash-
81a0: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
81b0: 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 t (hash-table-re
81c0: 66 2f 64 65 66 61 75 6c 74 20 72 65 73 68 20 74 f/default resh t
81d0: 65 73 74 2d 6e 61 6d 65 20 20 23 66 29 20 20 74 est-name #f) t
81e0: 65 73 74 2d 69 74 65 6d 20 20 23 66 29 29 0a 20 est-item #f)).
81f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8200: 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c (hash-tabl
8210: 65 2d 73 65 74 21 20 28 68 61 73 68 2d 74 61 62 e-set! (hash-tab
8220: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 72 le-ref/default r
8230: 65 73 68 20 74 65 73 74 2d 6e 61 6d 65 20 20 23 esh test-name #
8240: 66 29 20 74 65 73 74 2d 69 74 65 6d 20 20 20 28 f) test-item (
8250: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
8260: 29 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 )) .
8270: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 (hash-table-s
8280: 65 74 21 20 20 28 68 61 73 68 2d 74 61 62 6c 65 et! (hash-table
8290: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 28 68 61 -ref/default (ha
82a0: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
82b0: 61 75 6c 74 20 72 65 73 68 20 74 65 73 74 2d 6e ault resh test-n
82c0: 61 6d 65 20 20 23 66 29 20 74 65 73 74 2d 69 74 ame #f) test-it
82d0: 65 6d 20 23 66 29 20 72 75 6e 2d 69 64 20 28 6c em #f) run-id (l
82e0: 69 73 74 20 74 65 73 74 2d 73 74 61 74 75 73 20 ist test-status
82f0: 74 65 73 74 2d 68 74 6d 6c 2d 70 61 74 68 29 29 test-html-path))
8300: 29 29 20 0a 20 20 20 20 20 20 20 20 74 65 73 74 )) . test
8310: 2d 64 61 74 61 29 29 29 0a 20 20 20 20 20 20 72 -data))). r
8320: 75 6e 73 29 0a 20 20 20 72 65 73 68 29 29 0a 0a uns). resh))..
8330: 0a 3b 3b 20 74 65 73 74 73 3a 67 65 6e 72 61 74 .;; tests:genrat
8340: 65 20 64 61 73 68 62 6f 61 72 64 20 62 6f 64 79 e dashboard body
8350: 20 0a 3b 3b 0a 0a 28 64 65 66 69 6e 65 20 28 74 .;;..(define (t
8360: 65 73 74 73 3a 64 61 73 68 62 6f 61 72 64 2d 62 ests:dashboard-b
8370: 6f 64 79 20 70 61 67 65 20 70 67 2d 73 69 7a 65 ody page pg-size
8380: 20 6b 65 79 73 20 6e 75 6d 6b 65 79 73 20 20 74 keys numkeys t
8390: 6f 74 61 6c 2d 72 75 6e 73 20 6c 69 6e 6b 74 72 otal-runs linktr
83a0: 65 65 20 61 72 65 61 2d 6e 61 6d 65 20 67 65 74 ee area-name get
83b0: 2d 70 72 65 76 2d 6c 69 6e 6b 73 20 67 65 74 2d -prev-links get-
83c0: 6e 65 78 74 2d 6c 69 6e 6b 73 20 66 6c 61 67 20 next-links flag
83d0: 72 75 6e 2d 70 61 74 74 20 74 61 72 67 65 74 2d run-patt target-
83e0: 70 61 74 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 patt). (let* ((
83f0: 73 74 61 72 74 20 28 2a 20 70 61 67 65 20 70 67 start (* page pg
8400: 2d 73 69 7a 65 29 29 20 0a 09 09 09 09 09 3b 28 -size)) ......;(
8410: 72 75 6e 73 64 61 74 20 20 20 28 72 6d 74 3a 67 runsdat (rmt:g
8420: 65 74 2d 72 75 6e 73 20 22 25 22 20 70 67 2d 73 et-runs "%" pg-s
8430: 69 7a 65 20 73 74 61 72 74 20 28 6d 61 70 20 28 ize start (map (
8440: 6c 61 6d 62 64 61 20 28 78 29 28 6c 69 73 74 20 lambda (x)(list
8450: 78 20 22 25 22 29 29 20 6b 65 79 73 29 29 29 0a x "%")) keys))).
8460: 20 20 20 20 20 20 20 20 20 28 72 75 6e 73 64 61 (runsda
8470: 74 20 20 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e t (rmt:get-run
8480: 73 2d 62 79 2d 70 61 74 74 20 20 6b 65 79 73 20 s-by-patt keys
8490: 72 75 6e 2d 70 61 74 74 20 74 61 72 67 65 74 2d run-patt target-
84a0: 70 61 74 74 20 73 74 61 72 74 20 70 67 2d 73 69 patt start pg-si
84b0: 7a 65 20 23 66 20 30 20 73 6f 72 74 2d 6f 72 64 ze #f 0 sort-ord
84c0: 65 72 3a 20 22 64 65 73 63 22 29 29 0a 09 09 09 er: "desc"))....
84d0: 09 09 3b 20 64 62 3a 67 65 74 2d 72 75 6e 73 2d ..; db:get-runs-
84e0: 62 79 2d 70 61 74 74 20 20 20 6b 65 79 73 20 72 by-patt keys r
84f0: 75 6e 6e 61 6d 65 70 61 74 74 20 74 61 72 67 70 unnamepatt targp
8500: 61 74 74 20 6f 66 66 73 65 74 20 6c 69 6d 69 74 att offset limit
8510: 20 66 69 65 6c 64 73 20 6c 61 73 74 2d 75 70 64 fields last-upd
8520: 61 74 65 20 20 20 0a 09 20 28 68 65 61 64 65 72 ate .. (header
8530: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
8540: 72 75 6e 73 64 61 74 20 30 29 29 0a 09 20 28 72 runsdat 0)).. (r
8550: 75 6e 73 20 20 20 20 20 20 28 76 65 63 74 6f 72 uns (vector
8560: 2d 72 65 66 20 72 75 6e 73 64 61 74 20 31 29 29 -ref runsdat 1))
8570: 0a 20 20 20 20 20 20 20 20 20 28 63 74 72 20 30 . (ctr 0
8580: 29 0a 20 20 20 20 20 20 20 20 20 28 74 65 73 74 ). (test
8590: 2d 72 75 6e 73 2d 68 61 73 68 20 28 74 65 73 74 -runs-hash (test
85a0: 73 3a 67 65 74 2d 72 65 73 74 2d 64 61 74 61 20 s:get-rest-data
85b0: 72 75 6e 73 20 68 65 61 64 65 72 20 6e 75 6d 6b runs header numk
85c0: 65 79 73 29 29 0a 20 20 20 20 20 20 20 20 20 28 eys)). (
85d0: 74 65 73 74 2d 6c 69 73 74 20 28 68 61 73 68 2d test-list (hash-
85e0: 74 61 62 6c 65 2d 6b 65 79 73 20 74 65 73 74 2d table-keys test-
85f0: 72 75 6e 73 2d 68 61 73 68 29 29 29 20 0a 20 20 runs-hash))) .
8600: 20 20 0a 20 20 20 20 28 73 3a 68 74 6d 6c 20 74 . (s:html t
8610: 65 73 74 73 3a 63 73 73 2d 6a 73 63 72 69 70 74 ests:css-jscript
8620: 2d 62 6c 6f 63 6b 20 28 74 65 73 74 73 3a 63 73 -block (tests:cs
8630: 73 2d 6a 73 63 72 69 70 74 2d 62 6c 6f 63 6b 2d s-jscript-block-
8640: 63 6f 6e 64 20 66 6c 61 67 29 0a 09 20 20 20 20 cond flag)..
8650: 28 73 3a 74 69 74 6c 65 20 22 53 75 6d 6d 61 72 (s:title "Summar
8660: 79 20 66 6f 72 20 22 20 61 72 65 61 2d 6e 61 6d y for " area-nam
8670: 65 29 0a 09 20 20 20 20 28 73 3a 62 6f 64 79 20 e).. (s:body
8680: 27 6f 6e 6c 6f 61 64 20 22 61 64 64 45 76 65 6e 'onload "addEven
8690: 74 73 28 29 3b 22 0a 09 09 20 20 20 20 28 67 65 ts();"... (ge
86a0: 74 2d 70 72 65 76 2d 6c 69 6e 6b 73 20 70 61 67 t-prev-links pag
86b0: 65 20 6c 69 6e 6b 74 72 65 65 29 0a 09 09 20 20 e linktree)...
86c0: 20 20 28 67 65 74 2d 6e 65 78 74 2d 6c 69 6e 6b (get-next-link
86d0: 73 20 70 61 67 65 20 6c 69 6e 6b 74 72 65 65 20 s page linktree
86e0: 74 6f 74 61 6c 2d 72 75 6e 73 29 0a 09 09 20 20 total-runs)...
86f0: 20 20 0a 09 09 20 20 20 20 28 73 3a 68 31 20 22 ... (s:h1 "
8700: 53 75 6d 6d 61 72 79 20 66 6f 72 20 22 20 61 72 Summary for " ar
8710: 65 61 2d 6e 61 6d 65 29 0a 09 09 20 20 20 20 28 ea-name)... (
8720: 73 3a 68 33 20 22 46 69 6c 74 65 72 22 20 29 0a s:h3 "Filter" ).
8730: 09 09 20 20 20 20 28 73 3a 69 6e 70 75 74 20 27 .. (s:input '
8740: 74 79 70 65 20 22 74 65 78 74 22 20 20 27 6e 61 type "text" 'na
8750: 6d 65 20 22 74 65 73 74 6e 61 6d 65 22 20 27 69 me "testname" 'i
8760: 64 20 22 74 65 73 74 6e 61 6d 65 22 20 27 6c 65 d "testname" 'le
8770: 6e 67 74 68 20 22 33 30 22 20 27 6f 6e 6b 65 79 ngth "30" 'onkey
8780: 75 70 20 22 66 69 6c 74 65 72 73 6f 6d 65 28 29 up "filtersome()
8790: 22 29 0a 09 09 20 20 20 20 3b 3b 20 74 6f 70 20 ")... ;; top
87a0: 6c 69 73 74 0a 09 09 20 20 20 20 0a 09 09 20 20 list... ...
87b0: 20 20 28 73 3a 74 61 62 6c 65 20 27 69 64 20 22 (s:table 'id "
87c0: 4c 69 6e 6b 65 64 4c 69 73 74 31 22 20 27 62 6f LinkedList1" 'bo
87d0: 72 64 65 72 20 22 31 22 20 27 63 65 6c 6c 73 70 rder "1" 'cellsp
87e0: 61 63 69 6e 67 20 30 0a 09 09 09 20 20 20 20 20 acing 0....
87f0: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 6b 65 (map (lambda (ke
8800: 79 29 0a 09 09 09 09 20 20 20 20 28 6c 65 74 2a y)..... (let*
8810: 20 28 28 72 65 73 20 28 73 3a 74 72 20 27 63 6c ((res (s:tr 'cl
8820: 61 73 73 20 22 73 6f 6d 65 74 68 69 6e 67 22 20 ass "something"
8830: 0a 09 09 09 09 09 09 20 20 20 20 20 20 28 73 3a ....... (s:
8840: 74 68 20 6b 65 79 20 29 0a 09 09 09 09 09 09 20 th key ).......
8850: 20 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 (map (lambd
8860: 61 20 28 72 75 6e 29 0a 09 09 09 09 09 09 09 20 a (run)........
8870: 20 20 20 20 28 73 3a 74 68 20 20 28 76 65 63 74 (s:th (vect
8880: 6f 72 2d 72 65 66 20 72 75 6e 20 63 74 72 29 29 or-ref run ctr))
8890: 29 0a 09 09 09 09 09 09 09 20 20 20 72 75 6e 73 )........ runs
88a0: 29 29 29 29 0a 09 09 09 09 20 20 20 20 20 20 28 ))))..... (
88b0: 73 65 74 21 20 63 74 72 20 28 2b 20 63 74 72 20 set! ctr (+ ctr
88c0: 31 29 29 0a 09 09 09 09 20 20 20 20 20 20 72 65 1))..... re
88d0: 73 29 29 0a 09 09 09 09 20 20 6b 65 79 73 29 0a s))..... keys).
88e0: 09 09 09 20 20 20 20 20 28 73 3a 74 72 0a 09 09 ... (s:tr...
88f0: 09 20 20 20 20 20 20 28 73 3a 74 68 20 22 52 75 . (s:th "Ru
8900: 6e 20 4e 61 6d 65 22 29 0a 09 09 09 20 20 20 20 n Name")....
8910: 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 (map (lambda (
8920: 72 75 6e 29 0a 09 09 09 09 20 20 20 20 20 28 73 run)..... (s
8930: 3a 74 68 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 :th (db:get-valu
8940: 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 e-by-header run
8950: 68 65 61 64 65 72 20 22 72 75 6e 6e 61 6d 65 22 header "runname"
8960: 29 29 29 0a 09 09 09 09 20 20 20 72 75 6e 73 29 )))..... runs)
8970: 29 0a 09 09 09 20 20 20 20 20 0a 09 09 09 20 20 ).... ....
8980: 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 (map (lambda
8990: 28 74 65 73 74 2d 6e 61 6d 65 29 0a 09 09 09 09 (test-name).....
89a0: 20 20 20 20 28 6c 65 74 2a 20 28 28 69 74 65 6d (let* ((item
89b0: 2d 68 61 73 68 20 28 68 61 73 68 2d 74 61 62 6c -hash (hash-tabl
89c0: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 65 e-ref/default te
89d0: 73 74 2d 72 75 6e 73 2d 68 61 73 68 20 74 65 73 st-runs-hash tes
89e0: 74 2d 6e 61 6d 65 20 20 23 66 29 29 0a 09 09 09 t-name #f))....
89f0: 09 09 20 20 20 28 69 74 65 6d 2d 6b 65 79 73 20 .. (item-keys
8a00: 28 73 6f 72 74 20 28 68 61 73 68 2d 74 61 62 6c (sort (hash-tabl
8a10: 65 2d 6b 65 79 73 20 69 74 65 6d 2d 68 61 73 68 e-keys item-hash
8a20: 29 20 73 74 72 69 6e 67 3c 3d 3f 29 29 29 20 0a ) string<=?))) .
8a30: 09 09 09 09 20 20 20 20 20 20 28 6d 61 70 20 28 .... (map (
8a40: 6c 61 6d 62 64 61 20 28 69 74 65 6d 2d 6e 61 6d lambda (item-nam
8a50: 65 29 20 20 0a 20 20 09 09 20 20 20 20 20 20 20 e) . ..
8a60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8a70: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 72 65 (let* ((re
8a80: 73 20 28 73 3a 74 72 20 20 27 63 6c 61 73 73 20 s (s:tr 'class
8a90: 69 74 65 6d 2d 6e 61 6d 65 0a 09 09 09 09 09 09 item-name.......
8aa0: 09 09 28 73 3a 74 64 20 20 69 74 65 6d 2d 6e 61 ..(s:td item-na
8ab0: 6d 65 20 27 63 6c 61 73 73 20 22 74 65 73 74 22 me 'class "test"
8ac0: 20 29 0a 09 09 09 09 09 09 09 09 28 6d 61 70 20 ).........(map
8ad0: 28 6c 61 6d 62 64 61 20 28 72 75 6e 29 0a 09 09 (lambda (run)...
8ae0: 09 09 09 09 09 09 20 20 20 20 20 20 20 28 6c 65 ...... (le
8af0: 74 2a 20 28 28 72 75 6e 2d 74 65 73 74 20 28 68 t* ((run-test (h
8b00: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
8b10: 66 61 75 6c 74 20 69 74 65 6d 2d 68 61 73 68 20 fault item-hash
8b20: 69 74 65 6d 2d 6e 61 6d 65 20 20 23 66 29 29 0a item-name #f)).
8b30: 09 09 09 09 09 09 09 09 09 20 20 20 20 20 20 28 ......... (
8b40: 72 75 6e 2d 69 64 20 28 64 62 3a 67 65 74 2d 76 run-id (db:get-v
8b50: 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 alue-by-header r
8b60: 75 6e 20 68 65 61 64 65 72 20 22 69 64 22 29 29 un header "id"))
8b70: 0a 09 09 09 09 09 09 09 09 09 20 20 20 20 20 20 ..........
8b80: 28 72 65 73 75 6c 74 20 28 68 61 73 68 2d 74 61 (result (hash-ta
8b90: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
8ba0: 72 75 6e 2d 74 65 73 74 20 72 75 6e 2d 69 64 20 run-test run-id
8bb0: 22 6e 2f 61 22 29 29 0a 09 09 09 09 09 3b 28 72 "n/a"))......;(r
8bc0: 65 6c 61 74 69 76 65 2d 70 61 74 68 20 28 67 65 elative-path (ge
8bd0: 74 2d 72 65 6c 61 74 69 76 65 2d 70 61 74 68 29 t-relative-path)
8be0: 29 20 0a 09 09 09 09 09 09 09 09 09 20 20 20 20 ) ..........
8bf0: 20 20 28 73 74 61 74 75 73 20 28 69 66 20 28 73 (status (if (s
8c00: 74 72 69 6e 67 3f 20 72 65 73 75 6c 74 29 0a 09 tring? result)..
8c10: 09 09 09 09 09 09 09 09 09 09 20 20 72 65 73 75 .......... resu
8c20: 6c 74 0a 09 09 09 09 09 09 09 09 09 09 09 20 20 lt............
8c30: 28 63 61 72 20 72 65 73 75 6c 74 29 29 29 0a 09 (car result)))..
8c40: 09 09 09 09 09 09 09 09 20 20 20 20 20 20 28 6c ........ (l
8c50: 69 6e 6b 20 28 69 66 20 28 73 74 72 69 6e 67 3f ink (if (string?
8c60: 20 72 65 73 75 6c 74 29 0a 09 09 09 09 09 09 09 result)........
8c70: 09 09 09 09 72 65 73 75 6c 74 0a 09 09 09 09 09 ....result......
8c80: 09 09 09 09 09 09 28 69 66 20 28 65 71 75 61 6c ......(if (equal
8c90: 3f 20 66 6c 61 67 20 23 74 29 20 0a 09 09 09 09 ? flag #t) .....
8ca0: 09 09 09 09 09 09 09 20 20 20 20 28 73 3a 61 20 ....... (s:a
8cb0: 28 63 61 72 20 72 65 73 75 6c 74 29 20 27 68 72 (car result) 'hr
8cc0: 65 66 20 28 63 6f 6e 63 20 22 2e 2f 74 65 73 74 ef (conc "./test
8cd0: 5f 6c 6f 67 3f 72 75 6e 69 64 3d 22 20 72 75 6e _log?runid=" run
8ce0: 2d 69 64 20 22 26 74 65 73 74 6e 61 6d 65 3d 22 -id "&testname="
8cf0: 20 20 69 74 65 6d 2d 6e 61 6d 65 20 29 29 0a 09 item-name ))..
8d00: 09 09 09 09 09 09 09 09 09 09 20 20 20 20 28 73 .......... (s
8d10: 3a 61 20 28 63 61 72 20 72 65 73 75 6c 74 29 20 :a (car result)
8d20: 27 68 72 65 66 20 28 73 74 72 69 6e 67 2d 73 75 'href (string-su
8d30: 62 73 74 69 74 75 74 65 20 20 28 63 6f 6e 63 20 bstitute (conc
8d40: 6c 69 6e 6b 74 72 65 65 20 22 2f 22 29 20 20 22 linktree "/") "
8d50: 22 20 28 63 61 64 72 20 72 65 73 75 6c 74 29 20 " (cadr result)
8d60: 20 22 2d 22 29 29 29 29 29 29 0a 09 09 09 09 09 "-"))))))......
8d70: 09 09 09 09 20 28 73 3a 74 64 20 20 6c 69 6e 6b .... (s:td link
8d80: 20 27 63 6c 61 73 73 20 73 74 61 74 75 73 29 29 'class status))
8d90: 29 0a 09 09 09 09 09 09 09 09 20 20 20 20 20 72 )......... r
8da0: 75 6e 73 29 29 29 29 0a 09 09 09 09 09 20 20 20 uns))))......
8db0: 20 20 20 20 72 65 73 29 29 0a 09 09 09 09 09 20 res))......
8dc0: 20 20 69 74 65 6d 2d 6b 65 79 73 29 29 29 0a 09 item-keys)))..
8dd0: 09 09 09 20 20 74 65 73 74 2d 6c 69 73 74 29 29 ... test-list))
8de0: 29 29 29 29 20 0a 0a 3b 3b 20 28 74 65 73 74 73 )))) ..;; (tests
8df0: 3a 63 72 65 61 74 65 2d 68 74 6d 6c 2d 74 72 65 :create-html-tre
8e00: 65 20 22 74 65 73 74 2d 69 6e 64 65 78 2e 68 74 e "test-index.ht
8e10: 6d 6c 22 29 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 ml").;;.(define
8e20: 28 74 65 73 74 73 3a 63 72 65 61 74 65 2d 68 74 (tests:create-ht
8e30: 6d 6c 2d 74 72 65 65 20 6f 75 74 66 29 0a 20 20 ml-tree outf).
8e40: 28 6c 65 74 2a 20 28 28 6c 6f 63 6b 66 69 6c 65 (let* ((lockfile
8e50: 20 20 28 63 6f 6e 63 20 6f 75 74 66 20 22 2e 6c (conc outf ".l
8e60: 6f 63 6b 22 29 29 0a 09 20 28 72 75 6e 73 2d 74 ock")).. (runs-t
8e70: 6f 2d 70 72 6f 63 65 73 73 20 27 28 29 29 0a 20 o-process '()).
8e80: 20 20 20 20 20 20 20 20 28 6c 69 6e 6b 74 72 65 (linktre
8e90: 65 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c e (common:get-l
8ea0: 69 6e 6b 74 72 65 65 29 29 0a 20 20 20 20 20 20 inktree)).
8eb0: 20 20 20 28 61 72 65 61 2d 6e 61 6d 65 20 28 63 (area-name (c
8ec0: 6f 6d 6d 6f 6e 3a 67 65 74 2d 74 65 73 74 73 75 ommon:get-testsu
8ed0: 69 74 65 2d 6e 61 6d 65 29 29 0a 09 20 28 6b 65 ite-name)).. (ke
8ee0: 79 73 20 20 20 20 20 20 28 72 6d 74 3a 67 65 74 ys (rmt:get
8ef0: 2d 6b 65 79 73 29 29 0a 09 20 28 6e 75 6d 6b 65 -keys)).. (numke
8f00: 79 73 20 20 20 28 6c 65 6e 67 74 68 20 6b 65 79 ys (length key
8f10: 73 29 29 0a 20 20 20 20 20 20 20 20 20 28 72 75 s)). (ru
8f20: 6e 2d 70 61 74 74 20 28 6f 72 20 28 61 72 67 73 n-patt (or (args
8f30: 3a 67 65 74 2d 61 72 67 20 22 2d 72 75 6e 2d 70 :get-arg "-run-p
8f40: 61 74 74 22 29 0a 09 09 20 20 20 20 20 20 20 28 att")... (
8f50: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 args:get-arg "-r
8f60: 75 6e 6e 61 6d 65 22 29 0a 09 09 20 20 20 20 20 unname")...
8f70: 20 20 22 25 22 29 29 0a 20 20 20 20 20 20 20 20 "%")).
8f80: 20 28 74 61 72 67 65 74 20 28 6f 72 20 20 28 61 (target (or (a
8f90: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 rgs:get-arg "-ta
8fa0: 72 67 65 74 2d 70 61 74 74 22 29 20 0a 09 09 20 rget-patt") ...
8fb0: 20 20 20 20 20 28 61 72 67 73 3a 67 65 74 2d 61 (args:get-a
8fc0: 72 67 20 22 2d 74 61 72 67 65 74 22 29 0a 20 20 rg "-target").
8fd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8fe0: 20 20 20 20 22 25 22 29 29 0a 20 20 20 20 20 20 "%")).
8ff0: 20 20 20 28 74 61 72 67 6c 69 73 74 20 28 73 74 (targlist (st
9000: 72 69 6e 67 2d 73 70 6c 69 74 20 74 61 72 67 65 ring-split targe
9010: 74 20 22 2f 22 29 29 0a 20 20 20 20 20 20 20 20 t "/")).
9020: 20 28 6e 75 6d 74 61 72 67 20 20 28 6c 65 6e 67 (numtarg (leng
9030: 74 68 20 74 61 72 67 6c 69 73 74 29 29 20 20 0a th targlist)) .
9040: 20 20 20 20 20 20 20 20 20 28 74 61 72 67 74 77 (targtw
9050: 65 61 6b 65 64 20 28 69 66 20 28 3e 20 6e 75 6d eaked (if (> num
9060: 6b 65 79 73 20 6e 75 6d 74 61 72 67 29 0a 09 09 keys numtarg)...
9070: 09 20 20 28 61 70 70 65 6e 64 20 74 61 72 67 6c . (append targl
9080: 69 73 74 20 28 6d 61 6b 65 2d 6c 69 73 74 20 28 ist (make-list (
9090: 2d 20 6e 75 6d 6b 65 79 73 20 6e 75 6d 74 61 72 - numkeys numtar
90a0: 67 29 20 22 25 22 29 29 0a 09 09 09 20 20 74 61 g) "%")).... ta
90b0: 72 67 6c 69 73 74 29 29 0a 20 20 20 20 20 20 20 rglist)).
90c0: 20 20 28 74 61 72 67 65 74 2d 70 61 74 74 20 28 (target-patt (
90d0: 73 74 72 69 6e 67 2d 6a 6f 69 6e 20 74 61 72 67 string-join targ
90e0: 74 77 65 61 6b 65 64 20 22 2f 22 29 29 0a 09 09 tweaked "/"))...
90f0: 09 09 09 3b 28 74 6f 74 61 6c 2d 72 75 6e 73 20 ...;(total-runs
9100: 20 28 72 6d 74 3a 67 65 74 2d 6e 75 6d 2d 72 75 (rmt:get-num-ru
9110: 6e 73 20 22 25 22 29 29 20 3b 3b 74 68 69 73 20 ns "%")) ;;this
9120: 6e 65 65 64 73 20 74 6f 20 62 65 20 63 68 61 6e needs to be chan
9130: 67 65 64 20 74 6f 20 66 69 6c 74 65 72 20 62 79 ged to filter by
9140: 20 74 61 72 67 65 74 0a 09 20 28 74 6f 74 61 6c target.. (total
9150: 2d 72 75 6e 73 20 28 72 6d 74 3a 67 65 74 2d 72 -runs (rmt:get-r
9160: 75 6e 73 2d 63 6e 74 2d 62 79 2d 70 61 74 74 20 uns-cnt-by-patt
9170: 72 75 6e 2d 70 61 74 74 20 74 61 72 67 65 74 2d run-patt target-
9180: 70 61 74 74 20 6b 65 79 73 20 29 29 20 0a 20 20 patt keys )) .
9190: 20 20 20 20 20 20 20 28 70 67 2d 73 69 7a 65 20 (pg-size
91a0: 31 30 29 29 0a 20 20 20 20 28 69 66 20 28 63 6f 10)). (if (co
91b0: 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 mmon:simple-file
91c0: 2d 6c 6f 63 6b 20 6c 6f 63 6b 66 69 6c 65 29 0a -lock lockfile).
91d0: 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 (begin..
91e0: 09 09 09 09 3b 28 70 72 69 6e 74 20 74 6f 74 61 ....;(print tota
91f0: 6c 2d 72 75 6e 73 29 20 20 20 20 0a 09 20 20 28 l-runs) .. (
9200: 6c 65 74 20 6c 6f 6f 70 20 28 28 70 61 67 65 20 let loop ((page
9210: 30 29 29 0a 09 20 20 20 20 28 6c 65 74 2a 20 28 0)).. (let* (
9220: 28 6f 75 70 20 20 20 20 20 20 20 20 20 20 20 20 (oup
9230: 28 6f 70 65 6e 2d 6f 75 74 70 75 74 2d 66 69 6c (open-output-fil
9240: 65 20 28 6f 72 20 6f 75 74 66 20 28 63 6f 6e 63 e (or outf (conc
9250: 20 6c 69 6e 6b 74 72 65 65 20 22 2f 70 61 67 65 linktree "/page
9260: 22 20 70 61 67 65 20 22 2e 68 74 6d 6c 22 29 29 " page ".html"))
9270: 29 29 0a 09 09 20 20 20 28 67 65 74 2d 70 72 65 ))... (get-pre
9280: 76 2d 6c 69 6e 6b 73 20 28 6c 61 6d 62 64 61 20 v-links (lambda
9290: 28 70 61 67 65 20 6c 69 6e 6b 74 72 65 65 20 29 (page linktree )
92a0: 20 20 20 0a 09 09 09 09 20 20 20 20 20 28 6c 65 ..... (le
92b0: 74 2a 20 28 28 6c 69 6e 6b 20 20 28 69 66 20 28 t* ((link (if (
92c0: 6e 6f 74 20 28 65 71 3f 20 70 61 67 65 20 30 29 not (eq? page 0)
92d0: 29 0a 09 09 09 09 09 09 20 20 20 20 20 20 20 28 )....... (
92e0: 73 3a 61 20 22 26 6c 74 3b 26 6c 74 3b 70 72 65 s:a "<<pre
92f0: 76 22 20 27 68 72 65 66 20 28 63 6f 6e 63 20 20 v" 'href (conc
9300: 22 70 61 67 65 22 20 28 2d 20 70 61 67 65 20 31 "page" (- page 1
9310: 29 20 22 2e 68 74 6d 6c 22 29 29 0a 09 09 09 09 ) ".html")).....
9320: 09 09 20 20 20 20 20 20 20 28 73 3a 61 20 22 22 .. (s:a ""
9330: 20 27 68 72 65 66 20 28 63 6f 6e 63 20 20 20 22 'href (conc "
9340: 70 61 67 65 22 20 20 70 61 67 65 20 22 2e 68 74 page" page ".ht
9350: 6d 6c 22 29 29 29 29 29 0a 09 09 09 09 20 20 20 ml"))))).....
9360: 20 20 20 20 6c 69 6e 6b 29 29 29 0a 09 09 20 20 link)))...
9370: 20 28 67 65 74 2d 6e 65 78 74 2d 6c 69 6e 6b 73 (get-next-links
9380: 20 28 6c 61 6d 62 64 61 20 28 70 61 67 65 20 6c (lambda (page l
9390: 69 6e 6b 74 72 65 65 20 74 6f 74 61 6c 2d 72 75 inktree total-ru
93a0: 6e 73 29 20 20 20 0a 09 09 09 09 20 20 20 20 20 ns) .....
93b0: 28 6c 65 74 2a 20 28 28 6c 69 6e 6b 20 20 28 69 (let* ((link (i
93c0: 66 20 28 3e 20 74 6f 74 61 6c 2d 72 75 6e 73 20 f (> total-runs
93d0: 28 2b 20 31 30 20 28 2a 20 70 61 67 65 20 70 67 (+ 10 (* page pg
93e0: 2d 73 69 7a 65 29 29 29 0a 09 09 09 09 09 09 20 -size))).......
93f0: 20 20 20 20 20 20 28 73 3a 61 20 22 6e 65 78 74 (s:a "next
9400: 26 67 74 3b 26 67 74 3b 22 20 27 68 72 65 66 20 >>" 'href
9410: 28 63 6f 6e 63 20 20 22 70 61 67 65 22 20 20 28 (conc "page" (
9420: 2b 20 70 61 67 65 20 31 29 20 22 2e 68 74 6d 6c + page 1) ".html
9430: 22 29 29 0a 09 09 09 09 09 09 20 20 20 20 20 20 ")).......
9440: 20 28 73 3a 61 20 22 22 20 27 68 72 65 66 20 28 (s:a "" 'href (
9450: 63 6f 6e 63 20 20 20 22 70 61 67 65 22 20 70 61 conc "page" pa
9460: 67 65 20 20 22 2e 68 74 6d 6c 22 29 29 29 29 29 ge ".html")))))
9470: 0a 09 09 09 09 20 20 20 20 20 20 20 6c 69 6e 6b ..... link
9480: 29 29 29 20 29 0a 09 20 20 20 20 20 20 28 70 72 ))) ).. (pr
9490: 69 6e 74 20 22 74 6f 74 61 6c 20 72 75 6e 73 3a int "total runs:
94a0: 20 22 20 74 6f 74 61 6c 2d 72 75 6e 73 29 20 0a " total-runs) .
94b0: 09 20 20 20 20 20 20 28 73 3a 6f 75 74 70 75 74 . (s:output
94c0: 2d 6e 65 77 0a 09 20 20 20 20 20 20 20 6f 75 70 -new.. oup
94d0: 0a 09 20 20 20 20 20 20 20 28 74 65 73 74 73 3a .. (tests:
94e0: 64 61 73 68 62 6f 61 72 64 2d 62 6f 64 79 20 70 dashboard-body p
94f0: 61 67 65 20 70 67 2d 73 69 7a 65 20 6b 65 79 73 age pg-size keys
9500: 20 6e 75 6d 6b 65 79 73 20 74 6f 74 61 6c 2d 72 numkeys total-r
9510: 75 6e 73 20 6c 69 6e 6b 74 72 65 65 20 61 72 65 uns linktree are
9520: 61 2d 6e 61 6d 65 20 67 65 74 2d 70 72 65 76 2d a-name get-prev-
9530: 6c 69 6e 6b 73 20 67 65 74 2d 6e 65 78 74 2d 6c links get-next-l
9540: 69 6e 6b 73 20 23 66 20 72 75 6e 2d 70 61 74 74 inks #f run-patt
9550: 20 74 61 72 67 65 74 2d 70 61 74 74 29 29 20 3b target-patt)) ;
9560: 3b 20 75 70 64 61 74 65 20 74 68 69 73 20 66 75 ; update this fu
9570: 6e 63 74 69 6f 6e 0a 09 20 20 20 20 20 20 28 63 nction.. (c
9580: 6c 6f 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 lose-output-port
9590: 20 6f 75 70 29 0a 09 09 09 09 09 3b 20 28 73 65 oup)......; (se
95a0: 74 21 20 70 61 67 65 20 28 2b 20 31 20 70 61 67 t! page (+ 1 pag
95b0: 65 29 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 e)).. (if (
95c0: 3e 20 74 6f 74 61 6c 2d 72 75 6e 73 20 28 2a 20 > total-runs (*
95d0: 28 2b 20 31 20 70 61 67 65 29 20 70 67 2d 73 69 (+ 1 page) pg-si
95e0: 7a 65 29 29 0a 09 09 20 20 28 6c 6f 6f 70 20 28 ze))... (loop (
95f0: 2b 20 31 20 20 70 61 67 65 29 29 29 29 29 0a 09 + 1 page)))))..
9600: 20 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 (common:simple
9610: 2d 66 69 6c 65 2d 72 65 6c 65 61 73 65 2d 6c 6f -file-release-lo
9620: 63 6b 20 6c 6f 63 6b 66 69 6c 65 29 29 0a 09 28 ck lockfile))..(
9630: 62 65 67 69 6e 0a 09 20 20 28 64 65 62 75 67 3a begin.. (debug:
9640: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
9650: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 46 61 69 6c -log-port* "Fail
9660: 65 64 20 74 6f 20 67 65 74 20 6c 6f 63 6b 20 6f ed to get lock o
9670: 6e 20 66 69 6c 65 20 6f 75 74 66 2c 20 6c 6f 63 n file outf, loc
9680: 6b 66 69 6c 65 3a 20 22 20 6c 6f 63 6b 66 69 6c kfile: " lockfil
9690: 65 29 20 23 66 29 29 29 29 0a 0a 0a 28 64 65 66 e) #f))))...(def
96a0: 69 6e 65 20 28 74 65 73 74 73 3a 72 65 61 64 6c ine (tests:readl
96b0: 69 6e 65 73 20 66 69 6c 65 6e 61 6d 65 29 0a 20 ines filename).
96c0: 20 28 63 61 6c 6c 2d 77 69 74 68 2d 69 6e 70 75 (call-with-inpu
96d0: 74 2d 66 69 6c 65 20 66 69 6c 65 6e 61 6d 65 0a t-file filename.
96e0: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 70 29 0a (lambda (p).
96f0: 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 (let loop
9700: 28 28 6c 69 6e 65 20 28 72 65 61 64 2d 6c 69 6e ((line (read-lin
9710: 65 20 70 29 29 0a 20 20 20 20 20 20 20 20 20 20 e p)).
9720: 20 20 20 20 20 20 20 28 72 65 73 75 6c 74 20 27 (result '
9730: 28 29 29 29 0a 20 20 20 20 20 20 20 20 28 69 66 ())). (if
9740: 20 28 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 6c 69 (eof-object? li
9750: 6e 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ne).
9760: 28 72 65 76 65 72 73 65 20 72 65 73 75 6c 74 29 (reverse result)
9770: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 6f . (lo
9780: 6f 70 20 28 72 65 61 64 2d 6c 69 6e 65 20 70 29 op (read-line p)
9790: 20 28 63 6f 6e 73 20 6c 69 6e 65 20 72 65 73 75 (cons line resu
97a0: 6c 74 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 lt)))))))..(defi
97b0: 6e 65 20 28 74 65 73 74 73 3a 67 65 74 2d 74 65 ne (tests:get-te
97c0: 73 74 2d 6c 6f 67 20 72 75 6e 2d 69 64 20 74 65 st-log run-id te
97d0: 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 6e 61 6d st-name item-nam
97e0: 65 29 0a 20 20 28 6c 65 74 2a 20 28 28 74 65 73 e). (let* ((tes
97f0: 74 2d 64 61 74 61 20 20 20 20 28 72 6d 74 3a 67 t-data (rmt:g
9800: 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e et-tests-for-run
9810: 0a 09 09 09 09 20 20 20 28 73 74 72 69 6e 67 2d ..... (string-
9820: 3e 6e 75 6d 62 65 72 20 72 75 6e 2d 69 64 29 0a >number run-id).
9830: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9840: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9850: 20 20 20 20 74 65 73 74 2d 6e 61 6d 65 20 20 20 test-name
9860: 20 20 20 3b 3b 20 74 65 73 74 6e 61 6d 65 70 61 ;; testnamepa
9870: 74 74 0a 09 09 09 09 20 20 20 27 28 29 20 20 20 tt..... '()
9880: 20 20 20 20 20 3b 3b 20 73 74 61 74 65 73 0a 09 ;; states..
9890: 09 09 09 20 20 20 27 28 29 20 20 20 20 20 20 20 ... '()
98a0: 20 3b 3b 20 73 74 61 74 75 73 65 73 0a 09 09 09 ;; statuses....
98b0: 09 20 20 20 23 66 20 20 20 20 20 20 20 20 20 3b . #f ;
98c0: 3b 20 6f 66 66 73 65 74 0a 09 09 09 09 20 20 20 ; offset.....
98d0: 23 66 20 20 20 20 20 20 20 20 20 3b 3b 20 6e 75 #f ;; nu
98e0: 6d 2d 74 6f 2d 67 65 74 0a 09 09 09 09 20 20 20 m-to-get.....
98f0: 23 66 20 20 20 20 20 20 20 20 20 3b 3b 20 68 69 #f ;; hi
9900: 64 65 2f 6e 6f 74 2d 68 69 64 65 0a 09 09 09 09 de/not-hide.....
9910: 20 20 20 23 66 20 20 20 20 20 20 20 20 20 3b 3b #f ;;
9920: 20 73 6f 72 74 2d 62 79 0a 09 09 09 09 20 20 20 sort-by.....
9930: 23 66 20 20 20 20 20 20 20 20 20 3b 3b 20 73 6f #f ;; so
9940: 72 74 2d 6f 72 64 65 72 0a 09 09 09 09 20 20 20 rt-order.....
9950: 23 66 20 20 20 20 20 20 20 20 20 3b 3b 20 27 73 #f ;; 's
9960: 68 6f 72 74 6c 69 73 74 20 20 20 20 20 20 20 20 hortlist
9970: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9980: 20 20 20 3b 3b 20 71 72 79 74 79 70 65 0a 20 20 ;; qrytype.
9990: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
99a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
99b0: 20 30 20 20 20 20 20 20 20 20 20 3b 3b 20 6c 61 0 ;; la
99c0: 73 74 20 75 70 64 61 74 65 0a 09 09 09 09 20 20 st update.....
99d0: 20 23 66 29 29 0a 20 20 20 20 20 20 20 20 20 28 #f)). (
99e0: 70 61 74 68 20 22 22 29 0a 20 20 20 20 20 20 20 path "").
99f0: 20 20 28 66 6f 75 6e 64 20 30 29 29 0a 20 20 20 (found 0)).
9a00: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
9a10: 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 0 *default-lo
9a20: 67 2d 70 6f 72 74 2a 20 22 66 6f 75 6e 64 3a 20 g-port* "found:
9a30: 22 20 66 6f 75 6e 64 20 29 0a 0a 20 20 20 28 6c " found ).. (l
9a40: 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 et loop ((hed (c
9a50: 61 72 20 74 65 73 74 2d 64 61 74 61 29 29 0a 09 ar test-data))..
9a60: 09 20 28 74 61 6c 20 28 63 64 72 20 74 65 73 74 . (tal (cdr test
9a70: 2d 64 61 74 61 29 29 29 0a 20 20 20 20 20 20 20 -data))).
9a80: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
9a90: 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d info 0 *default-
9aa0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 69 74 65 6d 3a log-port* "item:
9ab0: 20 22 20 28 76 65 63 74 6f 72 2d 72 65 66 20 68 " (vector-ref h
9ac0: 65 64 20 31 31 29 20 28 76 65 63 74 6f 72 2d 72 ed 11) (vector-r
9ad0: 65 66 20 68 65 64 20 31 30 29 20 22 2f 22 20 28 ef hed 10) "/" (
9ae0: 76 65 63 74 6f 72 2d 72 65 66 20 68 65 64 20 31 vector-ref hed 1
9af0: 33 29 29 0a 0a 09 28 69 66 20 28 65 71 75 61 6c 3))...(if (equal
9b00: 3f 20 28 76 65 63 74 6f 72 2d 72 65 66 20 68 65 ? (vector-ref he
9b10: 64 20 31 31 29 20 69 74 65 6d 2d 6e 61 6d 65 29 d 11) item-name)
9b20: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 62 65 . (be
9b30: 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 gin.
9b40: 20 20 28 73 65 74 21 20 66 6f 75 6e 64 20 31 29 (set! found 1)
9b50: 20 0a 09 20 20 20 20 20 20 28 73 65 74 21 20 70 .. (set! p
9b60: 61 74 68 20 28 63 6f 6e 63 20 28 76 65 63 74 6f ath (conc (vecto
9b70: 72 2d 72 65 66 20 68 65 64 20 31 30 29 20 22 2f r-ref hed 10) "/
9b80: 22 20 28 76 65 63 74 6f 72 2d 72 65 66 20 68 65 " (vector-ref he
9b90: 64 20 31 33 29 29 29 29 29 0a 09 20 20 20 20 28 d 13))))).. (
9ba0: 69 66 20 28 61 6e 64 20 28 6e 6f 74 20 28 6e 75 if (and (not (nu
9bb0: 6c 6c 3f 20 74 61 6c 29 29 20 28 65 71 75 61 6c ll? tal)) (equal
9bc0: 3f 20 66 6f 75 6e 64 20 30 29 29 0a 09 09 28 6c ? found 0))...(l
9bd0: 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 oop (car tal)(cd
9be0: 72 20 74 61 6c 29 29 29 29 0a 20 20 20 28 69 66 r tal)))). (if
9bf0: 20 28 65 71 75 61 6c 3f 20 70 61 74 68 20 22 22 (equal? path ""
9c00: 29 0a 20 20 20 20 20 22 3c 48 32 3e 44 61 74 61 ). "<H2>Data
9c10: 20 6e 6f 74 20 66 6f 75 6e 64 3c 2f 48 32 3e 22 not found</H2>"
9c20: 0a 20 20 20 20 20 28 73 74 72 69 6e 67 2d 6a 6f . (string-jo
9c30: 69 6e 20 28 74 65 73 74 73 3a 72 65 61 64 6c 69 in (tests:readli
9c40: 6e 65 73 20 70 61 74 68 29 20 22 5c 6e 22 29 29 nes path) "\n"))
9c50: 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 ))...(define (te
9c60: 73 74 73 3a 64 79 6e 61 6d 69 63 2d 64 62 6f 61 sts:dynamic-dboa
9c70: 72 64 20 70 61 67 65 29 0a 3b 28 64 65 66 69 6e rd page).;(defin
9c80: 65 20 28 74 65 73 74 73 3a 63 72 65 61 74 65 2d e (tests:create-
9c90: 68 74 6d 6c 2d 74 72 65 65 20 6f 29 0a 20 28 6c html-tree o). (l
9ca0: 65 74 2a 20 28 0a 3b 28 70 61 67 65 20 22 31 22 et* (.;(page "1"
9cb0: 29 0a 20 20 20 20 20 20 20 20 20 20 28 6c 69 6e ). (lin
9cc0: 6b 74 72 65 65 20 20 28 63 6f 6d 6d 6f 6e 3a 67 ktree (common:g
9cd0: 65 74 2d 6c 69 6e 6b 74 72 65 65 29 29 0a 20 20 et-linktree)).
9ce0: 20 20 20 20 20 20 20 28 61 72 65 61 2d 6e 61 6d (area-nam
9cf0: 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 74 65 e (common:get-te
9d00: 73 74 73 75 69 74 65 2d 6e 61 6d 65 29 29 0a 09 stsuite-name))..
9d10: 20 20 20 20 20 20 20 28 6b 65 79 73 20 20 20 20 (keys
9d20: 20 20 28 72 6d 74 3a 67 65 74 2d 6b 65 79 73 29 (rmt:get-keys)
9d30: 29 0a 09 20 20 20 20 20 20 20 28 6e 75 6d 6b 65 ).. (numke
9d40: 79 73 20 20 20 28 6c 65 6e 67 74 68 20 6b 65 79 ys (length key
9d50: 73 29 29 0a 20 20 20 20 20 20 20 20 20 28 74 61 s)). (ta
9d60: 72 67 74 77 65 61 6b 65 64 20 28 6d 61 6b 65 2d rgtweaked (make-
9d70: 6c 69 73 74 20 6e 75 6d 6b 65 79 73 20 22 25 22 list numkeys "%"
9d80: 29 29 0a 20 20 20 20 20 20 20 20 20 28 74 61 72 )). (tar
9d90: 67 65 74 2d 70 61 74 74 20 28 73 74 72 69 6e 67 get-patt (string
9da0: 2d 6a 6f 69 6e 20 74 61 72 67 74 77 65 61 6b 65 -join targtweake
9db0: 64 20 22 2f 22 29 29 0a 20 20 20 20 20 20 20 20 d "/")).
9dc0: 20 28 74 6f 74 61 6c 2d 72 75 6e 73 20 20 28 72 (total-runs (r
9dd0: 6d 74 3a 67 65 74 2d 6e 75 6d 2d 72 75 6e 73 20 mt:get-num-runs
9de0: 22 25 22 29 29 0a 20 20 20 20 20 20 20 20 20 28 "%")). (
9df0: 70 67 2d 73 69 7a 65 20 31 30 29 0a 20 20 20 20 pg-size 10).
9e00: 20 20 20 20 20 28 70 67 20 28 69 66 20 28 65 71 (pg (if (eq
9e10: 75 61 6c 3f 20 70 61 67 65 20 23 66 29 0a 20 20 ual? page #f).
9e20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 30 0
9e30: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
9e40: 20 20 28 2d 20 28 73 74 72 69 6e 67 2d 3e 6e 75 (- (string->nu
9e50: 6d 62 65 72 20 70 61 67 65 29 20 31 29 29 29 0a mber page) 1))).
9e60: 20 20 20 20 20 20 20 20 20 20 28 67 65 74 2d 70 (get-p
9e70: 72 65 76 2d 6c 69 6e 6b 73 20 20 28 6c 61 6d 62 rev-links (lamb
9e80: 64 61 20 28 70 67 20 6c 69 6e 6b 74 72 65 65 29 da (pg linktree)
9e90: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
9ea0: 20 20 20 20 20 20 20 20 20 20 20 20 28 64 65 62 (deb
9eb0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
9ec0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
9ed0: 74 2a 20 22 76 61 6c 3a 20 22 20 28 2d 20 31 20 t* "val: " (- 1
9ee0: 70 67 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 pg)).
9ef0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
9f00: 6c 65 74 2a 20 28 28 6c 69 6e 6b 20 20 28 69 66 let* ((link (if
9f10: 20 28 6e 6f 74 20 28 65 71 3f 20 70 67 20 30 29 (not (eq? pg 0)
9f20: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
9f30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9f40: 20 28 73 3a 61 20 20 22 26 6c 74 3b 26 6c 74 3b (s:a "<<
9f50: 70 72 65 76 20 22 20 27 68 72 65 66 20 28 63 6f prev " 'href (co
9f60: 6e 63 20 20 22 64 61 73 68 62 6f 61 72 64 3f 70 nc "dashboard?p
9f70: 61 67 65 3d 22 20 20 70 67 20 20 29 29 0a 20 20 age=" pg )).
9f80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9f90: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 3a (s:
9fa0: 61 20 22 22 20 27 68 72 65 66 20 28 63 6f 6e 63 a "" 'href (conc
9fb0: 20 20 22 64 61 73 68 62 6f 61 72 64 3f 70 61 67 "dashboard?pag
9fc0: 65 3d 22 20 70 67 29 29 29 29 29 0a 20 20 20 20 e=" pg))))).
9fd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9fe0: 20 20 20 20 20 20 20 20 20 20 20 6c 69 6e 6b 29 link)
9ff0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 67 65 )). (ge
a000: 74 2d 6e 65 78 74 2d 6c 69 6e 6b 73 20 20 20 28 t-next-links (
a010: 6c 61 6d 62 64 61 20 28 70 67 20 6c 69 6e 6b 74 lambda (pg linkt
a020: 72 65 65 20 74 6f 74 61 6c 2d 72 75 6e 73 29 20 ree total-runs)
a030: 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
a040: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 (d
a050: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
a060: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
a070: 6f 72 74 2a 20 22 76 61 6c 3a 20 22 20 70 67 29 ort* "val: " pg)
a080: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
a090: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 (d
a0a0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
a0b0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
a0c0: 6f 72 74 2a 20 22 76 61 6c 3a 20 22 20 74 6f 74 ort* "val: " tot
a0d0: 61 6c 2d 72 75 6e 73 20 22 20 73 69 7a 65 22 20 al-runs " size"
a0e0: 70 67 2d 73 69 7a 65 29 0a 20 0a 20 20 20 20 20 pg-size). .
a0f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a100: 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 6c (let* ((l
a110: 69 6e 6b 20 20 28 69 66 20 28 3e 20 74 6f 74 61 ink (if (> tota
a120: 6c 2d 72 75 6e 73 20 28 2b 20 31 30 20 28 2a 20 l-runs (+ 10 (*
a130: 70 67 20 70 67 2d 73 69 7a 65 29 29 29 0a 20 20 pg pg-size))).
a140: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a150: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 3a 61 (s:a
a160: 20 20 22 6e 65 78 74 26 67 74 3b 26 67 74 3b 20 "next>>
a170: 22 20 20 27 68 72 65 66 20 28 63 6f 6e 63 20 20 " 'href (conc
a180: 22 64 61 73 68 62 6f 61 72 64 3f 70 61 67 65 3d "dashboard?page=
a190: 22 20 20 28 2b 20 70 67 20 32 29 20 20 29 29 0a " (+ pg 2) )).
a1a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a1b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 3a (s:
a1c0: 61 20 22 22 20 27 68 72 65 66 20 28 63 6f 6e 63 a "" 'href (conc
a1d0: 20 20 22 64 61 73 68 62 6f 61 72 64 3f 70 61 67 "dashboard?pag
a1e0: 65 3d 22 20 70 67 20 20 29 29 29 29 29 0a 20 20 e=" pg ))))).
a1f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a200: 20 20 20 20 20 20 20 20 20 20 20 6c 69 6e 6b 29 link)
a210: 29 29 0a 20 20 20 20 20 20 20 20 20 28 68 74 6d )). (htm
a220: 6c 2d 62 6f 64 79 20 28 74 65 73 74 73 3a 64 61 l-body (tests:da
a230: 73 68 62 6f 61 72 64 2d 62 6f 64 79 20 70 67 20 shboard-body pg
a240: 70 67 2d 73 69 7a 65 20 6b 65 79 73 20 6e 75 6d pg-size keys num
a250: 6b 65 79 73 20 74 6f 74 61 6c 2d 72 75 6e 73 20 keys total-runs
a260: 6c 69 6e 6b 74 72 65 65 20 61 72 65 61 2d 6e 61 linktree area-na
a270: 6d 65 20 67 65 74 2d 70 72 65 76 2d 6c 69 6e 6b me get-prev-link
a280: 73 20 67 65 74 2d 6e 65 78 74 2d 6c 69 6e 6b 73 s get-next-links
a290: 20 23 74 20 22 25 22 20 74 61 72 67 65 74 2d 70 #t "%" target-p
a2a0: 61 74 74 29 29 29 20 3b 3b 20 75 70 64 61 74 65 att))) ;; update
a2b0: 20 74 69 73 20 66 75 6e 63 74 69 6f 6e 0a 20 20 tis function.
a2c0: 20 20 20 20 20 20 68 74 6d 6c 2d 62 6f 64 79 29 html-body)
a2d0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 )..(define (test
a2e0: 73 3a 63 72 65 61 74 65 2d 68 74 6d 6c 2d 73 75 s:create-html-su
a2f0: 6d 6d 61 72 79 20 6f 75 74 66 29 0a 20 28 6c 65 mmary outf). (le
a300: 74 2a 20 28 28 6c 6f 63 6b 66 69 6c 65 20 20 28 t* ((lockfile (
a310: 63 6f 6e 63 20 6f 75 74 66 20 22 2e 6c 6f 63 6b conc outf ".lock
a320: 22 29 29 0a 20 20 20 20 20 20 20 20 28 6c 69 6e ")). (lin
a330: 6b 74 72 65 65 20 20 28 63 6f 6d 6d 6f 6e 3a 67 ktree (common:g
a340: 65 74 2d 6c 69 6e 6b 74 72 65 65 29 29 0a 09 09 et-linktree))...
a350: 09 09 28 6b 65 79 73 20 20 20 20 20 20 28 72 6d ..(keys (rm
a360: 74 3a 67 65 74 2d 6b 65 79 73 29 29 0a 20 20 20 t:get-keys)).
a370: 20 20 20 20 20 28 61 72 65 61 2d 6e 61 6d 65 20 (area-name
a380: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 74 65 73 74 (common:get-test
a390: 73 75 69 74 65 2d 6e 61 6d 65 29 29 0a 20 20 20 suite-name)).
a3a0: 20 20 20 20 20 28 72 75 6e 2d 70 61 74 74 20 28 (run-patt (
a3b0: 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 or (args:get-arg
a3c0: 20 22 2d 72 75 6e 2d 70 61 74 74 22 29 0a 20 20 "-run-patt").
a3d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a3e0: 20 20 20 20 20 20 28 61 72 67 73 3a 67 65 74 2d (args:get-
a3f0: 61 72 67 20 22 2d 72 75 6e 6e 61 6d 65 22 29 0a arg "-runname").
a400: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a410: 20 20 20 20 20 20 20 20 22 25 22 29 29 0a 20 20 "%")).
a420: 20 20 20 20 20 20 28 74 61 72 67 65 74 20 28 6f (target (o
a430: 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 r (args:get-arg
a440: 22 2d 74 61 72 67 65 74 2d 70 61 74 74 22 29 0a "-target-patt").
a450: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a460: 20 20 20 20 20 20 20 20 28 61 72 67 73 3a 67 65 (args:ge
a470: 74 2d 61 72 67 20 22 2d 74 61 72 67 65 74 22 29 t-arg "-target")
a480: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
a490: 20 20 20 20 20 20 20 20 20 22 25 22 29 29 0a 20 "%")).
a4a0: 20 20 20 20 20 20 20 20 28 74 61 72 67 6c 69 73 (targlis
a4b0: 74 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 t (string-split
a4c0: 74 61 72 67 65 74 20 22 2f 22 29 29 0a 20 20 20 target "/")).
a4d0: 20 20 20 20 20 20 28 6e 75 6d 6b 65 79 73 20 20 (numkeys
a4e0: 28 6c 65 6e 67 74 68 20 6b 65 79 73 29 29 0a 09 (length keys))..
a4f0: 20 20 20 20 20 20 20 28 6e 75 6d 74 61 72 67 20 (numtarg
a500: 20 28 6c 65 6e 67 74 68 20 74 61 72 67 6c 69 73 (length targlis
a510: 74 29 29 20 20 0a 20 20 20 20 20 20 20 20 20 28 t)) . (
a520: 74 61 72 67 74 77 65 61 6b 65 64 20 28 69 66 20 targtweaked (if
a530: 28 3e 20 6e 75 6d 6b 65 79 73 20 6e 75 6d 74 61 (> numkeys numta
a540: 72 67 29 0a 09 09 09 20 20 20 09 09 09 09 09 09 rg).... ......
a550: 09 09 28 61 70 70 65 6e 64 20 74 61 72 67 6c 69 ..(append targli
a560: 73 74 20 28 6d 61 6b 65 2d 6c 69 73 74 20 28 2d st (make-list (-
a570: 20 6e 75 6d 6b 65 79 73 20 6e 75 6d 74 61 72 67 numkeys numtarg
a580: 29 20 22 25 22 29 29 0a 09 09 09 20 20 09 09 09 ) "%")).... ...
a590: 09 09 09 09 09 74 61 72 67 6c 69 73 74 29 29 0a .....targlist)).
a5a0: 20 20 20 20 20 20 20 20 28 74 61 72 67 65 74 2d (target-
a5b0: 70 61 74 74 20 28 73 74 72 69 6e 67 2d 6a 6f 69 patt (string-joi
a5c0: 6e 20 74 61 72 67 74 77 65 61 6b 65 64 20 22 2f n targtweaked "/
a5d0: 22 29 29 29 0a 20 20 20 20 28 69 66 20 28 63 6f "))). (if (co
a5e0: 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 mmon:simple-file
a5f0: 2d 6c 6f 63 6b 20 6c 6f 63 6b 66 69 6c 65 29 0a -lock lockfile).
a600: 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 (begin.
a610: 20 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 (let* (
a620: 3b 28 72 75 6e 73 64 61 74 31 20 20 20 28 72 6d ;(runsdat1 (rm
a630: 74 3a 67 65 74 2d 72 75 6e 73 20 72 75 6e 2d 70 t:get-runs run-p
a640: 61 74 74 20 23 66 20 23 66 20 28 6d 61 70 20 28 att #f #f (map (
a650: 6c 61 6d 62 64 61 20 28 78 29 28 6c 69 73 74 20 lambda (x)(list
a660: 78 20 22 25 22 29 29 20 6b 65 79 73 29 29 29 0a x "%")) keys))).
a670: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a680: 20 28 72 75 6e 73 64 61 74 20 20 20 28 72 6d 74 (runsdat (rmt
a690: 3a 67 65 74 2d 72 75 6e 73 2d 62 79 2d 70 61 74 :get-runs-by-pat
a6a0: 74 20 20 6b 65 79 73 20 72 75 6e 2d 70 61 74 74 t keys run-patt
a6b0: 20 74 61 72 67 65 74 2d 70 61 74 74 20 23 66 20 target-patt #f
a6c0: 23 66 20 23 66 20 30 29 29 0a 09 09 09 09 09 20 #f #f 0))......
a6d0: 20 20 20 20 20 20 28 72 75 6e 73 20 20 20 20 20 (runs
a6e0: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e (vector-ref run
a6f0: 73 64 61 74 20 31 29 29 0a 20 20 20 20 20 20 20 sdat 1)).
a700: 20 20 20 20 20 20 20 20 20 20 28 68 65 61 64 65 (heade
a710: 72 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 r (vector-r
a720: 65 66 20 72 75 6e 73 64 61 74 20 30 29 29 0a 20 ef runsdat 0)).
a730: 20 20 20 20 20 20 20 09 20 20 20 20 20 20 20 28 . (
a740: 6f 75 70 20 20 20 20 20 20 20 28 6f 70 65 6e 2d oup (open-
a750: 6f 75 74 70 75 74 2d 66 69 6c 65 20 28 6f 72 20 output-file (or
a760: 6f 75 74 66 20 28 63 6f 6e 63 20 6c 69 6e 6b 74 outf (conc linkt
a770: 72 65 65 20 22 2f 74 61 72 67 65 74 73 2e 68 74 ree "/targets.ht
a780: 6d 6c 22 29 29 29 29 0a 20 20 20 20 20 20 20 20 ml")))).
a790: 20 20 20 20 20 20 20 20 20 28 74 61 72 67 65 74 (target
a7a0: 2d 68 61 73 68 20 28 74 65 73 74 3a 63 72 65 61 -hash (test:crea
a7b0: 74 65 2d 74 61 72 67 65 74 2d 68 61 73 68 20 72 te-target-hash r
a7c0: 75 6e 73 20 68 65 61 64 65 72 20 28 6c 65 6e 67 uns header (leng
a7d0: 74 68 20 6b 65 79 73 29 29 29 29 0a 20 20 20 20 th keys)))).
a7e0: 20 20 20 20 20 20 20 28 74 65 73 74 3a 63 72 65 (test:cre
a7f0: 61 74 65 2d 74 61 72 67 65 74 2d 68 74 6d 6c 20 ate-target-html
a800: 74 61 72 67 65 74 2d 68 61 73 68 20 6f 75 70 20 target-hash oup
a810: 61 72 65 61 2d 6e 61 6d 65 20 6c 69 6e 6b 74 72 area-name linktr
a820: 65 65 29 0a 20 20 20 20 20 20 20 20 20 20 28 74 ee). (t
a830: 65 73 74 3a 63 72 65 61 74 65 2d 72 75 6e 2d 68 est:create-run-h
a840: 74 6d 6c 20 20 72 75 6e 73 20 61 72 65 61 2d 6e tml runs area-n
a850: 61 6d 65 20 6c 69 6e 6b 74 72 65 65 20 28 6c 65 ame linktree (le
a860: 6e 67 74 68 20 6b 65 79 73 29 20 68 65 61 64 65 ngth keys) heade
a870: 72 29 29 0a 09 20 20 28 63 6f 6d 6d 6f 6e 3a 73 r)).. (common:s
a880: 69 6d 70 6c 65 2d 66 69 6c 65 2d 72 65 6c 65 61 imple-file-relea
a890: 73 65 2d 6c 6f 63 6b 20 6c 6f 63 6b 66 69 6c 65 se-lock lockfile
a8a0: 29 29 0a 09 23 66 29 29 29 0a 0a 28 64 65 66 69 ))..#f)))..(defi
a8b0: 6e 65 20 28 74 65 73 74 3a 67 65 74 2d 74 65 73 ne (test:get-tes
a8c0: 74 2d 68 61 73 68 20 74 65 73 74 2d 64 61 74 61 t-hash test-data
a8d0: 29 0a 09 28 6c 65 74 20 28 28 72 65 73 68 20 28 )..(let ((resh (
a8e0: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
a8f0: 29 29 0a 20 20 20 20 09 28 6d 61 70 20 28 6c 61 )). .(map (la
a900: 6d 62 64 61 20 28 74 65 73 74 29 0a 20 20 20 20 mbda (test).
a910: 20 20 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 (let* ((test
a920: 2d 6e 61 6d 65 20 28 76 65 63 74 6f 72 2d 72 65 -name (vector-re
a930: 66 20 74 65 73 74 20 32 29 29 0a 20 20 20 20 20 f test 2)).
a940: 20 20 20 20 20 20 20 20 20 20 28 74 65 73 74 2d (test-
a950: 68 74 6d 6c 2d 70 61 74 68 20 28 69 66 20 28 66 html-path (if (f
a960: 69 6c 65 2d 65 78 69 73 74 73 3f 20 28 63 6f 6e ile-exists? (con
a970: 63 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 65 c (vector-ref te
a980: 73 74 20 31 30 29 20 22 2f 74 65 73 74 2d 73 75 st 10) "/test-su
a990: 6d 6d 61 72 79 2e 68 74 6d 6c 22 29 29 0a 09 09 mmary.html"))...
a9a0: 09 09 09 09 09 09 09 09 09 09 09 09 09 09 20 28 .............. (
a9b0: 63 6f 6e 63 20 28 76 65 63 74 6f 72 2d 72 65 66 conc (vector-ref
a9c0: 20 74 65 73 74 20 31 30 29 20 22 2f 74 65 73 74 test 10) "/test
a9d0: 2d 73 75 6d 6d 61 72 79 2e 68 74 6d 6c 22 20 29 -summary.html" )
a9e0: 0a 09 09 09 09 09 09 09 20 09 09 09 09 09 09 09 ........ .......
a9f0: 09 09 20 28 63 6f 6e 63 20 28 76 65 63 74 6f 72 .. (conc (vector
aa00: 2d 72 65 66 20 74 65 73 74 20 31 30 29 20 22 2f -ref test 10) "/
aa10: 22 20 28 76 65 63 74 6f 72 2d 72 65 66 20 74 65 " (vector-ref te
aa20: 73 74 20 31 33 29 29 29 29 0a 20 20 20 20 20 20 st 13)))).
aa30: 20 20 20 20 20 20 20 20 20 28 74 65 73 74 2d 69 (test-i
aa40: 74 65 6d 20 20 28 76 65 63 74 6f 72 2d 72 65 66 tem (vector-ref
aa50: 20 74 65 73 74 20 31 31 29 29 0a 20 20 20 20 20 test 11)).
aa60: 20 20 20 20 20 20 20 20 20 20 28 74 65 73 74 2d (test-
aa70: 73 74 61 74 75 73 20 28 76 65 63 74 6f 72 2d 72 status (vector-r
aa80: 65 66 20 74 65 73 74 20 34 29 29 29 0a 20 20 20 ef test 4))).
aa90: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
aaa0: 28 6e 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 (not (hash-table
aab0: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 72 65 73 -ref/default res
aac0: 68 20 74 65 73 74 2d 69 74 65 6d 20 20 23 66 29 h test-item #f)
aad0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
aae0: 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
aaf0: 2d 73 65 74 21 20 72 65 73 68 20 74 65 73 74 2d -set! resh test-
ab00: 69 74 65 6d 20 20 20 28 6d 61 6b 65 2d 68 61 73 item (make-has
ab10: 68 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 20 20 h-table))).
ab20: 20 20 20 20 20 20 20 20 20 20 28 68 61 73 68 2d (hash-
ab30: 74 61 62 6c 65 2d 73 65 74 21 20 28 68 61 73 68 table-set! (hash
ab40: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
ab50: 6c 74 20 72 65 73 68 20 74 65 73 74 2d 69 74 65 lt resh test-ite
ab60: 6d 20 20 23 66 29 20 74 65 73 74 2d 6e 61 6d 65 m #f) test-name
ab70: 20 28 6c 69 73 74 20 74 65 73 74 2d 73 74 61 74 (list test-stat
ab80: 75 73 20 74 65 73 74 2d 68 74 6d 6c 2d 70 61 74 us test-html-pat
ab90: 68 29 29 29 29 20 0a 20 20 20 20 20 20 20 20 74 h)))) . t
aba0: 65 73 74 2d 64 61 74 61 29 0a 72 65 73 68 29 29 est-data).resh))
abb0: 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 3a ..(define (test:
abc0: 67 65 74 2d 64 61 74 61 2d 3e 62 2d 6b 65 79 73 get-data->b-keys
abd0: 20 6f 72 64 65 72 65 64 2d 64 61 74 61 20 61 2d ordered-data a-
abe0: 6b 65 79 73 29 0a 20 20 28 64 65 6c 65 74 65 2d keys). (delete-
abf0: 64 75 70 6c 69 63 61 74 65 73 0a 20 20 20 28 73 duplicates. (s
ac00: 6f 72 74 20 28 61 70 70 6c 79 0a 09 20 20 61 70 ort (apply.. ap
ac10: 70 65 6e 64 0a 09 20 20 28 6d 61 70 20 28 6c 61 pend.. (map (la
ac20: 6d 62 64 61 20 28 73 75 62 2d 6b 65 79 29 0a 09 mbda (sub-key)..
ac30: 09 20 28 6c 65 74 20 28 28 73 75 62 64 61 74 20 . (let ((subdat
ac40: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 (hash-table-ref
ac50: 6f 72 64 65 72 65 64 2d 64 61 74 61 20 73 75 62 ordered-data sub
ac60: 2d 6b 65 79 29 29 29 0a 09 09 20 20 20 28 68 61 -key)))... (ha
ac70: 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 73 75 sh-table-keys su
ac80: 62 64 61 74 29 29 29 0a 09 20 20 20 20 20 20 20 bdat)))..
ac90: 61 2d 6b 65 79 73 29 29 0a 09 20 73 74 72 69 6e a-keys)).. strin
aca0: 67 3e 3d 3f 29 29 29 0a 0a 0a 28 64 65 66 69 6e g>=?)))...(defin
acb0: 65 20 28 74 65 73 74 3a 63 72 65 61 74 65 2d 72 e (test:create-r
acc0: 75 6e 2d 68 74 6d 6c 20 72 75 6e 73 20 61 72 65 un-html runs are
acd0: 61 2d 6e 61 6d 65 20 6c 69 6e 6b 74 72 65 65 20 a-name linktree
ace0: 6e 75 6d 6b 65 79 73 20 68 65 61 64 65 72 29 0a numkeys header).
acf0: 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 (map (lambda (
ad00: 72 75 6e 29 0a 09 09 20 28 6c 65 74 2a 20 28 28 run)... (let* ((
ad10: 74 61 72 67 65 74 20 28 73 74 72 69 6e 67 2d 6a target (string-j
ad20: 6f 69 6e 20 28 74 61 6b 65 20 28 76 65 63 74 6f oin (take (vecto
ad30: 72 2d 3e 6c 69 73 74 20 72 75 6e 29 20 6e 75 6d r->list run) num
ad40: 6b 65 79 73 29 20 22 2f 22 29 29 0a 09 09 09 09 keys) "/")).....
ad50: 09 09 28 72 75 6e 2d 6e 61 6d 65 20 28 64 62 3a ..(run-name (db:
ad60: 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 get-value-by-hea
ad70: 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 der run header "
ad80: 72 75 6e 6e 61 6d 65 22 29 29 0a 20 20 20 20 20 runname")).
ad90: 20 20 20 20 20 20 20 28 72 75 6e 2d 74 69 6d 65 (run-time
ada0: 20 28 73 65 63 6f 6e 64 73 2d 3e 77 6f 72 6b 2d (seconds->work-
adb0: 77 65 65 6b 2f 64 61 79 2d 74 69 6d 65 20 28 64 week/day-time (d
adc0: 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 b:get-value-by-h
add0: 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 eader run header
ade0: 20 22 65 76 65 6e 74 5f 74 69 6d 65 22 29 29 29 "event_time")))
adf0: 0a 09 09 09 09 09 09 28 6f 75 70 20 28 69 66 20 .......(oup (if
ae00: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 28 63 (file-exists? (c
ae10: 6f 6e 63 20 6c 69 6e 6b 74 72 65 65 20 22 2f 22 onc linktree "/"
ae20: 20 74 61 72 67 65 74 20 22 2f 22 20 72 75 6e 2d target "/" run-
ae30: 6e 61 6d 65 29 29 0a 20 20 20 20 20 20 20 20 20 name)).
ae40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
ae50: 6f 70 65 6e 2d 6f 75 74 70 75 74 2d 66 69 6c 65 open-output-file
ae60: 20 28 63 6f 6e 63 20 6c 69 6e 6b 74 72 65 65 20 (conc linktree
ae70: 22 2f 22 20 74 61 72 67 65 74 20 22 2f 22 20 72 "/" target "/" r
ae80: 75 6e 2d 6e 61 6d 65 20 22 2f 72 75 6e 2e 68 74 un-name "/run.ht
ae90: 6d 6c 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 ml")).
aea0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 23 #
aeb0: 66 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 f)).
aec0: 28 72 75 6e 2d 69 64 20 28 64 62 3a 67 65 74 2d (run-id (db:get-
aed0: 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 value-by-header
aee0: 72 75 6e 20 68 65 61 64 65 72 20 22 69 64 22 29 run header "id")
aef0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 74 ). (t
af00: 65 73 74 2d 64 61 74 61 20 20 20 20 28 72 6d 74 est-data (rmt
af10: 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 :get-tests-for-r
af20: 75 6e 0a 09 09 09 09 20 20 09 09 09 09 09 09 09 un..... .......
af30: 09 20 72 75 6e 2d 69 64 0a 20 20 20 20 20 20 20 . run-id.
af40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
af50: 20 20 20 20 22 25 22 20 20 20 20 20 20 20 3b 3b "%" ;;
af60: 20 74 65 73 74 6e 61 6d 65 70 61 74 74 0a 09 09 testnamepatt...
af70: 09 09 20 20 09 09 09 09 09 09 09 09 20 27 28 29 .. ........ '()
af80: 20 20 20 20 20 20 20 20 3b 3b 20 73 74 61 74 65 ;; state
af90: 73 0a 09 09 09 09 20 20 20 09 09 09 09 09 09 09 s..... .......
afa0: 09 20 27 28 29 20 20 20 20 20 20 20 20 3b 3b 20 . '() ;;
afb0: 73 74 61 74 75 73 65 73 0a 09 09 09 09 20 20 09 statuses..... .
afc0: 09 09 09 09 09 09 09 20 09 23 66 20 20 20 20 20 ....... .#f
afd0: 20 20 20 20 3b 3b 20 6f 66 66 73 65 74 0a 09 09 ;; offset...
afe0: 09 09 20 20 09 09 09 09 09 09 20 09 09 09 23 66 .. ...... ...#f
aff0: 20 20 20 20 20 20 20 20 20 3b 3b 20 6e 75 6d 2d ;; num-
b000: 74 6f 2d 67 65 74 0a 09 09 09 09 20 20 20 09 09 to-get..... ..
b010: 09 09 09 09 09 09 09 23 66 20 20 20 20 20 20 20 .......#f
b020: 20 20 3b 3b 20 68 69 64 65 2f 6e 6f 74 2d 68 69 ;; hide/not-hi
b030: 64 65 0a 09 09 09 09 20 20 09 09 09 09 09 09 09 de..... .......
b040: 09 20 20 23 66 20 20 20 20 20 20 20 20 20 3b 3b . #f ;;
b050: 20 73 6f 72 74 2d 62 79 0a 09 09 09 09 20 20 20 sort-by.....
b060: 09 09 09 09 09 09 09 09 09 23 66 20 20 20 20 20 .........#f
b070: 20 20 20 20 3b 3b 20 73 6f 72 74 2d 6f 72 64 65 ;; sort-orde
b080: 72 0a 09 09 09 09 20 20 20 09 09 09 09 09 09 09 r..... .......
b090: 09 09 23 66 20 20 20 20 20 20 20 20 20 3b 3b 20 ..#f ;;
b0a0: 27 73 68 6f 72 74 6c 69 73 74 20 20 20 20 20 20 'shortlist
b0b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b0c0: 20 20 20 20 20 3b 3b 20 71 72 79 74 79 70 65 0a ;; qrytype.
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 30 20 20 20 0
b0f0: 20 20 20 20 20 20 3b 3b 20 6c 61 73 74 20 75 70 ;; last up
b100: 64 61 74 65 0a 09 09 09 09 20 20 09 09 09 09 09 date..... .....
b110: 09 09 09 09 23 66 29 29 0a 20 20 20 20 20 20 20 ....#f)).
b120: 20 20 20 20 20 28 69 74 65 6d 2d 74 65 73 74 2d (item-test-
b130: 68 61 73 68 20 28 74 65 73 74 3a 67 65 74 2d 74 hash (test:get-t
b140: 65 73 74 2d 68 61 73 68 20 74 65 73 74 2d 64 61 est-hash test-da
b150: 74 61 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 ta)).
b160: 20 28 69 74 65 6d 73 20 20 28 68 61 73 68 2d 74 (items (hash-t
b170: 61 62 6c 65 2d 6b 65 79 73 20 69 74 65 6d 2d 74 able-keys item-t
b180: 65 73 74 2d 68 61 73 68 29 29 0a 20 09 09 09 09 est-hash)). ....
b190: 09 09 28 74 65 73 74 2d 6e 61 6d 65 73 20 28 74 ..(test-names (t
b1a0: 65 73 74 3a 67 65 74 2d 64 61 74 61 2d 3e 62 2d est:get-data->b-
b1b0: 6b 65 79 73 20 69 74 65 6d 2d 74 65 73 74 2d 68 keys item-test-h
b1c0: 61 73 68 20 69 74 65 6d 73 29 29 29 0a 20 20 20 ash items))).
b1d0: 20 28 69 66 20 6f 75 70 0a 20 20 20 20 20 20 28 (if oup. (
b1e0: 62 65 67 69 6e 20 0a 20 20 20 20 20 28 73 3a 6f begin . (s:o
b1f0: 75 74 70 75 74 2d 6e 65 77 0a 09 20 20 20 6f 75 utput-new.. ou
b200: 70 0a 09 20 20 20 28 73 3a 68 74 6d 6c 20 74 65 p.. (s:html te
b210: 73 74 73 3a 63 73 73 2d 6a 73 63 72 69 70 74 2d sts:css-jscript-
b220: 62 6c 6f 63 6b 20 28 74 65 73 74 73 3a 63 73 73 block (tests:css
b230: 2d 6a 73 63 72 69 70 74 2d 62 6c 6f 63 6b 2d 63 -jscript-block-c
b240: 6f 6e 64 20 23 66 29 0a 09 09 20 20 20 28 73 3a ond #f)... (s:
b250: 74 69 74 6c 65 20 22 52 75 6e 73 20 56 69 65 77 title "Runs View
b260: 20 22 20 72 75 6e 2d 6e 61 6d 65 29 0a 09 09 20 " run-name)...
b270: 20 20 28 73 3a 62 6f 64 79 0a 09 09 20 20 20 20 (s:body...
b280: 20 28 73 3a 68 31 20 22 52 75 6e 73 20 56 69 65 (s:h1 "Runs Vie
b290: 77 20 22 20 29 0a 20 20 20 20 20 20 20 20 20 28 w " ). (
b2a0: 73 3a 68 33 20 22 54 61 72 67 65 74 22 20 74 61 s:h3 "Target" ta
b2b0: 72 67 65 74 29 0a 09 09 09 09 20 28 73 3a 70 20 rget)..... (s:p
b2c0: 0a 09 09 09 09 09 28 73 3a 62 20 22 52 75 6e 20 ......(s:b "Run
b2d0: 6e 61 6d 65 22 20 29 20 72 75 6e 2d 6e 61 6d 65 name" ) run-name
b2e0: 29 0a 20 20 20 20 20 20 20 20 20 28 73 3a 70 20 ). (s:p
b2f0: 0a 09 09 09 09 09 28 73 3a 62 20 22 52 75 6e 20 ......(s:b "Run
b300: 44 61 74 65 22 20 29 20 72 75 6e 2d 74 69 6d 65 Date" ) run-time
b310: 29 0a 20 20 20 20 20 20 20 20 20 28 73 3a 74 61 ). (s:ta
b320: 62 6c 65 20 27 62 6f 72 64 65 72 20 31 20 27 63 ble 'border 1 'c
b330: 65 6c 6c 73 70 61 63 69 6e 67 20 30 0a 20 20 20 ellspacing 0.
b340: 20 20 20 20 20 20 20 20 28 73 3a 74 72 0a 20 20 (s:tr.
b350: 20 20 20 20 20 20 20 20 20 28 73 3a 74 68 20 22 (s:th "
b360: 49 74 65 6d 73 22 29 0a 20 20 20 20 20 20 20 20 Items").
b370: 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 (map (lambda
b380: 28 74 65 73 74 29 0a 20 20 20 20 20 20 20 20 20 (test).
b390: 20 20 20 28 73 3a 74 68 20 74 65 73 74 29 29 0a (s:th test)).
b3a0: 20 20 20 20 20 20 20 20 20 20 20 74 65 73 74 2d test-
b3b0: 6e 61 6d 65 73 29 29 20 20 0a 20 20 20 20 20 20 names)) .
b3c0: 20 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 (map (lambd
b3d0: 61 20 28 69 74 65 6d 29 20 0a 09 09 09 09 09 20 a (item) ......
b3e0: 20 28 6c 65 74 2a 20 28 28 74 65 73 74 2d 68 61 (let* ((test-ha
b3f0: 73 68 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 sh (hash-table-r
b400: 65 66 2f 64 65 66 61 75 6c 74 20 69 74 65 6d 2d ef/default item-
b410: 74 65 73 74 2d 68 61 73 68 20 69 74 65 6d 20 20 test-hash item
b420: 23 66 29 29 29 0a 09 09 09 09 09 09 09 09 20 28 #f)))......... (
b430: 69 66 20 74 65 73 74 2d 68 61 73 68 0a 20 20 20 if test-hash.
b440: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
b450: 62 65 67 69 6e 0a 09 09 09 09 09 09 09 09 09 28 begin..........(
b460: 73 3a 74 72 0a 09 09 09 09 09 20 20 09 09 09 28 s:tr...... ...(
b470: 73 3a 74 64 20 27 63 6c 61 73 73 20 22 74 65 73 s:td 'class "tes
b480: 74 22 20 69 74 65 6d 29 0a 20 20 20 20 20 20 20 t" item).
b490: 20 20 20 20 20 09 09 09 28 6d 61 70 20 28 6c 61 ...(map (la
b4a0: 6d 62 64 61 20 28 74 65 73 74 29 0a 09 09 09 09 mbda (test).....
b4b0: 09 09 20 20 09 09 28 6c 65 74 2a 20 28 28 74 65 .. ..(let* ((te
b4c0: 73 74 2d 64 65 74 61 69 6c 73 20 28 68 61 73 68 st-details (hash
b4d0: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
b4e0: 6c 74 20 74 65 73 74 2d 68 61 73 68 20 74 65 73 lt test-hash tes
b4f0: 74 20 20 23 66 29 29 0a 09 09 09 09 09 09 09 09 t #f)).........
b500: 09 09 09 09 28 73 74 61 74 75 73 20 28 69 66 20 ....(status (if
b510: 74 65 73 74 2d 64 65 74 61 69 6c 73 0a 09 09 09 test-details....
b520: 09 09 09 09 09 09 09 09 09 09 09 09 09 28 63 61 .............(ca
b530: 72 20 74 65 73 74 2d 64 65 74 61 69 6c 73 29 29 r test-details))
b540: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
b550: 20 20 20 20 20 20 20 20 20 20 28 6c 69 6e 6b 20 (link
b560: 28 69 66 20 74 65 73 74 2d 64 65 74 61 69 6c 73 (if test-details
b570: 20 0a 09 09 09 09 09 09 09 09 09 09 09 09 09 09 ...............
b580: 28 73 74 72 69 6e 67 2d 73 75 62 73 74 69 74 75 (string-substitu
b590: 74 65 20 20 28 63 6f 6e 63 20 6c 69 6e 6b 74 72 te (conc linktr
b5a0: 65 65 20 22 2f 22 20 74 61 72 67 65 74 20 22 2f ee "/" target "/
b5b0: 22 20 72 75 6e 2d 6e 61 6d 65 20 22 2f 22 29 20 " run-name "/")
b5c0: 20 22 22 20 28 63 61 64 72 20 74 65 73 74 2d 64 "" (cadr test-d
b5d0: 65 74 61 69 6c 73 29 20 22 2d 22 29 29 29 29 0a etails) "-")))).
b5e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b5f0: 20 20 20 28 69 66 20 74 65 73 74 2d 64 65 74 61 (if test-deta
b600: 69 6c 73 0a 09 09 09 09 09 09 09 09 09 09 09 28 ils............(
b610: 73 3a 74 64 20 27 63 6c 61 73 73 20 73 74 61 74 s:td 'class stat
b620: 75 73 0a 09 09 09 09 09 09 09 09 09 09 09 09 28 us.............(
b630: 73 3a 61 20 27 63 6c 61 73 73 20 22 6c 69 6e 6b s:a 'class "link
b640: 22 20 27 68 72 65 66 20 6c 69 6e 6b 20 73 74 61 " 'href link sta
b650: 74 75 73 20 29 29 0a 20 20 20 20 20 20 20 20 20 tus )).
b660: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 3a (s:
b670: 74 64 20 22 22 29 29 29 29 20 09 09 09 0a 09 09 td "")))) ......
b680: 09 09 09 09 09 09 09 74 65 73 74 2d 6e 61 6d 65 .......test-name
b690: 73 29 29 29 29 29 29 0a 09 09 09 09 20 20 28 73 s))))))..... (s
b6a0: 6f 72 74 20 69 74 65 6d 73 20 73 74 72 69 6e 67 ort items string
b6b0: 3c 3d 3f 29 29 29 29 29 29 0a 09 09 28 63 6c 6f <=?))))))...(clo
b6c0: 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 6f se-output-port o
b6d0: 75 70 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a up)). (debug:
b6e0: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 53 6b print-info 0 "Sk
b6f0: 69 70 3a 20 44 69 72 63 74 6f 72 79 20 73 74 72 ip: Dirctory str
b700: 75 63 74 75 72 65 20 22 20 6c 69 6e 6b 74 72 65 ucture " linktre
b710: 65 20 22 2f 22 20 74 61 72 67 65 74 20 22 2f 22 e "/" target "/"
b720: 20 72 75 6e 2d 6e 61 6d 65 20 22 20 64 6f 65 73 run-name " does
b730: 20 6e 6f 74 20 65 78 69 73 74 2e 20 4d 65 67 61 not exist. Mega
b740: 74 65 73 74 20 77 69 6c 6c 20 6e 6f 74 20 63 72 test will not cr
b750: 65 61 74 65 20 72 75 6e 2e 68 74 6d 6c 22 29 29 eate run.html"))
b760: 29 29 0a 72 75 6e 73 29 29 0a 0a 28 64 65 66 69 )).runs))..(defi
b770: 6e 65 20 28 74 65 73 74 3a 63 72 65 61 74 65 2d ne (test:create-
b780: 74 61 72 67 65 74 2d 68 61 73 68 20 72 75 6e 73 target-hash runs
b790: 20 68 65 61 64 65 72 20 6e 75 6d 6b 65 79 73 29 header numkeys)
b7a0: 0a 20 20 28 6c 65 74 20 28 28 72 65 73 68 20 28 . (let ((resh (
b7b0: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
b7c0: 29 29 0a 20 20 20 28 66 6f 72 2d 65 61 63 68 0a )). (for-each.
b7d0: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 72 75 (lambda (ru
b7e0: 6e 29 0a 20 20 20 20 20 20 20 20 28 6c 65 74 2a n). (let*
b7f0: 20 28 28 72 75 6e 2d 6e 61 6d 65 20 28 64 62 3a ((run-name (db:
b800: 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 get-value-by-hea
b810: 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 der run header "
b820: 72 75 6e 6e 61 6d 65 22 29 29 0a 20 20 20 20 20 runname")).
b830: 20 20 20 20 20 20 20 20 20 20 28 74 61 72 67 65 (targe
b840: 74 20 20 20 28 73 74 72 69 6e 67 2d 6a 6f 69 6e t (string-join
b850: 20 28 74 61 6b 65 20 28 76 65 63 74 6f 72 2d 3e (take (vector->
b860: 6c 69 73 74 20 72 75 6e 29 20 6e 75 6d 6b 65 79 list run) numkey
b870: 73 29 20 22 2f 22 29 29 0a 20 20 20 20 20 20 20 s) "/")).
b880: 20 20 20 20 20 20 20 20 28 72 75 6e 2d 6c 69 73 (run-lis
b890: 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 t (hash-table-re
b8a0: 66 2f 64 65 66 61 75 6c 74 20 72 65 73 68 20 74 f/default resh t
b8b0: 61 72 67 65 74 20 20 23 66 29 29 29 0a 20 20 20 arget #f))).
b8c0: 20 20 20 20 20 20 20 20 20 20 20 20 0a 20 20 20 .
b8d0: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
b8e0: 28 6e 6f 74 20 72 75 6e 2d 6c 69 73 74 29 0a 20 (not run-list).
b8f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b900: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
b910: 74 21 20 72 65 73 68 20 74 61 72 67 65 74 20 20 t! resh target
b920: 20 28 6c 69 73 74 20 72 75 6e 2d 6e 61 6d 65 29 (list run-name)
b930: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
b940: 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
b950: 2d 73 65 74 21 20 72 65 73 68 20 74 61 72 67 65 -set! resh targe
b960: 74 20 20 20 28 63 6f 6e 73 20 72 75 6e 2d 6e 61 t (cons run-na
b970: 6d 65 20 72 75 6e 2d 6c 69 73 74 29 29 29 29 29 me run-list)))))
b980: 0a 20 20 20 20 20 20 72 75 6e 73 29 0a 20 20 20 . runs).
b990: 72 65 73 68 29 29 0a 0a 28 64 65 66 69 6e 65 20 resh))..(define
b9a0: 28 74 65 73 74 3a 67 65 74 2d 6d 61 78 2d 72 75 (test:get-max-ru
b9b0: 6e 2d 63 6e 74 20 74 61 72 67 65 74 2d 68 61 73 n-cnt target-has
b9c0: 68 20 74 61 72 67 65 74 73 29 0a 20 20 20 28 6c h targets). (l
b9d0: 65 74 2a 20 28 28 63 6e 74 20 30 20 29 29 0a 20 et* ((cnt 0 )).
b9e0: 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 (map (lambda (
b9f0: 74 61 72 67 65 74 29 0a 20 20 20 20 20 20 20 20 target).
ba00: 28 6c 65 74 2a 20 28 28 72 75 6e 73 20 20 28 68 (let* ((runs (h
ba10: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
ba20: 66 61 75 6c 74 20 74 61 72 67 65 74 2d 68 61 73 fault target-has
ba30: 68 20 74 61 72 67 65 74 20 20 23 66 29 29 0a 20 h target #f)).
ba40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 (r
ba50: 75 6e 2d 6c 65 6e 67 74 68 20 28 69 66 20 72 75 un-length (if ru
ba60: 6e 73 0a 09 09 09 09 09 09 09 09 09 09 09 09 09 ns..............
ba70: 09 09 09 28 6c 65 6e 67 74 68 20 72 75 6e 73 29 ...(length runs)
ba80: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
ba90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
baa0: 20 20 30 29 29 29 0a 20 20 0a 20 20 20 20 20 20 0))). .
bab0: 20 20 20 20 20 20 20 20 28 69 66 20 28 3c 20 63 (if (< c
bac0: 6e 74 20 72 75 6e 2d 6c 65 6e 67 74 68 29 0a 20 nt run-length).
bad0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s
bae0: 65 74 21 20 63 6e 74 20 20 72 75 6e 2d 6c 65 6e et! cnt run-len
baf0: 67 74 68 29 29 29 29 20 0a 09 09 74 61 72 67 65 gth)))) ...targe
bb00: 74 73 29 20 0a 63 6e 74 29 29 0a 20 0a 28 64 65 ts) .cnt)). .(de
bb10: 66 69 6e 65 20 28 74 65 73 74 3a 70 61 64 2d 72 fine (test:pad-r
bb20: 75 6e 73 20 74 61 72 67 65 74 2d 68 61 73 68 20 uns target-hash
bb30: 74 61 72 67 65 74 73 20 6d 61 78 2d 72 6f 77 2d targets max-row-
bb40: 6c 65 6e 67 74 68 29 0a 20 28 6d 61 70 20 28 6c length). (map (l
bb50: 61 6d 62 64 61 20 28 74 61 72 67 65 74 29 0a 20 ambda (target).
bb60: 20 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 (let loop
bb70: 20 28 28 72 75 6e 2d 6c 69 73 74 20 20 28 68 61 ((run-list (ha
bb80: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
bb90: 61 75 6c 74 20 74 61 72 67 65 74 2d 68 61 73 68 ault target-hash
bba0: 20 74 61 72 67 65 74 20 20 23 66 29 29 29 0a 20 target #f))).
bbb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i
bbc0: 66 20 28 3c 20 28 6c 65 6e 67 74 68 20 72 75 6e f (< (length run
bbd0: 2d 6c 69 73 74 29 20 6d 61 78 2d 72 6f 77 2d 6c -list) max-row-l
bbe0: 65 6e 67 74 68 29 0a 20 20 20 20 20 20 20 20 20 ength).
bbf0: 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 20 20 (begin
bc00: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
bc10: 09 09 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 .. (hash-table-s
bc20: 65 74 21 20 74 61 72 67 65 74 2d 68 61 73 68 20 et! target-hash
bc30: 74 61 72 67 65 74 20 20 20 28 63 6f 6e 73 20 22 target (cons "
bc40: 22 20 72 75 6e 2d 6c 69 73 74 29 29 0a 20 20 20 " run-list)).
bc50: 20 20 20 20 20 20 20 20 20 20 20 20 09 09 20 28 .. (
bc60: 6c 6f 6f 70 20 28 68 61 73 68 2d 74 61 62 6c 65 loop (hash-table
bc70: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 61 72 -ref/default tar
bc80: 67 65 74 2d 68 61 73 68 20 74 61 72 67 65 74 20 get-hash target
bc90: 20 23 66 29 20 29 29 29 29 29 20 0a 09 09 74 61 #f) ))))) ...ta
bca0: 72 67 65 74 73 29 0a 20 20 20 74 61 72 67 65 74 rgets). target
bcb0: 2d 68 61 73 68 29 0a 0a 28 64 65 66 69 6e 65 20 -hash)..(define
bcc0: 28 74 65 73 74 3a 63 72 65 61 74 65 2d 74 61 72 (test:create-tar
bcd0: 67 65 74 2d 68 74 6d 6c 20 74 61 72 67 65 74 2d get-html target-
bce0: 68 61 73 68 20 6f 75 70 20 61 72 65 61 2d 6e 61 hash oup area-na
bcf0: 6d 65 20 6c 69 6e 6b 74 72 65 65 29 0a 20 20 28 me linktree). (
bd00: 6c 65 74 2a 20 28 28 74 61 72 67 65 74 73 20 28 let* ((targets (
bd10: 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 hash-table-keys
bd20: 74 61 72 67 65 74 2d 68 61 73 68 29 29 0a 20 20 target-hash)).
bd30: 20 20 20 20 20 20 20 28 6d 61 78 2d 72 6f 77 2d (max-row-
bd40: 6c 65 6e 67 74 68 20 28 74 65 73 74 3a 67 65 74 length (test:get
bd50: 2d 6d 61 78 2d 72 75 6e 2d 63 6e 74 20 74 61 72 -max-run-cnt tar
bd60: 67 65 74 2d 68 61 73 68 20 74 61 72 67 65 74 73 get-hash targets
bd70: 29 29 0a 20 20 20 20 20 20 20 20 20 28 70 61 64 )). (pad
bd80: 2d 72 75 6e 73 2d 68 61 73 68 20 28 74 65 73 74 -runs-hash (test
bd90: 3a 70 61 64 2d 72 75 6e 73 20 74 61 72 67 65 74 :pad-runs target
bda0: 2d 68 61 73 68 20 74 61 72 67 65 74 73 20 6d 61 -hash targets ma
bdb0: 78 2d 72 6f 77 2d 6c 65 6e 67 74 68 29 29 29 0a x-row-length))).
bdc0: 20 20 20 28 73 3a 6f 75 74 70 75 74 2d 6e 65 77 (s:output-new
bdd0: 0a 09 20 20 20 6f 75 70 0a 09 20 20 20 28 73 3a .. oup.. (s:
bde0: 68 74 6d 6c 20 74 65 73 74 73 3a 63 73 73 2d 6a html tests:css-j
bdf0: 73 63 72 69 70 74 2d 62 6c 6f 63 6b 20 28 74 65 script-block (te
be00: 73 74 73 3a 63 73 73 2d 6a 73 63 72 69 70 74 2d sts:css-jscript-
be10: 62 6c 6f 63 6b 2d 63 6f 6e 64 20 23 66 29 0a 0a block-cond #f)..
be20: 09 09 20 20 20 28 73 3a 74 69 74 6c 65 20 22 54 .. (s:title "T
be30: 61 72 67 65 74 20 56 69 65 77 20 22 20 61 72 65 arget View " are
be40: 61 2d 6e 61 6d 65 29 0a 09 09 20 20 20 28 73 3a a-name)... (s:
be50: 62 6f 64 79 0a 09 09 20 20 20 28 73 3a 68 31 20 body... (s:h1
be60: 22 54 61 72 67 65 74 20 56 69 65 77 20 22 20 61 "Target View " a
be70: 72 65 61 2d 6e 61 6d 65 29 0a 09 09 09 09 09 28 rea-name)......(
be80: 73 3a 74 61 62 6c 65 20 27 69 64 20 22 4c 69 6e s:table 'id "Lin
be90: 6b 65 64 4c 69 73 74 31 22 20 27 62 6f 72 64 65 kedList1" 'borde
bea0: 72 20 22 31 22 20 27 63 65 6c 6c 73 70 61 63 69 r "1" 'cellspaci
beb0: 6e 67 20 30 0a 20 20 20 20 20 20 20 20 20 20 20 ng 0.
bec0: 20 20 28 73 3a 74 72 20 27 63 6c 61 73 73 20 22 (s:tr 'class "
bed0: 73 6f 6d 65 74 68 69 6e 67 22 20 0a 20 20 20 20 something" .
bee0: 20 20 20 20 20 20 20 20 20 20 20 28 73 3a 74 68 (s:th
bef0: 20 22 54 61 72 67 65 74 22 29 0a 09 09 09 09 09 "Target")......
bf00: 09 09 09 28 73 3a 74 68 20 27 63 6f 6c 73 70 61 ...(s:th 'colspa
bf10: 6e 20 6d 61 78 2d 72 6f 77 2d 6c 65 6e 67 74 68 n max-row-length
bf20: 20 22 52 75 6e 73 22 29 29 20 20 20 20 20 20 20 "Runs"))
bf30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bf40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bf50: 20 20 20 20 20 20 20 0a 20 20 20 20 20 20 20 20 .
bf60: 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 (let* ((
bf70: 74 62 6c 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 tbl (map (lambda
bf80: 20 28 74 61 72 67 65 74 29 0a 20 20 20 20 20 20 (target).
bf90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bfa0: 28 73 3a 74 72 0a 20 20 20 20 20 20 20 20 20 20 (s:tr.
bfb0: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 3a 74 (s:t
bfc0: 64 20 27 63 6c 61 73 73 20 22 74 65 73 74 22 20 d 'class "test"
bfd0: 74 61 72 67 65 74 29 0a 09 09 09 09 09 09 09 09 target).........
bfe0: 09 09 20 20 28 6c 65 74 2a 20 28 28 72 75 6e 73 .. (let* ((runs
bff0: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 (hash-table-re
c000: 66 2f 64 65 66 61 75 6c 74 20 74 61 72 67 65 74 f/default target
c010: 2d 68 61 73 68 20 74 61 72 67 65 74 20 20 23 66 -hash target #f
c020: 29 29 0a 09 09 09 09 09 09 09 09 09 09 09 09 09 ))..............
c030: 09 20 28 72 65 73 74 2d 72 6f 77 20 28 6d 61 70 . (rest-row (map
c040: 20 28 6c 61 6d 62 64 61 20 28 72 75 6e 29 0a 09 (lambda (run)..
c050: 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 ................
c060: 09 09 09 28 69 66 20 28 65 71 75 61 6c 3f 20 72 ...(if (equal? r
c070: 75 6e 20 22 22 29 0a 09 09 09 09 09 09 09 09 09 un "")..........
c080: 09 09 09 09 09 09 09 09 09 09 09 09 09 28 73 3a .............(s:
c090: 74 64 20 72 75 6e 29 0a 20 20 20 20 20 20 20 20 td run).
c0a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c0b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c0c0: 20 20 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 (if (file-ex
c0d0: 69 73 74 73 3f 28 63 6f 6e 63 20 6c 69 6e 6b 74 ists?(conc linkt
c0e0: 72 65 65 20 22 2f 22 20 74 61 72 67 65 74 20 22 ree "/" target "
c0f0: 2f 22 20 72 75 6e 20 29 29 0a 09 09 09 09 09 09 /" run )).......
c100: 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 ................
c110: 28 62 65 67 69 6e 20 0a 09 09 09 09 09 09 09 09 (begin .........
c120: 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 28 ...............(
c130: 73 3a 74 64 20 0a 09 09 09 09 09 09 09 09 09 09 s:td ...........
c140: 09 09 09 09 09 09 09 09 09 09 09 09 09 28 73 3a .............(s:
c150: 61 20 27 68 72 65 66 20 28 63 6f 6e 63 20 20 74 a 'href (conc t
c160: 61 72 67 65 74 20 22 2f 22 20 72 75 6e 20 22 2f arget "/" run "/
c170: 72 75 6e 2e 68 74 6d 6c 22 29 20 72 75 6e 29 29 run.html") run))
c180: 29 29 29 29 0a 09 09 09 09 09 09 09 09 09 09 09 ))))............
c190: 09 09 09 09 09 09 09 09 09 28 72 65 76 65 72 73 .........(revers
c1a0: 65 20 72 75 6e 73 29 29 29 29 0a 20 20 20 20 20 e runs)))).
c1b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c1c0: 20 20 20 20 20 20 20 20 20 72 65 73 74 2d 72 6f rest-ro
c1d0: 77 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 w))).
c1e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c1f0: 20 20 20 20 20 20 20 20 74 61 72 67 65 74 73 29 targets)
c200: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
c210: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 74 62 tb
c220: 6c 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 l))))).
c230: 20 28 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d 70 (close-output-p
c240: 6f 72 74 20 6f 75 70 29 29 29 0a 0a 0a 28 64 65 ort oup)))...(de
c250: 66 69 6e 65 20 28 74 65 73 74 73 3a 63 72 65 61 fine (tests:crea
c260: 74 65 2d 68 74 6d 6c 2d 74 72 65 65 2d 6f 6c 64 te-html-tree-old
c270: 20 6f 75 74 66 29 0a 20 20 20 28 6c 65 74 2a 20 outf). (let*
c280: 28 28 6c 6f 63 6b 66 69 6c 65 20 20 28 63 6f 6e ((lockfile (con
c290: 63 20 6f 75 74 66 20 22 2e 6c 6f 63 6b 22 29 29 c outf ".lock"))
c2a0: 0a 09 20 28 72 75 6e 73 2d 74 6f 2d 70 72 6f 63 .. (runs-to-proc
c2b0: 65 73 73 20 27 28 29 29 29 0a 20 20 20 20 28 69 ess '())). (i
c2c0: 66 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 f (common:simple
c2d0: 2d 66 69 6c 65 2d 6c 6f 63 6b 20 6c 6f 63 6b 66 -file-lock lockf
c2e0: 69 6c 65 29 0a 09 28 6c 65 74 2a 20 28 28 6c 69 ile)..(let* ((li
c2f0: 6e 6b 74 72 65 65 20 20 28 63 6f 6d 6d 6f 6e 3a nktree (common:
c300: 67 65 74 2d 6c 69 6e 6b 74 72 65 65 29 29 0a 09 get-linktree))..
c310: 20 20 20 20 20 20 20 28 6f 75 70 20 20 20 20 20 (oup
c320: 20 20 28 6f 70 65 6e 2d 6f 75 74 70 75 74 2d 66 (open-output-f
c330: 69 6c 65 20 28 6f 72 20 6f 75 74 66 20 28 63 6f ile (or outf (co
c340: 6e 63 20 6c 69 6e 6b 74 72 65 65 20 22 2f 72 75 nc linktree "/ru
c350: 6e 73 2d 69 6e 64 65 78 2e 68 74 6d 6c 22 29 29 ns-index.html"))
c360: 29 29 0a 09 20 20 20 20 20 20 20 28 61 72 65 61 )).. (area
c370: 2d 6e 61 6d 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 -name (common:ge
c380: 74 2d 74 65 73 74 73 75 69 74 65 2d 6e 61 6d 65 t-testsuite-name
c390: 29 29 0a 09 20 20 20 20 20 20 20 28 6b 65 79 73 )).. (keys
c3a0: 20 20 20 20 20 20 28 72 6d 74 3a 67 65 74 2d 6b (rmt:get-k
c3b0: 65 79 73 29 29 0a 09 20 20 20 20 20 20 20 28 6e eys)).. (n
c3c0: 75 6d 6b 65 79 73 20 20 20 28 6c 65 6e 67 74 68 umkeys (length
c3d0: 20 6b 65 79 73 29 29 0a 09 20 20 20 20 20 20 20 keys))..
c3e0: 28 72 75 6e 73 64 61 74 20 20 20 28 72 6d 74 3a (runsdat (rmt:
c3f0: 67 65 74 2d 72 75 6e 73 20 22 25 22 20 23 66 20 get-runs "%" #f
c400: 23 66 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 #f (map (lambda
c410: 28 78 29 28 6c 69 73 74 20 78 20 22 25 22 29 29 (x)(list x "%"))
c420: 20 6b 65 79 73 29 29 29 0a 09 20 20 20 20 20 20 keys)))..
c430: 20 28 68 65 61 64 65 72 20 20 20 20 28 76 65 63 (header (vec
c440: 74 6f 72 2d 72 65 66 20 72 75 6e 73 64 61 74 20 tor-ref runsdat
c450: 30 29 29 0a 09 20 20 20 20 20 20 20 28 72 75 6e 0)).. (run
c460: 73 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 s (vector-r
c470: 65 66 20 72 75 6e 73 64 61 74 20 31 29 29 0a 09 ef runsdat 1))..
c480: 20 20 20 20 20 20 20 28 72 75 6e 74 72 65 65 64 (runtreed
c490: 61 74 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 at (map (lambda
c4a0: 28 78 29 0a 09 09 09 09 20 20 28 74 65 73 74 73 (x)..... (tests
c4b0: 3a 72 75 6e 2d 72 65 63 6f 72 64 2d 3e 74 65 73 :run-record->tes
c4c0: 74 2d 70 61 74 68 20 78 20 6e 75 6d 6b 65 79 73 t-path x numkeys
c4d0: 29 29 0a 09 09 09 09 72 75 6e 73 29 29 0a 09 20 )).....runs))..
c4e0: 20 20 20 20 20 20 28 72 75 6e 73 2d 68 74 72 65 (runs-htre
c4f0: 65 20 28 63 6f 6d 6d 6f 6e 3a 6c 69 73 74 2d 3e e (common:list->
c500: 68 74 72 65 65 20 72 75 6e 74 72 65 65 64 61 74 htree runtreedat
c510: 29 29 29 0a 09 20 20 28 73 65 74 21 20 72 75 6e ))).. (set! run
c520: 73 2d 74 6f 2d 70 72 6f 63 65 73 73 20 72 75 6e s-to-process run
c530: 73 29 0a 09 20 20 28 73 3a 6f 75 74 70 75 74 2d s).. (s:output-
c540: 6e 65 77 0a 09 20 20 20 6f 75 70 0a 09 20 20 20 new.. oup..
c550: 28 73 3a 68 74 6d 6c 20 74 65 73 74 73 3a 63 73 (s:html tests:cs
c560: 73 2d 6a 73 63 72 69 70 74 2d 62 6c 6f 63 6b 0a s-jscript-block.
c570: 09 09 20 20 20 28 73 3a 74 69 74 6c 65 20 22 53 .. (s:title "S
c580: 75 6d 6d 61 72 79 20 66 6f 72 20 22 20 61 72 65 ummary for " are
c590: 61 2d 6e 61 6d 65 29 0a 09 09 20 20 20 28 73 3a a-name)... (s:
c5a0: 62 6f 64 79 20 27 6f 6e 6c 6f 61 64 20 22 61 64 body 'onload "ad
c5b0: 64 45 76 65 6e 74 73 28 29 3b 22 0a 09 09 09 20 dEvents();"....
c5c0: 20 20 28 73 3a 68 31 20 22 53 75 6d 6d 61 72 79 (s:h1 "Summary
c5d0: 20 66 6f 72 20 22 20 61 72 65 61 2d 6e 61 6d 65 for " area-name
c5e0: 29 0a 09 09 09 20 20 20 3b 3b 20 74 6f 70 20 6c ).... ;; top l
c5f0: 69 73 74 0a 09 09 09 20 20 20 28 73 3a 75 6c 20 ist.... (s:ul
c600: 27 69 64 20 22 4c 69 6e 6b 65 64 4c 69 73 74 31 'id "LinkedList1
c610: 22 20 27 63 6c 61 73 73 20 22 4c 69 6e 6b 65 64 " 'class "Linked
c620: 4c 69 73 74 22 0a 09 09 09 09 20 28 73 3a 6c 69 List"..... (s:li
c630: 0a 09 09 09 09 20 20 22 52 75 6e 73 22 0a 09 09 ..... "Runs"...
c640: 09 09 20 20 28 63 6f 6d 6d 6f 6e 3a 68 74 72 65 .. (common:htre
c650: 65 2d 3e 68 74 6d 6c 20 72 75 6e 73 2d 68 74 72 e->html runs-htr
c660: 65 65 0a 09 09 09 09 09 09 20 20 20 20 20 20 27 ee....... '
c670: 28 29 0a 09 09 09 09 09 09 20 20 20 20 20 20 28 ()....... (
c680: 6c 61 6d 62 64 61 20 28 78 20 70 29 0a 09 09 09 lambda (x p)....
c690: 09 09 09 09 28 6c 65 74 2a 20 28 28 74 61 72 67 ....(let* ((targ
c6a0: 2d 70 61 74 68 20 28 73 74 72 69 6e 67 2d 69 6e -path (string-in
c6b0: 74 65 72 73 70 65 72 73 65 20 70 20 22 2f 22 29 tersperse p "/")
c6c0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
c6d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c6e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c6f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c700: 20 28 66 75 6c 6c 2d 70 61 74 68 20 28 63 6f 6e (full-path (con
c710: 63 20 6c 69 6e 6b 74 72 65 65 20 22 2f 22 20 74 c linktree "/" t
c720: 61 72 67 2d 70 61 74 68 29 29 0a 20 20 20 20 20 arg-path)).
c730: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c740: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c750: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c760: 20 20 20 20 20 20 20 20 20 20 28 72 75 6e 2d 6e (run-n
c770: 61 6d 65 20 20 28 63 61 72 20 28 72 65 76 65 72 ame (car (rever
c780: 73 65 20 70 29 29 29 29 0a 20 20 20 20 20 20 20 se p)))).
c790: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c7a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c7b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c7c0: 20 20 20 28 69 66 20 28 61 6e 64 20 28 63 6f 6d (if (and (com
c7d0: 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f mon:file-exists?
c7e0: 20 66 75 6c 6c 2d 70 61 74 68 29 0a 20 20 20 20 full-path).
c7f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c800: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c810: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c820: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
c830: 64 69 72 65 63 74 6f 72 79 3f 20 20 20 66 75 6c directory? ful
c840: 6c 2d 70 61 74 68 29 0a 20 20 20 20 20 20 20 20 l-path).
c850: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c860: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c870: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c880: 20 20 20 20 20 20 20 20 20 20 20 28 66 69 6c 65 (file
c890: 2d 77 72 69 74 65 2d 61 63 63 65 73 73 3f 20 66 -write-access? f
c8a0: 75 6c 6c 2d 70 61 74 68 29 29 0a 20 20 20 20 20 ull-path)).
c8b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c8c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c8d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c8e0: 20 20 20 20 20 20 20 20 20 28 73 3a 61 20 72 75 (s:a ru
c8f0: 6e 2d 6e 61 6d 65 20 27 68 72 65 66 20 28 63 6f n-name 'href (co
c900: 6e 63 20 74 61 72 67 2d 70 61 74 68 20 22 2f 72 nc targ-path "/r
c910: 75 6e 2d 73 75 6d 6d 61 72 79 2e 68 74 6d 6c 22 un-summary.html"
c920: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
c930: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c940: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c950: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c960: 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 (begin.
c970: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c980: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c990: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c9a0: 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 (debug:p
c9b0: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
c9c0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a log-port* "INFO:
c9d0: 20 43 61 6e 27 74 20 63 72 65 61 74 65 20 22 20 Can't create "
c9e0: 74 61 72 67 2d 70 61 74 68 20 22 2f 72 75 6e 2d targ-path "/run-
c9f0: 73 75 6d 6d 61 72 79 2e 68 74 6d 6c 22 29 0a 20 summary.html").
ca00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ca10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ca20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ca30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
ca40: 63 6f 6e 63 20 72 75 6e 2d 6e 61 6d 65 20 22 20 conc run-name "
ca50: 28 4e 6f 74 20 61 62 6c 65 20 74 6f 20 63 72 65 (Not able to cre
ca60: 61 74 65 20 73 75 6d 6d 61 72 79 20 61 74 20 22 ate summary at "
ca70: 20 74 61 72 67 2d 70 61 74 68 20 22 29 22 29 29 targ-path ")"))
ca80: 29 29 29 29 29 29 29 29 29 0a 20 20 20 20 20 20 ))))))))).
ca90: 20 20 20 20 28 63 6c 6f 73 65 2d 6f 75 74 70 75 (close-outpu
caa0: 74 2d 70 6f 72 74 20 6f 75 70 29 0a 09 20 20 28 t-port oup).. (
cab0: 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 common:simple-fi
cac0: 6c 65 2d 72 65 6c 65 61 73 65 2d 6c 6f 63 6b 20 le-release-lock
cad0: 6c 6f 63 6b 66 69 6c 65 29 0a 20 20 20 20 20 20 lockfile).
cae0: 20 20 20 20 20 20 20 20 20 0a 09 20 20 28 66 6f .. (fo
caf0: 72 2d 65 61 63 68 0a 09 20 20 20 28 6c 61 6d 62 r-each.. (lamb
cb00: 64 61 20 28 72 75 6e 29 0a 09 20 20 20 20 20 28 da (run).. (
cb10: 6c 65 74 2a 20 28 28 74 65 73 74 2d 73 75 62 70 let* ((test-subp
cb20: 61 74 68 20 28 74 65 73 74 73 3a 72 75 6e 2d 72 ath (tests:run-r
cb30: 65 63 6f 72 64 2d 3e 74 65 73 74 2d 70 61 74 68 ecord->test-path
cb40: 20 72 75 6e 20 6e 75 6d 6b 65 79 73 29 29 0a 09 run numkeys))..
cb50: 09 20 20 20 20 28 72 75 6e 2d 69 64 20 20 20 20 . (run-id
cb60: 20 20 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 (db:get-value
cb70: 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 -by-header run h
cb80: 65 61 64 65 72 20 22 69 64 22 29 29 0a 20 20 20 eader "id")).
cb90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cba0: 20 28 72 75 6e 2d 64 69 72 20 20 20 20 20 20 28 (run-dir (
cbb0: 74 65 73 74 73 3a 72 75 6e 2d 72 65 63 6f 72 64 tests:run-record
cbc0: 2d 3e 74 65 73 74 2d 70 61 74 68 20 72 75 6e 20 ->test-path run
cbd0: 6e 75 6d 6b 65 79 73 29 29 0a 09 09 20 20 20 20 numkeys))...
cbe0: 28 74 65 73 74 2d 64 61 74 73 20 20 20 20 28 72 (test-dats (r
cbf0: 6d 74 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 mt:get-tests-for
cc00: 2d 72 75 6e 0a 09 09 09 09 20 20 20 72 75 6e 2d -run..... run-
cc10: 69 64 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 id.
cc20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cc30: 20 20 20 20 20 20 22 25 2f 22 20 20 20 20 20 20 "%/"
cc40: 20 3b 3b 20 74 65 73 74 6e 61 6d 65 70 61 74 74 ;; testnamepatt
cc50: 0a 09 09 09 09 20 20 20 27 28 29 20 20 20 20 20 ..... '()
cc60: 20 20 20 3b 3b 20 73 74 61 74 65 73 0a 09 09 09 ;; states....
cc70: 09 20 20 20 27 28 29 20 20 20 20 20 20 20 20 3b . '() ;
cc80: 3b 20 73 74 61 74 75 73 65 73 0a 09 09 09 09 20 ; statuses.....
cc90: 20 20 23 66 20 20 20 20 20 20 20 20 20 3b 3b 20 #f ;;
cca0: 6f 66 66 73 65 74 0a 09 09 09 09 20 20 20 23 66 offset..... #f
ccb0: 20 20 20 20 20 20 20 20 20 3b 3b 20 6e 75 6d 2d ;; num-
ccc0: 74 6f 2d 67 65 74 0a 09 09 09 09 20 20 20 23 66 to-get..... #f
ccd0: 20 20 20 20 20 20 20 20 20 3b 3b 20 68 69 64 65 ;; hide
cce0: 2f 6e 6f 74 2d 68 69 64 65 0a 09 09 09 09 20 20 /not-hide.....
ccf0: 20 23 66 20 20 20 20 20 20 20 20 20 3b 3b 20 73 #f ;; s
cd00: 6f 72 74 2d 62 79 0a 09 09 09 09 20 20 20 23 66 ort-by..... #f
cd10: 20 20 20 20 20 20 20 20 20 3b 3b 20 73 6f 72 74 ;; sort
cd20: 2d 6f 72 64 65 72 0a 09 09 09 09 20 20 20 23 66 -order..... #f
cd30: 20 20 20 20 20 20 20 20 20 3b 3b 20 27 73 68 6f ;; 'sho
cd40: 72 74 6c 69 73 74 20 20 20 20 20 20 20 20 20 20 rtlist
cd50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cd60: 20 3b 3b 20 71 72 79 74 79 70 65 0a 20 20 20 20 ;; qrytype.
cd70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cd80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 30 0
cd90: 20 20 20 20 20 20 20 20 20 3b 3b 20 6c 61 73 74 ;; last
cda0: 20 75 70 64 61 74 65 0a 09 09 09 09 20 20 20 23 update..... #
cdb0: 66 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 f)).
cdc0: 20 20 20 20 20 20 20 20 28 74 65 73 74 73 2d 74 (tests-t
cdd0: 72 65 65 2d 64 61 74 20 28 6d 61 70 20 28 6c 61 ree-dat (map (la
cde0: 6d 62 64 61 20 28 74 65 73 74 2d 64 61 74 29 0a mbda (test-dat).
cdf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ce00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ce10: 20 20 20 20 20 20 20 20 20 3b 3b 20 28 74 65 73 ;; (tes
ce20: 74 73 3a 72 75 6e 2d 72 65 63 6f 72 64 2d 3e 74 ts:run-record->t
ce30: 65 73 74 2d 70 61 74 68 20 78 20 6e 75 6d 6b 65 est-path x numke
ce40: 79 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 ys)).
ce50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ce60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l
ce70: 65 74 2a 20 28 28 74 65 73 74 2d 6e 61 6d 65 20 et* ((test-name
ce80: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 (db:test-get-te
ce90: 73 74 6e 61 6d 65 20 74 65 73 74 2d 64 61 74 29 stname test-dat)
cea0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
ceb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cec0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ced0: 20 20 28 69 74 65 6d 2d 70 61 74 68 20 20 28 64 (item-path (d
cee0: 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d b:test-get-item-
cef0: 70 61 74 68 20 74 65 73 74 2d 64 61 74 29 29 0a path test-dat)).
cf00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cf10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cf20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cf30: 28 66 75 6c 6c 2d 6e 61 6d 65 20 20 28 64 62 3a (full-name (db:
cf40: 74 65 73 74 2d 6d 61 6b 65 2d 66 75 6c 6c 2d 6e test-make-full-n
cf50: 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 ame test-name it
cf60: 65 6d 2d 70 61 74 68 29 29 0a 20 20 20 20 20 20 em-path)).
cf70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cf80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cf90: 20 20 20 20 20 20 20 20 20 20 28 70 61 74 68 2d (path-
cfa0: 70 61 72 74 73 20 28 73 74 72 69 6e 67 2d 73 70 parts (string-sp
cfb0: 6c 69 74 20 66 75 6c 6c 2d 6e 61 6d 65 29 29 29 lit full-name)))
cfc0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
cfd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cfe0: 20 20 20 20 20 20 20 20 20 20 20 20 70 61 74 68 path
cff0: 2d 70 61 72 74 73 29 29 0a 20 20 20 20 20 20 20 -parts)).
d000: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d010: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d020: 74 65 73 74 2d 64 61 74 73 29 29 0a 20 20 20 20 test-dats)).
d030: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d040: 28 74 65 73 74 73 2d 68 74 72 65 65 20 28 63 6f (tests-htree (co
d050: 6d 6d 6f 6e 3a 6c 69 73 74 2d 3e 68 74 72 65 65 mmon:list->htree
d060: 20 74 65 73 74 73 2d 74 72 65 65 2d 64 61 74 29 tests-tree-dat)
d070: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
d080: 20 20 20 20 20 20 28 68 74 6d 6c 2d 64 69 72 20 (html-dir
d090: 20 20 20 28 63 6f 6e 63 20 6c 69 6e 6b 74 72 65 (conc linktre
d0a0: 65 20 22 2f 22 20 28 73 74 72 69 6e 67 2d 69 6e e "/" (string-in
d0b0: 74 65 72 73 70 65 72 73 65 20 72 75 6e 2d 64 69 tersperse run-di
d0c0: 72 20 22 2f 22 29 29 29 0a 20 20 20 20 20 20 20 r "/"))).
d0d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 68 74 (ht
d0e0: 6d 6c 2d 70 61 74 68 20 20 20 28 63 6f 6e 63 20 ml-path (conc
d0f0: 68 74 6d 6c 2d 64 69 72 20 22 2f 72 75 6e 2d 73 html-dir "/run-s
d100: 75 6d 6d 61 72 79 2e 68 74 6d 6c 22 29 29 0a 20 ummary.html")).
d110: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d120: 20 20 20 28 6f 75 70 20 20 20 20 20 20 20 20 20 (oup
d130: 28 69 66 20 28 61 6e 64 20 28 63 6f 6d 6d 6f 6e (if (and (common
d140: 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 68 74 :file-exists? ht
d150: 6d 6c 2d 64 69 72 29 0a 20 20 20 20 20 20 20 20 ml-dir).
d160: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d170: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d180: 20 20 28 64 69 72 65 63 74 6f 72 79 3f 20 20 20 (directory?
d190: 68 74 6d 6c 2d 64 69 72 29 0a 20 20 20 20 20 20 html-dir).
d1a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d1b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d1c0: 20 20 20 20 28 66 69 6c 65 2d 77 72 69 74 65 2d (file-write-
d1d0: 61 63 63 65 73 73 3f 20 68 74 6d 6c 2d 64 69 72 access? html-dir
d1e0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
d1f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d200: 20 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 6f 75 (open-ou
d210: 74 70 75 74 2d 66 69 6c 65 20 20 68 74 6d 6c 2d tput-file html-
d220: 70 61 74 68 29 0a 20 20 20 20 20 20 20 20 20 20 path).
d230: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d240: 20 20 20 20 20 20 20 20 20 20 20 23 66 29 29 29 #f)))
d250: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
d260: 3b 3b 20 28 70 72 69 6e 74 20 22 72 75 6e 2d 64 ;; (print "run-d
d270: 69 72 3a 20 22 20 72 75 6e 2d 64 69 72 20 22 2c ir: " run-dir ",
d280: 20 74 65 73 74 73 2d 74 72 65 65 2d 64 61 74 3a tests-tree-dat:
d290: 20 22 20 74 65 73 74 73 2d 74 72 65 65 2d 64 61 " tests-tree-da
d2a0: 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 t).
d2b0: 20 20 28 69 66 20 6f 75 70 0a 20 20 20 20 20 20 (if oup.
d2c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 62 65 (be
d2d0: 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 gin.
d2e0: 20 20 20 20 20 20 20 20 20 28 73 3a 6f 75 74 70 (s:outp
d2f0: 75 74 2d 6e 65 77 0a 20 20 20 20 20 20 20 20 20 ut-new.
d300: 20 20 20 20 20 20 20 20 20 20 20 20 20 6f 75 70 oup
d310: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
d320: 20 20 20 20 20 20 20 28 73 3a 68 74 6d 6c 20 74 (s:html t
d330: 65 73 74 73 3a 63 73 73 2d 6a 73 63 72 69 70 74 ests:css-jscript
d340: 2d 62 6c 6f 63 6b 0a 20 20 20 20 20 20 20 20 20 -block.
d350: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d360: 20 20 20 20 20 28 73 3a 74 69 74 6c 65 20 22 53 (s:title "S
d370: 75 6d 6d 61 72 79 20 66 6f 72 20 22 20 61 72 65 ummary for " are
d380: 61 2d 6e 61 6d 65 29 0a 20 20 20 20 20 20 20 20 a-name).
d390: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d3a0: 20 20 20 20 20 20 28 73 3a 62 6f 64 79 20 27 6f (s:body 'o
d3b0: 6e 6c 6f 61 64 20 22 61 64 64 45 76 65 6e 74 73 nload "addEvents
d3c0: 28 29 3b 22 0a 20 20 20 20 20 20 20 20 20 20 20 ();".
d3d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d3e0: 20 20 20 20 20 20 20 20 20 20 20 28 73 3a 68 31 (s:h1
d3f0: 20 22 53 75 6d 6d 61 72 79 20 66 6f 72 20 22 20 "Summary for "
d400: 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 (string-interspe
d410: 72 73 65 20 72 75 6e 2d 64 69 72 20 22 2f 22 29 rse run-dir "/")
d420: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
d430: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d440: 20 20 20 20 20 20 20 20 3b 3b 20 74 6f 70 20 6c ;; top l
d450: 69 73 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 ist.
d460: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d470: 20 20 20 20 20 20 20 20 20 20 28 73 3a 75 6c 20 (s:ul
d480: 27 69 64 20 22 4c 69 6e 6b 65 64 4c 69 73 74 31 'id "LinkedList1
d490: 22 20 27 63 6c 61 73 73 20 22 4c 69 6e 6b 65 64 " 'class "Linked
d4a0: 4c 69 73 74 22 0a 20 20 20 20 20 20 20 20 20 20 List".
d4b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d4c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d4d0: 20 20 28 73 3a 6c 69 0a 20 20 20 20 20 20 20 20 (s:li.
d4e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d4f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d500: 20 20 20 20 20 22 54 65 73 74 73 22 0a 20 20 20 "Tests".
d510: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d520: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d530: 20 20 20 20 20 20 20 20 20 20 28 63 6f 6d 6d 6f (commo
d540: 6e 3a 68 74 72 65 65 2d 3e 68 74 6d 6c 20 74 65 n:htree->html te
d550: 73 74 73 2d 68 74 72 65 65 0a 20 20 20 20 20 20 sts-htree.
d560: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d570: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d580: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d590: 20 20 20 20 20 20 20 20 20 20 20 27 28 29 0a 20 '().
d5a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d5b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d5c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d5d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d5e0: 28 6c 61 6d 62 64 61 20 28 78 20 70 29 0a 20 20 (lambda (x p).
d5f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d600: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d610: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d620: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d630: 20 28 6c 65 74 2a 20 28 28 74 61 72 67 2d 70 61 (let* ((targ-pa
d640: 74 68 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 th (string-inter
d650: 73 70 65 72 73 65 20 70 20 22 2f 22 29 29 0a 20 sperse p "/")).
d660: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d670: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d680: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d690: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d6a0: 20 20 20 20 20 20 20 20 20 28 74 65 73 74 2d 6e (test-n
d6b0: 61 6d 65 20 28 63 61 72 20 70 29 29 0a 20 20 20 ame (car p)).
d6c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d6d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d6e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d6f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d700: 20 20 20 20 20 20 20 28 69 74 65 6d 2d 70 61 74 (item-pat
d710: 68 20 3b 3b 20 28 69 66 20 28 3e 20 28 6c 65 6e h ;; (if (> (len
d720: 67 74 68 20 70 29 20 32 29 20 3b 3b 20 74 65 73 gth p) 2) ;; tes
d730: 74 2d 6e 61 6d 65 20 2b 20 72 75 6e 2d 6e 61 6d t-name + run-nam
d740: 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 e.
d750: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d760: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d770: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d780: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 74 (st
d790: 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
d7a0: 20 70 20 22 2f 22 29 29 0a 20 20 20 20 20 20 20 p "/")).
d7b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d7c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d7d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d7e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d7f0: 20 20 20 28 66 75 6c 6c 2d 74 61 72 67 20 28 63 (full-targ (c
d800: 6f 6e 63 20 68 74 6d 6c 2d 64 69 72 20 22 2f 22 onc html-dir "/"
d810: 20 74 61 72 67 2d 70 61 74 68 29 29 0a 20 20 20 targ-path)).
d820: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d830: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d840: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d850: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d860: 20 20 20 20 20 20 20 28 73 74 64 2d 66 69 6c 65 (std-file
d870: 20 20 28 63 6f 6e 63 20 66 75 6c 6c 2d 74 61 72 (conc full-tar
d880: 67 20 22 2f 74 65 73 74 2d 73 75 6d 6d 61 72 79 g "/test-summary
d890: 2e 68 74 6d 6c 22 29 29 0a 20 20 20 20 20 20 20 .html")).
d8a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d8b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d8c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d8d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d8e0: 20 20 20 28 61 6c 74 2d 66 69 6c 65 20 20 28 63 (alt-file (c
d8f0: 6f 6e 63 20 66 75 6c 6c 2d 74 61 72 67 20 22 2f onc full-targ "/
d900: 6d 65 67 61 74 65 73 74 2d 72 6f 6c 6c 75 70 2d megatest-rollup-
d910: 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 2e 68 74 " test-name ".ht
d920: 6d 6c 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 ml")).
d930: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d940: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d950: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d960: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d970: 28 68 74 6d 6c 2d 66 69 6c 65 20 28 69 66 20 28 (html-file (if (
d980: 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 common:file-exis
d990: 74 73 3f 20 61 6c 74 2d 66 69 6c 65 29 0a 20 20 ts? alt-file).
d9a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d9b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d9c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d9d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d9e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d9f0: 20 20 20 20 20 20 20 61 6c 74 2d 66 69 6c 65 0a alt-file.
da00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
da10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
da20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
da30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
da40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
da50: 20 20 20 20 20 20 20 20 20 73 74 64 2d 66 69 6c std-fil
da60: 65 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 e)).
da70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
da80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
da90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
daa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 (r
dab0: 75 6e 2d 6e 61 6d 65 20 20 28 63 61 72 20 28 72 un-name (car (r
dac0: 65 76 65 72 73 65 20 70 29 29 29 29 0a 20 20 20 everse p)))).
dad0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dae0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
daf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
db00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
db10: 20 20 28 69 66 20 28 61 6e 64 20 28 6e 6f 74 20 (if (and (not
db20: 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 (common:file-exi
db30: 73 74 73 3f 20 66 75 6c 6c 2d 74 61 72 67 29 29 sts? full-targ))
db40: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
db50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
db60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
db70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
db80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
db90: 64 69 72 65 63 74 6f 72 79 3f 20 66 75 6c 6c 2d directory? full-
dba0: 74 61 72 67 29 0a 20 20 20 20 20 20 20 20 20 20 targ).
dbb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dbc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dbd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dbe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dbf0: 20 20 20 20 28 66 69 6c 65 2d 77 72 69 74 65 2d (file-write-
dc00: 61 63 63 65 73 73 3f 20 66 75 6c 6c 2d 74 61 72 access? full-tar
dc10: 67 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 g)).
dc20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dc30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dc40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dc50: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 74 65 (te
dc60: 73 74 73 3a 73 75 6d 6d 61 72 69 7a 65 2d 74 65 sts:summarize-te
dc70: 73 74 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 st .
dc80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dc90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dca0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dcb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 72 75 ru
dcc0: 6e 2d 69 64 20 0a 20 20 20 20 20 20 20 20 20 20 n-id .
dcd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dce0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dcf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dd00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dd10: 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 64 (rmt:get-test-id
dd20: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
dd30: 65 20 69 74 65 6d 2d 70 61 74 68 29 29 29 0a 20 e item-path))).
dd40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dd50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dd60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dd70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dd80: 20 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a (if (common:
dd90: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 66 75 6c file-exists? ful
dda0: 6c 2d 74 61 72 67 29 0a 20 20 20 20 20 20 20 20 l-targ).
ddb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ddc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ddd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dde0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ddf0: 20 28 73 3a 61 20 72 75 6e 2d 6e 61 6d 65 20 27 (s:a run-name '
de00: 68 72 65 66 20 68 74 6d 6c 2d 66 69 6c 65 29 0a href html-file).
de10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
de20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
de30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
de40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
de50: 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a (begin.
de60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
de70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
de80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
de90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dea0: 20 20 20 20 20 20 20 20 20 20 20 28 64 65 62 75 (debu
deb0: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
dec0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 52 lt-log-port* "ER
ded0: 52 4f 52 3a 20 63 61 6e 27 74 20 61 63 63 65 73 ROR: can't acces
dee0: 73 20 22 20 66 75 6c 6c 2d 74 61 72 67 29 0a 20 s " full-targ).
def0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
df00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
df10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
df20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
df30: 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 63 20 (conc
df40: 22 4e 6f 20 73 75 6d 6d 61 72 79 20 66 6f 72 20 "No summary for
df50: 22 20 72 75 6e 2d 6e 61 6d 65 29 29 29 29 29 0a " run-name))))).
df60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
df70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
df80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
df90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dfa0: 20 29 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 )))))).
dfb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6c (cl
dfc0: 6f 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 ose-output-port
dfd0: 6f 75 70 29 29 29 29 29 0a 20 20 20 20 20 20 20 oup))))).
dfe0: 20 20 20 20 72 75 6e 73 29 0a 20 20 20 20 20 20 runs).
dff0: 20 20 20 20 23 74 29 0a 09 23 66 29 29 29 0a 0a #t)..#f)))..
e000: 0a 0a 0a 0a 0a 0a 3b 3b 20 43 48 45 43 4b 20 2d ......;; CHECK -
e010: 20 57 41 53 20 54 48 49 53 20 41 44 44 45 44 20 WAS THIS ADDED
e020: 4f 52 20 52 45 4d 4f 56 45 44 3f 20 4d 41 4e 55 OR REMOVED? MANU
e030: 41 4c 20 4d 45 52 47 45 20 57 49 54 48 20 41 50 AL MERGE WITH AP
e040: 49 20 53 54 55 46 46 21 21 21 0a 3b 3b 0a 3b 3b I STUFF!!!.;;.;;
e050: 20 67 65 74 20 61 20 70 72 65 74 74 79 20 74 61 get a pretty ta
e060: 62 6c 65 20 74 6f 20 73 75 6d 6d 61 72 69 7a 65 ble to summarize
e070: 20 73 74 65 70 73 0a 3b 3b 0a 3b 3b 20 28 64 65 steps.;;.;; (de
e080: 66 69 6e 65 20 28 64 63 6f 6d 6d 6f 6e 3a 70 72 fine (dcommon:pr
e090: 6f 63 65 73 73 2d 73 74 65 70 73 2d 74 61 62 6c ocess-steps-tabl
e0a0: 65 20 73 74 65 70 73 29 3b 3b 20 64 62 20 74 65 e steps);; db te
e0b0: 73 74 2d 69 64 20 23 21 6b 65 79 20 28 77 6f 72 st-id #!key (wor
e0c0: 6b 2d 61 72 65 61 20 23 66 29 29 0a 28 64 65 66 k-area #f)).(def
e0d0: 69 6e 65 20 28 74 65 73 74 73 3a 70 72 6f 63 65 ine (tests:proce
e0e0: 73 73 2d 73 74 65 70 73 2d 74 61 62 6c 65 20 73 ss-steps-table s
e0f0: 74 65 70 73 29 3b 3b 20 64 62 20 74 65 73 74 2d teps);; db test-
e100: 69 64 20 23 21 6b 65 79 20 28 77 6f 72 6b 2d 61 id #!key (work-a
e110: 72 65 61 20 23 66 29 29 0a 3b 3b 20 20 28 6c 65 rea #f)).;; (le
e120: 74 20 28 28 73 74 65 70 73 20 20 20 28 64 62 3a t ((steps (db:
e130: 67 65 74 2d 73 74 65 70 73 2d 66 6f 72 2d 74 65 get-steps-for-te
e140: 73 74 20 64 62 20 74 65 73 74 2d 69 64 20 77 6f st db test-id wo
e150: 72 6b 2d 61 72 65 61 3a 20 77 6f 72 6b 2d 61 72 rk-area: work-ar
e160: 65 61 29 29 29 0a 20 20 20 20 3b 3b 20 6f 72 67 ea))). ;; org
e170: 61 6e 69 73 65 20 74 68 65 20 73 74 65 70 73 20 anise the steps
e180: 66 6f 72 20 62 65 74 74 65 72 20 72 65 61 64 61 for better reada
e190: 62 69 6c 69 74 79 0a 20 20 20 20 28 6c 65 74 20 bility. (let
e1a0: 28 28 72 65 73 20 28 6d 61 6b 65 2d 68 61 73 68 ((res (make-hash
e1b0: 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 20 20 20 -table))).
e1c0: 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 20 (for-each .
e1d0: 20 20 28 6c 61 6d 62 64 61 20 28 73 74 65 70 29 (lambda (step)
e1e0: 0a 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 .. (debug:print
e1f0: 36 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6 *default-log-p
e200: 6f 72 74 2a 20 22 73 74 65 70 3d 22 20 73 74 65 ort* "step=" ste
e210: 70 29 0a 09 20 28 6c 65 74 20 28 28 72 65 63 6f p).. (let ((reco
e220: 72 64 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 rd (hash-table-r
e230: 65 66 2f 64 65 66 61 75 6c 74 20 0a 09 09 09 72 ef/default ....r
e240: 65 73 20 0a 09 09 09 28 74 64 62 3a 73 74 65 70 es ....(tdb:step
e250: 2d 67 65 74 2d 73 74 65 70 6e 61 6d 65 20 73 74 -get-stepname st
e260: 65 70 29 0a 09 09 09 3b 3b 20 20 20 20 20 20 20 ep)....;;
e270: 20 20 20 20 30 20 20 20 20 20 20 20 20 20 20 20 0
e280: 20 20 20 20 20 20 20 20 20 20 20 31 20 20 20 20 1
e290: 32 20 20 20 20 33 20 20 20 20 20 20 20 34 20 20 2 3 4
e2a0: 20 20 20 20 20 20 20 35 20 20 20 20 20 20 20 36 5 6
e2b0: 20 20 20 20 20 20 20 37 0a 09 09 09 3b 3b 20 20 7....;;
e2c0: 20 20 20 20 20 20 73 74 65 70 6e 61 6d 65 20 20 stepname
e2d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 73 74 st
e2e0: 61 72 74 20 65 6e 64 20 73 74 61 74 75 73 20 44 art end status D
e2f0: 75 72 61 74 69 6f 6e 20 20 4c 6f 67 66 69 6c 65 uration Logfile
e300: 20 43 6f 6d 6d 65 6e 74 20 20 66 69 72 73 74 2d Comment first-
e310: 69 64 0a 09 09 09 28 76 65 63 74 6f 72 20 28 74 id....(vector (t
e320: 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 65 70 db:step-get-step
e330: 6e 61 6d 65 20 73 74 65 70 29 20 22 22 20 20 20 name step) ""
e340: 22 22 20 22 22 20 20 20 20 20 22 22 20 20 20 20 "" "" ""
e350: 20 20 20 20 22 22 20 20 20 20 20 22 22 20 20 20 "" ""
e360: 20 20 20 20 23 66 29 29 29 29 0a 09 20 20 20 28 #f)))).. (
e370: 64 65 62 75 67 3a 70 72 69 6e 74 20 36 20 2a 64 debug:print 6 *d
e380: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
e390: 20 22 72 65 63 6f 72 64 28 62 65 66 6f 72 65 29 "record(before)
e3a0: 20 3d 20 22 20 72 65 63 6f 72 64 20 0a 09 09 09 = " record ....
e3b0: 22 5c 6e 69 64 3a 20 20 20 20 20 20 20 22 20 28 "\nid: " (
e3c0: 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 69 64 20 tdb:step-get-id
e3d0: 73 74 65 70 29 0a 09 09 09 22 5c 6e 73 74 65 70 step)...."\nstep
e3e0: 6e 61 6d 65 3a 20 22 20 28 74 64 62 3a 73 74 65 name: " (tdb:ste
e3f0: 70 2d 67 65 74 2d 73 74 65 70 6e 61 6d 65 20 73 p-get-stepname s
e400: 74 65 70 29 0a 09 09 09 22 5c 6e 73 74 61 74 65 tep)...."\nstate
e410: 3a 20 20 20 20 22 20 28 74 64 62 3a 73 74 65 70 : " (tdb:step
e420: 2d 67 65 74 2d 73 74 61 74 65 20 73 74 65 70 29 -get-state step)
e430: 0a 09 09 09 22 5c 6e 73 74 61 74 75 73 3a 20 20 ...."\nstatus:
e440: 20 22 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 " (tdb:step-get
e450: 2d 73 74 61 74 75 73 20 73 74 65 70 29 0a 09 09 -status step)...
e460: 09 22 5c 6e 74 69 6d 65 3a 20 20 20 20 20 22 20 ."\ntime: "
e470: 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 65 76 (tdb:step-get-ev
e480: 65 6e 74 5f 74 69 6d 65 20 73 74 65 70 29 29 0a ent_time step)).
e490: 09 20 20 20 28 69 66 20 28 6e 6f 74 20 28 76 65 . (if (not (ve
e4a0: 63 74 6f 72 2d 72 65 66 20 72 65 63 6f 72 64 20 ctor-ref record
e4b0: 37 29 29 28 76 65 63 74 6f 72 2d 73 65 74 21 20 7))(vector-set!
e4c0: 72 65 63 6f 72 64 20 37 20 28 74 64 62 3a 73 74 record 7 (tdb:st
e4d0: 65 70 2d 67 65 74 2d 69 64 20 73 74 65 70 29 29 ep-get-id step))
e4e0: 29 20 3b 3b 20 64 6f 20 6e 6f 74 20 63 6c 6f 62 ) ;; do not clob
e4f0: 62 65 72 20 74 68 65 20 69 64 20 69 66 20 70 72 ber the id if pr
e500: 65 76 69 6f 75 73 6c 79 20 73 65 74 0a 09 20 20 eviously set..
e510: 20 28 63 61 73 65 20 28 73 74 72 69 6e 67 2d 3e (case (string->
e520: 73 79 6d 62 6f 6c 20 28 74 64 62 3a 73 74 65 70 symbol (tdb:step
e530: 2d 67 65 74 2d 73 74 61 74 65 20 73 74 65 70 29 -get-state step)
e540: 29 0a 09 20 20 20 20 20 28 28 73 74 61 72 74 29 ).. ((start)
e550: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 72 65 63 (vector-set! rec
e560: 6f 72 64 20 31 20 28 74 64 62 3a 73 74 65 70 2d ord 1 (tdb:step-
e570: 67 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 73 get-event_time s
e580: 74 65 70 29 29 0a 09 20 20 20 20 20 20 28 76 65 tep)).. (ve
e590: 63 74 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 64 ctor-set! record
e5a0: 20 33 20 28 69 66 20 28 65 71 75 61 6c 3f 20 28 3 (if (equal? (
e5b0: 76 65 63 74 6f 72 2d 72 65 66 20 72 65 63 6f 72 vector-ref recor
e5c0: 64 20 33 29 20 22 22 29 0a 09 09 09 09 09 28 74 d 3) "")......(t
e5d0: 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 61 74 db:step-get-stat
e5e0: 75 73 20 73 74 65 70 29 29 29 0a 09 20 20 20 20 us step)))..
e5f0: 20 20 28 69 66 20 28 3e 20 28 73 74 72 69 6e 67 (if (> (string
e600: 2d 6c 65 6e 67 74 68 20 28 74 64 62 3a 73 74 65 -length (tdb:ste
e610: 70 2d 67 65 74 2d 6c 6f 67 66 69 6c 65 20 73 74 p-get-logfile st
e620: 65 70 29 29 0a 09 09 20 20 20 20 20 30 29 0a 09 ep))... 0)..
e630: 09 20 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 . (vector-set!
e640: 72 65 63 6f 72 64 20 35 20 28 74 64 62 3a 73 74 record 5 (tdb:st
e650: 65 70 2d 67 65 74 2d 6c 6f 67 66 69 6c 65 20 73 ep-get-logfile s
e660: 74 65 70 29 29 29 29 0a 09 20 20 20 20 20 28 28 tep)))).. ((
e670: 65 6e 64 29 20 20 0a 09 20 20 20 20 20 20 28 76 end) .. (v
e680: 65 63 74 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 ector-set! recor
e690: 64 20 32 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 d 2 (any->number
e6a0: 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 65 (tdb:step-get-e
e6b0: 76 65 6e 74 5f 74 69 6d 65 20 73 74 65 70 29 29 vent_time step))
e6c0: 29 0a 09 20 20 20 20 20 20 28 76 65 63 74 6f 72 ).. (vector
e6d0: 2d 73 65 74 21 20 72 65 63 6f 72 64 20 33 20 28 -set! record 3 (
e6e0: 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 61 tdb:step-get-sta
e6f0: 74 75 73 20 73 74 65 70 29 29 0a 09 20 20 20 20 tus step))..
e700: 20 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 72 (vector-set! r
e710: 65 63 6f 72 64 20 34 20 28 6c 65 74 20 28 28 73 ecord 4 (let ((s
e720: 74 61 72 74 74 20 28 61 6e 79 2d 3e 6e 75 6d 62 tartt (any->numb
e730: 65 72 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 er (vector-ref r
e740: 65 63 6f 72 64 20 31 29 29 29 0a 09 09 09 09 09 ecord 1)))......
e750: 20 20 28 65 6e 64 74 20 20 20 28 61 6e 79 2d 3e (endt (any->
e760: 6e 75 6d 62 65 72 20 28 76 65 63 74 6f 72 2d 72 number (vector-r
e770: 65 66 20 72 65 63 6f 72 64 20 32 29 29 29 29 0a ef record 2)))).
e780: 09 09 09 09 20 20 20 20 20 20 28 64 65 62 75 67 .... (debug
e790: 3a 70 72 69 6e 74 20 34 20 2a 64 65 66 61 75 6c :print 4 *defaul
e7a0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 65 63 t-log-port* "rec
e7b0: 6f 72 64 5b 31 5d 3d 22 20 28 76 65 63 74 6f 72 ord[1]=" (vector
e7c0: 2d 72 65 66 20 72 65 63 6f 72 64 20 31 29 20 0a -ref record 1) .
e7d0: 09 09 09 09 09 09 20 20 20 22 2c 20 73 74 61 72 ...... ", star
e7e0: 74 74 3d 22 20 73 74 61 72 74 74 20 22 2c 20 65 tt=" startt ", e
e7f0: 6e 64 74 3d 22 20 65 6e 64 74 0a 09 09 09 09 09 ndt=" endt......
e800: 09 20 20 20 22 2c 20 67 65 74 2d 73 74 61 74 75 . ", get-statu
e810: 73 3a 20 22 20 28 74 64 62 3a 73 74 65 70 2d 67 s: " (tdb:step-g
e820: 65 74 2d 73 74 61 74 75 73 20 73 74 65 70 29 29 et-status step))
e830: 0a 09 09 09 09 20 20 20 20 20 20 28 69 66 20 28 ..... (if (
e840: 61 6e 64 20 28 6e 75 6d 62 65 72 3f 20 73 74 61 and (number? sta
e850: 72 74 74 29 28 6e 75 6d 62 65 72 3f 20 65 6e 64 rtt)(number? end
e860: 74 29 29 0a 09 09 09 09 09 20 20 28 73 65 63 6f t))...... (seco
e870: 6e 64 73 2d 3e 68 72 2d 6d 69 6e 2d 73 65 63 20 nds->hr-min-sec
e880: 28 2d 20 65 6e 64 74 20 73 74 61 72 74 74 29 29 (- endt startt))
e890: 20 22 2d 31 22 29 29 29 0a 09 20 20 20 20 20 20 "-1")))..
e8a0: 28 69 66 20 28 3e 20 28 73 74 72 69 6e 67 2d 6c (if (> (string-l
e8b0: 65 6e 67 74 68 20 28 74 64 62 3a 73 74 65 70 2d ength (tdb:step-
e8c0: 67 65 74 2d 6c 6f 67 66 69 6c 65 20 73 74 65 70 get-logfile step
e8d0: 29 29 0a 09 09 20 20 20 20 20 30 29 0a 09 09 20 ))... 0)...
e8e0: 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 72 65 (vector-set! re
e8f0: 63 6f 72 64 20 35 20 28 74 64 62 3a 73 74 65 70 cord 5 (tdb:step
e900: 2d 67 65 74 2d 6c 6f 67 66 69 6c 65 20 73 74 65 -get-logfile ste
e910: 70 29 29 29 0a 09 20 20 20 20 20 20 28 69 66 20 p))).. (if
e920: 28 3e 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 (> (string-lengt
e930: 68 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d h (tdb:step-get-
e940: 63 6f 6d 6d 65 6e 74 20 73 74 65 70 29 29 0a 09 comment step))..
e950: 09 20 20 20 20 20 30 29 0a 09 09 20 20 28 76 65 . 0)... (ve
e960: 63 74 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 64 ctor-set! record
e970: 20 36 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 6 (tdb:step-get
e980: 2d 63 6f 6d 6d 65 6e 74 20 73 74 65 70 29 29 29 -comment step)))
e990: 29 0a 09 20 20 20 20 20 28 65 6c 73 65 0a 09 20 ).. (else..
e9a0: 20 20 20 20 20 28 76 65 63 74 6f 72 2d 73 65 74 (vector-set
e9b0: 21 20 72 65 63 6f 72 64 20 32 20 28 74 64 62 3a ! record 2 (tdb:
e9c0: 73 74 65 70 2d 67 65 74 2d 73 74 61 74 65 20 73 step-get-state s
e9d0: 74 65 70 29 29 0a 09 20 20 20 20 20 20 28 76 65 tep)).. (ve
e9e0: 63 74 6f 72 2d 73 65 74 21 20 72 65 63 6f 72 64 ctor-set! record
e9f0: 20 33 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 3 (tdb:step-get
ea00: 2d 73 74 61 74 75 73 20 73 74 65 70 29 29 0a 09 -status step))..
ea10: 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 73 65 (vector-se
ea20: 74 21 20 72 65 63 6f 72 64 20 34 20 28 74 64 62 t! record 4 (tdb
ea30: 3a 73 74 65 70 2d 67 65 74 2d 65 76 65 6e 74 5f :step-get-event_
ea40: 74 69 6d 65 20 73 74 65 70 29 29 0a 09 20 20 20 time step))..
ea50: 20 20 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 (vector-set!
ea60: 72 65 63 6f 72 64 20 36 20 28 74 64 62 3a 73 74 record 6 (tdb:st
ea70: 65 70 2d 67 65 74 2d 63 6f 6d 6d 65 6e 74 20 73 ep-get-comment s
ea80: 74 65 70 29 29 29 29 0a 09 20 20 20 28 68 61 73 tep)))).. (has
ea90: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 72 65 73 h-table-set! res
eaa0: 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 (tdb:step-get-s
eab0: 74 65 70 6e 61 6d 65 20 73 74 65 70 29 20 72 65 tepname step) re
eac0: 63 6f 72 64 29 0a 09 20 20 20 28 64 65 62 75 67 cord).. (debug
ead0: 3a 70 72 69 6e 74 20 36 20 2a 64 65 66 61 75 6c :print 6 *defaul
eae0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 65 63 t-log-port* "rec
eaf0: 6f 72 64 28 61 66 74 65 72 29 20 20 3d 20 22 20 ord(after) = "
eb00: 72 65 63 6f 72 64 20 0a 09 09 09 22 5c 6e 69 64 record ...."\nid
eb10: 3a 20 20 20 20 20 20 20 22 20 28 74 64 62 3a 73 : " (tdb:s
eb20: 74 65 70 2d 67 65 74 2d 69 64 20 73 74 65 70 29 tep-get-id step)
eb30: 0a 09 09 09 22 5c 6e 73 74 65 70 6e 61 6d 65 3a ...."\nstepname:
eb40: 20 22 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 " (tdb:step-get
eb50: 2d 73 74 65 70 6e 61 6d 65 20 73 74 65 70 29 0a -stepname step).
eb60: 09 09 09 22 5c 6e 73 74 61 74 65 3a 20 20 20 20 ..."\nstate:
eb70: 22 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d " (tdb:step-get-
eb80: 73 74 61 74 65 20 73 74 65 70 29 0a 09 09 09 22 state step)...."
eb90: 5c 6e 73 74 61 74 75 73 3a 20 20 20 22 20 28 74 \nstatus: " (t
eba0: 64 62 3a 73 74 65 70 2d 67 65 74 2d 73 74 61 74 db:step-get-stat
ebb0: 75 73 20 73 74 65 70 29 0a 09 09 09 22 5c 6e 74 us step)...."\nt
ebc0: 69 6d 65 3a 20 20 20 20 20 22 20 28 74 64 62 3a ime: " (tdb:
ebd0: 73 74 65 70 2d 67 65 74 2d 65 76 65 6e 74 5f 74 step-get-event_t
ebe0: 69 6d 65 20 73 74 65 70 29 29 29 29 0a 20 20 20 ime step)))).
ebf0: 20 20 20 20 3b 3b 20 28 65 6c 73 65 20 20 20 28 ;; (else (
ec00: 76 65 63 74 6f 72 2d 73 65 74 21 20 72 65 63 6f vector-set! reco
ec10: 72 64 20 31 20 28 74 64 62 3a 73 74 65 70 2d 67 rd 1 (tdb:step-g
ec20: 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 73 74 et-event_time st
ec30: 65 70 29 29 29 0a 20 20 20 20 20 20 20 28 73 6f ep))). (so
ec40: 72 74 20 73 74 65 70 73 20 28 6c 61 6d 62 64 61 rt steps (lambda
ec50: 20 28 61 20 62 29 0a 09 09 20 20 20 20 20 28 63 (a b)... (c
ec60: 6f 6e 64 0a 09 09 20 20 20 20 20 20 28 28 3c 20 ond... ((<
ec70: 20 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 2d (tdb:step-get-
ec80: 65 76 65 6e 74 5f 74 69 6d 65 20 61 29 28 74 64 event_time a)(td
ec90: 62 3a 73 74 65 70 2d 67 65 74 2d 65 76 65 6e 74 b:step-get-event
eca0: 5f 74 69 6d 65 20 62 29 29 20 23 74 29 0a 09 09 _time b)) #t)...
ecb0: 20 20 20 20 20 20 28 28 65 71 3f 20 28 74 64 62 ((eq? (tdb
ecc0: 3a 73 74 65 70 2d 67 65 74 2d 65 76 65 6e 74 5f :step-get-event_
ecd0: 74 69 6d 65 20 61 29 28 74 64 62 3a 73 74 65 70 time a)(tdb:step
ece0: 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 -get-event_time
ecf0: 62 29 29 20 0a 09 09 20 20 20 20 20 20 20 28 3c b)) ... (<
ed00: 20 20 20 28 74 64 62 3a 73 74 65 70 2d 67 65 74 (tdb:step-get
ed10: 2d 69 64 20 61 29 20 20 20 20 20 20 20 20 28 74 -id a) (t
ed20: 64 62 3a 73 74 65 70 2d 67 65 74 2d 69 64 20 62 db:step-get-id b
ed30: 29 29 29 0a 09 09 20 20 20 20 20 20 28 65 6c 73 )))... (els
ed40: 65 20 23 66 29 29 29 29 29 0a 20 20 20 20 20 20 e #f))))).
ed50: 72 65 73 29 29 0a 0a 3b 3b 20 0a 3b 3b 0a 28 64 res))..;; .;;.(d
ed60: 65 66 69 6e 65 20 28 74 65 73 74 73 3a 67 65 74 efine (tests:get
ed70: 2d 63 6f 6d 70 72 65 73 73 65 64 2d 73 74 65 70 -compressed-step
ed80: 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 s run-id test-id
ed90: 29 0a 20 20 28 6c 65 74 2a 20 28 28 73 74 65 70 ). (let* ((step
eda0: 73 2d 64 61 74 61 20 20 28 72 6d 74 3a 67 65 74 s-data (rmt:get
edb0: 2d 73 74 65 70 73 2d 66 6f 72 2d 74 65 73 74 20 -steps-for-test
edc0: 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 29 run-id test-id))
edd0: 20 3b 3b 20 20 20 20 20 20 30 20 20 20 20 20 20 ;; 0
ede0: 20 31 20 20 20 20 32 20 20 20 20 33 20 20 20 20 1 2 3
edf0: 20 20 20 34 20 20 20 20 20 20 20 35 20 20 20 20 4 5
ee00: 20 20 20 36 20 20 20 20 20 20 37 20 20 20 20 20 6 7
ee10: 20 20 0a 09 20 28 63 6f 6d 70 72 73 74 65 70 73 .. (comprsteps
ee20: 20 20 28 74 65 73 74 73 3a 70 72 6f 63 65 73 73 (tests:process
ee30: 2d 73 74 65 70 73 2d 74 61 62 6c 65 20 73 74 65 -steps-table ste
ee40: 70 73 2d 64 61 74 61 29 29 29 20 3b 3b 20 23 3c ps-data))) ;; #<
ee50: 73 74 65 70 6e 61 6d 65 20 73 74 61 72 74 20 65 stepname start e
ee60: 6e 64 20 73 74 61 74 75 73 20 44 75 72 61 74 69 nd status Durati
ee70: 6f 6e 20 4c 6f 67 66 69 6c 65 20 43 6f 6d 6d 65 on Logfile Comme
ee80: 6e 74 20 69 64 3e 0a 20 20 20 20 28 6d 61 70 20 nt id>. (map
ee90: 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 20 20 20 (lambda (x)..
eea0: 3b 3b 20 74 61 6b 65 20 61 64 76 61 6e 74 61 67 ;; take advantag
eeb0: 65 20 6f 66 20 74 68 65 20 5c 6e 20 6f 6e 20 74 e of the \n on t
eec0: 69 6d 65 2d 3e 73 74 72 69 6e 67 0a 09 20 20 20 ime->string..
eed0: 28 76 65 63 74 6f 72 20 20 20 20 3b 3b 20 77 65 (vector ;; we
eee0: 20 61 72 65 20 63 6f 6e 73 74 72 75 63 74 69 6e are constructin
eef0: 67 20 62 61 73 69 63 61 6c 6c 79 20 74 68 65 20 g basically the
ef00: 6f 72 69 67 69 6e 61 6c 20 76 65 63 74 6f 72 20 original vector
ef10: 62 75 74 20 63 6f 6c 6c 61 70 73 69 6e 67 20 73 but collapsing s
ef20: 74 61 72 74 20 65 6e 64 20 72 65 63 6f 72 64 73 tart end records
ef30: 0a 09 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 .. (vector-re
ef40: 66 20 78 20 30 29 20 20 20 20 20 20 20 20 20 20 f x 0)
ef50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ef60: 20 20 20 20 3b 3b 20 69 64 20 20 20 20 20 20 20 ;; id
ef70: 20 30 0a 09 20 20 20 20 28 6c 65 74 20 28 28 73 0.. (let ((s
ef80: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 78 20 31 (vector-ref x 1
ef90: 29 29 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 ))).. (if (
efa0: 6e 75 6d 62 65 72 3f 20 73 29 28 73 65 63 6f 6e number? s)(secon
efb0: 64 73 2d 3e 74 69 6d 65 2d 73 74 72 69 6e 67 20 ds->time-string
efc0: 73 29 20 73 29 29 20 3b 3b 20 73 74 61 72 74 74 s) s)) ;; startt
efd0: 69 6d 65 20 31 0a 09 20 20 20 20 28 6c 65 74 20 ime 1.. (let
efe0: 28 28 73 20 28 76 65 63 74 6f 72 2d 72 65 66 20 ((s (vector-ref
eff0: 78 20 32 29 29 29 0a 09 20 20 20 20 20 20 28 69 x 2))).. (i
f000: 66 20 28 6e 75 6d 62 65 72 3f 20 73 29 28 73 65 f (number? s)(se
f010: 63 6f 6e 64 73 2d 3e 74 69 6d 65 2d 73 74 72 69 conds->time-stri
f020: 6e 67 20 73 29 20 73 29 29 20 3b 3b 20 65 6e 64 ng s) s)) ;; end
f030: 74 69 6d 65 20 20 20 32 0a 09 20 20 20 20 28 76 time 2.. (v
f040: 65 63 74 6f 72 2d 72 65 66 20 78 20 33 29 20 20 ector-ref x 3)
f050: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
f060: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 73 ;; s
f070: 74 61 74 75 73 20 20 20 20 33 20 20 20 20 0a 09 tatus 3 ..
f080: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
f090: 78 20 34 29 20 20 20 20 20 20 20 20 20 20 20 20 x 4)
f0a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
f0b0: 20 20 3b 3b 20 64 75 72 61 74 69 6f 6e 20 20 34 ;; duration 4
f0c0: 0a 09 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 .. (vector-re
f0d0: 66 20 78 20 35 29 20 20 20 20 20 20 20 20 20 20 f x 5)
f0e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
f0f0: 20 20 20 20 3b 3b 20 6c 6f 67 66 69 6c 65 20 20 ;; logfile
f100: 20 35 0a 09 20 20 20 20 28 76 65 63 74 6f 72 2d 5.. (vector-
f110: 72 65 66 20 78 20 36 29 20 20 20 20 20 20 20 20 ref x 6)
f120: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
f130: 20 20 20 20 20 20 3b 3b 20 63 6f 6d 6d 65 6e 74 ;; comment
f140: 20 20 20 36 0a 09 20 20 20 20 28 76 65 63 74 6f 6.. (vecto
f150: 72 2d 72 65 66 20 78 20 37 29 29 29 20 20 20 20 r-ref x 7)))
f160: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
f170: 20 20 20 20 20 20 20 20 3b 3b 20 69 64 20 20 20 ;; id
f180: 20 20 20 20 20 37 0a 09 20 28 73 6f 72 74 20 28 7.. (sort (
f190: 68 61 73 68 2d 74 61 62 6c 65 2d 76 61 6c 75 65 hash-table-value
f1a0: 73 20 63 6f 6d 70 72 73 74 65 70 73 29 0a 09 20 s comprsteps)..
f1b0: 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 61 (lambda (a
f1c0: 20 62 29 0a 09 09 20 28 6c 65 74 20 28 28 74 69 b)... (let ((ti
f1d0: 6d 65 2d 61 20 28 76 65 63 74 6f 72 2d 72 65 66 me-a (vector-ref
f1e0: 20 61 20 31 29 29 0a 09 09 20 20 20 20 20 20 20 a 1))...
f1f0: 28 74 69 6d 65 2d 62 20 28 76 65 63 74 6f 72 2d (time-b (vector-
f200: 72 65 66 20 62 20 31 29 29 0a 09 09 20 20 20 20 ref b 1))...
f210: 20 20 20 28 69 64 2d 61 20 20 20 28 76 65 63 74 (id-a (vect
f220: 6f 72 2d 72 65 66 20 61 20 37 29 29 0a 09 09 20 or-ref a 7))...
f230: 20 20 20 20 20 20 28 69 64 2d 62 20 20 20 28 76 (id-b (v
f240: 65 63 74 6f 72 2d 72 65 66 20 62 20 37 29 29 29 ector-ref b 7)))
f250: 0a 09 09 20 20 20 28 69 66 20 28 61 6e 64 20 28 ... (if (and (
f260: 6e 75 6d 62 65 72 3f 20 74 69 6d 65 2d 61 29 28 number? time-a)(
f270: 6e 75 6d 62 65 72 3f 20 74 69 6d 65 2d 62 29 29 number? time-b))
f280: 0a 09 09 20 20 20 20 20 20 20 28 69 66 20 28 3c ... (if (<
f290: 20 74 69 6d 65 2d 61 20 74 69 6d 65 2d 62 29 0a time-a time-b).
f2a0: 09 09 09 20 20 20 23 74 0a 09 09 09 20 20 20 28 ... #t.... (
f2b0: 69 66 20 28 65 71 3f 20 74 69 6d 65 2d 61 20 74 if (eq? time-a t
f2c0: 69 6d 65 2d 62 29 0a 09 09 09 20 20 20 20 20 20 ime-b)....
f2d0: 20 28 3c 20 69 64 2d 61 20 69 64 2d 62 29 0a 09 (< id-a id-b)..
f2e0: 09 09 20 20 20 20 20 20 20 3b 3b 20 28 73 74 72 .. ;; (str
f2f0: 69 6e 67 3c 3f 20 28 63 6f 6e 63 20 28 76 65 63 ing<? (conc (vec
f300: 74 6f 72 2d 72 65 66 20 61 20 32 29 29 0a 09 09 tor-ref a 2))...
f310: 09 20 20 20 20 20 20 20 3b 3b 09 20 20 20 20 28 . ;;. (
f320: 63 6f 6e 63 20 28 76 65 63 74 6f 72 2d 72 65 66 conc (vector-ref
f330: 20 62 20 32 29 29 29 0a 09 09 09 20 20 20 20 20 b 2)))....
f340: 20 20 23 66 29 29 0a 09 09 20 20 20 20 20 20 20 #f))...
f350: 28 73 74 72 69 6e 67 3c 3f 20 28 63 6f 6e 63 20 (string<? (conc
f360: 74 69 6d 65 2d 61 29 28 63 6f 6e 63 20 74 69 6d time-a)(conc tim
f370: 65 2d 62 29 29 29 29 29 29 29 29 29 0a 0a 0a 3b e-b)))))))))...;
f380: 3b 20 53 61 76 65 20 74 65 73 74 20 73 74 61 74 ; Save test stat
f390: 65 20 61 6e 64 20 73 74 61 74 75 73 20 69 6e 20 e and status in
f3a0: 74 6f 20 61 20 66 69 6c 65 20 2e 66 69 6e 61 6c to a file .final
f3b0: 2d 73 74 61 74 75 73 20 69 6e 20 74 68 65 20 74 -status in the t
f3c0: 65 73 74 20 64 69 72 65 63 74 6f 72 79 0a 3b 3b est directory.;;
f3d0: 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a .(define (tests:
f3e0: 73 61 76 65 2d 66 69 6e 61 6c 2d 73 74 61 74 75 save-final-statu
f3f0: 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 s run-id test-id
f400: 29 0a 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 ). (let* ((test
f410: 2d 64 61 74 20 20 28 72 6d 74 3a 67 65 74 2d 74 -dat (rmt:get-t
f420: 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 72 est-info-by-id r
f430: 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 29 0a un-id test-id)).
f440: 09 20 28 6f 75 74 2d 64 69 72 20 20 20 28 64 62 . (out-dir (db
f450: 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 :test-get-rundir
f460: 20 74 65 73 74 2d 64 61 74 29 29 0a 09 20 28 73 test-dat)).. (s
f470: 74 61 74 75 73 2d 66 69 6c 65 20 20 28 63 6f 6e tatus-file (con
f480: 63 20 6f 75 74 2d 64 69 72 20 22 2f 2e 66 69 6e c out-dir "/.fin
f490: 61 6c 2d 73 74 61 74 75 73 22 29 29 0a 20 20 20 al-status")).
f4a0: 29 0a 20 20 20 20 3b 3b 20 66 69 72 73 74 20 76 ). ;; first v
f4b0: 65 72 69 66 79 20 77 65 20 61 72 65 20 61 62 6c erify we are abl
f4c0: 65 20 74 6f 20 77 72 69 74 65 20 74 68 65 20 6f e to write the o
f4d0: 75 74 70 75 74 20 66 69 6c 65 0a 20 20 20 20 28 utput file. (
f4e0: 69 66 20 28 6e 6f 74 20 28 66 69 6c 65 2d 77 72 if (not (file-wr
f4f0: 69 74 65 2d 61 63 63 65 73 73 3f 20 6f 75 74 2d ite-access? out-
f500: 64 69 72 29 29 0a 09 20 20 20 20 28 64 65 62 75 dir)).. (debu
f510: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
f520: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 52 lt-log-port* "ER
f530: 52 4f 52 3a 20 63 61 6e 6e 6f 74 20 77 72 69 74 ROR: cannot writ
f540: 65 20 2e 66 69 6e 61 6c 2d 73 74 61 74 75 73 20 e .final-status
f550: 74 6f 20 22 20 6f 75 74 2d 64 69 72 29 0a 09 20 to " out-dir)..
f560: 20 20 20 28 6c 65 74 2a 20 0a 20 20 20 20 20 20 (let* .
f570: 20 20 20 28 28 6f 75 74 70 20 20 20 20 20 20 28 ((outp (
f580: 6f 70 65 6e 2d 6f 75 74 70 75 74 2d 66 69 6c 65 open-output-file
f590: 20 73 74 61 74 75 73 2d 66 69 6c 65 29 29 0a 09 status-file))..
f5a0: 20 20 20 20 20 20 20 28 73 74 61 74 75 73 20 20 (status
f5b0: 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 (db:test-get-s
f5c0: 74 61 74 75 73 20 20 20 74 65 73 74 2d 64 61 74 tatus test-dat
f5d0: 29 29 0a 20 20 20 20 20 20 20 20 20 28 73 74 61 )). (sta
f5e0: 74 65 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d te (db:test-
f5f0: 67 65 74 2d 73 74 61 74 65 20 20 20 20 74 65 73 get-state tes
f600: 74 2d 64 61 74 29 29 29 0a 20 20 20 20 20 20 20 t-dat))).
f610: 20 28 66 70 72 69 6e 74 66 20 6f 75 74 70 20 22 (fprintf outp "
f620: 7e 53 5c 6e 22 20 73 74 61 74 65 29 20 0a 20 20 ~S\n" state) .
f630: 20 20 20 20 20 20 28 66 70 72 69 6e 74 66 20 6f (fprintf o
f640: 75 74 70 20 22 7e 53 5c 6e 22 20 73 74 61 74 75 utp "~S\n" statu
f650: 73 29 20 0a 20 20 20 20 20 20 20 20 28 63 6c 6f s) . (clo
f660: 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 6f se-output-port o
f670: 75 74 70 29 29 29 29 29 0a 0a 0a 3b 3b 20 73 75 utp)))))...;; su
f680: 6d 6d 61 72 69 7a 65 20 74 65 73 74 20 69 6e 20 mmarize test in
f690: 74 6f 20 61 20 66 69 6c 65 20 74 65 73 74 2d 73 to a file test-s
f6a0: 75 6d 6d 61 72 79 2e 68 74 6d 6c 20 69 6e 20 74 ummary.html in t
f6b0: 68 65 20 74 65 73 74 20 64 69 72 65 63 74 6f 72 he test director
f6c0: 79 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 65 y.;;.(define (te
f6d0: 73 74 73 3a 73 75 6d 6d 61 72 69 7a 65 2d 74 65 sts:summarize-te
f6e0: 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 st run-id test-i
f6f0: 64 29 0a 20 20 28 6c 65 74 2a 20 28 28 74 65 73 d). (let* ((tes
f700: 74 2d 64 61 74 20 20 28 72 6d 74 3a 67 65 74 2d t-dat (rmt:get-
f710: 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 test-info-by-id
f720: 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 29 run-id test-id))
f730: 0a 09 20 28 6f 75 74 2d 64 69 72 20 20 20 28 64 .. (out-dir (d
f740: 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 b:test-get-rundi
f750: 72 20 74 65 73 74 2d 64 61 74 29 29 0a 09 20 28 r test-dat)).. (
f760: 6f 75 74 2d 66 69 6c 65 20 20 28 63 6f 6e 63 20 out-file (conc
f770: 6f 75 74 2d 64 69 72 20 22 2f 74 65 73 74 2d 73 out-dir "/test-s
f780: 75 6d 6d 61 72 79 2e 68 74 6d 6c 22 29 29 29 0a ummary.html"))).
f790: 20 20 20 20 3b 3b 20 66 69 72 73 74 20 76 65 72 ;; first ver
f7a0: 69 66 79 20 77 65 20 61 72 65 20 61 62 6c 65 20 ify we are able
f7b0: 74 6f 20 77 72 69 74 65 20 74 68 65 20 6f 75 74 to write the out
f7c0: 70 75 74 20 66 69 6c 65 0a 20 20 20 20 28 69 66 put file. (if
f7d0: 20 28 6e 6f 74 20 28 66 69 6c 65 2d 77 72 69 74 (not (file-writ
f7e0: 65 2d 61 63 63 65 73 73 3f 20 6f 75 74 2d 64 69 e-access? out-di
f7f0: 72 29 29 0a 09 28 64 65 62 75 67 3a 70 72 69 6e r))..(debug:prin
f800: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
f810: 2d 70 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 63 -port* "ERROR: c
f820: 61 6e 6e 6f 74 20 77 72 69 74 65 20 74 65 73 74 annot write test
f830: 2d 73 75 6d 6d 61 72 79 2e 68 74 6d 6c 20 74 6f -summary.html to
f840: 20 22 20 6f 75 74 2d 64 69 72 29 0a 09 28 6c 65 " out-dir)..(le
f850: 74 2a 20 28 3b 3b 20 28 73 74 65 70 73 2d 64 61 t* (;; (steps-da
f860: 74 20 28 72 6d 74 3a 67 65 74 2d 73 74 65 70 73 t (rmt:get-steps
f870: 2d 66 6f 72 2d 74 65 73 74 20 72 75 6e 2d 69 64 -for-test run-id
f880: 20 74 65 73 74 2d 69 64 29 29 0a 09 20 20 20 20 test-id))..
f890: 20 20 20 28 74 65 73 74 2d 6e 61 6d 65 20 28 64 (test-name (d
f8a0: 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e b:test-get-testn
f8b0: 61 6d 65 20 74 65 73 74 2d 64 61 74 29 29 0a 09 ame test-dat))..
f8c0: 20 20 20 20 20 20 20 28 69 74 65 6d 2d 70 61 74 (item-pat
f8d0: 68 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 h (db:test-get-i
f8e0: 74 65 6d 2d 70 61 74 68 20 74 65 73 74 2d 64 61 tem-path test-da
f8f0: 74 29 29 0a 09 20 20 20 20 20 20 20 28 66 75 6c t)).. (ful
f900: 6c 2d 6e 61 6d 65 20 28 64 62 3a 74 65 73 74 2d l-name (db:test-
f910: 6d 61 6b 65 2d 66 75 6c 6c 2d 6e 61 6d 65 20 74 make-full-name t
f920: 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 est-name item-pa
f930: 74 68 29 29 0a 09 20 20 20 20 20 20 20 28 6f 75 th)).. (ou
f940: 70 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 6f 75 p (open-ou
f950: 74 70 75 74 2d 66 69 6c 65 20 6f 75 74 2d 66 69 tput-file out-fi
f960: 6c 65 29 29 0a 09 20 20 20 20 20 20 20 28 73 74 le)).. (st
f970: 61 74 75 73 20 20 20 20 28 64 62 3a 74 65 73 74 atus (db:test
f980: 2d 67 65 74 2d 73 74 61 74 75 73 20 20 20 74 65 -get-status te
f990: 73 74 2d 64 61 74 29 29 0a 09 20 20 20 20 20 20 st-dat))..
f9a0: 20 28 63 6f 6c 6f 72 20 20 20 20 20 28 63 6f 6d (color (com
f9b0: 6d 6f 6e 3a 67 65 74 2d 63 6f 6c 6f 72 2d 66 72 mon:get-color-fr
f9c0: 6f 6d 2d 73 74 61 74 75 73 20 73 74 61 74 75 73 om-status status
f9d0: 29 29 0a 09 20 20 20 20 20 20 20 28 6c 6f 67 66 )).. (logf
f9e0: 20 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 (db:test-g
f9f0: 65 74 2d 66 69 6e 61 6c 5f 6c 6f 67 66 20 74 65 et-final_logf te
fa00: 73 74 2d 64 61 74 29 29 0a 09 20 20 20 20 20 20 st-dat))..
fa10: 20 28 73 74 65 70 73 2d 64 61 74 20 28 74 65 73 (steps-dat (tes
fa20: 74 73 3a 67 65 74 2d 63 6f 6d 70 72 65 73 73 65 ts:get-compresse
fa30: 64 2d 73 74 65 70 73 20 72 75 6e 2d 69 64 20 74 d-steps run-id t
fa40: 65 73 74 2d 69 64 29 29 29 0a 09 20 20 3b 3b 20 est-id))).. ;;
fa50: 28 64 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 6f 6d (dcommon:get-com
fa60: 70 72 65 73 73 65 64 2d 73 74 65 70 73 20 23 66 pressed-steps #f
fa70: 20 31 20 33 30 30 34 35 29 0a 09 20 20 3b 3b 20 1 30045).. ;;
fa80: 28 23 28 22 77 61 73 74 69 6e 67 5f 74 69 6d 65 (#("wasting_time
fa90: 22 20 22 32 33 3a 33 36 3a 31 33 22 20 22 32 33 " "23:36:13" "23
faa0: 3a 33 36 3a 32 31 22 20 22 30 22 20 22 38 2e 30 :36:21" "0" "8.0
fab0: 73 22 20 22 77 61 73 74 69 6e 67 5f 74 69 6d 65 s" "wasting_time
fac0: 2e 6c 6f 67 22 29 29 0a 09 0a 09 20 20 28 73 3a .log")).... (s:
fad0: 6f 75 74 70 75 74 2d 6e 65 77 0a 09 20 20 20 6f output-new.. o
fae0: 75 70 0a 09 20 20 20 28 73 3a 68 74 6d 6c 0a 09 up.. (s:html..
faf0: 20 20 20 20 28 73 3a 74 69 74 6c 65 20 22 53 75 (s:title "Su
fb00: 6d 6d 61 72 79 20 66 6f 72 20 22 20 66 75 6c 6c mmary for " full
fb10: 2d 6e 61 6d 65 29 0a 09 20 20 20 20 28 73 3a 62 -name).. (s:b
fb20: 6f 64 79 20 0a 09 20 20 20 20 20 28 73 3a 68 32 ody .. (s:h2
fb30: 20 22 53 75 6d 6d 61 72 79 20 66 6f 72 20 22 20 "Summary for "
fb40: 66 75 6c 6c 2d 6e 61 6d 65 29 0a 09 20 20 20 20 full-name)..
fb50: 20 28 73 3a 74 61 62 6c 65 20 27 63 65 6c 6c 73 (s:table 'cells
fb60: 70 61 63 69 6e 67 20 22 30 22 20 27 62 6f 72 64 pacing "0" 'bord
fb70: 65 72 20 22 31 22 0a 09 09 20 20 20 20 20 20 28 er "1"... (
fb80: 73 3a 74 72 20 28 73 3a 74 64 20 22 72 75 6e 20 s:tr (s:td "run
fb90: 69 64 22 29 20 20 20 28 73 3a 74 64 20 28 64 62 id") (s:td (db
fba0: 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 5f 69 64 :test-get-run_id
fbb0: 20 20 20 74 65 73 74 2d 64 61 74 29 29 0a 09 09 test-dat))...
fbc0: 09 20 20 20 20 28 73 3a 74 64 20 22 74 65 73 74 . (s:td "test
fbd0: 20 69 64 22 29 20 20 28 73 3a 74 64 20 28 64 62 id") (s:td (db
fbe0: 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 20 20 20 :test-get-id
fbf0: 20 20 20 74 65 73 74 2d 64 61 74 29 29 29 0a 09 test-dat)))..
fc00: 09 20 20 20 20 20 20 28 73 3a 74 72 20 28 73 3a . (s:tr (s:
fc10: 74 64 20 22 74 65 73 74 6e 61 6d 65 22 29 20 28 td "testname") (
fc20: 73 3a 74 64 20 74 65 73 74 2d 6e 61 6d 65 29 0a s:td test-name).
fc30: 09 09 09 20 20 20 20 28 73 3a 74 64 20 22 69 74 ... (s:td "it
fc40: 65 6d 70 61 74 68 22 29 20 28 73 3a 74 64 20 69 empath") (s:td i
fc50: 74 65 6d 2d 70 61 74 68 29 29 0a 09 09 20 20 20 tem-path))...
fc60: 20 20 20 28 73 3a 74 72 20 28 73 3a 74 64 20 22 (s:tr (s:td "
fc70: 73 74 61 74 65 22 29 20 20 20 20 28 73 3a 74 64 state") (s:td
fc80: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 (db:test-get-st
fc90: 61 74 65 20 20 20 20 74 65 73 74 2d 64 61 74 29 ate test-dat)
fca0: 29 0a 09 09 09 20 20 20 20 28 73 3a 74 64 20 22 ).... (s:td "
fcb0: 73 74 61 74 75 73 22 29 20 20 20 28 73 3a 74 64 status") (s:td
fcc0: 20 28 73 3a 61 20 27 68 72 65 66 20 6c 6f 67 66 (s:a 'href logf
fcd0: 20 28 73 3a 66 6f 6e 74 20 27 63 6f 6c 6f 72 20 (s:font 'color
fce0: 63 6f 6c 6f 72 20 73 74 61 74 75 73 29 29 29 29 color status))))
fcf0: 0a 09 09 20 20 20 20 20 20 28 73 3a 74 72 20 28 ... (s:tr (
fd00: 73 3a 74 64 20 22 54 65 73 74 44 61 74 65 22 29 s:td "TestDate")
fd10: 20 28 73 3a 74 64 20 28 73 65 63 6f 6e 64 73 2d (s:td (seconds-
fd20: 3e 77 6f 72 6b 2d 77 65 65 6b 2f 64 61 79 2d 74 >work-week/day-t
fd30: 69 6d 65 20 0a 09 09 09 09 09 09 20 20 20 20 20 ime .......
fd40: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 65 76 65 (db:test-get-eve
fd50: 6e 74 5f 74 69 6d 65 20 74 65 73 74 2d 64 61 74 nt_time test-dat
fd60: 29 29 29 0a 09 09 09 20 20 20 20 28 73 3a 74 64 ))).... (s:td
fd70: 20 22 44 75 72 61 74 69 6f 6e 22 29 20 28 73 3a "Duration") (s:
fd80: 74 64 20 28 73 65 63 6f 6e 64 73 2d 3e 68 72 2d td (seconds->hr-
fd90: 6d 69 6e 2d 73 65 63 20 28 64 62 3a 74 65 73 74 min-sec (db:test
fda0: 2d 67 65 74 2d 72 75 6e 5f 64 75 72 61 74 69 6f -get-run_duratio
fdb0: 6e 20 74 65 73 74 2d 64 61 74 29 29 29 29 29 0a n test-dat))))).
fdc0: 09 20 20 20 20 20 28 73 3a 68 33 20 22 4c 6f 67 . (s:h3 "Log
fdd0: 20 66 69 6c 65 73 22 29 0a 09 20 20 20 20 20 28 files").. (
fde0: 73 3a 74 61 62 6c 65 20 0a 09 20 20 20 20 20 20 s:table ..
fdf0: 27 63 65 6c 6c 73 70 61 63 69 6e 67 20 22 30 22 'cellspacing "0"
fe00: 20 27 62 6f 72 64 65 72 20 22 31 22 0a 09 20 20 'border "1"..
fe10: 20 20 20 20 28 73 3a 74 72 20 28 73 3a 74 64 20 (s:tr (s:td
fe20: 22 46 69 6e 61 6c 20 6c 6f 67 22 29 28 73 3a 74 "Final log")(s:t
fe30: 64 20 28 73 3a 61 20 27 68 72 65 66 20 6c 6f 67 d (s:a 'href log
fe40: 66 20 6c 6f 67 66 29 29 29 29 0a 09 20 20 20 20 f logf))))..
fe50: 20 28 73 3a 74 61 62 6c 65 0a 09 20 20 20 20 20 (s:table..
fe60: 20 27 63 65 6c 6c 73 70 61 63 69 6e 67 20 22 30 'cellspacing "0
fe70: 22 20 27 62 6f 72 64 65 72 20 22 31 22 0a 09 20 " 'border "1"..
fe80: 20 20 20 20 20 28 73 3a 74 72 20 28 73 3a 74 64 (s:tr (s:td
fe90: 20 22 53 74 65 70 20 4e 61 6d 65 22 29 28 73 3a "Step Name")(s:
fea0: 74 64 20 22 53 74 61 72 74 22 29 28 73 3a 74 64 td "Start")(s:td
feb0: 20 22 45 6e 64 22 29 28 73 3a 74 64 20 22 53 74 "End")(s:td "St
fec0: 61 74 75 73 22 29 28 73 3a 74 64 20 22 44 75 72 atus")(s:td "Dur
fed0: 61 74 69 6f 6e 22 29 28 73 3a 74 64 20 22 4c 6f ation")(s:td "Lo
fee0: 67 20 46 69 6c 65 22 29 29 0a 09 20 20 20 20 20 g File"))..
fef0: 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 73 (map (lambda (s
ff00: 74 65 70 2d 64 61 74 29 0a 09 09 20 20 20 20 20 tep-dat)...
ff10: 28 73 3a 74 72 20 28 73 3a 74 64 20 28 74 64 62 (s:tr (s:td (tdb
ff20: 3a 73 74 65 70 73 2d 74 61 62 6c 65 2d 67 65 74 :steps-table-get
ff30: 2d 73 74 65 70 6e 61 6d 65 20 73 74 65 70 2d 64 -stepname step-d
ff40: 61 74 29 29 0a 09 09 09 20 20 20 28 73 3a 74 64 at)).... (s:td
ff50: 20 28 74 64 62 3a 73 74 65 70 73 2d 74 61 62 6c (tdb:steps-tabl
ff60: 65 2d 67 65 74 2d 73 74 61 72 74 20 20 20 20 73 e-get-start s
ff70: 74 65 70 2d 64 61 74 29 29 0a 09 09 09 20 20 20 tep-dat))....
ff80: 28 73 3a 74 64 20 28 74 64 62 3a 73 74 65 70 73 (s:td (tdb:steps
ff90: 2d 74 61 62 6c 65 2d 67 65 74 2d 65 6e 64 20 20 -table-get-end
ffa0: 20 20 20 20 73 74 65 70 2d 64 61 74 29 29 0a 09 step-dat))..
ffb0: 09 09 20 20 20 28 73 3a 74 64 20 28 74 64 62 3a .. (s:td (tdb:
ffc0: 73 74 65 70 73 2d 74 61 62 6c 65 2d 67 65 74 2d steps-table-get-
ffd0: 73 74 61 74 75 73 20 20 20 73 74 65 70 2d 64 61 status step-da
ffe0: 74 29 29 0a 09 09 09 20 20 20 28 73 3a 74 64 20 t)).... (s:td
fff0: 28 74 64 62 3a 73 74 65 70 73 2d 74 61 62 6c 65 (tdb:steps-table
10000 2d 67 65 74 2d 72 75 6e 74 69 6d 65 20 20 73 74 -get-runtime st
10010 65 70 2d 64 61 74 29 29 0a 09 09 09 20 20 20 28 ep-dat)).... (
10020 73 3a 74 64 20 28 6c 65 74 20 28 28 73 74 65 70 s:td (let ((step
10030 2d 6c 6f 67 20 28 74 64 62 3a 73 74 65 70 73 2d -log (tdb:steps-
10040 74 61 62 6c 65 2d 67 65 74 2d 6c 6f 67 2d 66 69 table-get-log-fi
10050 6c 65 20 73 74 65 70 2d 64 61 74 29 29 29 0a 09 le step-dat)))..
10060 09 09 09 20 20 20 28 73 3a 61 20 27 68 72 65 66 ... (s:a 'href
10070 20 73 74 65 70 2d 6c 6f 67 20 73 74 65 70 2d 6c step-log step-l
10080 6f 67 29 29 29 29 29 0a 09 09 20 20 20 73 74 65 og)))))... ste
10090 70 73 2d 64 61 74 29 29 0a 09 20 20 20 20 20 29 ps-dat)).. )
100a0 29 29 0a 09 20 20 28 63 6c 6f 73 65 2d 6f 75 74 )).. (close-out
100b0 70 75 74 2d 70 6f 72 74 20 6f 75 70 29 29 29 29 put-port oup))))
100c0 29 0a 09 20 20 0a 09 20 20 0a 3b 3b 20 4d 55 53 ).. .. .;; MUS
100d0 54 20 42 45 20 43 41 4c 4c 45 44 20 6c 6f 63 61 T BE CALLED loca
100e0 6c 21 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 74 l!.;;.(define (t
100f0 65 73 74 73 3a 74 65 73 74 2d 67 65 74 2d 70 61 ests:test-get-pa
10100 74 68 73 2d 6d 61 74 63 68 69 6e 67 20 6b 65 79 ths-matching key
10110 6e 61 6d 65 73 20 74 61 72 67 65 74 20 66 6e 61 names target fna
10120 6d 65 70 61 74 74 20 23 21 6b 65 79 20 28 72 65 mepatt #!key (re
10130 73 20 27 28 29 29 29 0a 20 20 3b 3b 20 42 55 47 s '())). ;; BUG
10140 3a 20 4d 6f 76 65 20 74 68 65 20 76 61 6c 75 65 : Move the value
10150 73 20 64 65 72 69 76 65 64 20 66 72 6f 6d 20 61 s derived from a
10160 72 67 73 20 74 6f 20 70 61 72 61 6d 65 74 65 72 rgs to parameter
10170 73 20 61 6e 64 20 70 75 73 68 20 74 6f 20 6d 65 s and push to me
10180 67 61 74 65 73 74 2e 73 63 6d 0a 20 20 28 6c 65 gatest.scm. (le
10190 74 2a 20 28 28 74 65 73 74 70 61 74 74 20 20 20 t* ((testpatt
101a0 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (or (args:get-ar
101b0 67 20 22 2d 74 65 73 74 70 61 74 74 22 29 28 61 g "-testpatt")(a
101c0 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 65 rgs:get-arg "-te
101d0 73 74 70 61 74 74 22 29 20 22 25 22 29 29 0a 09 stpatt") "%"))..
101e0 20 28 73 74 61 74 65 70 61 74 74 20 20 28 6f 72 (statepatt (or
101f0 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
10200 2d 73 74 61 74 65 22 29 20 20 20 28 61 72 67 73 -state") (args
10210 3a 67 65 74 2d 61 72 67 20 22 3a 73 74 61 74 65 :get-arg ":state
10220 22 29 20 20 20 20 22 25 22 29 29 0a 09 20 28 73 ") "%")).. (s
10230 74 61 74 75 73 70 61 74 74 20 28 6f 72 20 28 61 tatuspatt (or (a
10240 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 73 74 rgs:get-arg "-st
10250 61 74 75 73 22 29 20 20 28 61 72 67 73 3a 67 65 atus") (args:ge
10260 74 2d 61 72 67 20 22 3a 73 74 61 74 75 73 22 29 t-arg ":status")
10270 20 20 20 22 25 22 29 29 0a 09 20 28 72 75 6e 6e "%")).. (runn
10280 61 6d 65 20 20 20 20 28 6f 72 20 28 61 72 67 73 ame (or (args
10290 3a 67 65 74 2d 61 72 67 20 22 2d 72 75 6e 6e 61 :get-arg "-runna
102a0 6d 65 22 29 20 28 61 72 67 73 3a 67 65 74 2d 61 me") (args:get-a
102b0 72 67 20 22 3a 72 75 6e 6e 61 6d 65 22 29 20 20 rg ":runname")
102c0 22 25 22 29 29 0a 09 20 28 70 61 74 68 73 2d 66 "%")).. (paths-f
102d0 72 6f 6d 2d 64 62 20 28 72 6d 74 3a 74 65 73 74 rom-db (rmt:test
102e0 2d 67 65 74 2d 70 61 74 68 73 2d 6d 61 74 63 68 -get-paths-match
102f0 69 6e 67 2d 6b 65 79 6e 61 6d 65 73 2d 74 61 72 ing-keynames-tar
10300 67 65 74 2d 6e 65 77 20 6b 65 79 6e 61 6d 65 73 get-new keynames
10310 20 74 61 72 67 65 74 20 72 65 73 0a 09 09 09 09 target res.....
10320 09 74 65 73 74 70 61 74 74 0a 09 09 09 09 09 73 .testpatt......s
10330 74 61 74 65 70 61 74 74 0a 09 09 09 09 09 73 74 tatepatt......st
10340 61 74 75 73 70 61 74 74 0a 09 09 09 09 09 72 75 atuspatt......ru
10350 6e 6e 61 6d 65 29 29 29 0a 20 20 20 20 28 69 66 nname))). (if
10360 20 66 6e 61 6d 65 70 61 74 74 0a 09 28 61 70 70 fnamepatt..(app
10370 6c 79 20 61 70 70 65 6e 64 20 0a 09 20 20 20 20 ly append ..
10380 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 (map (lambda
10390 28 70 29 0a 09 09 20 20 20 20 20 20 28 69 66 20 (p)... (if
103a0 28 64 69 72 65 63 74 6f 72 79 2d 65 78 69 73 74 (directory-exist
103b0 73 3f 20 70 29 0a 09 09 09 20 20 28 6c 65 74 20 s? p).... (let
103c0 28 28 67 6c 6f 62 2d 71 75 65 72 79 20 28 63 6f ((glob-query (co
103d0 6e 63 20 70 20 22 2f 22 20 66 6e 61 6d 65 70 61 nc p "/" fnamepa
103e0 74 74 29 29 29 0a 09 09 09 20 20 20 20 28 68 61 tt))).... (ha
103f0 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a ndle-exceptions.
10400 09 09 09 09 65 78 6e 0a 09 09 09 20 20 20 20 20 ....exn....
10410 20 28 62 65 67 69 6e 0a 09 09 09 09 28 70 72 69 (begin.....(pri
10420 6e 74 20 22 62 75 69 6c 74 2d 69 6e 20 67 6c 6f nt "built-in glo
10430 62 20 6f 6e 20 22 20 67 6c 6f 62 2d 71 75 65 72 b on " glob-quer
10440 79 20 22 2c 20 66 61 69 6c 65 64 2c 20 74 72 79 y ", failed, try
10450 20 75 73 69 6e 67 20 74 68 65 20 73 68 65 6c 6c using the shell
10460 2e 20 65 78 6e 3d 22 20 65 78 6e 29 0a 09 09 09 . exn=" exn)....
10470 09 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f .(with-input-fro
10480 6d 2d 70 69 70 65 0a 09 09 09 09 20 28 63 6f 6e m-pipe..... (con
10490 63 20 22 65 63 68 6f 20 22 20 67 6c 6f 62 2d 71 c "echo " glob-q
104a0 75 65 72 79 29 0a 09 09 09 09 20 72 65 61 64 2d uery)..... read-
104b0 6c 69 6e 65 73 29 29 20 20 3b 3b 20 77 65 20 61 lines)) ;; we a
104c0 72 65 6e 27 74 20 67 6f 69 6e 67 20 74 6f 20 74 ren't going to t
104d0 72 79 20 74 6f 6f 20 68 61 72 64 2e 20 49 66 20 ry too hard. If
104e0 67 6c 6f 62 20 62 72 65 61 6b 73 20 69 74 20 69 glob breaks it i
104f0 73 20 6c 69 6b 65 6c 79 20 62 65 63 61 75 73 65 s likely because
10500 20 73 6f 6d 65 6f 6e 65 20 74 72 69 65 64 20 74 someone tried t
10510 6f 20 64 6f 20 2a 2f 2a 2f 2a 2e 6c 6f 67 20 6f o do */*/*.log o
10520 72 20 73 69 6d 69 6c 61 72 0a 09 09 09 20 20 20 r similar....
10530 20 20 20 28 67 6c 6f 62 20 67 6c 6f 62 2d 71 75 (glob glob-qu
10540 65 72 79 29 29 29 0a 09 09 09 20 20 27 28 29 29 ery))).... '())
10550 29 0a 09 09 20 20 20 20 70 61 74 68 73 2d 66 72 )... paths-fr
10560 6f 6d 2d 64 62 29 29 0a 09 70 61 74 68 73 2d 66 om-db))..paths-f
10570 72 6f 6d 2d 64 62 29 29 29 0a 0a 09 09 09 20 20 rom-db))).....
10580 20 20 20 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=========
10590 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
105a0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
105b0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
105c0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
105d0 20 47 61 74 68 65 72 20 64 61 74 61 20 66 72 6f Gather data fro
105e0 6d 20 74 65 73 74 2f 74 61 73 6b 20 73 70 65 63 m test/task spec
105f0 69 66 69 63 61 74 69 6f 6e 73 0a 3b 3b 3d 3d 3d ifications.;;===
10600 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10610 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10620 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10630 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10640 3d 3d 3d 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 20 ===..;; (define
10650 28 74 65 73 74 73 3a 67 65 74 2d 76 61 6c 69 64 (tests:get-valid
10660 2d 74 65 73 74 73 20 74 65 73 74 73 64 69 72 20 -tests testsdir
10670 74 65 73 74 2d 70 61 74 74 73 29 20 3b 3b 20 20 test-patts) ;;
10680 23 21 6b 65 79 20 28 74 65 73 74 2d 6e 61 6d 65 #!key (test-name
10690 73 20 27 28 29 29 29 0a 3b 3b 20 20 20 28 6c 65 s '())).;; (le
106a0 74 20 28 28 74 65 73 74 73 20 28 67 6c 6f 62 20 t ((tests (glob
106b0 28 63 6f 6e 63 20 74 65 73 74 73 64 69 72 20 22 (conc testsdir "
106c0 2f 74 65 73 74 73 2f 2a 22 29 29 29 29 20 3b 3b /tests/*")))) ;;
106d0 20 22 20 28 73 74 72 69 6e 67 2d 74 72 61 6e 73 " (string-trans
106e0 6c 61 74 65 20 70 61 74 74 20 22 25 22 20 22 2a late patt "%" "*
106f0 22 29 29 29 29 29 0a 3b 3b 20 20 20 20 20 28 73 "))))).;; (s
10700 65 74 21 20 74 65 73 74 73 20 28 66 69 6c 74 65 et! tests (filte
10710 72 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 29 r (lambda (test)
10720 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 (common:file-exi
10730 73 74 73 3f 20 28 63 6f 6e 63 20 74 65 73 74 20 sts? (conc test
10740 22 2f 74 65 73 74 63 6f 6e 66 69 67 22 29 29 29 "/testconfig")))
10750 20 74 65 73 74 73 29 29 0a 3b 3b 20 20 20 20 20 tests)).;;
10760 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 74 (delete-duplicat
10770 65 73 0a 3b 3b 20 20 20 20 20 20 28 66 69 6c 74 es.;; (filt
10780 65 72 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 er (lambda (test
10790 6e 61 6d 65 29 0a 3b 3b 20 09 20 20 20 20 20 20 name).;; .
107a0 20 28 74 65 73 74 73 3a 6d 61 74 63 68 20 74 65 (tests:match te
107b0 73 74 2d 70 61 74 74 73 20 74 65 73 74 6e 61 6d st-patts testnam
107c0 65 20 23 66 29 29 0a 3b 3b 20 09 20 20 20 20 20 e #f)).;; .
107d0 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 74 65 (map (lambda (te
107e0 73 74 70 29 0a 3b 3b 20 09 09 20 20 20 20 28 6c stp).;; .. (l
107f0 61 73 74 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 ast (string-spli
10800 74 20 74 65 73 74 70 20 22 2f 22 29 29 29 0a 3b t testp "/"))).;
10810 3b 20 09 09 20 20 74 65 73 74 73 29 29 29 29 29 ; .. tests)))))
10820 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 ..(define (tests
10830 3a 67 65 74 2d 74 65 73 74 2d 70 61 74 68 2d 66 :get-test-path-f
10840 72 6f 6d 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 29 rom-environment)
10850 0a 20 20 28 69 66 20 28 61 6e 64 20 28 67 65 74 . (if (and (get
10860 65 6e 76 20 22 4d 54 5f 4c 49 4e 4b 54 52 45 45 env "MT_LINKTREE
10870 22 29 0a 09 20 20 20 28 67 65 74 65 6e 76 20 22 ").. (getenv "
10880 4d 54 5f 54 41 52 47 45 54 22 29 0a 09 20 20 20 MT_TARGET")..
10890 28 67 65 74 65 6e 76 20 22 4d 54 5f 52 55 4e 4e (getenv "MT_RUNN
108a0 41 4d 45 22 29 0a 09 20 20 20 28 67 65 74 65 6e AME").. (geten
108b0 76 20 22 4d 54 5f 54 45 53 54 5f 4e 41 4d 45 22 v "MT_TEST_NAME"
108c0 29 0a 09 20 20 20 28 67 65 74 65 6e 76 20 22 4d ).. (getenv "M
108d0 54 5f 49 54 45 4d 50 41 54 48 22 29 29 0a 20 20 T_ITEMPATH")).
108e0 20 20 20 20 28 63 6f 6e 63 20 28 67 65 74 65 6e (conc (geten
108f0 76 20 22 4d 54 5f 4c 49 4e 4b 54 52 45 45 22 29 v "MT_LINKTREE")
10900 20 20 22 2f 22 0a 09 20 20 20 20 28 67 65 74 65 "/".. (gete
10910 6e 76 20 22 4d 54 5f 54 41 52 47 45 54 22 29 20 nv "MT_TARGET")
10920 20 20 20 22 2f 22 0a 09 20 20 20 20 28 67 65 74 "/".. (get
10930 65 6e 76 20 22 4d 54 5f 52 55 4e 4e 41 4d 45 22 env "MT_RUNNAME"
10940 29 20 20 20 22 2f 22 0a 09 20 20 20 20 28 67 65 ) "/".. (ge
10950 74 65 6e 76 20 22 4d 54 5f 54 45 53 54 5f 4e 41 tenv "MT_TEST_NA
10960 4d 45 22 29 0a 09 20 20 20 20 28 69 66 20 28 61 ME").. (if (a
10970 6e 64 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 49 nd (getenv "MT_I
10980 54 45 4d 50 41 54 48 22 29 0a 20 20 20 20 20 20 TEMPATH").
10990 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
109a0 6e 6f 74 20 28 73 74 72 69 6e 67 3d 3f 20 22 22 not (string=? ""
109b0 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 49 54 45 (getenv "MT_ITE
109c0 4d 50 41 54 48 22 29 29 29 29 0a 09 09 28 63 6f MPATH"))))...(co
109d0 6e 63 20 22 2f 22 20 28 67 65 74 65 6e 76 20 22 nc "/" (getenv "
109e0 4d 54 5f 49 54 45 4d 50 41 54 48 22 29 29 0a 20 MT_ITEMPATH")).
109f0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 22 "
10a00 22 29 29 0a 20 20 20 20 20 20 23 66 29 29 0a 0a ")). #f))..
10a10 3b 3b 20 69 66 20 2e 74 65 73 74 63 6f 6e 66 69 ;; if .testconfi
10a20 67 20 65 78 69 73 74 73 20 69 6e 20 74 65 73 74 g exists in test
10a30 20 64 69 72 65 63 74 6f 72 79 20 72 65 61 64 20 directory read
10a40 61 6e 64 20 72 65 74 75 72 6e 20 69 74 0a 3b 3b and return it.;;
10a50 20 65 6c 73 65 20 69 66 20 68 61 76 65 20 63 61 else if have ca
10a60 63 68 65 64 20 63 6f 70 79 20 69 6e 20 2a 74 65 ched copy in *te
10a70 73 74 63 6f 6e 66 69 67 73 2a 20 72 65 74 75 72 stconfigs* retur
10a80 6e 20 69 74 20 49 46 46 20 74 68 65 72 65 20 69 n it IFF there i
10a90 73 20 61 20 73 65 63 74 69 6f 6e 20 22 68 61 76 s a section "hav
10aa0 65 20 66 75 6c 6c 64 61 74 61 22 0a 3b 3b 20 65 e fulldata".;; e
10ab0 6c 73 65 20 72 65 61 64 20 74 68 65 20 74 65 73 lse read the tes
10ac0 74 63 6f 6e 66 69 67 20 66 69 6c 65 0a 3b 3b 20 tconfig file.;;
10ad0 20 20 69 66 20 68 61 76 65 20 70 61 74 68 20 74 if have path t
10ae0 6f 20 74 65 73 74 20 64 69 72 65 63 74 6f 72 79 o test directory
10af0 20 73 61 76 65 20 74 68 65 20 63 6f 6e 66 69 67 save the config
10b00 20 61 73 20 2e 74 65 73 74 63 6f 6e 66 69 67 20 as .testconfig
10b10 61 6e 64 20 72 65 74 75 72 6e 20 69 74 0a 3b 3b and return it.;;
10b20 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a .(define (tests:
10b30 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 74 get-testconfig t
10b40 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 est-name item-pa
10b50 74 68 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 th test-registry
10b60 20 73 79 73 74 65 6d 2d 61 6c 6c 6f 77 65 64 20 system-allowed
10b70 23 21 6b 65 79 20 28 66 6f 72 63 65 2d 63 72 65 #!key (force-cre
10b80 61 74 65 20 23 66 29 28 61 6c 6c 6f 77 2d 77 72 ate #f)(allow-wr
10b90 69 74 65 2d 63 61 63 68 65 20 23 74 29 28 77 61 ite-cache #t)(wa
10ba0 69 74 2d 61 2d 6d 69 6e 75 74 65 20 23 66 29 29 it-a-minute #f))
10bb0 0a 20 20 28 6c 65 74 2a 20 28 28 75 73 65 2d 63 . (let* ((use-c
10bc0 61 63 68 65 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a ache (common:
10bd0 75 73 65 2d 63 61 63 68 65 3f 29 29 0a 09 20 28 use-cache?)).. (
10be0 63 61 63 68 65 2d 70 61 74 68 20 20 20 28 74 65 cache-path (te
10bf0 73 74 73 3a 67 65 74 2d 74 65 73 74 2d 70 61 74 sts:get-test-pat
10c00 68 2d 66 72 6f 6d 2d 65 6e 76 69 72 6f 6e 6d 65 h-from-environme
10c10 6e 74 29 29 0a 09 20 28 63 61 63 68 65 2d 66 69 nt)).. (cache-fi
10c20 6c 65 20 20 20 28 61 6e 64 20 63 61 63 68 65 2d le (and cache-
10c30 70 61 74 68 20 28 63 6f 6e 63 20 63 61 63 68 65 path (conc cache
10c40 2d 70 61 74 68 20 22 2f 2e 74 65 73 74 63 6f 6e -path "/.testcon
10c50 66 69 67 22 29 29 29 0a 09 20 28 63 61 63 68 65 fig"))).. (cache
10c60 2d 65 78 69 73 74 73 20 28 61 6e 64 20 63 61 63 -exists (and cac
10c70 68 65 2d 66 69 6c 65 0a 09 09 09 20 20 20 20 28 he-file.... (
10c80 6e 6f 74 20 66 6f 72 63 65 2d 63 72 65 61 74 65 not force-create
10c90 29 20 20 3b 3b 20 69 66 20 66 6f 72 63 65 2d 63 ) ;; if force-c
10ca0 72 65 61 74 65 20 74 68 65 6e 20 70 72 65 74 65 reate then prete
10cb0 6e 64 20 74 68 65 72 65 20 69 73 20 6e 6f 20 63 nd there is no c
10cc0 61 63 68 65 20 74 6f 20 72 65 61 64 0a 09 09 09 ache to read....
10cd0 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 (common:file
10ce0 2d 65 78 69 73 74 73 3f 20 63 61 63 68 65 2d 66 -exists? cache-f
10cf0 69 6c 65 29 29 29 0a 09 20 28 63 61 63 68 65 64 ile))).. (cached
10d00 2d 64 61 74 20 20 20 28 69 66 20 28 61 6e 64 20 -dat (if (and
10d10 28 6e 6f 74 20 66 6f 72 63 65 2d 63 72 65 61 74 (not force-creat
10d20 65 29 0a 09 09 09 09 63 61 63 68 65 2d 65 78 69 e).....cache-exi
10d30 73 74 73 0a 09 09 09 09 75 73 65 2d 63 61 63 68 sts.....use-cach
10d40 65 29 0a 09 09 09 20 20 20 28 68 61 6e 64 6c 65 e).... (handle
10d50 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 09 20 -exceptions....
10d60 20 20 20 20 20 20 65 78 6e 0a 09 09 09 20 20 20 exn....
10d70 20 20 28 62 65 67 69 6e 0a 09 09 09 20 20 20 20 (begin....
10d80 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
10d90 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
10da0 6f 72 74 2a 20 22 66 61 69 6c 65 64 20 74 6f 20 ort* "failed to
10db0 72 65 61 64 20 22 20 63 61 63 68 65 2d 66 69 6c read " cache-fil
10dc0 65 20 22 2c 20 65 78 6e 3d 22 20 65 78 6e 29 0a e ", exn=" exn).
10dd0 09 09 09 20 20 20 20 20 20 20 23 66 29 20 3b 3b ... #f) ;;
10de0 20 61 6e 79 20 69 73 73 75 65 73 2c 20 6a 75 73 any issues, jus
10df0 74 20 67 69 76 65 20 75 70 20 77 69 74 68 20 74 t give up with t
10e00 68 65 20 63 61 63 68 65 64 20 76 65 72 73 69 6f he cached versio
10e10 6e 20 61 6e 64 20 72 65 2d 72 65 61 64 0a 09 09 n and re-read...
10e20 09 20 20 20 20 20 28 63 6f 6e 66 69 67 66 3a 72 . (configf:r
10e30 65 61 64 2d 61 6c 69 73 74 20 63 61 63 68 65 2d ead-alist cache-
10e40 66 69 6c 65 29 29 0a 09 09 09 20 20 20 23 66 29 file)).... #f)
10e50 29 0a 20 20 20 20 20 20 20 20 20 28 74 65 73 74 ). (test
10e60 2d 66 75 6c 6c 2d 6e 61 6d 65 20 28 69 66 20 28 -full-name (if (
10e70 61 6e 64 20 69 74 65 6d 2d 70 61 74 68 20 28 6e and item-path (n
10e80 6f 74 20 28 73 74 72 69 6e 67 2d 6e 75 6c 6c 3f ot (string-null?
10e90 20 69 74 65 6d 2d 70 61 74 68 29 29 29 0a 20 20 item-path))).
10ea0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
10eb0 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 63 (conc
10ec0 20 74 65 73 74 2d 6e 61 6d 65 20 22 2f 22 20 69 test-name "/" i
10ed0 74 65 6d 2d 70 61 74 68 29 0a 20 20 20 20 20 20 tem-path).
10ee0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
10ef0 20 20 20 20 20 20 20 74 65 73 74 2d 6e 61 6d 65 test-name
10f00 29 29 29 0a 20 20 20 20 28 69 66 20 63 61 63 68 ))). (if cach
10f10 65 64 2d 64 61 74 0a 09 63 61 63 68 65 64 2d 64 ed-dat..cached-d
10f20 61 74 0a 09 28 6c 65 74 20 28 28 64 61 74 20 28 at..(let ((dat (
10f30 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
10f40 65 66 61 75 6c 74 20 2a 74 65 73 74 63 6f 6e 66 efault *testconf
10f50 69 67 73 2a 20 74 65 73 74 2d 66 75 6c 6c 2d 6e igs* test-full-n
10f60 61 6d 65 20 23 66 29 29 29 0a 09 20 20 28 69 66 ame #f))).. (if
10f70 20 28 61 6e 64 20 20 64 61 74 20 3b 3b 20 68 61 (and dat ;; ha
10f80 76 65 20 61 20 6c 6f 63 61 6c 6c 79 20 63 61 63 ve a locally cac
10f90 68 65 64 20 76 65 72 73 69 6f 6e 0a 09 09 20 20 hed version...
10fa0 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 (hash-table-re
10fb0 66 2f 64 65 66 61 75 6c 74 20 64 61 74 20 22 68 f/default dat "h
10fc0 61 76 65 20 66 75 6c 6c 64 61 74 61 22 20 23 66 ave fulldata" #f
10fd0 29 29 20 3b 3b 20 6d 61 72 6b 65 64 20 61 73 20 )) ;; marked as
10fe0 67 6f 6f 64 20 64 61 74 61 3f 0a 09 20 20 20 20 good data?..
10ff0 20 20 64 61 74 0a 09 20 20 20 20 20 20 3b 3b 20 dat.. ;;
11000 6e 6f 20 63 61 63 68 65 64 20 64 61 74 61 20 61 no cached data a
11010 76 61 69 6c 61 62 6c 65 0a 09 20 20 20 20 20 20 vailable..
11020 28 6c 65 74 2a 20 28 28 74 72 65 67 20 20 20 20 (let* ((treg
11030 20 20 20 20 20 28 6f 72 20 74 65 73 74 2d 72 65 (or test-re
11040 67 69 73 74 72 79 0a 09 09 09 09 20 20 20 20 20 gistry.....
11050 20 20 28 74 65 73 74 73 3a 67 65 74 2d 61 6c 6c (tests:get-all
11060 29 29 29 0a 09 09 20 20 20 20 20 28 74 65 73 74 )))... (test
11070 2d 70 61 74 68 20 20 20 20 28 6f 72 20 28 68 61 -path (or (ha
11080 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
11090 61 75 6c 74 20 74 72 65 67 20 74 65 73 74 2d 6e ault treg test-n
110a0 61 6d 65 20 23 66 29 0a 20 20 20 20 20 20 20 20 ame #f).
110b0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
110c0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
110d0 6c 65 74 2a 20 28 28 6c 6f 63 61 6c 2d 74 63 64 let* ((local-tcd
110e0 69 72 20 28 63 6f 6e 63 20 28 67 65 74 65 6e 76 ir (conc (getenv
110f0 20 22 4d 54 5f 4c 49 4e 4b 54 52 45 45 22 29 20 "MT_LINKTREE")
11100 22 2f 22 0a 20 20 20 20 20 20 20 20 20 20 20 20 "/".
11110 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11120 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11130 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11140 20 20 20 20 20 28 67 65 74 65 6e 76 20 22 4d 54 (getenv "MT
11150 5f 54 41 52 47 45 54 22 29 20 22 2f 22 0a 20 20 _TARGET") "/".
11160 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11170 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11180 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11190 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
111a0 67 65 74 65 6e 76 20 22 4d 54 5f 52 55 4e 4e 41 getenv "MT_RUNNA
111b0 4d 45 22 29 20 22 2f 22 0a 20 20 20 20 20 20 20 ME") "/".
111c0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
111d0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
111e0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
111f0 20 20 20 20 20 20 20 20 20 20 74 65 73 74 2d 6e test-n
11200 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 ame "/" item-pat
11210 68 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 h)).
11220 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11230 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11240 20 20 28 6c 6f 63 61 6c 2d 74 63 66 67 20 28 63 (local-tcfg (c
11250 6f 6e 63 20 6c 6f 63 61 6c 2d 74 63 64 69 72 20 onc local-tcdir
11260 22 2f 74 65 73 74 63 6f 6e 66 69 67 22 29 29 29 "/testconfig")))
11270 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
11280 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11290 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 63 (if (c
112a0 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 ommon:file-exist
112b0 73 3f 20 6c 6f 63 61 6c 2d 74 63 66 67 29 0a 20 s? local-tcfg).
112c0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
112d0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
112e0 20 20 20 20 20 20 20 20 20 20 20 20 6c 6f 63 61 loca
112f0 6c 2d 74 63 64 69 72 0a 20 20 20 20 20 20 20 20 l-tcdir.
11300 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11310 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11320 20 20 20 20 20 23 66 29 29 0a 09 09 09 09 20 20 #f)).....
11330 20 20 20 20 20 28 63 6f 6e 63 20 2a 74 6f 70 70 (conc *topp
11340 61 74 68 2a 20 22 2f 74 65 73 74 73 2f 22 20 74 ath* "/tests/" t
11350 65 73 74 2d 6e 61 6d 65 29 29 29 0a 09 09 20 20 est-name)))...
11360 20 20 20 28 74 65 73 74 2d 63 6f 6e 66 69 67 66 (test-configf
11370 20 28 63 6f 6e 63 20 74 65 73 74 2d 70 61 74 68 (conc test-path
11380 20 22 2f 74 65 73 74 63 6f 6e 66 69 67 22 29 29 "/testconfig"))
11390 0a 09 09 20 20 20 20 20 28 74 65 73 74 65 78 69 ... (testexi
113a0 73 74 73 20 20 20 28 6c 65 74 20 6c 6f 6f 70 61 sts (let loopa
113b0 20 28 28 74 72 69 65 73 2d 6c 65 66 74 20 33 30 ((tries-left 30
113c0 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
113d0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
113e0 20 20 20 20 20 20 20 20 28 63 6f 6e 64 0a 20 20 (cond.
113f0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11400 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11410 20 20 20 20 28 0a 20 20 20 20 20 20 20 20 20 20 (.
11420 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11430 20 20 20 20 20 20 20 20 20 20 20 20 20 28 61 6e (an
11440 64 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 d (common:file-e
11450 78 69 73 74 73 3f 20 74 65 73 74 2d 63 6f 6e 66 xists? test-conf
11460 69 67 66 29 28 66 69 6c 65 2d 72 65 61 64 2d 61 igf)(file-read-a
11470 63 63 65 73 73 3f 20 74 65 73 74 2d 63 6f 6e 66 ccess? test-conf
11480 69 67 66 29 29 0a 20 20 20 20 20 20 20 20 20 20 igf)).
11490 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
114a0 20 20 20 20 20 20 20 20 20 20 20 20 20 23 74 29 #t)
114b0 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
114c0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
114d0 20 20 20 20 20 20 20 28 0a 20 20 20 20 20 20 20 (.
114e0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
114f0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11500 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 (common:file-exi
11510 73 74 73 3f 20 74 65 73 74 2d 63 6f 6e 66 69 67 sts? test-config
11520 66 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 f).
11530 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11540 20 20 20 20 20 20 20 20 20 20 28 64 65 62 75 67 (debug
11550 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
11560 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 t-log-port* "WAR
11570 4e 49 4e 47 3a 20 43 61 6e 6e 6f 74 20 72 65 61 NING: Cannot rea
11580 64 20 74 65 73 74 63 6f 6e 66 69 67 20 66 69 6c d testconfig fil
11590 65 3a 20 22 74 65 73 74 2d 63 6f 6e 66 69 67 66 e: "test-configf
115a0 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
115b0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
115c0 20 20 20 20 20 20 20 20 20 23 66 29 0a 20 20 20 #f).
115d0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
115e0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
115f0 20 20 20 28 0a 20 20 20 20 20 20 20 20 20 20 20 (.
11600 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11610 20 20 20 20 20 20 20 20 20 20 20 20 28 61 6e 64 (and
11620 20 77 61 69 74 2d 61 2d 6d 69 6e 75 74 65 20 28 wait-a-minute (
11630 3e 20 74 72 69 65 73 2d 6c 65 66 74 20 30 29 29 > tries-left 0))
11640 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
11650 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11660 20 20 20 20 20 20 20 20 28 74 68 72 65 61 64 2d (thread-
11670 73 6c 65 65 70 21 20 31 30 29 0a 20 20 20 20 20 sleep! 10).
11680 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11690 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
116a0 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
116b0 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
116c0 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 74 65 rt* "WARNING: te
116d0 73 74 63 6f 6e 66 69 67 20 66 69 6c 65 20 64 6f stconfig file do
116e0 65 73 20 6e 6f 74 20 65 78 69 73 74 3a 20 22 74 es not exist: "t
116f0 65 73 74 2d 63 6f 6e 66 69 67 66 22 20 77 69 6c est-configf" wil
11700 6c 20 72 65 74 72 79 20 69 6e 20 31 30 20 73 65 l retry in 10 se
11710 63 6f 6e 64 73 2e 20 20 54 72 69 65 73 20 6c 65 conds. Tries le
11720 66 74 3a 20 22 74 72 69 65 73 2d 6c 65 66 74 29 ft: "tries-left)
11730 20 3b 3b 20 42 42 3a 20 74 68 69 73 20 66 69 72 ;; BB: this fir
11740 65 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 es.
11750 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11760 20 20 20 20 20 20 20 20 20 20 28 6c 6f 6f 70 61 (loopa
11770 20 28 73 75 62 31 20 74 72 69 65 73 2d 6c 65 66 (sub1 tries-lef
11780 74 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 t))).
11790 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
117a0 20 20 20 20 20 20 20 20 20 20 20 28 65 6c 73 65 (else
117b0 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
117c0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
117d0 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 (debug:p
117e0 72 69 6e 74 20 32 20 2a 64 65 66 61 75 6c 74 2d rint 2 *default-
117f0 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 log-port* "WARNI
11800 4e 47 3a 20 74 65 73 74 63 6f 6e 66 69 67 20 66 NG: testconfig f
11810 69 6c 65 20 64 6f 65 73 20 6e 6f 74 20 65 78 69 ile does not exi
11820 73 74 3a 20 22 74 65 73 74 2d 63 6f 6e 66 69 67 st: "test-config
11830 66 29 20 3b 3b 20 42 42 3a 20 74 68 69 73 20 66 f) ;; BB: this f
11840 69 72 65 73 0a 20 20 20 20 20 20 20 20 20 20 20 ires.
11850 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11860 20 20 20 20 20 20 20 20 20 20 20 20 23 66 29 29 #f))
11870 29 29 0a 09 09 20 20 20 20 20 28 74 63 66 67 20 ))... (tcfg
11880 20 20 20 20 20 20 20 20 28 69 66 20 74 65 73 74 (if test
11890 65 78 69 73 74 73 0a 09 09 09 09 20 20 20 20 20 exists.....
118a0 20 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 74 (read-config t
118b0 65 73 74 2d 63 6f 6e 66 69 67 66 20 23 66 20 73 est-configf #f s
118c0 79 73 74 65 6d 2d 61 6c 6c 6f 77 65 64 0a 09 09 ystem-allowed...
118d0 09 09 09 09 20 20 20 20 65 6e 76 69 72 6f 6e 2d .... environ-
118e0 70 61 74 74 3a 20 28 69 66 20 73 79 73 74 65 6d patt: (if system
118f0 2d 61 6c 6c 6f 77 65 64 0a 09 09 09 09 09 09 09 -allowed........
11900 09 20 20 20 20 20 20 22 70 72 65 2d 6c 61 75 6e . "pre-laun
11910 63 68 2d 65 6e 76 2d 76 61 72 73 22 0a 09 09 09 ch-env-vars"....
11920 09 09 09 09 09 20 20 20 20 20 20 23 66 29 29 0a ..... #f)).
11930 09 09 09 09 20 20 20 20 20 20 20 23 66 29 29 29 .... #f)))
11940 0a 09 09 28 69 66 20 28 61 6e 64 20 74 63 66 67 ...(if (and tcfg
11950 20 63 61 63 68 65 2d 66 69 6c 65 29 20 28 68 61 cache-file) (ha
11960 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 63 sh-table-set! tc
11970 66 67 20 22 68 61 76 65 20 66 75 6c 6c 64 61 74 fg "have fulldat
11980 61 22 20 23 74 29 29 20 3b 3b 20 6d 61 72 6b 20 a" #t)) ;; mark
11990 74 68 69 73 20 61 73 20 66 75 6c 6c 79 20 72 65 this as fully re
119a0 61 64 20 64 61 74 61 0a 09 09 28 69 66 20 74 63 ad data...(if tc
119b0 66 67 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 fg (hash-table-s
119c0 65 74 21 20 2a 74 65 73 74 63 6f 6e 66 69 67 73 et! *testconfigs
119d0 2a 20 74 65 73 74 2d 66 75 6c 6c 2d 6e 61 6d 65 * test-full-name
119e0 20 74 63 66 67 29 29 0a 09 09 28 69 66 20 28 61 tcfg))...(if (a
119f0 6e 64 20 74 65 73 74 65 78 69 73 74 73 0a 09 09 nd testexists...
11a00 09 20 63 61 63 68 65 2d 66 69 6c 65 0a 09 09 09 . cache-file....
11a10 20 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 (file-write-acc
11a20 65 73 73 3f 20 63 61 63 68 65 2d 70 61 74 68 29 ess? cache-path)
11a30 0a 09 09 09 20 61 6c 6c 6f 77 2d 77 72 69 74 65 .... allow-write
11a40 2d 63 61 63 68 65 29 0a 09 09 20 20 20 20 28 6c -cache)... (l
11a50 65 74 20 28 28 74 70 61 74 68 20 28 63 6f 6e 63 et ((tpath (conc
11a60 20 63 61 63 68 65 2d 70 61 74 68 20 22 2f 2e 74 cache-path "/.t
11a70 65 73 74 63 6f 6e 66 69 67 22 29 29 29 0a 09 09 estconfig")))...
11a80 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
11a90 6e 74 2d 69 6e 66 6f 20 31 20 2a 64 65 66 61 75 nt-info 1 *defau
11aa0 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 43 61 lt-log-port* "Ca
11ab0 63 68 69 6e 67 20 74 65 73 74 63 6f 6e 66 69 67 ching testconfig
11ac0 20 66 6f 72 20 22 20 74 65 73 74 2d 6e 61 6d 65 for " test-name
11ad0 20 22 20 69 6e 20 22 20 74 70 61 74 68 29 0a 20 " in " tpath).
11ae0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11af0 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 74 63 (if (and tc
11b00 66 67 20 28 6e 6f 74 20 28 63 6f 6d 6d 6f 6e 3a fg (not (common:
11b10 69 6e 2d 72 75 6e 6e 69 6e 67 2d 74 65 73 74 3f in-running-test?
11b20 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
11b30 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c
11b40 6f 6e 66 69 67 66 3a 77 72 69 74 65 2d 61 6c 69 onfigf:write-ali
11b50 73 74 20 74 63 66 67 20 74 70 61 74 68 29 29 29 st tcfg tpath)))
11b60 29 0a 09 09 74 63 66 67 29 29 29 29 29 29 0a 20 )...tcfg)))))).
11b70 20 0a 3b 3b 20 73 6f 72 74 20 74 65 73 74 73 20 .;; sort tests
11b80 62 79 20 70 72 69 6f 72 69 74 79 20 61 6e 64 20 by priority and
11b90 77 61 69 74 6f 6e 0a 3b 3b 20 4d 6f 76 65 20 74 waiton.;; Move t
11ba0 65 73 74 20 73 70 65 63 69 66 69 63 20 73 74 75 est specific stu
11bb0 66 66 20 74 6f 20 61 20 74 65 73 74 20 75 6e 69 ff to a test uni
11bc0 74 20 46 49 58 4d 45 20 6f 6e 65 20 6f 66 20 74 t FIXME one of t
11bd0 68 65 73 65 20 64 61 79 73 0a 28 64 65 66 69 6e hese days.(defin
11be0 65 20 28 74 65 73 74 73 3a 73 6f 72 74 2d 62 79 e (tests:sort-by
11bf0 2d 70 72 69 6f 72 69 74 79 2d 61 6e 64 2d 77 61 -priority-and-wa
11c00 69 74 6f 6e 20 74 65 73 74 2d 72 65 63 6f 72 64 iton test-record
11c10 73 29 0a 20 20 28 69 66 20 28 65 71 3f 20 28 68 s). (if (eq? (h
11c20 61 73 68 2d 74 61 62 6c 65 2d 73 69 7a 65 20 74 ash-table-size t
11c30 65 73 74 2d 72 65 63 6f 72 64 73 29 20 30 29 0a est-records) 0).
11c40 20 20 20 20 20 20 27 28 29 0a 20 20 20 20 20 20 '().
11c50 28 6c 65 74 2a 20 28 28 6d 75 6e 67 65 70 72 69 (let* ((mungepri
11c60 6f 72 69 74 79 20 28 6c 61 6d 62 64 61 20 28 70 ority (lambda (p
11c70 72 69 6f 72 69 74 79 29 0a 09 09 09 20 20 20 20 riority)....
11c80 20 20 28 69 66 20 70 72 69 6f 72 69 74 79 0a 09 (if priority..
11c90 09 09 09 20 20 28 6c 65 74 20 28 28 74 6d 70 20 ... (let ((tmp
11ca0 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 20 70 72 69 (any->number pri
11cb0 6f 72 69 74 79 29 29 29 0a 09 09 09 09 20 20 20 ority))).....
11cc0 20 28 69 66 20 74 6d 70 20 74 6d 70 20 28 62 65 (if tmp tmp (be
11cd0 67 69 6e 20 28 64 65 62 75 67 3a 70 72 69 6e 74 gin (debug:print
11ce0 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c -error 0 *defaul
11cf0 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 62 61 64 t-log-port* "bad
11d00 20 70 72 69 6f 72 69 74 79 20 76 61 6c 75 65 20 priority value
11d10 22 20 70 72 69 6f 72 69 74 79 20 22 2c 20 75 73 " priority ", us
11d20 69 6e 67 20 30 22 29 20 30 29 29 29 0a 09 09 09 ing 0") 0)))....
11d30 09 20 20 30 29 29 29 0a 09 20 20 20 20 20 28 61 . 0))).. (a
11d40 6c 6c 2d 74 65 73 74 73 20 20 20 20 20 20 28 68 ll-tests (h
11d50 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 74 ash-table-keys t
11d60 65 73 74 2d 72 65 63 6f 72 64 73 29 29 0a 09 20 est-records))..
11d70 20 20 20 20 28 61 6c 6c 2d 77 61 69 74 65 64 2d (all-waited-
11d80 6f 6e 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 on (let loop ((
11d90 68 65 64 20 28 63 61 72 20 61 6c 6c 2d 74 65 73 hed (car all-tes
11da0 74 73 29 29 0a 09 09 09 09 09 28 74 61 6c 20 28 ts))......(tal (
11db0 63 64 72 20 61 6c 6c 2d 74 65 73 74 73 29 29 0a cdr all-tests)).
11dc0 09 09 09 09 09 28 72 65 73 20 27 28 29 29 29 0a .....(res '())).
11dd0 09 09 09 20 20 20 20 20 20 20 28 6c 65 74 2a 20 ... (let*
11de0 28 28 74 72 65 63 20 20 20 20 28 68 61 73 68 2d ((trec (hash-
11df0 74 61 62 6c 65 2d 72 65 66 20 74 65 73 74 2d 72 table-ref test-r
11e00 65 63 6f 72 64 73 20 68 65 64 29 29 0a 09 09 09 ecords hed))....
11e10 09 20 20 20 20 20 20 28 77 61 69 74 6f 6e 73 20 . (waitons
11e20 28 6f 72 20 28 74 65 73 74 73 3a 74 65 73 74 71 (or (tests:testq
11e30 75 65 75 65 2d 67 65 74 2d 77 61 69 74 6f 6e 73 ueue-get-waitons
11e40 20 74 72 65 63 29 20 27 28 29 29 29 29 0a 09 09 trec) '())))...
11e50 09 09 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 .. (if (null? ta
11e60 6c 29 0a 09 09 09 09 20 20 20 20 20 28 61 70 70 l)..... (app
11e70 65 6e 64 20 72 65 73 20 77 61 69 74 6f 6e 73 29 end res waitons)
11e80 0a 09 09 09 09 20 20 20 20 20 28 6c 6f 6f 70 20 ..... (loop
11e90 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 (car tal)(cdr ta
11ea0 6c 29 28 61 70 70 65 6e 64 20 72 65 73 20 77 61 l)(append res wa
11eb0 69 74 6f 6e 73 29 29 29 29 29 29 0a 09 20 20 20 itons))))))..
11ec0 20 20 28 73 6f 72 74 2d 66 6e 31 20 0a 09 20 20 (sort-fn1 ..
11ed0 20 20 20 20 28 6c 61 6d 62 64 61 20 28 61 20 62 (lambda (a b
11ee0 29 0a 09 09 28 6c 65 74 2a 20 28 28 61 2d 72 65 )...(let* ((a-re
11ef0 63 6f 72 64 20 20 20 28 68 61 73 68 2d 74 61 62 cord (hash-tab
11f00 6c 65 2d 72 65 66 20 74 65 73 74 2d 72 65 63 6f le-ref test-reco
11f10 72 64 73 20 61 29 29 0a 09 09 20 20 20 20 20 20 rds a))...
11f20 20 28 62 2d 72 65 63 6f 72 64 20 20 20 28 68 61 (b-record (ha
11f30 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 74 65 73 sh-table-ref tes
11f40 74 2d 72 65 63 6f 72 64 73 20 62 29 29 0a 09 09 t-records b))...
11f50 20 20 20 20 20 20 20 28 61 2d 77 61 69 74 6f 6e (a-waiton
11f60 73 20 20 28 6f 72 20 28 74 65 73 74 73 3a 74 65 s (or (tests:te
11f70 73 74 71 75 65 75 65 2d 67 65 74 2d 77 61 69 74 stqueue-get-wait
11f80 6f 6e 73 20 61 2d 72 65 63 6f 72 64 29 20 27 28 ons a-record) '(
11f90 29 29 29 0a 09 09 20 20 20 20 20 20 20 28 62 2d )))... (b-
11fa0 77 61 69 74 6f 6e 73 20 20 28 6f 72 20 28 74 65 waitons (or (te
11fb0 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 sts:testqueue-ge
11fc0 74 2d 77 61 69 74 6f 6e 73 20 62 2d 72 65 63 6f t-waitons b-reco
11fd0 72 64 29 20 27 28 29 29 29 0a 09 09 20 20 20 20 rd) '()))...
11fe0 20 20 20 28 61 2d 63 6f 6e 66 69 67 20 20 20 28 (a-config (
11ff0 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d tests:testqueue-
12000 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 20 get-testconfig
12010 61 2d 72 65 63 6f 72 64 29 29 0a 09 09 20 20 20 a-record))...
12020 20 20 20 20 28 62 2d 63 6f 6e 66 69 67 20 20 20 (b-config
12030 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 (tests:testqueue
12040 2d 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 -get-testconfig
12050 20 62 2d 72 65 63 6f 72 64 29 29 0a 09 09 20 20 b-record))...
12060 20 20 20 20 20 28 61 2d 72 61 77 2d 70 72 69 20 (a-raw-pri
12070 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 (configf:lookup
12080 20 61 2d 63 6f 6e 66 69 67 20 22 72 65 71 75 69 a-config "requi
12090 72 65 6d 65 6e 74 73 22 20 22 70 72 69 6f 72 69 rements" "priori
120a0 74 79 22 29 29 0a 09 09 20 20 20 20 20 20 20 28 ty"))... (
120b0 62 2d 72 61 77 2d 70 72 69 20 20 28 63 6f 6e 66 b-raw-pri (conf
120c0 69 67 66 3a 6c 6f 6f 6b 75 70 20 62 2d 63 6f 6e igf:lookup b-con
120d0 66 69 67 20 22 72 65 71 75 69 72 65 6d 65 6e 74 fig "requirement
120e0 73 22 20 22 70 72 69 6f 72 69 74 79 22 29 29 0a s" "priority")).
120f0 09 09 20 20 20 20 20 20 20 28 61 2d 70 72 69 6f .. (a-prio
12100 72 69 74 79 20 28 6d 75 6e 67 65 70 72 69 6f 72 rity (mungeprior
12110 69 74 79 20 61 2d 72 61 77 2d 70 72 69 29 29 0a ity a-raw-pri)).
12120 09 09 20 20 20 20 20 20 20 28 62 2d 70 72 69 6f .. (b-prio
12130 72 69 74 79 20 28 6d 75 6e 67 65 70 72 69 6f 72 rity (mungeprior
12140 69 74 79 20 62 2d 72 61 77 2d 70 72 69 29 29 29 ity b-raw-pri)))
12150 0a 09 09 20 20 28 74 65 73 74 73 3a 74 65 73 74 ... (tests:test
12160 71 75 65 75 65 2d 73 65 74 2d 70 72 69 6f 72 69 queue-set-priori
12170 74 79 21 20 61 2d 72 65 63 6f 72 64 20 61 2d 70 ty! a-record a-p
12180 72 69 6f 72 69 74 79 29 0a 09 09 20 20 28 74 65 riority)... (te
12190 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 73 65 sts:testqueue-se
121a0 74 2d 70 72 69 6f 72 69 74 79 21 20 62 2d 72 65 t-priority! b-re
121b0 63 6f 72 64 20 62 2d 70 72 69 6f 72 69 74 79 29 cord b-priority)
121c0 0a 09 09 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 ... ;; (debug:p
121d0 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
121e0 6c 6f 67 2d 70 6f 72 74 2a 20 22 61 3d 22 20 61 log-port* "a=" a
121f0 20 22 2c 20 62 3d 22 20 62 20 22 2c 20 61 2d 77 ", b=" b ", a-w
12200 61 69 74 6f 6e 73 3d 22 20 61 2d 77 61 69 74 6f aitons=" a-waito
12210 6e 73 20 22 2c 20 62 2d 77 61 69 74 6f 6e 73 3d ns ", b-waitons=
12220 22 20 62 2d 77 61 69 74 6f 6e 73 29 0a 09 09 20 " b-waitons)...
12230 20 28 63 6f 6e 64 0a 09 09 20 20 20 3b 3b 20 69 (cond... ;; i
12240 73 20 0a 09 09 20 20 20 28 28 6d 65 6d 62 65 72 s ... ((member
12250 20 61 20 62 2d 77 61 69 74 6f 6e 73 29 20 20 20 a b-waitons)
12260 20 20 20 20 20 20 20 3b 3b 20 69 73 20 62 20 77 ;; is b w
12270 61 69 74 69 6e 67 20 6f 6e 20 61 3f 0a 09 09 20 aiting on a?...
12280 20 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 ;; (debug:pri
12290 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
122a0 67 2d 70 6f 72 74 2a 20 22 63 61 73 65 31 22 29 g-port* "case1")
122b0 0a 09 09 20 20 20 20 23 74 29 0a 09 09 20 20 20 ... #t)...
122c0 28 28 6d 65 6d 62 65 72 20 62 20 61 2d 77 61 69 ((member b a-wai
122d0 74 6f 6e 73 29 20 20 20 20 20 20 20 20 20 20 3b tons) ;
122e0 3b 20 69 73 20 61 20 77 61 69 74 69 6e 67 20 6f ; is a waiting o
122f0 6e 20 62 3f 0a 09 09 20 20 20 20 3b 3b 20 28 64 n b?... ;; (d
12300 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
12310 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
12320 22 63 61 73 65 32 22 29 0a 09 09 20 20 20 20 23 "case2")... #
12330 66 29 0a 09 09 20 20 20 28 28 61 6e 64 20 28 6e f)... ((and (n
12340 6f 74 20 28 6e 75 6c 6c 3f 20 61 2d 77 61 69 74 ot (null? a-wait
12350 6f 6e 73 29 29 20 20 3b 3b 20 62 6f 74 68 20 68 ons)) ;; both h
12360 61 76 65 20 77 61 69 74 6f 6e 73 20 2d 20 64 6f ave waitons - do
12370 20 6e 6f 74 20 64 69 73 74 75 72 62 0a 09 09 09 not disturb....
12380 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 62 2d 77 (not (null? b-w
12390 61 69 74 6f 6e 73 29 29 29 0a 09 09 20 20 20 20 aitons)))...
123a0 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 ;; (debug:print
123b0 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
123c0 6f 72 74 2a 20 22 63 61 73 65 32 2e 31 22 29 0a ort* "case2.1").
123d0 09 09 20 20 20 20 23 74 29 0a 09 09 20 20 20 28 .. #t)... (
123e0 28 61 6e 64 20 28 6e 75 6c 6c 3f 20 61 2d 77 61 (and (null? a-wa
123f0 69 74 6f 6e 73 29 20 20 20 20 20 20 20 20 3b 3b itons) ;;
12400 20 6e 6f 20 77 61 69 74 6f 6e 73 20 66 6f 72 20 no waitons for
12410 61 20 62 75 74 20 62 20 68 61 73 20 77 61 69 74 a but b has wait
12420 6f 6e 73 0a 09 09 09 20 28 6e 6f 74 20 28 6e 75 ons.... (not (nu
12430 6c 6c 3f 20 62 2d 77 61 69 74 6f 6e 73 29 29 29 ll? b-waitons)))
12440 0a 09 09 20 20 20 20 3b 3b 20 28 64 65 62 75 67 ... ;; (debug
12450 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
12460 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 63 61 73 t-log-port* "cas
12470 65 33 22 29 0a 09 09 20 20 20 20 23 66 29 0a 09 e3")... #f)..
12480 09 20 20 20 28 28 61 6e 64 20 28 6e 6f 74 20 28 . ((and (not (
12490 6e 75 6c 6c 3f 20 61 2d 77 61 69 74 6f 6e 73 29 null? a-waitons)
124a0 29 20 20 3b 3b 20 61 20 68 61 73 20 77 61 69 74 ) ;; a has wait
124b0 6f 6e 73 20 62 75 74 20 62 20 64 6f 65 73 20 6e ons but b does n
124c0 6f 74 0a 09 09 09 20 28 6e 75 6c 6c 3f 20 62 2d ot.... (null? b-
124d0 77 61 69 74 6f 6e 73 29 29 20 0a 09 09 20 20 20 waitons)) ...
124e0 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ;; (debug:print
124f0 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
12500 70 6f 72 74 2a 20 22 63 61 73 65 34 22 29 0a 09 port* "case4")..
12510 09 20 20 20 20 23 74 29 0a 09 09 20 20 20 28 28 . #t)... ((
12520 6e 6f 74 20 28 65 71 3f 20 61 2d 70 72 69 6f 72 not (eq? a-prior
12530 69 74 79 20 62 2d 70 72 69 6f 72 69 74 79 29 29 ity b-priority))
12540 20 3b 3b 20 75 73 65 0a 09 09 20 20 20 20 28 3e ;; use... (>
12550 20 61 2d 70 72 69 6f 72 69 74 79 20 62 2d 70 72 a-priority b-pr
12560 69 6f 72 69 74 79 29 29 0a 09 09 20 20 20 28 65 iority))... (e
12570 6c 73 65 0a 09 09 20 20 20 20 3b 3b 20 28 64 65 lse... ;; (de
12580 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
12590 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
125a0 63 61 73 65 35 22 29 0a 09 09 20 20 20 20 28 73 case5")... (s
125b0 74 72 69 6e 67 3e 3f 20 61 20 62 29 29 29 29 29 tring>? a b)))))
125c0 29 0a 09 20 20 20 20 20 0a 09 20 20 20 20 20 28 ).. .. (
125d0 73 6f 72 74 2d 66 6e 32 0a 09 20 20 20 20 20 20 sort-fn2..
125e0 28 6c 61 6d 62 64 61 20 28 61 20 62 29 0a 09 09 (lambda (a b)...
125f0 28 3e 20 28 6d 75 6e 67 65 70 72 69 6f 72 69 74 (> (mungepriorit
12600 79 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 y (tests:testque
12610 75 65 2d 67 65 74 2d 70 72 69 6f 72 69 74 79 20 ue-get-priority
12620 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 (hash-table-ref
12630 74 65 73 74 2d 72 65 63 6f 72 64 73 20 61 29 29 test-records a))
12640 29 0a 09 09 20 20 20 28 6d 75 6e 67 65 70 72 69 )... (mungepri
12650 6f 72 69 74 79 20 28 74 65 73 74 73 3a 74 65 73 ority (tests:tes
12660 74 71 75 65 75 65 2d 67 65 74 2d 70 72 69 6f 72 tqueue-get-prior
12670 69 74 79 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ity (hash-table-
12680 72 65 66 20 74 65 73 74 2d 72 65 63 6f 72 64 73 ref test-records
12690 20 62 29 29 29 29 29 29 29 0a 09 3b 3b 20 28 6c b)))))))..;; (l
126a0 65 74 20 28 28 64 6f 74 2d 72 65 73 20 28 74 65 et ((dot-res (te
126b0 73 74 73 3a 72 75 6e 2d 64 6f 74 20 28 74 65 73 sts:run-dot (tes
126c0 74 73 3a 74 65 73 74 73 2d 3e 64 6f 74 20 74 65 ts:tests->dot te
126d0 73 74 2d 72 65 63 6f 72 64 73 29 20 22 70 6c 61 st-records) "pla
126e0 69 6e 22 29 29 29 0a 09 3b 3b 20 20 20 28 64 65 in")))..;; (de
126f0 62 75 67 3a 70 72 69 6e 74 20 22 64 6f 74 2d 72 bug:print "dot-r
12700 65 73 3d 22 20 64 6f 74 2d 72 65 73 29 29 0a 09 es=" dot-res))..
12710 3b 3b 20 28 6c 65 74 20 28 28 64 61 74 61 20 28 ;; (let ((data (
12720 6d 61 70 20 63 64 72 20 28 66 69 6c 74 65 72 0a map cdr (filter.
12730 09 3b 3b 20 20 20 20 20 09 09 20 20 28 6c 61 6d .;; .. (lam
12740 62 64 61 20 28 78 29 28 65 71 75 61 6c 3f 20 22 bda (x)(equal? "
12750 6e 6f 64 65 22 20 28 63 61 72 20 78 29 29 29 0a node" (car x))).
12760 09 3b 3b 20 20 20 20 20 09 09 20 20 28 6d 61 70 .;; .. (map
12770 20 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 28 74 string-split (t
12780 65 73 74 73 3a 65 61 73 79 2d 64 6f 74 20 74 65 ests:easy-dot te
12790 73 74 2d 72 65 63 6f 72 64 73 20 22 70 6c 61 69 st-records "plai
127a0 6e 22 29 29 29 29 29 29 0a 09 3b 3b 20 20 20 28 n"))))))..;; (
127b0 6d 61 70 20 63 61 72 20 28 73 6f 72 74 20 64 61 map car (sort da
127c0 74 61 20 28 6c 61 6d 62 64 61 20 28 61 20 62 29 ta (lambda (a b)
127d0 0a 09 3b 3b 20 20 20 20 20 09 09 20 20 20 20 28 ..;; .. (
127e0 3e 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 > (string->numbe
127f0 72 20 28 63 61 64 64 72 20 61 29 29 28 73 74 72 r (caddr a))(str
12800 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 63 61 64 ing->number (cad
12810 64 72 20 62 29 29 29 29 29 29 29 0a 09 3b 3b 20 dr b)))))))..;;
12820 29 29 0a 09 28 73 6f 72 74 20 61 6c 6c 2d 74 65 ))..(sort all-te
12830 73 74 73 20 73 6f 72 74 2d 66 6e 31 29 29 29 29 sts sort-fn1))))
12840 20 3b 3b 20 61 76 6f 69 64 20 64 65 61 6c 69 6e ;; avoid dealin
12850 67 20 77 69 74 68 20 64 65 6c 65 74 65 64 20 74 g with deleted t
12860 65 73 74 73 2c 20 6c 6f 6f 6b 20 61 74 20 74 68 ests, look at th
12870 65 20 68 61 73 68 20 74 61 62 6c 65 0a 0a 28 64 e hash table..(d
12880 65 66 69 6e 65 20 28 74 65 73 74 73 3a 65 61 73 efine (tests:eas
12890 79 2d 64 6f 74 20 74 65 73 74 2d 72 65 63 6f 72 y-dot test-recor
128a0 64 73 20 6f 75 74 74 79 70 65 29 0a 20 20 28 6c ds outtype). (l
128b0 65 74 2d 76 61 6c 75 65 73 20 28 28 28 66 64 20 et-values (((fd
128c0 74 65 6d 70 2d 70 61 74 68 29 20 28 66 69 6c 65 temp-path) (file
128d0 2d 6d 6b 73 74 65 6d 70 20 28 63 6f 6e 63 20 22 -mkstemp (conc "
128e0 2f 74 6d 70 2f 22 20 28 63 75 72 72 65 6e 74 2d /tmp/" (current-
128f0 75 73 65 72 2d 6e 61 6d 65 29 20 22 2e 58 58 58 user-name) ".XXX
12900 58 58 58 22 29 29 29 29 0a 20 20 20 20 28 6c 65 XXX")))). (le
12910 74 20 28 28 61 6c 6c 2d 74 65 73 74 6e 61 6d 65 t ((all-testname
12920 73 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 s (hash-table-ke
12930 79 73 20 74 65 73 74 2d 72 65 63 6f 72 64 73 29 ys test-records)
12940 29 0a 09 20 20 28 74 65 6d 70 2d 70 6f 72 74 20 ).. (temp-port
12950 20 20 20 20 28 6f 70 65 6e 2d 6f 75 74 70 75 74 (open-output
12960 2d 66 69 6c 65 2a 20 66 64 29 29 29 0a 20 20 20 -file* fd))).
12970 20 20 20 3b 3b 20 28 66 6f 72 6d 61 74 20 74 65 ;; (format te
12980 6d 70 2d 70 6f 72 74 20 22 54 68 69 73 20 66 69 mp-port "This fi
12990 6c 65 20 69 73 20 7e 41 2e 7e 25 22 20 74 65 6d le is ~A.~%" tem
129a0 70 2d 70 61 74 68 29 0a 20 20 20 20 20 20 28 66 p-path). (f
129b0 6f 72 6d 61 74 20 74 65 6d 70 2d 70 6f 72 74 20 ormat temp-port
129c0 22 64 69 67 72 61 70 68 20 74 65 73 74 73 20 7b "digraph tests {
129d0 5c 6e 22 29 0a 20 20 20 20 20 20 28 66 6f 72 6d \n"). (form
129e0 61 74 20 74 65 6d 70 2d 70 6f 72 74 20 22 20 20 at temp-port "
129f0 73 69 7a 65 3d 34 2c 38 5c 6e 22 29 0a 20 20 20 size=4,8\n").
12a00 20 20 20 3b 3b 20 28 66 6f 72 6d 61 74 20 74 65 ;; (format te
12a10 6d 70 2d 70 6f 72 74 20 22 20 20 20 73 70 6c 69 mp-port " spli
12a20 6e 65 73 3d 6e 6f 6e 65 5c 6e 22 29 0a 20 20 20 nes=none\n").
12a30 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 (for-each.
12a40 20 20 20 20 28 6c 61 6d 62 64 61 20 28 74 65 73 (lambda (tes
12a50 74 6e 61 6d 65 29 0a 09 20 28 6c 65 74 2a 20 28 tname).. (let* (
12a60 28 74 65 73 74 72 65 63 20 28 68 61 73 68 2d 74 (testrec (hash-t
12a70 61 62 6c 65 2d 72 65 66 20 74 65 73 74 2d 72 65 able-ref test-re
12a80 63 6f 72 64 73 20 74 65 73 74 6e 61 6d 65 29 29 cords testname))
12a90 0a 09 09 28 77 61 69 74 6f 6e 73 20 28 6f 72 20 ...(waitons (or
12aa0 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 (tests:testqueue
12ab0 2d 67 65 74 2d 77 61 69 74 6f 6e 73 20 74 65 73 -get-waitons tes
12ac0 74 72 65 63 29 20 27 28 29 29 29 29 0a 09 20 20 trec) '())))..
12ad0 20 28 66 6f 72 2d 65 61 63 68 0a 09 20 20 20 20 (for-each..
12ae0 28 6c 61 6d 62 64 61 20 28 77 61 69 74 6f 6e 29 (lambda (waiton)
12af0 0a 09 20 20 20 20 20 20 28 66 6f 72 6d 61 74 20 .. (format
12b00 74 65 6d 70 2d 70 6f 72 74 20 28 63 6f 6e 63 20 temp-port (conc
12b10 22 20 20 20 22 20 77 61 69 74 6f 6e 20 22 20 2d " " waiton " -
12b20 3e 20 22 20 74 65 73 74 6e 61 6d 65 20 22 20 5b > " testname " [
12b30 73 70 6c 69 6e 65 73 3d 6f 72 74 68 6f 5d 5c 6e splines=ortho]\n
12b40 22 29 29 29 0a 09 20 20 20 20 77 61 69 74 6f 6e "))).. waiton
12b50 73 29 29 29 0a 20 20 20 20 20 20 20 61 6c 6c 2d s))). all-
12b60 74 65 73 74 6e 61 6d 65 73 29 0a 20 20 20 20 20 testnames).
12b70 20 28 66 6f 72 6d 61 74 20 74 65 6d 70 2d 70 6f (format temp-po
12b80 72 74 20 22 7d 5c 6e 22 29 0a 20 20 20 20 20 20 rt "}\n").
12b90 28 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d 70 6f (close-output-po
12ba0 72 74 20 74 65 6d 70 2d 70 6f 72 74 29 0a 20 20 rt temp-port).
12bb0 20 20 20 20 28 77 69 74 68 2d 69 6e 70 75 74 2d (with-input-
12bc0 66 72 6f 6d 2d 70 69 70 65 0a 20 20 20 20 20 20 from-pipe.
12bd0 20 28 63 6f 6e 63 20 22 65 6e 76 20 2d 69 20 50 (conc "env -i P
12be0 41 54 48 3d 24 50 41 54 48 20 64 6f 74 20 2d 54 ATH=$PATH dot -T
12bf0 22 20 6f 75 74 74 79 70 65 20 22 20 3c 20 22 20 " outtype " < "
12c00 74 65 6d 70 2d 70 61 74 68 29 0a 20 20 20 20 20 temp-path).
12c10 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 20 28 (lambda ().. (
12c20 6c 65 74 20 28 28 72 65 73 20 28 72 65 61 64 2d let ((res (read-
12c30 6c 69 6e 65 73 29 29 29 0a 09 20 20 20 3b 3b 20 lines))).. ;;
12c40 28 64 65 6c 65 74 65 2d 66 69 6c 65 20 74 65 6d (delete-file tem
12c50 70 2d 70 61 74 68 29 0a 09 20 20 20 72 65 73 29 p-path).. res)
12c60 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 )))))..(define (
12c70 74 65 73 74 73 3a 77 72 69 74 65 2d 64 6f 74 2d tests:write-dot-
12c80 66 69 6c 65 20 74 65 73 74 2d 72 65 63 6f 72 64 file test-record
12c90 73 20 66 6e 61 6d 65 20 73 69 7a 65 78 20 73 69 s fname sizex si
12ca0 7a 65 79 29 0a 20 20 28 69 66 20 28 66 69 6c 65 zey). (if (file
12cb0 2d 77 72 69 74 65 2d 61 63 63 65 73 73 3f 20 28 -write-access? (
12cc0 70 61 74 68 6e 61 6d 65 2d 64 69 72 65 63 74 6f pathname-directo
12cd0 72 79 20 66 6e 61 6d 65 29 29 0a 20 20 20 20 20 ry fname)).
12ce0 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f (with-output-to
12cf0 2d 66 69 6c 65 20 66 6e 61 6d 65 0a 09 28 6c 61 -file fname..(la
12d00 6d 62 64 61 20 28 29 0a 09 20 20 28 6d 61 70 20 mbda ().. (map
12d10 70 72 69 6e 74 20 28 74 65 73 74 73 3a 74 65 73 print (tests:tes
12d20 74 73 2d 3e 64 6f 74 20 74 65 73 74 2d 72 65 63 ts->dot test-rec
12d30 6f 72 64 73 20 73 69 7a 65 78 20 73 69 7a 65 79 ords sizex sizey
12d40 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ))))))..(define
12d50 28 74 65 73 74 73 3a 74 65 73 74 73 2d 3e 64 6f (tests:tests->do
12d60 74 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 73 t test-records s
12d70 69 7a 65 78 20 73 69 7a 65 79 29 0a 20 20 28 6c izex sizey). (l
12d80 65 74 20 28 28 61 6c 6c 2d 74 65 73 74 6e 61 6d et ((all-testnam
12d90 65 73 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b es (hash-table-k
12da0 65 79 73 20 74 65 73 74 2d 72 65 63 6f 72 64 73 eys test-records
12db0 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 75 6c ))). (if (nul
12dc0 6c 3f 20 61 6c 6c 2d 74 65 73 74 6e 61 6d 65 73 l? all-testnames
12dd0 29 0a 09 27 28 29 0a 09 28 6c 65 74 20 6c 6f 6f )..'()..(let loo
12de0 70 20 28 28 68 65 64 20 28 63 61 72 20 61 6c 6c p ((hed (car all
12df0 2d 74 65 73 74 6e 61 6d 65 73 29 29 0a 09 09 20 -testnames))...
12e00 20 20 28 74 61 6c 20 28 63 64 72 20 61 6c 6c 2d (tal (cdr all-
12e10 74 65 73 74 6e 61 6d 65 73 29 29 0a 09 09 20 20 testnames))...
12e20 20 28 72 65 73 20 28 6c 69 73 74 20 22 64 69 67 (res (list "dig
12e30 72 61 70 68 20 74 65 73 74 73 20 7b 22 0a 09 09 raph tests {"...
12e40 09 20 20 20 20 20 20 28 63 6f 6e 63 20 22 20 73 . (conc " s
12e50 69 7a 65 3d 5c 22 22 20 28 6f 72 20 73 69 7a 65 ize=\"" (or size
12e60 78 20 31 31 29 20 22 2c 22 20 28 6f 72 20 73 69 x 11) "," (or si
12e70 7a 65 79 20 31 31 29 20 22 5c 22 3b 22 29 0a 09 zey 11) "\";")..
12e80 09 09 20 20 20 20 20 20 22 20 72 61 74 69 6f 3d .. " ratio=
12e90 30 2e 39 35 3b 22 0a 09 09 09 20 20 20 20 20 20 0.95;"....
12ea0 29 29 29 0a 09 20 20 28 6c 65 74 2a 20 28 28 74 ))).. (let* ((t
12eb0 65 73 74 72 65 63 20 28 68 61 73 68 2d 74 61 62 estrec (hash-tab
12ec0 6c 65 2d 72 65 66 20 74 65 73 74 2d 72 65 63 6f le-ref test-reco
12ed0 72 64 73 20 68 65 64 29 29 0a 09 09 20 28 77 61 rds hed))... (wa
12ee0 69 74 6f 6e 73 20 28 6f 72 20 28 74 65 73 74 73 itons (or (tests
12ef0 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 77 :testqueue-get-w
12f00 61 69 74 6f 6e 73 20 74 65 73 74 72 65 63 29 20 aitons testrec)
12f10 27 28 29 29 29 0a 09 09 20 28 6e 65 77 72 65 73 '()))... (newres
12f20 20 20 28 61 70 70 65 6e 64 20 72 65 73 0a 09 09 (append res...
12f30 09 09 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 77 .. (if (null? w
12f40 61 69 74 6f 6e 73 29 0a 09 09 09 09 20 20 20 20 aitons).....
12f50 20 20 28 6c 69 73 74 20 28 63 6f 6e 63 20 22 20 (list (conc "
12f60 20 20 5c 22 22 20 68 65 64 20 22 5c 22 20 5b 73 \"" hed "\" [s
12f70 68 61 70 65 3d 62 6f 78 5d 3b 22 29 29 0a 09 09 hape=box];"))...
12f80 09 09 20 20 20 20 20 20 28 6d 61 70 20 28 6c 61 .. (map (la
12f90 6d 62 64 61 20 28 77 61 69 74 6f 6e 29 0a 09 09 mbda (waiton)...
12fa0 09 09 09 20 20 20 20 20 28 63 6f 6e 63 20 22 20 ... (conc "
12fb0 20 20 5c 22 22 20 77 61 69 74 6f 6e 20 22 5c 22 \"" waiton "\"
12fc0 20 2d 3e 20 5c 22 22 20 68 65 64 20 22 5c 22 20 -> \"" hed "\"
12fd0 5b 73 68 61 70 65 3d 62 6f 78 5d 3b 22 29 29 0a [shape=box];")).
12fe0 09 09 09 09 09 20 20 20 77 61 69 74 6f 6e 73 29 ..... waitons)
12ff0 0a 09 09 09 09 20 20 20 20 20 20 29 29 29 29 0a ..... )))).
13000 09 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 . (if (null?
13010 74 61 6c 29 0a 09 09 28 61 70 70 65 6e 64 20 6e tal)...(append n
13020 65 77 72 65 73 20 28 6c 69 73 74 20 22 7d 22 29 ewres (list "}")
13030 29 0a 09 09 28 6c 6f 6f 70 20 28 63 61 72 20 74 )...(loop (car t
13040 61 6c 29 28 63 64 72 20 74 61 6c 29 20 6e 65 77 al)(cdr tal) new
13050 72 65 73 29 0a 09 09 29 29 29 29 29 29 0a 0a 3b res)...))))))..;
13060 3b 20 28 74 65 73 74 73 3a 72 75 6e 2d 64 6f 74 ; (tests:run-dot
13070 20 28 6c 69 73 74 20 22 64 69 67 72 61 70 68 20 (list "digraph
13080 74 65 73 74 73 20 7b 22 20 22 61 20 2d 3e 20 62 tests {" "a -> b
13090 22 20 22 7d 22 29 20 22 70 6c 61 69 6e 22 29 0a " "}") "plain").
130a0 0a 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a .(define (tests:
130b0 72 75 6e 2d 64 6f 74 20 69 6e 64 61 74 20 6f 75 run-dot indat ou
130c0 74 74 79 70 65 29 20 3b 3b 20 6f 75 74 74 79 70 ttype) ;; outtyp
130d0 65 20 69 73 20 70 6c 61 69 6e 2c 20 66 69 67 2c e is plain, fig,
130e0 20 64 6f 74 2c 20 65 74 63 2e 20 68 74 74 70 3a dot, etc. http:
130f0 2f 2f 77 77 77 2e 67 72 61 70 68 76 69 7a 2e 6f //www.graphviz.o
13100 72 67 2f 63 6f 6e 74 65 6e 74 2f 6f 75 74 70 75 rg/content/outpu
13110 74 2d 66 6f 72 6d 61 74 73 0a 20 20 28 6c 65 74 t-formats. (let
13120 2d 76 61 6c 75 65 73 20 28 28 28 69 6e 70 20 6f -values (((inp o
13130 75 70 20 70 69 64 29 28 70 72 6f 63 65 73 73 20 up pid)(process
13140 22 65 6e 76 20 2d 69 20 50 41 54 48 3d 24 50 41 "env -i PATH=$PA
13150 54 48 20 64 6f 74 22 20 28 6c 69 73 74 20 22 2d TH dot" (list "-
13160 54 22 20 6f 75 74 74 79 70 65 29 29 29 29 0a 20 T" outtype)))).
13170 20 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d (with-output-
13180 74 6f 2d 70 6f 72 74 20 6f 75 70 0a 20 20 20 20 to-port oup.
13190 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 28 6d (lambda ()..(m
131a0 61 70 20 70 72 69 6e 74 20 69 6e 64 61 74 29 29 ap print indat))
131b0 29 0a 20 20 20 20 28 63 6c 6f 73 65 2d 6f 75 74 ). (close-out
131c0 70 75 74 2d 70 6f 72 74 20 6f 75 70 29 0a 20 20 put-port oup).
131d0 20 20 28 6c 65 74 20 28 28 72 65 73 20 28 77 69 (let ((res (wi
131e0 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 6f th-input-from-po
131f0 72 74 20 69 6e 70 0a 09 09 20 28 6c 61 6d 62 64 rt inp... (lambd
13200 61 20 28 29 0a 09 09 20 20 20 28 72 65 61 64 2d a ()... (read-
13210 6c 69 6e 65 73 29 29 29 29 29 0a 20 20 20 20 20 lines))))).
13220 20 28 63 6c 6f 73 65 2d 69 6e 70 75 74 2d 70 6f (close-input-po
13230 72 74 20 69 6e 70 29 0a 20 20 20 20 20 20 72 65 rt inp). re
13240 73 29 29 29 0a 0a 3b 3b 20 72 65 61 64 20 64 61 s)))..;; read da
13250 74 61 20 66 72 6f 6d 20 74 6d 70 20 66 69 6c 65 ta from tmp file
13260 20 6f 72 20 63 72 65 61 74 65 20 69 66 20 6e 6f or create if no
13270 74 20 65 78 69 73 74 73 0a 3b 3b 20 69 66 20 65 t exists.;; if e
13280 78 69 73 74 73 20 72 65 67 65 6e 20 69 6e 20 62 xists regen in b
13290 61 63 6b 67 72 6f 75 6e 64 0a 3b 3b 0a 28 64 65 ackground.;;.(de
132a0 66 69 6e 65 20 28 74 65 73 74 73 3a 6c 61 7a 79 fine (tests:lazy
132b0 2d 64 6f 74 20 74 65 73 74 72 65 63 6f 72 64 73 -dot testrecords
132c0 20 20 6f 75 74 74 79 70 65 20 73 69 7a 65 78 20 outtype sizex
132d0 73 69 7a 65 79 29 0a 20 20 28 6c 65 74 20 28 28 sizey). (let ((
132e0 64 66 69 6c 65 20 28 63 6f 6e 63 20 22 2f 74 6d dfile (conc "/tm
132f0 70 2f 2e 22 20 28 63 75 72 72 65 6e 74 2d 75 73 p/." (current-us
13300 65 72 2d 6e 61 6d 65 29 20 22 2d 22 20 28 73 65 er-name) "-" (se
13310 72 76 65 72 3a 6d 6b 2d 73 69 67 6e 61 74 75 72 rver:mk-signatur
13320 65 29 20 22 2e 64 6f 74 22 29 29 0a 09 28 66 6e e) ".dot"))..(fn
13330 61 6d 65 20 28 63 6f 6e 63 20 22 2f 74 6d 70 2f ame (conc "/tmp/
13340 2e 22 20 28 63 75 72 72 65 6e 74 2d 75 73 65 72 ." (current-user
13350 2d 6e 61 6d 65 29 20 22 2d 22 20 28 73 65 72 76 -name) "-" (serv
13360 65 72 3a 6d 6b 2d 73 69 67 6e 61 74 75 72 65 29 er:mk-signature)
13370 20 22 2e 64 6f 74 64 61 74 22 29 29 29 0a 20 20 ".dotdat"))).
13380 20 20 28 74 65 73 74 73 3a 77 72 69 74 65 2d 64 (tests:write-d
13390 6f 74 2d 66 69 6c 65 20 74 65 73 74 72 65 63 6f ot-file testreco
133a0 72 64 73 20 64 66 69 6c 65 20 73 69 7a 65 78 20 rds dfile sizex
133b0 73 69 7a 65 79 29 0a 20 20 20 20 28 69 66 20 28 sizey). (if (
133c0 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 common:file-exis
133d0 74 73 3f 20 66 6e 61 6d 65 29 0a 09 28 6c 65 74 ts? fname)..(let
133e0 20 28 28 72 65 73 20 28 77 69 74 68 2d 69 6e 70 ((res (with-inp
133f0 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 20 66 6e 61 ut-from-file fna
13400 6d 65 0a 09 09 20 20 20 20 20 28 6c 61 6d 62 64 me... (lambd
13410 61 20 28 29 0a 09 09 20 20 20 20 20 20 20 28 72 a ()... (r
13420 65 61 64 2d 6c 69 6e 65 73 29 29 29 29 29 0a 09 ead-lines)))))..
13430 20 20 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 (system (conc
13440 22 65 6e 76 20 2d 69 20 50 41 54 48 3d 24 50 41 "env -i PATH=$PA
13450 54 48 20 64 6f 74 20 2d 54 20 22 20 6f 75 74 74 TH dot -T " outt
13460 79 70 65 20 22 20 3c 20 22 20 64 66 69 6c 65 20 ype " < " dfile
13470 22 20 3e 20 22 20 66 6e 61 6d 65 20 22 26 22 29 " > " fname "&")
13480 29 0a 09 20 20 72 65 73 29 0a 09 28 62 65 67 69 ).. res)..(begi
13490 6e 0a 09 20 20 28 73 79 73 74 65 6d 20 28 63 6f n.. (system (co
134a0 6e 63 20 22 65 6e 76 20 2d 69 20 50 41 54 48 3d nc "env -i PATH=
134b0 24 50 41 54 48 20 64 6f 74 20 2d 54 20 22 20 6f $PATH dot -T " o
134c0 75 74 74 79 70 65 20 22 20 3c 20 22 20 64 66 69 uttype " < " dfi
134d0 6c 65 20 22 20 3e 20 22 20 66 6e 61 6d 65 29 29 le " > " fname))
134e0 0a 09 20 20 28 77 69 74 68 2d 69 6e 70 75 74 2d .. (with-input-
134f0 66 72 6f 6d 2d 66 69 6c 65 20 66 6e 61 6d 65 0a from-file fname.
13500 09 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a . (lambda ().
13510 09 20 20 20 20 20 20 28 72 65 61 64 2d 6c 69 6e . (read-lin
13520 65 73 29 29 29 29 29 29 29 0a 09 20 20 0a 0a 3b es))))))).. ..;
13530 3b 20 66 6f 72 20 65 61 63 68 20 74 65 73 74 3a ; for each test:
13540 0a 3b 3b 20 20 20 0a 28 64 65 66 69 6e 65 20 28 .;; .(define (
13550 74 65 73 74 73 3a 66 69 6c 74 65 72 2d 6e 6f 6e tests:filter-non
13560 2d 72 75 6e 6e 61 62 6c 65 20 72 75 6e 2d 69 64 -runnable run-id
13570 20 74 65 73 74 6b 65 79 6e 61 6d 65 73 20 74 65 testkeynames te
13580 73 74 72 65 63 6f 72 64 73 68 61 73 68 29 0a 20 strecordshash).
13590 20 28 6c 65 74 20 28 28 72 75 6e 6e 61 62 6c 65 (let ((runnable
135a0 73 20 27 28 29 29 29 0a 20 20 20 20 28 66 6f 72 s '())). (for
135b0 2d 65 61 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 -each. (lamb
135c0 64 61 20 28 74 65 73 74 6b 65 79 6e 61 6d 65 29 da (testkeyname)
135d0 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 . (let* ((
135e0 74 65 73 74 2d 72 65 63 6f 72 64 20 28 68 61 73 test-record (has
135f0 68 2d 74 61 62 6c 65 2d 72 65 66 20 74 65 73 74 h-table-ref test
13600 72 65 63 6f 72 64 73 68 61 73 68 20 74 65 73 74 recordshash test
13610 6b 65 79 6e 61 6d 65 29 29 0a 09 20 20 20 20 20 keyname))..
13620 20 28 74 65 73 74 2d 6e 61 6d 65 20 20 20 28 74 (test-name (t
13630 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 ests:testqueue-g
13640 65 74 2d 74 65 73 74 6e 61 6d 65 20 20 74 65 73 et-testname tes
13650 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 20 20 20 t-record))..
13660 20 20 28 69 74 65 6d 64 61 74 20 20 20 20 20 28 (itemdat (
13670 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d tests:testqueue-
13680 67 65 74 2d 69 74 65 6d 64 61 74 20 20 20 74 65 get-itemdat te
13690 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 20 20 st-record))..
136a0 20 20 20 28 69 74 65 6d 2d 70 61 74 68 20 20 20 (item-path
136b0 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 (tests:testqueue
136c0 2d 67 65 74 2d 69 74 65 6d 5f 70 61 74 68 20 74 -get-item_path t
136d0 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 20 est-record))..
136e0 20 20 20 20 28 77 61 69 74 6f 6e 73 20 20 20 20 (waitons
136f0 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 (tests:testqueu
13700 65 2d 67 65 74 2d 77 61 69 74 6f 6e 73 20 20 20 e-get-waitons
13710 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 test-record))..
13720 20 20 20 20 20 28 6b 65 65 70 2d 74 65 73 74 20 (keep-test
13730 20 20 23 74 29 0a 09 20 20 20 20 20 20 28 74 65 #t).. (te
13740 73 74 2d 69 64 20 20 20 20 20 28 72 6d 74 3a 67 st-id (rmt:g
13750 65 74 2d 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 et-test-id run-i
13760 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d d test-name item
13770 2d 70 61 74 68 29 29 0a 09 20 20 20 20 20 20 28 -path)).. (
13780 74 64 61 74 20 20 20 20 20 20 20 20 28 72 6d 74 tdat (rmt
13790 3a 67 65 74 2d 74 65 73 74 69 6e 66 6f 2d 73 74 :get-testinfo-st
137a0 61 74 65 2d 73 74 61 74 75 73 20 72 75 6e 2d 69 ate-status run-i
137b0 64 20 74 65 73 74 2d 69 64 29 29 29 20 3b 3b 20 d test-id))) ;;
137c0 28 63 64 62 3a 67 65 74 2d 74 65 73 74 2d 69 6e (cdb:get-test-in
137d0 66 6f 2d 62 79 2d 69 64 20 2a 72 75 6e 72 65 6d fo-by-id *runrem
137e0 6f 74 65 2a 20 74 65 73 74 2d 69 64 29 29 29 0a ote* test-id))).
137f0 09 20 28 69 66 20 74 64 61 74 0a 09 20 20 20 20 . (if tdat..
13800 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 20 (begin..
13810 3b 3b 20 4c 6f 6f 6b 20 61 74 20 74 68 65 20 74 ;; Look at the t
13820 65 73 74 20 73 74 61 74 65 20 61 6e 64 20 73 74 est state and st
13830 61 74 75 73 0a 09 20 20 20 20 20 20 20 28 69 66 atus.. (if
13840 20 28 6f 72 20 28 61 6e 64 20 28 6d 65 6d 62 65 (or (and (membe
13850 72 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 r (db:test-get-s
13860 74 61 74 75 73 20 74 64 61 74 29 20 0a 09 09 09 tatus tdat) ....
13870 09 20 20 20 20 27 28 22 50 41 53 53 22 20 22 57 . '("PASS" "W
13880 41 52 4e 22 20 22 57 41 49 56 45 44 22 20 22 43 ARN" "WAIVED" "C
13890 48 45 43 4b 22 20 22 53 4b 49 50 22 29 29 0a 09 HECK" "SKIP"))..
138a0 09 09 20 20 20 20 28 65 71 75 61 6c 3f 20 28 64 .. (equal? (d
138b0 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 b:test-get-state
138c0 20 74 64 61 74 29 20 22 43 4f 4d 50 4c 45 54 45 tdat) "COMPLETE
138d0 44 22 29 29 0a 09 09 20 20 20 20 20 20 20 28 6d D"))... (m
138e0 65 6d 62 65 72 20 28 64 62 3a 74 65 73 74 2d 67 ember (db:test-g
138f0 65 74 2d 73 74 61 74 65 20 74 64 61 74 29 0a 09 et-state tdat)..
13900 09 09 09 20 20 20 20 27 28 22 49 4e 43 4f 4d 50 ... '("INCOMP
13910 4c 45 54 45 22 20 22 4b 49 4c 4c 45 44 22 29 29 LETE" "KILLED"))
13920 29 0a 09 09 20 20 20 28 73 65 74 21 20 6b 65 65 )... (set! kee
13930 70 2d 74 65 73 74 20 23 66 29 29 0a 0a 09 20 20 p-test #f))...
13940 20 20 20 20 20 3b 3b 20 65 78 61 6d 69 6e 65 20 ;; examine
13950 77 61 69 74 6f 6e 73 20 66 6f 72 20 61 6e 79 20 waitons for any
13960 66 61 69 6c 73 2e 20 49 66 20 69 74 20 69 73 20 fails. If it is
13970 46 41 49 4c 20 6f 72 20 49 4e 43 4f 4d 50 4c 45 FAIL or INCOMPLE
13980 54 45 20 74 68 65 6e 20 65 6c 69 6d 69 6e 61 74 TE then eliminat
13990 65 20 74 68 69 73 20 74 65 73 74 0a 09 20 20 20 e this test..
139a0 20 20 20 20 3b 3b 20 66 72 6f 6d 20 74 68 65 20 ;; from the
139b0 72 75 6e 6e 61 62 6c 65 20 6c 69 73 74 0a 09 20 runnable list..
139c0 20 20 20 20 20 20 28 69 66 20 6b 65 65 70 2d 74 (if keep-t
139d0 65 73 74 0a 09 09 20 20 20 28 66 6f 72 2d 65 61 est... (for-ea
139e0 63 68 20 28 6c 61 6d 62 64 61 20 28 77 61 69 74 ch (lambda (wait
139f0 6f 6e 29 0a 09 09 09 20 20 20 20 20 20 20 3b 3b on).... ;;
13a00 20 66 6f 72 20 6e 6f 77 20 77 65 20 61 72 65 20 for now we are
13a10 77 61 69 74 69 6e 67 20 6f 6e 6c 79 20 6f 6e 20 waiting only on
13a20 74 68 65 20 70 61 72 65 6e 74 20 74 65 73 74 0a the parent test.
13a30 09 09 09 20 20 20 20 20 20 20 28 6c 65 74 2a 20 ... (let*
13a40 28 28 70 61 72 65 6e 74 2d 74 65 73 74 2d 69 64 ((parent-test-id
13a50 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 (rmt:get-test-i
13a60 64 20 72 75 6e 2d 69 64 20 77 61 69 74 6f 6e 20 d run-id waiton
13a70 22 22 29 29 0a 09 09 09 09 20 20 20 20 20 20 28 ""))..... (
13a80 77 74 64 61 74 20 20 20 20 20 20 20 20 20 20 28 wtdat (
13a90 72 6d 74 3a 67 65 74 2d 74 65 73 74 69 6e 66 6f rmt:get-testinfo
13aa0 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 72 75 -state-status ru
13ab0 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 29 29 20 n-id test-id)))
13ac0 3b 3b 20 28 63 64 62 3a 67 65 74 2d 74 65 73 74 ;; (cdb:get-test
13ad0 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 2a 72 75 6e -info-by-id *run
13ae0 72 65 6d 6f 74 65 2a 20 74 65 73 74 2d 69 64 29 remote* test-id)
13af0 29 29 0a 09 09 09 09 20 28 69 66 20 28 6f 72 20 ))..... (if (or
13b00 28 61 6e 64 20 28 65 71 75 61 6c 3f 20 28 64 62 (and (equal? (db
13b10 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 :test-get-state
13b20 77 74 64 61 74 29 20 22 43 4f 4d 50 4c 45 54 45 wtdat) "COMPLETE
13b30 44 22 29 0a 09 09 09 09 09 20 20 20 20 20 20 28 D")...... (
13b40 6d 65 6d 62 65 72 20 28 64 62 3a 74 65 73 74 2d member (db:test-
13b50 67 65 74 2d 73 74 61 74 75 73 20 77 74 64 61 74 get-status wtdat
13b60 29 20 27 28 22 46 41 49 4c 22 20 22 41 42 4f 52 ) '("FAIL" "ABOR
13b70 54 22 29 29 29 0a 09 09 09 09 09 20 28 6d 65 6d T")))...... (mem
13b80 62 65 72 20 28 64 62 3a 74 65 73 74 2d 67 65 74 ber (db:test-get
13b90 2d 73 74 61 74 75 73 20 77 74 64 61 74 29 20 20 -status wtdat)
13ba0 27 28 22 4b 49 4c 4c 45 44 22 29 29 0a 09 09 09 '("KILLED"))....
13bb0 09 09 20 28 6d 65 6d 62 65 72 20 28 64 62 3a 74 .. (member (db:t
13bc0 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 77 74 est-get-state wt
13bd0 64 61 74 29 20 20 20 27 28 22 49 4e 43 4f 4d 50 dat) '("INCOMP
13be0 45 54 45 22 29 29 29 0a 09 09 09 09 20 3b 3b 20 ETE")))..... ;;
13bf0 28 69 66 20 28 6f 72 20 28 6d 65 6d 62 65 72 20 (if (or (member
13c00 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 (db:test-get-sta
13c10 74 75 73 20 77 74 64 61 74 29 0a 09 09 09 09 20 tus wtdat).....
13c20 3b 3b 20 20 20 20 20 20 20 20 09 20 27 28 22 46 ;; . '("F
13c30 41 49 4c 22 20 22 4b 49 4c 4c 45 44 22 29 29 0a AIL" "KILLED")).
13c40 09 09 09 09 20 3b 3b 20 20 20 20 20 20 20 20 20 .... ;;
13c50 28 6d 65 6d 62 65 72 20 28 64 62 3a 74 65 73 74 (member (db:test
13c60 2d 67 65 74 2d 73 74 61 74 65 20 77 74 64 61 74 -get-state wtdat
13c70 29 0a 09 09 09 09 20 3b 3b 20 20 20 20 20 20 20 )..... ;;
13c80 20 09 20 27 28 22 49 4e 43 4f 4d 50 45 54 45 22 . '("INCOMPETE"
13c90 29 29 29 0a 09 09 09 09 20 20 20 20 20 28 73 65 )))..... (se
13ca0 74 21 20 6b 65 65 70 2d 74 65 73 74 20 23 66 29 t! keep-test #f)
13cb0 29 29 29 20 3b 3b 20 6e 6f 20 70 6f 69 6e 74 20 ))) ;; no point
13cc0 69 6e 20 72 75 6e 6e 69 6e 67 20 74 68 69 73 20 in running this
13cd0 6f 6e 65 20 61 67 61 69 6e 0a 09 09 09 20 20 20 one again....
13ce0 20 20 77 61 69 74 6f 6e 73 29 29 29 29 0a 09 20 waitons))))..
13cf0 28 69 66 20 6b 65 65 70 2d 74 65 73 74 20 28 73 (if keep-test (s
13d00 65 74 21 20 72 75 6e 6e 61 62 6c 65 73 20 28 63 et! runnables (c
13d10 6f 6e 73 20 74 65 73 74 6b 65 79 6e 61 6d 65 20 ons testkeyname
13d20 72 75 6e 6e 61 62 6c 65 73 29 29 29 29 29 0a 20 runnables))))).
13d30 20 20 20 20 74 65 73 74 6b 65 79 6e 61 6d 65 73 testkeynames
13d40 29 0a 20 20 20 20 72 75 6e 6e 61 62 6c 65 73 29 ). runnables)
13d50 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )..;;===========
13d60 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13d70 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13d80 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13d90 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 72 ===========.;; r
13da0 65 66 61 63 74 6f 72 69 6e 67 20 74 68 69 73 20 efactoring this
13db0 62 6c 6f 63 6b 20 69 6e 74 6f 20 74 65 73 74 73 block into tests
13dc0 3a 67 65 74 2d 66 75 6c 6c 2d 64 61 74 61 20 66 :get-full-data f
13dd0 72 6f 6d 20 6c 69 6e 65 20 32 36 33 20 6f 66 20 rom line 263 of
13de0 72 75 6e 73 2e 73 63 6d 0a 3b 3b 3d 3d 3d 3d 3d runs.scm.;;=====
13df0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13e00 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13e10 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13e20 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13e30 3d 0a 3b 3b 20 68 65 64 20 69 73 20 74 68 65 20 =.;; hed is the
13e40 74 65 73 74 20 6e 61 6d 65 0a 3b 3b 20 74 65 73 test name.;; tes
13e50 74 2d 72 65 63 6f 72 64 73 20 69 73 20 61 20 68 t-records is a h
13e60 61 73 68 20 6f 66 20 74 65 73 74 2d 6e 61 6d 65 ash of test-name
13e70 20 3d 3e 20 74 65 73 74 20 72 65 63 6f 72 64 0a => test record.
13e80 28 64 65 66 69 6e 65 20 28 74 65 73 74 73 3a 67 (define (tests:g
13e90 65 74 2d 66 75 6c 6c 2d 64 61 74 61 20 74 65 73 et-full-data tes
13ea0 74 2d 6e 61 6d 65 73 20 74 65 73 74 2d 72 65 63 t-names test-rec
13eb0 6f 72 64 73 20 72 65 71 75 69 72 65 64 2d 74 65 ords required-te
13ec0 73 74 73 20 61 6c 6c 2d 74 65 73 74 73 2d 72 65 sts all-tests-re
13ed0 67 69 73 74 72 79 29 0a 20 20 28 6c 65 74 20 28 gistry). (let (
13ee0 28 6d 69 73 73 69 6e 67 2d 77 61 69 74 6f 6e 73 (missing-waitons
13ef0 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
13f00 65 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f e))). (if (no
13f10 74 20 28 6e 75 6c 6c 3f 20 74 65 73 74 2d 6e 61 t (null? test-na
13f20 6d 65 73 29 29 0a 20 20 20 20 20 20 28 6c 65 74 mes)). (let
13f30 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 61 72 loop ((hed (car
13f40 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 0a 09 09 test-names))...
13f50 20 28 74 61 6c 20 28 63 64 72 20 74 65 73 74 2d (tal (cdr test-
13f60 6e 61 6d 65 73 29 29 29 20 20 20 20 20 20 20 20 names)))
13f70 20 3b 3b 20 27 72 65 74 75 72 6e 2d 70 72 6f 63 ;; 'return-proc
13f80 73 20 74 65 6c 6c 73 20 74 68 65 20 63 6f 6e 66 s tells the conf
13f90 69 67 20 72 65 61 64 65 72 20 74 6f 20 70 72 65 ig reader to pre
13fa0 70 20 72 75 6e 6e 69 6e 67 20 73 79 73 74 65 6d p running system
13fb0 20 62 75 74 20 72 65 74 75 72 6e 20 61 20 70 72 but return a pr
13fc0 6f 63 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 oc..(debug:print
13fd0 2d 69 6e 66 6f 20 34 20 2a 64 65 66 61 75 6c 74 -info 4 *default
13fe0 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 68 65 64 3d -log-port* "hed=
13ff0 22 20 68 65 64 20 22 20 61 74 20 74 6f 70 20 6f " hed " at top o
14000 66 20 6c 6f 6f 70 22 29 0a 20 20 20 20 20 20 20 f loop").
14010 20 3b 3b 20 64 6f 6e 27 74 20 6b 6e 6f 77 20 69 ;; don't know i
14020 74 65 6d 2d 70 61 74 68 20 61 74 20 74 68 69 73 tem-path at this
14030 20 74 69 6d 65 2c 20 6c 65 74 20 74 68 65 20 74 time, let the t
14040 65 73 74 63 6f 6e 66 69 67 20 67 65 74 20 74 68 estconfig get th
14050 65 20 74 6f 70 20 6c 65 76 65 6c 20 74 65 73 74 e top level test
14060 63 6f 6e 66 69 67 0a 09 28 6c 65 74 2a 20 28 28 config..(let* ((
14070 63 6f 6e 66 69 67 20 20 28 74 65 73 74 73 3a 67 config (tests:g
14080 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 68 65 et-testconfig he
14090 64 20 23 66 20 61 6c 6c 2d 74 65 73 74 73 2d 72 d #f all-tests-r
140a0 65 67 69 73 74 72 79 20 27 72 65 74 75 72 6e 2d egistry 'return-
140b0 70 72 6f 63 73 29 29 0a 09 20 20 20 20 20 20 20 procs))..
140c0 28 77 61 69 74 6f 6e 73 20 28 6c 65 74 20 28 28 (waitons (let ((
140d0 69 6e 73 74 72 20 28 69 66 20 63 6f 6e 66 69 67 instr (if config
140e0 20 0a 09 09 09 09 09 20 28 63 6f 6e 66 69 67 66 ...... (configf
140f0 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 20 22 :lookup config "
14100 72 65 71 75 69 72 65 6d 65 6e 74 73 22 20 22 77 requirements" "w
14110 61 69 74 6f 6e 22 29 0a 09 09 09 09 09 20 28 62 aiton")...... (b
14120 65 67 69 6e 20 3b 3b 20 4e 6f 20 63 6f 6e 66 69 egin ;; No confi
14130 67 20 6d 65 61 6e 73 20 74 68 69 73 20 69 73 20 g means this is
14140 61 20 6e 6f 6e 2d 65 78 69 73 74 65 6e 74 20 74 a non-existent t
14150 65 73 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 est.
14160 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14170 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
14180 6c 65 74 20 28 28 77 61 69 74 65 72 73 20 27 28 let ((waiters '(
14190 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
141a0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
141b0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
141c0 20 3b 3b 20 66 69 6e 64 20 74 68 65 20 77 61 69 ;; find the wai
141d0 74 65 72 28 73 29 20 66 6f 72 20 74 68 69 73 20 ter(s) for this
141e0 77 61 69 74 6f 6e 2e 0a 20 20 20 20 20 20 20 20 waiton..
141f0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14200 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14210 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a (for-each .
14220 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14230 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14240 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
14250 6c 61 6d 62 64 61 28 77 61 69 74 65 72 29 0a 20 lambda(waiter).
14260 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14270 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14280 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14290 3b 3b 20 28 70 72 69 6e 74 20 22 74 65 73 74 2d ;; (print "test-
142a0 72 65 63 6f 72 64 20 3d 20 22 20 28 68 61 73 68 record = " (hash
142b0 2d 74 61 62 6c 65 2d 72 65 66 20 74 65 73 74 2d -table-ref test-
142c0 72 65 63 6f 72 64 73 20 77 61 69 74 65 72 29 29 records waiter))
142d0 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
142e0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
142f0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14300 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 77 61 69 ;; (print "wai
14310 74 6f 6e 73 20 3d 20 22 20 28 76 65 63 74 6f 72 tons = " (vector
14320 2d 72 65 66 20 28 68 61 73 68 2d 74 61 62 6c 65 -ref (hash-table
14330 2d 72 65 66 20 74 65 73 74 2d 72 65 63 6f 72 64 -ref test-record
14340 73 20 77 61 69 74 65 72 29 20 32 29 29 0a 20 20 s waiter) 2)).
14350 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14360 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14370 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
14380 69 66 20 28 6d 65 6d 62 65 72 20 68 65 64 20 28 if (member hed (
14390 76 65 63 74 6f 72 2d 72 65 66 20 28 68 61 73 68 vector-ref (hash
143a0 2d 74 61 62 6c 65 2d 72 65 66 20 74 65 73 74 2d -table-ref test-
143b0 72 65 63 6f 72 64 73 20 77 61 69 74 65 72 29 20 records waiter)
143c0 32 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 2)).
143d0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
143e0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
143f0 20 20 20 20 20 20 20 20 28 73 65 74 21 20 77 61 (set! wa
14400 69 74 65 72 73 20 28 63 6f 6e 73 20 77 61 69 74 iters (cons wait
14410 65 72 20 77 61 69 74 65 72 73 29 29 0a 20 20 20 er waiters)).
14420 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14430 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14440 20 20 20 20 20 20 20 20 20 20 20 20 20 20 29 0a ).
14450 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14460 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14470 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 29 )
14480 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
14490 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
144a0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 68 (h
144b0 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 74 ash-table-keys t
144c0 65 73 74 2d 72 65 63 6f 72 64 73 29 29 0a 20 20 est-records)).
144d0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
144e0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
144f0 20 20 20 20 20 20 20 20 20 20 20 28 68 61 73 68 (hash
14500 2d 74 61 62 6c 65 2d 73 65 74 21 20 6d 69 73 73 -table-set! miss
14510 69 6e 67 2d 77 61 69 74 6f 6e 73 20 68 65 64 20 ing-waitons hed
14520 77 61 69 74 65 72 73 29 0a 20 20 20 20 20 20 20 waiters).
14530 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14540 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14550 20 20 20 20 29 0a 09 09 09 09 09 20 20 20 22 22 )...... ""
14560 29 29 29 29 0a 09 09 09 20 20 28 64 65 62 75 67 )))).... (debug
14570 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 38 20 2a 64 :print-info 8 *d
14580 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
14590 20 22 77 61 69 74 6f 6e 73 20 73 74 72 69 6e 67 "waitons string
145a0 20 69 73 20 22 20 69 6e 73 74 72 29 0a 09 09 09 is " instr)....
145b0 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 (string-split
145c0 28 63 6f 6e 64 0a 09 09 09 09 09 20 28 28 70 72 (cond...... ((pr
145d0 6f 63 65 64 75 72 65 3f 20 69 6e 73 74 72 29 0a ocedure? instr).
145e0 09 09 09 09 09 20 20 28 6c 65 74 20 28 28 72 65 ..... (let ((re
145f0 73 20 28 69 6e 73 74 72 29 29 29 0a 09 09 09 09 s (instr))).....
14600 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
14610 74 2d 69 6e 66 6f 20 38 20 2a 64 65 66 61 75 6c t-info 8 *defaul
14620 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 77 61 69 t-log-port* "wai
14630 74 6f 6e 20 70 72 6f 63 65 64 75 72 65 20 72 65 ton procedure re
14640 73 75 6c 74 73 20 69 6e 20 73 74 72 69 6e 67 20 sults in string
14650 22 20 72 65 73 20 22 20 66 6f 72 20 74 65 73 74 " res " for test
14660 20 22 20 68 65 64 29 0a 09 09 09 09 09 20 20 20 " hed)......
14670 20 72 65 73 29 29 0a 09 09 09 09 09 20 28 28 73 res))...... ((s
14680 74 72 69 6e 67 3f 20 69 6e 73 74 72 29 20 20 20 tring? instr)
14690 20 20 69 6e 73 74 72 29 0a 09 09 09 09 09 20 28 instr)...... (
146a0 65 6c 73 65 20 0a 09 09 09 09 09 20 20 3b 3b 20 else ...... ;;
146b0 4e 4f 54 45 3a 20 54 68 69 73 20 69 73 20 61 63 NOTE: This is ac
146c0 74 75 61 6c 6c 79 20 74 68 65 20 63 61 73 65 20 tually the case
146d0 6f 66 20 2a 6e 6f 2a 20 77 61 69 74 6f 6e 73 21 of *no* waitons!
146e0 20 3b 3b 20 0a 09 09 09 09 09 20 20 22 22 29 29 ;; ...... ""))
146f0 29 29 29 29 0a 09 20 20 28 69 66 20 28 6e 6f 74 )))).. (if (not
14700 20 63 6f 6e 66 69 67 29 20 3b 3b 20 74 68 69 73 config) ;; this
14710 20 69 73 20 61 20 6e 6f 6e 2d 65 78 69 73 74 61 is a non-exista
14720 6e 74 20 74 65 73 74 20 63 61 6c 6c 65 64 20 69 nt test called i
14730 6e 20 61 20 77 61 69 74 6f 6e 2e 20 0a 09 20 20 n a waiton. ..
14740 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 (if (null? t
14750 61 6c 29 0a 09 09 20 20 74 65 73 74 2d 72 65 63 al)... test-rec
14760 6f 72 64 73 0a 09 09 20 20 28 6c 6f 6f 70 20 28 ords... (loop (
14770 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c car tal)(cdr tal
14780 29 29 29 0a 09 20 20 20 20 20 20 28 62 65 67 69 ))).. (begi
14790 6e 0a 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 n...(debug:print
147a0 2d 69 6e 66 6f 20 38 20 2a 64 65 66 61 75 6c 74 -info 8 *default
147b0 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 77 61 69 74 -log-port* "wait
147c0 6f 6e 73 3a 20 22 20 77 61 69 74 6f 6e 73 29 0a ons: " waitons).
147d0 09 09 3b 3b 20 63 68 65 63 6b 20 66 6f 72 20 68 ..;; check for h
147e0 65 64 20 69 6e 20 77 61 69 74 6f 6e 73 20 3d 3e ed in waitons =>
147f0 20 74 68 69 73 20 77 6f 75 6c 64 20 62 65 20 63 this would be c
14800 69 72 63 75 6c 61 72 2c 20 72 65 6d 6f 76 65 20 ircular, remove
14810 69 74 20 61 6e 64 20 69 73 73 75 65 20 61 6e 0a it and issue an.
14820 09 09 3b 3b 20 65 72 72 6f 72 0a 09 09 28 69 66 ..;; error...(if
14830 20 28 6d 65 6d 62 65 72 20 68 65 64 20 77 61 69 (member hed wai
14840 74 6f 6e 73 29 0a 09 09 20 20 20 20 28 62 65 67 tons)... (beg
14850 69 6e 0a 09 09 20 20 20 20 20 20 28 64 65 62 75 in... (debu
14860 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 g:print-error 0
14870 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
14880 74 2a 20 22 74 65 73 74 20 22 20 68 65 64 20 22 t* "test " hed "
14890 20 68 61 73 20 6c 69 73 74 65 64 20 69 74 73 65 has listed itse
148a0 6c 66 20 61 73 20 61 20 77 61 69 74 6f 6e 2c 20 lf as a waiton,
148b0 70 6c 65 61 73 65 20 63 6f 72 72 65 63 74 20 74 please correct t
148c0 68 69 73 21 22 29 0a 09 09 20 20 20 20 20 20 28 his!")... (
148d0 73 65 74 21 20 77 61 69 74 6f 6e 73 20 28 66 69 set! waitons (fi
148e0 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 lter (lambda (x)
148f0 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 78 20 68 (not (equal? x h
14900 65 64 29 29 29 20 77 61 69 74 6f 6e 73 29 29 29 ed))) waitons)))
14910 29 0a 09 09 0a 09 09 3b 3b 20 28 69 74 65 6d 73 )......;; (items
14920 20 20 20 28 69 74 65 6d 73 3a 67 65 74 2d 69 74 (items:get-it
14930 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 20 ems-from-config
14940 63 6f 6e 66 69 67 29 29 29 0a 09 09 28 69 66 20 config)))...(if
14950 28 6e 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 (not (hash-table
14960 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 65 73 -ref/default tes
14970 74 2d 72 65 63 6f 72 64 73 20 68 65 64 20 23 66 t-records hed #f
14980 29 29 0a 09 09 20 20 20 20 28 68 61 73 68 2d 74 ))... (hash-t
14990 61 62 6c 65 2d 73 65 74 21 20 74 65 73 74 2d 72 able-set! test-r
149a0 65 63 6f 72 64 73 0a 09 09 09 09 20 20 20 20 20 ecords.....
149b0 68 65 64 20 28 76 65 63 74 6f 72 20 68 65 64 20 hed (vector hed
149c0 20 20 20 20 3b 3b 20 30 0a 09 09 09 09 09 09 20 ;; 0.......
149d0 63 6f 6e 66 69 67 20 20 3b 3b 20 31 0a 09 09 09 config ;; 1....
149e0 09 09 09 20 77 61 69 74 6f 6e 73 20 3b 3b 20 32 ... waitons ;; 2
149f0 0a 09 09 09 09 09 09 20 28 63 6f 6e 66 69 67 66 ....... (configf
14a00 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 20 22 :lookup config "
14a10 72 65 71 75 69 72 65 6d 65 6e 74 73 22 20 22 70 requirements" "p
14a20 72 69 6f 72 69 74 79 22 29 20 20 20 20 20 3b 3b riority") ;;
14a30 20 70 72 69 6f 72 69 74 79 20 33 0a 09 09 09 09 priority 3.....
14a40 09 09 20 28 6c 65 74 20 28 28 69 74 65 6d 73 20 .. (let ((items
14a50 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
14a60 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 63 6f 6e -ref/default con
14a70 66 69 67 20 22 69 74 65 6d 73 22 20 23 66 29 29 fig "items" #f))
14a80 20 3b 3b 20 69 74 65 6d 73 20 34 0a 09 09 09 09 ;; items 4.....
14a90 09 09 20 20 20 20 20 20 20 28 69 74 65 6d 73 74 .. (itemst
14aa0 61 62 6c 65 20 28 68 61 73 68 2d 74 61 62 6c 65 able (hash-table
14ab0 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 63 6f 6e -ref/default con
14ac0 66 69 67 20 22 69 74 65 6d 73 74 61 62 6c 65 22 fig "itemstable"
14ad0 20 23 66 29 29 29 20 0a 09 09 09 09 09 09 20 20 #f))) .......
14ae0 20 3b 3b 20 69 66 20 65 69 74 68 65 72 20 69 74 ;; if either it
14af0 65 6d 73 20 6f 72 20 69 74 65 6d 73 20 74 61 62 ems or items tab
14b00 6c 65 20 69 73 20 61 20 70 72 6f 63 20 72 65 74 le is a proc ret
14b10 75 72 6e 20 69 74 20 73 6f 20 74 65 73 74 20 72 urn it so test r
14b20 75 6e 6e 69 6e 67 0a 09 09 09 09 09 09 20 20 20 unning.......
14b30 3b 3b 20 70 72 6f 63 65 73 73 20 63 61 6e 20 6b ;; process can k
14b40 6e 6f 77 20 74 6f 20 63 61 6c 6c 20 69 74 65 6d now to call item
14b50 73 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d s:get-items-from
14b60 2d 63 6f 6e 66 69 67 0a 09 09 09 09 09 09 20 20 -config.......
14b70 20 3b 3b 20 69 66 20 65 69 74 68 65 72 20 69 73 ;; if either is
14b80 20 61 20 6c 69 73 74 20 61 6e 64 20 6e 6f 6e 65 a list and none
14b90 20 69 73 20 61 20 70 72 6f 63 20 67 6f 20 61 68 is a proc go ah
14ba0 65 61 64 20 61 6e 64 20 63 61 6c 6c 20 67 65 74 ead and call get
14bb0 2d 69 74 65 6d 73 0a 09 09 09 09 09 09 20 20 20 -items.......
14bc0 3b 3b 20 6f 74 68 65 72 77 69 73 65 20 72 65 74 ;; otherwise ret
14bd0 75 72 6e 20 23 66 20 2d 20 74 68 69 73 20 69 73 urn #f - this is
14be0 20 6e 6f 74 20 61 6e 20 69 74 65 72 61 74 65 64 not an iterated
14bf0 20 74 65 73 74 0a 09 09 09 09 09 09 20 20 20 28 test....... (
14c00 63 6f 6e 64 0a 09 09 09 09 09 09 20 20 20 20 28 cond....... (
14c10 28 70 72 6f 63 65 64 75 72 65 3f 20 69 74 65 6d (procedure? item
14c20 73 29 20 20 20 20 20 20 0a 09 09 09 09 09 09 20 s) .......
14c30 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
14c40 2d 69 6e 66 6f 20 34 20 2a 64 65 66 61 75 6c 74 -info 4 *default
14c50 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 69 74 65 6d -log-port* "item
14c60 73 20 69 73 20 61 20 70 72 6f 63 65 64 75 72 65 s is a procedure
14c70 2c 20 77 69 6c 6c 20 63 61 6c 63 20 6c 61 74 65 , will calc late
14c80 72 22 29 0a 09 09 09 09 09 09 20 20 20 20 20 69 r")....... i
14c90 74 65 6d 73 29 20 20 20 20 20 20 20 20 20 20 20 tems)
14ca0 20 3b 3b 20 63 61 6c 63 20 6c 61 74 65 72 0a 09 ;; calc later..
14cb0 09 09 09 09 09 20 20 20 20 28 28 70 72 6f 63 65 ..... ((proce
14cc0 64 75 72 65 3f 20 69 74 65 6d 73 74 61 62 6c 65 dure? itemstable
14cd0 29 0a 09 09 09 09 09 09 20 20 20 20 20 28 64 65 )....... (de
14ce0 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 bug:print-info 4
14cf0 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
14d00 72 74 2a 20 22 69 74 65 6d 73 74 61 62 6c 65 20 rt* "itemstable
14d10 69 73 20 61 20 70 72 6f 63 65 64 75 72 65 2c 20 is a procedure,
14d20 77 69 6c 6c 20 63 61 6c 63 20 6c 61 74 65 72 22 will calc later"
14d30 29 0a 09 09 09 09 09 09 20 20 20 20 20 69 74 65 )....... ite
14d40 6d 73 74 61 62 6c 65 29 20 20 20 20 20 20 20 3b mstable) ;
14d50 3b 20 63 61 6c 63 20 6c 61 74 65 72 0a 09 09 09 ; calc later....
14d60 09 09 09 20 20 20 20 28 28 66 69 6c 74 65 72 20 ... ((filter
14d70 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 09 09 09 (lambda (x).....
14d80 09 09 09 20 20 20 20 20 20 20 28 6c 65 74 20 28 ... (let (
14d90 28 76 61 6c 20 28 63 61 72 20 78 29 29 29 0a 09 (val (car x)))..
14da0 09 09 09 09 09 09 09 20 28 69 66 20 28 70 72 6f ....... (if (pro
14db0 63 65 64 75 72 65 3f 20 76 61 6c 29 20 76 61 6c cedure? val) val
14dc0 20 23 66 29 29 29 0a 09 09 09 09 09 09 09 20 20 #f)))........
14dd0 20 20 20 28 61 70 70 65 6e 64 20 28 69 66 20 28 (append (if (
14de0 6c 69 73 74 3f 20 69 74 65 6d 73 29 20 69 74 65 list? items) ite
14df0 6d 73 20 27 28 29 29 0a 09 09 09 09 09 09 09 09 ms '()).........
14e00 20 20 20 20 20 28 69 66 20 28 6c 69 73 74 3f 20 (if (list?
14e10 69 74 65 6d 73 74 61 62 6c 65 29 20 69 74 65 6d itemstable) item
14e20 73 74 61 62 6c 65 20 27 28 29 29 29 29 0a 09 09 stable '())))...
14e30 09 09 09 09 20 20 20 20 20 27 68 61 76 65 2d 70 .... 'have-p
14e40 72 6f 63 65 64 75 72 65 29 0a 09 09 09 09 09 09 rocedure).......
14e50 20 20 20 20 28 28 6f 72 20 28 6c 69 73 74 3f 20 ((or (list?
14e60 69 74 65 6d 73 29 28 6c 69 73 74 3f 20 69 74 65 items)(list? ite
14e70 6d 73 74 61 62 6c 65 29 29 20 3b 3b 20 63 61 6c mstable)) ;; cal
14e80 63 20 6e 6f 77 0a 09 09 09 09 09 09 20 20 20 20 c now.......
14e90 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
14ea0 66 6f 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 4 *default-lo
14eb0 67 2d 70 6f 72 74 2a 20 22 69 74 65 6d 73 20 61 g-port* "items a
14ec0 6e 64 20 69 74 65 6d 73 74 61 62 6c 65 20 61 72 nd itemstable ar
14ed0 65 20 6c 69 73 74 73 2c 20 63 61 6c 63 20 6e 6f e lists, calc no
14ee0 77 5c 6e 22 0a 09 09 09 09 09 09 09 09 20 20 20 w\n".........
14ef0 20 20 20 20 22 20 20 20 20 69 74 65 6d 73 3a 20 " items:
14f00 22 20 69 74 65 6d 73 20 22 20 69 74 65 6d 73 74 " items " itemst
14f10 61 62 6c 65 3a 20 22 20 69 74 65 6d 73 74 61 62 able: " itemstab
14f20 6c 65 29 0a 09 09 09 09 09 09 20 20 20 20 20 28 le)....... (
14f30 69 74 65 6d 73 3a 67 65 74 2d 69 74 65 6d 73 2d items:get-items-
14f40 66 72 6f 6d 2d 63 6f 6e 66 69 67 20 63 6f 6e 66 from-config conf
14f50 69 67 29 29 0a 09 09 09 09 09 09 20 20 20 20 28 ig))....... (
14f60 65 6c 73 65 20 23 66 29 29 29 20 20 20 20 20 20 else #f)))
14f70 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14f80 20 20 20 20 20 3b 3b 20 6e 6f 74 20 69 74 65 72 ;; not iter
14f90 61 74 65 64 0a 09 09 09 09 09 09 20 23 66 20 20 ated....... #f
14fa0 20 20 20 20 3b 3b 20 69 74 65 6d 73 64 61 74 20 ;; itemsdat
14fb0 35 0a 09 09 09 09 09 09 20 23 66 20 20 20 20 20 5....... #f
14fc0 20 3b 3b 20 73 70 61 72 65 20 2d 20 75 73 65 64 ;; spare - used
14fd0 20 66 6f 72 20 69 74 65 6d 2d 70 61 74 68 0a 09 for item-path..
14fe0 09 09 09 09 09 20 29 29 29 0a 20 20 20 20 20 20 ..... ))).
14ff0 20 20 20 20 20 20 20 20 20 20 28 66 6f 72 2d 65 (for-e
15000 61 63 68 20 0a 09 09 20 28 6c 61 6d 62 64 61 20 ach ... (lambda
15010 28 77 61 69 74 6f 6e 29 0a 09 09 20 20 20 28 69 (waiton)... (i
15020 66 20 28 61 6e 64 20 77 61 69 74 6f 6e 20 28 6e f (and waiton (n
15030 6f 74 20 28 73 74 72 69 6e 67 3d 20 22 23 66 22 ot (string= "#f"
15040 20 77 61 69 74 6f 6e 29 29 20 28 6e 6f 74 20 28 waiton)) (not (
15050 6d 65 6d 62 65 72 20 77 61 69 74 6f 6e 20 74 65 member waiton te
15060 73 74 2d 6e 61 6d 65 73 29 29 29 0a 09 09 20 20 st-names)))...
15070 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 20 (begin....
15080 28 73 65 74 21 20 72 65 71 75 69 72 65 64 2d 74 (set! required-t
15090 65 73 74 73 20 28 63 6f 6e 73 20 77 61 69 74 6f ests (cons waito
150a0 6e 20 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 n required-tests
150b0 29 29 0a 09 09 09 20 28 73 65 74 21 20 74 65 73 )).... (set! tes
150c0 74 2d 6e 61 6d 65 73 20 28 63 6f 6e 73 20 77 61 t-names (cons wa
150d0 69 74 6f 6e 20 74 65 73 74 2d 6e 61 6d 65 73 29 iton test-names)
150e0 29 29 29 29 20 3b 3b 20 77 61 73 20 61 6e 20 61 )))) ;; was an a
150f0 70 70 65 6e 64 2c 20 6e 6f 77 20 61 20 63 6f 6e ppend, now a con
15100 73 0a 09 09 20 77 61 69 74 6f 6e 73 29 0a 09 09 s... waitons)...
15110 28 6c 65 74 20 28 28 72 65 6d 74 65 73 74 73 20 (let ((remtests
15120 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 74 (delete-duplicat
15130 65 73 20 28 61 70 70 65 6e 64 20 77 61 69 74 6f es (append waito
15140 6e 73 20 74 61 6c 29 29 29 29 0a 09 09 20 20 28 ns tal))))... (
15150 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 if (not (null? r
15160 65 6d 74 65 73 74 73 29 29 0a 09 09 20 20 20 20 emtests))...
15170 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 72 65 6d (loop (car rem
15180 74 65 73 74 73 29 28 63 64 72 20 72 65 6d 74 65 tests)(cdr remte
15190 73 74 73 29 29 0a 09 09 20 20 20 20 20 20 74 65 sts))... te
151a0 73 74 2d 72 65 63 6f 72 64 73 29 29 29 29 29 29 st-records))))))
151b0 29 0a 20 20 20 20 20 20 28 66 6f 72 2d 65 61 63 ). (for-eac
151c0 68 0a 20 20 20 20 20 20 20 20 20 28 6c 61 6d 62 h. (lamb
151d0 64 61 20 28 6d 69 73 73 69 6e 67 2d 77 61 69 74 da (missing-wait
151e0 6f 6e 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 on).
151f0 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 (debug:print-err
15200 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f or 0 *default-lo
15210 67 2d 70 6f 72 74 2a 20 22 6e 6f 6e 2d 65 78 69 g-port* "non-exi
15220 73 74 65 6e 74 20 74 65 73 74 20 5c 22 22 20 6d stent test \"" m
15230 69 73 73 69 6e 67 2d 77 61 69 74 6f 6e 20 22 5c issing-waiton "\
15240 22 20 69 73 20 61 20 77 61 69 74 6f 6e 20 66 6f " is a waiton fo
15250 72 20 74 65 73 74 73 20 22 20 28 68 61 73 68 2d r tests " (hash-
15260 74 61 62 6c 65 2d 72 65 66 20 6d 69 73 73 69 6e table-ref missin
15270 67 2d 77 61 69 74 6f 6e 73 20 6d 69 73 73 69 6e g-waitons missin
15280 67 2d 77 61 69 74 6f 6e 29 29 0a 20 20 20 20 20 g-waiton)).
15290 20 20 20 20 29 0a 20 20 20 20 20 20 20 20 20 28 ). (
152a0 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 hash-table-keys
152b0 6d 69 73 73 69 6e 67 2d 77 61 69 74 6f 6e 73 29 missing-waitons)
152c0 0a 20 20 20 20 20 20 29 0a 29 29 0a 0a 3b 3b 3d . ).))..;;=
152d0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
152e0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
152f0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15300 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15310 3d 3d 3d 3d 3d 0a 3b 3b 20 74 65 73 74 20 73 74 =====.;; test st
15320 65 70 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d eps.;;==========
15330 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15340 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15350 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15360 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b ============..;;
15370 20 74 65 73 74 73 74 65 70 2d 73 65 74 2d 73 74 teststep-set-st
15380 61 74 75 73 21 20 75 73 65 64 20 74 6f 20 62 65 atus! used to be
15390 20 68 65 72 65 0a 0a 28 64 65 66 69 6e 65 20 28 here..(define (
153a0 74 65 73 74 2d 67 65 74 2d 6b 69 6c 6c 2d 72 65 test-get-kill-re
153b0 71 75 65 73 74 20 72 75 6e 2d 69 64 20 74 65 73 quest run-id tes
153c0 74 2d 69 64 29 20 3b 3b 20 72 75 6e 2d 69 64 20 t-id) ;; run-id
153d0 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 64 61 test-name itemda
153e0 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 74 65 73 t). (let* ((tes
153f0 74 64 61 74 20 20 20 28 72 6d 74 3a 67 65 74 2d tdat (rmt:get-
15400 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 test-info-by-id
15410 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 29 run-id test-id))
15420 29 0a 20 20 20 20 28 61 6e 64 20 74 65 73 74 64 ). (and testd
15430 61 74 0a 09 20 28 65 71 75 61 6c 3f 20 28 74 65 at.. (equal? (te
15440 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 73 st:get-state tes
15450 74 64 61 74 29 20 22 4b 49 4c 4c 52 45 51 22 29 tdat) "KILLREQ")
15460 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 )))..(define (te
15470 73 74 3a 74 64 62 2d 67 65 74 2d 72 75 6e 64 61 st:tdb-get-runda
15480 74 2d 63 6f 75 6e 74 20 74 64 62 29 0a 20 20 28 t-count tdb). (
15490 69 66 20 74 64 62 0a 20 20 20 20 20 20 28 6c 65 if tdb. (le
154a0 74 20 28 28 72 65 73 20 30 29 29 0a 09 28 73 71 t ((res 0))..(sq
154b0 6c 69 74 65 33 3a 66 6f 72 2d 65 61 63 68 2d 72 lite3:for-each-r
154c0 6f 77 0a 09 20 28 6c 61 6d 62 64 61 20 28 63 6f ow.. (lambda (co
154d0 75 6e 74 29 0a 09 20 20 20 28 73 65 74 21 20 72 unt).. (set! r
154e0 65 73 20 63 6f 75 6e 74 29 29 0a 09 20 74 64 62 es count)).. tdb
154f0 0a 09 20 22 53 45 4c 45 43 54 20 63 6f 75 6e 74 .. "SELECT count
15500 28 69 64 29 20 46 52 4f 4d 20 74 65 73 74 5f 72 (id) FROM test_r
15510 75 6e 64 61 74 3b 22 29 0a 09 72 65 73 29 29 0a undat;")..res)).
15520 20 20 30 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 0)..(define (t
15530 65 73 74 73 3a 75 70 64 61 74 65 2d 63 65 6e 74 ests:update-cent
15540 72 61 6c 2d 6d 65 74 61 2d 69 6e 66 6f 20 72 75 ral-meta-info ru
15550 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 63 70 75 n-id test-id cpu
15560 6c 6f 61 64 20 64 69 73 6b 66 72 65 65 20 6d 69 load diskfree mi
15570 6e 75 74 65 73 20 75 6e 61 6d 65 20 68 6f 73 74 nutes uname host
15580 6e 61 6d 65 29 0a 20 20 28 72 6d 74 3a 67 65 6e name). (rmt:gen
15590 65 72 61 6c 2d 63 61 6c 6c 20 27 75 70 64 61 74 eral-call 'updat
155a0 65 2d 74 65 73 74 2d 72 75 6e 64 61 74 20 72 75 e-test-rundat ru
155b0 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 28 63 75 n-id test-id (cu
155c0 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 28 rrent-seconds) (
155d0 6f 72 20 63 70 75 6c 6f 61 64 20 2d 31 29 28 6f or cpuload -1)(o
155e0 72 20 64 69 73 6b 66 72 65 65 20 2d 31 29 20 2d r diskfree -1) -
155f0 31 20 28 6f 72 20 6d 69 6e 75 74 65 73 20 2d 31 1 (or minutes -1
15600 29 29 0a 20 20 28 69 66 20 28 61 6e 64 20 63 70 )). (if (and cp
15610 75 6c 6f 61 64 20 64 69 73 6b 66 72 65 65 29 0a uload diskfree).
15620 20 20 20 20 20 20 28 72 6d 74 3a 67 65 6e 65 72 (rmt:gener
15630 61 6c 2d 63 61 6c 6c 20 27 75 70 64 61 74 65 2d al-call 'update-
15640 63 70 75 6c 6f 61 64 2d 64 69 73 6b 66 72 65 65 cpuload-diskfree
15650 20 72 75 6e 2d 69 64 20 63 70 75 6c 6f 61 64 20 run-id cpuload
15660 64 69 73 6b 66 72 65 65 20 74 65 73 74 2d 69 64 diskfree test-id
15670 29 29 0a 20 20 28 69 66 20 6d 69 6e 75 74 65 73 )). (if minutes
15680 20 0a 20 20 20 20 20 20 28 72 6d 74 3a 67 65 6e . (rmt:gen
15690 65 72 61 6c 2d 63 61 6c 6c 20 27 75 70 64 61 74 eral-call 'updat
156a0 65 2d 72 75 6e 2d 64 75 72 61 74 69 6f 6e 20 72 e-run-duration r
156b0 75 6e 2d 69 64 20 6d 69 6e 75 74 65 73 20 74 65 un-id minutes te
156c0 73 74 2d 69 64 29 29 0a 20 20 28 69 66 20 28 61 st-id)). (if (a
156d0 6e 64 20 75 6e 61 6d 65 20 68 6f 73 74 6e 61 6d nd uname hostnam
156e0 65 29 0a 20 20 20 20 20 20 28 72 6d 74 3a 67 65 e). (rmt:ge
156f0 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 75 70 64 61 neral-call 'upda
15700 74 65 2d 75 6e 61 6d 65 2d 68 6f 73 74 20 72 75 te-uname-host ru
15710 6e 2d 69 64 20 75 6e 61 6d 65 20 68 6f 73 74 6e n-id uname hostn
15720 61 6d 65 20 74 65 73 74 2d 69 64 29 29 29 0a 20 ame test-id))).
15730 20 0a 3b 3b 20 54 68 69 73 20 6f 6e 65 20 69 73 .;; This one is
15740 20 66 6f 72 20 72 75 6e 6e 69 6e 67 20 77 69 74 for running wit
15750 68 20 6e 6f 20 64 62 20 61 63 63 65 73 73 20 28 h no db access (
15760 69 2e 65 2e 20 76 69 61 20 72 6d 74 3a 20 69 6e i.e. via rmt: in
15770 74 65 72 6e 61 6c 6c 79 29 0a 28 64 65 66 69 6e ternally).(defin
15780 65 20 28 74 65 73 74 73 3a 73 65 74 2d 66 75 6c e (tests:set-ful
15790 6c 2d 6d 65 74 61 2d 69 6e 66 6f 20 64 62 20 74 l-meta-info db t
157a0 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 6d 69 est-id run-id mi
157b0 6e 75 74 65 73 20 77 6f 72 6b 2d 61 72 65 61 20 nutes work-area
157c0 72 65 6d 74 72 69 65 73 29 0a 3b 3b 20 28 64 65 remtries).;; (de
157d0 66 69 6e 65 20 28 74 65 73 74 73 3a 73 65 74 2d fine (tests:set-
157e0 66 75 6c 6c 2d 6d 65 74 61 2d 69 6e 66 6f 20 74 full-meta-info t
157f0 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 6d 69 est-id run-id mi
15800 6e 75 74 65 73 20 77 6f 72 6b 2d 61 72 65 61 29 nutes work-area)
15810 0a 3b 3b 20 20 28 6c 65 74 20 28 28 72 65 6d 74 .;; (let ((remt
15820 72 69 65 73 20 31 30 29 29 0a 20 20 28 6c 65 74 ries 10)). (let
15830 2a 20 28 28 63 70 75 6c 6f 61 64 20 20 28 67 65 * ((cpuload (ge
15840 74 2d 63 70 75 2d 6c 6f 61 64 29 29 0a 09 20 28 t-cpu-load)).. (
15850 64 69 73 6b 66 72 65 65 20 28 67 65 74 2d 64 66 diskfree (get-df
15860 20 28 63 75 72 72 65 6e 74 2d 64 69 72 65 63 74 (current-direct
15870 6f 72 79 29 29 29 0a 09 20 28 75 6e 61 6d 65 20 ory))).. (uname
15880 20 20 20 28 67 65 74 2d 75 6e 61 6d 65 20 22 2d (get-uname "-
15890 73 72 76 70 69 6f 22 29 29 0a 09 20 28 68 6f 73 srvpio")).. (hos
158a0 74 6e 61 6d 65 20 28 67 65 74 2d 68 6f 73 74 2d tname (get-host-
158b0 6e 61 6d 65 29 29 29 0a 20 20 20 20 28 74 65 73 name))). (tes
158c0 74 73 3a 75 70 64 61 74 65 2d 63 65 6e 74 72 61 ts:update-centra
158d0 6c 2d 6d 65 74 61 2d 69 6e 66 6f 20 72 75 6e 2d l-meta-info run-
158e0 69 64 20 74 65 73 74 2d 69 64 20 63 70 75 6c 6f id test-id cpulo
158f0 61 64 20 64 69 73 6b 66 72 65 65 20 6d 69 6e 75 ad diskfree minu
15900 74 65 73 20 75 6e 61 6d 65 20 68 6f 73 74 6e 61 tes uname hostna
15910 6d 65 29 29 29 0a 20 20 20 20 0a 3b 3b 20 28 64 me))). .;; (d
15920 65 66 69 6e 65 20 28 74 65 73 74 73 3a 73 65 74 efine (tests:set
15930 2d 70 61 72 74 69 61 6c 2d 6d 65 74 61 2d 69 6e -partial-meta-in
15940 66 6f 20 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 fo test-id run-i
15950 64 20 6d 69 6e 75 74 65 73 20 77 6f 72 6b 2d 61 d minutes work-a
15960 72 65 61 29 0a 23 3b 28 64 65 66 69 6e 65 20 28 rea).#;(define (
15970 74 65 73 74 73 3a 73 65 74 2d 70 61 72 74 69 61 tests:set-partia
15980 6c 2d 6d 65 74 61 2d 69 6e 66 6f 20 74 65 73 74 l-meta-info test
15990 2d 69 64 20 72 75 6e 2d 69 64 20 6d 69 6e 75 74 -id run-id minut
159a0 65 73 20 77 6f 72 6b 2d 61 72 65 61 20 72 65 6d es work-area rem
159b0 74 72 69 65 73 29 0a 20 20 28 6c 65 74 2a 20 28 tries). (let* (
159c0 28 63 70 75 6c 6f 61 64 20 20 28 67 65 74 2d 63 (cpuload (get-c
159d0 70 75 2d 6c 6f 61 64 29 29 0a 09 20 28 64 69 73 pu-load)).. (dis
159e0 6b 66 72 65 65 20 28 67 65 74 2d 64 66 20 28 63 kfree (get-df (c
159f0 75 72 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 79 urrent-directory
15a00 29 29 29 0a 09 20 28 72 65 6d 74 72 69 65 73 20 ))).. (remtries
15a10 31 30 29 29 0a 20 20 20 20 28 68 61 6e 64 6c 65 10)). (handle
15a20 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 20 -exceptions.
15a30 20 65 78 6e 0a 20 20 20 20 20 28 69 66 20 28 3e exn. (if (>
15a40 20 72 65 6d 74 72 69 65 73 20 30 29 0a 09 20 28 remtries 0).. (
15a50 62 65 67 69 6e 0a 09 20 20 20 28 70 72 69 6e 74 begin.. (print
15a60 2d 63 61 6c 6c 2d 63 68 61 69 6e 20 28 63 75 72 -call-chain (cur
15a70 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 rent-error-port)
15a80 29 0a 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 ).. (debug:pri
15a90 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 nt-info 0 *defau
15aa0 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 lt-log-port* "WA
15ab0 52 4e 49 4e 47 3a 20 66 61 69 6c 65 64 20 74 6f RNING: failed to
15ac0 20 73 65 74 20 6d 65 74 61 20 69 6e 66 6f 2e 20 set meta info.
15ad0 57 69 6c 6c 20 74 72 79 20 22 20 72 65 6d 74 72 Will try " remtr
15ae0 69 65 73 20 22 20 6d 6f 72 65 20 74 69 6d 65 73 ies " more times
15af0 22 29 0a 09 20 20 20 28 73 65 74 21 20 72 65 6d ").. (set! rem
15b00 74 72 69 65 73 20 28 2d 20 72 65 6d 74 72 69 65 tries (- remtrie
15b10 73 20 31 29 29 0a 09 20 20 20 28 74 68 72 65 61 s 1)).. (threa
15b20 64 2d 73 6c 65 65 70 21 20 31 30 29 0a 09 20 20 d-sleep! 10)..
15b30 20 28 74 65 73 74 73 3a 73 65 74 2d 66 75 6c 6c (tests:set-full
15b40 2d 6d 65 74 61 2d 69 6e 66 6f 20 64 62 20 74 65 -meta-info db te
15b50 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 6d 69 6e st-id run-id min
15b60 75 74 65 73 20 77 6f 72 6b 2d 61 72 65 61 20 28 utes work-area (
15b70 2d 20 72 65 6d 74 72 69 65 73 20 31 29 29 29 0a - remtries 1))).
15b80 09 20 28 6c 65 74 20 28 28 65 72 72 2d 73 74 61 . (let ((err-sta
15b90 74 75 73 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d tus ((condition-
15ba0 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f property-accesso
15bb0 72 20 27 73 71 6c 69 74 65 33 20 27 73 74 61 74 r 'sqlite3 'stat
15bc0 75 73 20 23 66 29 20 65 78 6e 29 29 29 0a 09 20 us #f) exn)))..
15bd0 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 (debug:print-e
15be0 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d rror 0 *default-
15bf0 6c 6f 67 2d 70 6f 72 74 2a 20 22 74 72 69 65 64 log-port* "tried
15c00 20 66 6f 72 20 6f 76 65 72 20 61 20 6d 69 6e 75 for over a minu
15c10 74 65 20 74 6f 20 75 70 64 61 74 65 20 6d 65 74 te to update met
15c20 61 20 69 6e 66 6f 20 61 6e 64 20 66 61 69 6c 65 a info and faile
15c30 64 2e 20 47 69 76 69 6e 67 20 75 70 22 29 0a 09 d. Giving up")..
15c40 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
15c50 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
15c60 6f 72 74 2a 20 22 45 58 43 45 50 54 49 4f 4e 3a ort* "EXCEPTION:
15c70 20 64 61 74 61 62 61 73 65 20 70 72 6f 62 61 62 database probab
15c80 6c 79 20 6f 76 65 72 6c 6f 61 64 65 64 20 6f 72 ly overloaded or
15c90 20 75 6e 72 65 61 64 61 62 6c 65 2e 22 29 0a 09 unreadable.")..
15ca0 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
15cb0 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
15cc0 6f 72 74 2a 20 22 20 6d 65 73 73 61 67 65 3a 20 ort* " message:
15cd0 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 " ((condition-pr
15ce0 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 operty-accessor
15cf0 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 'exn 'message) e
15d00 78 6e 29 29 0a 09 20 20 20 28 64 65 62 75 67 3a xn)).. (debug:
15d10 70 72 69 6e 74 20 35 20 2a 64 65 66 61 75 6c 74 print 5 *default
15d20 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 65 78 6e 3d -log-port* "exn=
15d30 22 20 28 63 6f 6e 64 69 74 69 6f 6e 2d 3e 6c 69 " (condition->li
15d40 73 74 20 65 78 6e 29 29 0a 09 20 20 20 28 64 65 st exn)).. (de
15d50 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
15d60 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
15d70 20 73 74 61 74 75 73 3a 20 20 22 20 28 28 63 6f status: " ((co
15d80 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 ndition-property
15d90 2d 61 63 63 65 73 73 6f 72 20 27 73 71 6c 69 74 -accessor 'sqlit
15da0 65 33 20 27 73 74 61 74 75 73 29 20 65 78 6e 29 e3 'status) exn)
15db0 29 0a 09 20 20 20 28 70 72 69 6e 74 2d 63 61 6c ).. (print-cal
15dc0 6c 2d 63 68 61 69 6e 20 28 63 75 72 72 65 6e 74 l-chain (current
15dd0 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 29 29 0a -error-port)))).
15de0 20 20 20 20 20 28 74 65 73 74 73 3a 75 70 64 61 (tests:upda
15df0 74 65 2d 74 65 73 74 64 61 74 2d 6d 65 74 61 2d te-testdat-meta-
15e00 69 6e 66 6f 20 64 62 20 74 65 73 74 2d 69 64 20 info db test-id
15e10 77 6f 72 6b 2d 61 72 65 61 20 63 70 75 6c 6f 61 work-area cpuloa
15e20 64 20 64 69 73 6b 66 72 65 65 20 6d 69 6e 75 74 d diskfree minut
15e30 65 73 29 0a 20 20 29 29 29 0a 09 20 0a 3b 3b 3d es). ))).. .;;=
15e40 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15e50 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15e60 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15e70 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15e80 3d 3d 3d 3d 3d 0a 3b 3b 20 41 20 52 20 43 20 48 =====.;; A R C H
15e90 20 49 20 56 20 49 20 4e 20 47 0a 3b 3b 3d 3d 3d I V I N G.;;===
15ea0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15eb0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15ec0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15ed0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15ee0 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 74 65 ===..(define (te
15ef0 73 74 3a 61 72 63 68 69 76 65 20 64 62 20 74 65 st:archive db te
15f00 73 74 2d 69 64 29 0a 20 20 23 66 29 0a 0a 28 64 st-id). #f)..(d
15f10 65 66 69 6e 65 20 28 74 65 73 74 3a 61 72 63 68 efine (test:arch
15f20 69 76 65 2d 74 65 73 74 73 20 64 62 20 6b 65 79 ive-tests db key
15f30 6e 61 6d 65 73 20 74 61 72 67 65 74 29 0a 20 20 names target).
15f40 23 66 29 0a 0a #f)..