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 37 2c right 2006-2017,
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 28 75 73 ===========..(us
0390: 65 20 66 6f 72 6d 61 74 20 74 79 70 65 64 2d 72 e format typed-r
03a0: 65 63 6f 72 64 73 29 20 3b 3b 20 52 41 44 54 20 ecords) ;; RADT
03b0: 3d 3e 20 70 75 72 70 6f 73 65 20 6f 66 20 6a 73 => purpose of js
03c0: 6f 6e 20 66 6f 72 6d 61 74 3f 3f 0a 0a 28 64 65 on format??..(de
03d0: 63 6c 61 72 65 20 28 75 6e 69 74 20 72 6d 74 29 clare (unit rmt)
03e0: 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 ).(declare (uses
03f0: 20 61 70 69 29 29 0a 28 64 65 63 6c 61 72 65 20 api)).(declare
0400: 28 75 73 65 73 20 68 74 74 70 2d 74 72 61 6e 73 (uses http-trans
0410: 70 6f 72 74 29 29 0a 28 64 65 63 6c 61 72 65 20 port)).(declare
0420: 28 75 73 65 73 20 63 6f 6d 6d 6f 6e 6d 6f 64 29 (uses commonmod)
0430: 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 ).(declare (uses
0440: 20 64 62 66 69 6c 65 29 29 0a 3b 3b 20 28 64 65 dbfile)).;; (de
0450: 63 6c 61 72 65 20 28 75 73 65 73 20 64 62 6d 65 clare (uses dbme
0460: 6d 6d 6f 64 29 29 0a 28 64 65 63 6c 61 72 65 20 mmod)).(declare
0470: 28 75 73 65 73 20 64 62 6d 6f 64 29 29 0a 28 64 (uses dbmod)).(d
0480: 65 63 6c 61 72 65 20 28 75 73 65 73 20 74 63 70 eclare (uses tcp
0490: 2d 74 72 61 6e 73 70 6f 72 74 6d 6f 64 29 29 0a -transportmod)).
04a0: 28 69 6e 63 6c 75 64 65 20 22 63 6f 6d 6d 6f 6e (include "common
04b0: 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a 3b _records.scm").;
04c0: 3b 20 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 ; (declare (uses
04d0: 20 72 6d 74 6d 6f 64 29 29 0a 0a 3b 3b 20 75 73 rmtmod))..;; us
04e0: 65 64 20 62 79 20 68 74 74 70 2d 74 72 61 6e 73 ed by http-trans
04f0: 70 6f 72 74 0a 28 69 6d 70 6f 72 74 20 64 62 66 port.(import dbf
0500: 69 6c 65 29 20 3b 3b 20 72 6d 74 6d 6f 64 29 0a ile) ;; rmtmod).
0510: 0a 28 69 6d 70 6f 72 74 20 63 6f 6d 6d 6f 6e 6d .(import commonm
0520: 6f 64 0a 3b 3b 20 09 64 62 6d 65 6d 6d 6f 64 0a od.;; .dbmemmod.
0530: 09 64 62 66 69 6c 65 0a 09 64 62 6d 6f 64 0a 09 .dbfile..dbmod..
0540: 74 63 70 2d 74 72 61 6e 73 70 6f 72 74 6d 6f 64 tcp-transportmod
0550: 29 0a 0a 3b 3b 20 68 74 74 70 20 2d 20 75 73 65 )..;; http - use
0560: 20 74 68 65 20 6f 6c 64 20 68 74 74 70 20 2b 20 the old http +
0570: 69 6e 20 2f 74 6d 70 20 64 62 0a 3b 3b 20 74 63 in /tmp db.;; tc
0580: 70 20 20 2d 20 75 73 65 20 74 63 70 20 74 72 61 p - use tcp tra
0590: 6e 73 70 6f 72 74 20 77 69 74 68 20 69 6e 6d 65 nsport with inme
05a0: 6d 20 64 62 0a 3b 3b 20 6e 66 73 20 20 2d 20 75 m db.;; nfs - u
05b0: 73 65 20 64 69 72 65 63 74 20 74 6f 20 64 69 73 se direct to dis
05c0: 6b 20 61 63 63 65 73 73 20 28 72 65 61 64 2d 6f k access (read-o
05d0: 6e 6c 79 29 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 nly).;;.(define
05e0: 72 6d 74 3a 74 72 61 6e 73 70 6f 72 74 2d 6d 6f rmt:transport-mo
05f0: 64 65 20 28 6d 61 6b 65 2d 70 61 72 61 6d 65 74 de (make-paramet
0600: 65 72 20 27 68 74 74 70 29 29 0a 3b 3b 0a 3b 3b er 'http)).;;.;;
0610: 20 54 48 45 53 45 20 41 52 45 20 41 4c 4c 20 43 THESE ARE ALL C
0620: 41 4c 4c 45 44 20 4f 4e 20 54 48 45 20 43 4c 49 ALLED ON THE CLI
0630: 45 4e 54 20 53 49 44 45 21 21 21 0a 3b 3b 0a 0a ENT SIDE!!!.;;..
0640: 3b 3b 20 67 65 6e 65 72 61 74 65 20 65 6e 74 72 ;; generate entr
0650: 69 65 73 20 66 6f 72 20 7e 2f 2e 6d 65 67 61 74 ies for ~/.megat
0660: 65 73 74 72 63 20 77 69 74 68 20 74 68 65 20 66 estrc with the f
0670: 6f 6c 6c 6f 77 69 6e 67 0a 3b 3b 0a 3b 3b 20 20 ollowing.;;.;;
0680: 67 72 65 70 20 64 65 66 69 6e 65 20 2e 2e 2f 72 grep define ../r
0690: 6d 74 2e 73 63 6d 20 7c 20 67 72 65 70 20 72 6d mt.scm | grep rm
06a0: 74 3a 20 7c 70 65 72 6c 20 2d 70 69 20 2d 65 20 t: |perl -pi -e
06b0: 27 73 2f 5c 28 64 65 66 69 6e 65 5c 73 2b 5c 28 's/\(define\s+\(
06c0: 28 5c 53 2b 29 5c 57 2e 2a 24 2f 5c 31 2f 27 7c (\S+)\W.*$/\1/'|
06d0: 73 6f 72 74 20 2d 75 0a 0a 3b 3b 3d 3d 3d 3d 3d sort -u..;;=====
06e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
06f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0700: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0710: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0720: 3d 0a 3b 3b 20 20 53 20 55 20 50 20 50 20 4f 20 =.;; S U P P O
0730: 52 20 54 20 20 20 46 20 55 20 4e 20 43 20 54 20 R T F U N C T
0740: 49 20 4f 20 4e 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d I O N S.;;======
0750: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0760: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0770: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0780: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0790: 0a 0a 3b 3b 20 69 66 20 61 20 73 65 72 76 65 72 ..;; if a server
07a0: 20 69 73 20 65 69 74 68 65 72 20 72 75 6e 6e 69 is either runni
07b0: 6e 67 20 6f 72 20 69 6e 20 74 68 65 20 70 72 6f ng or in the pro
07c0: 63 65 73 73 20 6f 66 20 73 74 61 72 74 69 6e 67 cess of starting
07d0: 20 63 61 6c 6c 20 63 6c 69 65 6e 74 3a 73 65 74 call client:set
07e0: 75 70 0a 3b 3b 20 65 6c 73 65 20 72 65 74 75 72 up.;; else retur
07f0: 6e 20 23 66 20 74 6f 20 6c 65 74 20 74 68 65 20 n #f to let the
0800: 63 61 6c 6c 69 6e 67 20 70 72 6f 63 20 6b 6e 6f calling proc kno
0810: 77 20 74 68 61 74 20 74 68 65 72 65 20 69 73 20 w that there is
0820: 6e 6f 20 73 65 72 76 65 72 20 61 76 61 69 6c 61 no server availa
0830: 62 6c 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 ble.;;.(define (
0840: 72 6d 74 3a 67 65 74 2d 63 6f 6e 6e 65 63 74 69 rmt:get-connecti
0850: 6f 6e 2d 69 6e 66 6f 20 61 72 65 61 70 61 74 68 on-info areapath
0860: 20 72 75 6e 72 65 6d 6f 74 65 29 20 3b 3b 20 54 runremote) ;; T
0870: 4f 44 4f 3a 20 70 75 73 68 20 61 72 65 61 70 61 ODO: push areapa
0880: 74 68 20 64 6f 77 6e 2e 0a 20 20 28 6c 65 74 2a th down.. (let*
0890: 20 28 28 63 69 6e 66 6f 20 20 20 20 20 28 69 66 ((cinfo (if
08a0: 20 28 61 6e 64 20 28 72 65 6d 6f 74 65 3f 20 72 (and (remote? r
08b0: 75 6e 72 65 6d 6f 74 65 29 0a 09 09 09 20 20 20 unremote)....
08c0: 20 20 28 72 65 6d 6f 74 65 2d 61 70 69 2d 75 72 (remote-api-ur
08d0: 6c 20 72 75 6e 72 65 6d 6f 74 65 29 29 20 3b 3b l runremote)) ;;
08e0: 20 77 65 20 68 61 76 65 20 61 20 63 6f 6e 6e 65 we have a conne
08f0: 63 74 69 6f 6e 0a 09 09 09 72 75 6e 72 65 6d 6f ction....runremo
0900: 74 65 0a 09 09 09 23 66 29 29 29 0a 20 20 20 20 te....#f))).
0910: 28 69 66 20 63 69 6e 66 6f 0a 09 63 69 6e 66 6f (if cinfo..cinfo
0920: 0a 09 28 69 66 20 28 73 65 72 76 65 72 3a 63 68 ..(if (server:ch
0930: 65 63 6b 2d 69 66 2d 72 75 6e 6e 69 6e 67 20 61 eck-if-running a
0940: 72 65 61 70 61 74 68 29 0a 09 20 20 20 20 28 63 reapath).. (c
0950: 6c 69 65 6e 74 3a 73 65 74 75 70 20 61 72 65 61 lient:setup area
0960: 70 61 74 68 20 72 75 6e 72 65 6d 6f 74 65 29 0a path runremote).
0970: 09 20 20 20 20 23 66 29 29 29 29 0a 0a 28 64 65 . #f))))..(de
0980: 66 69 6e 65 20 28 72 6d 74 3a 6f 6e 2d 68 6f 6d fine (rmt:on-hom
0990: 65 68 6f 73 74 3f 20 72 75 6e 72 65 6d 6f 74 65 ehost? runremote
09a0: 29 0a 20 20 28 6c 65 74 2a 20 28 28 68 68 2d 64 ). (let* ((hh-d
09b0: 61 74 20 28 72 65 6d 6f 74 65 2d 68 68 2d 64 61 at (remote-hh-da
09c0: 74 20 72 75 6e 72 65 6d 6f 74 65 29 29 29 0a 20 t runremote))).
09d0: 20 20 20 28 69 66 20 28 70 61 69 72 3f 20 68 68 (if (pair? hh
09e0: 2d 64 61 74 29 0a 09 28 63 64 72 20 68 68 2d 64 -dat)..(cdr hh-d
09f0: 61 74 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 at)..(begin.. (
0a00: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
0a10: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
0a20: 70 6f 72 74 2a 20 22 68 68 2d 64 61 74 3d 22 68 port* "hh-dat="h
0a30: 68 2d 64 61 74 29 0a 09 20 20 23 66 29 29 29 29 h-dat).. #f))))
0a40: 0a 0a 28 64 65 66 69 6e 65 20 28 6d 61 6b 65 2d ..(define (make-
0a50: 61 6e 64 2d 69 6e 69 74 2d 72 65 6d 6f 74 65 20 and-init-remote
0a60: 61 72 65 61 70 61 74 68 29 0a 20 20 20 28 63 61 areapath). (ca
0a70: 73 65 20 28 72 6d 74 3a 74 72 61 6e 73 70 6f 72 se (rmt:transpor
0a80: 74 2d 6d 6f 64 65 29 0a 20 20 20 20 20 28 28 68 t-mode). ((h
0a90: 74 74 70 29 28 6d 61 6b 65 2d 72 65 6d 6f 74 65 ttp)(make-remote
0aa0: 29 29 0a 20 20 20 20 20 28 28 74 63 70 29 20 28 )). ((tcp) (
0ab0: 74 74 3a 6d 61 6b 65 2d 72 65 6d 6f 74 65 20 61 tt:make-remote a
0ac0: 72 65 61 70 61 74 68 29 29 0a 20 20 20 20 20 28 reapath)). (
0ad0: 65 6c 73 65 20 23 66 29 29 29 0a 0a 3b 3b 3d 3d else #f)))..;;==
0ae0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0af0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0b00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0b10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0b20: 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 2a 73 ====..(define *s
0b30: 65 6e 64 2d 72 65 63 65 69 76 65 2d 6d 75 74 65 end-receive-mute
0b40: 78 2a 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 x* (make-mutex))
0b50: 20 3b 3b 20 73 68 6f 75 6c 64 20 68 61 76 65 20 ;; should have
0b60: 73 65 70 61 72 61 74 65 20 6d 75 74 65 78 20 70 separate mutex p
0b70: 65 72 20 72 75 6e 2d 69 64 0a 0a 3b 3b 20 52 41 er run-id..;; RA
0b80: 20 3d 3e 20 65 2e 67 2e 20 75 73 61 67 65 20 28 => e.g. usage (
0b90: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
0ba0: 20 27 67 65 74 2d 76 61 72 20 23 66 20 28 6c 69 'get-var #f (li
0bb0: 73 74 20 76 61 72 6e 61 6d 65 29 29 0a 3b 3b 0a st varname)).;;.
0bc0: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 73 65 6e (define (rmt:sen
0bd0: 64 2d 72 65 63 65 69 76 65 20 63 6d 64 20 72 69 d-receive cmd ri
0be0: 64 20 70 61 72 61 6d 73 20 23 21 6b 65 79 20 28 d params #!key (
0bf0: 61 74 74 65 6d 70 74 6e 75 6d 20 31 29 28 61 72 attemptnum 1)(ar
0c00: 65 61 2d 64 61 74 20 23 66 29 29 20 3b 3b 20 73 ea-dat #f)) ;; s
0c10: 74 61 72 74 20 61 74 74 65 6d 70 74 6e 75 6d 20 tart attemptnum
0c20: 61 74 20 31 20 73 6f 20 74 68 65 20 6d 6f 64 75 at 1 so the modu
0c30: 6c 6f 20 62 65 6c 6f 77 20 77 6f 72 6b 73 20 61 lo below works a
0c40: 73 20 65 78 70 65 63 74 65 64 0a 20 20 28 61 73 s expected. (as
0c50: 73 65 72 74 20 2a 74 6f 70 70 61 74 68 2a 20 22 sert *toppath* "
0c60: 46 41 54 41 4c 3a 20 72 6d 74 3a 73 65 6e 64 2d FATAL: rmt:send-
0c70: 72 65 63 65 69 76 65 20 63 61 6c 6c 65 64 20 77 receive called w
0c80: 69 74 68 20 2a 74 6f 70 70 61 74 68 2a 20 6e 6f ith *toppath* no
0c90: 74 20 73 65 74 2e 22 29 0a 20 20 28 69 66 20 28 t set."). (if (
0ca0: 3e 20 61 74 74 65 6d 70 74 6e 75 6d 20 32 29 0a > attemptnum 2).
0cb0: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
0cc0: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
0cd0: 67 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 61 g-port* "INFO: a
0ce0: 74 74 65 6d 70 74 6e 75 6d 20 69 6e 20 72 6d 74 ttemptnum in rmt
0cf0: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 69 73 :send-receive is
0d00: 20 22 20 61 74 74 65 6d 70 74 6e 75 6d 29 29 0a " attemptnum)).
0d10: 20 20 0a 20 20 28 63 6f 6e 64 0a 20 20 20 28 28 . (cond. ((
0d20: 3e 20 61 74 74 65 6d 70 74 6e 75 6d 20 32 29 20 > attemptnum 2)
0d30: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 (thread-sleep! 0
0d40: 2e 30 35 29 29 0a 20 20 20 28 28 3e 20 61 74 74 .05)). ((> att
0d50: 65 6d 70 74 6e 75 6d 20 31 30 29 20 28 74 68 72 emptnum 10) (thr
0d60: 65 61 64 2d 73 6c 65 65 70 21 20 30 2e 35 29 29 ead-sleep! 0.5))
0d70: 0a 20 20 20 28 28 3e 20 61 74 74 65 6d 70 74 6e . ((> attemptn
0d80: 75 6d 20 32 30 29 20 28 74 68 72 65 61 64 2d 73 um 20) (thread-s
0d90: 6c 65 65 70 21 20 31 29 29 29 0a 0a 20 20 3b 3b leep! 1))).. ;;
0da0: 20 49 27 6d 20 74 75 72 6e 69 6e 67 20 74 68 69 I'm turning thi
0db0: 73 20 6f 66 66 2c 20 69 74 20 6d 61 79 20 6d 61 s off, it may ma
0dc0: 6b 65 20 73 65 6e 73 65 20 74 6f 20 6d 6f 76 65 ke sense to move
0dd0: 20 69 74 0a 20 20 3b 3b 20 69 6e 74 6f 20 68 74 it. ;; into ht
0de0: 74 70 2d 74 72 61 6e 73 70 6f 72 74 2d 68 61 6e tp-transport-han
0df0: 64 6c 65 72 0a 20 20 28 69 66 20 28 61 6e 64 20 dler. (if (and
0e00: 28 3e 20 61 74 74 65 6d 70 74 6e 75 6d 20 35 29 (> attemptnum 5)
0e10: 20 28 3d 20 30 20 28 6d 6f 64 75 6c 6f 20 61 74 (= 0 (modulo at
0e20: 74 65 6d 70 74 6e 75 6d 20 31 35 29 29 29 20 20 temptnum 15)))
0e30: 0a 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 28 . (begin..(
0e40: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
0e50: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
0e60: 20 22 45 52 52 4f 52 3a 20 63 61 6e 27 74 20 63 "ERROR: can't c
0e70: 6f 6e 6e 65 63 74 20 74 6f 20 73 65 72 76 65 72 onnect to server
0e80: 2c 20 74 72 79 69 6e 67 20 74 6f 20 73 74 61 72 , trying to star
0e90: 74 20 61 20 73 65 72 76 65 72 2e 22 29 0a 09 28 t a server.")..(
0ea0: 73 65 72 76 65 72 3a 72 75 6e 20 2a 74 6f 70 70 server:run *topp
0eb0: 61 74 68 2a 29 0a 09 28 74 68 72 65 61 64 2d 73 ath*)..(thread-s
0ec0: 6c 65 65 70 21 20 33 29 29 29 0a 20 20 0a 20 20 leep! 3))). .
0ed0: 3b 3b 20 31 2e 20 63 68 65 63 6b 20 69 66 20 73 ;; 1. check if s
0ee0: 65 72 76 65 72 20 69 73 20 73 74 61 72 74 65 64 erver is started
0ef0: 20 49 46 46 20 63 6d 64 20 69 73 20 61 20 77 72 IFF cmd is a wr
0f00: 69 74 65 20 4f 52 20 69 66 20 77 65 20 61 72 65 ite OR if we are
0f10: 20 6e 6f 74 20 6f 6e 20 74 68 65 20 68 6f 6d 65 not on the home
0f20: 68 6f 73 74 2c 20 73 74 6f 72 65 20 69 6e 20 72 host, store in r
0f30: 75 6e 72 65 6d 6f 74 65 0a 20 20 3b 3b 20 32 2e unremote. ;; 2.
0f40: 20 63 68 65 63 6b 20 74 68 65 20 61 67 65 20 6f check the age o
0f50: 66 20 74 68 65 20 63 6f 6e 6e 65 63 74 69 6f 6e f the connection
0f60: 73 2e 20 72 65 66 72 65 73 68 20 74 68 65 20 63 s. refresh the c
0f70: 6f 6e 6e 65 63 74 69 6f 6e 20 69 66 20 69 74 20 onnection if it
0f80: 69 73 20 6f 6c 64 65 72 20 74 68 61 6e 20 74 69 is older than ti
0f90: 6d 65 6f 75 74 2d 32 30 20 73 65 63 6f 6e 64 73 meout-20 seconds
0fa0: 2e 0a 20 20 3b 3b 20 33 2e 20 64 6f 20 74 68 65 .. ;; 3. do the
0fb0: 20 71 75 65 72 79 2c 20 69 66 20 6f 6e 20 68 6f query, if on ho
0fc0: 6d 65 68 6f 73 74 20 75 73 65 20 6c 6f 63 61 6c mehost use local
0fd0: 20 61 63 63 65 73 73 0a 20 20 3b 3b 0a 20 20 28 access. ;;. (
0fe0: 6c 65 74 2a 20 28 28 73 74 61 72 74 2d 74 69 6d let* ((start-tim
0ff0: 65 20 20 20 20 28 63 75 72 72 65 6e 74 2d 73 65 e (current-se
1000: 63 6f 6e 64 73 29 29 20 3b 3b 20 73 6e 61 70 73 conds)) ;; snaps
1010: 68 6f 74 20 74 69 6d 65 20 73 6f 20 61 6c 6c 20 hot time so all
1020: 75 73 65 20 63 61 73 65 73 20 67 65 74 20 73 61 use cases get sa
1030: 6d 65 20 76 61 6c 75 65 0a 20 20 20 20 20 20 20 me value.
1040: 20 20 28 61 72 65 61 70 61 74 68 20 20 20 20 20 (areapath
1050: 20 2a 74 6f 70 70 61 74 68 2a 29 3b 3b 20 54 4f *toppath*);; TO
1060: 44 4f 20 2d 20 72 65 73 6f 6c 76 65 20 66 72 6f DO - resolve fro
1070: 6d 20 64 62 73 74 72 75 63 74 20 74 6f 20 62 65 m dbstruct to be
1080: 20 63 6f 6d 70 61 74 69 62 6c 65 20 77 69 74 68 compatible with
1090: 20 6d 75 6c 74 69 70 6c 65 20 61 72 65 61 73 0a multiple areas.
10a0: 09 20 28 72 75 6e 72 65 6d 6f 74 65 20 20 20 20 . (runremote
10b0: 20 28 6f 72 20 61 72 65 61 2d 64 61 74 0a 09 09 (or area-dat...
10c0: 09 20 20 20 20 2a 72 75 6e 72 65 6d 6f 74 65 2a . *runremote*
10d0: 29 29 0a 20 20 20 20 20 20 20 20 20 28 61 74 74 )). (att
10e0: 65 6d 70 74 6e 75 6d 20 20 20 20 28 2b 20 31 20 emptnum (+ 1
10f0: 61 74 74 65 6d 70 74 6e 75 6d 29 29 0a 09 20 28 attemptnum)).. (
1100: 72 65 61 64 6f 6e 6c 79 2d 6d 6f 64 65 20 28 72 readonly-mode (r
1110: 6d 74 6d 6f 64 3a 63 61 6c 63 2d 72 6f 2d 6d 6f mtmod:calc-ro-mo
1120: 64 65 20 72 75 6e 72 65 6d 6f 74 65 20 2a 74 6f de runremote *to
1130: 70 70 61 74 68 2a 29 29 0a 09 20 28 74 65 73 74 ppath*)).. (test
1140: 73 75 69 74 65 20 20 20 20 20 28 63 6f 6d 6d 6f suite (commo
1150: 6e 3a 67 65 74 2d 74 65 73 74 73 75 69 74 65 2d n:get-testsuite-
1160: 6e 61 6d 65 29 29 0a 09 20 28 6d 74 65 78 65 20 name)).. (mtexe
1170: 20 20 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a (common:
1180: 66 69 6e 64 2d 6c 6f 63 61 6c 2d 6d 65 67 61 74 find-local-megat
1190: 65 73 74 29 29 29 0a 0a 20 20 20 20 28 63 61 73 est))).. (cas
11a0: 65 20 28 72 6d 74 3a 74 72 61 6e 73 70 6f 72 74 e (rmt:transport
11b0: 2d 6d 6f 64 65 29 0a 20 20 20 20 20 20 28 28 68 -mode). ((h
11c0: 74 74 70 29 28 68 74 74 70 2d 74 72 61 6e 73 70 ttp)(http-transp
11d0: 6f 72 74 2d 68 61 6e 64 6c 65 72 20 72 75 6e 72 ort-handler runr
11e0: 65 6d 6f 74 65 20 63 6d 64 20 72 69 64 20 70 61 emote cmd rid pa
11f0: 72 61 6d 73 20 61 74 74 65 6d 70 74 6e 75 6d 20 rams attemptnum
1200: 61 72 65 61 2d 64 61 74 20 61 72 65 61 70 61 74 area-dat areapat
1210: 68 20 72 65 61 64 6f 6e 6c 79 2d 6d 6f 64 65 29 h readonly-mode)
1220: 29 0a 20 20 20 20 20 20 28 28 74 63 70 29 20 28 ). ((tcp) (
1230: 74 63 70 2d 74 72 61 6e 73 70 6f 72 74 2d 68 61 tcp-transport-ha
1240: 6e 64 6c 65 72 20 20 72 75 6e 72 65 6d 6f 74 65 ndler runremote
1250: 20 63 6d 64 20 72 69 64 20 70 61 72 61 6d 73 20 cmd rid params
1260: 61 74 74 65 6d 70 74 6e 75 6d 20 61 72 65 61 2d attemptnum area-
1270: 64 61 74 20 61 72 65 61 70 61 74 68 20 72 65 61 dat areapath rea
1280: 64 6f 6e 6c 79 2d 6d 6f 64 65 20 74 65 73 74 73 donly-mode tests
1290: 75 69 74 65 20 6d 74 65 78 65 29 29 0a 20 20 20 uite mtexe)).
12a0: 20 20 20 28 28 6e 66 73 29 20 28 6e 66 73 3a 74 ((nfs) (nfs:t
12b0: 72 61 6e 73 70 6f 72 74 2d 68 61 6e 64 6c 65 72 ransport-handler
12c0: 20 20 72 75 6e 72 65 6d 6f 74 65 20 63 6d 64 20 runremote cmd
12d0: 72 69 64 20 70 61 72 61 6d 73 20 61 74 74 65 6d rid params attem
12e0: 70 74 6e 75 6d 20 61 72 65 61 2d 64 61 74 20 61 ptnum area-dat a
12f0: 72 65 61 70 61 74 68 20 72 65 61 64 6f 6e 6c 79 reapath readonly
1300: 2d 6d 6f 64 65 20 74 65 73 74 73 75 69 74 65 20 -mode testsuite
1310: 6d 74 65 78 65 29 29 0a 20 20 20 20 20 20 29 29 mtexe)). ))
1320: 29 0a 0a 28 64 65 66 69 6e 65 20 28 6e 66 73 3a )..(define (nfs:
1330: 74 72 61 6e 73 70 6f 72 74 2d 68 61 6e 64 6c 65 transport-handle
1340: 72 20 20 72 75 6e 72 65 6d 6f 74 65 20 63 6d 64 r runremote cmd
1350: 20 72 75 6e 2d 69 64 20 70 61 72 61 6d 73 20 61 run-id params a
1360: 74 74 65 6d 70 74 6e 75 6d 20 61 72 65 61 2d 64 ttemptnum area-d
1370: 61 74 20 61 72 65 61 70 61 74 68 20 72 65 61 64 at areapath read
1380: 6f 6e 6c 79 2d 6d 6f 64 65 20 74 65 73 74 73 75 only-mode testsu
1390: 69 74 65 20 6d 74 65 78 65 29 0a 20 20 28 6c 65 ite mtexe). (le
13a0: 74 2a 20 28 28 6b 65 79 73 20 20 20 20 20 28 63 t* ((keys (c
13b0: 6f 6d 6d 6f 6e 3a 67 65 74 2d 66 69 65 6c 64 73 ommon:get-fields
13c0: 20 2a 63 6f 6e 66 69 67 64 61 74 2a 29 29 0a 09 *configdat*))..
13d0: 20 28 64 62 73 74 72 75 63 74 20 28 64 62 6d 6f (dbstruct (dbmo
13e0: 64 3a 6e 66 73 2d 67 65 74 2d 64 62 73 74 72 75 d:nfs-get-dbstru
13f0: 63 74 20 72 75 6e 2d 69 64 20 6b 65 79 73 20 28 ct run-id keys (
1400: 64 62 66 69 6c 65 3a 64 62 2d 69 6e 69 74 2d 70 dbfile:db-init-p
1410: 72 6f 63 29 20 61 72 65 61 70 61 74 68 29 29 29 roc) areapath)))
1420: 0a 20 20 20 20 28 61 70 69 3a 64 69 73 70 61 74 . (api:dispat
1430: 63 68 2d 72 65 71 75 65 73 74 20 64 62 73 74 72 ch-request dbstr
1440: 75 63 74 20 63 6d 64 20 72 75 6e 2d 69 64 20 70 uct cmd run-id p
1450: 61 72 61 6d 73 29 29 29 0a 09 20 0a 28 64 65 66 arams))).. .(def
1460: 69 6e 65 20 28 74 63 70 2d 74 72 61 6e 73 70 6f ine (tcp-transpo
1470: 72 74 2d 68 61 6e 64 6c 65 72 20 72 75 6e 72 65 rt-handler runre
1480: 6d 6f 74 65 20 63 6d 64 20 72 75 6e 2d 69 64 20 mote cmd run-id
1490: 70 61 72 61 6d 73 20 61 74 74 65 6d 70 74 6e 75 params attemptnu
14a0: 6d 20 61 72 65 61 2d 64 61 74 20 61 72 65 61 70 m area-dat areap
14b0: 61 74 68 20 72 65 61 64 6f 6e 6c 79 2d 6d 6f 64 ath readonly-mod
14c0: 65 20 74 65 73 74 73 75 69 74 65 20 6d 74 65 78 e testsuite mtex
14d0: 65 29 0a 20 20 28 69 66 20 28 6e 6f 74 20 72 75 e). (if (not ru
14e0: 6e 72 65 6d 6f 74 65 29 0a 20 20 20 20 20 20 28 nremote). (
14f0: 6c 65 74 2a 20 28 28 6e 65 77 72 65 6d 6f 74 65 let* ((newremote
1500: 20 20 28 6d 61 6b 65 2d 61 6e 64 2d 69 6e 69 74 (make-and-init
1510: 2d 72 65 6d 6f 74 65 20 61 72 65 61 70 61 74 68 -remote areapath
1520: 29 29 29 0a 09 28 73 65 74 21 20 2a 72 75 6e 72 )))..(set! *runr
1530: 65 6d 6f 74 65 2a 20 6e 65 77 72 65 6d 6f 74 65 emote* newremote
1540: 29 0a 09 28 73 65 74 21 20 72 75 6e 72 65 6d 6f )..(set! runremo
1550: 74 65 20 6e 65 77 72 65 6d 6f 74 65 29 29 29 0a te newremote))).
1560: 20 20 28 6c 65 74 2a 20 28 28 64 62 66 6e 61 6d (let* ((dbfnam
1570: 65 20 28 63 6f 6e 63 20 28 64 62 66 69 6c 65 3a e (conc (dbfile:
1580: 72 75 6e 2d 69 64 2d 3e 64 62 6e 75 6d 20 72 75 run-id->dbnum ru
1590: 6e 2d 69 64 29 22 2e 64 62 22 29 29 29 20 3b 3b n-id)".db"))) ;;
15a0: 28 64 62 66 69 6c 65 3a 72 75 6e 2d 69 64 2d 3e (dbfile:run-id->
15b0: 70 61 74 68 20 61 72 65 61 70 61 74 68 20 72 75 path areapath ru
15c0: 6e 2d 69 64 29 29 29 0a 20 20 20 20 28 74 74 3a n-id))). (tt:
15d0: 68 61 6e 64 6c 65 72 20 72 75 6e 72 65 6d 6f 74 handler runremot
15e0: 65 20 63 6d 64 20 72 75 6e 2d 69 64 20 70 61 72 e cmd run-id par
15f0: 61 6d 73 20 61 74 74 65 6d 70 74 6e 75 6d 20 61 ams attemptnum a
1600: 72 65 61 2d 64 61 74 20 61 72 65 61 70 61 74 68 rea-dat areapath
1610: 20 72 65 61 64 6f 6e 6c 79 2d 6d 6f 64 65 20 64 readonly-mode d
1620: 62 66 6e 61 6d 65 20 74 65 73 74 73 75 69 74 65 bfname testsuite
1630: 20 6d 74 65 78 65 29 29 29 0a 09 0a 28 64 65 66 mtexe)))...(def
1640: 69 6e 65 20 28 68 74 74 70 2d 74 72 61 6e 73 70 ine (http-transp
1650: 6f 72 74 2d 68 61 6e 64 6c 65 72 20 72 75 6e 72 ort-handler runr
1660: 65 6d 6f 74 65 20 63 6d 64 20 72 69 64 20 70 61 emote cmd rid pa
1670: 72 61 6d 73 20 61 74 74 65 6d 70 74 6e 75 6d 20 rams attemptnum
1680: 61 72 65 61 2d 64 61 74 20 61 72 65 61 70 61 74 area-dat areapat
1690: 68 20 72 65 61 64 6f 6e 6c 79 2d 6d 6f 64 65 29 h readonly-mode)
16a0: 0a 20 20 3b 3b 20 64 6f 20 61 6c 6c 20 74 68 65 . ;; do all the
16b0: 20 70 72 65 70 20 6c 6f 63 6b 65 64 20 75 6e 64 prep locked und
16c0: 65 72 20 74 68 65 20 72 6d 74 2d 6d 75 74 65 78 er the rmt-mutex
16d0: 0a 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 . (mutex-lock!
16e0: 2a 72 6d 74 2d 6d 75 74 65 78 2a 29 0a 20 20 0a *rmt-mutex*). .
16f0: 20 20 3b 3b 20 65 6e 73 75 72 65 20 77 65 20 68 ;; ensure we h
1700: 61 76 65 20 61 20 72 65 63 6f 72 64 20 66 6f 72 ave a record for
1710: 20 6f 75 72 20 63 6f 6e 6e 65 63 74 69 6f 6e 20 our connection
1720: 66 6f 72 20 67 69 76 65 6e 20 61 72 65 61 0a 20 for given area.
1730: 20 28 69 66 20 28 6e 6f 74 20 72 75 6e 72 65 6d (if (not runrem
1740: 6f 74 65 29 20 20 20 20 20 20 20 20 20 20 20 20 ote)
1750: 20 20 20 20 20 20 20 3b 3b 20 63 61 6e 20 72 65 ;; can re
1760: 6d 6f 76 65 20 74 68 69 73 20 6f 6e 65 2e 20 73 move this one. s
1770: 68 6f 75 6c 64 20 6e 65 76 65 72 20 67 65 74 20 hould never get
1780: 68 65 72 65 2e 20 20 20 20 20 20 20 20 20 0a 20 here. .
1790: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 28 73 65 (begin..(se
17a0: 74 21 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 28 t! *runremote* (
17b0: 6d 61 6b 65 2d 61 6e 64 2d 69 6e 69 74 2d 72 65 make-and-init-re
17c0: 6d 6f 74 65 20 61 72 65 61 70 61 74 68 29 29 0a mote areapath)).
17d0: 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 (let* ((
17e0: 73 65 72 76 65 72 2d 69 6e 66 6f 20 28 72 65 6d server-info (rem
17f0: 6f 74 65 2d 73 65 72 76 65 72 2d 69 6e 66 6f 20 ote-server-info
1800: 2a 72 75 6e 72 65 6d 6f 74 65 2a 29 29 29 20 0a *runremote*))) .
1810: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 73 65 (if se
1820: 72 76 65 72 2d 69 6e 66 6f 0a 09 20 20 20 20 20 rver-info..
1830: 20 28 62 65 67 69 6e 0a 09 09 28 72 65 6d 6f 74 (begin...(remot
1840: 65 2d 73 65 72 76 65 72 2d 75 72 6c 2d 73 65 74 e-server-url-set
1850: 21 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 28 73 ! *runremote* (s
1860: 65 72 76 65 72 3a 72 65 63 6f 72 64 2d 3e 75 72 erver:record->ur
1870: 6c 20 73 65 72 76 65 72 2d 69 6e 66 6f 29 29 0a l server-info)).
1880: 09 09 28 72 65 6d 6f 74 65 2d 73 65 72 76 65 72 ..(remote-server
1890: 2d 69 64 2d 73 65 74 21 20 2a 72 75 6e 72 65 6d -id-set! *runrem
18a0: 6f 74 65 2a 20 28 73 65 72 76 65 72 3a 72 65 63 ote* (server:rec
18b0: 6f 72 64 2d 3e 69 64 20 73 65 72 76 65 72 2d 69 ord->id server-i
18c0: 6e 66 6f 29 29 29 29 29 20 20 0a 09 28 73 65 74 nfo))))) ..(set
18d0: 21 20 72 75 6e 72 65 6d 6f 74 65 20 20 20 2a 72 ! runremote *r
18e0: 75 6e 72 65 6d 6f 74 65 2a 29 29 29 20 3b 3b 20 unremote*))) ;;
18f0: 6e 65 77 20 72 75 6e 72 65 6d 6f 74 65 20 77 69 new runremote wi
1900: 6c 6c 20 63 6f 6d 65 20 66 72 6f 6d 20 74 68 69 ll come from thi
1910: 73 20 6f 6e 20 6e 65 78 74 20 69 74 65 72 61 74 s on next iterat
1920: 69 6f 6e 0a 0a 20 20 3b 3b 20 65 6e 73 75 72 65 ion.. ;; ensure
1930: 20 77 65 20 68 61 76 65 20 61 20 68 6f 6d 65 68 we have a homeh
1940: 6f 73 74 20 72 65 63 6f 72 64 0a 20 20 28 69 66 ost record. (if
1950: 20 28 6f 72 20 28 6e 6f 74 20 28 70 61 69 72 3f (or (not (pair?
1960: 20 28 72 65 6d 6f 74 65 2d 68 68 2d 64 61 74 20 (remote-hh-dat
1970: 72 75 6e 72 65 6d 6f 74 65 29 29 29 20 20 3b 3b runremote))) ;;
1980: 20 6e 6f 74 20 6f 6e 20 68 6f 6d 65 68 6f 73 74 not on homehost
1990: 0a 09 20 20 28 6e 6f 74 20 28 63 64 72 20 28 72 .. (not (cdr (r
19a0: 65 6d 6f 74 65 2d 68 68 2d 64 61 74 20 72 75 6e emote-hh-dat run
19b0: 72 65 6d 6f 74 65 29 29 29 29 20 20 20 3b 3b 20 remote)))) ;;
19c0: 6e 6f 74 20 6f 6e 20 68 6f 6d 65 68 6f 73 74 0a not on homehost.
19d0: 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c (thread-sl
19e0: 65 65 70 21 20 30 2e 31 29 20 3b 3b 20 73 69 6e eep! 0.1) ;; sin
19f0: 63 65 20 77 65 20 73 68 6f 75 6c 64 6e 27 74 20 ce we shouldn't
1a00: 67 65 74 20 68 65 72 65 2c 20 64 65 6c 61 79 20 get here, delay
1a10: 61 20 6c 69 74 74 6c 65 0a 20 20 20 20 20 20 28 a little. (
1a20: 6c 65 74 20 28 28 68 68 2d 64 61 74 61 20 28 73 let ((hh-data (s
1a30: 65 72 76 65 72 3a 63 68 6f 6f 73 65 2d 73 65 72 erver:choose-ser
1a40: 76 65 72 20 61 72 65 61 70 61 74 68 20 27 68 6f ver areapath 'ho
1a50: 6d 65 68 6f 73 74 29 29 29 0a 09 28 72 65 6d 6f mehost)))..(remo
1a60: 74 65 2d 68 68 2d 64 61 74 2d 73 65 74 21 20 72 te-hh-dat-set! r
1a70: 75 6e 72 65 6d 6f 74 65 20 28 6f 72 20 68 68 2d unremote (or hh-
1a80: 64 61 74 61 20 28 63 6f 6e 73 20 23 66 20 23 66 data (cons #f #f
1a90: 29 29 29 29 29 0a 20 20 0a 20 20 28 63 6f 6e 64 ))))). . (cond
1aa0: 0a 20 20 20 3b 3b 20 67 69 76 65 20 75 70 20 69 . ;; give up i
1ab0: 66 20 6d 6f 72 65 20 74 68 61 6e 20 31 35 30 20 f more than 150
1ac0: 61 74 74 65 6d 70 74 73 0a 20 20 20 28 28 3e 20 attempts. ((>
1ad0: 61 74 74 65 6d 70 74 6e 75 6d 20 31 35 30 29 0a attemptnum 150).
1ae0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
1af0: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
1b00: 70 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 31 35 port* "ERROR: 15
1b10: 30 20 74 72 69 65 73 20 74 6f 20 73 74 61 72 74 0 tries to start
1b20: 2f 63 6f 6e 6e 65 63 74 20 74 6f 20 73 65 72 76 /connect to serv
1b30: 65 72 2e 20 47 69 76 69 6e 67 20 75 70 2e 22 29 er. Giving up.")
1b40: 0a 20 20 20 20 28 65 78 69 74 20 31 29 29 0a 0a . (exit 1))..
1b50: 20 20 20 3b 3b 20 72 65 61 64 6f 6e 6c 79 20 6d ;; readonly m
1b60: 6f 64 65 2c 20 72 65 61 64 20 72 65 71 75 65 73 ode, read reques
1b70: 74 2d 20 20 68 61 6e 64 6c 65 20 69 74 20 2d 20 t- handle it -
1b80: 63 61 73 65 20 32 0a 20 20 20 28 28 61 6e 64 20 case 2. ((and
1b90: 72 65 61 64 6f 6e 6c 79 2d 6d 6f 64 65 0a 20 20 readonly-mode.
1ba0: 20 20 20 20 20 20 20 28 6d 65 6d 62 65 72 20 63 (member c
1bb0: 6d 64 20 61 70 69 3a 72 65 61 64 2d 6f 6e 6c 79 md api:read-only
1bc0: 2d 71 75 65 72 69 65 73 29 29 20 0a 20 20 20 20 -queries)) .
1bd0: 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a (mutex-unlock! *
1be0: 72 6d 74 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 rmt-mutex*).
1bf0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
1c00: 6f 20 31 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f o 12 *default-lo
1c10: 67 2d 70 6f 72 74 2a 20 22 72 6d 74 3a 73 65 6e g-port* "rmt:sen
1c20: 64 2d 72 65 63 65 69 76 65 2c 20 63 61 73 65 20 d-receive, case
1c30: 32 22 29 0a 20 20 20 20 28 72 6d 74 3a 6f 70 65 2"). (rmt:ope
1c40: 6e 2d 71 72 79 2d 63 6c 6f 73 65 2d 6c 6f 63 61 n-qry-close-loca
1c50: 6c 6c 79 20 63 6d 64 20 30 20 70 61 72 61 6d 73 lly cmd 0 params
1c60: 29 0a 20 20 20 20 29 0a 0a 20 20 20 3b 3b 20 72 ). ).. ;; r
1c70: 65 61 64 6f 6e 6c 79 20 6d 6f 64 65 2c 20 77 72 eadonly mode, wr
1c80: 69 74 65 20 72 65 71 75 65 73 74 2e 20 20 44 6f ite request. Do
1c90: 20 6e 6f 74 68 69 6e 67 2c 20 72 65 74 75 72 6e nothing, return
1ca0: 20 23 66 0a 20 20 20 28 72 65 61 64 6f 6e 6c 79 #f. (readonly
1cb0: 2d 6d 6f 64 65 20 28 65 78 74 72 61 73 2d 72 65 -mode (extras-re
1cc0: 61 64 6f 6e 6c 79 2d 6d 6f 64 65 20 2a 72 6d 74 adonly-mode *rmt
1cd0: 2d 6d 75 74 65 78 2a 20 2a 64 65 66 61 75 6c 74 -mutex* *default
1ce0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 63 6d 64 20 70 -log-port* cmd p
1cf0: 61 72 61 6d 73 29 29 0a 0a 20 20 20 3b 3b 20 54 arams)).. ;; T
1d00: 68 69 73 20 62 6c 6f 63 6b 20 77 61 73 20 66 6f his block was fo
1d10: 72 20 70 72 65 2d 65 6d 70 74 69 76 65 6c 79 20 r pre-emptively
1d20: 72 65 73 65 74 74 69 6e 67 20 74 68 65 20 63 6f resetting the co
1d30: 6e 6e 65 63 74 69 6f 6e 20 69 66 20 74 68 65 72 nnection if ther
1d40: 65 20 68 61 64 20 62 65 65 6e 20 6e 6f 20 63 6f e had been no co
1d50: 6d 6d 75 6e 69 63 61 74 69 6f 6e 20 66 6f 72 20 mmunication for
1d60: 73 6f 6d 65 20 74 69 6d 65 2e 0a 20 20 20 3b 3b some time.. ;;
1d70: 20 49 20 64 6f 6e 27 74 20 74 68 69 6e 6b 20 69 I don't think i
1d80: 74 20 61 64 64 73 20 61 6e 79 20 76 61 6c 75 65 t adds any value
1d90: 2e 20 49 66 20 74 68 65 20 73 65 72 76 65 72 20 . If the server
1da0: 69 73 20 6e 6f 74 20 74 68 65 72 65 2c 20 6a 75 is not there, ju
1db0: 73 74 20 66 61 69 6c 20 61 6e 64 20 73 74 61 72 st fail and star
1dc0: 74 20 61 20 6e 65 77 20 63 6f 6e 6e 65 63 74 69 t a new connecti
1dd0: 6f 6e 2e 0a 20 20 20 3b 3b 20 61 6c 73 6f 2c 20 on.. ;; also,
1de0: 74 68 65 20 65 78 70 69 72 65 2d 74 69 6d 65 20 the expire-time
1df0: 63 61 6c 63 75 6c 61 74 69 6f 6e 20 6d 69 67 68 calculation migh
1e00: 74 20 6e 6f 74 20 62 65 20 63 6f 72 72 65 63 74 t not be correct
1e10: 2e 20 57 65 20 77 61 6e 74 2c 20 74 69 6d 65 2d . We want, time-
1e20: 73 69 6e 63 65 2d 6c 61 73 74 2d 73 65 72 76 65 since-last-serve
1e30: 72 2d 61 63 63 65 73 73 20 3e 20 28 73 65 72 76 r-access > (serv
1e40: 65 72 3a 67 65 74 2d 74 69 6d 65 6f 75 74 29 0a er:get-timeout).
1e50: 20 20 20 3b 3b 0a 20 20 20 3b 3b 20 72 65 73 65 ;;. ;; rese
1e60: 74 20 74 68 65 20 63 6f 6e 6e 65 63 74 69 6f 6e t the connection
1e70: 20 69 66 20 69 74 20 68 61 73 20 62 65 65 6e 20 if it has been
1e80: 75 6e 75 73 65 64 20 74 6f 6f 20 6c 6f 6e 67 0a unused too long.
1e90: 20 20 20 28 28 61 6e 64 20 72 75 6e 72 65 6d 6f ((and runremo
1ea0: 74 65 0a 20 20 20 20 20 20 20 20 20 28 72 65 6d te. (rem
1eb0: 6f 74 65 2d 61 70 69 2d 75 72 6c 20 72 75 6e 72 ote-api-url runr
1ec0: 65 6d 6f 74 65 29 0a 09 20 28 3e 20 28 63 75 72 emote).. (> (cur
1ed0: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 3b 3b rent-seconds) ;;
1ee0: 20 69 66 20 69 74 20 68 61 73 20 62 65 65 6e 20 if it has been
1ef0: 6d 6f 72 65 20 74 68 61 6e 20 73 65 72 76 65 72 more than server
1f00: 2d 74 69 6d 65 6f 75 74 20 73 65 63 6f 6e 64 73 -timeout seconds
1f10: 20 73 69 6e 63 65 20 6c 61 73 74 20 63 6f 6e 74 since last cont
1f20: 61 63 74 2c 20 63 6c 6f 73 65 20 74 68 69 73 20 act, close this
1f30: 63 6f 6e 6e 65 63 74 69 6f 6e 20 61 6e 64 20 73 connection and s
1f40: 74 61 72 74 20 61 20 6e 65 77 20 6f 6e 0a 09 20 tart a new on..
1f50: 20 20 20 28 2b 20 28 72 65 6d 6f 74 65 2d 6c 61 (+ (remote-la
1f60: 73 74 2d 61 63 63 65 73 73 20 72 75 6e 72 65 6d st-access runrem
1f70: 6f 74 65 29 0a 09 20 20 20 20 20 20 20 28 72 65 ote).. (re
1f80: 6d 6f 74 65 2d 73 65 72 76 65 72 2d 74 69 6d 65 mote-server-time
1f90: 6f 75 74 20 72 75 6e 72 65 6d 6f 74 65 29 29 29 out runremote)))
1fa0: 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 ). (debug:pri
1fb0: 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 nt-info 0 *defau
1fc0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 43 6f lt-log-port* "Co
1fd0: 6e 6e 65 63 74 69 6f 6e 20 74 6f 20 22 20 28 72 nnection to " (r
1fe0: 65 6d 6f 74 65 2d 73 65 72 76 65 72 2d 75 72 6c emote-server-url
1ff0: 20 72 75 6e 72 65 6d 6f 74 65 29 20 22 20 65 78 runremote) " ex
2000: 70 69 72 65 64 20 64 75 65 20 74 6f 20 6e 6f 20 pired due to no
2010: 61 63 63 65 73 73 65 73 20 69 6e 20 22 20 28 72 accesses in " (r
2020: 65 6d 6f 74 65 2d 73 65 72 76 65 72 2d 74 69 6d emote-server-tim
2030: 65 6f 75 74 20 72 75 6e 72 65 6d 6f 74 65 29 20 eout runremote)
2040: 22 20 73 65 63 6f 6e 64 73 2c 20 66 6f 72 63 69 " seconds, forci
2050: 6e 67 20 6e 65 77 20 63 6f 6e 6e 65 63 74 69 6f ng new connectio
2060: 6e 2e 22 29 0a 20 20 20 20 28 68 74 74 70 2d 74 n."). (http-t
2070: 72 61 6e 73 70 6f 72 74 3a 63 6c 6f 73 65 2d 63 ransport:close-c
2080: 6f 6e 6e 65 63 74 69 6f 6e 73 20 72 75 6e 72 65 onnections runre
2090: 6d 6f 74 65 29 0a 20 20 20 20 3b 3b 20 6d 6f 76 mote). ;; mov
20a0: 69 6e 67 20 74 68 69 73 20 73 65 74 74 69 6e 67 ing this setting
20b0: 20 6f 66 20 72 75 6e 72 65 6d 6f 74 65 20 63 6f of runremote co
20c0: 6e 6e 64 61 74 20 74 6f 20 23 66 20 74 6f 20 69 nndat to #f to i
20d0: 6e 73 69 64 65 20 74 68 65 20 68 74 74 70 2d 74 nside the http-t
20e0: 72 61 6e 73 70 6f 72 74 3a 63 6c 6f 73 65 2d 63 ransport:close-c
20f0: 6f 6e 6e 65 63 74 69 6f 6e 73 0a 20 20 20 20 3b onnections. ;
2100: 3b 20 28 72 65 6d 6f 74 65 2d 63 6f 6e 6e 64 61 ; (remote-connda
2110: 74 2d 73 65 74 21 20 72 75 6e 72 65 6d 6f 74 65 t-set! runremote
2120: 20 23 66 29 20 3b 3b 20 69 6e 76 61 6c 69 64 61 #f) ;; invalida
2130: 74 65 20 74 68 65 20 63 6f 6e 6e 65 63 74 69 6f te the connectio
2140: 6e 2c 20 74 68 75 73 20 66 6f 72 63 69 6e 67 20 n, thus forcing
2150: 61 20 6e 65 77 20 63 6f 6e 6e 65 63 74 69 6f 6e a new connection
2160: 2e 0a 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c .. (mutex-unl
2170: 6f 63 6b 21 20 2a 72 6d 74 2d 6d 75 74 65 78 2a ock! *rmt-mutex*
2180: 29 0a 20 20 20 20 28 72 6d 74 3a 73 65 6e 64 2d ). (rmt:send-
2190: 72 65 63 65 69 76 65 20 63 6d 64 20 72 69 64 20 receive cmd rid
21a0: 70 61 72 61 6d 73 20 61 74 74 65 6d 70 74 6e 75 params attemptnu
21b0: 6d 3a 20 61 74 74 65 6d 70 74 6e 75 6d 29 29 0a m: attemptnum)).
21c0: 20 20 20 0a 20 20 20 3b 3b 20 6f 6e 20 68 6f 6d . ;; on hom
21d0: 65 68 6f 73 74 20 61 6e 64 20 74 68 69 73 20 69 ehost and this i
21e0: 73 20 61 20 72 65 61 64 0a 20 20 20 28 28 61 6e s a read. ((an
21f0: 64 20 28 6e 6f 74 20 28 72 65 6d 6f 74 65 2d 66 d (not (remote-f
2200: 6f 72 63 65 2d 73 65 72 76 65 72 20 72 75 6e 72 orce-server runr
2210: 65 6d 6f 74 65 29 29 20 3b 3b 20 68 6f 6e 6f 72 emote)) ;; honor
2220: 20 66 6f 72 63 65 64 20 75 73 65 20 6f 66 20 73 forced use of s
2230: 65 72 76 65 72 2c 20 69 2e 65 2e 20 73 65 72 76 erver, i.e. serv
2240: 65 72 20 4e 4f 54 20 72 65 71 75 69 72 65 64 0a er NOT required.
2250: 09 20 28 72 6d 74 3a 6f 6e 2d 68 6f 6d 65 68 6f . (rmt:on-homeho
2260: 73 74 3f 20 72 75 6e 72 65 6d 6f 74 65 29 0a 20 st? runremote).
2270: 20 20 20 20 20 20 20 20 28 6d 65 6d 62 65 72 20 (member
2280: 63 6d 64 20 61 70 69 3a 72 65 61 64 2d 6f 6e 6c cmd api:read-onl
2290: 79 2d 71 75 65 72 69 65 73 29 29 20 20 20 3b 3b y-queries)) ;;
22a0: 20 74 68 69 73 20 69 73 20 61 20 72 65 61 64 0a this is a read.
22b0: 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 (mutex-unloc
22c0: 6b 21 20 2a 72 6d 74 2d 6d 75 74 65 78 2a 29 0a k! *rmt-mutex*).
22d0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
22e0: 2d 69 6e 66 6f 20 31 32 20 2a 64 65 66 61 75 6c -info 12 *defaul
22f0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 6d 74 t-log-port* "rmt
2300: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 2c 20 63 :send-receive, c
2310: 61 73 65 20 20 35 22 29 0a 20 20 20 20 28 72 6d ase 5"). (rm
2320: 74 3a 6f 70 65 6e 2d 71 72 79 2d 63 6c 6f 73 65 t:open-qry-close
2330: 2d 6c 6f 63 61 6c 6c 79 20 63 6d 64 20 30 20 70 -locally cmd 0 p
2340: 61 72 61 6d 73 29 29 0a 0a 20 20 20 3b 3b 20 6f arams)).. ;; o
2350: 6e 20 68 6f 6d 65 68 6f 73 74 20 61 6e 64 20 74 n homehost and t
2360: 68 69 73 20 69 73 20 61 20 77 72 69 74 65 2c 20 his is a write,
2370: 77 65 20 61 6c 72 65 61 64 79 20 68 61 76 65 20 we already have
2380: 61 20 73 65 72 76 65 72 0a 20 20 20 28 28 61 6e a server. ((an
2390: 64 20 28 6e 6f 74 20 28 72 65 6d 6f 74 65 2d 66 d (not (remote-f
23a0: 6f 72 63 65 2d 73 65 72 76 65 72 20 72 75 6e 72 orce-server runr
23b0: 65 6d 6f 74 65 29 29 20 20 20 20 20 3b 3b 20 68 emote)) ;; h
23c0: 6f 6e 6f 72 20 66 6f 72 63 65 64 20 75 73 65 20 onor forced use
23d0: 6f 66 20 73 65 72 76 65 72 2c 20 69 2e 65 2e 20 of server, i.e.
23e0: 73 65 72 76 65 72 20 4e 4f 54 20 72 65 71 75 69 server NOT requi
23f0: 72 65 64 0a 09 20 28 63 64 72 20 28 72 65 6d 6f red.. (cdr (remo
2400: 74 65 2d 68 68 2d 64 61 74 20 72 75 6e 72 65 6d te-hh-dat runrem
2410: 6f 74 65 29 29 20 20 20 20 20 20 20 20 20 20 20 ote))
2420: 3b 3b 20 6f 6e 20 68 6f 6d 65 68 6f 73 74 0a 20 ;; on homehost.
2430: 20 20 20 20 20 20 20 20 28 6e 6f 74 20 28 6d 65 (not (me
2440: 6d 62 65 72 20 63 6d 64 20 61 70 69 3a 72 65 61 mber cmd api:rea
2450: 64 2d 6f 6e 6c 79 2d 71 75 65 72 69 65 73 29 29 d-only-queries))
2460: 20 20 3b 3b 20 74 68 69 73 20 69 73 20 61 20 77 ;; this is a w
2470: 72 69 74 65 0a 20 20 20 20 20 20 20 20 20 28 72 rite. (r
2480: 65 6d 6f 74 65 2d 73 65 72 76 65 72 2d 75 72 6c emote-server-url
2490: 20 72 75 6e 72 65 6d 6f 74 65 29 29 20 20 20 20 runremote))
24a0: 20 20 20 20 20 20 20 20 3b 3b 20 68 61 76 65 20 ;; have
24b0: 61 20 73 65 72 76 65 72 20 28 6e 65 65 64 65 64 a server (needed
24c0: 20 74 6f 20 73 79 6e 63 20 77 72 69 74 74 65 6e to sync written
24d0: 20 64 61 74 61 20 62 61 63 6b 29 0a 20 20 20 20 data back).
24e0: 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a (mutex-unlock! *
24f0: 72 6d 74 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 rmt-mutex*).
2500: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
2510: 6f 20 31 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f o 12 *default-lo
2520: 67 2d 70 6f 72 74 2a 20 22 72 6d 74 3a 73 65 6e g-port* "rmt:sen
2530: 64 2d 72 65 63 65 69 76 65 2c 20 63 61 73 65 20 d-receive, case
2540: 20 34 2e 31 22 29 0a 20 20 20 20 28 72 6d 74 3a 4.1"). (rmt:
2550: 6f 70 65 6e 2d 71 72 79 2d 63 6c 6f 73 65 2d 6c open-qry-close-l
2560: 6f 63 61 6c 6c 79 20 63 6d 64 20 30 20 70 61 72 ocally cmd 0 par
2570: 61 6d 73 29 29 0a 0a 20 20 20 3b 3b 20 20 6f 6e ams)).. ;; on
2580: 20 68 6f 6d 65 68 6f 73 74 2c 20 6e 6f 20 73 65 homehost, no se
2590: 72 76 65 72 20 63 6f 6e 74 61 63 74 20 6d 61 64 rver contact mad
25a0: 65 20 61 6e 64 20 74 68 69 73 20 69 73 20 61 20 e and this is a
25b0: 77 72 69 74 65 2c 20 70 61 73 73 69 76 65 6c 79 write, passively
25c0: 20 73 74 61 72 74 20 61 20 73 65 72 76 65 72 20 start a server
25d0: 0a 20 20 20 28 28 61 6e 64 20 28 6e 6f 74 20 28 . ((and (not (
25e0: 72 65 6d 6f 74 65 2d 66 6f 72 63 65 2d 73 65 72 remote-force-ser
25f0: 76 65 72 20 72 75 6e 72 65 6d 6f 74 65 29 29 20 ver runremote))
2600: 20 20 20 20 3b 3b 20 68 6f 6e 6f 72 20 66 6f 72 ;; honor for
2610: 63 65 64 20 75 73 65 20 6f 66 20 73 65 72 76 65 ced use of serve
2620: 72 2c 20 69 2e 65 2e 20 73 65 72 76 65 72 20 4e r, i.e. server N
2630: 4f 54 20 72 65 71 75 69 72 65 64 0a 09 20 28 63 OT required.. (c
2640: 64 72 20 28 72 65 6d 6f 74 65 2d 68 68 2d 64 61 dr (remote-hh-da
2650: 74 20 72 75 6e 72 65 6d 6f 74 65 29 29 20 20 20 t runremote))
2660: 20 20 20 20 20 20 20 20 3b 3b 20 68 61 76 65 20 ;; have
2670: 68 6f 6d 65 68 6f 73 74 0a 20 20 20 20 20 20 20 homehost.
2680: 20 20 28 6e 6f 74 20 28 72 65 6d 6f 74 65 2d 73 (not (remote-s
2690: 65 72 76 65 72 2d 75 72 6c 20 72 75 6e 72 65 6d erver-url runrem
26a0: 6f 74 65 29 29 20 20 20 20 20 20 20 3b 3b 20 6e ote)) ;; n
26b0: 6f 20 63 6f 6e 6e 65 63 74 69 6f 6e 20 79 65 74 o connection yet
26c0: 0a 09 20 28 6e 6f 74 20 28 6d 65 6d 62 65 72 20 .. (not (member
26d0: 63 6d 64 20 61 70 69 3a 72 65 61 64 2d 6f 6e 6c cmd api:read-onl
26e0: 79 2d 71 75 65 72 69 65 73 29 29 29 20 3b 3b 20 y-queries))) ;;
26f0: 6e 6f 74 20 61 20 72 65 61 64 2d 6f 6e 6c 79 20 not a read-only
2700: 71 75 65 72 79 0a 20 20 20 20 28 64 65 62 75 67 query. (debug
2710: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 32 20 2a :print-info 12 *
2720: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
2730: 2a 20 22 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 * "rmt:send-rece
2740: 69 76 65 2c 20 63 61 73 65 20 20 38 22 29 0a 20 ive, case 8").
2750: 20 20 20 28 6c 65 74 20 28 28 73 65 72 76 65 72 (let ((server
2760: 2d 69 6e 66 6f 20 20 28 73 65 72 76 65 72 3a 63 -info (server:c
2770: 68 65 63 6b 2d 69 66 2d 72 75 6e 6e 69 6e 67 20 heck-if-running
2780: 2a 74 6f 70 70 61 74 68 2a 29 29 29 20 3b 3b 20 *toppath*))) ;;
2790: 28 73 65 72 76 65 72 3a 72 65 61 64 2d 64 6f 74 (server:read-dot
27a0: 73 65 72 76 65 72 2d 3e 75 72 6c 20 2a 74 6f 70 server->url *top
27b0: 70 61 74 68 2a 29 29 29 20 3b 3b 20 28 73 65 72 path*))) ;; (ser
27c0: 76 65 72 3a 63 68 65 63 6b 2d 69 66 2d 72 75 6e ver:check-if-run
27d0: 6e 69 6e 67 20 2a 74 6f 70 70 61 74 68 2a 29 29 ning *toppath*))
27e0: 29 20 3b 3b 20 44 6f 20 4e 4f 54 20 77 61 6e 74 ) ;; Do NOT want
27f0: 20 74 6f 20 72 75 6e 20 73 65 72 76 65 72 3a 63 to run server:c
2800: 68 65 63 6b 2d 69 66 2d 72 75 6e 6e 69 6e 67 20 heck-if-running
2810: 2d 20 76 65 72 79 20 65 78 70 65 6e 73 69 76 65 - very expensive
2820: 20 74 6f 20 64 6f 20 66 6f 72 20 65 76 65 72 79 to do for every
2830: 20 77 72 69 74 65 20 63 61 6c 6c 0a 20 20 20 20 write call.
2840: 20 20 28 69 66 20 73 65 72 76 65 72 2d 69 6e 66 (if server-inf
2850: 6f 0a 09 20 20 28 62 65 67 69 6e 0a 20 20 20 20 o.. (begin.
2860: 20 20 20 20 20 20 20 20 28 72 65 6d 6f 74 65 2d (remote-
2870: 73 65 72 76 65 72 2d 75 72 6c 2d 73 65 74 21 20 server-url-set!
2880: 72 75 6e 72 65 6d 6f 74 65 20 28 73 65 72 76 65 runremote (serve
2890: 72 3a 72 65 63 6f 72 64 2d 3e 75 72 6c 20 73 65 r:record->url se
28a0: 72 76 65 72 2d 69 6e 66 6f 29 29 20 3b 3b 20 74 rver-info)) ;; t
28b0: 68 65 20 73 74 72 69 6e 67 20 63 61 6e 20 62 65 he string can be
28c0: 20 63 6f 6e 73 75 6d 65 64 20 62 79 20 74 68 65 consumed by the
28d0: 20 63 6c 69 65 6e 74 20 73 65 74 75 70 20 69 66 client setup if
28e0: 20 6e 65 65 64 65 64 0a 20 20 20 20 20 20 20 20 needed.
28f0: 20 20 20 20 28 72 65 6d 6f 74 65 2d 73 65 72 76 (remote-serv
2900: 65 72 2d 69 64 2d 73 65 74 21 20 72 75 6e 72 65 er-id-set! runre
2910: 6d 6f 74 65 20 28 73 65 72 76 65 72 3a 72 65 63 mote (server:rec
2920: 6f 72 64 2d 3e 69 64 20 73 65 72 76 65 72 2d 69 ord->id server-i
2930: 6e 66 6f 29 29 29 20 20 0a 09 20 20 28 69 66 20 nfo))) .. (if
2940: 28 63 6f 6d 6d 6f 6e 3a 66 6f 72 63 65 2d 73 65 (common:force-se
2950: 72 76 65 72 3f 29 0a 09 20 20 20 20 20 20 28 73 rver?).. (s
2960: 65 72 76 65 72 3a 73 74 61 72 74 2d 61 6e 64 2d erver:start-and-
2970: 77 61 69 74 20 2a 74 6f 70 70 61 74 68 2a 29 0a wait *toppath*).
2980: 09 20 20 20 20 20 20 28 73 65 72 76 65 72 3a 6b . (server:k
2990: 69 6e 64 2d 72 75 6e 20 2a 74 6f 70 70 61 74 68 ind-run *toppath
29a0: 2a 29 29 29 0a 20 20 20 20 20 20 28 72 65 6d 6f *))). (remo
29b0: 74 65 2d 66 6f 72 63 65 2d 73 65 72 76 65 72 2d te-force-server-
29c0: 73 65 74 21 20 72 75 6e 72 65 6d 6f 74 65 20 28 set! runremote (
29d0: 63 6f 6d 6d 6f 6e 3a 66 6f 72 63 65 2d 73 65 72 common:force-ser
29e0: 76 65 72 3f 29 29 0a 20 20 20 20 20 20 28 6d 75 ver?)). (mu
29f0: 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 72 6d 74 tex-unlock! *rmt
2a00: 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 20 20 28 -mutex*). (
2a10: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
2a20: 20 31 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 12 *default-log
2a30: 2d 70 6f 72 74 2a 20 22 72 6d 74 3a 73 65 6e 64 -port* "rmt:send
2a40: 2d 72 65 63 65 69 76 65 2c 20 63 61 73 65 20 20 -receive, case
2a50: 38 2e 31 22 29 0a 20 20 20 20 20 20 28 72 6d 74 8.1"). (rmt
2a60: 3a 6f 70 65 6e 2d 71 72 79 2d 63 6c 6f 73 65 2d :open-qry-close-
2a70: 6c 6f 63 61 6c 6c 79 20 63 6d 64 20 30 20 70 61 locally cmd 0 pa
2a80: 72 61 6d 73 29 29 29 0a 0a 20 20 20 3b 3b 44 4f rams))).. ;;DO
2a90: 54 20 43 41 53 45 39 20 5b 6c 61 62 65 6c 3d 22 T CASE9 [label="
2aa0: 66 6f 72 63 65 20 73 65 72 76 65 72 5c 6e 6e 6f force server\nno
2ab0: 74 20 6f 6e 20 68 6f 6d 65 68 6f 73 74 22 5d 3b t on homehost"];
2ac0: 0a 20 20 20 3b 3b 44 4f 54 20 4d 55 54 45 58 4c . ;;DOT MUTEXL
2ad0: 4f 43 4b 20 2d 3e 20 43 41 53 45 39 20 5b 6c 61 OCK -> CASE9 [la
2ae0: 62 65 6c 3d 22 6e 6f 20 63 6f 6e 6e 65 63 74 69 bel="no connecti
2af0: 6f 6e 5c 6e 61 6e 64 20 65 69 74 68 65 72 20 72 on\nand either r
2b00: 65 71 75 69 72 65 20 73 65 72 76 65 72 5c 6e 6f equire server\no
2b10: 72 20 6e 6f 74 20 6f 6e 20 68 6f 6d 65 68 6f 73 r not on homehos
2b20: 74 22 5d 3b 20 7b 72 61 6e 6b 3d 73 61 6d 65 20 t"]; {rank=same
2b30: 22 63 61 73 65 20 39 22 20 43 41 53 45 39 7d 3b "case 9" CASE9};
2b40: 0a 20 20 20 3b 3b 44 4f 54 20 43 41 53 45 39 20 . ;;DOT CASE9
2b50: 2d 3e 20 22 73 74 61 72 74 5c 6e 73 65 72 76 65 -> "start\nserve
2b60: 72 22 20 2d 3e 20 22 72 6d 74 3a 73 65 6e 64 2d r" -> "rmt:send-
2b70: 72 65 63 65 69 76 65 22 3b 0a 20 20 20 28 28 6f receive";. ((o
2b80: 72 20 28 61 6e 64 20 28 72 65 6d 6f 74 65 2d 66 r (and (remote-f
2b90: 6f 72 63 65 2d 73 65 72 76 65 72 20 72 75 6e 72 orce-server runr
2ba0: 65 6d 6f 74 65 29 20 20 20 20 20 20 20 20 20 20 emote)
2bb0: 20 20 20 20 3b 3b 20 77 65 20 61 72 65 20 66 6f ;; we are fo
2bc0: 72 63 69 6e 67 20 61 20 73 65 72 76 65 72 20 61 rcing a server a
2bd0: 6e 64 20 64 6f 6e 27 74 20 79 65 74 20 68 61 76 nd don't yet hav
2be0: 65 20 61 20 63 6f 6e 6e 65 63 74 69 6f 6e 20 74 e a connection t
2bf0: 6f 20 6f 6e 65 0a 09 20 20 20 20 20 28 6e 6f 74 o one.. (not
2c00: 20 28 72 65 6d 6f 74 65 2d 61 70 69 2d 75 72 6c (remote-api-url
2c10: 20 72 75 6e 72 65 6d 6f 74 65 29 29 29 0a 09 28 runremote)))..(
2c20: 61 6e 64 20 28 6e 6f 74 20 28 63 64 72 20 28 72 and (not (cdr (r
2c30: 65 6d 6f 74 65 2d 68 68 2d 64 61 74 20 72 75 6e emote-hh-dat run
2c40: 72 65 6d 6f 74 65 29 29 29 20 20 20 20 20 20 20 remote)))
2c50: 20 3b 3b 20 6e 6f 74 20 6f 6e 20 61 20 68 6f 6d ;; not on a hom
2c60: 65 68 6f 73 74 20 0a 09 20 20 20 20 20 28 6e 6f ehost .. (no
2c70: 74 20 28 72 65 6d 6f 74 65 2d 61 70 69 2d 75 72 t (remote-api-ur
2c80: 6c 20 72 75 6e 72 65 6d 6f 74 65 29 29 29 29 20 l runremote))))
2c90: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 61 6e 64 ;; and
2ca0: 20 6e 6f 20 63 6f 6e 6e 65 63 74 69 6f 6e 0a 20 no connection.
2cb0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
2cc0: 69 6e 66 6f 20 31 32 20 2a 64 65 66 61 75 6c 74 info 12 *default
2cd0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 6d 74 3a -log-port* "rmt:
2ce0: 73 65 6e 64 2d 72 65 63 65 69 76 65 2c 20 63 61 send-receive, ca
2cf0: 73 65 20 39 2c 20 68 68 2d 64 61 74 3a 20 22 20 se 9, hh-dat: "
2d00: 28 72 65 6d 6f 74 65 2d 68 68 2d 64 61 74 20 72 (remote-hh-dat r
2d10: 75 6e 72 65 6d 6f 74 65 29 20 22 20 72 75 6e 72 unremote) " runr
2d20: 65 6d 6f 74 65 3a 20 22 20 28 72 65 6d 6f 74 65 emote: " (remote
2d30: 2d 3e 61 6c 69 73 74 20 72 75 6e 72 65 6d 6f 74 ->alist runremot
2d40: 65 29 29 0a 20 20 20 20 28 6d 75 74 65 78 2d 75 e)). (mutex-u
2d50: 6e 6c 6f 63 6b 21 20 2a 72 6d 74 2d 6d 75 74 65 nlock! *rmt-mute
2d60: 78 2a 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 x*). (if (not
2d70: 20 28 73 65 72 76 65 72 3a 63 68 65 63 6b 2d 69 (server:check-i
2d80: 66 2d 72 75 6e 6e 69 6e 67 20 2a 74 6f 70 70 61 f-running *toppa
2d90: 74 68 2a 29 29 20 3b 3b 20 77 68 6f 20 6b 6e 6f th*)) ;; who kno
2da0: 77 73 2c 20 6d 61 79 62 65 20 6f 6e 65 20 68 61 ws, maybe one ha
2db0: 73 20 73 74 61 72 74 65 64 20 75 70 3f 0a 09 28 s started up?..(
2dc0: 73 65 72 76 65 72 3a 73 74 61 72 74 2d 61 6e 64 server:start-and
2dd0: 2d 77 61 69 74 20 2a 74 6f 70 70 61 74 68 2a 29 -wait *toppath*)
2de0: 29 0a 20 20 20 20 3b 3b 20 77 61 73 3a 20 28 72 ). ;; was: (r
2df0: 65 6d 6f 74 65 2d 63 6f 6e 6e 64 61 74 2d 73 65 emote-conndat-se
2e00: 74 21 20 72 75 6e 72 65 6d 6f 74 65 20 28 72 6d t! runremote (rm
2e10: 74 3a 67 65 74 2d 63 6f 6e 6e 65 63 74 69 6f 6e t:get-connection
2e20: 2d 69 6e 66 6f 20 2a 74 6f 70 70 61 74 68 2a 20 -info *toppath*
2e30: 72 75 6e 72 65 6d 6f 74 65 29 29 20 3b 3b 20 63 runremote)) ;; c
2e40: 61 6c 6c 73 20 63 6c 69 65 6e 74 3a 73 65 74 75 alls client:setu
2e50: 70 20 77 68 69 63 68 20 63 61 6c 6c 73 20 63 6c p which calls cl
2e60: 69 65 6e 74 3a 73 65 74 75 70 2d 68 74 74 70 0a ient:setup-http.
2e70: 20 20 20 20 28 73 65 74 21 20 72 75 6e 72 65 6d (set! runrem
2e80: 6f 74 65 20 28 72 6d 74 3a 67 65 74 2d 63 6f 6e ote (rmt:get-con
2e90: 6e 65 63 74 69 6f 6e 2d 69 6e 66 6f 20 2a 74 6f nection-info *to
2ea0: 70 70 61 74 68 2a 20 72 75 6e 72 65 6d 6f 74 65 ppath* runremote
2eb0: 29 29 20 3b 3b 20 63 61 6c 6c 73 20 63 6c 69 65 )) ;; calls clie
2ec0: 6e 74 3a 73 65 74 75 70 20 77 68 69 63 68 20 63 nt:setup which c
2ed0: 61 6c 6c 73 20 63 6c 69 65 6e 74 3a 73 65 74 75 alls client:setu
2ee0: 70 2d 68 74 74 70 0a 20 20 20 20 28 72 6d 74 3a p-http. (rmt:
2ef0: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 63 6d 64 send-receive cmd
2f00: 20 72 69 64 20 70 61 72 61 6d 73 20 61 74 74 65 rid params atte
2f10: 6d 70 74 6e 75 6d 3a 20 61 74 74 65 6d 70 74 6e mptnum: attemptn
2f20: 75 6d 29 29 20 3b 3b 20 54 4f 44 4f 3a 20 61 64 um)) ;; TODO: ad
2f30: 64 20 62 61 63 6b 2d 6f 66 66 20 74 69 6d 65 6f d back-off timeo
2f40: 75 74 20 61 73 0a 0a 20 20 20 3b 3b 44 4f 54 20 ut as.. ;;DOT
2f50: 43 41 53 45 31 30 20 5b 6c 61 62 65 6c 3d 22 6f CASE10 [label="o
2f60: 6e 20 68 6f 6d 65 68 6f 73 74 22 5d 3b 0a 20 20 n homehost"];.
2f70: 20 3b 3b 44 4f 54 20 4d 55 54 45 58 4c 4f 43 4b ;;DOT MUTEXLOCK
2f80: 20 2d 3e 20 43 41 53 45 31 30 20 5b 6c 61 62 65 -> CASE10 [labe
2f90: 6c 3d 22 73 65 72 76 65 72 20 6e 6f 74 20 72 65 l="server not re
2fa0: 71 75 69 72 65 64 2c 5c 6e 6f 6e 20 68 6f 6d 65 quired,\non home
2fb0: 68 6f 73 74 22 5d 3b 20 7b 72 61 6e 6b 3d 73 61 host"]; {rank=sa
2fc0: 6d 65 20 22 63 61 73 65 20 31 30 22 20 43 41 53 me "case 10" CAS
2fd0: 45 31 30 7d 3b 0a 20 20 20 3b 3b 44 4f 54 20 43 E10};. ;;DOT C
2fe0: 41 53 45 31 30 20 2d 3e 20 22 72 6d 74 3a 6f 70 ASE10 -> "rmt:op
2ff0: 65 6e 2d 71 72 79 2d 63 6c 6f 73 65 2d 6c 6f 63 en-qry-close-loc
3000: 61 6c 6c 79 22 3b 0a 20 20 20 3b 3b 20 61 6c 6c ally";. ;; all
3010: 20 73 65 74 20 75 70 20 69 66 20 67 65 74 20 74 set up if get t
3020: 68 69 73 20 66 61 72 2c 20 64 69 73 70 61 74 63 his far, dispatc
3030: 68 20 74 68 65 20 71 75 65 72 79 0a 20 20 20 28 h the query. (
3040: 28 61 6e 64 20 28 6e 6f 74 20 28 72 65 6d 6f 74 (and (not (remot
3050: 65 2d 66 6f 72 63 65 2d 73 65 72 76 65 72 20 72 e-force-server r
3060: 75 6e 72 65 6d 6f 74 65 29 29 0a 09 20 28 63 64 unremote)).. (cd
3070: 72 20 28 72 65 6d 6f 74 65 2d 68 68 2d 64 61 74 r (remote-hh-dat
3080: 20 72 75 6e 72 65 6d 6f 74 65 29 29 29 20 3b 3b runremote))) ;;
3090: 20 77 65 20 61 72 65 20 6f 6e 20 68 6f 6d 65 68 we are on homeh
30a0: 6f 73 74 0a 20 20 20 20 28 6d 75 74 65 78 2d 75 ost. (mutex-u
30b0: 6e 6c 6f 63 6b 21 20 2a 72 6d 74 2d 6d 75 74 65 nlock! *rmt-mute
30c0: 78 2a 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 x*). (debug:p
30d0: 72 69 6e 74 2d 69 6e 66 6f 20 31 32 20 2a 64 65 rint-info 12 *de
30e0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
30f0: 22 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 "rmt:send-receiv
3100: 65 2c 20 63 61 73 65 20 31 30 22 29 0a 20 20 20 e, case 10").
3110: 20 28 72 6d 74 3a 6f 70 65 6e 2d 71 72 79 2d 63 (rmt:open-qry-c
3120: 6c 6f 73 65 2d 6c 6f 63 61 6c 6c 79 20 63 6d 64 lose-locally cmd
3130: 20 28 69 66 20 72 69 64 20 72 69 64 20 30 29 20 (if rid rid 0)
3140: 70 61 72 61 6d 73 29 29 0a 0a 20 20 20 3b 3b 44 params)).. ;;D
3150: 4f 54 20 43 41 53 45 31 31 20 5b 6c 61 62 65 6c OT CASE11 [label
3160: 3d 22 73 65 6e 64 5f 72 65 63 65 69 76 65 22 5d ="send_receive"]
3170: 3b 0a 20 20 20 3b 3b 44 4f 54 20 4d 55 54 45 58 ;. ;;DOT MUTEX
3180: 4c 4f 43 4b 20 2d 3e 20 43 41 53 45 31 31 20 5b LOCK -> CASE11 [
3190: 6c 61 62 65 6c 3d 22 65 6c 73 65 22 5d 3b 20 7b label="else"]; {
31a0: 72 61 6e 6b 3d 73 61 6d 65 20 22 63 61 73 65 20 rank=same "case
31b0: 31 31 22 20 43 41 53 45 31 31 7d 3b 0a 20 20 20 11" CASE11};.
31c0: 3b 3b 44 4f 54 20 43 41 53 45 31 31 20 2d 3e 20 ;;DOT CASE11 ->
31d0: 22 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 "rmt:send-receiv
31e0: 65 22 20 5b 6c 61 62 65 6c 3d 22 63 61 6c 6c 20 e" [label="call
31f0: 66 61 69 6c 65 64 22 5d 3b 0a 20 20 20 3b 3b 44 failed"];. ;;D
3200: 4f 54 20 43 41 53 45 31 31 20 2d 3e 20 22 52 45 OT CASE11 -> "RE
3210: 53 55 4c 54 22 20 5b 6c 61 62 65 6c 3d 22 63 61 SULT" [label="ca
3220: 6c 6c 20 73 75 63 63 65 65 64 65 64 22 5d 3b 0a ll succeeded"];.
3230: 20 20 20 3b 3b 20 6e 6f 74 20 6f 6e 20 68 6f 6d ;; not on hom
3240: 65 68 6f 73 74 2c 20 64 6f 20 73 65 72 76 65 72 ehost, do server
3250: 20 71 75 65 72 79 0a 20 20 20 28 65 6c 73 65 20 query. (else
3260: 28 65 78 74 72 61 73 2d 63 61 73 65 2d 31 31 20 (extras-case-11
3270: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
3280: 74 2a 20 72 75 6e 72 65 6d 6f 74 65 20 63 6d 64 t* runremote cmd
3290: 20 70 61 72 61 6d 73 20 61 74 74 65 6d 70 74 6e params attemptn
32a0: 75 6d 20 72 69 64 29 29 29 29 0a 0a 3b 3b 20 62 um rid))))..;; b
32b0: 75 6e 63 68 20 6f 66 20 73 6d 61 6c 6c 20 66 75 unch of small fu
32c0: 6e 63 74 69 6f 6e 73 20 66 61 63 74 6f 72 65 64 nctions factored
32d0: 20 6f 75 74 20 6f 66 20 73 65 6e 64 2d 72 65 63 out of send-rec
32e0: 65 69 76 65 20 74 6f 20 6d 61 6b 65 20 64 65 62 eive to make deb
32f0: 75 67 20 65 61 73 69 65 72 0a 3b 3b 0a 0a 28 64 ug easier.;;..(d
3300: 65 66 69 6e 65 20 28 65 78 74 72 61 73 2d 63 61 efine (extras-ca
3310: 73 65 2d 31 31 20 2a 64 65 66 61 75 6c 74 2d 6c se-11 *default-l
3320: 6f 67 2d 70 6f 72 74 2a 20 72 75 6e 72 65 6d 6f og-port* runremo
3330: 74 65 20 63 6d 64 20 70 61 72 61 6d 73 20 61 74 te cmd params at
3340: 74 65 6d 70 74 6e 75 6d 20 72 69 64 29 0a 20 20 temptnum rid).
3350: 3b 3b 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b ;; (mutex-unlock
3360: 21 20 2a 72 6d 74 2d 6d 75 74 65 78 2a 29 0a 20 ! *rmt-mutex*).
3370: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
3380: 66 6f 20 31 32 20 2a 64 65 66 61 75 6c 74 2d 6c fo 12 *default-l
3390: 6f 67 2d 70 6f 72 74 2a 20 22 72 6d 74 3a 73 65 og-port* "rmt:se
33a0: 6e 64 2d 72 65 63 65 69 76 65 2c 20 63 61 73 65 nd-receive, case
33b0: 20 20 39 22 29 0a 20 20 3b 3b 20 28 6d 75 74 65 9"). ;; (mute
33c0: 78 2d 6c 6f 63 6b 21 20 2a 72 6d 74 2d 6d 75 74 x-lock! *rmt-mut
33d0: 65 78 2a 29 0a 20 20 28 6c 65 74 2a 20 28 3b 3b ex*). (let* (;;
33e0: 20 28 63 6f 6e 6e 69 6e 66 6f 20 28 72 65 6d 6f (conninfo (remo
33f0: 74 65 2d 63 6f 6e 6e 64 61 74 20 72 75 6e 72 65 te-conndat runre
3400: 6d 6f 74 65 29 29 0a 09 20 28 64 61 74 2d 69 6e mote)).. (dat-in
3410: 20 20 28 63 6f 6e 64 69 74 69 6f 6e 2d 63 61 73 (condition-cas
3420: 65 20 3b 3b 20 68 61 6e 64 6c 69 6e 67 20 68 65 e ;; handling he
3430: 72 65 20 68 61 73 0a 09 09 09 20 20 20 20 20 3b re has.... ;
3440: 3b 20 63 61 75 73 65 64 20 61 20 6c 6f 74 20 6f ; caused a lot o
3450: 66 0a 09 09 09 20 20 20 20 20 3b 3b 20 70 72 6f f.... ;; pro
3460: 62 6c 65 6d 73 2e 20 48 6f 77 65 76 65 72 20 69 blems. However i
3470: 74 0a 09 09 09 20 20 20 20 20 3b 3b 20 69 73 20 t.... ;; is
3480: 6e 65 65 64 65 64 20 74 6f 20 64 65 61 6c 20 77 needed to deal w
3490: 69 74 68 0a 09 09 09 20 20 20 20 20 3b 3b 20 61 ith.... ;; a
34a0: 74 74 65 6d 74 70 65 64 0a 09 09 09 20 20 20 20 ttemtped....
34b0: 20 3b 3b 20 63 6f 6d 6d 75 6e 69 63 61 74 69 6f ;; communicatio
34c0: 6e 20 74 6f 0a 09 09 09 20 20 20 20 20 3b 3b 20 n to.... ;;
34d0: 73 65 72 76 65 72 73 20 74 68 61 74 20 68 61 76 servers that hav
34e0: 65 20 67 6f 6e 65 0a 09 09 09 20 20 20 20 20 3b e gone.... ;
34f0: 3b 20 61 77 61 79 0a 09 09 09 20 20 20 20 20 28 ; away.... (
3500: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 63 http-transport:c
3510: 6c 69 65 6e 74 2d 61 70 69 2d 73 65 6e 64 2d 72 lient-api-send-r
3520: 65 63 65 69 76 65 20 30 20 72 75 6e 72 65 6d 6f eceive 0 runremo
3530: 74 65 20 63 6d 64 20 70 61 72 61 6d 73 29 0a 09 te cmd params)..
3540: 09 09 20 20 20 20 20 3b 3b 20 28 68 74 74 70 2d .. ;; (http-
3550: 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 65 6e 74 transport:client
3560: 2d 61 70 69 2d 73 65 6e 64 2d 72 65 63 65 69 76 -api-send-receiv
3570: 65 20 30 20 63 6f 6e 6e 69 6e 66 6f 20 63 6d 64 e 0 conninfo cmd
3580: 20 70 61 72 61 6d 73 20 72 75 6e 72 65 6d 6f 74 params runremot
3590: 65 29 0a 09 09 09 20 20 20 20 20 28 28 73 65 72 e).... ((ser
35a0: 76 65 72 6d 69 73 6d 61 74 63 68 29 20 20 28 76 vermismatch) (v
35b0: 65 63 74 6f 72 20 23 66 20 22 53 65 72 76 65 72 ector #f "Server
35c0: 20 69 64 20 6d 69 73 6d 61 74 63 68 22 20 29 29 id mismatch" ))
35d0: 0a 09 09 09 20 20 20 20 20 28 28 63 6f 6d 6d 66 .... ((commf
35e0: 61 69 6c 29 28 76 65 63 74 6f 72 20 23 66 20 22 ail)(vector #f "
35f0: 63 6f 6d 6d 75 6e 69 63 61 74 69 6f 6e 73 20 66 communications f
3600: 61 69 6c 22 29 29 0a 09 09 09 20 20 20 20 20 28 ail")).... (
3610: 28 65 78 6e 29 28 76 65 63 74 6f 72 20 23 66 20 (exn)(vector #f
3620: 22 6f 74 68 65 72 20 66 61 69 6c 22 20 28 70 72 "other fail" (pr
3630: 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 29 29 int-call-chain))
3640: 29 29 29 0a 09 20 28 64 61 74 20 20 20 20 20 20 ))).. (dat
3650: 28 69 66 20 28 61 6e 64 20 28 76 65 63 74 6f 72 (if (and (vector
3660: 3f 20 64 61 74 2d 69 6e 29 20 3b 3b 20 2e 2e 2e ? dat-in) ;; ...
3670: 20 63 68 65 63 6b 20 69 74 20 69 73 20 61 20 63 check it is a c
3680: 6f 72 72 65 63 74 20 73 69 7a 65 0a 09 09 09 20 orrect size....
3690: 20 20 20 28 3e 20 28 76 65 63 74 6f 72 2d 6c 65 (> (vector-le
36a0: 6e 67 74 68 20 64 61 74 2d 69 6e 29 20 31 29 29 ngth dat-in) 1))
36b0: 0a 09 09 20 20 20 20 20 20 20 64 61 74 2d 69 6e ... dat-in
36c0: 0a 09 09 20 20 20 20 20 20 20 28 76 65 63 74 6f ... (vecto
36d0: 72 20 23 66 20 28 63 6f 6e 63 20 22 63 6f 6d 6d r #f (conc "comm
36e0: 75 6e 69 63 61 74 69 6f 6e 73 20 66 61 69 6c 20 unications fail
36f0: 28 74 79 70 65 20 32 29 2c 20 64 61 74 2d 69 6e (type 2), dat-in
3700: 3d 22 20 64 61 74 2d 69 6e 29 29 29 29 0a 09 20 =" dat-in))))..
3710: 28 73 75 63 63 65 73 73 20 20 28 69 66 20 28 76 (success (if (v
3720: 65 63 74 6f 72 3f 20 64 61 74 29 20 28 76 65 63 ector? dat) (vec
3730: 74 6f 72 2d 72 65 66 20 64 61 74 20 30 29 20 23 tor-ref dat 0) #
3740: 66 29 29 0a 09 20 28 72 65 73 20 20 20 20 20 20 f)).. (res
3750: 28 69 66 20 28 76 65 63 74 6f 72 3f 20 64 61 74 (if (vector? dat
3760: 29 20 28 76 65 63 74 6f 72 2d 72 65 66 20 64 61 ) (vector-ref da
3770: 74 20 31 29 20 23 66 29 29 29 0a 20 20 20 20 28 t 1) #f))). (
3780: 69 66 20 28 61 6e 64 20 28 72 65 6d 6f 74 65 3f if (and (remote?
3790: 20 72 75 6e 72 65 6d 6f 74 65 29 0a 09 20 20 20 runremote)..
37a0: 20 20 28 72 65 6d 6f 74 65 2d 61 70 69 2d 75 72 (remote-api-ur
37b0: 6c 20 72 75 6e 72 65 6d 6f 74 65 29 29 20 3b 3b l runremote)) ;;
37c0: 20 28 61 6e 64 20 28 76 65 63 74 6f 72 3f 20 63 (and (vector? c
37d0: 6f 6e 6e 69 6e 66 6f 29 20 28 3c 20 35 20 28 76 onninfo) (< 5 (v
37e0: 65 63 74 6f 72 2d 6c 65 6e 67 74 68 20 63 6f 6e ector-length con
37f0: 6e 69 6e 66 6f 29 29 29 0a 09 28 72 65 6d 6f 74 ninfo)))..(remot
3800: 65 2d 6c 61 73 74 2d 61 63 63 65 73 73 2d 73 65 e-last-access-se
3810: 74 21 20 72 75 6e 72 65 6d 6f 74 65 20 28 63 75 t! runremote (cu
3820: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 20 rrent-seconds))
3830: 3b 3b 20 72 65 66 72 65 73 68 20 61 63 63 65 73 ;; refresh acces
3840: 73 20 74 69 6d 65 0a 09 28 62 65 67 69 6e 0a 09 s time..(begin..
3850: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
3860: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
3870: 72 74 2a 20 22 49 4e 46 4f 3a 20 53 68 6f 75 6c rt* "INFO: Shoul
3880: 64 20 6e 6f 74 20 67 65 74 20 68 65 72 65 21 20 d not get here!
3890: 72 75 6e 72 65 6d 6f 74 65 3d 22 28 72 65 6d 6f runremote="(remo
38a0: 74 65 2d 3e 61 6c 69 73 74 20 72 75 6e 72 65 6d te->alist runrem
38b0: 6f 74 65 29 29 0a 09 20 20 3b 3b 20 28 73 65 74 ote)).. ;; (set
38c0: 21 20 63 6f 6e 6e 69 6e 66 6f 20 23 66 29 0a 09 ! conninfo #f)..
38d0: 20 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 (http-transpor
38e0: 74 3a 63 6c 6f 73 65 2d 63 6f 6e 6e 65 63 74 69 t:close-connecti
38f0: 6f 6e 73 20 72 75 6e 72 65 6d 6f 74 65 29 29 29 ons runremote)))
3900: 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
3910: 74 2d 69 6e 66 6f 20 31 33 20 2a 64 65 66 61 75 t-info 13 *defau
3920: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 6d lt-log-port* "rm
3930: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 2c 20 t:send-receive,
3940: 63 61 73 65 20 20 39 2e 20 72 75 6e 72 65 6d 6f case 9. runremo
3950: 74 65 3d 22 20 28 72 65 6d 6f 74 65 2d 3e 61 6c te=" (remote->al
3960: 69 73 74 20 72 75 6e 72 65 6d 6f 74 65 29 20 22 ist runremote) "
3970: 20 64 61 74 3d 22 20 64 61 74 20 22 20 72 75 6e dat=" dat " run
3980: 72 65 6d 6f 74 65 20 3d 20 22 20 72 75 6e 72 65 remote = " runre
3990: 6d 6f 74 65 29 0a 20 20 20 20 28 6d 75 74 65 78 mote). (mutex
39a0: 2d 75 6e 6c 6f 63 6b 21 20 2a 72 6d 74 2d 6d 75 -unlock! *rmt-mu
39b0: 74 65 78 2a 29 0a 20 20 20 20 28 69 66 20 73 75 tex*). (if su
39c0: 63 63 65 73 73 20 3b 3b 20 73 75 63 63 65 73 73 ccess ;; success
39d0: 20 6f 6e 6c 79 20 74 65 6c 6c 73 20 75 73 20 74 only tells us t
39e0: 68 61 74 20 74 68 65 20 74 72 61 6e 73 70 6f 72 hat the transpor
39f0: 74 20 77 61 73 0a 09 3b 3b 20 73 75 63 63 65 73 t was..;; succes
3a00: 73 66 75 6c 2c 20 68 61 76 65 20 74 6f 20 65 78 sful, have to ex
3a10: 61 6d 69 6e 65 20 74 68 65 20 64 61 74 61 20 74 amine the data t
3a20: 6f 20 73 65 65 20 69 66 0a 09 3b 3b 20 74 68 65 o see if..;; the
3a30: 72 65 20 77 61 73 20 61 20 64 65 74 65 63 74 65 re was a detecte
3a40: 64 20 69 73 73 75 65 20 61 74 20 74 68 65 20 6f d issue at the o
3a50: 74 68 65 72 20 65 6e 64 0a 09 28 65 78 74 72 61 ther end..(extra
3a60: 73 2d 74 72 61 6e 73 70 6f 72 74 2d 73 75 63 63 s-transport-succ
3a70: 65 64 65 64 20 2a 64 65 66 61 75 6c 74 2d 6c 6f eded *default-lo
3a80: 67 2d 70 6f 72 74 2a 20 2a 72 6d 74 2d 6d 75 74 g-port* *rmt-mut
3a90: 65 78 2a 20 61 74 74 65 6d 70 74 6e 75 6d 20 72 ex* attemptnum r
3aa0: 75 6e 72 65 6d 6f 74 65 20 72 65 73 20 70 61 72 unremote res par
3ab0: 61 6d 73 20 72 69 64 20 63 6d 64 29 0a 09 28 62 ams rid cmd)..(b
3ac0: 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 egin.
3ad0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 (debug:print-err
3ae0: 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f or 0 *default-lo
3af0: 67 2d 70 6f 72 74 2a 20 22 20 64 61 74 3d 22 20 g-port* " dat="
3b00: 64 61 74 29 20 0a 20 20 20 20 20 20 20 20 20 20 dat) .
3b10: 20 28 65 78 74 72 61 73 2d 74 72 61 6e 73 70 6f (extras-transpo
3b20: 72 74 2d 66 61 69 6c 65 64 20 2a 64 65 66 61 75 rt-failed *defau
3b30: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 2a 72 6d lt-log-port* *rm
3b40: 74 2d 6d 75 74 65 78 2a 20 61 74 74 65 6d 70 74 t-mutex* attempt
3b50: 6e 75 6d 20 72 75 6e 72 65 6d 6f 74 65 20 63 6d num runremote cm
3b60: 64 20 72 69 64 20 70 61 72 61 6d 73 29 29 0a 09 d rid params))..
3b70: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d )))..(define (rm
3b80: 74 3a 70 72 69 6e 74 2d 64 62 2d 73 74 61 74 73 t:print-db-stats
3b90: 29 0a 20 20 28 6c 65 74 20 28 28 66 6d 74 73 74 ). (let ((fmtst
3ba0: 72 20 22 7e 34 30 61 7e 37 2d 64 7e 39 2d 64 7e r "~40a~7-d~9-d~
3bb0: 32 30 2c 32 2d 66 22 29 29 20 3b 3b 20 22 7e 32 20,2-f")) ;; "~2
3bc0: 30 2c 32 2d 66 22 0a 20 20 20 20 28 64 65 62 75 0,2-f". (debu
3bd0: 67 3a 70 72 69 6e 74 20 31 38 20 2a 64 65 66 61 g:print 18 *defa
3be0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 44 ult-log-port* "D
3bf0: 42 20 53 74 61 74 73 5c 6e 3d 3d 3d 3d 3d 3d 3d B Stats\n=======
3c00: 3d 22 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 ="). (debug:p
3c10: 72 69 6e 74 20 31 38 20 2a 64 65 66 61 75 6c 74 rint 18 *default
3c20: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 28 66 6f 72 6d -log-port* (form
3c30: 61 74 20 23 66 20 22 7e 34 30 61 7e 38 61 7e 31 at #f "~40a~8a~1
3c40: 30 61 7e 31 30 61 22 20 22 43 6d 64 22 20 22 43 0a~10a" "Cmd" "C
3c50: 6f 75 6e 74 22 20 22 54 6f 74 54 69 6d 65 22 20 ount" "TotTime"
3c60: 22 41 76 67 22 29 29 0a 20 20 20 20 28 66 6f 72 "Avg")). (for
3c70: 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 63 -each (lambda (c
3c80: 6d 64 29 0a 09 09 28 6c 65 74 20 28 28 63 6d 64 md)...(let ((cmd
3c90: 2d 64 61 74 20 28 68 61 73 68 2d 74 61 62 6c 65 -dat (hash-table
3ca0: 2d 72 65 66 20 2a 64 62 2d 73 74 61 74 73 2a 20 -ref *db-stats*
3cb0: 63 6d 64 29 29 29 0a 09 09 20 20 28 64 65 62 75 cmd)))... (debu
3cc0: 67 3a 70 72 69 6e 74 20 31 38 20 2a 64 65 66 61 g:print 18 *defa
3cd0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 28 66 ult-log-port* (f
3ce0: 6f 72 6d 61 74 20 23 66 20 66 6d 74 73 74 72 20 ormat #f fmtstr
3cf0: 63 6d 64 20 28 76 65 63 74 6f 72 2d 72 65 66 20 cmd (vector-ref
3d00: 63 6d 64 2d 64 61 74 20 30 29 20 28 76 65 63 74 cmd-dat 0) (vect
3d10: 6f 72 2d 72 65 66 20 63 6d 64 2d 64 61 74 20 31 or-ref cmd-dat 1
3d20: 29 20 28 2f 20 28 76 65 63 74 6f 72 2d 72 65 66 ) (/ (vector-ref
3d30: 20 63 6d 64 2d 64 61 74 20 31 29 28 76 65 63 74 cmd-dat 1)(vect
3d40: 6f 72 2d 72 65 66 20 63 6d 64 2d 64 61 74 20 30 or-ref cmd-dat 0
3d50: 29 29 29 29 29 29 0a 09 20 20 20 20 20 20 28 73 )))))).. (s
3d60: 6f 72 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ort (hash-table-
3d70: 6b 65 79 73 20 2a 64 62 2d 73 74 61 74 73 2a 29 keys *db-stats*)
3d80: 0a 09 09 20 20 20 20 28 6c 61 6d 62 64 61 20 28 ... (lambda (
3d90: 61 20 62 29 0a 09 09 20 20 20 20 20 20 28 3e 20 a b)... (>
3da0: 28 76 65 63 74 6f 72 2d 72 65 66 20 28 68 61 73 (vector-ref (has
3db0: 68 2d 74 61 62 6c 65 2d 72 65 66 20 2a 64 62 2d h-table-ref *db-
3dc0: 73 74 61 74 73 2a 20 61 29 20 30 29 0a 09 09 09 stats* a) 0)....
3dd0: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 28 68 61 (vector-ref (ha
3de0: 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 2a 64 62 sh-table-ref *db
3df0: 2d 73 74 61 74 73 2a 20 62 29 20 30 29 29 29 29 -stats* b) 0))))
3e00: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d )))..(define (rm
3e10: 74 3a 67 65 74 2d 6d 61 78 2d 71 75 65 72 79 2d t:get-max-query-
3e20: 61 76 65 72 61 67 65 20 72 75 6e 2d 69 64 29 0a average run-id).
3e30: 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a (mutex-lock! *
3e40: 64 62 2d 73 74 61 74 73 2d 6d 75 74 65 78 2a 29 db-stats-mutex*)
3e50: 0a 20 20 28 6c 65 74 2a 20 28 28 72 75 6e 6b 65 . (let* ((runke
3e60: 79 20 28 63 6f 6e 63 20 22 72 75 6e 2d 69 64 3d y (conc "run-id=
3e70: 22 20 72 75 6e 2d 69 64 20 22 20 22 29 29 0a 09 " run-id " "))..
3e80: 20 28 63 6d 64 73 20 20 20 28 66 69 6c 74 65 72 (cmds (filter
3e90: 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 09 09 (lambda (x)....
3ea0: 20 20 20 28 73 75 62 73 74 72 69 6e 67 2d 69 6e (substring-in
3eb0: 64 65 78 20 72 75 6e 6b 65 79 20 78 29 29 0a 09 dex runkey x))..
3ec0: 09 09 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b .. (hash-table-k
3ed0: 65 79 73 20 2a 64 62 2d 73 74 61 74 73 2a 29 29 eys *db-stats*))
3ee0: 29 0a 09 20 28 72 65 73 20 20 20 20 28 69 66 20 ).. (res (if
3ef0: 28 6e 75 6c 6c 3f 20 63 6d 64 73 29 0a 09 09 20 (null? cmds)...
3f00: 20 20 20 20 28 63 6f 6e 73 20 27 6e 6f 6e 65 20 (cons 'none
3f10: 30 29 0a 09 09 20 20 20 20 20 28 6c 65 74 20 6c 0)... (let l
3f20: 6f 6f 70 20 28 28 63 6d 64 20 28 63 61 72 20 63 oop ((cmd (car c
3f30: 6d 64 73 29 29 0a 09 09 09 09 28 74 61 6c 20 28 mds)).....(tal (
3f40: 63 64 72 20 63 6d 64 73 29 29 0a 09 09 09 09 28 cdr cmds)).....(
3f50: 6d 61 78 2d 63 6d 64 20 28 63 61 72 20 63 6d 64 max-cmd (car cmd
3f60: 73 29 29 0a 09 09 09 09 28 72 65 73 20 30 29 29 s)).....(res 0))
3f70: 0a 09 09 20 20 20 20 20 20 20 28 6c 65 74 2a 20 ... (let*
3f80: 28 28 63 6d 64 2d 64 61 74 20 28 68 61 73 68 2d ((cmd-dat (hash-
3f90: 74 61 62 6c 65 2d 72 65 66 20 2a 64 62 2d 73 74 table-ref *db-st
3fa0: 61 74 73 2a 20 63 6d 64 29 29 0a 09 09 09 20 20 ats* cmd))....
3fb0: 20 20 20 20 28 74 6f 74 20 20 20 20 20 28 76 65 (tot (ve
3fc0: 63 74 6f 72 2d 72 65 66 20 63 6d 64 2d 64 61 74 ctor-ref cmd-dat
3fd0: 20 30 29 29 0a 09 09 09 20 20 20 20 20 20 28 63 0)).... (c
3fe0: 75 72 72 61 76 67 20 28 2f 20 28 76 65 63 74 6f urravg (/ (vecto
3ff0: 72 2d 72 65 66 20 63 6d 64 2d 64 61 74 20 31 29 r-ref cmd-dat 1)
4000: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 63 6d 64 (vector-ref cmd
4010: 2d 64 61 74 20 30 29 29 29 20 3b 3b 20 63 6f 75 -dat 0))) ;; cou
4020: 6e 74 20 69 73 20 6e 65 76 65 72 20 7a 65 72 6f nt is never zero
4030: 20 62 79 20 63 6f 6e 73 74 72 75 63 74 69 6f 6e by construction
4040: 0a 09 09 09 20 20 20 20 20 20 28 63 75 72 72 6d .... (currm
4050: 61 78 20 28 6d 61 78 20 72 65 73 20 63 75 72 72 ax (max res curr
4060: 61 76 67 29 29 0a 09 09 09 20 20 20 20 20 20 28 avg)).... (
4070: 6e 65 77 6d 61 78 2d 63 6d 64 20 28 69 66 20 28 newmax-cmd (if (
4080: 3e 20 63 75 72 72 61 76 67 20 72 65 73 29 20 63 > curravg res) c
4090: 6d 64 20 6d 61 78 2d 63 6d 64 29 29 29 0a 09 09 md max-cmd)))...
40a0: 09 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c . (if (null? tal
40b0: 29 0a 09 09 09 20 20 20 20 20 28 69 66 20 28 3e ).... (if (>
40c0: 20 74 6f 74 20 31 30 29 0a 09 09 09 09 20 28 63 tot 10)..... (c
40d0: 6f 6e 73 20 6e 65 77 6d 61 78 2d 63 6d 64 20 63 ons newmax-cmd c
40e0: 75 72 72 6d 61 78 29 0a 09 09 09 09 20 28 63 6f urrmax)..... (co
40f0: 6e 73 20 27 6e 6f 6e 65 20 30 29 29 0a 09 09 09 ns 'none 0))....
4100: 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 (loop (car
4110: 74 61 6c 29 28 63 64 72 20 74 61 6c 29 20 6e 65 tal)(cdr tal) ne
4120: 77 6d 61 78 2d 63 6d 64 20 63 75 72 72 6d 61 78 wmax-cmd currmax
4130: 29 29 29 29 29 29 29 0a 20 20 20 20 28 6d 75 74 ))))))). (mut
4140: 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 64 62 2d 73 ex-unlock! *db-s
4150: 74 61 74 73 2d 6d 75 74 65 78 2a 29 0a 20 20 20 tats-mutex*).
4160: 20 72 65 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 res))..(define
4170: 28 72 6d 74 3a 6f 70 65 6e 2d 71 72 79 2d 63 6c (rmt:open-qry-cl
4180: 6f 73 65 2d 6c 6f 63 61 6c 6c 79 20 63 6d 64 20 ose-locally cmd
4190: 72 75 6e 2d 69 64 20 70 61 72 61 6d 73 20 23 21 run-id params #!
41a0: 6b 65 79 20 28 72 65 6d 72 65 74 72 69 65 73 20 key (remretries
41b0: 35 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 71 72 5)). (let* ((qr
41c0: 79 2d 69 73 2d 77 72 69 74 65 20 20 20 20 28 6e y-is-write (n
41d0: 6f 74 20 28 6d 65 6d 62 65 72 20 63 6d 64 20 61 ot (member cmd a
41e0: 70 69 3a 72 65 61 64 2d 6f 6e 6c 79 2d 71 75 65 pi:read-only-que
41f0: 72 69 65 73 29 29 29 0a 09 20 28 64 62 2d 66 69 ries))).. (db-fi
4200: 6c 65 2d 70 61 74 68 20 20 20 20 28 64 62 3a 64 le-path (db:d
4210: 62 66 69 6c 65 2d 70 61 74 68 29 29 20 3b 3b 20 bfile-path)) ;;
4220: 20 30 29 29 0a 09 20 28 64 62 73 74 72 75 63 74 0)).. (dbstruct
4230: 73 2d 6c 6f 63 61 6c 20 28 64 62 3a 73 65 74 75 s-local (db:setu
4240: 70 20 23 74 29 29 0a 09 20 28 72 65 61 64 2d 6f p #t)).. (read-o
4250: 6e 6c 79 20 20 20 20 20 20 20 28 6e 6f 74 20 28 nly (not (
4260: 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 73 file-write-acces
4270: 73 3f 20 64 62 2d 66 69 6c 65 2d 70 61 74 68 29 s? db-file-path)
4280: 29 29 0a 09 20 28 73 74 61 72 74 20 20 20 20 20 )).. (start
4290: 20 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d 6d (current-m
42a0: 69 6c 6c 69 73 65 63 6f 6e 64 73 29 29 0a 09 20 illiseconds))..
42b0: 28 72 65 73 64 61 74 20 20 20 20 20 20 20 20 20 (resdat
42c0: 20 28 69 66 20 28 6e 6f 74 20 28 61 6e 64 20 72 (if (not (and r
42d0: 65 61 64 2d 6f 6e 6c 79 20 71 72 79 2d 69 73 2d ead-only qry-is-
42e0: 77 72 69 74 65 29 29 0a 09 09 09 20 20 20 20 20 write))....
42f0: 20 28 6c 65 74 20 28 28 76 20 28 61 70 69 3a 65 (let ((v (api:e
4300: 78 65 63 75 74 65 2d 72 65 71 75 65 73 74 73 20 xecute-requests
4310: 64 62 73 74 72 75 63 74 73 2d 6c 6f 63 61 6c 20 dbstructs-local
4320: 28 76 65 63 74 6f 72 20 28 73 79 6d 62 6f 6c 2d (vector (symbol-
4330: 3e 73 74 72 69 6e 67 20 63 6d 64 29 20 70 61 72 >string cmd) par
4340: 61 6d 73 29 29 29 29 0a 09 09 09 3b 3b 09 28 68 ams))))....;;.(h
4350: 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 andle-exceptions
4360: 20 3b 3b 20 74 68 65 72 65 20 68 61 73 20 62 65 ;; there has be
4370: 65 6e 20 61 20 6c 6f 6e 67 20 68 69 73 74 6f 72 en a long histor
4380: 79 20 6f 66 20 72 65 63 65 69 76 69 6e 67 20 73 y of receiving s
4390: 74 72 61 6e 67 65 20 65 72 72 6f 72 73 20 66 72 trange errors fr
43a0: 6f 6d 20 76 61 6c 75 65 73 20 72 65 74 75 72 6e om values return
43b0: 65 64 20 62 79 20 74 68 65 20 63 6c 69 65 6e 74 ed by the client
43c0: 20 77 68 65 6e 20 74 68 69 6e 67 73 20 67 6f 20 when things go
43d0: 77 72 6f 6e 67 2e 2e 0a 09 09 09 3b 3b 09 20 65 wrong......;;. e
43e0: 78 6e 20 20 20 20 20 20 20 20 20 20 20 20 20 20 xn
43f0: 20 3b 3b 20 20 54 68 69 73 20 69 73 20 61 6e 20 ;; This is an
4400: 61 74 74 65 6d 70 74 20 74 6f 20 64 65 74 65 63 attempt to detec
4410: 74 20 74 68 61 74 20 73 69 74 75 61 74 69 6f 6e t that situation
4420: 20 61 6e 64 20 72 65 63 6f 76 65 72 20 67 72 61 and recover gra
4430: 63 65 66 75 6c 6c 79 0a 09 09 09 3b 3b 09 20 28 cefully....;;. (
4440: 62 65 67 69 6e 0a 09 09 09 3b 3b 09 20 20 20 28 begin....;;. (
4450: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
4460: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
4470: 20 22 45 52 52 4f 52 3a 20 62 61 64 20 64 61 74 "ERROR: bad dat
4480: 61 20 66 72 6f 6d 20 73 65 72 76 65 72 20 22 20 a from server "
4490: 76 20 22 20 6d 65 73 73 61 67 65 3a 20 22 20 20 v " message: "
44a0: 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 ((condition-prop
44b0: 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 erty-accessor 'e
44c0: 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e xn 'message) exn
44d0: 29 20 22 2c 20 65 78 6e 3d 22 20 65 78 6e 29 0a ) ", exn=" exn).
44e0: 09 09 09 3b 3b 09 20 20 20 28 76 65 63 74 6f 72 ...;;. (vector
44f0: 20 23 74 20 27 28 29 29 29 20 3b 3b 20 73 68 6f #t '())) ;; sho
4500: 75 6c 64 20 61 6c 77 61 79 73 20 67 65 74 20 61 uld always get a
4510: 20 76 65 63 74 6f 72 20 62 75 74 20 69 66 20 73 vector but if s
4520: 6f 6d 65 74 68 69 6e 67 20 67 6f 65 73 20 77 72 omething goes wr
4530: 6f 6e 67 20 72 65 74 75 72 6e 20 61 20 64 75 6d ong return a dum
4540: 6d 79 0a 09 09 09 09 20 28 69 66 20 28 61 6e 64 my..... (if (and
4550: 20 28 76 65 63 74 6f 72 3f 20 76 29 0a 09 09 09 (vector? v)....
4560: 09 09 20 20 28 3e 20 28 76 65 63 74 6f 72 2d 6c .. (> (vector-l
4570: 65 6e 67 74 68 20 76 29 20 31 29 29 0a 09 09 09 ength v) 1))....
4580: 09 20 20 20 20 20 28 6c 65 74 20 28 28 6e 65 77 . (let ((new
4590: 76 65 63 20 28 76 65 63 74 6f 72 20 28 76 65 63 vec (vector (vec
45a0: 74 6f 72 2d 72 65 66 20 76 20 30 29 28 76 65 63 tor-ref v 0)(vec
45b0: 74 6f 72 2d 72 65 66 20 76 20 31 29 29 29 29 0a tor-ref v 1)))).
45c0: 09 09 09 09 20 20 20 20 20 20 20 6e 65 77 76 65 .... newve
45d0: 63 29 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 c) ;;
45e0: 62 79 20 63 6f 70 79 69 6e 67 20 74 68 65 20 76 by copying the v
45f0: 65 63 74 6f 72 20 77 68 69 6c 65 20 69 6e 73 69 ector while insi
4600: 64 65 20 74 68 65 20 65 72 72 6f 72 20 68 61 6e de the error han
4610: 64 6c 65 72 20 77 65 20 73 68 6f 75 6c 64 20 66 dler we should f
4620: 6f 72 63 65 20 74 68 65 20 64 65 74 65 63 74 69 orce the detecti
4630: 6f 6e 20 6f 66 20 61 20 63 6f 72 72 75 70 74 65 on of a corrupte
4640: 64 20 72 65 63 6f 72 64 0a 09 09 09 09 20 20 20 d record.....
4650: 20 20 28 76 65 63 74 6f 72 20 23 74 20 27 28 29 (vector #t '()
4660: 29 29 29 20 3b 3b 20 29 20 20 3b 3b 20 77 65 20 ))) ;; ) ;; we
4670: 63 6f 75 6c 64 20 61 6c 73 6f 20 63 68 65 63 6b could also check
4680: 20 74 68 61 74 20 74 68 65 20 72 65 74 75 72 6e that the return
4690: 65 64 20 74 79 70 65 73 20 61 72 65 20 76 61 6c ed types are val
46a0: 69 64 0a 09 09 09 20 20 20 20 20 20 28 76 65 63 id.... (vec
46b0: 74 6f 72 20 23 74 20 27 28 29 29 29 29 0a 09 20 tor #t '())))..
46c0: 28 73 75 63 63 65 73 73 20 20 20 20 20 20 20 20 (success
46d0: 28 76 65 63 74 6f 72 2d 72 65 66 20 72 65 73 64 (vector-ref resd
46e0: 61 74 20 30 29 29 0a 09 20 28 72 65 73 20 20 20 at 0)).. (res
46f0: 20 20 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 (vector
4700: 2d 72 65 66 20 72 65 73 64 61 74 20 31 29 29 0a -ref resdat 1)).
4710: 09 20 28 64 75 72 61 74 69 6f 6e 20 20 20 20 20 . (duration
4720: 20 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 6d 69 (- (current-mi
4730: 6c 6c 69 73 65 63 6f 6e 64 73 29 20 73 74 61 72 lliseconds) star
4740: 74 29 29 29 0a 20 20 20 20 28 69 66 20 28 61 6e t))). (if (an
4750: 64 20 72 65 61 64 2d 6f 6e 6c 79 20 71 72 79 2d d read-only qry-
4760: 69 73 2d 77 72 69 74 65 29 0a 20 20 20 20 20 20 is-write).
4770: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
4780: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
4790: 72 74 2a 20 22 45 52 52 4f 52 3a 20 61 74 74 65 rt* "ERROR: atte
47a0: 6d 70 74 20 74 6f 20 77 72 69 74 65 20 74 6f 20 mpt to write to
47b0: 72 65 61 64 2d 6f 6e 6c 79 20 64 61 74 61 62 61 read-only databa
47c0: 73 65 20 69 67 6e 6f 72 65 64 2e 20 63 6d 64 3d se ignored. cmd=
47d0: 22 20 63 6d 64 29 29 0a 20 20 20 20 28 69 66 20 " cmd)). (if
47e0: 28 6e 6f 74 20 73 75 63 63 65 73 73 29 0a 09 28 (not success)..(
47f0: 69 66 20 28 3e 20 72 65 6d 72 65 74 72 69 65 73 if (> remretries
4800: 20 30 29 0a 09 20 20 20 20 28 62 65 67 69 6e 0a 0).. (begin.
4810: 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
4820: 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 int-error 0 *def
4830: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
4840: 6c 6f 63 61 6c 20 71 75 65 72 79 20 66 61 69 6c local query fail
4850: 65 64 2e 20 54 72 79 69 6e 67 20 61 67 61 69 6e ed. Trying again
4860: 2e 22 29 0a 09 20 20 20 20 20 20 28 74 68 72 65 .").. (thre
4870: 61 64 2d 73 6c 65 65 70 21 20 28 2f 20 28 72 61 ad-sleep! (/ (ra
4880: 6e 64 6f 6d 20 35 30 30 30 29 20 31 30 30 30 29 ndom 5000) 1000)
4890: 29 20 3b 3b 20 73 6f 6d 65 20 72 61 6e 64 6f 6d ) ;; some random
48a0: 20 64 65 6c 61 79 20 0a 09 20 20 20 20 20 20 28 delay .. (
48b0: 72 6d 74 3a 6f 70 65 6e 2d 71 72 79 2d 63 6c 6f rmt:open-qry-clo
48c0: 73 65 2d 6c 6f 63 61 6c 6c 79 20 63 6d 64 20 72 se-locally cmd r
48d0: 75 6e 2d 69 64 20 70 61 72 61 6d 73 20 72 65 6d un-id params rem
48e0: 72 65 74 72 69 65 73 3a 20 28 2d 20 72 65 6d 72 retries: (- remr
48f0: 65 74 72 69 65 73 20 31 29 29 29 0a 09 20 20 20 etries 1)))..
4900: 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 (begin.. (
4910: 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f debug:print-erro
4920: 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 r 0 *default-log
4930: 2d 70 6f 72 74 2a 20 22 74 6f 6f 20 6d 61 6e 79 -port* "too many
4940: 20 72 65 74 72 69 65 73 20 69 6e 20 72 6d 74 3a retries in rmt:
4950: 6f 70 65 6e 2d 71 72 79 2d 63 6c 6f 73 65 2d 6c open-qry-close-l
4960: 6f 63 61 6c 6c 79 2c 20 67 69 76 69 6e 67 20 75 ocally, giving u
4970: 70 22 29 0a 09 20 20 20 20 20 20 23 66 29 29 0a p").. #f)).
4980: 09 28 62 65 67 69 6e 0a 09 20 20 3b 3b 20 28 72 .(begin.. ;; (r
4990: 6d 74 3a 75 70 64 61 74 65 2d 64 62 2d 73 74 61 mt:update-db-sta
49a0: 74 73 20 72 75 6e 2d 69 64 20 63 6d 64 20 70 61 ts run-id cmd pa
49b0: 72 61 6d 73 20 64 75 72 61 74 69 6f 6e 29 0a 09 rams duration)..
49c0: 20 20 3b 3b 20 6d 61 72 6b 20 74 68 69 73 20 72 ;; mark this r
49d0: 75 6e 20 61 73 20 64 69 72 74 79 20 69 66 20 74 un as dirty if t
49e0: 68 69 73 20 77 61 73 20 61 20 77 72 69 74 65 2c his was a write,
49f0: 20 74 68 65 20 77 61 74 63 68 64 6f 67 20 69 73 the watchdog is
4a00: 20 72 65 73 70 6f 6e 73 69 62 6c 65 20 66 6f 72 responsible for
4a10: 20 73 79 6e 63 69 6e 67 20 69 74 0a 09 20 20 28 syncing it.. (
4a20: 69 66 20 71 72 79 2d 69 73 2d 77 72 69 74 65 0a if qry-is-write.
4a30: 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 73 74 . (let ((st
4a40: 61 72 74 2d 74 69 6d 65 20 28 63 75 72 72 65 6e art-time (curren
4a50: 74 2d 73 65 63 6f 6e 64 73 29 29 29 0a 09 09 28 t-seconds)))...(
4a60: 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 64 62 2d mutex-lock! *db-
4a70: 6d 75 6c 74 69 2d 73 79 6e 63 2d 6d 75 74 65 78 multi-sync-mutex
4a80: 2a 29 0a 2f 09 09 28 73 65 74 21 20 2a 64 62 2d *)./..(set! *db-
4a90: 6c 61 73 74 2d 61 63 63 65 73 73 2a 20 73 74 61 last-access* sta
4aa0: 72 74 2d 74 69 6d 65 29 20 20 3b 3b 20 54 48 49 rt-time) ;; THI
4ab0: 53 20 49 53 20 50 52 4f 42 41 42 4c 59 20 55 53 S IS PROBABLY US
4ac0: 45 4c 45 53 53 3f 20 28 77 65 20 61 72 65 20 6f ELESS? (we are o
4ad0: 6e 20 61 20 63 6c 69 65 6e 74 29 0a 20 20 20 20 n a client).
4ae0: 20 20 20 20 20 20 20 20 20 20 20 20 28 6d 75 74 (mut
4af0: 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 64 62 2d 6d ex-unlock! *db-m
4b00: 75 6c 74 69 2d 73 79 6e 63 2d 6d 75 74 65 78 2a ulti-sync-mutex*
4b10: 29 29 29 29 29 0a 20 20 20 20 72 65 73 29 29 0a ))))). res)).
4b20: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 73 65 .(define (rmt:se
4b30: 6e 64 2d 72 65 63 65 69 76 65 2d 6e 6f 2d 61 75 nd-receive-no-au
4b40: 74 6f 2d 63 6c 69 65 6e 74 2d 73 65 74 75 70 20 to-client-setup
4b50: 72 75 6e 72 65 6d 6f 74 65 20 63 6d 64 20 72 75 runremote cmd ru
4b60: 6e 2d 69 64 20 70 61 72 61 6d 73 29 0a 20 20 28 n-id params). (
4b70: 6c 65 74 2a 20 28 28 72 75 6e 2d 69 64 20 20 20 let* ((run-id
4b80: 28 69 66 20 72 75 6e 2d 69 64 20 72 75 6e 2d 69 (if run-id run-i
4b90: 64 20 30 29 29 0a 09 20 28 72 65 73 20 20 09 20 d 0)).. (res .
4ba0: 20 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 (http-transpor
4bb0: 74 3a 63 6c 69 65 6e 74 2d 61 70 69 2d 73 65 6e t:client-api-sen
4bc0: 64 2d 72 65 63 65 69 76 65 20 72 75 6e 2d 69 64 d-receive run-id
4bd0: 20 72 75 6e 72 65 6d 6f 74 65 20 63 6d 64 20 70 runremote cmd p
4be0: 61 72 61 6d 73 29 29 29 0a 20 20 20 20 28 69 66 arams))). (if
4bf0: 20 28 61 6e 64 20 72 65 73 20 28 76 65 63 74 6f (and res (vecto
4c00: 72 2d 72 65 66 20 72 65 73 20 30 29 29 0a 09 28 r-ref res 0))..(
4c10: 76 65 63 74 6f 72 2d 72 65 66 20 72 65 73 20 31 vector-ref res 1
4c20: 29 20 3b 3b 3b 20 59 45 53 21 21 20 54 48 49 53 ) ;;; YES!! THIS
4c30: 20 49 53 20 43 4f 52 52 45 43 54 21 21 20 43 48 IS CORRECT!! CH
4c40: 41 4e 47 45 20 49 54 20 48 45 52 45 2c 20 54 48 ANGE IT HERE, TH
4c50: 45 4e 20 43 48 41 4e 47 45 20 72 6d 74 3a 73 65 EN CHANGE rmt:se
4c60: 6e 64 2d 72 65 63 65 69 76 65 20 41 4c 53 4f 21 nd-receive ALSO!
4c70: 21 21 0a 09 23 66 29 29 29 0a 0a 3b 3b 3d 3d 3d !!..#f)))..;;===
4c80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4c90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4ca0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4cb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4cc0: 3d 3d 3d 0a 3b 3b 0a 3b 3b 20 41 20 43 20 54 20 ===.;;.;; A C T
4cd0: 55 20 41 20 4c 20 20 20 41 20 50 20 49 20 20 20 U A L A P I
4ce0: 43 20 41 20 4c 20 4c 20 53 20 20 0a 3b 3b 0a 3b C A L L S .;;.;
4cf0: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
4d00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4d10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4d20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4d30: 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 3d 3d 3d 3d 3d =======..;;=====
4d40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4d50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4d60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4d70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4d80: 3d 0a 3b 3b 20 20 53 20 45 20 52 20 56 20 45 20 =.;; S E R V E
4d90: 52 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d R.;;============
4da0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4db0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4dc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4dd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 ==========..(def
4de0: 69 6e 65 20 28 72 6d 74 3a 6b 69 6c 6c 2d 73 65 ine (rmt:kill-se
4df0: 72 76 65 72 20 72 75 6e 2d 69 64 29 0a 20 20 28 rver run-id). (
4e00: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
4e10: 20 27 6b 69 6c 6c 2d 73 65 72 76 65 72 20 72 75 'kill-server ru
4e20: 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 n-id (list run-i
4e30: 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 d)))..(define (r
4e40: 6d 74 3a 73 74 61 72 74 2d 73 65 72 76 65 72 20 mt:start-server
4e50: 72 75 6e 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 run-id). (rmt:s
4e60: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 73 74 61 end-receive 'sta
4e70: 72 74 2d 73 65 72 76 65 72 20 30 20 28 6c 69 73 rt-server 0 (lis
4e80: 74 20 72 75 6e 2d 69 64 29 29 29 0a 0a 3b 3b 3d t run-id)))..;;=
4e90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4ea0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4eb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4ec0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4ed0: 3d 3d 3d 3d 3d 0a 3b 3b 20 20 4d 20 49 20 53 20 =====.;; M I S
4ee0: 43 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d C.;;============
4ef0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4f00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4f10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4f20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 ==========..(def
4f30: 69 6e 65 20 28 72 6d 74 3a 6c 6f 67 69 6e 20 72 ine (rmt:login r
4f40: 75 6e 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 un-id). (rmt:se
4f50: 6e 64 2d 72 65 63 65 69 76 65 20 27 6c 6f 67 69 nd-receive 'logi
4f60: 6e 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 2a n run-id (list *
4f70: 74 6f 70 70 61 74 68 2a 20 6d 65 67 61 74 65 73 toppath* megates
4f80: 74 2d 76 65 72 73 69 6f 6e 20 28 63 6c 69 65 6e t-version (clien
4f90: 74 3a 67 65 74 2d 73 69 67 6e 61 74 75 72 65 29 t:get-signature)
4fa0: 29 29 29 0a 0a 3b 3b 20 54 68 69 73 20 6c 6f 67 )))..;; This log
4fb0: 69 6e 20 64 6f 65 73 20 6e 6f 20 72 65 74 72 69 in does no retri
4fc0: 65 73 20 75 6e 64 65 72 20 74 68 65 20 68 6f 6f es under the hoo
4fd0: 64 20 2d 20 69 74 20 61 63 74 73 20 61 20 62 69 d - it acts a bi
4fe0: 74 20 6c 69 6b 65 20 61 20 70 69 6e 67 2e 0a 3b t like a ping..;
4ff0: 3b 20 44 65 70 72 65 63 61 74 65 64 20 66 6f 72 ; Deprecated for
5000: 20 6e 6d 73 67 2d 74 72 61 6e 73 70 6f 72 74 2e nmsg-transport.
5010: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 .;;.(define (rmt
5020: 3a 6c 6f 67 69 6e 2d 6e 6f 2d 61 75 74 6f 2d 63 :login-no-auto-c
5030: 6c 69 65 6e 74 2d 73 65 74 75 70 20 72 75 6e 72 lient-setup runr
5040: 65 6d 6f 74 65 29 0a 20 20 28 72 6d 74 3a 73 65 emote). (rmt:se
5050: 6e 64 2d 72 65 63 65 69 76 65 2d 6e 6f 2d 61 75 nd-receive-no-au
5060: 74 6f 2d 63 6c 69 65 6e 74 2d 73 65 74 75 70 20 to-client-setup
5070: 72 75 6e 72 65 6d 6f 74 65 20 27 6c 6f 67 69 6e runremote 'login
5080: 20 30 20 28 6c 69 73 74 20 2a 74 6f 70 70 61 74 0 (list *toppat
5090: 68 2a 20 6d 65 67 61 74 65 73 74 2d 76 65 72 73 h* megatest-vers
50a0: 69 6f 6e 20 28 63 6c 69 65 6e 74 3a 67 65 74 2d ion (client:get-
50b0: 73 69 67 6e 61 74 75 72 65 29 29 29 29 0a 0a 3b signature))))..;
50c0: 3b 20 68 61 6e 64 20 6f 66 66 20 61 20 63 61 6c ; hand off a cal
50d0: 6c 20 74 6f 20 6f 6e 65 20 6f 66 20 74 68 65 20 l to one of the
50e0: 64 62 3a 71 75 65 72 69 65 73 20 73 74 61 74 65 db:queries state
50f0: 6d 65 6e 74 73 0a 3b 3b 20 61 64 64 65 64 20 72 ments.;; added r
5100: 75 6e 2d 69 64 20 74 6f 20 6d 61 6b 65 20 6c 6f un-id to make lo
5110: 6f 6b 69 6e 67 20 75 70 20 74 68 65 20 63 6f 72 oking up the cor
5120: 72 65 63 74 20 64 62 20 70 6f 73 73 69 62 6c 65 rect db possible
5130: 20 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 72 6d .;;.(define (rm
5140: 74 3a 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 73 t:general-call s
5150: 74 6d 74 6e 61 6d 65 20 72 75 6e 2d 69 64 20 2e tmtname run-id .
5160: 20 70 61 72 61 6d 73 29 0a 20 20 28 72 6d 74 3a params). (rmt:
5170: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 send-receive 'ge
5180: 6e 65 72 61 6c 2d 63 61 6c 6c 20 72 75 6e 2d 69 neral-call run-i
5190: 64 20 28 61 70 70 65 6e 64 20 28 6c 69 73 74 20 d (append (list
51a0: 73 74 6d 74 6e 61 6d 65 20 72 75 6e 2d 69 64 29 stmtname run-id)
51b0: 20 70 61 72 61 6d 73 29 29 29 0a 0a 0a 3b 3b 20 params)))...;;
51c0: 67 69 76 65 6e 20 61 20 68 6f 73 74 6e 61 6d 65 given a hostname
51d0: 2c 20 72 65 74 75 72 6e 20 61 20 70 61 69 72 20 , return a pair
51e0: 6f 66 20 63 70 75 20 6c 6f 61 64 20 61 6e 64 20 of cpu load and
51f0: 75 70 64 61 74 65 20 74 69 6d 65 20 72 65 70 72 update time repr
5200: 65 73 65 6e 74 69 6e 67 20 6c 61 74 65 73 74 20 esenting latest
5210: 69 6e 74 65 6c 6c 69 67 65 6e 63 65 20 66 72 6f intelligence fro
5220: 6d 20 74 65 73 74 73 20 72 75 6e 6e 69 6e 67 20 m tests running
5230: 6f 6e 20 74 68 61 74 20 68 6f 73 74 0a 28 64 65 on that host.(de
5240: 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 6c 61 fine (rmt:get-la
5250: 74 65 73 74 2d 68 6f 73 74 2d 6c 6f 61 64 20 68 test-host-load h
5260: 6f 73 74 6e 61 6d 65 29 0a 20 20 28 72 6d 74 3a ostname). (rmt:
5270: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 send-receive 'ge
5280: 74 2d 6c 61 74 65 73 74 2d 68 6f 73 74 2d 6c 6f t-latest-host-lo
5290: 61 64 20 30 20 28 6c 69 73 74 20 68 6f 73 74 6e ad 0 (list hostn
52a0: 61 6d 65 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ame)))..(define
52b0: 28 72 6d 74 3a 73 64 62 2d 71 72 79 20 71 72 79 (rmt:sdb-qry qry
52c0: 20 76 61 6c 20 72 75 6e 2d 69 64 29 0a 20 20 3b val run-id). ;
52d0: 3b 20 61 64 64 20 63 61 63 68 69 6e 67 20 69 66 ; add caching if
52e0: 20 71 72 79 20 69 73 20 27 67 65 74 69 64 20 6f qry is 'getid o
52f0: 72 20 27 67 65 74 73 74 72 0a 20 20 28 72 6d 74 r 'getstr. (rmt
5300: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 73 :send-receive 's
5310: 64 62 2d 71 72 79 20 72 75 6e 2d 69 64 20 28 6c db-qry run-id (l
5320: 69 73 74 20 71 72 79 20 76 61 6c 29 29 29 0a 0a ist qry val)))..
5330: 3b 3b 20 4e 4f 54 20 43 4f 4d 50 4c 45 54 45 44 ;; NOT COMPLETED
5340: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 72 75 .(define (rmt:ru
5350: 6e 74 65 73 74 73 20 75 73 65 72 20 72 75 6e 2d ntests user run-
5360: 69 64 20 74 65 73 74 70 61 74 74 20 70 61 72 61 id testpatt para
5370: 6d 73 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d ms). (rmt:send-
5380: 72 65 63 65 69 76 65 20 27 72 75 6e 74 65 73 74 receive 'runtest
5390: 73 20 72 75 6e 2d 69 64 20 74 65 73 74 70 61 74 s run-id testpat
53a0: 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d t))..(define (rm
53b0: 74 3a 67 65 74 2d 72 75 6e 2d 72 65 63 6f 72 64 t:get-run-record
53c0: 2d 69 64 73 20 20 74 61 72 67 65 74 20 72 75 6e -ids target run
53d0: 20 6b 65 79 6e 61 6d 65 73 20 74 65 73 74 2d 70 keynames test-p
53e0: 61 74 74 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 att). (rmt:send
53f0: 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 72 75 -receive 'get-ru
5400: 6e 2d 72 65 63 6f 72 64 2d 69 64 73 20 23 66 20 n-record-ids #f
5410: 28 6c 69 73 74 20 74 61 72 67 65 74 20 72 75 6e (list target run
5420: 20 6b 65 79 6e 61 6d 65 73 20 74 65 73 74 2d 70 keynames test-p
5430: 61 74 74 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 att)))..(define
5440: 28 72 6d 74 3a 67 65 74 2d 63 68 61 6e 67 65 64 (rmt:get-changed
5450: 2d 72 65 63 6f 72 64 2d 69 64 73 20 73 69 6e 63 -record-ids sinc
5460: 65 2d 74 69 6d 65 29 0a 20 20 28 72 6d 74 3a 73 e-time). (rmt:s
5470: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 end-receive 'get
5480: 2d 63 68 61 6e 67 65 64 2d 72 65 63 6f 72 64 2d -changed-record-
5490: 69 64 73 20 23 66 20 28 6c 69 73 74 20 73 69 6e ids #f (list sin
54a0: 63 65 2d 74 69 6d 65 29 29 20 29 0a 0a 28 64 65 ce-time)) )..(de
54b0: 66 69 6e 65 20 28 72 6d 74 3a 64 72 6f 70 2d 61 fine (rmt:drop-a
54c0: 6c 6c 2d 74 72 69 67 67 65 72 73 29 0a 20 20 20 ll-triggers).
54d0: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
54e0: 69 76 65 20 27 64 72 6f 70 2d 61 6c 6c 2d 74 72 ive 'drop-all-tr
54f0: 69 67 67 65 72 73 20 23 66 20 27 28 29 29 29 0a iggers #f '())).
5500: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 63 72 .(define (rmt:cr
5510: 65 61 74 65 2d 61 6c 6c 2d 74 72 69 67 67 65 72 eate-all-trigger
5520: 73 29 0a 20 20 20 20 20 28 72 6d 74 3a 73 65 6e s). (rmt:sen
5530: 64 2d 72 65 63 65 69 76 65 20 27 63 72 65 61 74 d-receive 'creat
5540: 65 2d 61 6c 6c 2d 74 72 69 67 67 65 72 73 20 23 e-all-triggers #
5550: 66 20 27 28 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d f '()))..;;=====
5560: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5570: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5580: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5590: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
55a0: 3d 0a 3b 3b 20 20 54 20 45 20 53 20 54 20 20 20 =.;; T E S T
55b0: 4d 20 45 20 54 20 41 20 0a 3b 3b 3d 3d 3d 3d 3d M E T A .;;=====
55c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
55d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
55e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
55f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5600: 3d 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a =..(define (rmt:
5610: 67 65 74 2d 74 65 73 74 73 2d 74 61 67 73 29 0a get-tests-tags).
5620: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
5630: 69 76 65 20 27 67 65 74 2d 74 65 73 74 73 2d 74 ive 'get-tests-t
5640: 61 67 73 20 23 66 20 27 28 29 29 29 0a 0a 3b 3b ags #f '()))..;;
5650: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5660: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5670: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5680: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5690: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 4b 20 45 20 59 ======.;; K E Y
56a0: 20 53 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d S .;;==========
56b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
56c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
56d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
56e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b ============..;;
56f0: 20 54 68 65 73 65 20 72 65 71 75 69 72 65 20 72 These require r
5700: 75 6e 2d 69 64 20 62 65 63 61 75 73 65 20 74 68 un-id because th
5710: 65 20 76 61 6c 75 65 73 20 63 6f 6d 65 20 66 72 e values come fr
5720: 6f 6d 20 74 68 65 20 72 75 6e 21 0a 3b 3b 0a 28 om the run!.;;.(
5730: 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d define (rmt:get-
5740: 6b 65 79 2d 76 61 6c 2d 70 61 69 72 73 20 72 75 key-val-pairs ru
5750: 6e 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e n-id). (rmt:sen
5760: 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 6b d-receive 'get-k
5770: 65 79 2d 76 61 6c 2d 70 61 69 72 73 20 72 75 6e ey-val-pairs run
5780: 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 -id (list run-id
5790: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d )))..(define (rm
57a0: 74 3a 67 65 74 2d 6b 65 79 73 29 0a 20 20 28 69 t:get-keys). (i
57b0: 66 20 2a 64 62 2d 6b 65 79 73 2a 20 2a 64 62 2d f *db-keys* *db-
57c0: 6b 65 79 73 2a 20 0a 20 20 20 20 20 28 6c 65 74 keys* . (let
57d0: 20 28 28 72 65 73 20 28 72 6d 74 3a 73 65 6e 64 ((res (rmt:send
57e0: 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 6b 65 -receive 'get-ke
57f0: 79 73 20 23 66 20 27 28 29 29 29 29 0a 20 20 20 ys #f '()))).
5800: 20 20 20 20 28 73 65 74 21 20 2a 64 62 2d 6b 65 (set! *db-ke
5810: 79 73 2a 20 72 65 73 29 0a 20 20 20 20 20 20 20 ys* res).
5820: 72 65 73 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 res)))..(define
5830: 28 72 6d 74 3a 67 65 74 2d 6b 65 79 73 2d 77 72 (rmt:get-keys-wr
5840: 69 74 65 29 20 3b 3b 20 64 75 6d 6d 79 20 71 75 ite) ;; dummy qu
5850: 65 72 79 20 74 6f 20 66 6f 72 63 65 20 73 65 72 ery to force ser
5860: 76 65 72 20 73 74 61 72 74 0a 20 20 28 6c 65 74 ver start. (let
5870: 20 28 28 72 65 73 20 28 72 6d 74 3a 73 65 6e 64 ((res (rmt:send
5880: 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 6b 65 -receive 'get-ke
5890: 79 73 2d 77 72 69 74 65 20 23 66 20 27 28 29 29 ys-write #f '())
58a0: 29 29 0a 20 20 20 20 28 73 65 74 21 20 2a 64 62 )). (set! *db
58b0: 2d 6b 65 79 73 2a 20 72 65 73 29 0a 20 20 20 20 -keys* res).
58c0: 72 65 73 29 29 0a 0a 3b 3b 20 77 65 20 64 6f 6e res))..;; we don
58d0: 27 74 20 72 65 75 73 65 20 72 75 6e 2d 69 64 27 't reuse run-id'
58e0: 73 20 28 65 78 63 65 70 74 20 70 6f 73 73 69 62 s (except possib
58f0: 6c 79 20 2a 61 66 74 65 72 2a 20 61 20 64 62 20 ly *after* a db
5900: 63 6c 65 61 6e 75 70 29 20 73 6f 20 69 74 20 69 cleanup) so it i
5910: 73 20 73 61 66 65 0a 3b 3b 20 74 6f 20 63 61 63 s safe.;; to cac
5920: 68 65 20 74 68 65 20 72 65 73 75 6c 73 20 69 6e he the resuls in
5930: 20 61 20 68 61 73 68 0a 3b 3b 0a 28 64 65 66 69 a hash.;;.(defi
5940: 6e 65 20 28 72 6d 74 3a 67 65 74 2d 6b 65 79 2d ne (rmt:get-key-
5950: 76 61 6c 73 20 72 75 6e 2d 69 64 29 0a 20 20 28 vals run-id). (
5960: 6f 72 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 or (hash-table-r
5970: 65 66 2f 64 65 66 61 75 6c 74 20 2a 6b 65 79 76 ef/default *keyv
5980: 61 6c 73 2a 20 72 75 6e 2d 69 64 20 23 66 29 0a als* run-id #f).
5990: 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 (let ((res
59a0: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
59b0: 76 65 20 27 67 65 74 2d 6b 65 79 2d 76 61 6c 73 ve 'get-key-vals
59c0: 20 23 66 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 #f (list run-id
59d0: 29 29 29 29 0a 20 20 20 20 20 20 20 20 28 68 61 )))). (ha
59e0: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a 6b sh-table-set! *k
59f0: 65 79 76 61 6c 73 2a 20 72 75 6e 2d 69 64 20 72 eyvals* run-id r
5a00: 65 73 29 0a 20 20 20 20 20 20 20 20 72 65 73 29 es). res)
5a10: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
5a20: 3a 67 65 74 2d 74 61 72 67 65 74 73 29 0a 20 20 :get-targets).
5a30: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
5a40: 65 20 27 67 65 74 2d 74 61 72 67 65 74 73 20 23 e 'get-targets #
5a50: 66 20 27 28 29 29 29 0a 0a 28 64 65 66 69 6e 65 f '()))..(define
5a60: 20 28 72 6d 74 3a 67 65 74 2d 74 61 72 67 65 74 (rmt:get-target
5a70: 20 72 75 6e 2d 69 64 29 0a 20 20 28 61 73 73 65 run-id). (asse
5a80: 72 74 20 28 6e 75 6d 62 65 72 3f 20 72 75 6e 2d rt (number? run-
5a90: 69 64 29 20 22 46 41 54 41 4c 3a 20 52 75 6e 20 id) "FATAL: Run
5aa0: 69 64 20 72 65 71 75 69 72 65 64 2e 22 29 0a 20 id required.").
5ab0: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
5ac0: 76 65 20 27 67 65 74 2d 74 61 72 67 65 74 20 72 ve 'get-target r
5ad0: 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d un-id (list run-
5ae0: 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 id)))..(define (
5af0: 72 6d 74 3a 67 65 74 2d 72 75 6e 2d 74 69 6d 65 rmt:get-run-time
5b00: 73 20 72 75 6e 70 61 74 74 20 74 61 72 67 65 74 s runpatt target
5b10: 70 61 74 74 29 0a 20 20 28 72 6d 74 3a 73 65 6e patt). (rmt:sen
5b20: 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 72 d-receive 'get-r
5b30: 75 6e 2d 74 69 6d 65 73 20 23 66 20 28 6c 69 73 un-times #f (lis
5b40: 74 20 72 75 6e 70 61 74 74 20 74 61 72 67 65 74 t runpatt target
5b50: 70 61 74 74 20 29 29 29 20 0a 0a 0a 3b 3b 3d 3d patt ))) ...;;==
5b60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5b70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5b80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5b90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5ba0: 3d 3d 3d 3d 0a 3b 3b 20 20 54 20 45 20 53 20 54 ====.;; T E S T
5bb0: 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d S.;;===========
5bc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5bd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5be0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5bf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 ===========..;;
5c00: 4a 75 73 74 20 73 6f 6d 65 20 73 79 6e 74 61 74 Just some syntat
5c10: 69 63 20 73 75 67 61 72 0a 28 64 65 66 69 6e 65 ic sugar.(define
5c20: 20 28 72 6d 74 3a 72 65 67 69 73 74 65 72 2d 74 (rmt:register-t
5c30: 65 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d est run-id test-
5c40: 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 0a name item-path).
5c50: 20 20 28 61 73 73 65 72 74 20 28 6e 75 6d 62 65 (assert (numbe
5c60: 72 3f 20 72 75 6e 2d 69 64 29 20 22 46 41 54 41 r? run-id) "FATA
5c70: 4c 3a 20 52 75 6e 20 69 64 20 72 65 71 75 69 72 L: Run id requir
5c80: 65 64 2e 22 29 0a 20 20 28 72 6d 74 3a 67 65 6e ed."). (rmt:gen
5c90: 65 72 61 6c 2d 63 61 6c 6c 20 27 72 65 67 69 73 eral-call 'regis
5ca0: 74 65 72 2d 74 65 73 74 20 72 75 6e 2d 69 64 20 ter-test run-id
5cb0: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
5cc0: 20 69 74 65 6d 2d 70 61 74 68 29 29 0a 0a 28 64 item-path))..(d
5cd0: 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 74 efine (rmt:get-t
5ce0: 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 est-id run-id te
5cf0: 73 74 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 stname item-path
5d00: 29 0a 20 20 28 61 73 73 65 72 74 20 28 6e 75 6d ). (assert (num
5d10: 62 65 72 3f 20 72 75 6e 2d 69 64 29 20 22 46 41 ber? run-id) "FA
5d20: 54 41 4c 3a 20 52 75 6e 20 69 64 20 72 65 71 75 TAL: Run id requ
5d30: 69 72 65 64 2e 22 29 0a 20 20 28 72 6d 74 3a 73 ired."). (rmt:s
5d40: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 end-receive 'get
5d50: 2d 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 -test-id run-id
5d60: 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 (list run-id tes
5d70: 74 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 tname item-path)
5d80: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
5d90: 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 :get-test-info-b
5da0: 79 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 y-id run-id test
5db0: 2d 69 64 29 0a 20 20 28 69 66 20 28 6e 75 6d 62 -id). (if (numb
5dc0: 65 72 3f 20 74 65 73 74 2d 69 64 29 0a 20 20 20 er? test-id).
5dd0: 20 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 (rmt:send-rec
5de0: 65 69 76 65 20 27 67 65 74 2d 74 65 73 74 2d 69 eive 'get-test-i
5df0: 6e 66 6f 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 nfo-by-id run-id
5e00: 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 (list run-id te
5e10: 73 74 2d 69 64 29 29 0a 20 20 20 20 20 20 28 62 st-id)). (b
5e20: 65 67 69 6e 0a 09 28 64 65 62 75 67 3a 70 72 69 egin..(debug:pri
5e30: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
5e40: 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 g-port* "WARNING
5e50: 3a 20 42 61 64 20 64 61 74 61 20 68 61 6e 64 65 : Bad data hande
5e60: 64 20 74 6f 20 72 6d 74 3a 67 65 74 2d 74 65 73 d to rmt:get-tes
5e70: 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 72 75 6e t-info-by-id run
5e80: 2d 69 64 3d 22 20 72 75 6e 2d 69 64 20 22 2c 20 -id=" run-id ",
5e90: 74 65 73 74 2d 69 64 3d 22 20 74 65 73 74 2d 69 test-id=" test-i
5ea0: 64 29 0a 09 28 70 72 69 6e 74 2d 63 61 6c 6c 2d d)..(print-call-
5eb0: 63 68 61 69 6e 20 28 63 75 72 72 65 6e 74 2d 65 chain (current-e
5ec0: 72 72 6f 72 2d 70 6f 72 74 29 29 0a 09 23 66 29 rror-port))..#f)
5ed0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
5ee0: 3a 67 65 74 2d 74 65 73 74 2d 73 74 61 74 65 2d :get-test-state-
5ef0: 73 74 61 74 75 73 2d 62 79 2d 69 64 20 72 75 6e status-by-id run
5f00: 2d 69 64 20 74 65 73 74 2d 69 64 29 0a 20 20 28 -id test-id). (
5f10: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
5f20: 20 27 67 65 74 2d 74 65 73 74 2d 73 74 61 74 65 'get-test-state
5f30: 2d 73 74 61 74 75 73 2d 62 79 2d 69 64 20 72 75 -status-by-id ru
5f40: 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 n-id (list run-i
5f50: 64 20 74 65 73 74 2d 69 64 29 29 29 0a 0a 28 64 d test-id)))..(d
5f60: 65 66 69 6e 65 20 28 72 6d 74 3a 74 65 73 74 2d efine (rmt:test-
5f70: 67 65 74 2d 72 75 6e 64 69 72 2d 66 72 6f 6d 2d get-rundir-from-
5f80: 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 74 test-id run-id t
5f90: 65 73 74 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 est-id). (rmt:s
5fa0: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 74 65 73 end-receive 'tes
5fb0: 74 2d 67 65 74 2d 72 75 6e 64 69 72 2d 66 72 6f t-get-rundir-fro
5fc0: 6d 2d 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 m-test-id run-id
5fd0: 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 (list run-id te
5fe0: 73 74 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 6e st-id)))..(defin
5ff0: 65 20 28 72 6d 74 3a 6f 70 65 6e 2d 74 65 73 74 e (rmt:open-test
6000: 2d 64 62 2d 62 79 2d 74 65 73 74 2d 69 64 20 72 -db-by-test-id r
6010: 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 23 21 un-id test-id #!
6020: 6b 65 79 20 28 77 6f 72 6b 2d 61 72 65 61 20 23 key (work-area #
6030: 66 29 29 0a 20 20 28 61 73 73 65 72 74 20 28 6e f)). (assert (n
6040: 75 6d 62 65 72 3f 20 72 75 6e 2d 69 64 29 20 22 umber? run-id) "
6050: 46 41 54 41 4c 3a 20 52 75 6e 20 69 64 20 72 65 FATAL: Run id re
6060: 71 75 69 72 65 64 2e 22 29 0a 20 20 28 6c 65 74 quired."). (let
6070: 2a 20 28 28 74 65 73 74 2d 70 61 74 68 20 28 69 * ((test-path (i
6080: 66 20 28 73 74 72 69 6e 67 3f 20 77 6f 72 6b 2d f (string? work-
6090: 61 72 65 61 29 0a 09 09 09 77 6f 72 6b 2d 61 72 area)....work-ar
60a0: 65 61 0a 09 09 09 28 72 6d 74 3a 74 65 73 74 2d ea....(rmt:test-
60b0: 67 65 74 2d 72 75 6e 64 69 72 2d 66 72 6f 6d 2d get-rundir-from-
60c0: 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 74 test-id run-id t
60d0: 65 73 74 2d 69 64 29 29 29 29 0a 20 20 20 20 28 est-id)))). (
60e0: 64 65 62 75 67 3a 70 72 69 6e 74 20 33 20 2a 64 debug:print 3 *d
60f0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
6100: 20 22 54 45 53 54 20 50 41 54 48 3a 20 22 20 74 "TEST PATH: " t
6110: 65 73 74 2d 70 61 74 68 29 0a 20 20 20 20 28 6f est-path). (o
6120: 70 65 6e 2d 74 65 73 74 2d 64 62 20 74 65 73 74 pen-test-db test
6130: 2d 70 61 74 68 29 29 29 0a 0a 3b 3b 20 57 41 52 -path)))..;; WAR
6140: 4e 49 4e 47 3a 20 54 68 69 73 20 63 75 72 72 65 NING: This curre
6150: 6e 74 6c 79 20 62 79 70 61 73 73 65 73 20 74 68 ntly bypasses th
6160: 65 20 74 72 61 6e 73 61 63 74 69 6f 6e 20 77 72 e transaction wr
6170: 61 70 70 65 64 20 77 72 69 74 65 73 20 73 79 73 apped writes sys
6180: 74 65 6d 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 tem.(define (rmt
6190: 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d :test-set-state-
61a0: 73 74 61 74 75 73 2d 62 79 2d 69 64 20 72 75 6e status-by-id run
61b0: 2d 69 64 20 74 65 73 74 2d 69 64 20 6e 65 77 73 -id test-id news
61c0: 74 61 74 65 20 6e 65 77 73 74 61 74 75 73 20 6e tate newstatus n
61d0: 65 77 63 6f 6d 6d 65 6e 74 29 0a 20 20 28 61 73 ewcomment). (as
61e0: 73 65 72 74 20 28 6e 75 6d 62 65 72 3f 20 72 75 sert (number? ru
61f0: 6e 2d 69 64 29 20 22 46 41 54 41 4c 3a 20 52 75 n-id) "FATAL: Ru
6200: 6e 20 69 64 20 72 65 71 75 69 72 65 64 2e 22 29 n id required.")
6210: 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 . (rmt:send-rec
6220: 65 69 76 65 20 27 74 65 73 74 2d 73 65 74 2d 73 eive 'test-set-s
6230: 74 61 74 65 2d 73 74 61 74 75 73 2d 62 79 2d 69 tate-status-by-i
6240: 64 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 d run-id (list r
6250: 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 6e 65 un-id test-id ne
6260: 77 73 74 61 74 65 20 6e 65 77 73 74 61 74 75 73 wstate newstatus
6270: 20 6e 65 77 63 6f 6d 6d 65 6e 74 29 29 29 0a 0a newcomment)))..
6280: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 73 65 74 (define (rmt:set
6290: 2d 74 65 73 74 73 2d 73 74 61 74 65 2d 73 74 61 -tests-state-sta
62a0: 74 75 73 20 72 75 6e 2d 69 64 20 74 65 73 74 6e tus run-id testn
62b0: 61 6d 65 73 20 63 75 72 72 73 74 61 74 65 20 63 ames currstate c
62c0: 75 72 72 73 74 61 74 75 73 20 6e 65 77 73 74 61 urrstatus newsta
62d0: 74 65 20 6e 65 77 73 74 61 74 75 73 29 0a 20 20 te newstatus).
62e0: 28 61 73 73 65 72 74 20 28 6e 75 6d 62 65 72 3f (assert (number?
62f0: 20 72 75 6e 2d 69 64 29 20 22 46 41 54 41 4c 3a run-id) "FATAL:
6300: 20 52 75 6e 20 69 64 20 72 65 71 75 69 72 65 64 Run id required
6310: 2e 22 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d ."). (rmt:send-
6320: 72 65 63 65 69 76 65 20 27 73 65 74 2d 74 65 73 receive 'set-tes
6330: 74 73 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 ts-state-status
6340: 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e run-id (list run
6350: 2d 69 64 20 74 65 73 74 6e 61 6d 65 73 20 63 75 -id testnames cu
6360: 72 72 73 74 61 74 65 20 63 75 72 72 73 74 61 74 rrstate currstat
6370: 75 73 20 6e 65 77 73 74 61 74 65 20 6e 65 77 73 us newstate news
6380: 74 61 74 75 73 29 29 29 0a 0a 28 64 65 66 69 6e tatus)))..(defin
6390: 65 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 73 e (rmt:get-tests
63a0: 2d 66 6f 72 2d 72 75 6e 20 72 75 6e 2d 69 64 20 -for-run run-id
63b0: 74 65 73 74 70 61 74 74 20 73 74 61 74 65 73 20 testpatt states
63c0: 73 74 61 74 75 73 65 73 20 6f 66 66 73 65 74 20 statuses offset
63d0: 6c 69 6d 69 74 20 6e 6f 74 2d 69 6e 20 73 6f 72 limit not-in sor
63e0: 74 2d 62 79 20 73 6f 72 74 2d 6f 72 64 65 72 20 t-by sort-order
63f0: 71 72 79 76 61 6c 73 20 6c 61 73 74 2d 75 70 64 qryvals last-upd
6400: 61 74 65 20 6d 6f 64 65 29 0a 20 20 28 61 73 73 ate mode). (ass
6410: 65 72 74 20 28 6e 75 6d 62 65 72 3f 20 72 75 6e ert (number? run
6420: 2d 69 64 29 20 22 46 41 54 41 4c 3a 20 52 75 6e -id) "FATAL: Run
6430: 20 69 64 20 72 65 71 75 69 72 65 64 2e 22 29 0a id required.").
6440: 20 20 3b 3b 20 28 69 66 20 28 6e 75 6d 62 65 72 ;; (if (number
6450: 3f 20 72 75 6e 2d 69 64 29 0a 20 20 28 72 6d 74 ? run-id). (rmt
6460: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 :send-receive 'g
6470: 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e et-tests-for-run
6480: 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 run-id (list ru
6490: 6e 2d 69 64 20 74 65 73 74 70 61 74 74 20 73 74 n-id testpatt st
64a0: 61 74 65 73 20 73 74 61 74 75 73 65 73 20 6f 66 ates statuses of
64b0: 66 73 65 74 20 6c 69 6d 69 74 20 6e 6f 74 2d 69 fset limit not-i
64c0: 6e 20 73 6f 72 74 2d 62 79 20 73 6f 72 74 2d 6f n sort-by sort-o
64d0: 72 64 65 72 20 71 72 79 76 61 6c 73 20 6c 61 73 rder qryvals las
64e0: 74 2d 75 70 64 61 74 65 20 6d 6f 64 65 29 29 29 t-update mode)))
64f0: 0a 20 20 3b 3b 20 20 20 20 28 62 65 67 69 6e 0a . ;; (begin.
6500: 20 20 3b 3b 09 28 64 65 62 75 67 3a 70 72 69 6e ;;.(debug:prin
6510: 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 t-error 0 *defau
6520: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 6d lt-log-port* "rm
6530: 74 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d t:get-tests-for-
6540: 72 75 6e 20 63 61 6c 6c 65 64 20 77 69 74 68 20 run called with
6550: 62 61 64 20 72 75 6e 2d 69 64 3d 22 20 72 75 6e bad run-id=" run
6560: 2d 69 64 29 0a 20 20 3b 3b 09 28 70 72 69 6e 74 -id). ;;.(print
6570: 2d 63 61 6c 6c 2d 63 68 61 69 6e 20 28 63 75 72 -call-chain (cur
6580: 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 rent-error-port)
6590: 29 0a 20 20 3b 3b 09 27 28 29 29 29 29 0a 0a 28 ). ;;.'())))..(
65a0: 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d define (rmt:get-
65b0: 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 2d 73 74 tests-for-run-st
65c0: 61 74 65 2d 73 74 61 74 75 73 20 72 75 6e 2d 69 ate-status run-i
65d0: 64 20 74 65 73 74 70 61 74 74 20 6c 61 73 74 2d d testpatt last-
65e0: 75 70 64 61 74 65 29 0a 20 20 28 61 73 73 65 72 update). (asser
65f0: 74 20 28 6e 75 6d 62 65 72 3f 20 72 75 6e 2d 69 t (number? run-i
6600: 64 29 20 22 46 41 54 41 4c 3a 20 52 75 6e 20 69 d) "FATAL: Run i
6610: 64 20 72 65 71 75 69 72 65 64 2e 22 29 0a 20 20 d required.").
6620: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
6630: 65 20 27 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 e 'get-tests-for
6640: 2d 72 75 6e 2d 73 74 61 74 65 2d 73 74 61 74 75 -run-state-statu
6650: 73 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 s run-id (list r
6660: 75 6e 2d 69 64 20 74 65 73 74 70 61 74 74 20 6c un-id testpatt l
6670: 61 73 74 2d 75 70 64 61 74 65 29 29 29 0a 0a 3b ast-update)))..;
6680: 3b 20 67 65 74 20 73 74 75 66 66 20 76 69 61 20 ; get stuff via
6690: 73 79 6e 63 68 61 73 68 20 0a 28 64 65 66 69 6e synchash .(defin
66a0: 65 20 28 72 6d 74 3a 73 79 6e 63 68 61 73 68 2d e (rmt:synchash-
66b0: 67 65 74 20 72 75 6e 2d 69 64 20 70 72 6f 63 20 get run-id proc
66c0: 73 79 6e 63 6b 65 79 20 6b 65 79 6e 75 6d 20 70 synckey keynum p
66d0: 61 72 61 6d 73 29 0a 20 20 28 61 73 73 65 72 74 arams). (assert
66e0: 20 28 6e 75 6d 62 65 72 3f 20 72 75 6e 2d 69 64 (number? run-id
66f0: 29 20 22 46 41 54 41 4c 3a 20 52 75 6e 20 69 64 ) "FATAL: Run id
6700: 20 72 65 71 75 69 72 65 64 2e 22 29 0a 20 20 28 required."). (
6710: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
6720: 20 27 73 79 6e 63 68 61 73 68 2d 67 65 74 20 72 'synchash-get r
6730: 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d un-id (list run-
6740: 69 64 20 70 72 6f 63 20 73 79 6e 63 6b 65 79 20 id proc synckey
6750: 6b 65 79 6e 75 6d 20 70 61 72 61 6d 73 29 29 29 keynum params)))
6760: 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 ..(define (rmt:g
6770: 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e et-tests-for-run
6780: 2d 6d 69 6e 64 61 74 61 20 72 75 6e 2d 69 64 20 -mindata run-id
6790: 74 65 73 74 70 61 74 74 20 73 74 61 74 65 73 20 testpatt states
67a0: 73 74 61 74 75 73 20 6e 6f 74 2d 69 6e 29 0a 20 status not-in).
67b0: 20 28 61 73 73 65 72 74 20 28 6e 75 6d 62 65 72 (assert (number
67c0: 3f 20 72 75 6e 2d 69 64 29 20 22 46 41 54 41 4c ? run-id) "FATAL
67d0: 3a 20 52 75 6e 20 69 64 20 72 65 71 75 69 72 65 : Run id require
67e0: 64 2e 22 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 d."). (rmt:send
67f0: 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 74 65 -receive 'get-te
6800: 73 74 73 2d 66 6f 72 2d 72 75 6e 2d 6d 69 6e 64 sts-for-run-mind
6810: 61 74 61 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 ata run-id (list
6820: 20 72 75 6e 2d 69 64 20 74 65 73 74 70 61 74 74 run-id testpatt
6830: 20 73 74 61 74 65 73 20 73 74 61 74 75 73 20 6e states status n
6840: 6f 74 2d 69 6e 29 29 29 0a 20 20 0a 3b 3b 20 49 ot-in))). .;; I
6850: 44 45 41 3a 20 54 68 72 65 61 64 69 66 79 20 74 DEA: Threadify t
6860: 68 65 73 65 20 2d 20 74 68 65 79 20 73 70 65 6e hese - they spen
6870: 64 20 61 20 6c 6f 74 20 6f 66 20 74 69 6d 65 20 d a lot of time
6880: 77 61 69 74 69 6e 67 20 2e 2e 2e 0a 3b 3b 0a 28 waiting ....;;.(
6890: 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d define (rmt:get-
68a0: 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 73 2d 6d tests-for-runs-m
68b0: 69 6e 64 61 74 61 20 72 75 6e 2d 69 64 73 20 74 indata run-ids t
68c0: 65 73 74 70 61 74 74 20 73 74 61 74 65 73 20 73 estpatt states s
68d0: 74 61 74 75 73 20 6e 6f 74 2d 69 6e 29 0a 20 20 tatus not-in).
68e0: 28 6c 65 74 20 28 28 6d 75 6c 74 69 2d 72 75 6e (let ((multi-run
68f0: 2d 6d 75 74 65 78 20 28 6d 61 6b 65 2d 6d 75 74 -mutex (make-mut
6900: 65 78 29 29 0a 09 28 72 75 6e 2d 69 64 2d 6c 69 ex))..(run-id-li
6910: 73 74 20 28 69 66 20 72 75 6e 2d 69 64 73 0a 09 st (if run-ids..
6920: 09 09 20 72 75 6e 2d 69 64 73 0a 09 09 09 20 28 .. run-ids.... (
6930: 72 6d 74 3a 67 65 74 2d 61 6c 6c 2d 72 75 6e 2d rmt:get-all-run-
6940: 69 64 73 29 29 29 0a 09 28 72 65 73 75 6c 74 20 ids)))..(result
6950: 20 20 20 20 20 27 28 29 29 29 0a 20 20 20 20 28 '())). (
6960: 69 66 20 28 6e 75 6c 6c 3f 20 72 75 6e 2d 69 64 if (null? run-id
6970: 2d 6c 69 73 74 29 0a 09 27 28 29 0a 09 28 6c 65 -list)..'()..(le
6980: 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 20 20 20 t loop ((hed
6990: 20 28 63 61 72 20 72 75 6e 2d 69 64 2d 6c 69 73 (car run-id-lis
69a0: 74 29 29 0a 09 09 20 20 20 28 74 61 6c 20 20 20 t))... (tal
69b0: 20 20 28 63 64 72 20 72 75 6e 2d 69 64 2d 6c 69 (cdr run-id-li
69c0: 73 74 29 29 0a 09 09 20 20 20 28 74 68 72 65 61 st))... (threa
69d0: 64 73 20 27 28 29 29 29 0a 09 20 20 28 69 66 20 ds '())).. (if
69e0: 28 3e 20 28 6c 65 6e 67 74 68 20 74 68 72 65 61 (> (length threa
69f0: 64 73 29 20 35 29 0a 09 20 20 20 20 20 20 28 6c ds) 5).. (l
6a00: 6f 6f 70 20 68 65 64 20 74 61 6c 20 28 66 69 6c oop hed tal (fil
6a10: 74 65 72 20 28 6c 61 6d 62 64 61 20 28 74 68 29 ter (lambda (th)
6a20: 28 6e 6f 74 20 28 6d 65 6d 62 65 72 20 28 74 68 (not (member (th
6a30: 72 65 61 64 2d 73 74 61 74 65 20 74 68 29 20 27 read-state th) '
6a40: 28 74 65 72 6d 69 6e 61 74 65 64 20 64 65 61 64 (terminated dead
6a50: 29 29 29 29 20 74 68 72 65 61 64 73 29 29 0a 09 )))) threads))..
6a60: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 6e 65 (let* ((ne
6a70: 77 74 68 72 65 61 64 20 28 6d 61 6b 65 2d 74 68 wthread (make-th
6a80: 72 65 61 64 0a 09 09 09 09 20 28 6c 61 6d 62 64 read..... (lambd
6a90: 61 20 28 29 0a 09 09 09 09 20 20 20 28 6c 65 74 a ()..... (let
6aa0: 20 28 28 72 65 73 20 28 72 6d 74 3a 73 65 6e 64 ((res (rmt:send
6ab0: 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 74 65 -receive 'get-te
6ac0: 73 74 73 2d 66 6f 72 2d 72 75 6e 2d 6d 69 6e 64 sts-for-run-mind
6ad0: 61 74 61 20 68 65 64 20 28 6c 69 73 74 20 68 65 ata hed (list he
6ae0: 64 20 74 65 73 74 70 61 74 74 20 73 74 61 74 65 d testpatt state
6af0: 73 20 73 74 61 74 75 73 20 6e 6f 74 2d 69 6e 29 s status not-in)
6b00: 29 29 29 0a 09 09 09 09 20 20 20 20 20 28 69 66 )))..... (if
6b10: 20 28 6c 69 73 74 3f 20 72 65 73 29 0a 09 09 09 (list? res)....
6b20: 09 09 20 28 62 65 67 69 6e 0a 09 09 09 09 09 20 .. (begin......
6b30: 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 6d (mutex-lock! m
6b40: 75 6c 74 69 2d 72 75 6e 2d 6d 75 74 65 78 29 0a ulti-run-mutex).
6b50: 09 09 09 09 09 20 20 20 28 73 65 74 21 20 72 65 ..... (set! re
6b60: 73 75 6c 74 20 28 61 70 70 65 6e 64 20 72 65 73 sult (append res
6b70: 75 6c 74 20 72 65 73 29 29 0a 09 09 09 09 09 20 ult res))......
6b80: 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 (mutex-unlock!
6b90: 20 6d 75 6c 74 69 2d 72 75 6e 2d 6d 75 74 65 78 multi-run-mutex
6ba0: 29 29 0a 09 09 09 09 09 20 28 64 65 62 75 67 3a ))...... (debug:
6bb0: 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 print-error 0 *d
6bc0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
6bd0: 20 22 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d "get-tests-for-
6be0: 72 75 6e 2d 6d 69 6e 64 61 74 61 20 66 61 69 6c run-mindata fail
6bf0: 65 64 20 66 6f 72 20 72 75 6e 2d 69 64 20 22 20 ed for run-id "
6c00: 68 65 64 20 22 2c 20 74 65 73 74 70 61 74 74 20 hed ", testpatt
6c10: 22 20 74 65 73 74 70 61 74 74 20 22 2c 20 73 74 " testpatt ", st
6c20: 61 74 65 73 20 22 20 73 74 61 74 65 73 20 22 2c ates " states ",
6c30: 20 73 74 61 74 75 73 20 22 20 73 74 61 74 75 73 status " status
6c40: 20 22 2c 20 6e 6f 74 2d 69 6e 20 22 20 6e 6f 74 ", not-in " not
6c50: 2d 69 6e 29 29 29 29 0a 09 09 09 09 20 28 63 6f -in))))..... (co
6c60: 6e 63 20 22 6d 75 6c 74 69 2d 72 75 6e 2d 74 68 nc "multi-run-th
6c70: 72 65 61 64 20 66 6f 72 20 72 75 6e 2d 69 64 20 read for run-id
6c80: 22 20 68 65 64 29 29 29 0a 09 09 20 20 20 20 20 " hed)))...
6c90: 28 6e 65 77 74 68 72 65 61 64 73 20 28 63 6f 6e (newthreads (con
6ca0: 73 20 6e 65 77 74 68 72 65 61 64 20 74 68 72 65 s newthread thre
6cb0: 61 64 73 29 29 29 0a 09 09 28 74 68 72 65 61 64 ads)))...(thread
6cc0: 2d 73 74 61 72 74 21 20 6e 65 77 74 68 72 65 61 -start! newthrea
6cd0: 64 29 0a 09 09 28 74 68 72 65 61 64 2d 73 6c 65 d)...(thread-sle
6ce0: 65 70 21 20 30 2e 30 35 29 20 3b 3b 20 67 69 76 ep! 0.05) ;; giv
6cf0: 65 20 74 68 61 74 20 74 68 72 65 61 64 20 73 6f e that thread so
6d00: 6d 65 20 74 69 6d 65 20 74 6f 20 73 74 61 72 74 me time to start
6d10: 0a 09 09 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 ...(if (null? ta
6d20: 6c 29 0a 09 09 20 20 20 20 6e 65 77 74 68 72 65 l)... newthre
6d30: 61 64 73 0a 09 09 20 20 20 20 28 6c 6f 6f 70 20 ads... (loop
6d40: 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 (car tal)(cdr ta
6d50: 6c 29 20 6e 65 77 74 68 72 65 61 64 73 29 29 29 l) newthreads)))
6d60: 29 29 29 0a 20 20 20 20 72 65 73 75 6c 74 29 29 ))). result))
6d70: 0a 0a 3b 3b 20 3b 3b 20 49 44 45 41 3a 20 54 68 ..;; ;; IDEA: Th
6d80: 72 65 61 64 69 66 79 20 74 68 65 73 65 20 2d 20 readify these -
6d90: 74 68 65 79 20 73 70 65 6e 64 20 61 20 6c 6f 74 they spend a lot
6da0: 20 6f 66 20 74 69 6d 65 20 77 61 69 74 69 6e 67 of time waiting
6db0: 20 2e 2e 2e 0a 3b 3b 20 3b 3b 0a 3b 3b 20 28 64 ....;; ;;.;; (d
6dc0: 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 74 efine (rmt:get-t
6dd0: 65 73 74 73 2d 66 6f 72 2d 72 75 6e 73 2d 6d 69 ests-for-runs-mi
6de0: 6e 64 61 74 61 20 72 75 6e 2d 69 64 73 20 74 65 ndata run-ids te
6df0: 73 74 70 61 74 74 20 73 74 61 74 65 73 20 73 74 stpatt states st
6e00: 61 74 75 73 20 6e 6f 74 2d 69 6e 29 0a 3b 3b 20 atus not-in).;;
6e10: 20 20 28 6c 65 74 20 28 28 72 75 6e 2d 69 64 2d (let ((run-id-
6e20: 6c 69 73 74 20 28 69 66 20 72 75 6e 2d 69 64 73 list (if run-ids
6e30: 0a 3b 3b 20 09 09 09 20 72 75 6e 2d 69 64 73 0a .;; ... run-ids.
6e40: 3b 3b 20 09 09 09 20 28 72 6d 74 3a 67 65 74 2d ;; ... (rmt:get-
6e50: 61 6c 6c 2d 72 75 6e 2d 69 64 73 29 29 29 29 0a all-run-ids)))).
6e60: 3b 3b 20 20 20 20 20 28 61 70 70 6c 79 20 61 70 ;; (apply ap
6e70: 70 65 6e 64 20 28 6d 61 70 20 28 6c 61 6d 62 64 pend (map (lambd
6e80: 61 20 28 72 75 6e 2d 69 64 29 0a 3b 3b 20 09 09 a (run-id).;; ..
6e90: 09 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 . (rmt:send-rece
6ea0: 69 76 65 20 27 67 65 74 2d 74 65 73 74 73 2d 66 ive 'get-tests-f
6eb0: 6f 72 2d 72 75 6e 2d 6d 69 6e 64 61 74 61 20 72 or-run-mindata r
6ec0: 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d un-id (list run-
6ed0: 69 64 73 20 74 65 73 74 70 61 74 74 20 73 74 61 ids testpatt sta
6ee0: 74 65 73 20 73 74 61 74 75 73 20 6e 6f 74 2d 69 tes status not-i
6ef0: 6e 29 29 29 0a 3b 3b 20 09 09 20 20 20 20 20 20 n))).;; ..
6f00: 20 72 75 6e 2d 69 64 2d 6c 69 73 74 29 29 29 29 run-id-list))))
6f10: 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 64 ..(define (rmt:d
6f20: 65 6c 65 74 65 2d 74 65 73 74 2d 72 65 63 6f 72 elete-test-recor
6f30: 64 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 ds run-id test-i
6f40: 64 29 0a 20 20 28 61 73 73 65 72 74 20 28 6e 75 d). (assert (nu
6f50: 6d 62 65 72 3f 20 72 75 6e 2d 69 64 29 20 22 46 mber? run-id) "F
6f60: 41 54 41 4c 3a 20 52 75 6e 20 69 64 20 72 65 71 ATAL: Run id req
6f70: 75 69 72 65 64 2e 22 29 0a 20 20 28 72 6d 74 3a uired."). (rmt:
6f80: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 64 65 send-receive 'de
6f90: 6c 65 74 65 2d 74 65 73 74 2d 72 65 63 6f 72 64 lete-test-record
6fa0: 73 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 s run-id (list r
6fb0: 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 29 29 un-id test-id)))
6fc0: 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 ..(define (rmt:t
6fd0: 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 est-set-state-st
6fe0: 61 74 75 73 20 72 75 6e 2d 69 64 20 74 65 73 74 atus run-id test
6ff0: 2d 69 64 20 73 74 61 74 65 20 73 74 61 74 75 73 -id state status
7000: 20 6d 73 67 29 0a 20 20 28 61 73 73 65 72 74 20 msg). (assert
7010: 28 6e 75 6d 62 65 72 3f 20 72 75 6e 2d 69 64 29 (number? run-id)
7020: 20 22 46 41 54 41 4c 3a 20 52 75 6e 20 69 64 20 "FATAL: Run id
7030: 72 65 71 75 69 72 65 64 2e 22 29 0a 20 20 28 72 required."). (r
7040: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
7050: 27 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d 'test-set-state-
7060: 73 74 61 74 75 73 20 72 75 6e 2d 69 64 20 28 6c status run-id (l
7070: 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d ist run-id test-
7080: 69 64 20 73 74 61 74 65 20 73 74 61 74 75 73 20 id state status
7090: 6d 73 67 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 msg)))..(define
70a0: 28 72 6d 74 3a 74 65 73 74 2d 74 6f 70 6c 65 76 (rmt:test-toplev
70b0: 65 6c 2d 6e 75 6d 2d 69 74 65 6d 73 20 72 75 6e el-num-items run
70c0: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 29 0a 20 -id test-name).
70d0: 20 28 61 73 73 65 72 74 20 28 6e 75 6d 62 65 72 (assert (number
70e0: 3f 20 72 75 6e 2d 69 64 29 20 22 46 41 54 41 4c ? run-id) "FATAL
70f0: 3a 20 52 75 6e 20 69 64 20 72 65 71 75 69 72 65 : Run id require
7100: 64 2e 22 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 d."). (rmt:send
7110: 2d 72 65 63 65 69 76 65 20 27 74 65 73 74 2d 74 -receive 'test-t
7120: 6f 70 6c 65 76 65 6c 2d 6e 75 6d 2d 69 74 65 6d oplevel-num-item
7130: 73 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 s run-id (list r
7140: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 29 un-id test-name)
7150: 29 29 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 ))..;; (define (
7160: 72 6d 74 3a 67 65 74 2d 70 72 65 76 69 6f 75 73 rmt:get-previous
7170: 2d 74 65 73 74 2d 72 75 6e 2d 72 65 63 6f 72 64 -test-run-record
7180: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
7190: 65 20 69 74 65 6d 2d 70 61 74 68 29 0a 3b 3b 20 e item-path).;;
71a0: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
71b0: 69 76 65 20 27 67 65 74 2d 70 72 65 76 69 6f 75 ive 'get-previou
71c0: 73 2d 74 65 73 74 2d 72 75 6e 2d 72 65 63 6f 72 s-test-run-recor
71d0: 64 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 d run-id (list r
71e0: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 un-id test-name
71f0: 69 74 65 6d 2d 70 61 74 68 29 29 29 0a 0a 28 64 item-path)))..(d
7200: 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 6d efine (rmt:get-m
7210: 61 74 63 68 69 6e 67 2d 70 72 65 76 69 6f 75 73 atching-previous
7220: 2d 74 65 73 74 2d 72 75 6e 2d 72 65 63 6f 72 64 -test-run-record
7230: 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 s run-id test-na
7240: 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 0a 20 20 me item-path).
7250: 28 61 73 73 65 72 74 20 28 6e 75 6d 62 65 72 3f (assert (number?
7260: 20 72 75 6e 2d 69 64 29 20 22 46 41 54 41 4c 3a run-id) "FATAL:
7270: 20 52 75 6e 20 69 64 20 72 65 71 75 69 72 65 64 Run id required
7280: 2e 22 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d ."). (rmt:send-
7290: 72 65 63 65 69 76 65 20 27 67 65 74 2d 6d 61 74 receive 'get-mat
72a0: 63 68 69 6e 67 2d 70 72 65 76 69 6f 75 73 2d 74 ching-previous-t
72b0: 65 73 74 2d 72 75 6e 2d 72 65 63 6f 72 64 73 20 est-run-records
72c0: 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e run-id (list run
72d0: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 -id test-name it
72e0: 65 6d 2d 70 61 74 68 29 29 29 0a 0a 28 64 65 66 em-path)))..(def
72f0: 69 6e 65 20 28 72 6d 74 3a 74 65 73 74 2d 67 65 ine (rmt:test-ge
7300: 74 2d 6c 6f 67 66 69 6c 65 2d 69 6e 66 6f 20 72 t-logfile-info r
7310: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 29 un-id test-name)
7320: 0a 20 20 28 61 73 73 65 72 74 20 28 6e 75 6d 62 . (assert (numb
7330: 65 72 3f 20 72 75 6e 2d 69 64 29 20 22 46 41 54 er? run-id) "FAT
7340: 41 4c 3a 20 52 75 6e 20 69 64 20 72 65 71 75 69 AL: Run id requi
7350: 72 65 64 2e 22 29 0a 20 20 28 72 6d 74 3a 73 65 red."). (rmt:se
7360: 6e 64 2d 72 65 63 65 69 76 65 20 27 74 65 73 74 nd-receive 'test
7370: 2d 67 65 74 2d 6c 6f 67 66 69 6c 65 2d 69 6e 66 -get-logfile-inf
7380: 6f 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 o run-id (list r
7390: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 29 un-id test-name)
73a0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
73b0: 3a 74 65 73 74 2d 67 65 74 2d 72 65 63 6f 72 64 :test-get-record
73c0: 73 2d 66 6f 72 2d 69 6e 64 65 78 2d 66 69 6c 65 s-for-index-file
73d0: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
73e0: 65 29 0a 20 20 28 61 73 73 65 72 74 20 28 6e 75 e). (assert (nu
73f0: 6d 62 65 72 3f 20 72 75 6e 2d 69 64 29 20 22 46 mber? run-id) "F
7400: 41 54 41 4c 3a 20 52 75 6e 20 69 64 20 72 65 71 ATAL: Run id req
7410: 75 69 72 65 64 2e 22 29 0a 20 20 28 72 6d 74 3a uired."). (rmt:
7420: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 74 65 send-receive 'te
7430: 73 74 2d 67 65 74 2d 72 65 63 6f 72 64 73 2d 66 st-get-records-f
7440: 6f 72 2d 69 6e 64 65 78 2d 66 69 6c 65 20 72 75 or-index-file ru
7450: 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 n-id (list run-i
7460: 64 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a 0a d test-name)))..
7470: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 (define (rmt:get
7480: 2d 74 65 73 74 69 6e 66 6f 2d 73 74 61 74 65 2d -testinfo-state-
7490: 73 74 61 74 75 73 20 72 75 6e 2d 69 64 20 74 65 status run-id te
74a0: 73 74 2d 69 64 29 0a 20 20 28 61 73 73 65 72 74 st-id). (assert
74b0: 20 28 6e 75 6d 62 65 72 3f 20 72 75 6e 2d 69 64 (number? run-id
74c0: 29 20 22 46 41 54 41 4c 3a 20 52 75 6e 20 69 64 ) "FATAL: Run id
74d0: 20 72 65 71 75 69 72 65 64 2e 22 29 0a 20 20 28 required."). (
74e0: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
74f0: 20 27 67 65 74 2d 74 65 73 74 69 6e 66 6f 2d 73 'get-testinfo-s
7500: 74 61 74 65 2d 73 74 61 74 75 73 20 72 75 6e 2d tate-status run-
7510: 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 id (list run-id
7520: 74 65 73 74 2d 69 64 29 29 29 0a 0a 28 64 65 66 test-id)))..(def
7530: 69 6e 65 20 28 72 6d 74 3a 74 65 73 74 2d 73 65 ine (rmt:test-se
7540: 74 2d 6c 6f 67 21 20 72 75 6e 2d 69 64 20 74 65 t-log! run-id te
7550: 73 74 2d 69 64 20 6c 6f 67 66 29 0a 20 20 28 61 st-id logf). (a
7560: 73 73 65 72 74 20 28 6e 75 6d 62 65 72 3f 20 72 ssert (number? r
7570: 75 6e 2d 69 64 29 20 22 46 41 54 41 4c 3a 20 52 un-id) "FATAL: R
7580: 75 6e 20 69 64 20 72 65 71 75 69 72 65 64 2e 22 un id required."
7590: 29 0a 20 20 28 69 66 20 28 73 74 72 69 6e 67 3f ). (if (string?
75a0: 20 6c 6f 67 66 29 28 72 6d 74 3a 67 65 6e 65 72 logf)(rmt:gener
75b0: 61 6c 2d 63 61 6c 6c 20 27 74 65 73 74 2d 73 65 al-call 'test-se
75c0: 74 2d 6c 6f 67 20 72 75 6e 2d 69 64 20 6c 6f 67 t-log run-id log
75d0: 66 20 74 65 73 74 2d 69 64 29 29 29 0a 0a 28 64 f test-id)))..(d
75e0: 65 66 69 6e 65 20 28 72 6d 74 3a 74 65 73 74 2d efine (rmt:test-
75f0: 73 65 74 2d 74 6f 70 2d 70 72 6f 63 65 73 73 2d set-top-process-
7600: 70 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d pid run-id test-
7610: 69 64 20 70 69 64 29 0a 20 20 28 61 73 73 65 72 id pid). (asser
7620: 74 20 28 6e 75 6d 62 65 72 3f 20 72 75 6e 2d 69 t (number? run-i
7630: 64 29 20 22 46 41 54 41 4c 3a 20 52 75 6e 20 69 d) "FATAL: Run i
7640: 64 20 72 65 71 75 69 72 65 64 2e 22 29 0a 20 20 d required.").
7650: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
7660: 65 20 27 74 65 73 74 2d 73 65 74 2d 74 6f 70 2d e 'test-set-top-
7670: 70 72 6f 63 65 73 73 2d 70 69 64 20 72 75 6e 2d process-pid run-
7680: 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 id (list run-id
7690: 74 65 73 74 2d 69 64 20 70 69 64 29 29 29 0a 0a test-id pid)))..
76a0: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 65 73 (define (rmt:tes
76b0: 74 2d 67 65 74 2d 74 6f 70 2d 70 72 6f 63 65 73 t-get-top-proces
76c0: 73 2d 70 69 64 20 72 75 6e 2d 69 64 20 74 65 73 s-pid run-id tes
76d0: 74 2d 69 64 29 0a 20 20 28 61 73 73 65 72 74 20 t-id). (assert
76e0: 28 6e 75 6d 62 65 72 3f 20 72 75 6e 2d 69 64 29 (number? run-id)
76f0: 20 22 46 41 54 41 4c 3a 20 52 75 6e 20 69 64 20 "FATAL: Run id
7700: 72 65 71 75 69 72 65 64 2e 22 29 0a 20 20 28 72 required."). (r
7710: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
7720: 27 74 65 73 74 2d 67 65 74 2d 74 6f 70 2d 70 72 'test-get-top-pr
7730: 6f 63 65 73 73 2d 70 69 64 20 72 75 6e 2d 69 64 ocess-pid run-id
7740: 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 (list run-id te
7750: 73 74 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 6e st-id)))..(defin
7760: 65 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e 2d 69 e (rmt:get-run-i
7770: 64 73 2d 6d 61 74 63 68 69 6e 67 2d 74 61 72 67 ds-matching-targ
7780: 65 74 20 6b 65 79 6e 61 6d 65 73 20 74 61 72 67 et keynames targ
7790: 65 74 20 72 65 73 20 72 75 6e 6e 61 6d 65 20 74 et res runname t
77a0: 65 73 74 70 61 74 74 20 73 74 61 74 65 70 61 74 estpatt statepat
77b0: 74 20 73 74 61 74 75 73 70 61 74 74 29 0a 20 20 t statuspatt).
77c0: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
77d0: 65 20 27 67 65 74 2d 72 75 6e 2d 69 64 73 2d 6d e 'get-run-ids-m
77e0: 61 74 63 68 69 6e 67 2d 74 61 72 67 65 74 20 23 atching-target #
77f0: 66 20 28 6c 69 73 74 20 6b 65 79 6e 61 6d 65 73 f (list keynames
7800: 20 74 61 72 67 65 74 20 72 65 73 20 72 75 6e 6e target res runn
7810: 61 6d 65 20 74 65 73 74 70 61 74 74 20 73 74 61 ame testpatt sta
7820: 74 65 70 61 74 74 20 73 74 61 74 75 73 70 61 74 tepatt statuspat
7830: 74 29 29 29 0a 0a 3b 3b 20 4e 4f 54 45 3a 20 54 t)))..;; NOTE: T
7840: 68 69 73 20 77 69 6c 6c 20 6f 70 65 6e 20 61 6e his will open an
7850: 64 20 61 63 63 65 73 73 20 41 4c 4c 20 72 75 6e d access ALL run
7860: 20 64 61 74 61 62 61 73 65 73 2e 20 0a 3b 3b 0a databases. .;;.
7870: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 65 73 (define (rmt:tes
7880: 74 2d 67 65 74 2d 70 61 74 68 73 2d 6d 61 74 63 t-get-paths-matc
7890: 68 69 6e 67 2d 6b 65 79 6e 61 6d 65 73 2d 74 61 hing-keynames-ta
78a0: 72 67 65 74 2d 6e 65 77 20 6b 65 79 6e 61 6d 65 rget-new keyname
78b0: 73 20 74 61 72 67 65 74 20 72 65 73 20 74 65 73 s target res tes
78c0: 74 70 61 74 74 20 73 74 61 74 65 70 61 74 74 20 tpatt statepatt
78d0: 73 74 61 74 75 73 70 61 74 74 20 72 75 6e 6e 61 statuspatt runna
78e0: 6d 65 29 0a 20 20 28 6c 65 74 20 28 28 72 75 6e me). (let ((run
78f0: 2d 69 64 73 20 28 72 6d 74 3a 67 65 74 2d 72 75 -ids (rmt:get-ru
7900: 6e 2d 69 64 73 2d 6d 61 74 63 68 69 6e 67 2d 74 n-ids-matching-t
7910: 61 72 67 65 74 20 6b 65 79 6e 61 6d 65 73 20 74 arget keynames t
7920: 61 72 67 65 74 20 72 65 73 20 72 75 6e 6e 61 6d arget res runnam
7930: 65 20 74 65 73 74 70 61 74 74 20 73 74 61 74 65 e testpatt state
7940: 70 61 74 74 20 73 74 61 74 75 73 70 61 74 74 29 patt statuspatt)
7950: 29 29 0a 20 20 20 20 28 61 70 70 6c 79 20 61 70 )). (apply ap
7960: 70 65 6e 64 20 0a 09 20 20 20 28 6d 61 70 20 28 pend .. (map (
7970: 6c 61 6d 62 64 61 20 28 72 75 6e 2d 69 64 29 0a lambda (run-id).
7980: 09 09 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 .. (rmt:send-re
7990: 63 65 69 76 65 20 27 74 65 73 74 2d 67 65 74 2d ceive 'test-get-
79a0: 70 61 74 68 73 2d 6d 61 74 63 68 69 6e 67 2d 6b paths-matching-k
79b0: 65 79 6e 61 6d 65 73 2d 74 61 72 67 65 74 2d 6e eynames-target-n
79c0: 65 77 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 ew run-id (list
79d0: 72 75 6e 2d 69 64 20 6b 65 79 6e 61 6d 65 73 20 run-id keynames
79e0: 74 61 72 67 65 74 20 72 65 73 20 74 65 73 74 70 target res testp
79f0: 61 74 74 20 73 74 61 74 65 70 61 74 74 20 73 74 att statepatt st
7a00: 61 74 75 73 70 61 74 74 20 72 75 6e 6e 61 6d 65 atuspatt runname
7a10: 29 29 29 0a 09 20 20 20 72 75 6e 2d 69 64 73 29 ))).. run-ids)
7a20: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d )))..(define (rm
7a30: 74 3a 67 65 74 2d 70 72 65 72 65 71 73 2d 6e 6f t:get-prereqs-no
7a40: 74 2d 6d 65 74 20 72 75 6e 2d 69 64 20 77 61 69 t-met run-id wai
7a50: 74 6f 6e 73 20 72 65 66 2d 74 65 73 74 2d 6e 61 tons ref-test-na
7a60: 6d 65 20 72 65 66 2d 69 74 65 6d 2d 70 61 74 68 me ref-item-path
7a70: 20 23 21 6b 65 79 20 28 6d 6f 64 65 20 27 28 6e #!key (mode '(n
7a80: 6f 72 6d 61 6c 29 29 28 69 74 65 6d 6d 61 70 73 ormal))(itemmaps
7a90: 20 23 66 29 29 0a 20 20 28 61 73 73 65 72 74 20 #f)). (assert
7aa0: 28 6e 75 6d 62 65 72 3f 20 72 75 6e 2d 69 64 29 (number? run-id)
7ab0: 20 22 46 41 54 41 4c 3a 20 52 75 6e 20 69 64 20 "FATAL: Run id
7ac0: 72 65 71 75 69 72 65 64 2e 22 29 0a 20 20 28 72 required."). (r
7ad0: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
7ae0: 27 67 65 74 2d 70 72 65 72 65 71 73 2d 6e 6f 74 'get-prereqs-not
7af0: 2d 6d 65 74 20 72 75 6e 2d 69 64 20 28 6c 69 73 -met run-id (lis
7b00: 74 20 72 75 6e 2d 69 64 20 77 61 69 74 6f 6e 73 t run-id waitons
7b10: 20 72 65 66 2d 74 65 73 74 2d 6e 61 6d 65 20 72 ref-test-name r
7b20: 65 66 2d 69 74 65 6d 2d 70 61 74 68 20 6d 6f 64 ef-item-path mod
7b30: 65 20 69 74 65 6d 6d 61 70 73 29 29 29 0a 0a 28 e itemmaps)))..(
7b40: 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d define (rmt:get-
7b50: 63 6f 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e 6e count-tests-runn
7b60: 69 6e 67 2d 66 6f 72 2d 72 75 6e 2d 69 64 20 72 ing-for-run-id r
7b70: 75 6e 2d 69 64 29 0a 20 20 28 61 73 73 65 72 74 un-id). (assert
7b80: 20 28 6e 75 6d 62 65 72 3f 20 72 75 6e 2d 69 64 (number? run-id
7b90: 29 20 22 46 41 54 41 4c 3a 20 52 75 6e 20 69 64 ) "FATAL: Run id
7ba0: 20 72 65 71 75 69 72 65 64 2e 22 29 0a 20 20 28 required."). (
7bb0: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
7bc0: 20 27 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 'get-count-test
7bd0: 73 2d 72 75 6e 6e 69 6e 67 2d 66 6f 72 2d 72 75 s-running-for-ru
7be0: 6e 2d 69 64 20 72 75 6e 2d 69 64 20 28 6c 69 73 n-id run-id (lis
7bf0: 74 20 72 75 6e 2d 69 64 29 29 29 0a 0a 28 64 65 t run-id)))..(de
7c00: 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 6e 6f fine (rmt:get-no
7c10: 74 2d 63 6f 6d 70 6c 65 74 65 64 2d 63 6e 74 20 t-completed-cnt
7c20: 72 75 6e 2d 69 64 29 0a 20 20 28 61 73 73 65 72 run-id). (asser
7c30: 74 20 28 6e 75 6d 62 65 72 3f 20 72 75 6e 2d 69 t (number? run-i
7c40: 64 29 20 22 46 41 54 41 4c 3a 20 52 75 6e 20 69 d) "FATAL: Run i
7c50: 64 20 72 65 71 75 69 72 65 64 2e 22 29 0a 20 20 d required.").
7c60: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
7c70: 65 20 27 67 65 74 2d 6e 6f 74 2d 63 6f 6d 70 6c e 'get-not-compl
7c80: 65 74 65 64 2d 63 6e 74 20 72 75 6e 2d 69 64 20 eted-cnt run-id
7c90: 28 6c 69 73 74 20 72 75 6e 2d 69 64 29 29 29 0a (list run-id))).
7ca0: 0a 0a 3b 3b 20 53 74 61 74 69 73 74 69 63 61 6c ..;; Statistical
7cb0: 20 71 75 65 72 69 65 73 0a 0a 28 64 65 66 69 6e queries..(defin
7cc0: 65 20 28 72 6d 74 3a 67 65 74 2d 63 6f 75 6e 74 e (rmt:get-count
7cd0: 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 20 72 -tests-running r
7ce0: 75 6e 2d 69 64 29 0a 20 20 28 61 73 73 65 72 74 un-id). (assert
7cf0: 20 28 6e 75 6d 62 65 72 3f 20 72 75 6e 2d 69 64 (number? run-id
7d00: 29 20 22 46 41 54 41 4c 3a 20 52 75 6e 20 69 64 ) "FATAL: Run id
7d10: 20 72 65 71 75 69 72 65 64 2e 22 29 0a 20 20 28 required."). (
7d20: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
7d30: 20 27 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 'get-count-test
7d40: 73 2d 72 75 6e 6e 69 6e 67 20 72 75 6e 2d 69 64 s-running run-id
7d50: 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 29 29 29 (list run-id)))
7d60: 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 ..(define (rmt:g
7d70: 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d 72 et-count-tests-r
7d80: 75 6e 6e 69 6e 67 2d 66 6f 72 2d 74 65 73 74 6e unning-for-testn
7d90: 61 6d 65 20 72 75 6e 2d 69 64 20 74 65 73 74 6e ame run-id testn
7da0: 61 6d 65 29 0a 20 20 28 61 73 73 65 72 74 20 28 ame). (assert (
7db0: 6e 75 6d 62 65 72 3f 20 72 75 6e 2d 69 64 29 20 number? run-id)
7dc0: 22 46 41 54 41 4c 3a 20 52 75 6e 20 69 64 20 72 "FATAL: Run id r
7dd0: 65 71 75 69 72 65 64 2e 22 29 0a 20 20 28 72 6d equired."). (rm
7de0: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
7df0: 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d get-count-tests-
7e00: 72 75 6e 6e 69 6e 67 2d 66 6f 72 2d 74 65 73 74 running-for-test
7e10: 6e 61 6d 65 20 72 75 6e 2d 69 64 20 28 6c 69 73 name run-id (lis
7e20: 74 20 72 75 6e 2d 69 64 20 74 65 73 74 6e 61 6d t run-id testnam
7e30: 65 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 e)))..(define (r
7e40: 6d 74 3a 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 mt:get-count-tes
7e50: 74 73 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f ts-running-in-jo
7e60: 62 67 72 6f 75 70 20 72 75 6e 2d 69 64 20 6a 6f bgroup run-id jo
7e70: 62 67 72 6f 75 70 29 0a 20 20 28 61 73 73 65 72 bgroup). (asser
7e80: 74 20 28 6e 75 6d 62 65 72 3f 20 72 75 6e 2d 69 t (number? run-i
7e90: 64 29 20 22 46 41 54 41 4c 3a 20 52 75 6e 20 69 d) "FATAL: Run i
7ea0: 64 20 72 65 71 75 69 72 65 64 2e 22 29 0a 20 20 d required.").
7eb0: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
7ec0: 65 20 27 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 e 'get-count-tes
7ed0: 74 73 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f ts-running-in-jo
7ee0: 62 67 72 6f 75 70 20 72 75 6e 2d 69 64 20 28 6c bgroup run-id (l
7ef0: 69 73 74 20 72 75 6e 2d 69 64 20 6a 6f 62 67 72 ist run-id jobgr
7f00: 6f 75 70 29 29 29 0a 0a 3b 3b 20 73 74 61 74 65 oup)))..;; state
7f10: 20 61 6e 64 20 73 74 61 74 75 73 20 61 72 65 20 and status are
7f20: 65 78 74 72 61 20 68 69 6e 74 73 20 6e 6f 74 20 extra hints not
7f30: 75 73 75 61 6c 6c 79 20 75 73 65 64 20 69 6e 20 usually used in
7f40: 74 68 65 20 63 61 6c 63 75 6c 61 74 69 6f 6e 0a the calculation.
7f50: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a ;;.(define (rmt:
7f60: 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 set-state-status
7f70: 2d 61 6e 64 2d 72 6f 6c 6c 2d 75 70 2d 69 74 65 -and-roll-up-ite
7f80: 6d 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e ms run-id test-n
7f90: 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 73 74 ame item-path st
7fa0: 61 74 65 20 73 74 61 74 75 73 20 63 6f 6d 6d 65 ate status comme
7fb0: 6e 74 29 0a 20 20 28 61 73 73 65 72 74 20 28 6e nt). (assert (n
7fc0: 75 6d 62 65 72 3f 20 72 75 6e 2d 69 64 29 20 22 umber? run-id) "
7fd0: 46 41 54 41 4c 3a 20 52 75 6e 20 69 64 20 72 65 FATAL: Run id re
7fe0: 71 75 69 72 65 64 2e 22 29 0a 20 20 28 72 6d 74 quired."). (rmt
7ff0: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 73 :send-receive 's
8000: 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d et-state-status-
8010: 61 6e 64 2d 72 6f 6c 6c 2d 75 70 2d 69 74 65 6d and-roll-up-item
8020: 73 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 s run-id (list r
8030: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 un-id test-name
8040: 69 74 65 6d 2d 70 61 74 68 20 73 74 61 74 65 20 item-path state
8050: 73 74 61 74 75 73 20 63 6f 6d 6d 65 6e 74 29 29 status comment))
8060: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a )..(define (rmt:
8070: 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 set-state-status
8080: 2d 61 6e 64 2d 72 6f 6c 6c 2d 75 70 2d 72 75 6e -and-roll-up-run
8090: 20 72 75 6e 2d 69 64 20 73 74 61 74 65 20 73 74 run-id state st
80a0: 61 74 75 73 29 0a 20 20 28 61 73 73 65 72 74 20 atus). (assert
80b0: 28 6e 75 6d 62 65 72 3f 20 72 75 6e 2d 69 64 29 (number? run-id)
80c0: 20 22 46 41 54 41 4c 3a 20 52 75 6e 20 69 64 20 "FATAL: Run id
80d0: 72 65 71 75 69 72 65 64 2e 22 29 0a 20 20 28 72 required."). (r
80e0: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
80f0: 27 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 'set-state-statu
8100: 73 2d 61 6e 64 2d 72 6f 6c 6c 2d 75 70 2d 72 75 s-and-roll-up-ru
8110: 6e 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 n run-id (list r
8120: 75 6e 2d 69 64 20 73 74 61 74 65 20 73 74 61 74 un-id state stat
8130: 75 73 29 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 us)))...(define
8140: 28 72 6d 74 3a 75 70 64 61 74 65 2d 70 61 73 73 (rmt:update-pass
8150: 2d 66 61 69 6c 2d 63 6f 75 6e 74 73 20 72 75 6e -fail-counts run
8160: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 29 0a 20 -id test-name).
8170: 20 28 61 73 73 65 72 74 20 28 6e 75 6d 62 65 72 (assert (number
8180: 3f 20 72 75 6e 2d 69 64 29 20 22 46 41 54 41 4c ? run-id) "FATAL
8190: 3a 20 52 75 6e 20 69 64 20 72 65 71 75 69 72 65 : Run id require
81a0: 64 2e 22 29 0a 20 20 28 72 6d 74 3a 67 65 6e 65 d."). (rmt:gene
81b0: 72 61 6c 2d 63 61 6c 6c 20 27 75 70 64 61 74 65 ral-call 'update
81c0: 2d 70 61 73 73 2d 66 61 69 6c 2d 63 6f 75 6e 74 -pass-fail-count
81d0: 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 s run-id test-na
81e0: 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 me test-name tes
81f0: 74 2d 6e 61 6d 65 29 29 0a 0a 28 64 65 66 69 6e t-name))..(defin
8200: 65 20 28 72 6d 74 3a 74 6f 70 2d 74 65 73 74 2d e (rmt:top-test-
8210: 73 65 74 2d 70 65 72 2d 70 66 2d 63 6f 75 6e 74 set-per-pf-count
8220: 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 s run-id test-na
8230: 6d 65 29 0a 20 20 28 61 73 73 65 72 74 20 28 6e me). (assert (n
8240: 75 6d 62 65 72 3f 20 72 75 6e 2d 69 64 29 20 22 umber? run-id) "
8250: 46 41 54 41 4c 3a 20 52 75 6e 20 69 64 20 72 65 FATAL: Run id re
8260: 71 75 69 72 65 64 2e 22 29 0a 20 20 28 72 6d 74 quired."). (rmt
8270: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 74 :send-receive 't
8280: 6f 70 2d 74 65 73 74 2d 73 65 74 2d 70 65 72 2d op-test-set-per-
8290: 70 66 2d 63 6f 75 6e 74 73 20 72 75 6e 2d 69 64 pf-counts run-id
82a0: 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 (list run-id te
82b0: 73 74 2d 6e 61 6d 65 29 29 29 0a 0a 28 64 65 66 st-name)))..(def
82c0: 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 72 61 77 ine (rmt:get-raw
82d0: 2d 72 75 6e 2d 73 74 61 74 73 20 72 75 6e 2d 69 -run-stats run-i
82e0: 64 29 0a 20 20 28 61 73 73 65 72 74 20 28 6e 75 d). (assert (nu
82f0: 6d 62 65 72 3f 20 72 75 6e 2d 69 64 29 20 22 46 mber? run-id) "F
8300: 41 54 41 4c 3a 20 52 75 6e 20 69 64 20 72 65 71 ATAL: Run id req
8310: 75 69 72 65 64 2e 22 29 0a 20 20 28 72 6d 74 3a uired."). (rmt:
8320: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 send-receive 'ge
8330: 74 2d 72 61 77 2d 72 75 6e 2d 73 74 61 74 73 20 t-raw-run-stats
8340: 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e run-id (list run
8350: 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 -id)))..(define
8360: 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 74 69 (rmt:get-test-ti
8370: 6d 65 73 20 72 75 6e 6e 61 6d 65 20 74 61 72 67 mes runname targ
8380: 65 74 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d et). (rmt:send-
8390: 72 65 63 65 69 76 65 20 27 67 65 74 2d 74 65 73 receive 'get-tes
83a0: 74 2d 74 69 6d 65 73 20 23 66 20 28 6c 69 73 74 t-times #f (list
83b0: 20 72 75 6e 6e 61 6d 65 20 74 61 72 67 65 74 20 runname target
83c0: 29 29 29 20 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d ))) ..;;========
83d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
83e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
83f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8400: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
8410: 3b 20 20 52 20 55 20 4e 20 53 0a 3b 3b 3d 3d 3d ; R U N S.;;===
8420: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8430: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8440: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8450: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8460: 3d 3d 3d 0a 0a 3b 3b 20 42 55 47 20 2d 20 4c 4f ===..;; BUG - LO
8470: 4f 4b 20 41 54 20 48 4f 57 20 54 48 49 53 20 57 OK AT HOW THIS W
8480: 4f 52 4b 53 21 21 21 0a 3b 3b 0a 28 64 65 66 69 ORKS!!!.;;.(defi
8490: 6e 65 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e 2d ne (rmt:get-run-
84a0: 69 6e 66 6f 20 72 75 6e 2d 69 64 29 0a 20 20 28 info run-id). (
84b0: 61 73 73 65 72 74 20 28 6e 75 6d 62 65 72 3f 20 assert (number?
84c0: 72 75 6e 2d 69 64 29 20 22 46 41 54 41 4c 3a 20 run-id) "FATAL:
84d0: 52 75 6e 20 69 64 20 72 65 71 75 69 72 65 64 2e Run id required.
84e0: 22 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 "). (rmt:send-r
84f0: 65 63 65 69 76 65 20 27 67 65 74 2d 72 75 6e 2d eceive 'get-run-
8500: 69 6e 66 6f 20 23 66 20 28 6c 69 73 74 20 72 75 info #f (list ru
8510: 6e 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 n-id)))..(define
8520: 20 28 72 6d 74 3a 67 65 74 2d 6e 75 6d 2d 72 75 (rmt:get-num-ru
8530: 6e 73 20 72 75 6e 70 61 74 74 29 0a 20 20 28 72 ns runpatt). (r
8540: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
8550: 27 67 65 74 2d 6e 75 6d 2d 72 75 6e 73 20 23 66 'get-num-runs #f
8560: 20 28 6c 69 73 74 20 72 75 6e 70 61 74 74 29 29 (list runpatt))
8570: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a )..(define (rmt:
8580: 67 65 74 2d 72 75 6e 73 2d 63 6e 74 2d 62 79 2d get-runs-cnt-by-
8590: 70 61 74 74 20 72 75 6e 70 61 74 74 20 74 61 72 patt runpatt tar
85a0: 67 65 74 70 61 74 74 20 6b 65 79 73 29 0a 20 20 getpatt keys).
85b0: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
85c0: 65 20 27 67 65 74 2d 72 75 6e 73 2d 63 6e 74 2d e 'get-runs-cnt-
85d0: 62 79 2d 70 61 74 74 20 23 66 20 28 6c 69 73 74 by-patt #f (list
85e0: 20 72 75 6e 70 61 74 74 20 20 74 61 72 67 65 74 runpatt target
85f0: 70 61 74 74 20 6b 65 79 73 29 29 29 0a 0a 3b 3b patt keys)))..;;
8600: 20 55 73 65 20 74 68 65 20 73 70 65 63 69 61 6c Use the special
8610: 20 72 75 6e 2d 69 64 20 3d 3d 20 23 66 20 73 63 run-id == #f sc
8620: 65 6e 61 72 69 6f 20 68 65 72 65 20 73 69 6e 63 enario here sinc
8630: 65 20 74 68 65 72 65 20 69 73 20 6e 6f 20 72 75 e there is no ru
8640: 6e 20 79 65 74 0a 28 64 65 66 69 6e 65 20 28 72 n yet.(define (r
8650: 6d 74 3a 72 65 67 69 73 74 65 72 2d 72 75 6e 20 mt:register-run
8660: 6b 65 79 76 61 6c 73 20 72 75 6e 6e 61 6d 65 20 keyvals runname
8670: 73 74 61 74 65 20 73 74 61 74 75 73 20 75 73 65 state status use
8680: 72 20 63 6f 6e 74 6f 75 72 29 0a 20 20 28 72 6d r contour). (rm
8690: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
86a0: 72 65 67 69 73 74 65 72 2d 72 75 6e 20 23 66 20 register-run #f
86b0: 28 6c 69 73 74 20 6b 65 79 76 61 6c 73 20 72 75 (list keyvals ru
86c0: 6e 6e 61 6d 65 20 73 74 61 74 65 20 73 74 61 74 nname state stat
86d0: 75 73 20 75 73 65 72 20 63 6f 6e 74 6f 75 72 29 us user contour)
86e0: 29 29 0a 20 20 20 20 0a 28 64 65 66 69 6e 65 20 )). .(define
86f0: 28 72 6d 74 3a 67 65 74 2d 72 75 6e 2d 6e 61 6d (rmt:get-run-nam
8700: 65 2d 66 72 6f 6d 2d 69 64 20 72 75 6e 2d 69 64 e-from-id run-id
8710: 29 0a 20 20 28 61 73 73 65 72 74 20 28 6e 75 6d ). (assert (num
8720: 62 65 72 3f 20 72 75 6e 2d 69 64 29 20 22 46 41 ber? run-id) "FA
8730: 54 41 4c 3a 20 52 75 6e 20 69 64 20 72 65 71 75 TAL: Run id requ
8740: 69 72 65 64 2e 22 29 0a 20 20 28 72 6d 74 3a 73 ired."). (rmt:s
8750: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 end-receive 'get
8760: 2d 72 75 6e 2d 6e 61 6d 65 2d 66 72 6f 6d 2d 69 -run-name-from-i
8770: 64 20 23 66 20 28 6c 69 73 74 20 72 75 6e 2d 69 d #f (list run-i
8780: 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 d)))..(define (r
8790: 6d 74 3a 64 65 6c 65 74 65 2d 72 75 6e 20 72 75 mt:delete-run ru
87a0: 6e 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e n-id). (rmt:sen
87b0: 64 2d 72 65 63 65 69 76 65 20 27 64 65 6c 65 74 d-receive 'delet
87c0: 65 2d 72 75 6e 20 23 66 20 28 6c 69 73 74 20 72 e-run #f (list r
87d0: 75 6e 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 6e un-id)))..(defin
87e0: 65 20 28 72 6d 74 3a 75 70 64 61 74 65 2d 72 75 e (rmt:update-ru
87f0: 6e 2d 73 74 61 74 73 20 72 75 6e 2d 69 64 20 73 n-stats run-id s
8800: 74 61 74 73 29 0a 20 20 28 72 6d 74 3a 73 65 6e tats). (rmt:sen
8810: 64 2d 72 65 63 65 69 76 65 20 27 75 70 64 61 74 d-receive 'updat
8820: 65 2d 72 75 6e 2d 73 74 61 74 73 20 23 66 20 28 e-run-stats #f (
8830: 6c 69 73 74 20 72 75 6e 2d 69 64 20 73 74 61 74 list run-id stat
8840: 73 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 s)))..(define (r
8850: 6d 74 3a 64 65 6c 65 74 65 2d 6f 6c 64 2d 64 65 mt:delete-old-de
8860: 6c 65 74 65 64 2d 74 65 73 74 2d 72 65 63 6f 72 leted-test-recor
8870: 64 73 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d ds). (rmt:send-
8880: 72 65 63 65 69 76 65 20 27 64 65 6c 65 74 65 2d receive 'delete-
8890: 6f 6c 64 2d 64 65 6c 65 74 65 64 2d 74 65 73 74 old-deleted-test
88a0: 2d 72 65 63 6f 72 64 73 20 23 66 20 27 28 29 29 -records #f '())
88b0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a )..(define (rmt:
88c0: 67 65 74 2d 72 75 6e 73 20 72 75 6e 70 61 74 74 get-runs runpatt
88d0: 20 63 6f 75 6e 74 20 6f 66 66 73 65 74 20 6b 65 count offset ke
88e0: 79 70 61 74 74 73 29 0a 20 20 28 72 6d 74 3a 73 ypatts). (rmt:s
88f0: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 end-receive 'get
8900: 2d 72 75 6e 73 20 23 66 20 28 6c 69 73 74 20 72 -runs #f (list r
8910: 75 6e 70 61 74 74 20 63 6f 75 6e 74 20 6f 66 66 unpatt count off
8920: 73 65 74 20 6b 65 79 70 61 74 74 73 29 29 29 0a set keypatts))).
8930: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 73 69 .(define (rmt:si
8940: 6d 70 6c 65 2d 67 65 74 2d 72 75 6e 73 20 72 75 mple-get-runs ru
8950: 6e 70 61 74 74 20 63 6f 75 6e 74 20 6f 66 66 73 npatt count offs
8960: 65 74 20 74 61 72 67 65 74 20 6c 61 73 74 2d 75 et target last-u
8970: 70 64 61 74 65 29 0a 20 20 28 72 6d 74 3a 73 65 pdate). (rmt:se
8980: 6e 64 2d 72 65 63 65 69 76 65 20 27 73 69 6d 70 nd-receive 'simp
8990: 6c 65 2d 67 65 74 2d 72 75 6e 73 20 23 66 20 28 le-get-runs #f (
89a0: 6c 69 73 74 20 72 75 6e 70 61 74 74 20 63 6f 75 list runpatt cou
89b0: 6e 74 20 6f 66 66 73 65 74 20 74 61 72 67 65 74 nt offset target
89c0: 20 6c 61 73 74 2d 75 70 64 61 74 65 29 29 29 0a last-update))).
89d0: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 .(define (rmt:ge
89e0: 74 2d 61 6c 6c 2d 72 75 6e 2d 69 64 73 29 0a 20 t-all-run-ids).
89f0: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
8a00: 76 65 20 27 67 65 74 2d 61 6c 6c 2d 72 75 6e 2d ve 'get-all-run-
8a10: 69 64 73 20 23 66 20 27 28 29 29 29 0a 0a 28 64 ids #f '()))..(d
8a20: 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 70 efine (rmt:get-p
8a30: 72 65 76 2d 72 75 6e 2d 69 64 73 20 72 75 6e 2d rev-run-ids run-
8a40: 69 64 29 0a 20 20 28 61 73 73 65 72 74 20 28 6e id). (assert (n
8a50: 75 6d 62 65 72 3f 20 72 75 6e 2d 69 64 29 20 22 umber? run-id) "
8a60: 46 41 54 41 4c 3a 20 52 75 6e 20 69 64 20 72 65 FATAL: Run id re
8a70: 71 75 69 72 65 64 2e 22 29 0a 20 20 28 72 6d 74 quired."). (rmt
8a80: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 :send-receive 'g
8a90: 65 74 2d 70 72 65 76 2d 72 75 6e 2d 69 64 73 20 et-prev-run-ids
8aa0: 23 66 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 29 #f (list run-id)
8ab0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
8ac0: 3a 6c 6f 63 6b 2f 75 6e 6c 6f 63 6b 2d 72 75 6e :lock/unlock-run
8ad0: 20 72 75 6e 2d 69 64 20 6c 6f 63 6b 20 75 6e 6c run-id lock unl
8ae0: 6f 63 6b 20 75 73 65 72 29 0a 20 20 28 61 73 73 ock user). (ass
8af0: 65 72 74 20 28 6e 75 6d 62 65 72 3f 20 72 75 6e ert (number? run
8b00: 2d 69 64 29 20 22 46 41 54 41 4c 3a 20 52 75 6e -id) "FATAL: Run
8b10: 20 69 64 20 72 65 71 75 69 72 65 64 2e 22 29 0a id required.").
8b20: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
8b30: 69 76 65 20 27 6c 6f 63 6b 2f 75 6e 6c 6f 63 6b ive 'lock/unlock
8b40: 2d 72 75 6e 20 23 66 20 28 6c 69 73 74 20 72 75 -run #f (list ru
8b50: 6e 2d 69 64 20 6c 6f 63 6b 20 75 6e 6c 6f 63 6b n-id lock unlock
8b60: 20 75 73 65 72 29 29 29 0a 0a 3b 3b 20 73 65 74 user)))..;; set
8b70: 2f 67 65 74 20 73 74 61 74 75 73 0a 28 64 65 66 /get status.(def
8b80: 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e ine (rmt:get-run
8b90: 2d 73 74 61 74 75 73 20 72 75 6e 2d 69 64 29 0a -status run-id).
8ba0: 20 20 28 61 73 73 65 72 74 20 28 6e 75 6d 62 65 (assert (numbe
8bb0: 72 3f 20 72 75 6e 2d 69 64 29 20 22 46 41 54 41 r? run-id) "FATA
8bc0: 4c 3a 20 52 75 6e 20 69 64 20 72 65 71 75 69 72 L: Run id requir
8bd0: 65 64 2e 22 29 0a 20 20 28 72 6d 74 3a 73 65 6e ed."). (rmt:sen
8be0: 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 72 d-receive 'get-r
8bf0: 75 6e 2d 73 74 61 74 75 73 20 23 66 20 28 6c 69 un-status #f (li
8c00: 73 74 20 72 75 6e 2d 69 64 29 29 29 0a 0a 28 64 st run-id)))..(d
8c10: 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 72 efine (rmt:get-r
8c20: 75 6e 2d 73 74 61 74 65 20 72 75 6e 2d 69 64 29 un-state run-id)
8c30: 0a 20 20 28 61 73 73 65 72 74 20 28 6e 75 6d 62 . (assert (numb
8c40: 65 72 3f 20 72 75 6e 2d 69 64 29 20 22 46 41 54 er? run-id) "FAT
8c50: 41 4c 3a 20 52 75 6e 20 69 64 20 72 65 71 75 69 AL: Run id requi
8c60: 72 65 64 2e 22 29 0a 20 20 28 72 6d 74 3a 73 65 red."). (rmt:se
8c70: 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d nd-receive 'get-
8c80: 72 75 6e 2d 73 74 61 74 65 20 23 66 20 28 6c 69 run-state #f (li
8c90: 73 74 20 72 75 6e 2d 69 64 29 29 29 0a 0a 28 64 st run-id)))..(d
8ca0: 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 72 efine (rmt:get-r
8cb0: 75 6e 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 un-state-status
8cc0: 72 75 6e 2d 69 64 29 0a 20 20 28 61 73 73 65 72 run-id). (asser
8cd0: 74 20 28 6e 75 6d 62 65 72 3f 20 72 75 6e 2d 69 t (number? run-i
8ce0: 64 29 20 22 46 41 54 41 4c 3a 20 52 75 6e 20 69 d) "FATAL: Run i
8cf0: 64 20 72 65 71 75 69 72 65 64 2e 22 29 0a 20 20 d required.").
8d00: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
8d10: 65 20 27 67 65 74 2d 72 75 6e 2d 73 74 61 74 65 e 'get-run-state
8d20: 2d 73 74 61 74 75 73 20 23 66 20 28 6c 69 73 74 -status #f (list
8d30: 20 72 75 6e 2d 69 64 29 29 29 0a 0a 28 64 65 66 run-id)))..(def
8d40: 69 6e 65 20 28 72 6d 74 3a 73 65 74 2d 72 75 6e ine (rmt:set-run
8d50: 2d 73 74 61 74 75 73 20 72 75 6e 2d 69 64 20 72 -status run-id r
8d60: 75 6e 2d 73 74 61 74 75 73 20 23 21 6b 65 79 20 un-status #!key
8d70: 28 6d 73 67 20 23 66 29 29 0a 20 20 28 61 73 73 (msg #f)). (ass
8d80: 65 72 74 20 28 6e 75 6d 62 65 72 3f 20 72 75 6e ert (number? run
8d90: 2d 69 64 29 20 22 46 41 54 41 4c 3a 20 52 75 6e -id) "FATAL: Run
8da0: 20 69 64 20 72 65 71 75 69 72 65 64 2e 22 29 0a id required.").
8db0: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
8dc0: 69 76 65 20 27 73 65 74 2d 72 75 6e 2d 73 74 61 ive 'set-run-sta
8dd0: 74 75 73 20 23 66 20 28 6c 69 73 74 20 72 75 6e tus #f (list run
8de0: 2d 69 64 20 72 75 6e 2d 73 74 61 74 75 73 20 6d -id run-status m
8df0: 73 67 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 sg)))..(define (
8e00: 72 6d 74 3a 73 65 74 2d 72 75 6e 2d 73 74 61 74 rmt:set-run-stat
8e10: 65 2d 73 74 61 74 75 73 20 72 75 6e 2d 69 64 20 e-status run-id
8e20: 73 74 61 74 65 20 73 74 61 74 75 73 20 29 0a 20 state status ).
8e30: 20 28 61 73 73 65 72 74 20 28 6e 75 6d 62 65 72 (assert (number
8e40: 3f 20 72 75 6e 2d 69 64 29 20 22 46 41 54 41 4c ? run-id) "FATAL
8e50: 3a 20 52 75 6e 20 69 64 20 72 65 71 75 69 72 65 : Run id require
8e60: 64 2e 22 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 d."). (rmt:send
8e70: 2d 72 65 63 65 69 76 65 20 27 73 65 74 2d 72 75 -receive 'set-ru
8e80: 6e 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 23 n-state-status #
8e90: 66 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 73 f (list run-id s
8ea0: 74 61 74 65 20 73 74 61 74 75 73 29 29 29 0a 0a tate status)))..
8eb0: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 75 70 64 (define (rmt:upd
8ec0: 61 74 65 2d 74 65 73 64 61 74 61 2d 6f 6e 2d 72 ate-tesdata-on-r
8ed0: 65 70 69 6c 63 61 74 65 2d 64 62 20 6f 6c 64 2d epilcate-db old-
8ee0: 6c 74 20 6e 65 77 2d 6c 74 29 0a 28 72 6d 74 3a lt new-lt).(rmt:
8ef0: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 75 70 send-receive 'up
8f00: 64 61 74 65 2d 74 65 73 64 61 74 61 2d 6f 6e 2d date-tesdata-on-
8f10: 72 65 70 69 6c 63 61 74 65 2d 64 62 20 23 66 20 repilcate-db #f
8f20: 28 6c 69 73 74 20 6f 6c 64 2d 6c 74 20 6e 65 77 (list old-lt new
8f30: 2d 6c 74 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 -lt)))..(define
8f40: 28 72 6d 74 3a 75 70 64 61 74 65 2d 72 75 6e 2d (rmt:update-run-
8f50: 65 76 65 6e 74 5f 74 69 6d 65 20 72 75 6e 2d 69 event_time run-i
8f60: 64 29 0a 20 20 28 61 73 73 65 72 74 20 28 6e 75 d). (assert (nu
8f70: 6d 62 65 72 3f 20 72 75 6e 2d 69 64 29 20 22 46 mber? run-id) "F
8f80: 41 54 41 4c 3a 20 52 75 6e 20 69 64 20 72 65 71 ATAL: Run id req
8f90: 75 69 72 65 64 2e 22 29 0a 20 20 28 72 6d 74 3a uired."). (rmt:
8fa0: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 75 70 send-receive 'up
8fb0: 64 61 74 65 2d 72 75 6e 2d 65 76 65 6e 74 5f 74 date-run-event_t
8fc0: 69 6d 65 20 23 66 20 28 6c 69 73 74 20 72 75 6e ime #f (list run
8fd0: 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 -id)))..(define
8fe0: 28 72 6d 74 3a 67 65 74 2d 72 75 6e 73 2d 62 79 (rmt:get-runs-by
8ff0: 2d 70 61 74 74 20 20 6b 65 79 73 20 72 75 6e 6e -patt keys runn
9000: 61 6d 65 70 61 74 74 20 74 61 72 67 70 61 74 74 amepatt targpatt
9010: 20 6f 66 66 73 65 74 20 6c 69 6d 69 74 20 66 69 offset limit fi
9020: 65 6c 64 73 20 6c 61 73 74 2d 72 75 6e 73 2d 75 elds last-runs-u
9030: 70 64 61 74 65 20 20 23 21 6b 65 79 20 20 28 73 pdate #!key (s
9040: 6f 72 74 2d 6f 72 64 65 72 20 22 61 73 63 22 29 ort-order "asc")
9050: 29 20 3b 3b 20 66 69 65 6c 64 73 20 6f 66 20 23 ) ;; fields of #
9060: 66 20 75 73 65 73 20 64 65 66 61 75 6c 74 0a 20 f uses default.
9070: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
9080: 76 65 20 27 67 65 74 2d 72 75 6e 73 2d 62 79 2d ve 'get-runs-by-
9090: 70 61 74 74 20 23 66 20 28 6c 69 73 74 20 6b 65 patt #f (list ke
90a0: 79 73 20 72 75 6e 6e 61 6d 65 70 61 74 74 20 74 ys runnamepatt t
90b0: 61 72 67 70 61 74 74 20 6f 66 66 73 65 74 20 6c argpatt offset l
90c0: 69 6d 69 74 20 66 69 65 6c 64 73 20 6c 61 73 74 imit fields last
90d0: 2d 72 75 6e 73 2d 75 70 64 61 74 65 20 73 6f 72 -runs-update sor
90e0: 74 2d 6f 72 64 65 72 29 29 29 0a 0a 28 64 65 66 t-order)))..(def
90f0: 69 6e 65 20 28 72 6d 74 3a 66 69 6e 64 2d 61 6e ine (rmt:find-an
9100: 64 2d 6d 61 72 6b 2d 69 6e 63 6f 6d 70 6c 65 74 d-mark-incomplet
9110: 65 20 72 75 6e 2d 69 64 20 6f 76 72 2d 64 65 61 e run-id ovr-dea
9120: 64 74 69 6d 65 29 0a 20 20 28 61 73 73 65 72 74 dtime). (assert
9130: 20 28 6e 75 6d 62 65 72 3f 20 72 75 6e 2d 69 64 (number? run-id
9140: 29 20 22 46 41 54 41 4c 3a 20 52 75 6e 20 69 64 ) "FATAL: Run id
9150: 20 72 65 71 75 69 72 65 64 2e 22 29 0a 20 20 3b required."). ;
9160: 3b 20 28 69 66 20 28 72 6d 74 3a 73 65 6e 64 2d ; (if (rmt:send-
9170: 72 65 63 65 69 76 65 20 27 68 61 76 65 2d 69 6e receive 'have-in
9180: 63 6f 6d 70 6c 65 74 65 73 3f 20 72 75 6e 2d 69 completes? run-i
9190: 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 6f d (list run-id o
91a0: 76 72 2d 64 65 61 64 74 69 6d 65 29 29 0a 20 20 vr-deadtime)).
91b0: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
91c0: 65 20 27 6d 61 72 6b 2d 69 6e 63 6f 6d 70 6c 65 e 'mark-incomple
91d0: 74 65 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 te run-id (list
91e0: 72 75 6e 2d 69 64 20 6f 76 72 2d 64 65 61 64 74 run-id ovr-deadt
91f0: 69 6d 65 29 29 29 20 3b 3b 20 29 0a 0a 28 64 65 ime))) ;; )..(de
9200: 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 6d 61 fine (rmt:get-ma
9210: 69 6e 2d 72 75 6e 2d 73 74 61 74 73 20 72 75 6e in-run-stats run
9220: 2d 69 64 29 0a 20 20 28 61 73 73 65 72 74 20 28 -id). (assert (
9230: 6e 75 6d 62 65 72 3f 20 72 75 6e 2d 69 64 29 20 number? run-id)
9240: 22 46 41 54 41 4c 3a 20 52 75 6e 20 69 64 20 72 "FATAL: Run id r
9250: 65 71 75 69 72 65 64 2e 22 29 0a 20 20 28 72 6d equired."). (rm
9260: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
9270: 67 65 74 2d 6d 61 69 6e 2d 72 75 6e 2d 73 74 61 get-main-run-sta
9280: 74 73 20 23 66 20 28 6c 69 73 74 20 72 75 6e 2d ts #f (list run-
9290: 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 id)))..(define (
92a0: 72 6d 74 3a 67 65 74 2d 76 61 72 20 76 61 72 6e rmt:get-var varn
92b0: 61 6d 65 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 ame). (rmt:send
92c0: 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 76 61 -receive 'get-va
92d0: 72 20 23 66 20 28 6c 69 73 74 20 76 61 72 6e 61 r #f (list varna
92e0: 6d 65 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 me)))..(define (
92f0: 72 6d 74 3a 64 65 6c 2d 76 61 72 20 76 61 72 6e rmt:del-var varn
9300: 61 6d 65 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 ame). (rmt:send
9310: 2d 72 65 63 65 69 76 65 20 27 64 65 6c 2d 76 61 -receive 'del-va
9320: 72 20 23 66 20 28 6c 69 73 74 20 76 61 72 6e 61 r #f (list varna
9330: 6d 65 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 me)))..(define (
9340: 72 6d 74 3a 73 65 74 2d 76 61 72 20 76 61 72 6e rmt:set-var varn
9350: 61 6d 65 20 76 61 6c 75 65 29 0a 20 20 28 72 6d ame value). (rm
9360: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
9370: 73 65 74 2d 76 61 72 20 23 66 20 28 6c 69 73 74 set-var #f (list
9380: 20 76 61 72 6e 61 6d 65 20 76 61 6c 75 65 29 29 varname value))
9390: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a )..(define (rmt:
93a0: 69 6e 63 2d 76 61 72 20 76 61 72 6e 61 6d 65 29 inc-var varname)
93b0: 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 . (rmt:send-rec
93c0: 65 69 76 65 20 27 69 6e 63 2d 76 61 72 20 23 66 eive 'inc-var #f
93d0: 20 28 6c 69 73 74 20 76 61 72 6e 61 6d 65 29 29 (list varname))
93e0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a )..(define (rmt:
93f0: 64 65 63 2d 76 61 72 20 76 61 72 6e 61 6d 65 29 dec-var varname)
9400: 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 . (rmt:send-rec
9410: 65 69 76 65 20 27 64 65 63 2d 76 61 72 20 23 66 eive 'dec-var #f
9420: 20 28 6c 69 73 74 20 76 61 72 6e 61 6d 65 29 29 (list varname))
9430: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a )..(define (rmt:
9440: 61 64 64 2d 76 61 72 20 76 61 72 6e 61 6d 65 20 add-var varname
9450: 76 61 6c 75 65 29 0a 20 20 28 72 6d 74 3a 73 65 value). (rmt:se
9460: 6e 64 2d 72 65 63 65 69 76 65 20 27 61 64 64 2d nd-receive 'add-
9470: 76 61 72 20 23 66 20 28 6c 69 73 74 20 76 61 72 var #f (list var
9480: 6e 61 6d 65 20 76 61 6c 75 65 29 29 29 0a 0a 3b name value)))..;
9490: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
94a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
94b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
94c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
94d0: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4d 20 55 20 4c =======.;; M U L
94e0: 20 54 20 49 20 52 20 55 20 4e 20 20 20 51 20 55 T I R U N Q U
94f0: 20 45 20 52 20 49 20 45 20 53 0a 3b 3b 3d 3d 3d E R I E S.;;===
9500: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9510: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9520: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9530: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9540: 3d 3d 3d 0a 0a 3b 3b 20 4e 65 65 64 20 74 6f 20 ===..;; Need to
9550: 6d 6f 76 65 20 74 68 69 73 20 74 6f 20 6d 75 6c move this to mul
9560: 74 69 2d 72 75 6e 20 73 65 63 74 69 6f 6e 20 61 ti-run section a
9570: 6e 64 20 6d 61 6b 65 20 61 73 73 6f 63 69 61 74 nd make associat
9580: 65 64 20 63 68 61 6e 67 65 73 0a 28 64 65 66 69 ed changes.(defi
9590: 6e 65 20 28 72 6d 74 3a 66 69 6e 64 2d 61 6e 64 ne (rmt:find-and
95a0: 2d 6d 61 72 6b 2d 69 6e 63 6f 6d 70 6c 65 74 65 -mark-incomplete
95b0: 2d 61 6c 6c 2d 72 75 6e 73 20 23 21 6b 65 79 20 -all-runs #!key
95c0: 28 6f 76 72 2d 64 65 61 64 74 69 6d 65 20 23 66 (ovr-deadtime #f
95d0: 29 29 0a 20 20 28 6c 65 74 20 28 28 72 75 6e 2d )). (let ((run-
95e0: 69 64 73 20 28 72 6d 74 3a 67 65 74 2d 61 6c 6c ids (rmt:get-all
95f0: 2d 72 75 6e 2d 69 64 73 29 29 29 0a 20 20 20 20 -run-ids))).
9600: 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 (for-each (lambd
9610: 61 20 28 72 75 6e 2d 69 64 29 0a 09 20 20 20 20 a (run-id)..
9620: 20 20 20 28 72 6d 74 3a 66 69 6e 64 2d 61 6e 64 (rmt:find-and
9630: 2d 6d 61 72 6b 2d 69 6e 63 6f 6d 70 6c 65 74 65 -mark-incomplete
9640: 20 72 75 6e 2d 69 64 20 6f 76 72 2d 64 65 61 64 run-id ovr-dead
9650: 74 69 6d 65 29 29 0a 09 20 20 20 20 20 72 75 6e time)).. run
9660: 2d 69 64 73 29 29 29 0a 0a 3b 3b 20 67 65 74 20 -ids)))..;; get
9670: 74 68 65 20 70 72 65 76 69 6f 75 73 20 72 65 63 the previous rec
9680: 6f 72 64 20 66 6f 72 20 77 68 65 6e 20 74 68 69 ord for when thi
9690: 73 20 74 65 73 74 20 77 61 73 20 72 75 6e 20 77 s test was run w
96a0: 68 65 72 65 20 61 6c 6c 20 6b 65 79 73 20 6d 61 here all keys ma
96b0: 74 63 68 20 62 75 74 20 72 75 6e 6e 61 6d 65 0a tch but runname.
96c0: 3b 3b 20 72 65 74 75 72 6e 73 20 23 66 20 69 66 ;; returns #f if
96d0: 20 6e 6f 20 73 75 63 68 20 74 65 73 74 20 66 6f no such test fo
96e0: 75 6e 64 2c 20 72 65 74 75 72 6e 73 20 61 20 73 und, returns a s
96f0: 69 6e 67 6c 65 20 74 65 73 74 20 72 65 63 6f 72 ingle test recor
9700: 64 20 69 66 20 66 6f 75 6e 64 0a 3b 3b 20 0a 3b d if found.;; .;
9710: 3b 20 52 75 6e 20 74 68 69 73 20 61 74 20 74 68 ; Run this at th
9720: 65 20 63 6c 69 65 6e 74 20 65 6e 64 20 73 69 6e e client end sin
9730: 63 65 20 77 65 20 68 61 76 65 20 74 6f 20 63 6f ce we have to co
9740: 6e 6e 65 63 74 20 74 6f 20 6d 75 6c 74 69 70 6c nnect to multipl
9750: 65 20 72 75 6e 2d 69 64 20 64 62 73 0a 3b 3b 0a e run-id dbs.;;.
9760: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 (define (rmt:get
9770: 2d 70 72 65 76 69 6f 75 73 2d 74 65 73 74 2d 72 -previous-test-r
9780: 75 6e 2d 72 65 63 6f 72 64 20 72 75 6e 2d 69 64 un-record run-id
9790: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item-
97a0: 70 61 74 68 29 0a 20 20 28 6c 65 74 2a 20 28 28 path). (let* ((
97b0: 6b 65 79 76 61 6c 73 20 28 72 6d 74 3a 67 65 74 keyvals (rmt:get
97c0: 2d 6b 65 79 2d 76 61 6c 2d 70 61 69 72 73 20 72 -key-val-pairs r
97d0: 75 6e 2d 69 64 29 29 0a 09 20 28 6b 65 79 73 20 un-id)).. (keys
97e0: 20 20 20 28 72 6d 74 3a 67 65 74 2d 6b 65 79 73 (rmt:get-keys
97f0: 29 29 0a 09 20 28 73 65 6c 73 74 72 20 20 28 73 )).. (selstr (s
9800: 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 tring-interspers
9810: 65 20 20 6b 65 79 73 20 22 2c 22 29 29 0a 09 20 e keys ","))..
9820: 28 71 72 79 73 74 72 20 20 28 73 74 72 69 6e 67 (qrystr (string
9830: 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 -intersperse (ma
9840: 70 20 28 6c 61 6d 62 64 61 20 28 78 29 28 63 6f p (lambda (x)(co
9850: 6e 63 20 78 20 22 3d 3f 22 29 29 20 6b 65 79 73 nc x "=?")) keys
9860: 29 20 22 20 41 4e 44 20 22 29 29 29 0a 20 20 20 ) " AND "))).
9870: 20 28 69 66 20 28 6e 6f 74 20 6b 65 79 76 61 6c (if (not keyval
9880: 73 29 0a 09 23 66 0a 09 28 6c 65 74 20 28 28 70 s)..#f..(let ((p
9890: 72 65 76 2d 72 75 6e 2d 69 64 73 20 28 72 6d 74 rev-run-ids (rmt
98a0: 3a 67 65 74 2d 70 72 65 76 2d 72 75 6e 2d 69 64 :get-prev-run-id
98b0: 73 20 72 75 6e 2d 69 64 29 29 29 0a 09 20 20 3b s run-id))).. ;
98c0: 3b 20 66 6f 72 20 65 61 63 68 20 72 75 6e 20 73 ; for each run s
98d0: 74 61 72 74 69 6e 67 20 77 69 74 68 20 74 68 65 tarting with the
98e0: 20 6d 6f 73 74 20 72 65 63 65 6e 74 20 6c 6f 6f most recent loo
98f0: 6b 20 74 6f 20 73 65 65 20 69 66 20 74 68 65 72 k to see if ther
9900: 65 20 69 73 20 61 20 6d 61 74 63 68 69 6e 67 20 e is a matching
9910: 74 65 73 74 0a 09 20 20 3b 3b 20 69 66 20 66 6f test.. ;; if fo
9920: 75 6e 64 20 74 68 65 6e 20 72 65 74 75 72 6e 20 und then return
9930: 74 68 61 74 20 6d 61 74 63 68 69 6e 67 20 74 65 that matching te
9940: 73 74 20 72 65 63 6f 72 64 0a 09 20 20 28 64 65 st record.. (de
9950: 62 75 67 3a 70 72 69 6e 74 20 34 20 2a 64 65 66 bug:print 4 *def
9960: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
9970: 73 65 6c 73 74 72 3a 20 22 20 73 65 6c 73 74 72 selstr: " selstr
9980: 20 22 2c 20 71 72 79 73 74 72 3a 20 22 20 71 72 ", qrystr: " qr
9990: 79 73 74 72 20 22 2c 20 6b 65 79 76 61 6c 73 3a ystr ", keyvals:
99a0: 20 22 20 6b 65 79 76 61 6c 73 20 22 2c 20 70 72 " keyvals ", pr
99b0: 65 76 69 6f 75 73 20 72 75 6e 20 69 64 73 20 66 evious run ids f
99c0: 6f 75 6e 64 3a 20 22 20 70 72 65 76 2d 72 75 6e ound: " prev-run
99d0: 2d 69 64 73 29 0a 09 20 20 28 69 66 20 28 6e 75 -ids).. (if (nu
99e0: 6c 6c 3f 20 70 72 65 76 2d 72 75 6e 2d 69 64 73 ll? prev-run-ids
99f0: 29 20 23 66 0a 09 20 20 20 20 20 20 28 6c 65 74 ) #f.. (let
9a00: 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 61 72 loop ((hed (car
9a10: 20 70 72 65 76 2d 72 75 6e 2d 69 64 73 29 29 0a prev-run-ids)).
9a20: 09 09 09 20 28 74 61 6c 20 28 63 64 72 20 70 72 ... (tal (cdr pr
9a30: 65 76 2d 72 75 6e 2d 69 64 73 29 29 29 0a 09 09 ev-run-ids)))...
9a40: 28 6c 65 74 20 28 28 72 65 73 75 6c 74 73 20 28 (let ((results (
9a50: 72 6d 74 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f rmt:get-tests-fo
9a60: 72 2d 72 75 6e 20 68 65 64 20 28 63 6f 6e 63 20 r-run hed (conc
9a70: 74 65 73 74 2d 6e 61 6d 65 20 22 2f 22 20 69 74 test-name "/" it
9a80: 65 6d 2d 70 61 74 68 29 20 27 28 29 20 27 28 29 em-path) '() '()
9a90: 20 3b 3b 20 72 75 6e 2d 69 64 20 74 65 73 74 70 ;; run-id testp
9aa0: 61 74 74 20 73 74 61 74 65 73 20 73 74 61 74 75 att states statu
9ab0: 73 65 73 0a 09 09 09 09 09 09 20 20 20 20 20 20 ses.......
9ac0: 23 66 20 23 66 20 23 66 20 20 20 20 20 20 20 20 #f #f #f
9ad0: 20 20 20 20 20 20 20 3b 3b 20 6f 66 66 73 65 74 ;; offset
9ae0: 20 6c 69 6d 69 74 20 6e 6f 74 2d 69 6e 20 68 69 limit not-in hi
9af0: 64 65 2f 6e 6f 74 2d 68 69 64 65 0a 09 09 09 09 de/not-hide.....
9b00: 09 09 20 20 20 20 20 20 23 66 20 23 66 20 23 66 .. #f #f #f
9b10: 20 23 66 20 27 6e 6f 72 6d 61 6c 29 29 29 20 3b #f 'normal))) ;
9b20: 3b 20 73 6f 72 74 2d 62 79 20 73 6f 72 74 2d 6f ; sort-by sort-o
9b30: 72 64 65 72 20 71 72 79 76 61 6c 73 20 6c 61 73 rder qryvals las
9b40: 74 2d 75 70 64 61 74 65 20 6d 6f 64 65 0a 09 09 t-update mode...
9b50: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 (debug:print 4
9b60: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
9b70: 72 74 2a 20 22 47 6f 74 20 74 65 73 74 73 20 66 rt* "Got tests f
9b80: 6f 72 20 72 75 6e 2d 69 64 20 22 20 72 75 6e 2d or run-id " run-
9b90: 69 64 20 22 2c 20 74 65 73 74 2d 6e 61 6d 65 20 id ", test-name
9ba0: 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 2c 20 69 " test-name ", i
9bb0: 74 65 6d 2d 70 61 74 68 20 22 20 69 74 65 6d 2d tem-path " item-
9bc0: 70 61 74 68 20 22 3a 20 22 20 72 65 73 75 6c 74 path ": " result
9bd0: 73 29 0a 09 09 20 20 28 69 66 20 28 61 6e 64 20 s)... (if (and
9be0: 28 6e 75 6c 6c 3f 20 72 65 73 75 6c 74 73 29 0a (null? results).
9bf0: 09 09 09 20 20 20 28 6e 6f 74 20 28 6e 75 6c 6c ... (not (null
9c00: 3f 20 74 61 6c 29 29 29 0a 09 09 20 20 20 20 20 ? tal)))...
9c10: 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 (loop (car tal)
9c20: 28 63 64 72 20 74 61 6c 29 29 0a 09 09 20 20 20 (cdr tal))...
9c30: 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 72 65 (if (null? re
9c40: 73 75 6c 74 73 29 20 23 66 0a 09 09 09 20 20 28 sults) #f.... (
9c50: 63 61 72 20 72 65 73 75 6c 74 73 29 29 29 29 29 car results)))))
9c60: 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 )))))..(define (
9c70: 72 6d 74 3a 67 65 74 2d 72 75 6e 2d 73 74 61 74 rmt:get-run-stat
9c80: 73 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 s). (rmt:send-r
9c90: 65 63 65 69 76 65 20 27 67 65 74 2d 72 75 6e 2d eceive 'get-run-
9ca0: 73 74 61 74 73 20 23 66 20 27 28 29 29 29 0a 0a stats #f '()))..
9cb0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
9cc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9cd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9ce0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9cf0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 53 20 54 ========.;; S T
9d00: 20 45 20 50 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d E P S.;;=======
9d10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9d20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9d30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9d40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
9d50: 0a 3b 3b 20 47 65 74 74 69 6e 67 20 73 74 65 70 .;; Getting step
9d60: 73 20 69 73 20 6d 6f 72 65 20 63 6f 6d 70 6c 69 s is more compli
9d70: 63 61 74 65 64 2e 0a 3b 3b 0a 3b 3b 20 49 66 20 cated..;;.;; If
9d80: 67 69 76 65 6e 20 77 6f 72 6b 20 61 72 65 61 20 given work area
9d90: 0a 3b 3b 20 20 31 2e 20 46 69 6e 64 20 74 68 65 .;; 1. Find the
9da0: 20 74 65 73 74 64 61 74 2e 64 62 20 66 69 6c 65 testdat.db file
9db0: 0a 3b 3b 20 20 32 2e 20 4f 70 65 6e 20 74 68 65 .;; 2. Open the
9dc0: 20 74 65 73 74 64 61 74 2e 64 62 20 66 69 6c 65 testdat.db file
9dd0: 20 61 6e 64 20 64 6f 20 74 68 65 20 71 75 65 72 and do the quer
9de0: 79 0a 3b 3b 20 49 66 20 6e 6f 74 20 67 69 76 65 y.;; If not give
9df0: 6e 20 74 68 65 20 77 6f 72 6b 20 61 72 65 61 0a n the work area.
9e00: 3b 3b 20 20 31 2e 20 44 6f 20 61 20 72 65 6d 6f ;; 1. Do a remo
9e10: 74 65 20 63 61 6c 6c 20 74 6f 20 67 65 74 20 74 te call to get t
9e20: 68 65 20 74 65 73 74 20 70 61 74 68 0a 3b 3b 20 he test path.;;
9e30: 20 32 2e 20 43 6f 6e 74 69 6e 75 65 20 61 73 20 2. Continue as
9e40: 61 62 6f 76 65 0a 3b 3b 20 0a 3b 3b 28 64 65 66 above.;; .;;(def
9e50: 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 73 74 65 ine (rmt:get-ste
9e60: 70 73 2d 66 6f 72 2d 74 65 73 74 20 72 75 6e 2d ps-for-test run-
9e70: 69 64 20 74 65 73 74 2d 69 64 29 0a 3b 3b 20 20 id test-id).;;
9e80: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
9e90: 65 20 27 67 65 74 2d 73 74 65 70 73 2d 64 61 74 e 'get-steps-dat
9ea0: 61 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 74 a run-id (list t
9eb0: 65 73 74 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 est-id)))..(defi
9ec0: 6e 65 20 28 72 6d 74 3a 74 65 73 74 73 74 65 70 ne (rmt:teststep
9ed0: 2d 73 65 74 2d 73 74 61 74 75 73 21 20 72 75 6e -set-status! run
9ee0: 2d 69 64 20 74 65 73 74 2d 69 64 20 74 65 73 74 -id test-id test
9ef0: 73 74 65 70 2d 6e 61 6d 65 20 73 74 61 74 65 2d step-name state-
9f00: 69 6e 20 73 74 61 74 75 73 2d 69 6e 20 63 6f 6d in status-in com
9f10: 6d 65 6e 74 20 6c 6f 67 66 69 6c 65 29 0a 20 20 ment logfile).
9f20: 28 61 73 73 65 72 74 20 28 6e 75 6d 62 65 72 3f (assert (number?
9f30: 20 72 75 6e 2d 69 64 29 20 22 46 41 54 41 4c 3a run-id) "FATAL:
9f40: 20 52 75 6e 20 69 64 20 72 65 71 75 69 72 65 64 Run id required
9f50: 2e 22 29 0a 20 20 28 6c 65 74 2a 20 28 28 73 74 ."). (let* ((st
9f60: 61 74 65 20 20 20 20 20 28 69 74 65 6d 73 3a 63 ate (items:c
9f70: 68 65 63 6b 2d 76 61 6c 69 64 2d 69 74 65 6d 73 heck-valid-items
9f80: 20 22 73 74 61 74 65 22 20 73 74 61 74 65 2d 69 "state" state-i
9f90: 6e 29 29 0a 09 20 28 73 74 61 74 75 73 20 20 20 n)).. (status
9fa0: 20 28 69 74 65 6d 73 3a 63 68 65 63 6b 2d 76 61 (items:check-va
9fb0: 6c 69 64 2d 69 74 65 6d 73 20 22 73 74 61 74 75 lid-items "statu
9fc0: 73 22 20 73 74 61 74 75 73 2d 69 6e 29 29 29 0a s" status-in))).
9fd0: 20 20 20 20 28 69 66 20 28 6f 72 20 28 6e 6f 74 (if (or (not
9fe0: 20 73 74 61 74 65 29 28 6e 6f 74 20 73 74 61 74 state)(not stat
9ff0: 75 73 29 29 0a 09 28 64 65 62 75 67 3a 70 72 69 us))..(debug:pri
a000: 6e 74 20 33 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 3 *default-lo
a010: 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 g-port* "WARNING
a020: 3a 20 49 6e 76 61 6c 69 64 20 22 20 28 69 66 20 : Invalid " (if
a030: 73 74 61 74 75 73 20 22 73 74 61 74 75 73 22 20 status "status"
a040: 22 73 74 61 74 65 22 29 0a 09 09 20 20 20 20 20 "state")...
a050: 22 20 76 61 6c 75 65 20 5c 22 22 20 28 69 66 20 " value \"" (if
a060: 73 74 61 74 75 73 20 73 74 61 74 65 2d 69 6e 20 status state-in
a070: 73 74 61 74 75 73 2d 69 6e 29 20 22 5c 22 2c 20 status-in) "\",
a080: 75 70 64 61 74 65 20 79 6f 75 72 20 76 61 6c 69 update your vali
a090: 64 76 61 6c 75 65 73 20 73 65 63 74 69 6f 6e 20 dvalues section
a0a0: 69 6e 20 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 in megatest.conf
a0b0: 69 67 22 29 29 0a 20 20 20 20 28 72 6d 74 3a 73 ig")). (rmt:s
a0c0: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 74 65 73 end-receive 'tes
a0d0: 74 73 74 65 70 2d 73 65 74 2d 73 74 61 74 75 73 tstep-set-status
a0e0: 21 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 ! run-id (list r
a0f0: 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 74 65 un-id test-id te
a100: 73 74 73 74 65 70 2d 6e 61 6d 65 20 73 74 61 74 ststep-name stat
a110: 65 2d 69 6e 20 73 74 61 74 75 73 2d 69 6e 20 63 e-in status-in c
a120: 6f 6d 6d 65 6e 74 20 6c 6f 67 66 69 6c 65 29 29 omment logfile))
a130: 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d ))...(define (rm
a140: 74 3a 64 65 6c 65 74 65 2d 73 74 65 70 73 2d 66 t:delete-steps-f
a150: 6f 72 2d 74 65 73 74 21 20 72 75 6e 2d 69 64 20 or-test! run-id
a160: 74 65 73 74 2d 69 64 29 0a 20 20 28 61 73 73 65 test-id). (asse
a170: 72 74 20 28 6e 75 6d 62 65 72 3f 20 72 75 6e 2d rt (number? run-
a180: 69 64 29 20 22 46 41 54 41 4c 3a 20 52 75 6e 20 id) "FATAL: Run
a190: 69 64 20 72 65 71 75 69 72 65 64 2e 22 29 0a 20 id required.").
a1a0: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
a1b0: 76 65 20 27 64 65 6c 65 74 65 2d 73 74 65 70 73 ve 'delete-steps
a1c0: 2d 66 6f 72 2d 74 65 73 74 21 20 72 75 6e 2d 69 -for-test! run-i
a1d0: 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 d (list run-id t
a1e0: 65 73 74 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 est-id)))..(defi
a1f0: 6e 65 20 28 72 6d 74 3a 67 65 74 2d 73 74 65 70 ne (rmt:get-step
a200: 73 2d 66 6f 72 2d 74 65 73 74 20 72 75 6e 2d 69 s-for-test run-i
a210: 64 20 74 65 73 74 2d 69 64 29 0a 20 20 28 61 73 d test-id). (as
a220: 73 65 72 74 20 28 6e 75 6d 62 65 72 3f 20 72 75 sert (number? ru
a230: 6e 2d 69 64 29 20 22 46 41 54 41 4c 3a 20 52 75 n-id) "FATAL: Ru
a240: 6e 20 69 64 20 72 65 71 75 69 72 65 64 2e 22 29 n id required.")
a250: 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 . (rmt:send-rec
a260: 65 69 76 65 20 27 67 65 74 2d 73 74 65 70 73 2d eive 'get-steps-
a270: 66 6f 72 2d 74 65 73 74 20 72 75 6e 2d 69 64 20 for-test run-id
a280: 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 (list run-id tes
a290: 74 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 t-id)))..(define
a2a0: 20 28 72 6d 74 3a 67 65 74 2d 73 74 65 70 73 2d (rmt:get-steps-
a2b0: 69 6e 66 6f 2d 62 79 2d 69 64 20 72 75 6e 2d 69 info-by-id run-i
a2c0: 64 20 74 65 73 74 2d 73 74 65 70 2d 69 64 29 0a d test-step-id).
a2d0: 20 20 28 61 73 73 65 72 74 20 28 6e 75 6d 62 65 (assert (numbe
a2e0: 72 3f 20 72 75 6e 2d 69 64 29 20 22 46 41 54 41 r? run-id) "FATA
a2f0: 4c 3a 20 52 75 6e 20 69 64 20 72 65 71 75 69 72 L: Run id requir
a300: 65 64 2e 22 29 0a 20 20 28 72 6d 74 3a 73 65 6e ed."). (rmt:sen
a310: 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 73 d-receive 'get-s
a320: 74 65 70 73 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 teps-info-by-id
a330: 23 66 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 #f (list run-id
a340: 74 65 73 74 2d 73 74 65 70 2d 69 64 29 29 29 0a test-step-id))).
a350: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
a360: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a370: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a380: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a390: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 54 20 =========.;; T
a3a0: 45 20 53 20 54 20 20 20 44 20 41 20 54 20 41 20 E S T D A T A
a3b0: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
a3c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a3d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a3e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a3f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 =========..(defi
a400: 6e 65 20 28 72 6d 74 3a 72 65 61 64 2d 74 65 73 ne (rmt:read-tes
a410: 74 2d 64 61 74 61 20 72 75 6e 2d 69 64 20 74 65 t-data run-id te
a420: 73 74 2d 69 64 20 63 61 74 65 67 6f 72 79 70 61 st-id categorypa
a430: 74 74 20 23 21 6b 65 79 20 28 77 6f 72 6b 2d 61 tt #!key (work-a
a440: 72 65 61 20 23 66 29 29 20 0a 20 20 28 61 73 73 rea #f)) . (ass
a450: 65 72 74 20 28 6e 75 6d 62 65 72 3f 20 72 75 6e ert (number? run
a460: 2d 69 64 29 20 22 46 41 54 41 4c 3a 20 52 75 6e -id) "FATAL: Run
a470: 20 69 64 20 72 65 71 75 69 72 65 64 2e 22 29 0a id required.").
a480: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
a490: 69 76 65 20 27 72 65 61 64 2d 74 65 73 74 2d 64 ive 'read-test-d
a4a0: 61 74 61 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 ata run-id (list
a4b0: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 run-id test-id
a4c0: 63 61 74 65 67 6f 72 79 70 61 74 74 29 29 29 0a categorypatt))).
a4d0: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 72 65 .(define (rmt:re
a4e0: 61 64 2d 74 65 73 74 2d 64 61 74 61 2d 76 61 72 ad-test-data-var
a4f0: 70 61 74 74 20 72 75 6e 2d 69 64 20 74 65 73 74 patt run-id test
a500: 2d 69 64 20 63 61 74 65 67 6f 72 79 70 61 74 74 -id categorypatt
a510: 20 76 61 72 70 61 74 74 20 23 21 6b 65 79 20 28 varpatt #!key (
a520: 77 6f 72 6b 2d 61 72 65 61 20 23 66 29 29 20 0a work-area #f)) .
a530: 20 20 28 61 73 73 65 72 74 20 28 6e 75 6d 62 65 (assert (numbe
a540: 72 3f 20 72 75 6e 2d 69 64 29 20 22 46 41 54 41 r? run-id) "FATA
a550: 4c 3a 20 52 75 6e 20 69 64 20 72 65 71 75 69 72 L: Run id requir
a560: 65 64 2e 22 29 0a 20 20 28 72 6d 74 3a 73 65 6e ed."). (rmt:sen
a570: 64 2d 72 65 63 65 69 76 65 20 27 72 65 61 64 2d d-receive 'read-
a580: 74 65 73 74 2d 64 61 74 61 2d 76 61 72 70 61 74 test-data-varpat
a590: 74 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 t run-id (list r
a5a0: 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 63 61 un-id test-id ca
a5b0: 74 65 67 6f 72 79 70 61 74 74 20 76 61 72 70 61 tegorypatt varpa
a5c0: 74 74 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 tt)))..(define (
a5d0: 72 6d 74 3a 67 65 74 2d 64 61 74 61 2d 69 6e 66 rmt:get-data-inf
a5e0: 6f 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 74 o-by-id run-id t
a5f0: 65 73 74 2d 64 61 74 61 2d 69 64 29 0a 20 20 28 est-data-id). (
a600: 61 73 73 65 72 74 20 28 6e 75 6d 62 65 72 3f 20 assert (number?
a610: 72 75 6e 2d 69 64 29 20 22 46 41 54 41 4c 3a 20 run-id) "FATAL:
a620: 52 75 6e 20 69 64 20 72 65 71 75 69 72 65 64 2e Run id required.
a630: 22 29 0a 20 20 20 28 72 6d 74 3a 73 65 6e 64 2d "). (rmt:send-
a640: 72 65 63 65 69 76 65 20 27 67 65 74 2d 64 61 74 receive 'get-dat
a650: 61 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 23 66 20 a-info-by-id #f
a660: 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 (list run-id tes
a670: 74 2d 64 61 74 61 2d 69 64 29 29 29 0a 0a 28 64 t-data-id)))..(d
a680: 65 66 69 6e 65 20 28 72 6d 74 3a 74 65 73 74 6d efine (rmt:testm
a690: 65 74 61 2d 61 64 64 2d 72 65 63 6f 72 64 20 74 eta-add-record t
a6a0: 65 73 74 6e 61 6d 65 29 0a 20 20 28 72 6d 74 3a estname). (rmt:
a6b0: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 74 65 send-receive 'te
a6c0: 73 74 6d 65 74 61 2d 61 64 64 2d 72 65 63 6f 72 stmeta-add-recor
a6d0: 64 20 23 66 20 28 6c 69 73 74 20 74 65 73 74 6e d #f (list testn
a6e0: 61 6d 65 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ame)))..(define
a6f0: 28 72 6d 74 3a 74 65 73 74 6d 65 74 61 2d 67 65 (rmt:testmeta-ge
a700: 74 2d 72 65 63 6f 72 64 20 74 65 73 74 6e 61 6d t-record testnam
a710: 65 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 e). (rmt:send-r
a720: 65 63 65 69 76 65 20 27 74 65 73 74 6d 65 74 61 eceive 'testmeta
a730: 2d 67 65 74 2d 72 65 63 6f 72 64 20 23 66 20 28 -get-record #f (
a740: 6c 69 73 74 20 74 65 73 74 6e 61 6d 65 29 29 29 list testname)))
a750: 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 ..(define (rmt:t
a760: 65 73 74 6d 65 74 61 2d 75 70 64 61 74 65 2d 66 estmeta-update-f
a770: 69 65 6c 64 20 74 65 73 74 2d 6e 61 6d 65 20 66 ield test-name f
a780: 6c 64 20 76 61 6c 29 0a 20 20 28 72 6d 74 3a 73 ld val). (rmt:s
a790: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 74 65 73 end-receive 'tes
a7a0: 74 6d 65 74 61 2d 75 70 64 61 74 65 2d 66 69 65 tmeta-update-fie
a7b0: 6c 64 20 23 66 20 28 6c 69 73 74 20 74 65 73 74 ld #f (list test
a7c0: 2d 6e 61 6d 65 20 66 6c 64 20 76 61 6c 29 29 29 -name fld val)))
a7d0: 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 ..(define (rmt:t
a7e0: 65 73 74 2d 64 61 74 61 2d 72 6f 6c 6c 75 70 20 est-data-rollup
a7f0: 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 73 run-id test-id s
a800: 74 61 74 75 73 29 0a 20 20 28 61 73 73 65 72 74 tatus). (assert
a810: 20 28 6e 75 6d 62 65 72 3f 20 72 75 6e 2d 69 64 (number? run-id
a820: 29 20 22 46 41 54 41 4c 3a 20 52 75 6e 20 69 64 ) "FATAL: Run id
a830: 20 72 65 71 75 69 72 65 64 2e 22 29 0a 20 20 28 required."). (
a840: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
a850: 20 27 74 65 73 74 2d 64 61 74 61 2d 72 6f 6c 6c 'test-data-roll
a860: 75 70 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 up run-id (list
a870: 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 73 run-id test-id s
a880: 74 61 74 75 73 29 29 29 0a 0a 28 64 65 66 69 6e tatus)))..(defin
a890: 65 20 28 72 6d 74 3a 63 73 76 2d 3e 74 65 73 74 e (rmt:csv->test
a8a0: 2d 64 61 74 61 20 72 75 6e 2d 69 64 20 74 65 73 -data run-id tes
a8b0: 74 2d 69 64 20 63 73 76 64 61 74 61 29 0a 20 20 t-id csvdata).
a8c0: 28 61 73 73 65 72 74 20 28 6e 75 6d 62 65 72 3f (assert (number?
a8d0: 20 72 75 6e 2d 69 64 29 20 22 46 41 54 41 4c 3a run-id) "FATAL:
a8e0: 20 52 75 6e 20 69 64 20 72 65 71 75 69 72 65 64 Run id required
a8f0: 2e 22 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d ."). (rmt:send-
a900: 72 65 63 65 69 76 65 20 27 63 73 76 2d 3e 74 65 receive 'csv->te
a910: 73 74 2d 64 61 74 61 20 72 75 6e 2d 69 64 20 28 st-data run-id (
a920: 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 list run-id test
a930: 2d 69 64 20 63 73 76 64 61 74 61 29 29 29 0a 0a -id csvdata)))..
a940: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
a950: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a960: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a970: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a980: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 54 20 41 ========.;; T A
a990: 20 53 20 4b 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d S K S.;;=======
a9a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a9b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a9c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a9d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
a9e0: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 61 .(define (rmt:ta
a9f0: 73 6b 73 2d 66 69 6e 64 2d 74 61 73 6b 2d 71 75 sks-find-task-qu
aa00: 65 75 65 2d 72 65 63 6f 72 64 73 20 74 61 72 67 eue-records targ
aa10: 65 74 20 72 75 6e 2d 6e 61 6d 65 20 74 65 73 74 et run-name test
aa20: 2d 70 61 74 74 20 73 74 61 74 65 2d 70 61 74 74 -patt state-patt
aa30: 20 61 63 74 69 6f 6e 2d 70 61 74 74 29 0a 20 20 action-patt).
aa40: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
aa50: 65 20 27 66 69 6e 64 2d 74 61 73 6b 2d 71 75 65 e 'find-task-que
aa60: 75 65 2d 72 65 63 6f 72 64 73 20 23 66 20 28 6c ue-records #f (l
aa70: 69 73 74 20 74 61 72 67 65 74 20 72 75 6e 2d 6e ist target run-n
aa80: 61 6d 65 20 74 65 73 74 2d 70 61 74 74 20 73 74 ame test-patt st
aa90: 61 74 65 2d 70 61 74 74 20 61 63 74 69 6f 6e 2d ate-patt action-
aaa0: 70 61 74 74 29 29 29 0a 0a 28 64 65 66 69 6e 65 patt)))..(define
aab0: 20 28 72 6d 74 3a 74 61 73 6b 73 2d 61 64 64 20 (rmt:tasks-add
aac0: 61 63 74 69 6f 6e 20 6f 77 6e 65 72 20 74 61 72 action owner tar
aad0: 67 65 74 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 get runname test
aae0: 70 61 74 74 20 70 61 72 61 6d 73 29 0a 20 20 28 patt params). (
aaf0: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
ab00: 20 27 74 61 73 6b 73 2d 61 64 64 20 23 66 20 28 'tasks-add #f (
ab10: 6c 69 73 74 20 61 63 74 69 6f 6e 20 6f 77 6e 65 list action owne
ab20: 72 20 74 61 72 67 65 74 20 72 75 6e 6e 61 6d 65 r target runname
ab30: 20 74 65 73 74 70 61 74 74 20 70 61 72 61 6d 73 testpatt params
ab40: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d )))..(define (rm
ab50: 74 3a 74 61 73 6b 73 2d 73 65 74 2d 73 74 61 74 t:tasks-set-stat
ab60: 65 2d 67 69 76 65 6e 2d 70 61 72 61 6d 2d 6b 65 e-given-param-ke
ab70: 79 20 70 61 72 61 6d 2d 6b 65 79 20 6e 65 77 2d y param-key new-
ab80: 73 74 61 74 65 29 0a 20 20 28 72 6d 74 3a 73 65 state). (rmt:se
ab90: 6e 64 2d 72 65 63 65 69 76 65 20 27 74 61 73 6b nd-receive 'task
aba0: 73 2d 73 65 74 2d 73 74 61 74 65 2d 67 69 76 65 s-set-state-give
abb0: 6e 2d 70 61 72 61 6d 2d 6b 65 79 20 23 66 20 28 n-param-key #f (
abc0: 6c 69 73 74 20 20 70 61 72 61 6d 2d 6b 65 79 20 list param-key
abd0: 6e 65 77 2d 73 74 61 74 65 29 29 29 0a 0a 28 64 new-state)))..(d
abe0: 65 66 69 6e 65 20 28 72 6d 74 3a 74 61 73 6b 73 efine (rmt:tasks
abf0: 2d 67 65 74 2d 6c 61 73 74 20 74 61 72 67 65 74 -get-last target
ac00: 20 72 75 6e 6e 61 6d 65 29 0a 20 20 28 72 6d 74 runname). (rmt
ac10: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 74 :send-receive 't
ac20: 61 73 6b 73 2d 67 65 74 2d 6c 61 73 74 20 23 66 asks-get-last #f
ac30: 20 28 6c 69 73 74 20 74 61 72 67 65 74 20 72 75 (list target ru
ac40: 6e 6e 61 6d 65 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d nname)))..;;====
ac50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ac60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ac70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ac80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ac90: 3d 3d 0a 3b 3b 20 4e 20 4f 20 20 20 53 20 59 20 ==.;; N O S Y
aca0: 4e 20 43 20 20 20 44 20 42 20 0a 3b 3b 3d 3d 3d N C D B .;;===
acb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
acc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
acd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ace0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
acf0: 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d ===..(define (rm
ad00: 74 3a 6e 6f 2d 73 79 6e 63 2d 73 65 74 20 76 61 t:no-sync-set va
ad10: 72 20 76 61 6c 29 0a 20 20 28 72 6d 74 3a 73 65 r val). (rmt:se
ad20: 6e 64 2d 72 65 63 65 69 76 65 20 27 6e 6f 2d 73 nd-receive 'no-s
ad30: 79 6e 63 2d 73 65 74 20 23 66 20 60 28 2c 76 61 ync-set #f `(,va
ad40: 72 20 2c 76 61 6c 29 29 29 0a 0a 28 64 65 66 69 r ,val)))..(defi
ad50: 6e 65 20 28 72 6d 74 3a 6e 6f 2d 73 79 6e 63 2d ne (rmt:no-sync-
ad60: 67 65 74 2f 64 65 66 61 75 6c 74 20 76 61 72 20 get/default var
ad70: 64 65 66 61 75 6c 74 29 0a 20 20 28 72 6d 74 3a default). (rmt:
ad80: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 6e 6f send-receive 'no
ad90: 2d 73 79 6e 63 2d 67 65 74 2f 64 65 66 61 75 6c -sync-get/defaul
ada0: 74 20 23 66 20 60 28 2c 76 61 72 20 2c 64 65 66 t #f `(,var ,def
adb0: 61 75 6c 74 29 29 29 0a 0a 28 64 65 66 69 6e 65 ault)))..(define
adc0: 20 28 72 6d 74 3a 6e 6f 2d 73 79 6e 63 2d 64 65 (rmt:no-sync-de
add0: 6c 21 20 76 61 72 29 0a 20 20 28 72 6d 74 3a 73 l! var). (rmt:s
ade0: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 6e 6f 2d end-receive 'no-
adf0: 73 79 6e 63 2d 64 65 6c 21 20 23 66 20 60 28 2c sync-del! #f `(,
ae00: 76 61 72 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 var)))..(define
ae10: 28 72 6d 74 3a 6e 6f 2d 73 79 6e 63 2d 67 65 74 (rmt:no-sync-get
ae20: 2d 6c 6f 63 6b 20 6b 65 79 6e 61 6d 65 29 0a 20 -lock keyname).
ae30: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
ae40: 76 65 20 27 6e 6f 2d 73 79 6e 63 2d 67 65 74 2d ve 'no-sync-get-
ae50: 6c 6f 63 6b 20 23 66 20 60 28 2c 6b 65 79 6e 61 lock #f `(,keyna
ae60: 6d 65 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d me)))..;;=======
ae70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ae80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ae90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aea0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
aeb0: 3b 3b 20 41 20 52 20 43 20 48 20 49 20 56 20 45 ;; A R C H I V E
aec0: 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d S.;;===========
aed0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aee0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aef0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
af00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 ===========..(de
af10: 66 69 6e 65 20 28 72 6d 74 3a 61 72 63 68 69 76 fine (rmt:archiv
af20: 65 2d 67 65 74 2d 61 6c 6c 6f 63 61 74 69 6f 6e e-get-allocation
af30: 73 20 20 74 65 73 74 6e 61 6d 65 20 69 74 65 6d s testname item
af40: 70 61 74 68 20 64 6e 65 65 64 65 64 29 0a 20 20 path dneeded).
af50: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
af60: 65 20 27 61 72 63 68 69 76 65 2d 67 65 74 2d 61 e 'archive-get-a
af70: 6c 6c 6f 63 61 74 69 6f 6e 73 20 23 66 20 28 6c llocations #f (l
af80: 69 73 74 20 74 65 73 74 6e 61 6d 65 20 69 74 65 ist testname ite
af90: 6d 70 61 74 68 20 64 6e 65 65 64 65 64 29 29 29 mpath dneeded)))
afa0: 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 61 ..(define (rmt:a
afb0: 72 63 68 69 76 65 2d 72 65 67 69 73 74 65 72 2d rchive-register-
afc0: 62 6c 6f 63 6b 2d 6e 61 6d 65 20 62 64 69 73 6b block-name bdisk
afd0: 2d 69 64 20 61 72 63 68 69 76 65 2d 70 61 74 68 -id archive-path
afe0: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
aff0: 63 65 69 76 65 20 27 61 72 63 68 69 76 65 2d 72 ceive 'archive-r
b000: 65 67 69 73 74 65 72 2d 62 6c 6f 63 6b 2d 6e 61 egister-block-na
b010: 6d 65 20 23 66 20 28 6c 69 73 74 20 62 64 69 73 me #f (list bdis
b020: 6b 2d 69 64 20 61 72 63 68 69 76 65 2d 70 61 74 k-id archive-pat
b030: 68 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 h)))..(define (r
b040: 6d 74 3a 61 72 63 68 69 76 65 2d 61 6c 6c 6f 63 mt:archive-alloc
b050: 61 74 65 2d 74 65 73 74 73 75 69 74 65 2f 61 72 ate-testsuite/ar
b060: 65 61 2d 74 6f 2d 62 6c 6f 63 6b 20 62 6c 6f 63 ea-to-block bloc
b070: 6b 2d 69 64 20 74 65 73 74 73 75 69 74 65 2d 6e k-id testsuite-n
b080: 61 6d 65 20 61 72 65 61 6b 65 79 29 0a 20 20 28 ame areakey). (
b090: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
b0a0: 20 27 61 72 63 68 69 76 65 2d 61 6c 6c 6f 63 61 'archive-alloca
b0b0: 74 65 2d 74 65 73 74 2d 74 6f 2d 62 6c 6f 63 6b te-test-to-block
b0c0: 20 23 66 20 28 6c 69 73 74 20 20 62 6c 6f 63 6b #f (list block
b0d0: 2d 69 64 20 74 65 73 74 73 75 69 74 65 2d 6e 61 -id testsuite-na
b0e0: 6d 65 20 61 72 65 61 6b 65 79 29 29 29 0a 0a 28 me areakey)))..(
b0f0: 64 65 66 69 6e 65 20 28 72 6d 74 3a 61 72 63 68 define (rmt:arch
b100: 69 76 65 2d 72 65 67 69 73 74 65 72 2d 64 69 73 ive-register-dis
b110: 6b 20 62 64 69 73 6b 2d 6e 61 6d 65 20 62 64 69 k bdisk-name bdi
b120: 73 6b 2d 70 61 74 68 20 64 66 29 0a 20 20 28 72 sk-path df). (r
b130: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
b140: 27 61 72 63 68 69 76 65 2d 72 65 67 69 73 74 65 'archive-registe
b150: 72 2d 64 69 73 6b 20 23 66 20 28 6c 69 73 74 20 r-disk #f (list
b160: 62 64 69 73 6b 2d 6e 61 6d 65 20 62 64 69 73 6b bdisk-name bdisk
b170: 2d 70 61 74 68 20 64 66 29 29 29 0a 0a 28 64 65 -path df)))..(de
b180: 66 69 6e 65 20 28 72 6d 74 3a 74 65 73 74 2d 73 fine (rmt:test-s
b190: 65 74 2d 61 72 63 68 69 76 65 2d 62 6c 6f 63 6b et-archive-block
b1a0: 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d -id run-id test-
b1b0: 69 64 20 61 72 63 68 69 76 65 2d 62 6c 6f 63 6b id archive-block
b1c0: 2d 69 64 29 0a 20 20 28 61 73 73 65 72 74 20 28 -id). (assert (
b1d0: 6e 75 6d 62 65 72 3f 20 72 75 6e 2d 69 64 29 20 number? run-id)
b1e0: 22 46 41 54 41 4c 3a 20 52 75 6e 20 69 64 20 72 "FATAL: Run id r
b1f0: 65 71 75 69 72 65 64 2e 22 29 0a 20 20 28 72 6d equired."). (rm
b200: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
b210: 74 65 73 74 2d 73 65 74 2d 61 72 63 68 69 76 65 test-set-archive
b220: 2d 62 6c 6f 63 6b 2d 69 64 20 72 75 6e 2d 69 64 -block-id run-id
b230: 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 (list run-id te
b240: 73 74 2d 69 64 20 61 72 63 68 69 76 65 2d 62 6c st-id archive-bl
b250: 6f 63 6b 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 ock-id)))..(defi
b260: 6e 65 20 28 72 6d 74 3a 74 65 73 74 2d 67 65 74 ne (rmt:test-get
b270: 2d 61 72 63 68 69 76 65 2d 62 6c 6f 63 6b 2d 69 -archive-block-i
b280: 6e 66 6f 20 61 72 63 68 69 76 65 2d 62 6c 6f 63 nfo archive-bloc
b290: 6b 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e k-id). (rmt:sen
b2a0: 64 2d 72 65 63 65 69 76 65 20 27 74 65 73 74 2d d-receive 'test-
b2b0: 67 65 74 2d 61 72 63 68 69 76 65 2d 62 6c 6f 63 get-archive-bloc
b2c0: 6b 2d 69 6e 66 6f 20 23 66 20 28 6c 69 73 74 20 k-info #f (list
b2d0: 61 72 63 68 69 76 65 2d 62 6c 6f 63 6b 2d 69 64 archive-block-id
b2e0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d )))..(define (rm
b2f0: 74 6d 6f 64 3a 63 61 6c 63 2d 72 6f 2d 6d 6f 64 tmod:calc-ro-mod
b300: 65 20 72 75 6e 72 65 6d 6f 74 65 20 2a 74 6f 70 e runremote *top
b310: 70 61 74 68 2a 29 0a 20 20 28 63 61 73 65 20 28 path*). (case (
b320: 72 6d 74 3a 74 72 61 6e 73 70 6f 72 74 2d 6d 6f rmt:transport-mo
b330: 64 65 29 0a 20 20 20 20 28 28 68 74 74 70 29 0a de). ((http).
b340: 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 72 75 (if (and ru
b350: 6e 72 65 6d 6f 74 65 0a 09 20 20 20 20 20 20 28 nremote.. (
b360: 72 65 6d 6f 74 65 2d 72 6f 2d 6d 6f 64 65 2d 63 remote-ro-mode-c
b370: 68 65 63 6b 65 64 20 72 75 6e 72 65 6d 6f 74 65 hecked runremote
b380: 29 29 0a 09 20 28 72 65 6d 6f 74 65 2d 72 6f 2d )).. (remote-ro-
b390: 6d 6f 64 65 20 72 75 6e 72 65 6d 6f 74 65 29 0a mode runremote).
b3a0: 09 20 28 6c 65 74 2a 20 28 28 6d 74 63 66 67 66 . (let* ((mtcfgf
b3b0: 69 6c 65 20 20 28 63 6f 6e 63 20 2a 74 6f 70 70 ile (conc *topp
b3c0: 61 74 68 2a 20 22 2f 6d 65 67 61 74 65 73 74 2e ath* "/megatest.
b3d0: 63 6f 6e 66 69 67 22 29 29 0a 09 09 28 72 6f 2d config"))...(ro-
b3e0: 6d 6f 64 65 20 28 6e 6f 74 20 28 66 69 6c 65 2d mode (not (file-
b3f0: 77 72 69 74 65 2d 61 63 63 65 73 73 3f 20 6d 74 write-access? mt
b400: 63 66 67 66 69 6c 65 29 29 29 29 20 3b 3b 20 54 cfgfile)))) ;; T
b410: 4f 44 4f 3a 20 75 73 65 20 64 62 73 74 72 75 63 ODO: use dbstruc
b420: 74 20 6f 72 20 72 75 6e 72 65 6d 6f 74 65 20 74 t or runremote t
b430: 6f 20 66 69 67 75 72 65 20 74 68 69 73 20 6f 75 o figure this ou
b440: 74 20 69 6e 20 66 75 74 75 72 65 0a 09 20 20 20 t in future..
b450: 28 69 66 20 72 75 6e 72 65 6d 6f 74 65 0a 09 20 (if runremote..
b460: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 20 (begin...
b470: 28 72 65 6d 6f 74 65 2d 72 6f 2d 6d 6f 64 65 2d (remote-ro-mode-
b480: 73 65 74 21 20 72 75 6e 72 65 6d 6f 74 65 20 72 set! runremote r
b490: 6f 2d 6d 6f 64 65 29 0a 09 09 20 28 72 65 6d 6f o-mode)... (remo
b4a0: 74 65 2d 72 6f 2d 6d 6f 64 65 2d 63 68 65 63 6b te-ro-mode-check
b4b0: 65 64 2d 73 65 74 21 20 72 75 6e 72 65 6d 6f 74 ed-set! runremot
b4c0: 65 20 23 74 29 0a 09 09 20 72 6f 2d 6d 6f 64 65 e #t)... ro-mode
b4d0: 29 0a 09 20 20 20 20 20 20 20 72 6f 2d 6d 6f 64 ).. ro-mod
b4e0: 65 29 29 29 29 0a 20 20 20 20 28 28 74 63 70 29 e)))). ((tcp)
b4f0: 0a 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 72 . (if (and r
b500: 75 6e 72 65 6d 6f 74 65 0a 09 20 20 20 20 20 20 unremote..
b510: 28 74 74 2d 72 6f 2d 6d 6f 64 65 2d 63 68 65 63 (tt-ro-mode-chec
b520: 6b 65 64 20 72 75 6e 72 65 6d 6f 74 65 29 29 0a ked runremote)).
b530: 09 20 28 74 74 2d 72 6f 2d 6d 6f 64 65 20 72 75 . (tt-ro-mode ru
b540: 6e 72 65 6d 6f 74 65 29 0a 09 20 28 6c 65 74 2a nremote).. (let*
b550: 20 28 28 6d 74 63 66 67 66 69 6c 65 20 20 28 63 ((mtcfgfile (c
b560: 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f onc *toppath* "/
b570: 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 67 22 megatest.config"
b580: 29 29 0a 09 09 28 72 6f 2d 6d 6f 64 65 20 28 6e ))...(ro-mode (n
b590: 6f 74 20 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 ot (file-write-a
b5a0: 63 63 65 73 73 3f 20 6d 74 63 66 67 66 69 6c 65 ccess? mtcfgfile
b5b0: 29 29 29 29 20 3b 3b 20 54 4f 44 4f 3a 20 75 73 )))) ;; TODO: us
b5c0: 65 20 64 62 73 74 72 75 63 74 20 6f 72 20 72 75 e dbstruct or ru
b5d0: 6e 72 65 6d 6f 74 65 20 74 6f 20 66 69 67 75 72 nremote to figur
b5e0: 65 20 74 68 69 73 20 6f 75 74 20 69 6e 20 66 75 e this out in fu
b5f0: 74 75 72 65 0a 09 20 20 20 28 69 66 20 72 75 6e ture.. (if run
b600: 72 65 6d 6f 74 65 0a 09 20 20 20 20 20 20 20 28 remote.. (
b610: 62 65 67 69 6e 0a 09 09 20 28 74 74 2d 72 6f 2d begin... (tt-ro-
b620: 6d 6f 64 65 2d 73 65 74 21 20 72 75 6e 72 65 6d mode-set! runrem
b630: 6f 74 65 20 72 6f 2d 6d 6f 64 65 29 0a 09 09 20 ote ro-mode)...
b640: 28 74 74 2d 72 6f 2d 6d 6f 64 65 2d 63 68 65 63 (tt-ro-mode-chec
b650: 6b 65 64 2d 73 65 74 21 20 72 75 6e 72 65 6d 6f ked-set! runremo
b660: 74 65 20 23 74 29 0a 09 09 20 72 6f 2d 6d 6f 64 te #t)... ro-mod
b670: 65 29 0a 09 20 20 20 20 20 20 20 72 6f 2d 6d 6f e).. ro-mo
b680: 64 65 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e de))))))..(defin
b690: 65 20 28 65 78 74 72 61 73 2d 72 65 61 64 6f 6e e (extras-readon
b6a0: 6c 79 2d 6d 6f 64 65 20 72 6d 74 2d 6d 75 74 65 ly-mode rmt-mute
b6b0: 78 20 6c 6f 67 2d 70 6f 72 74 20 63 6d 64 20 70 x log-port cmd p
b6c0: 61 72 61 6d 73 29 0a 20 20 28 6d 75 74 65 78 2d arams). (mutex-
b6d0: 75 6e 6c 6f 63 6b 21 20 72 6d 74 2d 6d 75 74 65 unlock! rmt-mute
b6e0: 78 29 0a 20 20 28 64 65 62 75 67 3a 70 72 69 6e x). (debug:prin
b6f0: 74 2d 69 6e 66 6f 20 31 32 20 6c 6f 67 2d 70 6f t-info 12 log-po
b700: 72 74 20 22 72 6d 74 3a 73 65 6e 64 2d 72 65 63 rt "rmt:send-rec
b710: 65 69 76 65 2c 20 63 61 73 65 20 33 22 29 0a 20 eive, case 3").
b720: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
b730: 6c 6f 67 2d 70 6f 72 74 20 22 57 41 52 4e 49 4e log-port "WARNIN
b740: 47 3a 20 77 72 69 74 65 20 74 72 61 6e 73 61 63 G: write transac
b750: 74 69 6f 6e 20 72 65 71 75 65 73 74 65 64 20 6f tion requested o
b760: 6e 20 61 20 72 65 61 64 6f 6e 6c 79 20 61 72 65 n a readonly are
b770: 61 2e 20 20 63 6d 64 3d 22 63 6d 64 22 20 70 61 a. cmd="cmd" pa
b780: 72 61 6d 73 3d 22 70 61 72 61 6d 73 29 0a 20 20 rams="params).
b790: 23 66 29 0a 0a 28 64 65 66 69 6e 65 20 28 65 78 #f)..(define (ex
b7a0: 74 72 61 73 2d 74 72 61 6e 73 70 6f 72 74 2d 66 tras-transport-f
b7b0: 61 69 6c 65 64 20 2a 64 65 66 61 75 6c 74 2d 6c ailed *default-l
b7c0: 6f 67 2d 70 6f 72 74 2a 20 2a 72 6d 74 2d 6d 75 og-port* *rmt-mu
b7d0: 74 65 78 2a 20 61 74 74 65 6d 70 74 6e 75 6d 20 tex* attemptnum
b7e0: 72 75 6e 72 65 6d 6f 74 65 20 63 6d 64 20 72 69 runremote cmd ri
b7f0: 64 20 70 61 72 61 6d 73 29 0a 20 20 28 64 65 62 d params). (deb
b800: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
b810: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 ult-log-port* "W
b820: 41 52 4e 49 4e 47 3a 20 63 6f 6d 6d 75 6e 69 63 ARNING: communic
b830: 61 74 69 6f 6e 20 66 61 69 6c 65 64 2e 20 54 72 ation failed. Tr
b840: 79 69 6e 67 20 61 67 61 69 6e 2c 20 74 72 79 20 ying again, try
b850: 6e 75 6d 3a 20 22 20 61 74 74 65 6d 70 74 6e 75 num: " attemptnu
b860: 6d 29 0a 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b m). (mutex-lock
b870: 21 20 2a 72 6d 74 2d 6d 75 74 65 78 2a 29 0a 20 ! *rmt-mutex*).
b880: 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 (http-transport
b890: 3a 63 6c 6f 73 65 2d 63 6f 6e 6e 65 63 74 69 6f :close-connectio
b8a0: 6e 73 20 72 75 6e 72 65 6d 6f 74 65 29 0a 20 20 ns runremote).
b8b0: 3b 3b 20 28 72 65 6d 6f 74 65 2d 73 65 72 76 65 ;; (remote-serve
b8c0: 72 2d 75 72 6c 2d 73 65 74 21 20 72 75 6e 72 65 r-url-set! runre
b8d0: 6d 6f 74 65 20 23 66 29 0a 20 20 28 6d 75 74 65 mote #f). (mute
b8e0: 78 2d 75 6e 6c 6f 63 6b 21 20 2a 72 6d 74 2d 6d x-unlock! *rmt-m
b8f0: 75 74 65 78 2a 29 0a 20 20 28 64 65 62 75 67 3a utex*). (debug:
b900: 70 72 69 6e 74 2d 69 6e 66 6f 20 31 32 20 2a 64 print-info 12 *d
b910: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
b920: 20 22 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 "rmt:send-recei
b930: 76 65 2c 20 63 61 73 65 20 20 39 2e 31 22 29 0a ve, case 9.1").
b940: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
b950: 69 76 65 20 63 6d 64 20 72 69 64 20 70 61 72 61 ive cmd rid para
b960: 6d 73 20 61 74 74 65 6d 70 74 6e 75 6d 3a 20 28 ms attemptnum: (
b970: 2b 20 61 74 74 65 6d 70 74 6e 75 6d 20 31 29 29 + attemptnum 1))
b980: 29 0a 20 20 0a 28 64 65 66 69 6e 65 20 28 65 78 ). .(define (ex
b990: 74 72 61 73 2d 74 72 61 6e 73 70 6f 72 74 2d 73 tras-transport-s
b9a0: 75 63 63 65 64 65 64 20 2a 64 65 66 61 75 6c 74 ucceded *default
b9b0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 2a 72 6d 74 2d -log-port* *rmt-
b9c0: 6d 75 74 65 78 2a 20 61 74 74 65 6d 70 74 6e 75 mutex* attemptnu
b9d0: 6d 20 72 75 6e 72 65 6d 6f 74 65 20 72 65 73 20 m runremote res
b9e0: 70 61 72 61 6d 73 20 72 69 64 20 63 6d 64 29 0a params rid cmd).
b9f0: 20 20 28 69 66 20 28 61 6e 64 20 28 76 65 63 74 (if (and (vect
ba00: 6f 72 3f 20 72 65 73 29 0a 09 20 20 20 28 65 71 or? res).. (eq
ba10: 3f 20 28 76 65 63 74 6f 72 2d 6c 65 6e 67 74 68 ? (vector-length
ba20: 20 72 65 73 29 20 32 29 0a 09 20 20 20 28 65 71 res) 2).. (eq
ba30: 3f 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 65 ? (vector-ref re
ba40: 73 20 31 29 20 27 6f 76 65 72 6c 6f 61 64 65 64 s 1) 'overloaded
ba50: 29 29 20 3b 3b 20 73 69 6e 63 65 20 77 65 20 61 )) ;; since we a
ba60: 72 65 0a 09 09 09 09 09 09 20 3b 3b 20 6c 6f 6f re....... ;; loo
ba70: 6b 69 6e 67 20 61 74 20 74 68 65 0a 09 09 09 09 king at the.....
ba80: 09 09 20 3b 3b 20 64 61 74 61 20 74 6f 20 63 61 .. ;; data to ca
ba90: 72 72 79 20 74 68 65 0a 09 09 09 09 09 09 20 3b rry the....... ;
baa0: 3b 20 65 72 72 6f 72 20 77 65 27 6c 6c 20 75 73 ; error we'll us
bab0: 65 20 61 0a 09 09 09 09 09 09 20 3b 3b 20 66 61 e a....... ;; fa
bac0: 69 72 6c 79 20 6f 62 74 75 73 65 0a 09 09 09 09 irly obtuse.....
bad0: 09 09 20 3b 3b 20 63 6f 6d 62 6f 20 74 6f 20 6d .. ;; combo to m
bae0: 69 6e 69 6d 69 73 65 0a 09 09 09 09 09 09 20 3b inimise....... ;
baf0: 3b 20 74 68 65 20 63 68 61 6e 63 65 73 20 6f 66 ; the chances of
bb00: 0a 09 09 09 09 09 09 20 3b 3b 20 73 6f 6d 65 20 ....... ;; some
bb10: 73 6f 72 74 20 6f 66 0a 09 09 09 09 09 09 20 3b sort of....... ;
bb20: 3b 20 63 6f 6c 6c 69 73 69 6f 6e 2e 20 20 74 68 ; collision. th
bb30: 69 73 0a 09 09 09 09 09 09 20 3b 3b 20 69 73 20 is....... ;; is
bb40: 74 68 65 20 63 61 73 65 20 77 68 65 72 65 0a 09 the case where..
bb50: 09 09 09 09 09 20 3b 3b 20 74 68 65 20 72 65 74 ..... ;; the ret
bb60: 75 72 6e 65 64 20 64 61 74 61 0a 09 09 09 09 09 urned data......
bb70: 09 20 3b 3b 20 69 73 20 62 61 64 20 6f 72 20 74 . ;; is bad or t
bb80: 68 65 0a 09 09 09 09 09 09 20 3b 3b 20 73 65 72 he....... ;; ser
bb90: 76 65 72 20 69 73 0a 09 09 09 09 09 09 20 3b 3b ver is....... ;;
bba0: 20 6f 76 65 72 6c 6f 61 64 65 64 20 61 6e 64 20 overloaded and
bbb0: 77 65 0a 09 09 09 09 09 09 20 3b 3b 20 77 61 6e we....... ;; wan
bbc0: 74 20 74 6f 20 65 61 73 65 20 6f 66 66 0a 09 09 t to ease off...
bbd0: 09 09 09 09 20 3b 3b 20 74 68 65 20 71 75 65 72 .... ;; the quer
bbe0: 69 65 73 0a 20 20 20 20 20 20 28 6c 65 74 20 28 ies. (let (
bbf0: 28 77 61 69 74 2d 64 65 6c 61 79 20 28 2b 20 61 (wait-delay (+ a
bc00: 74 74 65 6d 70 74 6e 75 6d 20 28 2a 20 61 74 74 ttemptnum (* att
bc10: 65 6d 70 74 6e 75 6d 20 31 30 29 29 29 29 0a 09 emptnum 10))))..
bc20: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
bc30: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
bc40: 2a 20 22 57 41 52 4e 49 4e 47 3a 20 73 65 72 76 * "WARNING: serv
bc50: 65 72 20 69 73 20 6f 76 65 72 6c 6f 61 64 65 64 er is overloaded
bc60: 2e 20 44 65 6c 61 79 69 6e 67 20 22 20 77 61 69 . Delaying " wai
bc70: 74 2d 64 65 6c 61 79 20 22 20 73 65 63 6f 6e 64 t-delay " second
bc80: 73 20 61 6e 64 20 74 72 79 69 6e 67 20 63 61 6c s and trying cal
bc90: 6c 20 61 67 61 69 6e 2e 22 29 0a 09 28 6d 75 74 l again.")..(mut
bca0: 65 78 2d 6c 6f 63 6b 21 20 2a 72 6d 74 2d 6d 75 ex-lock! *rmt-mu
bcb0: 74 65 78 2a 29 0a 09 28 68 74 74 70 2d 74 72 61 tex*)..(http-tra
bcc0: 6e 73 70 6f 72 74 3a 63 6c 6f 73 65 2d 63 6f 6e nsport:close-con
bcd0: 6e 65 63 74 69 6f 6e 73 20 72 75 6e 72 65 6d 6f nections runremo
bce0: 74 65 29 0a 09 28 73 65 74 21 20 2a 72 75 6e 72 te)..(set! *runr
bcf0: 65 6d 6f 74 65 2a 20 23 66 29 20 3b 3b 20 66 6f emote* #f) ;; fo
bd00: 72 63 65 20 73 74 61 72 74 69 6e 67 20 6f 76 65 rce starting ove
bd10: 72 0a 09 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b r..(mutex-unlock
bd20: 21 20 2a 72 6d 74 2d 6d 75 74 65 78 2a 29 0a 09 ! *rmt-mutex*)..
bd30: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 77 (thread-sleep! w
bd40: 61 69 74 2d 64 65 6c 61 79 29 0a 09 28 72 6d 74 ait-delay)..(rmt
bd50: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 63 6d :send-receive cm
bd60: 64 20 72 69 64 20 70 61 72 61 6d 73 20 61 74 74 d rid params att
bd70: 65 6d 70 74 6e 75 6d 3a 20 28 2b 20 61 74 74 65 emptnum: (+ atte
bd80: 6d 70 74 6e 75 6d 20 31 29 29 29 0a 20 20 20 20 mptnum 1))).
bd90: 20 20 72 65 73 29 29 20 3b 3b 20 41 6c 6c 20 67 res)) ;; All g
bda0: 6f 6f 64 2c 20 72 65 74 75 72 6e 20 72 65 73 0a ood, return res.
bdb0: 0a 23 3b 28 73 65 74 2d 66 75 6e 63 74 69 6f 6e .#;(set-function
bdc0: 73 20 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 s rmt:send-recei
bdd0: 76 65 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ve
bde0: 20 20 20 20 20 20 20 20 20 72 65 6d 6f 74 65 2d remote-
bdf0: 73 65 72 76 65 72 2d 75 72 6c 2d 73 65 74 21 0a server-url-set!.
be00: 09 20 20 20 20 20 20 20 68 74 74 70 2d 74 72 61 . http-tra
be10: 6e 73 70 6f 72 74 3a 63 6c 6f 73 65 2d 63 6f 6e nsport:close-con
be20: 6e 65 63 74 69 6f 6e 73 09 20 20 20 20 20 20 72 nections. r
be30: 65 6d 6f 74 65 2d 63 6f 6e 6e 64 61 74 2d 73 65 emote-conndat-se
be40: 74 21 0a 09 20 20 20 20 20 20 20 64 65 62 75 67 t!.. debug
be50: 3a 70 72 69 6e 74 20 20 20 20 20 20 20 20 20 20 :print
be60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
be70: 20 20 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e debug:print-in
be80: 66 6f 0a 09 20 20 20 20 20 20 20 72 65 6d 6f 74 fo.. remot
be90: 65 2d 72 6f 2d 6d 6f 64 65 20 20 20 20 20 20 20 e-ro-mode
bea0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
beb0: 20 20 72 65 6d 6f 74 65 2d 72 6f 2d 6d 6f 64 65 remote-ro-mode
bec0: 2d 73 65 74 21 0a 09 20 20 20 20 20 20 20 72 65 -set!.. re
bed0: 6d 6f 74 65 2d 72 6f 2d 6d 6f 64 65 2d 63 68 65 mote-ro-mode-che
bee0: 63 6b 65 64 2d 73 65 74 21 20 20 20 20 20 20 20 cked-set!
bef0: 20 20 20 20 20 72 65 6d 6f 74 65 2d 72 6f 2d 6d remote-ro-m
bf00: 6f 64 65 2d 63 68 65 63 6b 65 64 29 0a ode-checked).