Artifact
03f9f60209d4eaf3eae30908e1cd2f66afe06eee:
0000: 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 32 30 30 ;; Copyright 200
0010: 36 2d 32 30 31 32 2c 20 4d 61 74 74 68 65 77 20 6-2012, Matthew
0020: 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 0a 3b 3b 20 Welland..;; .;;
0030: 20 54 68 69 73 20 70 72 6f 67 72 61 6d 20 69 73 This program is
0040: 20 6d 61 64 65 20 61 76 61 69 6c 61 62 6c 65 20 made available
0050: 75 6e 64 65 72 20 74 68 65 20 47 4e 55 20 47 50 under the GNU GP
0060: 4c 20 76 65 72 73 69 6f 6e 20 32 2e 30 20 6f 72 L version 2.0 or
0070: 0a 3b 3b 20 20 67 72 65 61 74 65 72 2e 20 53 65 .;; greater. Se
0080: 65 20 74 68 65 20 61 63 63 6f 6d 70 61 6e 79 69 e the accompanyi
0090: 6e 67 20 66 69 6c 65 20 43 4f 50 59 49 4e 47 20 ng file COPYING
00a0: 66 6f 72 20 64 65 74 61 69 6c 73 2e 0a 3b 3b 20 for details..;;
00b0: 0a 3b 3b 20 20 54 68 69 73 20 70 72 6f 67 72 61 .;; This progra
00c0: 6d 20 69 73 20 64 69 73 74 72 69 62 75 74 65 64 m is distributed
00d0: 20 57 49 54 48 4f 55 54 20 41 4e 59 20 57 41 52 WITHOUT ANY WAR
00e0: 52 41 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 65 RANTY; without e
00f0: 76 65 6e 20 74 68 65 0a 3b 3b 20 20 69 6d 70 6c ven the.;; impl
0100: 69 65 64 20 77 61 72 72 61 6e 74 79 20 6f 66 20 ied warranty of
0110: 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 20 MERCHANTABILITY
0120: 6f 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 41 or FITNESS FOR A
0130: 20 50 41 52 54 49 43 55 4c 41 52 0a 3b 3b 20 20 PARTICULAR.;;
0140: 50 55 52 50 4f 53 45 2e 0a 0a 3b 3b 20 20 73 74 PURPOSE...;; st
0150: 72 66 74 69 6d 65 28 27 25 6d 2f 25 64 2f 25 59 rftime('%m/%d/%Y
0160: 20 25 48 3a 25 4d 3a 25 53 27 2c 27 6e 6f 77 27 %H:%M:%S','now'
0170: 2c 27 6c 6f 63 61 6c 74 69 6d 65 27 29 0a 0a 28 ,'localtime')..(
0180: 72 65 71 75 69 72 65 2d 65 78 74 65 6e 73 69 6f require-extensio
0190: 6e 20 74 65 73 74 29 0a 28 72 65 71 75 69 72 65 n test).(require
01a0: 2d 65 78 74 65 6e 73 69 6f 6e 20 72 65 67 65 78 -extension regex
01b0: 29 0a 28 72 65 71 75 69 72 65 2d 65 78 74 65 6e ).(require-exten
01c0: 73 69 6f 6e 20 73 72 66 69 2d 31 38 29 0a 28 69 sion srfi-18).(i
01d0: 6d 70 6f 72 74 20 73 72 66 69 2d 31 38 29 0a 28 mport srfi-18).(
01e0: 72 65 71 75 69 72 65 2d 65 78 74 65 6e 73 69 6f require-extensio
01f0: 6e 20 7a 6d 71 29 0a 28 69 6d 70 6f 72 74 20 7a n zmq).(import z
0200: 6d 71 29 0a 0a 28 64 65 66 69 6e 65 20 74 65 73 mq)..(define tes
0210: 74 2d 77 6f 72 6b 2d 64 69 72 20 28 63 75 72 72 t-work-dir (curr
0220: 65 6e 74 2d 64 69 72 65 63 74 6f 72 79 29 29 0a ent-directory)).
0230: 0a 3b 3b 20 72 65 61 64 20 69 6e 20 61 6c 6c 20 .;; read in all
0240: 74 68 65 20 5f 72 65 63 6f 72 64 20 66 69 6c 65 the _record file
0250: 73 0a 28 6c 65 74 20 28 28 66 69 6c 65 73 20 28 s.(let ((files (
0260: 67 6c 6f 62 20 22 2a 5f 72 65 63 6f 72 64 73 2e glob "*_records.
0270: 73 63 6d 22 29 29 29 0a 20 20 28 66 6f 72 2d 65 scm"))). (for-e
0280: 61 63 68 0a 20 20 20 28 6c 61 6d 62 64 61 20 28 ach. (lambda (
0290: 66 69 6c 65 29 0a 20 20 20 20 20 28 70 72 69 6e file). (prin
02a0: 74 20 22 4c 6f 61 64 69 6e 67 20 22 20 66 69 6c t "Loading " fil
02b0: 65 29 0a 20 20 20 20 20 28 6c 6f 61 64 20 66 69 e). (load fi
02c0: 6c 65 29 29 0a 20 20 20 66 69 6c 65 73 29 29 0a le)). files)).
02d0: 0a 28 64 65 66 69 6e 65 20 2a 72 75 6e 72 65 6d .(define *runrem
02e0: 6f 74 65 2a 20 23 66 29 0a 0a 3b 3b 3d 3d 3d 3d ote* #f)..;;====
02f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0300: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0310: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0320: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0330: 3d 3d 0a 3b 3b 20 50 20 52 20 4f 20 43 20 45 20 ==.;; P R O C E
0340: 53 20 53 20 45 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d S S E S.;;======
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 3d 3d 3d 3d 3d ================
0390: 0a 0a 28 74 65 73 74 20 22 63 6d 64 2d 72 75 6e ..(test "cmd-run
03a0: 2d 77 69 74 68 2d 73 74 64 65 72 72 2d 3e 6c 69 -with-stderr->li
03b0: 73 74 22 20 27 28 22 4e 6f 20 73 75 63 68 20 66 st" '("No such f
03c0: 69 6c 65 20 6f 72 20 64 69 72 65 63 74 6f 72 79 ile or directory
03d0: 22 29 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 "). (let ((
03e0: 72 65 73 6c 73 74 20 28 63 6d 64 2d 72 75 6e 2d reslst (cmd-run-
03f0: 77 69 74 68 2d 73 74 64 65 72 72 2d 3e 6c 69 73 with-stderr->lis
0400: 74 20 22 6c 73 22 20 22 2f 74 6d 70 2f 69 68 61 t "ls" "/tmp/iha
0410: 64 62 65 74 74 65 72 6e 6f 74 65 78 69 73 74 22 dbetternotexist"
0420: 29 29 29 0a 09 28 73 74 72 69 6e 67 2d 73 65 61 )))..(string-sea
0430: 72 63 68 20 28 72 65 67 65 78 70 20 22 4e 6f 20 rch (regexp "No
0440: 73 75 63 68 20 66 69 6c 65 20 6f 72 20 64 69 72 such file or dir
0450: 65 63 74 6f 72 79 22 29 28 63 61 72 20 72 65 73 ectory")(car res
0460: 6c 73 74 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d lst))))..;;=====
0470: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0480: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0490: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04b0: 3d 0a 3b 3b 20 54 20 45 20 53 20 54 20 20 20 4d =.;; T E S T M
04c0: 20 41 20 54 20 43 20 48 20 49 20 4e 20 47 0a 3b A T C H I N G.;
04d0: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
04e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0500: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0510: 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 74 65 73 74 =======..;; test
0520: 73 3a 67 6c 6f 62 2d 6c 69 6b 65 2d 6d 61 74 63 s:glob-like-matc
0530: 68 0a 28 74 65 73 74 20 23 66 20 27 28 22 61 62 h.(test #f '("ab
0540: 63 22 29 20 28 74 65 73 74 73 3a 67 6c 6f 62 2d c") (tests:glob-
0550: 6c 69 6b 65 2d 6d 61 74 63 68 20 22 61 62 63 22 like-match "abc"
0560: 20 22 61 62 63 22 29 29 0a 28 66 6f 72 2d 65 61 "abc")).(for-ea
0570: 63 68 20 0a 20 28 6c 61 6d 62 64 61 20 28 70 61 ch . (lambda (pa
0580: 74 74 20 73 74 72 20 65 78 70 65 63 74 65 64 29 tt str expected)
0590: 0a 20 20 20 28 74 65 73 74 20 28 63 6f 6e 63 20 . (test (conc
05a0: 70 61 74 74 20 22 20 22 20 73 74 72 20 22 3d 3e patt " " str "=>
05b0: 22 20 65 78 70 65 63 74 65 64 29 20 65 78 70 65 " expected) expe
05c0: 63 74 65 64 20 28 74 65 73 74 73 3a 67 6c 6f 62 cted (tests:glob
05d0: 2d 6c 69 6b 65 2d 6d 61 74 63 68 20 70 61 74 74 -like-match patt
05e0: 20 73 74 72 29 29 29 0a 20 28 6c 69 73 74 20 22 str))). (list "
05f0: 61 62 63 22 20 20 20 20 22 7e 61 62 63 22 20 22 abc" "~abc" "
0600: 7e 61 62 63 22 20 22 61 2a 63 22 20 20 22 61 25 ~abc" "a*c" "a%
0610: 63 22 29 0a 20 28 6c 69 73 74 20 22 61 62 63 22 c"). (list "abc"
0620: 20 20 20 20 22 61 62 63 64 22 20 22 61 62 63 22 "abcd" "abc"
0630: 20 20 22 41 42 43 22 20 20 22 41 42 43 22 29 0a "ABC" "ABC").
0640: 20 28 6c 69 73 74 20 27 28 22 61 62 63 22 29 20 (list '("abc")
0650: 20 23 74 20 20 20 20 20 20 23 66 20 20 20 20 20 #t #f
0660: 23 66 20 27 28 22 41 42 43 22 29 29 0a 20 29 0a #f '("ABC")). ).
0670: 0a 3b 3b 20 74 65 73 74 73 3a 6d 61 74 63 68 0a .;; tests:match.
0680: 28 74 65 73 74 20 23 66 20 23 74 20 28 74 65 73 (test #f #t (tes
0690: 74 73 3a 6d 61 74 63 68 20 22 61 62 63 2f 64 65 ts:match "abc/de
06a0: 66 22 20 22 61 62 63 22 20 22 64 65 66 22 29 29 f" "abc" "def"))
06b0: 0a 28 66 6f 72 2d 65 61 63 68 20 0a 20 28 6c 61 .(for-each . (la
06c0: 6d 62 64 61 20 28 70 61 74 74 65 72 6e 73 20 74 mbda (patterns t
06d0: 65 73 74 6e 61 6d 65 20 69 74 65 6d 70 61 74 68 estname itempath
06e0: 20 65 78 70 65 63 74 65 64 29 0a 20 20 20 28 74 expected). (t
06f0: 65 73 74 20 28 63 6f 6e 63 20 70 61 74 74 65 72 est (conc patter
0700: 6e 73 20 22 20 22 20 74 65 73 74 6e 61 6d 65 20 ns " " testname
0710: 22 2f 22 20 69 74 65 6d 70 61 74 68 20 22 3d 3e "/" itempath "=>
0720: 22 20 65 78 70 65 63 74 65 64 29 0a 09 20 65 78 " expected).. ex
0730: 70 65 63 74 65 64 20 0a 09 20 28 74 65 73 74 73 pected .. (tests
0740: 3a 6d 61 74 63 68 20 70 61 74 74 65 72 6e 73 20 :match patterns
0750: 74 65 73 74 6e 61 6d 65 20 69 74 65 6d 70 61 74 testname itempat
0760: 68 29 29 29 0a 20 28 6c 69 73 74 20 22 61 62 63 h))). (list "abc
0770: 22 20 22 61 62 63 2f 25 22 20 22 61 62 25 2f 63 " "abc/%" "ab%/c
0780: 25 22 20 22 7e 61 62 63 2f 63 25 22 20 22 61 62 %" "~abc/c%" "ab
0790: 63 2f 7e 63 25 22 20 22 61 2c 62 2f 63 2c 25 2f c/~c%" "a,b/c,%/
07a0: 64 22 20 22 25 2f 2c 25 2f 61 22 20 22 25 2f 2c d" "%/,%/a" "%/,
07b0: 25 2f 61 22 20 22 25 2f 2c 25 2f 61 22 20 22 25 %/a" "%/,%/a" "%
07c0: 22 20 22 25 22 20 22 25 2f 22 20 22 25 2f 22 29 " "%" "%/" "%/")
07d0: 0a 20 28 6c 69 73 74 20 22 61 62 63 22 20 22 61 . (list "abc" "a
07e0: 62 63 22 20 20 20 22 61 62 63 64 22 20 20 20 22 bc" "abcd" "
07f0: 61 62 63 22 20 20 20 20 20 22 61 62 63 22 20 20 abc" "abc"
0800: 20 20 20 22 61 22 20 20 20 20 20 20 20 20 20 22 "a" "
0810: 61 62 63 22 20 20 20 20 20 22 64 65 66 22 20 20 abc" "def"
0820: 20 20 22 67 68 69 22 20 20 20 22 61 22 20 22 61 "ghi" "a" "a
0830: 22 20 20 22 61 22 20 20 22 61 22 29 0a 20 28 6c " "a" "a"). (l
0840: 69 73 74 20 20 20 22 22 20 20 22 22 20 20 20 20 ist "" ""
0850: 20 20 22 63 64 65 22 20 20 20 20 22 63 64 65 22 "cde" "cde"
0860: 20 20 20 20 20 22 63 64 65 22 20 20 20 20 20 22 "cde" "
0870: 22 20 20 20 20 20 20 20 20 20 20 20 20 22 22 20 " ""
0880: 20 20 20 20 20 22 61 22 20 20 20 20 20 20 20 22 "a" "
0890: 62 22 20 20 20 20 22 22 20 20 22 62 22 20 20 22 b" "" "b" "
08a0: 22 20 20 20 22 62 22 29 0a 20 28 6c 69 73 74 20 " "b"). (list
08b0: 20 20 23 74 20 20 20 20 23 74 20 20 20 20 20 20 #t #t
08c0: 20 23 74 20 20 20 20 23 66 20 20 20 20 20 20 20 #t #f
08d0: 20 20 20 20 23 66 20 20 20 20 20 20 23 74 20 20 #f #t
08e0: 20 20 20 20 20 20 20 20 20 23 74 20 20 20 20 20 #t
08f0: 20 20 23 74 20 20 20 20 20 20 20 23 66 20 20 20 #t #f
0900: 20 20 23 74 20 20 23 74 20 20 20 23 74 20 20 20 #t #t #t
0910: 20 23 66 29 29 0a 0a 3b 3b 20 64 62 3a 70 61 74 #f))..;; db:pat
0920: 74 2d 3e 6c 69 6b 65 0a 28 74 65 73 74 20 23 66 t->like.(test #f
0930: 20 22 74 65 73 74 6e 61 6d 65 20 4c 49 4b 45 20 "testname LIKE
0940: 27 74 25 27 22 20 28 64 62 3a 70 61 74 74 2d 3e 't%'" (db:patt->
0950: 6c 69 6b 65 20 22 74 65 73 74 6e 61 6d 65 22 20 like "testname"
0960: 22 74 25 22 20 63 6f 6d 70 61 72 61 74 6f 72 3a "t%" comparator:
0970: 20 22 20 41 4e 44 20 22 29 29 0a 28 74 65 73 74 " AND ")).(test
0980: 20 23 66 20 22 74 65 73 74 6e 61 6d 65 20 4c 49 #f "testname LI
0990: 4b 45 20 27 74 25 27 20 41 4e 44 20 74 65 73 74 KE 't%' AND test
09a0: 6e 61 6d 65 20 4c 49 4b 45 20 27 25 74 27 22 20 name LIKE '%t'"
09b0: 28 64 62 3a 70 61 74 74 2d 3e 6c 69 6b 65 20 22 (db:patt->like "
09c0: 74 65 73 74 6e 61 6d 65 22 20 22 74 25 2c 25 74 testname" "t%,%t
09d0: 22 20 63 6f 6d 70 61 72 61 74 6f 72 3a 20 22 20 " comparator: "
09e0: 41 4e 44 20 22 29 29 0a 28 74 65 73 74 20 23 66 AND ")).(test #f
09f0: 20 22 69 74 65 6d 5f 70 61 74 68 20 47 4c 4f 42 "item_path GLOB
0a00: 20 27 27 22 20 28 64 62 3a 70 61 74 74 2d 3e 6c ''" (db:patt->l
0a10: 69 6b 65 20 22 69 74 65 6d 5f 70 61 74 68 22 20 ike "item_path"
0a20: 22 22 29 29 0a 0a 3b 3b 20 74 65 73 74 3a 6d 61 ""))..;; test:ma
0a30: 74 63 68 2d 3e 73 71 6c 71 72 79 0a 28 74 65 73 tch->sqlqry.(tes
0a40: 74 20 23 66 20 22 28 74 65 73 74 6e 61 6d 65 20 t #f "(testname
0a50: 47 4c 4f 42 20 27 61 27 20 41 4e 44 20 69 74 65 GLOB 'a' AND ite
0a60: 6d 5f 70 61 74 68 20 47 4c 4f 42 20 27 62 27 29 m_path GLOB 'b')
0a70: 20 4f 52 20 28 74 65 73 74 6e 61 6d 65 20 4c 49 OR (testname LI
0a80: 4b 45 20 27 61 25 27 20 41 4e 44 20 69 74 65 6d KE 'a%' AND item
0a90: 5f 70 61 74 68 20 4c 49 4b 45 20 27 25 27 29 20 _path LIKE '%')
0aa0: 4f 52 20 28 74 65 73 74 6e 61 6d 65 20 47 4c 4f OR (testname GLO
0ab0: 42 20 27 27 20 41 4e 44 20 69 74 65 6d 5f 70 61 B '' AND item_pa
0ac0: 74 68 20 4c 49 4b 45 20 27 62 25 27 29 22 0a 20 th LIKE 'b%')".
0ad0: 20 20 20 20 20 28 74 65 73 74 73 3a 6d 61 74 63 (tests:matc
0ae0: 68 2d 3e 73 71 6c 71 72 79 20 22 61 2f 62 2c 61 h->sqlqry "a/b,a
0af0: 25 2c 2f 62 25 22 29 29 0a 28 74 65 73 74 20 23 %,/b%")).(test #
0b00: 66 20 22 28 74 65 73 74 6e 61 6d 65 20 47 4c 4f f "(testname GLO
0b10: 42 20 27 61 27 20 41 4e 44 20 69 74 65 6d 5f 70 B 'a' AND item_p
0b20: 61 74 68 20 47 4c 4f 42 20 27 62 27 29 20 4f 52 ath GLOB 'b') OR
0b30: 20 28 74 65 73 74 6e 61 6d 65 20 4c 49 4b 45 20 (testname LIKE
0b40: 27 61 25 27 20 41 4e 44 20 69 74 65 6d 5f 70 61 'a%' AND item_pa
0b50: 74 68 20 4c 49 4b 45 20 27 25 27 29 20 4f 52 20 th LIKE '%') OR
0b60: 28 74 65 73 74 6e 61 6d 65 20 4c 49 4b 45 20 27 (testname LIKE '
0b70: 25 27 20 41 4e 44 20 69 74 65 6d 5f 70 61 74 68 %' AND item_path
0b80: 20 4c 49 4b 45 20 27 62 25 27 29 22 0a 20 20 20 LIKE 'b%')".
0b90: 20 20 20 28 74 65 73 74 73 3a 6d 61 74 63 68 2d (tests:match-
0ba0: 3e 73 71 6c 71 72 79 20 22 61 2f 62 2c 61 25 2c >sqlqry "a/b,a%,
0bb0: 25 2f 62 25 22 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d %/b%"))..;;=====
0bc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0bd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0be0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0bf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0c00: 3d 0a 3b 3b 20 53 20 45 20 52 20 56 20 45 20 52 =.;; S E R V E R
0c10: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
0c20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0c30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0c40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0c50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 74 65 73 74 =========..(test
0c60: 20 22 73 65 74 75 70 20 66 6f 72 20 72 75 6e 22 "setup for run"
0c70: 20 23 74 20 28 62 65 67 69 6e 20 28 73 65 74 75 #t (begin (setu
0c80: 70 2d 66 6f 72 2d 72 75 6e 29 0a 09 09 09 09 28 p-for-run).....(
0c90: 73 74 72 69 6e 67 3f 20 28 67 65 74 65 6e 76 20 string? (getenv
0ca0: 22 4d 54 5f 52 55 4e 5f 41 52 45 41 5f 48 4f 4d "MT_RUN_AREA_HOM
0cb0: 45 22 29 29 29 29 0a 0a 28 74 65 73 74 20 22 73 E"))))..(test "s
0cc0: 65 72 76 65 72 2d 72 65 67 69 73 74 65 72 2c 20 erver-register,
0cd0: 67 65 74 2d 62 65 73 74 2d 73 65 72 76 65 72 22 get-best-server"
0ce0: 20 23 74 20 28 6c 65 74 20 28 28 72 65 73 20 23 #t (let ((res #
0cf0: 66 29 29 0a 09 09 09 09 09 20 20 20 20 20 20 28 f))...... (
0d00: 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 74 open-run-close t
0d10: 61 73 6b 73 3a 73 65 72 76 65 72 2d 72 65 67 69 asks:server-regi
0d20: 73 74 65 72 20 74 61 73 6b 73 3a 6f 70 65 6e 2d ster tasks:open-
0d30: 64 62 20 31 20 22 62 6f 62 22 20 31 32 33 34 20 db 1 "bob" 1234
0d40: 31 30 30 20 27 6c 69 76 65 20 27 68 74 74 70 29 100 'live 'http)
0d50: 0a 09 09 09 09 09 20 20 20 20 20 20 28 73 65 74 ...... (set
0d60: 21 20 72 65 73 20 28 6f 70 65 6e 2d 72 75 6e 2d ! res (open-run-
0d70: 63 6c 6f 73 65 20 74 61 73 6b 73 3a 67 65 74 2d close tasks:get-
0d80: 62 65 73 74 2d 73 65 72 76 65 72 20 74 61 73 6b best-server task
0d90: 73 3a 6f 70 65 6e 2d 64 62 29 29 0a 09 09 09 09 s:open-db)).....
0da0: 09 20 20 20 20 20 20 28 6e 75 6d 62 65 72 3f 20 . (number?
0db0: 28 76 65 63 74 6f 72 2d 72 65 66 20 72 65 73 20 (vector-ref res
0dc0: 33 29 29 29 29 0a 0a 28 74 65 73 74 20 22 64 65 3))))..(test "de
0dd0: 2d 72 65 67 69 73 74 65 72 20 73 65 72 76 65 72 -register server
0de0: 22 20 23 66 20 28 6c 65 74 20 28 28 72 65 73 20 " #f (let ((res
0df0: 23 66 29 29 0a 09 09 09 09 28 6f 70 65 6e 2d 72 #f)).....(open-r
0e00: 75 6e 2d 63 6c 6f 73 65 20 74 61 73 6b 73 3a 73 un-close tasks:s
0e10: 65 72 76 65 72 2d 64 65 72 65 67 69 73 74 65 72 erver-deregister
0e20: 20 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 20 22 tasks:open-db "
0e30: 62 6f 62 22 20 70 6f 72 74 3a 20 31 32 33 34 29 bob" port: 1234)
0e40: 0a 09 09 09 09 28 6f 70 65 6e 2d 72 75 6e 2d 63 .....(open-run-c
0e50: 6c 6f 73 65 20 74 61 73 6b 73 3a 67 65 74 2d 62 lose tasks:get-b
0e60: 65 73 74 2d 73 65 72 76 65 72 20 74 61 73 6b 73 est-server tasks
0e70: 3a 6f 70 65 6e 2d 64 62 29 29 29 0a 0a 28 64 65 :open-db)))..(de
0e80: 66 69 6e 65 20 73 65 72 76 65 72 2d 70 69 64 20 fine server-pid
0e90: 23 66 29 0a 28 74 65 73 74 20 22 6c 61 75 6e 63 #f).(test "launc
0ea0: 68 20 73 65 72 76 65 72 22 20 23 74 20 28 6c 65 h server" #t (le
0eb0: 74 20 28 28 70 69 64 20 28 70 72 6f 63 65 73 73 t ((pid (process
0ec0: 2d 66 6f 72 6b 20 28 6c 61 6d 62 64 61 20 28 29 -fork (lambda ()
0ed0: 0a 09 09 09 09 09 09 20 20 20 20 3b 3b 20 28 64 ....... ;; (d
0ee0: 61 65 6d 6f 6e 3a 69 7a 65 29 0a 09 09 09 09 09 aemon:ize)......
0ef0: 09 20 20 20 20 28 73 65 72 76 65 72 3a 6c 61 75 . (server:lau
0f00: 6e 63 68 20 27 68 74 74 70 29 29 29 29 29 0a 09 nch 'http)))))..
0f10: 09 09 20 20 20 28 73 65 74 21 20 73 65 72 76 65 .. (set! serve
0f20: 72 2d 70 69 64 20 70 69 64 29 0a 09 09 09 20 20 r-pid pid)....
0f30: 20 28 6e 75 6d 62 65 72 3f 20 70 69 64 29 29 29 (number? pid)))
0f40: 0a 0a 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 ..(thread-sleep!
0f50: 20 33 29 20 3b 3b 20 6e 65 65 64 20 74 6f 20 77 3) ;; need to w
0f60: 61 69 74 20 66 6f 72 20 73 65 72 76 65 72 20 74 ait for server t
0f70: 6f 20 73 74 61 72 74 2e 20 59 65 73 2c 20 61 20 o start. Yes, a
0f80: 62 65 74 74 65 72 20 77 61 79 20 69 73 20 6e 65 better way is ne
0f90: 65 64 65 64 2e 0a 28 74 65 73 74 20 22 67 65 74 eded..(test "get
0fa0: 2d 62 65 73 74 2d 73 65 72 76 65 72 22 20 23 74 -best-server" #t
0fb0: 20 28 6c 65 74 20 28 28 64 61 74 20 28 6f 70 65 (let ((dat (ope
0fc0: 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 74 61 73 6b n-run-close task
0fd0: 73 3a 67 65 74 2d 62 65 73 74 2d 73 65 72 76 65 s:get-best-serve
0fe0: 72 20 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 29 r tasks:open-db)
0ff0: 29 29 0a 09 09 09 20 20 20 20 20 28 73 65 74 21 )).... (set!
1000: 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 28 6c 69 *runremote* (li
1010: 73 74 20 28 76 65 63 74 6f 72 2d 72 65 66 20 64 st (vector-ref d
1020: 61 74 20 31 29 28 76 65 63 74 6f 72 2d 72 65 66 at 1)(vector-ref
1030: 20 64 61 74 20 32 29 29 29 20 3b 3b 20 68 6f 73 dat 2))) ;; hos
1040: 74 20 69 70 20 70 75 6c 6c 70 6f 72 74 20 70 75 t ip pullport pu
1050: 62 70 6f 72 74 0a 09 09 09 20 20 20 20 20 28 61 bport.... (a
1060: 6e 64 20 28 73 74 72 69 6e 67 3f 20 28 63 61 72 nd (string? (car
1070: 20 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 29 29 0a *runremote*)).
1080: 09 09 09 20 20 20 20 20 09 20 20 28 6e 75 6d 62 ... . (numb
1090: 65 72 3f 20 28 63 61 64 72 20 2a 72 75 6e 72 65 er? (cadr *runre
10a0: 6d 6f 74 65 2a 29 29 29 29 29 0a 0a 28 74 65 73 mote*)))))..(tes
10b0: 74 20 23 66 20 23 74 20 28 63 61 72 20 28 63 64 t #f #t (car (cd
10c0: 62 3a 6c 6f 67 69 6e 20 2a 72 75 6e 72 65 6d 6f b:login *runremo
10d0: 74 65 2a 20 2a 74 6f 70 70 61 74 68 2a 20 2a 6d te* *toppath* *m
10e0: 79 2d 63 6c 69 65 6e 74 2d 73 69 67 6e 61 74 75 y-client-signatu
10f0: 72 65 2a 29 29 29 0a 28 74 65 73 74 20 23 66 20 re*))).(test #f
1100: 23 74 20 28 6c 65 74 20 28 28 72 65 73 20 28 63 #t (let ((res (c
1110: 6c 69 65 6e 74 3a 6c 6f 67 69 6e 20 2a 72 75 6e lient:login *run
1120: 72 65 6d 6f 74 65 2a 29 29 29 0a 09 20 20 20 20 remote*)))..
1130: 20 20 28 63 61 72 20 72 65 73 29 29 29 0a 0a 0a (car res)))...
1140: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
1150: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1160: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1170: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1180: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 43 20 4f 20 ========.;; C O
1190: 4e 20 46 20 49 20 47 20 20 20 46 20 49 20 4c 20 N F I G F I L
11a0: 45 20 53 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d E S .;;=========
11b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 =============..(
11f0: 64 65 66 69 6e 65 20 63 6f 6e 66 66 69 6c 65 20 define conffile
1200: 23 66 29 0a 28 74 65 73 74 20 22 52 65 61 64 20 #f).(test "Read
1210: 61 20 63 6f 6e 66 69 67 22 20 23 74 20 28 68 61 a config" #t (ha
1220: 73 68 2d 74 61 62 6c 65 3f 20 28 72 65 61 64 2d sh-table? (read-
1230: 63 6f 6e 66 69 67 20 22 74 65 73 74 2e 63 6f 6e config "test.con
1240: 66 69 67 22 20 23 66 20 23 66 29 29 29 0a 28 74 fig" #f #f))).(t
1250: 65 73 74 20 22 52 65 61 64 20 61 20 63 6f 6e 66 est "Read a conf
1260: 69 67 20 74 68 61 74 20 64 6f 65 73 6e 27 74 20 ig that doesn't
1270: 65 78 69 73 74 22 20 23 74 20 28 68 61 73 68 2d exist" #t (hash-
1280: 74 61 62 6c 65 3f 20 28 72 65 61 64 2d 63 6f 6e table? (read-con
1290: 66 69 67 20 22 6e 61 64 61 2e 63 6f 6e 66 69 67 fig "nada.config
12a0: 22 20 23 66 20 23 66 29 29 29 0a 0a 28 73 65 74 " #f #f)))..(set
12b0: 21 20 63 6f 6e 66 66 69 6c 65 20 28 72 65 61 64 ! conffile (read
12c0: 2d 63 6f 6e 66 69 67 20 22 74 65 73 74 2e 63 6f -config "test.co
12d0: 6e 66 69 67 22 20 23 66 20 23 66 29 29 0a 28 74 nfig" #f #f)).(t
12e0: 65 73 74 20 22 47 65 74 20 61 76 61 69 6c 61 62 est "Get availab
12f0: 6c 65 20 64 69 73 6b 73 70 61 63 65 22 20 23 74 le diskspace" #t
1300: 20 28 6e 75 6d 62 65 72 3f 20 28 67 65 74 2d 64 (number? (get-d
1310: 66 20 22 2e 2f 22 29 29 29 0a 28 74 65 73 74 20 f "./"))).(test
1320: 22 47 65 74 20 62 65 73 74 20 64 69 72 22 20 23 "Get best dir" #
1330: 74 20 28 6c 65 74 20 28 28 62 65 73 74 64 69 72 t (let ((bestdir
1340: 20 28 67 65 74 2d 62 65 73 74 2d 64 69 73 6b 20 (get-best-disk
1350: 63 6f 6e 66 66 69 6c 65 29 29 29 0a 09 09 09 20 conffile)))....
1360: 20 20 20 20 20 28 6f 72 20 28 65 71 75 61 6c 3f (or (equal?
1370: 20 22 2e 2f 22 20 20 20 62 65 73 74 64 69 72 29 "./" bestdir)
1380: 0a 09 09 09 09 20 20 28 65 71 75 61 6c 3f 20 22 ..... (equal? "
1390: 2f 74 6d 70 22 20 62 65 73 74 64 69 72 29 29 29 /tmp" bestdir)))
13a0: 29 0a 28 74 65 73 74 20 22 4d 75 6c 74 69 6c 69 ).(test "Multili
13b0: 6e 65 20 76 61 72 69 61 62 6c 65 22 20 34 20 28 ne variable" 4 (
13c0: 6c 65 6e 67 74 68 20 28 73 74 72 69 6e 67 2d 73 length (string-s
13d0: 70 6c 69 74 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f plit (config-loo
13e0: 6b 75 70 20 63 6f 6e 66 66 69 6c 65 20 22 6d 65 kup conffile "me
13f0: 74 61 64 61 74 61 22 20 22 64 65 73 63 72 69 70 tadata" "descrip
1400: 74 69 6f 6e 22 29 20 22 5c 6e 22 29 29 29 0a 0a tion") "\n")))..
1410: 3b 3b 20 64 62 0a 28 64 65 66 69 6e 65 20 72 6f ;; db.(define ro
1420: 77 20 20 20 20 28 76 65 63 74 6f 72 20 22 61 22 w (vector "a"
1430: 20 22 62 22 20 22 63 22 20 22 62 6c 61 68 22 29 "b" "c" "blah")
1440: 29 0a 28 64 65 66 69 6e 65 20 68 65 61 64 65 72 ).(define header
1450: 20 28 6c 69 73 74 20 22 63 6f 6c 31 22 20 22 63 (list "col1" "c
1460: 6f 6c 32 22 20 22 63 6f 6c 33 22 20 22 63 6f 6c ol2" "col3" "col
1470: 34 22 29 29 0a 28 74 65 73 74 20 22 47 65 74 20 4")).(test "Get
1480: 72 6f 77 20 62 79 20 68 65 61 64 65 72 22 20 22 row by header" "
1490: 62 6c 61 68 22 20 28 64 62 3a 67 65 74 2d 76 61 blah" (db:get-va
14a0: 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 6f lue-by-header ro
14b0: 77 20 68 65 61 64 65 72 20 22 63 6f 6c 34 22 29 w header "col4")
14c0: 29 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 20 2a 74 )..;; (define *t
14d0: 6f 70 70 61 74 68 2a 20 22 74 65 73 74 73 22 29 oppath* "tests")
14e0: 0a 28 64 65 66 69 6e 65 20 2a 64 62 2a 20 23 66 .(define *db* #f
14f0: 29 0a 28 74 65 73 74 20 22 6f 70 65 6e 2d 64 62 ).(test "open-db
1500: 22 20 23 74 20 28 62 65 67 69 6e 0a 09 09 20 20 " #t (begin...
1510: 20 20 20 28 73 65 74 21 20 2a 64 62 2a 20 28 6f (set! *db* (o
1520: 70 65 6e 2d 64 62 29 29 0a 09 09 20 20 20 20 20 pen-db))...
1530: 28 69 66 20 2a 64 62 2a 20 23 74 20 23 66 29 29 (if *db* #t #f))
1540: 29 0a 0a 3b 3b 20 71 75 69 74 20 77 61 73 74 69 )..;; quit wasti
1550: 6e 67 20 74 69 6d 65 2c 20 49 27 6d 20 63 68 61 ng time, I'm cha
1560: 6e 67 69 6e 67 20 2a 64 62 2a 20 74 6f 20 64 62 nging *db* to db
1570: 0a 28 64 65 66 69 6e 65 20 64 62 20 2a 64 62 2a .(define db *db*
1580: 29 0a 0a 28 74 65 73 74 20 22 67 65 74 20 63 70 )..(test "get cp
1590: 75 20 6c 6f 61 64 22 20 23 74 20 28 6e 75 6d 62 u load" #t (numb
15a0: 65 72 3f 20 28 67 65 74 2d 63 70 75 2d 6c 6f 61 er? (get-cpu-loa
15b0: 64 29 29 29 0a 28 74 65 73 74 20 22 67 65 74 20 d))).(test "get
15c0: 75 6e 61 6d 65 22 20 20 20 20 23 74 20 28 73 74 uname" #t (st
15d0: 72 69 6e 67 3f 20 28 67 65 74 2d 75 6e 61 6d 65 ring? (get-uname
15e0: 29 29 29 0a 0a 28 74 65 73 74 20 22 67 65 74 20 )))..(test "get
15f0: 76 61 6c 69 64 76 61 6c 75 65 73 20 61 73 20 6c validvalues as l
1600: 69 73 74 22 20 28 6c 69 73 74 20 22 73 74 61 72 ist" (list "star
1610: 74 22 20 22 65 6e 64 22 20 22 63 6f 6d 70 6c 65 t" "end" "comple
1620: 74 65 64 22 29 0a 20 20 20 20 20 20 28 73 74 72 ted"). (str
1630: 69 6e 67 2d 73 70 6c 69 74 20 28 63 6f 6e 66 69 ing-split (confi
1640: 67 2d 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 g-lookup *config
1650: 64 61 74 2a 20 22 76 61 6c 69 64 76 61 6c 75 65 dat* "validvalue
1660: 73 22 20 22 73 74 61 74 65 22 29 29 29 0a 0a 28 s" "state")))..(
1670: 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 for-each (lambda
1680: 20 28 69 74 65 6d 29 0a 09 20 20 20 20 28 74 65 (item).. (te
1690: 73 74 20 28 63 6f 6e 63 20 22 67 65 74 20 76 61 st (conc "get va
16a0: 6c 69 64 20 69 74 65 6d 73 20 28 22 20 69 74 65 lid items (" ite
16b0: 6d 20 22 29 22 29 0a 09 09 20 20 69 74 65 6d 20 m ")")... item
16c0: 28 69 74 65 6d 73 3a 63 68 65 63 6b 2d 76 61 6c (items:check-val
16d0: 69 64 2d 69 74 65 6d 73 20 22 73 74 61 74 65 22 id-items "state"
16e0: 20 69 74 65 6d 29 29 29 0a 09 20 20 28 6c 69 73 item))).. (lis
16f0: 74 20 22 73 74 61 72 74 22 20 22 65 6e 64 22 20 t "start" "end"
1700: 22 63 6f 6d 70 6c 65 74 65 64 22 29 29 0a 0a 28 "completed"))..(
1710: 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 for-each (lambda
1720: 20 28 69 74 65 6d 29 0a 09 20 20 20 20 28 74 65 (item).. (te
1730: 73 74 20 28 63 6f 6e 63 20 22 67 65 74 20 76 61 st (conc "get va
1740: 6c 69 64 20 69 74 65 6d 73 20 28 22 20 69 74 65 lid items (" ite
1750: 6d 20 22 29 22 29 0a 09 09 20 20 69 74 65 6d 20 m ")")... item
1760: 28 69 74 65 6d 73 3a 63 68 65 63 6b 2d 76 61 6c (items:check-val
1770: 69 64 2d 69 74 65 6d 73 20 22 73 74 61 74 75 73 id-items "status
1780: 22 20 69 74 65 6d 29 29 29 0a 09 20 20 28 6c 69 " item))).. (li
1790: 73 74 20 22 70 61 73 73 22 20 22 66 61 69 6c 22 st "pass" "fail"
17a0: 20 22 6e 2f 61 22 29 29 0a 0a 28 74 65 73 74 20 "n/a"))..(test
17b0: 23 66 20 23 66 20 28 69 74 65 6d 73 3a 63 68 65 #f #f (items:che
17c0: 63 6b 2d 76 61 6c 69 64 2d 69 74 65 6d 73 20 22 ck-valid-items "
17d0: 73 74 61 74 65 22 20 22 62 6c 61 68 66 6f 6f 6c state" "blahfool
17e0: 22 29 29 0a 0a 28 74 65 73 74 20 22 77 72 69 74 "))..(test "writ
17f0: 65 20 65 6e 76 20 66 69 6c 65 73 22 20 22 6e 61 e env files" "na
1800: 64 61 2e 63 73 68 22 20 28 62 65 67 69 6e 0a 20 da.csh" (begin.
1810: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1820: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1830: 20 20 20 20 20 28 73 61 76 65 2d 65 6e 76 69 72 (save-envir
1840: 6f 6e 6d 65 6e 74 2d 61 73 2d 66 69 6c 65 73 20 onment-as-files
1850: 22 6e 61 64 61 22 29 0a 20 20 20 20 20 20 20 20 "nada").
1860: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1870: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 61 (a
1880: 6e 64 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f nd (file-exists?
1890: 20 22 6e 61 64 61 2e 73 68 22 29 0a 20 20 20 20 "nada.sh").
18a0: 09 09 09 20 20 20 20 20 20 20 20 20 20 20 20 20 ...
18b0: 20 20 20 20 28 66 69 6c 65 2d 65 78 69 73 74 73 (file-exists
18c0: 3f 20 22 6e 61 64 61 2e 63 73 68 22 29 29 29 29 ? "nada.csh"))))
18d0: 0a 0a 28 74 65 73 74 20 23 66 20 23 74 20 28 63 ..(test #f #t (c
18e0: 64 62 3a 63 6c 69 65 6e 74 2d 63 61 6c 6c 20 2a db:client-call *
18f0: 72 75 6e 72 65 6d 6f 74 65 2a 20 27 69 6d 6d 65 runremote* 'imme
1900: 64 69 61 74 65 20 23 74 20 31 20 28 6c 61 6d 62 diate #t 1 (lamb
1910: 64 61 20 28 29 28 64 69 73 70 6c 61 79 20 22 47 da ()(display "G
1920: 6f 74 20 68 65 72 65 20 65 68 21 3f 22 29 20 23 ot here eh!?") #
1930: 74 29 29 29 0a 0a 3b 3b 20 28 73 65 74 21 20 2a t)))..;; (set! *
1940: 76 65 72 62 6f 73 69 74 79 2a 20 32 30 29 0a 28 verbosity* 20).(
1950: 74 65 73 74 20 23 66 20 2a 76 65 72 62 6f 73 69 test #f *verbosi
1960: 74 79 2a 20 28 63 61 64 72 20 28 63 64 62 3a 73 ty* (cadr (cdb:s
1970: 65 74 2d 76 65 72 62 6f 73 69 74 79 20 2a 72 75 et-verbosity *ru
1980: 6e 72 65 6d 6f 74 65 2a 20 2a 76 65 72 62 6f 73 nremote* *verbos
1990: 69 74 79 2a 29 29 29 0a 28 74 65 73 74 20 23 66 ity*))).(test #f
19a0: 20 23 66 20 28 63 64 62 3a 72 6f 6c 6c 2d 75 70 #f (cdb:roll-up
19b0: 2d 70 61 73 73 2d 66 61 69 6c 2d 63 6f 75 6e 74 -pass-fail-count
19c0: 73 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 31 20 s *runremote* 1
19d0: 22 74 65 73 74 31 22 20 22 22 20 22 50 41 53 53 "test1" "" "PASS
19e0: 22 29 29 0a 3b 3b 20 28 73 65 74 21 20 2a 76 65 ")).;; (set! *ve
19f0: 72 62 6f 73 69 74 79 2a 20 31 29 0a 3b 3b 20 28 rbosity* 1).;; (
1a00: 63 64 62 3a 73 65 74 2d 76 65 72 62 6f 73 69 74 cdb:set-verbosit
1a10: 79 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 2a 76 y *runremote* *v
1a20: 65 72 62 6f 73 69 74 79 2a 29 0a 0a 28 74 65 73 erbosity*)..(tes
1a30: 74 20 22 67 65 74 20 61 6c 6c 20 6c 65 67 61 6c t "get all legal
1a40: 20 74 65 73 74 73 22 20 28 6c 69 73 74 20 22 74 tests" (list "t
1a50: 65 73 74 31 22 20 22 74 65 73 74 32 22 29 20 28 est1" "test2") (
1a60: 73 6f 72 74 20 28 67 65 74 2d 61 6c 6c 2d 6c 65 sort (get-all-le
1a70: 67 61 6c 2d 74 65 73 74 73 29 20 73 74 72 69 6e gal-tests) strin
1a80: 67 3c 3d 3f 29 29 0a 0a 0a 28 74 65 73 74 20 22 g<=?))...(test "
1a90: 67 65 74 2d 6b 65 79 73 22 20 22 53 59 53 54 45 get-keys" "SYSTE
1aa0: 4d 22 20 28 63 61 72 20 28 64 62 3a 67 65 74 2d M" (car (db:get-
1ab0: 6b 65 79 73 20 2a 64 62 2a 29 29 29 0a 0a 28 64 keys *db*)))..(d
1ac0: 65 66 69 6e 65 20 72 65 6d 61 72 67 73 20 28 61 efine remargs (a
1ad0: 72 67 73 3a 67 65 74 2d 61 72 67 73 0a 09 09 20 rgs:get-args...
1ae0: 27 28 22 62 61 72 22 20 22 66 6f 6f 22 20 22 3a '("bar" "foo" ":
1af0: 72 75 6e 6e 61 6d 65 22 20 22 62 6f 62 22 20 22 runname" "bob" "
1b00: 3a 53 59 53 54 45 4d 22 20 22 75 62 75 6e 74 75 :SYSTEM" "ubuntu
1b10: 22 20 22 3a 52 45 4c 45 41 53 45 22 20 22 76 31 " ":RELEASE" "v1
1b20: 2e 32 22 20 22 3a 64 61 74 61 70 61 74 68 22 20 .2" ":datapath"
1b30: 22 62 6c 61 68 2f 66 6f 6f 22 20 22 6e 61 64 61 "blah/foo" "nada
1b40: 22 29 0a 09 09 20 28 6c 69 73 74 20 22 3a 72 75 ")... (list ":ru
1b50: 6e 6e 61 6d 65 22 20 22 3a 73 74 61 74 65 22 20 nname" ":state"
1b60: 22 3a 73 74 61 74 75 73 22 29 0a 09 09 20 28 6c ":status")... (l
1b70: 69 73 74 20 22 2d 68 22 29 0a 09 09 20 61 72 67 ist "-h")... arg
1b80: 73 3a 61 72 67 2d 68 61 73 68 0a 09 09 20 30 29 s:arg-hash... 0)
1b90: 29 0a 0a 28 74 65 73 74 20 22 72 65 67 69 73 74 )..(test "regist
1ba0: 65 72 2d 72 75 6e 22 20 23 74 20 28 6e 75 6d 62 er-run" #t (numb
1bb0: 65 72 3f 0a 09 09 09 20 28 64 62 3a 72 65 67 69 er?.... (db:regi
1bc0: 73 74 65 72 2d 72 75 6e 20 2a 64 62 2a 0a 09 09 ster-run *db*...
1bd0: 09 09 09 20 20 27 28 28 22 53 59 53 54 45 4d 22 ... '(("SYSTEM"
1be0: 20 22 6b 65 79 31 22 29 28 22 52 45 4c 45 41 53 "key1")("RELEAS
1bf0: 45 22 20 22 6b 65 79 32 22 29 29 0a 09 09 09 09 E" "key2")).....
1c00: 09 20 20 22 6d 79 72 75 6e 22 20 0a 09 09 09 09 . "myrun" .....
1c10: 09 20 20 22 6e 65 77 22 0a 09 09 09 09 09 20 20 . "new"......
1c20: 22 6e 2f 61 22 20 0a 09 09 09 09 09 20 20 22 62 "n/a" ...... "b
1c30: 6f 62 22 29 29 29 0a 0a 28 74 65 73 74 20 23 66 ob")))..(test #f
1c40: 20 23 74 20 20 20 20 20 20 20 20 20 20 20 20 20 #t
1c50: 28 63 64 62 3a 74 65 73 74 73 2d 72 65 67 69 73 (cdb:tests-regis
1c60: 74 65 72 2d 74 65 73 74 20 2a 72 75 6e 72 65 6d ter-test *runrem
1c70: 6f 74 65 2a 20 31 20 22 6e 61 64 61 22 20 22 22 ote* 1 "nada" ""
1c80: 29 29 0a 28 74 65 73 74 20 23 66 20 31 20 20 20 )).(test #f 1
1c90: 20 20 20 20 20 20 20 20 20 20 20 28 63 64 62 3a (cdb:
1ca0: 72 65 6d 6f 74 65 2d 72 75 6e 20 64 62 3a 67 65 remote-run db:ge
1cb0: 74 2d 74 65 73 74 2d 69 64 20 23 66 20 31 20 22 t-test-id #f 1 "
1cc0: 6e 61 64 61 22 20 22 22 29 29 0a 28 74 65 73 74 nada" "")).(test
1cd0: 20 23 66 20 22 4e 4f 54 5f 53 54 41 52 54 45 44 #f "NOT_STARTED
1ce0: 22 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 28 " (vector-ref (
1cf0: 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 open-run-close d
1d00: 62 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 20 b:get-test-info
1d10: 23 66 20 31 20 22 6e 61 64 61 22 20 22 22 29 20 #f 1 "nada" "")
1d20: 33 29 29 0a 28 74 65 73 74 20 23 66 20 22 4e 4f 3)).(test #f "NO
1d30: 54 5f 53 54 41 52 54 45 44 22 20 20 28 76 65 63 T_STARTED" (vec
1d40: 74 6f 72 2d 72 65 66 20 28 63 64 62 3a 67 65 74 tor-ref (cdb:get
1d50: 2d 74 65 73 74 2d 69 6e 66 6f 20 2a 72 75 6e 72 -test-info *runr
1d60: 65 6d 6f 74 65 2a 20 31 20 22 6e 61 64 61 22 20 emote* 1 "nada"
1d70: 22 22 29 20 33 29 29 0a 0a 28 64 65 66 69 6e 65 "") 3))..(define
1d80: 20 6b 65 79 73 20 28 64 62 3a 67 65 74 2d 6b 65 keys (db:get-ke
1d90: 79 73 20 2a 64 62 2a 29 29 0a 0a 3b 3b 3d 3d 3d ys *db*))..;;===
1da0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1db0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1dc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1dd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1de0: 3d 3d 3d 0a 3b 3b 20 44 20 42 0a 3b 3b 3d 3d 3d ===.;; D B.;;===
1df0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1e00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1e10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1e20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1e30: 3d 3d 3d 0a 0a 28 74 65 73 74 20 23 66 20 22 46 ===..(test #f "F
1e40: 4f 4f 20 4c 49 4b 45 20 27 61 62 63 25 64 65 66 OO LIKE 'abc%def
1e50: 27 22 20 28 64 62 3a 70 61 74 74 2d 3e 6c 69 6b '" (db:patt->lik
1e60: 65 20 22 46 4f 4f 22 20 22 61 62 63 25 64 65 66 e "FOO" "abc%def
1e70: 22 29 29 0a 28 74 65 73 74 20 23 66 20 22 6b 65 ")).(test #f "ke
1e80: 79 32 22 20 28 76 65 63 74 6f 72 2d 72 65 66 20 y2" (vector-ref
1e90: 28 63 61 72 20 28 76 65 63 74 6f 72 2d 72 65 66 (car (vector-ref
1ea0: 20 28 72 75 6e 73 3a 67 65 74 2d 72 75 6e 73 2d (runs:get-runs-
1eb0: 62 79 2d 70 61 74 74 20 2a 64 62 2a 20 27 28 22 by-patt *db* '("
1ec0: 53 59 53 54 45 4d 22 20 22 52 45 4c 45 41 53 45 SYSTEM" "RELEASE
1ed0: 22 29 20 22 25 22 20 22 6b 65 79 31 2f 6b 65 79 ") "%" "key1/key
1ee0: 32 22 29 20 31 29 29 20 31 29 29 0a 0a 28 74 65 2") 1)) 1))..(te
1ef0: 73 74 20 23 66 20 22 53 59 53 54 45 4d 2c 52 45 st #f "SYSTEM,RE
1f00: 4c 45 41 53 45 2c 69 64 2c 72 75 6e 6e 61 6d 65 LEASE,id,runname
1f10: 2c 73 74 61 74 65 2c 73 74 61 74 75 73 2c 6f 77 ,state,status,ow
1f20: 6e 65 72 2c 65 76 65 6e 74 5f 74 69 6d 65 22 20 ner,event_time"
1f30: 28 63 61 72 20 28 72 75 6e 73 3a 67 65 74 2d 73 (car (runs:get-s
1f40: 74 64 2d 72 75 6e 2d 66 69 65 6c 64 73 20 6b 65 td-run-fields ke
1f50: 79 73 20 27 28 22 69 64 22 20 22 72 75 6e 6e 61 ys '("id" "runna
1f60: 6d 65 22 20 22 73 74 61 74 65 22 20 22 73 74 61 me" "state" "sta
1f70: 74 75 73 22 20 22 6f 77 6e 65 72 22 20 22 65 76 tus" "owner" "ev
1f80: 65 6e 74 5f 74 69 6d 65 22 29 29 29 29 0a 28 74 ent_time")))).(t
1f90: 65 73 74 20 23 66 20 23 74 20 28 72 75 6e 73 3a est #f #t (runs:
1fa0: 6f 70 65 72 61 74 65 2d 6f 6e 20 27 70 72 69 6e operate-on 'prin
1fb0: 74 20 22 25 22 20 22 25 22 20 22 25 22 29 29 0a t "%" "%" "%")).
1fc0: 0a 3b 3b 28 74 65 73 74 20 22 75 70 64 61 74 65 .;;(test "update
1fd0: 2d 74 65 73 74 2d 69 6e 66 6f 22 20 23 74 20 28 -test-info" #t (
1fe0: 74 65 73 74 2d 75 70 64 61 74 65 2d 6d 65 74 61 test-update-meta
1ff0: 2d 69 6e 66 6f 20 2a 64 62 2a 20 31 20 22 6e 61 -info *db* 1 "na
2000: 64 61 22 20 0a 28 73 65 74 65 6e 76 20 22 42 4c da" .(setenv "BL
2010: 41 48 46 4f 4f 22 20 22 31 32 33 34 22 29 0a 28 AHFOO" "1234").(
2020: 75 6e 73 65 74 65 6e 76 20 22 4e 41 44 41 46 4f unsetenv "NADAFO
2030: 4f 22 29 0a 28 74 65 73 74 20 22 65 6e 76 20 74 O").(test "env t
2040: 65 6d 70 20 6f 76 65 72 72 69 64 65 73 22 20 22 emp overrides" "
2050: 78 79 7a 22 20 28 6c 65 74 20 28 28 70 72 65 76 xyz" (let ((prev
2060: 76 61 6c 73 20 28 61 6c 69 73 74 2d 3e 65 6e 76 vals (alist->env
2070: 2d 76 61 72 73 20 27 28 28 22 42 4c 41 48 46 4f -vars '(("BLAHFO
2080: 4f 22 20 34 33 32 31 29 28 22 4e 41 44 41 46 4f O" 4321)("NADAFO
2090: 4f 22 20 78 79 7a 29 29 29 29 0a 09 09 09 09 20 O" xyz)))).....
20a0: 20 20 20 20 20 20 28 72 65 73 75 6c 74 20 20 20 (result
20b0: 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 (get-environment
20c0: 2d 76 61 72 69 61 62 6c 65 20 22 4e 41 44 41 46 -variable "NADAF
20d0: 4f 4f 22 29 29 29 0a 09 09 09 09 20 20 20 20 28 OO")))..... (
20e0: 61 6c 69 73 74 2d 3e 65 6e 76 2d 76 61 72 73 20 alist->env-vars
20f0: 70 72 65 76 76 61 6c 73 29 0a 09 09 09 09 20 20 prevvals).....
2100: 20 20 72 65 73 75 6c 74 29 29 0a 0a 28 74 65 73 result))..(tes
2110: 74 20 22 65 6e 76 20 72 65 73 74 6f 72 65 64 22 t "env restored"
2120: 20 22 31 32 33 34 22 20 28 67 65 74 2d 65 6e 76 "1234" (get-env
2130: 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c ironment-variabl
2140: 65 20 22 42 4c 41 48 46 4f 4f 22 29 29 0a 0a 0a e "BLAHFOO"))...
2150: 28 74 65 73 74 20 22 49 74 65 6d 73 20 61 73 73 (test "Items ass
2160: 6f 63 22 20 22 45 6c 65 70 68 61 6e 74 22 20 28 oc" "Elephant" (
2170: 63 61 64 61 72 20 28 63 61 64 72 20 28 69 74 65 cadar (cadr (ite
2180: 6d 2d 61 73 73 6f 63 2d 3e 69 74 65 6d 2d 6c 69 m-assoc->item-li
2190: 73 74 20 27 28 28 22 41 4e 49 4d 41 4c 22 20 22 st '(("ANIMAL" "
21a0: 45 6c 65 70 68 61 6e 74 20 4c 69 6f 6e 22 29 28 Elephant Lion")(
21b0: 22 53 45 41 53 4f 4e 22 20 22 53 70 72 69 6e 67 "SEASON" "Spring
21c0: 20 46 61 6c 6c 22 29 29 29 29 29 29 0a 28 73 65 Fall")))))).(se
21d0: 74 21 20 2a 76 65 72 62 6f 73 69 74 79 2a 20 36 t! *verbosity* 6
21e0: 29 0a 28 74 65 73 74 20 22 49 74 65 6d 73 20 61 ).(test "Items a
21f0: 73 73 6f 63 22 20 27 28 29 28 69 74 65 6d 2d 61 ssoc" '()(item-a
2200: 73 73 6f 63 2d 3e 69 74 65 6d 2d 6c 69 73 74 20 ssoc->item-list
2210: 27 28 28 22 61 22 20 22 61 20 62 20 63 20 64 22 '(("a" "a b c d"
2220: 29 28 22 62 22 20 22 63 20 64 20 65 22 29 28 22 )("b" "c d e")("
2230: 63 22 20 22 22 29 28 22 64 22 29 29 29 29 0a 28 c" "")("d")))).(
2240: 73 65 74 21 20 2a 76 65 72 62 6f 73 69 74 79 2a set! *verbosity*
2250: 20 2d 31 29 0a 28 74 65 73 74 20 22 49 74 65 6d -1).(test "Item
2260: 73 20 61 73 73 6f 63 20 65 6d 70 74 79 20 69 74 s assoc empty it
2270: 65 6d 73 22 20 27 28 29 20 20 20 28 69 74 65 6d ems" '() (item
2280: 2d 61 73 73 6f 63 2d 3e 69 74 65 6d 2d 6c 69 73 -assoc->item-lis
2290: 74 20 27 28 28 22 41 22 29 29 29 29 0a 28 73 65 t '(("A")))).(se
22a0: 74 21 20 2a 76 65 72 62 6f 73 69 74 79 2a 20 31 t! *verbosity* 1
22b0: 29 0a 28 74 65 73 74 20 22 49 74 65 6d 73 20 74 ).(test "Items t
22c0: 61 62 6c 65 22 20 22 53 45 41 53 4f 4e 22 20 28 able" "SEASON" (
22d0: 63 61 61 64 61 72 20 28 69 74 65 6d 2d 74 61 62 caadar (item-tab
22e0: 6c 65 2d 3e 69 74 65 6d 2d 6c 69 73 74 20 27 28 le->item-list '(
22f0: 28 22 41 4e 49 4d 41 4c 22 20 22 45 6c 65 70 68 ("ANIMAL" "Eleph
2300: 61 6e 74 20 4c 69 6f 6e 22 29 28 22 53 45 41 53 ant Lion")("SEAS
2310: 4f 4e 22 20 22 53 70 72 69 6e 67 20 57 69 6e 74 ON" "Spring Wint
2320: 65 72 22 29 29 29 29 29 0a 28 74 65 73 74 20 22 er"))))).(test "
2330: 49 74 65 6d 73 20 74 61 62 6c 65 20 65 6d 70 74 Items table empt
2340: 79 20 69 74 65 6d 73 20 49 22 20 27 28 29 20 28 y items I" '() (
2350: 69 74 65 6d 2d 74 61 62 6c 65 2d 3e 69 74 65 6d item-table->item
2360: 2d 6c 69 73 74 20 27 28 28 22 41 22 29 29 29 29 -list '(("A"))))
2370: 0a 28 74 65 73 74 20 22 49 74 65 6d 73 20 74 61 .(test "Items ta
2380: 62 6c 65 20 65 6d 70 74 79 20 69 74 65 6d 73 20 ble empty items
2390: 49 49 22 20 27 28 29 20 28 69 74 65 6d 2d 74 61 II" '() (item-ta
23a0: 62 6c 65 2d 3e 69 74 65 6d 2d 6c 69 73 74 20 27 ble->item-list '
23b0: 28 28 22 41 22 20 22 22 29 29 29 29 0a 0a 3b 3b (("A" ""))))..;;
23c0: 20 54 65 73 74 20 6f 75 74 20 74 68 65 20 73 74 Test out the st
23d0: 65 70 73 20 63 6f 64 65 0a 0a 28 64 65 66 69 6e eps code..(defin
23e0: 65 20 74 65 73 74 2d 69 64 20 23 66 29 0a 0a 3b e test-id #f)..;
23f0: 3b 20 66 6f 72 63 65 20 6b 65 65 70 67 6f 69 6e ; force keepgoin
2400: 67 0a 3b 20 28 68 61 73 68 2d 74 61 62 6c 65 2d g.; (hash-table-
2410: 73 65 74 21 20 61 72 67 73 3a 61 72 67 2d 68 61 set! args:arg-ha
2420: 73 68 20 22 2d 6b 65 65 70 67 6f 69 6e 67 22 20 sh "-keepgoing"
2430: 23 74 29 0a 28 68 61 73 68 2d 74 61 62 6c 65 2d #t).(hash-table-
2440: 73 65 74 21 20 61 72 67 73 3a 61 72 67 2d 68 61 set! args:arg-ha
2450: 73 68 20 22 2d 69 74 65 6d 70 61 74 74 22 20 22 sh "-itempatt" "
2460: 25 22 29 0a 28 68 61 73 68 2d 74 61 62 6c 65 2d %").(hash-table-
2470: 73 65 74 21 20 61 72 67 73 3a 61 72 67 2d 68 61 set! args:arg-ha
2480: 73 68 20 22 2d 74 65 73 74 70 61 74 74 22 20 22 sh "-testpatt" "
2490: 25 22 29 0a 28 68 61 73 68 2d 74 61 62 6c 65 2d %").(hash-table-
24a0: 73 65 74 21 20 61 72 67 73 3a 61 72 67 2d 68 61 set! args:arg-ha
24b0: 73 68 20 22 2d 74 61 72 67 65 74 22 20 22 75 62 sh "-target" "ub
24c0: 75 6e 74 75 2f 72 31 2e 32 22 29 0a 28 74 65 73 untu/r1.2").(tes
24d0: 74 20 22 53 65 74 75 70 20 66 6f 72 20 61 20 72 t "Setup for a r
24e0: 75 6e 22 20 20 20 20 20 20 20 23 74 20 28 62 65 un" #t (be
24f0: 67 69 6e 20 28 73 65 74 75 70 2d 66 6f 72 2d 72 gin (setup-for-r
2500: 75 6e 29 20 23 74 29 29 0a 0a 28 64 65 66 69 6e un) #t))..(defin
2510: 65 20 2a 74 64 62 2a 20 23 66 29 0a 28 64 65 66 e *tdb* #f).(def
2520: 69 6e 65 20 6b 65 79 76 61 6c 73 20 23 66 29 0a ine keyvals #f).
2530: 28 74 65 73 74 20 22 74 61 72 67 65 74 2d 3e 6b (test "target->k
2540: 65 79 76 61 6c 22 20 23 74 20 28 6c 65 74 20 28 eyval" #t (let (
2550: 28 6b 76 20 28 6b 65 79 73 3a 74 61 72 67 65 74 (kv (keys:target
2560: 2d 3e 6b 65 79 76 61 6c 20 6b 65 79 73 20 28 61 ->keyval keys (a
2570: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 rgs:get-arg "-ta
2580: 72 67 65 74 22 29 29 29 29 0a 09 09 09 20 20 20 rget"))))....
2590: 20 28 73 65 74 21 20 6b 65 79 76 61 6c 73 20 6b (set! keyvals k
25a0: 76 29 28 6c 69 73 74 3f 20 6b 65 79 76 61 6c 73 v)(list? keyvals
25b0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 74 65 73 )))..(define tes
25c0: 74 64 62 70 61 74 68 20 28 63 6f 6e 63 20 22 2f tdbpath (conc "/
25d0: 74 6d 70 2f 22 20 28 67 65 74 65 6e 76 20 22 55 tmp/" (getenv "U
25e0: 53 45 52 22 29 20 22 2f 6d 65 67 61 74 65 73 74 SER") "/megatest
25f0: 5f 74 65 73 74 69 6e 67 22 29 29 0a 28 73 79 73 _testing")).(sys
2600: 74 65 6d 20 28 63 6f 6e 63 20 22 72 6d 20 2d 66 tem (conc "rm -f
2610: 20 22 20 74 65 73 74 64 62 70 61 74 68 20 22 2f " testdbpath "/
2620: 74 65 73 74 64 61 74 2e 64 62 3b 6d 6b 64 69 72 testdat.db;mkdir
2630: 20 2d 70 20 22 20 74 65 73 74 64 62 70 61 74 68 -p " testdbpath
2640: 29 29 0a 0a 28 70 72 69 6e 74 20 22 55 73 69 6e ))..(print "Usin
2650: 67 20 22 20 74 65 73 74 64 62 70 61 74 68 20 22 g " testdbpath "
2660: 20 66 6f 72 20 74 65 73 74 20 64 62 22 29 0a 28 for test db").(
2670: 74 65 73 74 20 23 66 20 23 74 20 28 6c 65 74 20 test #f #t (let
2680: 28 28 64 62 20 28 6f 70 65 6e 2d 74 65 73 74 2d ((db (open-test-
2690: 64 62 20 74 65 73 74 64 62 70 61 74 68 29 29 29 db testdbpath)))
26a0: 0a 09 20 20 20 20 20 20 28 73 65 74 21 20 2a 74 .. (set! *t
26b0: 64 62 2a 20 64 62 29 0a 09 20 20 20 20 20 20 28 db* db).. (
26c0: 73 71 6c 69 74 65 33 23 64 61 74 61 62 61 73 65 sqlite3#database
26d0: 3f 20 64 62 29 29 29 0a 28 73 71 6c 69 74 65 33 ? db))).(sqlite3
26e0: 23 66 69 6e 61 6c 69 7a 65 21 20 2a 74 64 62 2a #finalize! *tdb*
26f0: 29 0a 0a 3b 3b 20 28 74 65 73 74 20 22 52 65 6d )..;; (test "Rem
2700: 6f 76 65 20 74 68 65 20 72 6f 6c 6c 75 70 20 72 ove the rollup r
2710: 75 6e 22 20 23 74 20 28 62 65 67 69 6e 20 28 72 un" #t (begin (r
2720: 65 6d 6f 76 65 2d 72 75 6e 73 29 20 23 74 29 29 emove-runs) #t))
2730: 0a 28 64 65 66 69 6e 65 20 74 63 6f 6e 66 69 67 .(define tconfig
2740: 20 23 66 29 0a 28 74 65 73 74 20 22 67 65 74 20 #f).(test "get
2750: 61 20 74 65 73 74 63 6f 6e 66 69 67 22 20 23 74 a testconfig" #t
2760: 20 28 6c 65 74 20 28 28 74 63 6f 6e 66 20 28 74 (let ((tconf (t
2770: 65 73 74 73 3a 67 65 74 2d 74 65 73 74 63 6f 6e ests:get-testcon
2780: 66 69 67 20 22 74 65 73 74 31 22 20 27 72 65 74 fig "test1" 'ret
2790: 75 72 6e 2d 70 72 6f 63 73 29 29 29 0a 09 09 09 urn-procs)))....
27a0: 20 20 20 20 20 20 28 73 65 74 21 20 74 63 6f 6e (set! tcon
27b0: 66 69 67 20 74 63 6f 6e 66 29 0a 09 09 09 20 20 fig tconf)....
27c0: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 3f (hash-table?
27d0: 20 74 63 6f 6e 66 29 29 29 0a 28 64 62 3a 63 6c tconf))).(db:cl
27e0: 65 61 6e 2d 61 6c 6c 2d 63 61 63 68 65 73 29 0a ean-all-caches).
27f0: 0a 28 74 65 73 74 20 22 73 65 74 2d 6d 65 67 61 .(test "set-mega
2800: 74 65 73 74 2d 65 6e 76 2d 76 61 72 73 22 0a 20 test-env-vars".
2810: 20 20 20 20 20 22 75 62 75 6e 74 75 22 0a 20 20 "ubuntu".
2820: 20 20 20 20 28 62 65 67 69 6e 0a 09 28 73 65 74 (begin..(set
2830: 2d 6d 65 67 61 74 65 73 74 2d 65 6e 76 2d 76 61 -megatest-env-va
2840: 72 73 20 31 20 69 6e 6b 65 79 73 3a 20 6b 65 79 rs 1 inkeys: key
2850: 73 29 0a 09 28 67 65 74 2d 65 6e 76 69 72 6f 6e s)..(get-environ
2860: 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 53 ment-variable "S
2870: 59 53 54 45 4d 22 29 29 29 0a 28 74 65 73 74 20 YSTEM"))).(test
2880: 22 73 65 74 75 70 2d 65 6e 76 2d 64 65 66 61 75 "setup-env-defau
2890: 6c 74 73 22 0a 20 20 20 20 20 20 22 73 65 65 20 lts". "see
28a0: 74 68 69 73 20 76 61 72 69 61 62 6c 65 22 0a 20 this variable".
28b0: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 28 73 65 (begin..(se
28c0: 74 75 70 2d 65 6e 76 2d 64 65 66 61 75 6c 74 73 tup-env-defaults
28d0: 20 22 72 75 6e 63 6f 6e 66 69 67 73 2e 63 6f 6e "runconfigs.con
28e0: 66 69 67 22 20 31 20 2a 61 6c 72 65 61 64 79 2d fig" 1 *already-
28f0: 73 65 65 6e 2d 72 75 6e 63 6f 6e 66 69 67 2d 69 seen-runconfig-i
2900: 6e 66 6f 2a 20 6b 65 79 73 20 6b 65 79 76 61 6c nfo* keys keyval
2910: 73 20 22 70 72 65 2d 6c 61 75 6e 63 68 2d 65 6e s "pre-launch-en
2920: 76 2d 76 61 72 73 22 29 0a 09 28 67 65 74 2d 65 v-vars")..(get-e
2930: 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 nvironment-varia
2940: 62 6c 65 20 22 41 4c 4c 54 45 53 54 53 22 29 29 ble "ALLTESTS"))
2950: 29 0a 0a 28 74 65 73 74 20 23 66 20 22 75 62 75 )..(test #f "ubu
2960: 6e 74 75 22 20 28 63 61 72 20 28 6b 65 79 73 3a ntu" (car (keys:
2970: 74 61 72 67 65 74 2d 73 65 74 2d 61 72 67 73 20 target-set-args
2980: 6b 65 79 73 20 28 61 72 67 73 3a 67 65 74 2d 61 keys (args:get-a
2990: 72 67 20 22 2d 74 61 72 67 65 74 22 29 20 61 72 rg "-target") ar
29a0: 67 73 3a 61 72 67 2d 68 61 73 68 29 29 29 0a 0a gs:arg-hash)))..
29b0: 28 64 65 66 69 6e 65 20 72 69 6e 66 6f 20 23 66 (define rinfo #f
29c0: 29 0a 28 74 65 73 74 20 22 67 65 74 2d 72 75 6e ).(test "get-run
29d0: 2d 69 6e 66 6f 22 20 20 23 66 20 28 76 65 63 74 -info" #f (vect
29e0: 6f 72 3f 20 28 76 65 63 74 6f 72 2d 72 65 66 20 or? (vector-ref
29f0: 28 6c 65 74 20 28 28 72 69 6e 66 20 28 63 64 62 (let ((rinf (cdb
2a00: 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 64 62 3a 67 :remote-run db:g
2a10: 65 74 2d 72 75 6e 2d 69 6e 66 6f 20 23 66 20 31 et-run-info #f 1
2a20: 29 29 29 0a 09 09 09 09 09 09 28 73 65 74 21 20 ))).......(set!
2a30: 72 69 6e 66 6f 20 72 69 6e 66 29 0a 09 09 09 09 rinfo rinf).....
2a40: 09 09 72 69 6e 66 29 20 30 29 29 29 0a 28 74 65 ..rinf) 0))).(te
2a50: 73 74 20 22 67 65 74 2d 6b 65 79 2d 76 61 6c 73 st "get-key-vals
2a60: 22 20 20 22 6b 65 79 31 22 20 28 63 61 72 20 28 " "key1" (car (
2a70: 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 64 cdb:remote-run d
2a80: 62 3a 67 65 74 2d 6b 65 79 2d 76 61 6c 73 20 23 b:get-key-vals #
2a90: 66 20 31 29 29 29 0a 28 74 65 73 74 20 22 74 65 f 1))).(test "te
2aa0: 73 74 73 3a 73 6f 72 74 2d 62 79 22 20 27 28 29 sts:sort-by" '()
2ab0: 20 28 74 65 73 74 73 3a 73 6f 72 74 2d 62 79 2d (tests:sort-by-
2ac0: 70 72 69 6f 72 69 74 79 2d 61 6e 64 2d 77 61 69 priority-and-wai
2ad0: 74 6f 6e 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 ton (make-hash-t
2ae0: 61 62 6c 65 29 29 29 0a 0a 28 74 65 73 74 20 22 able)))..(test "
2af0: 75 70 64 61 74 65 2d 74 65 73 74 5f 6d 65 74 61 update-test_meta
2b00: 22 20 22 74 65 73 74 31 22 20 28 62 65 67 69 6e " "test1" (begin
2b10: 0a 09 09 09 09 20 20 20 28 72 75 6e 73 3a 75 70 ..... (runs:up
2b20: 64 61 74 65 2d 74 65 73 74 5f 6d 65 74 61 20 22 date-test_meta "
2b30: 74 65 73 74 31 22 20 74 63 6f 6e 66 69 67 29 0a test1" tconfig).
2b40: 09 09 09 09 20 20 20 28 6c 65 74 20 28 28 64 61 .... (let ((da
2b50: 74 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 t (cdb:remote-ru
2b60: 6e 20 64 62 3a 74 65 73 74 6d 65 74 61 2d 67 65 n db:testmeta-ge
2b70: 74 2d 72 65 63 6f 72 64 20 23 66 20 22 74 65 73 t-record #f "tes
2b80: 74 31 22 29 29 29 0a 09 09 09 09 20 20 20 20 20 t1"))).....
2b90: 28 76 65 63 74 6f 72 2d 72 65 66 20 64 61 74 20 (vector-ref dat
2ba0: 31 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 74 1))))..(define t
2bb0: 65 73 74 2d 70 61 74 68 20 22 74 65 73 74 73 2f est-path "tests/
2bc0: 74 65 73 74 31 22 29 0a 28 64 65 66 69 6e 65 20 test1").(define
2bd0: 64 69 73 6b 2d 70 61 74 68 20 23 66 29 0a 28 74 disk-path #f).(t
2be0: 65 73 74 20 22 67 65 74 2d 62 65 73 74 2d 64 69 est "get-best-di
2bf0: 73 6b 22 20 20 20 20 23 74 20 28 73 74 72 69 6e sk" #t (strin
2c00: 67 3f 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f g? (file-exists?
2c10: 20 28 6c 65 74 20 28 28 64 20 28 67 65 74 2d 62 (let ((d (get-b
2c20: 65 73 74 2d 64 69 73 6b 20 2a 63 6f 6e 66 69 67 est-disk *config
2c30: 64 61 74 2a 29 29 29 0a 09 09 09 09 09 09 20 20 dat*))).......
2c40: 20 20 20 28 73 65 74 21 20 64 69 73 6b 2d 70 61 (set! disk-pa
2c50: 74 68 20 64 29 0a 09 09 09 09 09 09 20 20 20 20 th d).......
2c60: 20 64 29 29 29 29 0a 28 74 65 73 74 20 22 63 72 d)))).(test "cr
2c70: 65 61 74 65 2d 77 6f 72 6b 2d 61 72 65 61 22 20 eate-work-area"
2c80: 23 74 20 28 73 79 6d 62 6f 6c 69 63 2d 6c 69 6e #t (symbolic-lin
2c90: 6b 3f 20 28 63 61 72 20 28 63 72 65 61 74 65 2d k? (car (create-
2ca0: 77 6f 72 6b 2d 61 72 65 61 20 31 20 72 69 6e 66 work-area 1 rinf
2cb0: 6f 20 6b 65 79 76 61 6c 73 20 31 20 74 65 73 74 o keyvals 1 test
2cc0: 2d 70 61 74 68 20 64 69 73 6b 2d 70 61 74 68 20 -path disk-path
2cd0: 22 74 65 73 74 31 22 20 27 28 29 29 29 29 29 0a "test1" '())))).
2ce0: 28 74 65 73 74 20 23 66 20 22 22 20 28 69 74 65 (test #f "" (ite
2cf0: 6d 2d 6c 69 73 74 2d 3e 70 61 74 68 20 27 28 29 m-list->path '()
2d00: 29 29 0a 0a 28 74 65 73 74 20 22 6c 61 75 6e 63 ))..(test "launc
2d10: 68 2d 74 65 73 74 22 20 23 74 20 28 73 74 72 69 h-test" #t (stri
2d20: 6e 67 3f 20 28 66 69 6c 65 2d 65 78 69 73 74 73 ng? (file-exists
2d30: 3f 20 28 6c 61 75 6e 63 68 2d 74 65 73 74 20 31 ? (launch-test 1
2d40: 20 31 20 72 69 6e 66 6f 20 6b 65 79 76 61 6c 73 1 rinfo keyvals
2d50: 20 22 72 75 6e 31 22 20 74 63 6f 6e 66 69 67 20 "run1" tconfig
2d60: 22 74 65 73 74 31 22 20 74 65 73 74 2d 70 61 74 "test1" test-pat
2d70: 68 20 27 28 29 20 28 6d 61 6b 65 2d 68 61 73 68 h '() (make-hash
2d80: 2d 74 61 62 6c 65 29 29 29 29 29 0a 0a 0a 28 74 -table)))))...(t
2d90: 65 73 74 20 22 52 75 6e 20 61 20 74 65 73 74 22 est "Run a test"
2da0: 20 23 74 20 28 67 65 6e 65 72 61 6c 2d 72 75 6e #t (general-run
2db0: 2d 63 61 6c 6c 20 0a 09 09 20 20 20 20 20 20 20 -call ...
2dc0: 22 2d 72 75 6e 74 65 73 74 73 22 20 0a 09 09 20 "-runtests" ...
2dd0: 20 20 20 20 20 20 22 72 75 6e 20 61 20 74 65 73 "run a tes
2de0: 74 22 0a 09 09 20 20 20 20 20 20 20 28 6c 61 6d t"... (lam
2df0: 62 64 61 20 28 74 61 72 67 65 74 20 72 75 6e 6e bda (target runn
2e00: 61 6d 65 20 6b 65 79 73 20 6b 65 79 76 61 6c 6c ame keys keyvall
2e10: 73 74 29 0a 09 09 09 20 28 6c 65 74 20 28 28 74 st).... (let ((t
2e20: 65 73 74 2d 70 61 74 74 73 20 22 74 65 73 74 25 est-patts "test%
2e30: 22 29 29 0a 09 09 09 20 20 20 3b 3b 20 28 72 75 ")).... ;; (ru
2e40: 6e 73 3a 72 75 6e 2d 74 65 73 74 73 20 74 61 72 ns:run-tests tar
2e50: 67 65 74 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 get runname test
2e60: 2d 70 61 74 74 73 20 75 73 65 72 20 28 6d 61 6b -patts user (mak
2e70: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 09 e-hash-table))..
2e80: 09 09 20 20 20 3b 3b 20 28 72 75 6e 3a 74 65 73 .. ;; (run:tes
2e90: 74 20 72 75 6e 2d 69 64 20 72 75 6e 2d 69 6e 66 t run-id run-inf
2ea0: 6f 20 6b 65 79 2d 76 61 6c 73 20 72 75 6e 6e 61 o key-vals runna
2eb0: 6d 65 20 74 65 73 74 2d 72 65 63 6f 72 64 20 66 me test-record f
2ec0: 6c 61 67 73 20 70 61 72 65 6e 74 2d 74 65 73 74 lags parent-test
2ed0: 29 0a 09 09 09 20 20 20 3b 3b 20 28 73 65 74 21 ).... ;; (set!
2ee0: 20 2a 76 65 72 62 6f 73 69 74 79 2a 20 32 32 29 *verbosity* 22)
2ef0: 20 3b 3b 20 28 6c 69 73 74 20 30 20 31 20 32 29 ;; (list 0 1 2)
2f00: 29 0a 09 09 09 20 20 20 28 72 75 6e 3a 74 65 73 ).... (run:tes
2f10: 74 20 31 20 3b 3b 20 72 75 6e 2d 69 64 0a 09 09 t 1 ;; run-id...
2f20: 09 09 20 20 20 20 20 23 66 20 20 20 20 20 20 20 .. #f
2f30: 20 3b 3b 20 72 75 6e 2d 69 6e 66 6f 20 69 73 20 ;; run-info is
2f40: 79 65 74 20 6f 6e 6c 79 20 61 20 64 72 65 61 6d yet only a dream
2f50: 0a 09 09 09 09 20 20 20 20 20 6b 65 79 76 61 6c ..... keyval
2f60: 6c 73 74 20 3b 3b 20 28 6b 65 79 73 3a 74 61 72 lst ;; (keys:tar
2f70: 67 65 74 2d 3e 6b 65 79 76 61 6c 20 6b 65 79 73 get->keyval keys
2f80: 20 74 61 72 67 65 74 29 0a 09 09 09 09 20 20 20 target).....
2f90: 20 20 22 72 75 6e 31 22 20 20 20 20 3b 3b 20 72 "run1" ;; r
2fa0: 75 6e 6e 61 6d 65 20 0a 09 09 09 09 20 20 20 20 unname .....
2fb0: 20 28 76 65 63 74 6f 72 20 20 20 20 20 20 20 20 (vector
2fc0: 20 20 20 20 3b 3b 20 74 65 73 74 5f 72 65 63 6f ;; test_reco
2fd0: 72 64 73 2e 73 63 6d 20 74 65 73 74 73 3a 74 65 rds.scm tests:te
2fe0: 73 74 71 75 65 75 65 0a 09 09 09 09 20 20 20 20 stqueue.....
2ff0: 20 20 22 74 65 73 74 31 22 20 20 20 20 20 20 20 "test1"
3000: 20 20 20 20 3b 3b 20 74 65 73 74 6e 61 6d 65 0a ;; testname.
3010: 09 09 09 09 20 20 20 20 20 20 74 63 6f 6e 66 69 .... tconfi
3020: 67 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 74 g ;; t
3030: 65 73 74 63 6f 6e 66 69 67 0a 09 09 09 09 20 20 estconfig.....
3040: 20 20 20 20 27 28 29 20 20 20 20 20 20 20 20 20 '()
3050: 20 20 20 20 20 20 3b 3b 20 77 61 69 74 6f 6e 73 ;; waitons
3060: 0a 09 09 09 09 20 20 20 20 20 20 30 20 20 20 20 ..... 0
3070: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ;;
3080: 70 72 69 6f 72 69 74 79 0a 09 09 09 09 20 20 20 priority.....
3090: 20 20 20 23 66 20 20 20 20 20 20 20 20 20 20 20 #f
30a0: 20 20 20 20 20 3b 3b 20 69 74 65 6d 73 0a 09 09 ;; items...
30b0: 09 09 20 20 20 20 20 20 23 66 20 20 20 20 20 20 .. #f
30c0: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 69 74 65 ;; ite
30d0: 6d 73 64 61 74 0a 09 09 09 09 20 20 20 20 20 20 msdat.....
30e0: 22 22 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ""
30f0: 20 20 3b 3b 20 69 74 65 6d 70 61 74 68 0a 09 09 ;; itempath...
3100: 09 09 20 20 20 20 20 20 29 0a 09 09 09 09 20 20 .. ).....
3110: 20 20 20 61 72 67 73 3a 61 72 67 2d 68 61 73 68 args:arg-hash
3120: 20 20 20 20 20 20 3b 3b 20 66 6c 61 67 73 20 28 ;; flags (
3130: 65 2e 67 2e 20 2d 69 74 65 6d 73 70 61 74 74 29 e.g. -itemspatt)
3140: 0a 09 09 09 09 20 20 20 20 20 23 66 29 0a 09 09 ..... #f)...
3150: 09 20 20 20 3b 3b 20 28 73 65 74 21 20 2a 76 65 . ;; (set! *ve
3160: 72 62 6f 73 69 74 79 2a 20 30 29 0a 09 09 09 20 rbosity* 0)....
3170: 20 20 29 29 29 29 0a 0a 0a 0a 0a 0a 28 74 65 73 ))))......(tes
3180: 74 20 22 73 65 72 76 65 72 20 73 74 6f 70 22 20 t "server stop"
3190: 23 66 20 28 6c 65 74 20 28 28 68 6f 73 74 6e 61 #f (let ((hostna
31a0: 6d 65 20 28 63 61 72 20 20 2a 72 75 6e 72 65 6d me (car *runrem
31b0: 6f 74 65 2a 29 29 0a 09 09 09 20 20 20 20 20 28 ote*)).... (
31c0: 70 6f 72 74 20 20 20 20 20 28 63 61 64 72 20 2a port (cadr *
31d0: 72 75 6e 72 65 6d 6f 74 65 2a 29 29 29 0a 09 09 runremote*)))...
31e0: 09 20 28 74 61 73 6b 73 3a 6b 69 6c 6c 2d 73 65 . (tasks:kill-se
31f0: 72 76 65 72 20 23 74 20 68 6f 73 74 6e 61 6d 65 rver #t hostname
3200: 20 70 6f 72 74 20 73 65 72 76 65 72 2d 70 69 64 port server-pid
3210: 20 27 68 74 74 70 29 0a 09 09 09 20 28 6f 70 65 'http).... (ope
3220: 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 74 61 73 6b n-run-close task
3230: 73 3a 67 65 74 2d 62 65 73 74 2d 73 65 72 76 65 s:get-best-serve
3240: 72 20 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 29 r tasks:open-db)
3250: 29 29 0a 0a 28 65 78 69 74 20 31 29 0a 3b 3b 20 ))..(exit 1).;;
3260: 28 74 65 73 74 20 22 63 61 63 68 65 20 69 73 20 (test "cache is
3270: 63 6f 68 65 72 65 6e 74 22 20 23 74 20 28 6c 65 coherent" #t (le
3280: 74 20 28 28 63 61 63 68 65 64 2d 69 6e 66 6f 20 t ((cached-info
3290: 28 64 62 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 (db:get-test-inf
32a0: 6f 2d 63 61 63 68 65 64 2d 62 79 2d 69 64 20 64 o-cached-by-id d
32b0: 62 20 32 29 29 0a 3b 3b 20 09 09 09 09 20 20 20 b 2)).;; ....
32c0: 28 6e 6f 6e 2d 63 61 63 68 65 64 20 20 28 64 62 (non-cached (db
32d0: 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 6e :get-test-info-n
32e0: 6f 74 2d 63 61 63 68 65 64 2d 62 79 2d 69 64 20 ot-cached-by-id
32f0: 64 62 20 32 29 29 29 0a 3b 3b 20 09 09 09 20 20 db 2))).;; ...
3300: 20 20 20 20 20 28 70 72 69 6e 74 20 22 5c 6e 43 (print "\nC
3310: 61 63 68 65 64 3a 20 20 20 20 22 20 63 61 63 68 ached: " cach
3320: 65 64 2d 69 6e 66 6f 29 0a 3b 3b 20 09 09 09 20 ed-info).;; ...
3330: 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 4e 6f (print "No
3340: 6e 63 61 63 68 65 64 3a 20 22 20 6e 6f 6e 2d 63 ncached: " non-c
3350: 61 63 68 65 64 29 0a 3b 3b 20 09 09 09 20 20 20 ached).;; ...
3360: 20 20 20 20 28 65 71 75 61 6c 3f 20 63 61 63 68 (equal? cach
3370: 65 64 2d 69 6e 66 6f 20 6e 6f 6e 2d 63 61 63 68 ed-info non-cach
3380: 65 64 29 29 29 0a 0a 28 63 68 61 6e 67 65 2d 64 ed)))..(change-d
3390: 69 72 65 63 74 6f 72 79 20 74 65 73 74 2d 77 6f irectory test-wo
33a0: 72 6b 2d 64 69 72 29 0a 28 74 65 73 74 20 22 41 rk-dir).(test "A
33b0: 64 64 20 61 20 73 74 65 70 22 20 20 23 74 0a 20 dd a step" #t.
33c0: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 28 64 62 (begin..(db
33d0: 3a 74 65 73 74 73 74 65 70 2d 73 65 74 2d 73 74 :teststep-set-st
33e0: 61 74 75 73 21 20 64 62 20 32 20 22 73 74 65 70 atus! db 2 "step
33f0: 31 22 20 22 73 74 61 72 74 22 20 30 20 22 54 68 1" "start" 0 "Th
3400: 69 73 20 69 73 20 61 20 63 6f 6d 6d 65 6e 74 22 is is a comment"
3410: 20 22 6d 79 6c 6f 67 66 69 6c 65 2e 68 74 6d 6c "mylogfile.html
3420: 22 29 0a 09 28 73 6c 65 65 70 20 32 29 0a 09 28 ")..(sleep 2)..(
3430: 64 62 3a 74 65 73 74 73 74 65 70 2d 73 65 74 2d db:teststep-set-
3440: 73 74 61 74 75 73 21 20 64 62 20 32 20 22 73 74 status! db 2 "st
3450: 65 70 31 22 20 22 65 6e 64 22 20 22 70 61 73 73 ep1" "end" "pass
3460: 22 20 22 54 68 69 73 20 69 73 20 61 20 64 69 66 " "This is a dif
3470: 66 65 72 65 6e 74 20 63 6f 6d 6d 65 6e 74 22 20 ferent comment"
3480: 22 66 69 6e 61 6c 6c 6f 67 66 69 6c 65 2e 68 74 "finallogfile.ht
3490: 6d 6c 22 29 0a 09 28 73 65 74 21 20 74 65 73 74 ml")..(set! test
34a0: 2d 69 64 20 28 64 62 3a 74 65 73 74 2d 67 65 74 -id (db:test-get
34b0: 2d 69 64 20 28 63 61 72 20 28 63 64 62 3a 72 65 -id (car (cdb:re
34c0: 6d 6f 74 65 2d 72 75 6e 20 64 62 3a 67 65 74 2d mote-run db:get-
34d0: 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 23 66 tests-for-run #f
34e0: 20 31 20 22 74 65 73 74 31 22 20 27 28 29 20 27 1 "test1" '() '
34f0: 28 29 29 29 29 29 0a 09 28 6e 75 6d 62 65 72 3f ()))))..(number?
3500: 20 74 65 73 74 2d 69 64 29 29 29 0a 0a 28 74 65 test-id)))..(te
3510: 73 74 20 22 47 65 74 20 72 75 6e 64 69 72 22 20 st "Get rundir"
3520: 20 20 20 20 20 20 23 74 20 28 6c 65 74 20 28 28 #t (let ((
3530: 72 75 6e 64 69 72 20 28 63 64 62 3a 72 65 6d 6f rundir (cdb:remo
3540: 74 65 2d 72 75 6e 20 64 62 3a 74 65 73 74 2d 67 te-run db:test-g
3550: 65 74 2d 72 75 6e 64 69 72 2d 66 72 6f 6d 2d 74 et-rundir-from-t
3560: 65 73 74 2d 69 64 20 23 66 20 74 65 73 74 2d 69 est-id #f test-i
3570: 64 29 29 29 0a 09 09 09 20 20 20 20 20 20 28 70 d))).... (p
3580: 72 69 6e 74 20 22 52 75 6e 64 69 72 20 22 20 72 rint "Rundir " r
3590: 75 6e 64 69 72 29 0a 09 09 09 20 20 20 20 20 20 undir)....
35a0: 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 6d (system (conc "m
35b0: 6b 64 69 72 20 2d 70 20 22 20 72 75 6e 64 69 72 kdir -p " rundir
35c0: 29 29 0a 09 09 09 20 20 20 20 20 20 28 73 74 72 )).... (str
35d0: 69 6e 67 3f 20 72 75 6e 64 69 72 29 29 29 0a 28 ing? rundir))).(
35e0: 74 65 73 74 20 23 66 20 23 74 20 28 73 71 6c 69 test #f #t (sqli
35f0: 74 65 33 23 64 61 74 61 62 61 73 65 3f 20 28 6f te3#database? (o
3600: 70 65 6e 2d 74 65 73 74 2d 64 62 20 22 2e 2f 22 pen-test-db "./"
3610: 29 29 29 0a 28 74 65 73 74 20 22 43 72 65 61 74 ))).(test "Creat
3620: 65 20 61 20 74 65 73 74 20 64 62 22 20 22 2e 2e e a test db" "..
3630: 2f 73 69 6d 70 6c 65 72 75 6e 73 2f 6b 65 79 31 /simpleruns/key1
3640: 2f 6b 65 79 32 2f 6d 79 72 75 6e 2f 74 65 73 74 /key2/myrun/test
3650: 31 2f 74 65 73 74 64 61 74 2e 64 62 22 0a 20 20 1/testdat.db".
3660: 20 20 20 20 28 6c 65 74 20 28 28 74 64 62 20 28 (let ((tdb (
3670: 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 open-run-close d
3680: 62 3a 6f 70 65 6e 2d 74 65 73 74 2d 64 62 2d 62 b:open-test-db-b
3690: 79 2d 74 65 73 74 2d 69 64 20 64 62 20 74 65 73 y-test-id db tes
36a0: 74 2d 69 64 29 29 29 0a 09 28 69 66 20 74 64 62 t-id)))..(if tdb
36b0: 20 28 73 71 6c 69 74 65 33 23 66 69 6e 61 6c 69 (sqlite3#finali
36c0: 7a 65 21 20 74 64 62 29 29 0a 09 28 66 69 6c 65 ze! tdb))..(file
36d0: 2d 65 78 69 73 74 73 3f 20 22 2e 2e 2f 73 69 6d -exists? "../sim
36e0: 70 6c 65 72 75 6e 73 2f 6b 65 79 31 2f 6b 65 79 pleruns/key1/key
36f0: 32 2f 6d 79 72 75 6e 2f 74 65 73 74 31 2f 74 65 2/myrun/test1/te
3700: 73 74 64 61 74 2e 64 62 22 29 29 29 0a 0a 28 74 stdat.db")))..(t
3710: 65 73 74 20 22 47 65 74 20 73 74 65 70 73 20 66 est "Get steps f
3720: 6f 72 20 74 65 73 74 22 20 23 74 20 28 6c 65 74 or test" #t (let
3730: 20 28 28 73 74 65 70 73 20 28 63 64 62 3a 72 65 ((steps (cdb:re
3740: 6d 6f 74 65 2d 72 75 6e 20 64 62 3a 67 65 74 2d mote-run db:get-
3750: 73 74 65 70 73 2d 66 6f 72 2d 74 65 73 74 20 23 steps-for-test #
3760: 66 20 74 65 73 74 2d 69 64 29 29 29 0a 09 09 09 f test-id)))....
3770: 09 28 70 72 69 6e 74 20 73 74 65 70 73 29 0a 09 .(print steps)..
3780: 09 09 09 28 3e 20 28 6c 65 6e 67 74 68 20 73 74 ...(> (length st
3790: 65 70 73 29 20 30 29 29 29 0a 28 74 65 73 74 20 eps) 0))).(test
37a0: 22 47 65 74 20 6e 69 63 65 20 74 61 62 6c 65 20 "Get nice table
37b0: 66 6f 72 20 73 74 65 70 73 22 20 22 32 2e 30 73 for steps" "2.0s
37c0: 22 0a 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 ". (begin..
37d0: 28 76 65 63 74 6f 72 2d 72 65 66 20 28 68 61 73 (vector-ref (has
37e0: 68 2d 74 61 62 6c 65 2d 72 65 66 20 28 6f 70 65 h-table-ref (ope
37f0: 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 n-run-close db:g
3800: 65 74 2d 73 74 65 70 73 2d 74 61 62 6c 65 20 23 et-steps-table #
3810: 66 20 74 65 73 74 2d 69 64 29 20 22 73 74 65 70 f test-id) "step
3820: 31 22 29 20 34 29 29 29 0a 0a 3b 3b 20 28 65 78 1") 4)))..;; (ex
3830: 69 74 29 0a 0a 28 74 65 73 74 20 23 66 20 22 6d it)..(test #f "m
3840: 79 72 75 6e 22 20 28 63 64 62 3a 72 65 6d 6f 74 yrun" (cdb:remot
3850: 65 2d 72 75 6e 20 64 62 3a 67 65 74 2d 72 75 6e e-run db:get-run
3860: 2d 6e 61 6d 65 2d 66 72 6f 6d 2d 69 64 20 23 66 -name-from-id #f
3870: 20 31 29 29 0a 0a 28 74 65 73 74 20 23 66 20 23 1))..(test #f #
3880: 66 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 f (cdb:remote-ru
3890: 6e 20 64 62 3a 72 6f 6c 6c 2d 75 70 2d 70 61 73 n db:roll-up-pas
38a0: 73 2d 66 61 69 6c 2d 63 6f 75 6e 74 73 20 23 66 s-fail-counts #f
38b0: 20 31 20 22 6e 61 64 61 22 20 22 22 20 22 50 41 1 "nada" "" "PA
38c0: 53 53 22 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d SS"))..;;=======
38d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
38e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
38f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3900: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
3910: 3b 3b 20 52 20 45 20 4d 20 4f 20 54 20 45 20 20 ;; R E M O T E
3920: 20 43 20 41 20 4c 20 4c 20 53 20 0a 3b 3b 3d 3d C A L L S .;;==
3930: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3940: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3950: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3960: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3970: 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 73 74 ====..(define st
3980: 61 72 74 2d 77 61 69 74 20 28 63 75 72 72 65 6e art-wait (curren
3990: 74 2d 73 65 63 6f 6e 64 73 29 29 0a 28 70 72 69 t-seconds)).(pri
39a0: 6e 74 20 22 53 74 61 72 74 69 6e 67 20 69 6e 74 nt "Starting int
39b0: 65 6e 73 69 76 65 20 63 61 63 68 65 20 61 6e 64 ensive cache and
39c0: 20 72 70 63 20 74 65 73 74 22 29 0a 28 66 6f 72 rpc test").(for
39d0: 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 70 -each (lambda (p
39e0: 61 72 61 6d 73 29 0a 09 20 20 20 20 28 70 72 69 arams).. (pri
39f0: 6e 74 20 22 49 6e 74 65 6e 73 69 76 65 3a 20 70 nt "Intensive: p
3a00: 61 72 61 6d 73 3d 22 20 70 61 72 61 6d 73 29 0a arams=" params).
3a10: 09 20 20 20 20 28 63 64 62 3a 74 65 73 74 73 2d . (cdb:tests-
3a20: 72 65 67 69 73 74 65 72 2d 74 65 73 74 20 2a 72 register-test *r
3a30: 75 6e 72 65 6d 6f 74 65 2a 20 31 20 28 63 6f 6e unremote* 1 (con
3a40: 63 20 22 74 65 73 74 22 20 28 72 61 6e 64 6f 6d c "test" (random
3a50: 20 32 30 29 29 20 22 22 29 0a 09 20 20 20 20 28 20)) "").. (
3a60: 61 70 70 6c 79 20 63 64 62 3a 74 65 73 74 2d 73 apply cdb:test-s
3a70: 65 74 2d 73 74 61 74 75 73 2d 73 74 61 74 65 20 et-status-state
3a80: 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 74 65 73 74 *runremote* test
3a90: 2d 69 64 20 70 61 72 61 6d 73 29 0a 09 20 20 20 -id params)..
3aa0: 20 28 63 64 62 3a 70 61 73 73 2d 66 61 69 6c 2d (cdb:pass-fail-
3ab0: 63 6f 75 6e 74 73 20 2a 72 75 6e 72 65 6d 6f 74 counts *runremot
3ac0: 65 2a 20 74 65 73 74 2d 69 64 20 28 72 61 6e 64 e* test-id (rand
3ad0: 6f 6d 20 31 30 30 29 20 28 72 61 6e 64 6f 6d 20 om 100) (random
3ae0: 31 30 30 29 29 0a 09 20 20 20 20 28 63 64 62 3a 100)).. (cdb:
3af0: 74 65 73 74 2d 72 6f 6c 6c 75 70 2d 74 65 73 74 test-rollup-test
3b00: 5f 64 61 74 61 2d 70 61 73 73 2d 66 61 69 6c 20 _data-pass-fail
3b10: 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 74 65 73 74 *runremote* test
3b20: 2d 69 64 29 0a 09 20 20 20 20 28 63 64 62 3a 72 -id).. (cdb:r
3b30: 6f 6c 6c 2d 75 70 2d 70 61 73 73 2d 66 61 69 6c oll-up-pass-fail
3b40: 2d 63 6f 75 6e 74 73 20 2a 72 75 6e 72 65 6d 6f -counts *runremo
3b50: 74 65 2a 20 31 20 22 74 65 73 74 31 22 20 22 22 te* 1 "test1" ""
3b60: 20 28 63 61 64 72 20 70 61 72 61 6d 73 29 29 0a (cadr params)).
3b70: 09 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 . (thread-sle
3b80: 65 70 21 20 30 2e 30 31 29 29 20 3b 3b 20 63 61 ep! 0.01)) ;; ca
3b90: 63 68 65 20 6f 72 64 65 72 69 6e 67 20 67 72 61 che ordering gra
3ba0: 6e 75 6c 61 72 69 74 79 20 69 73 20 61 74 20 74 nularity is at t
3bb0: 68 65 20 73 65 63 6f 6e 64 20 6c 65 76 65 6c 2e he second level.
3bc0: 20 53 68 6f 75 6c 64 20 72 65 61 6c 6c 79 20 62 Should really b
3bd0: 65 20 61 74 20 74 68 65 20 6d 73 20 6c 65 76 65 e at the ms leve
3be0: 6c 0a 09 20 20 27 28 28 22 43 4f 4d 50 4c 45 54 l.. '(("COMPLET
3bf0: 45 44 22 20 20 20 20 22 50 41 53 53 22 20 23 66 ED" "PASS" #f
3c00: 29 0a 09 20 20 20 20 28 22 4e 4f 54 5f 53 54 41 ).. ("NOT_STA
3c10: 52 54 45 44 22 20 20 22 46 41 49 4c 22 20 22 4a RTED" "FAIL" "J
3c20: 75 73 74 20 74 65 73 74 69 6e 67 22 29 0a 09 20 ust testing")..
3c30: 20 20 20 28 22 4e 4f 54 5f 53 54 41 52 54 45 44 ("NOT_STARTED
3c40: 22 20 20 22 46 41 49 4c 22 20 22 4a 75 73 74 20 " "FAIL" "Just
3c50: 74 65 73 74 69 6e 67 22 29 0a 09 20 20 20 20 28 testing").. (
3c60: 22 4e 4f 54 5f 53 54 41 52 54 45 44 22 20 20 22 "NOT_STARTED" "
3c70: 46 41 49 4c 22 20 22 4a 75 73 74 20 74 65 73 74 FAIL" "Just test
3c80: 69 6e 67 22 29 0a 09 20 20 20 20 28 22 43 4f 4d ing").. ("COM
3c90: 50 4c 45 54 45 44 22 20 20 20 20 22 50 41 53 53 PLETED" "PASS
3ca0: 22 20 23 66 29 0a 09 20 20 20 20 28 22 4e 4f 54 " #f).. ("NOT
3cb0: 5f 53 54 41 52 54 45 44 22 20 20 22 46 41 49 4c _STARTED" "FAIL
3cc0: 22 20 22 4a 75 73 74 20 74 65 73 74 69 6e 67 22 " "Just testing"
3cd0: 29 0a 09 20 20 20 20 28 22 4b 49 4c 4c 45 44 22 ).. ("KILLED"
3ce0: 20 20 20 20 20 20 20 22 55 4e 4b 4e 4f 57 4e 22 "UNKNOWN"
3cf0: 20 22 4d 6f 72 65 20 74 65 73 74 69 6e 67 22 29 "More testing")
3d00: 0a 09 20 20 20 20 28 22 4e 4f 54 5f 53 54 41 52 .. ("NOT_STAR
3d10: 54 45 44 22 20 20 22 46 41 49 4c 22 20 22 4a 75 TED" "FAIL" "Ju
3d20: 73 74 20 74 65 73 74 69 6e 67 22 29 0a 09 20 20 st testing")..
3d30: 20 20 28 22 4e 4f 54 5f 53 54 41 52 54 45 44 22 ("NOT_STARTED"
3d40: 20 20 22 46 41 49 4c 22 20 22 4a 75 73 74 20 74 "FAIL" "Just t
3d50: 65 73 74 69 6e 67 22 29 0a 09 20 20 20 20 28 22 esting").. ("
3d60: 43 4f 4d 50 4c 45 54 45 44 22 20 20 20 20 22 50 COMPLETED" "P
3d70: 41 53 53 22 20 23 66 29 0a 09 20 20 20 20 28 22 ASS" #f).. ("
3d80: 4e 4f 54 5f 53 54 41 52 54 45 44 22 20 20 22 46 NOT_STARTED" "F
3d90: 41 49 4c 22 20 22 4a 75 73 74 20 74 65 73 74 69 AIL" "Just testi
3da0: 6e 67 22 29 0a 09 20 20 20 20 28 22 4e 4f 54 5f ng").. ("NOT_
3db0: 53 54 41 52 54 45 44 22 20 20 22 46 41 49 4c 22 STARTED" "FAIL"
3dc0: 20 22 4a 75 73 74 20 74 65 73 74 69 6e 67 22 29 "Just testing")
3dd0: 0a 09 20 20 20 20 28 22 4b 49 4c 4c 45 44 22 20 .. ("KILLED"
3de0: 20 20 20 20 20 20 22 55 4e 4b 4e 4f 57 4e 22 20 "UNKNOWN"
3df0: 22 4d 6f 72 65 20 74 65 73 74 69 6e 67 22 29 0a "More testing").
3e00: 09 20 20 20 20 28 22 4e 4f 54 5f 53 54 41 52 54 . ("NOT_START
3e10: 45 44 22 20 20 22 46 41 49 4c 22 20 22 4a 75 73 ED" "FAIL" "Jus
3e20: 74 20 74 65 73 74 69 6e 67 22 29 0a 09 20 20 20 t testing")..
3e30: 20 28 22 43 4f 4d 50 4c 45 54 45 44 22 20 20 20 ("COMPLETED"
3e40: 20 22 50 41 53 53 22 20 23 66 29 0a 09 20 20 20 "PASS" #f)..
3e50: 20 28 22 4e 4f 54 5f 53 54 41 52 54 45 44 22 20 ("NOT_STARTED"
3e60: 20 22 46 41 49 4c 22 20 22 4a 75 73 74 20 74 65 "FAIL" "Just te
3e70: 73 74 69 6e 67 22 29 0a 09 20 20 20 20 28 22 4b sting").. ("K
3e80: 49 4c 4c 45 44 22 20 20 20 20 20 20 20 22 55 4e ILLED" "UN
3e90: 4b 4e 4f 57 4e 22 20 22 4d 6f 72 65 20 74 65 73 KNOWN" "More tes
3ea0: 74 69 6e 67 22 29 0a 09 20 20 20 20 28 22 4e 4f ting").. ("NO
3eb0: 54 5f 53 54 41 52 54 45 44 22 20 20 22 46 41 49 T_STARTED" "FAI
3ec0: 4c 22 20 22 4a 75 73 74 20 74 65 73 74 69 6e 67 L" "Just testing
3ed0: 22 29 0a 09 20 20 20 20 28 22 4e 4f 54 5f 53 54 ").. ("NOT_ST
3ee0: 41 52 54 45 44 22 20 20 22 46 41 49 4c 22 20 22 ARTED" "FAIL" "
3ef0: 4a 75 73 74 20 74 65 73 74 69 6e 67 22 29 0a 09 Just testing")..
3f00: 20 20 20 20 28 22 43 4f 4d 50 4c 45 54 45 44 22 ("COMPLETED"
3f10: 20 20 20 20 22 50 41 53 53 22 20 23 66 29 0a 09 "PASS" #f)..
3f20: 20 20 20 20 28 22 4e 4f 54 5f 53 54 41 52 54 45 ("NOT_STARTE
3f30: 44 22 20 20 22 46 41 49 4c 22 20 22 4a 75 73 74 D" "FAIL" "Just
3f40: 20 74 65 73 74 69 6e 67 22 29 0a 09 20 20 20 20 testing")..
3f50: 28 22 4e 4f 54 5f 53 54 41 52 54 45 44 22 20 20 ("NOT_STARTED"
3f60: 22 46 41 49 4c 22 20 22 4a 75 73 74 20 74 65 73 "FAIL" "Just tes
3f70: 74 69 6e 67 22 29 0a 09 20 20 20 20 28 22 4b 49 ting").. ("KI
3f80: 4c 4c 45 44 22 20 20 20 20 20 20 20 22 55 4e 4b LLED" "UNK
3f90: 4e 4f 57 4e 22 20 22 4d 6f 72 65 20 74 65 73 74 NOWN" "More test
3fa0: 69 6e 67 22 29 0a 09 20 20 20 20 28 22 4e 4f 54 ing").. ("NOT
3fb0: 5f 53 54 41 52 54 45 44 22 20 20 22 46 41 49 4c _STARTED" "FAIL
3fc0: 22 20 22 4a 75 73 74 20 74 65 73 74 69 6e 67 22 " "Just testing"
3fd0: 29 0a 09 20 20 20 20 28 22 43 4f 4d 50 4c 45 54 ).. ("COMPLET
3fe0: 45 44 22 20 20 20 20 22 50 41 53 53 22 20 23 66 ED" "PASS" #f
3ff0: 29 0a 09 20 20 20 20 28 22 4e 4f 54 5f 53 54 41 ).. ("NOT_STA
4000: 52 54 45 44 22 20 20 22 46 41 49 4c 22 20 22 4a RTED" "FAIL" "J
4010: 75 73 74 20 74 65 73 74 69 6e 67 22 29 0a 09 20 ust testing")..
4020: 20 20 20 28 22 4e 4f 54 5f 53 54 41 52 54 45 44 ("NOT_STARTED
4030: 22 20 20 22 46 41 49 4c 22 20 22 4a 75 73 74 20 " "FAIL" "Just
4040: 74 65 73 74 69 6e 67 22 29 0a 09 20 20 20 20 28 testing").. (
4050: 22 4b 49 4c 4c 45 44 22 20 20 20 20 20 20 20 22 "KILLED" "
4060: 55 4e 4b 4e 4f 57 4e 22 20 22 4d 6f 72 65 20 74 UNKNOWN" "More t
4070: 65 73 74 69 6e 67 22 29 0a 09 20 20 20 20 28 22 esting").. ("
4080: 4e 4f 54 5f 53 54 41 52 54 45 44 22 20 20 22 46 NOT_STARTED" "F
4090: 41 49 4c 22 20 22 4a 75 73 74 20 74 65 73 74 69 AIL" "Just testi
40a0: 6e 67 22 29 0a 09 20 20 20 20 28 22 4e 4f 54 5f ng").. ("NOT_
40b0: 53 54 41 52 54 45 44 22 20 20 22 46 41 49 4c 22 STARTED" "FAIL"
40c0: 20 22 4a 75 73 74 20 74 65 73 74 69 6e 67 22 29 "Just testing")
40d0: 0a 09 20 20 20 20 28 22 43 4f 4d 50 4c 45 54 45 .. ("COMPLETE
40e0: 44 22 20 20 20 20 22 50 41 53 53 22 20 23 66 29 D" "PASS" #f)
40f0: 0a 09 20 20 20 20 28 22 4e 4f 54 5f 53 54 41 52 .. ("NOT_STAR
4100: 54 45 44 22 20 20 22 46 41 49 4c 22 20 22 4a 75 TED" "FAIL" "Ju
4110: 73 74 20 74 65 73 74 69 6e 67 22 29 0a 09 20 20 st testing")..
4120: 20 20 28 22 4b 49 4c 4c 45 44 22 20 20 20 20 20 ("KILLED"
4130: 20 20 22 55 4e 4b 4e 4f 57 4e 22 20 22 4d 6f 72 "UNKNOWN" "Mor
4140: 65 20 74 65 73 74 69 6e 67 22 29 0a 09 20 20 20 e testing")..
4150: 20 28 22 4e 4f 54 5f 53 54 41 52 54 45 44 22 20 ("NOT_STARTED"
4160: 20 22 46 41 49 4c 22 20 22 4a 75 73 74 20 74 65 "FAIL" "Just te
4170: 73 74 69 6e 67 22 29 0a 09 20 20 20 20 28 22 4e sting").. ("N
4180: 4f 54 5f 53 54 41 52 54 45 44 22 20 20 22 46 41 OT_STARTED" "FA
4190: 49 4c 22 20 22 4a 75 73 74 20 74 65 73 74 69 6e IL" "Just testin
41a0: 67 22 29 0a 09 20 20 20 20 28 22 43 4f 4d 50 4c g").. ("COMPL
41b0: 45 54 45 44 22 20 20 20 20 22 50 41 53 53 22 20 ETED" "PASS"
41c0: 23 66 29 0a 09 20 20 20 20 28 22 4e 4f 54 5f 53 #f).. ("NOT_S
41d0: 54 41 52 54 45 44 22 20 20 22 46 41 49 4c 22 20 TARTED" "FAIL"
41e0: 22 4a 75 73 74 20 74 65 73 74 69 6e 67 22 29 0a "Just testing").
41f0: 09 20 20 20 20 28 22 4b 49 4c 4c 45 44 22 20 20 . ("KILLED"
4200: 20 20 20 20 20 22 55 4e 4b 4e 4f 57 4e 22 20 22 "UNKNOWN" "
4210: 4d 6f 72 65 20 74 65 73 74 69 6e 67 22 29 0a 09 More testing")..
4220: 20 20 20 20 28 22 4b 49 4c 4c 45 44 22 20 20 20 ("KILLED"
4230: 20 20 20 20 22 55 4e 4b 4e 4f 57 4e 22 20 22 4d "UNKNOWN" "M
4240: 6f 72 65 20 74 65 73 74 69 6e 67 22 29 0a 09 20 ore testing")..
4250: 20 20 20 29 29 0a 0a 3b 3b 20 6e 6f 77 20 73 65 ))..;; now se
4260: 74 20 61 6c 6c 20 74 65 73 74 73 20 74 6f 20 63 t all tests to c
4270: 6f 6d 70 6c 65 74 65 64 0a 28 63 64 62 3a 66 6c ompleted.(cdb:fl
4280: 75 73 68 2d 71 75 65 75 65 20 2a 72 75 6e 72 65 ush-queue *runre
4290: 6d 6f 74 65 2a 29 0a 28 6c 65 74 20 28 28 74 65 mote*).(let ((te
42a0: 73 74 73 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d sts (cdb:remote-
42b0: 72 75 6e 20 64 62 3a 67 65 74 2d 74 65 73 74 73 run db:get-tests
42c0: 2d 66 6f 72 2d 72 75 6e 20 23 66 20 31 20 22 25 -for-run #f 1 "%
42d0: 22 20 27 28 29 20 27 28 29 29 29 29 0a 20 20 28 " '() '()))). (
42e0: 70 72 69 6e 74 20 22 53 65 74 74 69 6e 67 20 22 print "Setting "
42f0: 20 28 6c 65 6e 67 74 68 20 74 65 73 74 73 29 20 (length tests)
4300: 22 20 74 6f 20 43 4f 4d 50 4c 45 54 45 44 2f 50 " to COMPLETED/P
4310: 41 53 53 22 29 0a 20 20 28 66 6f 72 2d 65 61 63 ASS"). (for-eac
4320: 68 0a 20 20 20 28 6c 61 6d 62 64 61 20 28 74 65 h. (lambda (te
4330: 73 74 29 0a 20 20 20 20 20 28 63 64 62 3a 74 65 st). (cdb:te
4340: 73 74 2d 73 65 74 2d 73 74 61 74 75 73 2d 73 74 st-set-status-st
4350: 61 74 65 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 ate *runremote*
4360: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 (db:test-get-id
4370: 74 65 73 74 29 20 22 43 4f 4d 50 4c 45 54 45 44 test) "COMPLETED
4380: 22 20 22 50 41 53 53 22 20 22 46 6f 72 63 65 64 " "PASS" "Forced
4390: 20 70 61 73 73 22 29 29 0a 20 20 20 74 65 73 74 pass")). test
43a0: 73 29 29 0a 0a 3b 3b 20 28 70 72 6f 63 65 73 73 s))..;; (process
43b0: 2d 77 61 69 74 20 73 65 72 76 65 72 2d 70 69 64 -wait server-pid
43c0: 29 0a 3b 3b 20 28 74 65 73 74 20 22 53 65 72 76 ).;; (test "Serv
43d0: 65 72 20 77 61 69 74 20 74 69 6d 65 22 20 23 74 er wait time" #t
43e0: 20 28 6c 65 74 20 28 28 72 75 6e 2d 64 65 6c 74 (let ((run-delt
43f0: 61 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 a (- (current-se
4400: 63 6f 6e 64 73 29 20 73 74 61 72 74 2d 77 61 69 conds) start-wai
4410: 74 29 29 29 0a 3b 3b 20 09 09 09 20 20 20 20 20 t))).;; ...
4420: 20 28 70 72 69 6e 74 20 22 53 65 72 76 65 72 20 (print "Server
4430: 72 61 6e 20 66 6f 72 20 22 20 72 75 6e 2d 64 65 ran for " run-de
4440: 6c 74 61 20 22 20 73 65 63 6f 6e 64 73 22 29 0a lta " seconds").
4450: 3b 3b 20 09 09 09 20 20 20 20 20 20 28 3e 20 72 ;; ... (> r
4460: 75 6e 2d 64 65 6c 74 61 20 32 30 29 29 29 0a 0a un-delta 20)))..
4470: 28 74 65 73 74 20 22 52 6f 6c 6c 75 70 20 74 68 (test "Rollup th
4480: 65 20 72 75 6e 28 73 29 22 20 23 74 20 28 62 65 e run(s)" #t (be
4490: 67 69 6e 0a 09 09 09 20 20 20 20 20 20 20 28 72 gin.... (r
44a0: 75 6e 73 3a 72 6f 6c 6c 75 70 2d 72 75 6e 20 6b uns:rollup-run k
44b0: 65 79 73 20 28 6b 65 79 73 2d 3e 61 6c 69 73 74 eys (keys->alist
44c0: 20 6b 65 79 73 20 22 6e 61 22 29 20 22 72 6f 6c keys "na") "rol
44d0: 6c 75 70 22 20 22 6d 61 74 74 22 29 0a 09 09 09 lup" "matt")....
44e0: 20 20 20 20 20 20 20 23 74 29 29 0a 0a 28 68 61 #t))..(ha
44f0: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 61 72 sh-table-set! ar
4500: 67 73 3a 61 72 67 2d 68 61 73 68 20 22 3a 72 75 gs:arg-hash ":ru
4510: 6e 6e 61 6d 65 22 20 22 25 22 29 0a 0a 28 74 65 nname" "%")..(te
4520: 73 74 20 22 52 65 6d 6f 76 65 20 74 68 65 20 72 st "Remove the r
4530: 6f 6c 6c 75 70 20 72 75 6e 22 20 23 74 20 28 62 ollup run" #t (b
4540: 65 67 69 6e 20 28 6f 70 65 72 61 74 65 2d 6f 6e egin (operate-on
4550: 20 27 72 65 6d 6f 76 65 2d 72 75 6e 73 29 29 29 'remove-runs)))
4560: 0a 0a 28 70 72 69 6e 74 20 22 57 61 69 74 69 6e ..(print "Waitin
4570: 67 20 66 6f 72 20 73 65 72 76 65 72 20 74 6f 20 g for server to
4580: 62 65 20 64 6f 6e 65 2c 20 73 68 6f 75 6c 64 20 be done, should
4590: 62 65 20 61 62 6f 75 74 20 32 30 20 73 65 63 6f be about 20 seco
45a0: 6e 64 73 22 29 0a 28 74 65 73 74 20 22 73 65 72 nds").(test "ser
45b0: 76 65 72 20 73 74 6f 70 22 20 23 66 20 28 6c 65 ver stop" #f (le
45c0: 74 20 28 28 68 6f 73 74 6e 61 6d 65 20 28 63 61 t ((hostname (ca
45d0: 72 20 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 29 29 r *runremote*))
45e0: 0a 09 09 09 20 20 20 20 20 28 70 6f 72 74 20 20 .... (port
45f0: 20 20 20 28 63 61 64 72 20 2a 72 75 6e 72 65 6d (cadr *runrem
4600: 6f 74 65 2a 29 29 29 0a 09 09 09 20 28 74 61 73 ote*))).... (tas
4610: 6b 73 3a 6b 69 6c 6c 2d 73 65 72 76 65 72 20 23 ks:kill-server #
4620: 74 20 68 6f 73 74 6e 61 6d 65 20 70 6f 72 74 20 t hostname port
4630: 73 65 72 76 65 72 2d 70 69 64 20 27 68 74 74 70 server-pid 'http
4640: 29 0a 09 09 09 20 28 6f 70 65 6e 2d 72 75 6e 2d ).... (open-run-
4650: 63 6c 6f 73 65 20 74 61 73 6b 73 3a 67 65 74 2d close tasks:get-
4660: 62 65 73 74 2d 73 65 72 76 65 72 20 74 61 73 6b best-server task
4670: 73 3a 6f 70 65 6e 2d 64 62 29 29 29 0a 0a 3b 3b s:open-db)))..;;
4680: 20 28 63 64 62 3a 6b 69 6c 6c 2d 73 65 72 76 65 (cdb:kill-serve
4690: 72 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 29 0a 0a r *runremote*)..
46a0: 3b 3b 20 28 74 68 72 65 61 64 2d 6a 6f 69 6e 21 ;; (thread-join!
46b0: 20 74 68 31 20 74 68 32 20 74 68 33 29 0a 0a 3b th1 th2 th3)..;
46c0: 3b 20 41 44 44 20 4d 45 21 21 21 21 20 28 64 62 ; ADD ME!!!! (db
46d0: 3a 67 65 74 2d 70 72 65 72 65 71 73 2d 6e 6f 74 :get-prereqs-not
46e0: 2d 6d 65 74 20 2a 64 62 2a 20 31 20 27 28 22 72 -met *db* 1 '("r
46f0: 75 6e 66 69 72 73 74 22 29 20 22 22 20 6d 6f 64 unfirst") "" mod
4700: 65 3a 20 27 6e 6f 72 6d 61 6c 29 0a 3b 3b 20 41 e: 'normal).;; A
4710: 44 44 20 4d 45 21 21 21 21 20 28 72 64 62 3a 67 DD ME!!!! (rdb:g
4720: 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e et-tests-for-run
4730: 20 2a 64 62 2a 20 31 20 22 72 75 6e 66 69 72 73 *db* 1 "runfirs
4740: 74 22 20 23 66 20 27 28 29 20 27 28 29 29 0a t" #f '() '()).