Artifact
5e992d9837c0cd36fa82985ec54b0328305c832a:
0000: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
0010: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0020: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0030: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0040: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 43 6f 70 79 ========.;; Copy
0050: 72 69 67 68 74 20 32 30 30 36 2d 32 30 31 33 2c right 2006-2013,
0060: 20 4d 61 74 74 68 65 77 20 57 65 6c 6c 61 6e 64 Matthew Welland
0070: 2e 0a 3b 3b 20 0a 3b 3b 20 20 54 68 69 73 20 70 ..;; .;; This p
0080: 72 6f 67 72 61 6d 20 69 73 20 6d 61 64 65 20 61 rogram is made a
0090: 76 61 69 6c 61 62 6c 65 20 75 6e 64 65 72 20 74 vailable under t
00a0: 68 65 20 47 4e 55 20 47 50 4c 20 76 65 72 73 69 he GNU GPL versi
00b0: 6f 6e 20 32 2e 30 20 6f 72 0a 3b 3b 20 20 67 72 on 2.0 or.;; gr
00c0: 65 61 74 65 72 2e 20 53 65 65 20 74 68 65 20 61 eater. See the a
00d0: 63 63 6f 6d 70 61 6e 79 69 6e 67 20 66 69 6c 65 ccompanying file
00e0: 20 43 4f 50 59 49 4e 47 20 66 6f 72 20 64 65 74 COPYING for det
00f0: 61 69 6c 73 2e 0a 3b 3b 20 0a 3b 3b 20 20 54 68 ails..;; .;; Th
0100: 69 73 20 70 72 6f 67 72 61 6d 20 69 73 20 64 69 is program is di
0110: 73 74 72 69 62 75 74 65 64 20 57 49 54 48 4f 55 stributed WITHOU
0120: 54 20 41 4e 59 20 57 41 52 52 41 4e 54 59 3b 20 T ANY WARRANTY;
0130: 77 69 74 68 6f 75 74 20 65 76 65 6e 20 74 68 65 without even the
0140: 0a 3b 3b 20 20 69 6d 70 6c 69 65 64 20 77 61 72 .;; implied war
0150: 72 61 6e 74 79 20 6f 66 20 4d 45 52 43 48 41 4e ranty of MERCHAN
0160: 54 41 42 49 4c 49 54 59 20 6f 72 20 46 49 54 4e TABILITY or FITN
0170: 45 53 53 20 46 4f 52 20 41 20 50 41 52 54 49 43 ESS FOR A PARTIC
0180: 55 4c 41 52 0a 3b 3b 20 20 50 55 52 50 4f 53 45 ULAR.;; PURPOSE
0190: 2e 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
01a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 75 73 65 ==========..(use
01e0: 20 66 6f 72 6d 61 74 20 74 79 70 65 64 2d 72 65 format typed-re
01f0: 63 6f 72 64 73 29 20 3b 3b 20 52 41 44 54 20 3d cords) ;; RADT =
0200: 3e 20 70 75 72 70 6f 73 65 20 6f 66 20 6a 73 6f > purpose of jso
0210: 6e 20 66 6f 72 6d 61 74 3f 3f 0a 0a 28 64 65 63 n format??..(dec
0220: 6c 61 72 65 20 28 75 6e 69 74 20 72 6d 74 29 29 lare (unit rmt))
0230: 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 .(declare (uses
0240: 61 70 69 29 29 0a 28 64 65 63 6c 61 72 65 20 28 api)).(declare (
0250: 75 73 65 73 20 74 64 62 29 29 0a 28 64 65 63 6c uses tdb)).(decl
0260: 61 72 65 20 28 75 73 65 73 20 68 74 74 70 2d 74 are (uses http-t
0270: 72 61 6e 73 70 6f 72 74 29 29 0a 3b 3b 28 64 65 ransport)).;;(de
0280: 63 6c 61 72 65 20 28 75 73 65 73 20 6e 6d 73 67 clare (uses nmsg
0290: 2d 74 72 61 6e 73 70 6f 72 74 29 29 0a 28 69 6e -transport)).(in
02a0: 63 6c 75 64 65 20 22 63 6f 6d 6d 6f 6e 5f 72 65 clude "common_re
02b0: 63 6f 72 64 73 2e 73 63 6d 22 29 0a 0a 3b 3b 0a cords.scm")..;;.
02c0: 3b 3b 20 54 48 45 53 45 20 41 52 45 20 41 4c 4c ;; THESE ARE ALL
02d0: 20 43 41 4c 4c 45 44 20 4f 4e 20 54 48 45 20 43 CALLED ON THE C
02e0: 4c 49 45 4e 54 20 53 49 44 45 21 21 21 0a 3b 3b LIENT SIDE!!!.;;
02f0: 0a 0a 3b 3b 20 67 65 6e 65 72 61 74 65 20 65 6e ..;; generate en
0300: 74 72 69 65 73 20 66 6f 72 20 7e 2f 2e 6d 65 67 tries for ~/.meg
0310: 61 74 65 73 74 72 63 20 77 69 74 68 20 74 68 65 atestrc with the
0320: 20 66 6f 6c 6c 6f 77 69 6e 67 0a 3b 3b 0a 3b 3b following.;;.;;
0330: 20 20 67 72 65 70 20 64 65 66 69 6e 65 20 2e 2e grep define ..
0340: 2f 72 6d 74 2e 73 63 6d 20 7c 20 67 72 65 70 20 /rmt.scm | grep
0350: 72 6d 74 3a 20 7c 70 65 72 6c 20 2d 70 69 20 2d rmt: |perl -pi -
0360: 65 20 27 73 2f 5c 28 64 65 66 69 6e 65 5c 73 2b e 's/\(define\s+
0370: 5c 28 28 5c 53 2b 29 5c 57 2e 2a 24 2f 5c 31 2f \((\S+)\W.*$/\1/
0380: 27 7c 73 6f 72 74 20 2d 75 0a 0a 28 64 65 66 73 '|sort -u..(defs
0390: 74 72 75 63 74 20 72 65 6d 6f 74 65 0a 20 20 28 truct remote. (
03a0: 68 68 2d 64 61 74 20 20 20 20 20 20 20 20 20 20 hh-dat
03b0: 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 68 6f (common:get-ho
03c0: 6d 65 68 6f 73 74 29 29 20 3b 3b 20 68 6f 6d 65 mehost)) ;; home
03d0: 68 6f 73 74 20 72 65 63 6f 72 64 20 28 20 61 64 host record ( ad
03e0: 64 72 20 2e 20 68 68 66 6c 61 67 20 29 0a 20 20 dr . hhflag ).
03f0: 28 73 65 72 76 65 72 2d 75 72 6c 20 20 20 20 20 (server-url
0400: 20 20 20 28 69 66 20 2a 74 6f 70 70 61 74 68 2a (if *toppath*
0410: 20 28 73 65 72 76 65 72 3a 72 65 61 64 2d 64 6f (server:read-do
0420: 74 73 65 72 76 65 72 20 2a 74 6f 70 70 61 74 68 tserver *toppath
0430: 2a 29 29 29 20 3b 3b 20 28 73 65 72 76 65 72 3a *))) ;; (server:
0440: 63 68 65 63 6b 2d 69 66 2d 72 75 6e 6e 69 6e 67 check-if-running
0450: 20 2a 74 6f 70 70 61 74 68 2a 29 20 23 66 29 29 *toppath*) #f))
0460: 0a 20 20 28 6c 61 73 74 2d 73 65 72 76 65 72 2d . (last-server-
0470: 63 68 65 63 6b 20 30 29 20 20 3b 3b 20 6c 61 73 check 0) ;; las
0480: 74 20 74 69 6d 65 20 77 65 20 63 68 65 63 6b 65 t time we checke
0490: 64 20 74 6f 20 73 65 65 20 69 66 20 74 68 65 20 d to see if the
04a0: 73 65 72 76 65 72 20 77 61 73 20 61 6c 69 76 65 server was alive
04b0: 0a 20 20 28 63 6f 6e 6e 64 61 74 20 20 20 20 20 . (conndat
04c0: 20 20 20 20 20 20 23 66 29 0a 20 20 28 74 72 61 #f). (tra
04d0: 6e 73 70 6f 72 74 20 20 20 20 20 20 20 20 20 2a nsport *
04e0: 74 72 61 6e 73 70 6f 72 74 2d 74 79 70 65 2a 29 transport-type*)
04f0: 0a 20 20 28 73 65 72 76 65 72 2d 74 69 6d 65 6f . (server-timeo
0500: 75 74 20 20 20 20 28 6f 72 20 28 73 65 72 76 65 ut (or (serve
0510: 72 3a 67 65 74 2d 74 69 6d 65 6f 75 74 29 20 31 r:get-timeout) 1
0520: 30 30 29 29 29 20 3b 3b 20 64 65 66 61 75 6c 74 00))) ;; default
0530: 20 74 6f 20 31 30 30 20 73 65 63 6f 6e 64 73 0a to 100 seconds.
0540: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
0550: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0560: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0570: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0580: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 53 20 =========.;; S
0590: 55 20 50 20 50 20 4f 20 52 20 54 20 20 20 46 20 U P P O R T F
05a0: 55 20 4e 20 43 20 54 20 49 20 4f 20 4e 20 53 0a U N C T I O N S.
05b0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
05c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
05d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
05e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
05f0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 69 66 20 ========..;; if
0600: 61 20 73 65 72 76 65 72 20 69 73 20 65 69 74 68 a server is eith
0610: 65 72 20 72 75 6e 6e 69 6e 67 20 6f 72 20 69 6e er running or in
0620: 20 74 68 65 20 70 72 6f 63 65 73 73 20 6f 66 20 the process of
0630: 73 74 61 72 74 69 6e 67 20 63 61 6c 6c 20 63 6c starting call cl
0640: 69 65 6e 74 3a 73 65 74 75 70 0a 3b 3b 20 65 6c ient:setup.;; el
0650: 73 65 20 72 65 74 75 72 6e 20 23 66 20 74 6f 20 se return #f to
0660: 6c 65 74 20 74 68 65 20 63 61 6c 6c 69 6e 67 20 let the calling
0670: 70 72 6f 63 20 6b 6e 6f 77 20 74 68 61 74 20 74 proc know that t
0680: 68 65 72 65 20 69 73 20 6e 6f 20 73 65 72 76 65 here is no serve
0690: 72 20 61 76 61 69 6c 61 62 6c 65 0a 3b 3b 0a 28 r available.;;.(
06a0: 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d define (rmt:get-
06b0: 63 6f 6e 6e 65 63 74 69 6f 6e 2d 69 6e 66 6f 20 connection-info
06c0: 72 75 6e 2d 69 64 29 0a 20 20 28 6c 65 74 20 28 run-id). (let (
06d0: 28 63 69 6e 66 6f 20 28 72 65 6d 6f 74 65 2d 63 (cinfo (remote-c
06e0: 6f 6e 6e 64 61 74 20 2a 72 75 6e 72 65 6d 6f 74 onndat *runremot
06f0: 65 2a 29 29 29 0a 20 20 20 20 28 69 66 20 63 69 e*))). (if ci
0700: 6e 66 6f 0a 09 63 69 6e 66 6f 0a 09 28 69 66 20 nfo..cinfo..(if
0710: 28 74 61 73 6b 73 3a 73 65 72 76 65 72 2d 72 75 (tasks:server-ru
0720: 6e 6e 69 6e 67 2d 6f 72 2d 73 74 61 72 74 69 6e nning-or-startin
0730: 67 3f 20 28 64 62 3a 64 65 6c 61 79 2d 69 66 2d g? (db:delay-if-
0740: 62 75 73 79 20 28 74 61 73 6b 73 3a 6f 70 65 6e busy (tasks:open
0750: 2d 64 62 29 29 20 72 75 6e 2d 69 64 29 0a 09 20 -db)) run-id)..
0760: 20 20 20 28 63 6c 69 65 6e 74 3a 73 65 74 75 70 (client:setup
0770: 20 72 75 6e 2d 69 64 29 0a 09 20 20 20 20 23 66 run-id).. #f
0780: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 2a 73 ))))..(define *s
0790: 65 6e 64 2d 72 65 63 65 69 76 65 2d 6d 75 74 65 end-receive-mute
07a0: 78 2a 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 x* (make-mutex))
07b0: 20 3b 3b 20 73 68 6f 75 6c 64 20 68 61 76 65 20 ;; should have
07c0: 73 65 70 61 72 61 74 65 20 6d 75 74 65 78 20 70 separate mutex p
07d0: 65 72 20 72 75 6e 2d 69 64 0a 0a 3b 3b 20 52 41 er run-id..;; RA
07e0: 20 3d 3e 20 65 2e 67 2e 20 75 73 61 67 65 20 28 => e.g. usage (
07f0: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
0800: 20 27 67 65 74 2d 76 61 72 20 23 66 20 28 6c 69 'get-var #f (li
0810: 73 74 20 76 61 72 6e 61 6d 65 29 29 0a 3b 3b 0a st varname)).;;.
0820: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 73 65 6e (define (rmt:sen
0830: 64 2d 72 65 63 65 69 76 65 20 63 6d 64 20 72 69 d-receive cmd ri
0840: 64 20 70 61 72 61 6d 73 20 23 21 6b 65 79 20 28 d params #!key (
0850: 61 74 74 65 6d 70 74 6e 75 6d 20 31 29 29 20 3b attemptnum 1)) ;
0860: 3b 20 73 74 61 72 74 20 61 74 74 65 6d 70 74 6e ; start attemptn
0870: 75 6d 20 61 74 20 31 20 73 6f 20 74 68 65 20 6d um at 1 so the m
0880: 6f 64 75 6c 6f 20 62 65 6c 6f 77 20 77 6f 72 6b odulo below work
0890: 73 20 61 73 20 65 78 70 65 63 74 65 64 0a 0a 20 s as expected..
08a0: 20 3b 3b 20 64 6f 20 61 6c 6c 20 74 68 65 20 70 ;; do all the p
08b0: 72 65 70 20 6c 6f 63 6b 65 64 20 75 6e 64 65 72 rep locked under
08c0: 20 74 68 65 20 72 6d 74 2d 6d 75 74 65 78 0a 20 the rmt-mutex.
08d0: 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 72 (mutex-lock! *r
08e0: 6d 74 2d 6d 75 74 65 78 2a 29 0a 0a 20 20 3b 3b mt-mutex*).. ;;
08f0: 20 31 2e 20 63 68 65 63 6b 20 69 66 20 73 65 72 1. check if ser
0900: 76 65 72 20 69 73 20 73 74 61 72 74 65 64 20 49 ver is started I
0910: 46 46 20 63 6d 64 20 69 73 20 61 20 77 72 69 74 FF cmd is a writ
0920: 65 20 4f 52 20 69 66 20 77 65 20 61 72 65 20 6e e OR if we are n
0930: 6f 74 20 6f 6e 20 74 68 65 20 68 6f 6d 65 68 6f ot on the homeho
0940: 73 74 2c 20 73 74 6f 72 65 20 69 6e 20 2a 72 75 st, store in *ru
0950: 6e 72 65 6d 6f 74 65 2a 0a 20 20 3b 3b 20 32 2e nremote*. ;; 2.
0960: 20 63 68 65 63 6b 20 74 68 65 20 61 67 65 20 6f check the age o
0970: 66 20 74 68 65 20 63 6f 6e 6e 65 63 74 69 6f 6e f the connection
0980: 73 2e 20 72 65 66 72 65 73 68 20 74 68 65 20 63 s. refresh the c
0990: 6f 6e 6e 65 63 74 69 6f 6e 20 69 66 20 69 74 20 onnection if it
09a0: 69 73 20 6f 6c 64 65 72 20 74 68 61 6e 20 74 69 is older than ti
09b0: 6d 65 6f 75 74 2d 32 30 20 73 65 63 6f 6e 64 73 meout-20 seconds
09c0: 2e 0a 20 20 3b 3b 20 33 2e 20 64 6f 20 74 68 65 .. ;; 3. do the
09d0: 20 71 75 65 72 79 2c 20 69 66 20 6f 6e 20 68 6f query, if on ho
09e0: 6d 65 68 6f 73 74 20 75 73 65 20 6c 6f 63 61 6c mehost use local
09f0: 20 61 63 63 65 73 73 0a 20 20 3b 3b 0a 20 20 28 access. ;;. (
0a00: 6c 65 74 2a 20 28 28 73 74 61 72 74 2d 74 69 6d let* ((start-tim
0a10: 65 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e e (current-secon
0a20: 64 73 29 29 29 20 3b 3b 20 73 6e 61 70 73 68 6f ds))) ;; snapsho
0a30: 74 20 74 69 6d 65 20 73 6f 20 61 6c 6c 20 75 73 t time so all us
0a40: 65 20 63 61 73 65 73 20 67 65 74 20 73 61 6d 65 e cases get same
0a50: 20 76 61 6c 75 65 0a 20 20 20 20 28 63 6f 6e 64 value. (cond
0a60: 0a 20 20 20 20 20 3b 3b 20 67 69 76 65 20 75 70 . ;; give up
0a70: 20 69 66 20 6d 6f 72 65 20 74 68 61 6e 20 31 35 if more than 15
0a80: 20 61 74 74 65 6d 70 74 73 0a 20 20 20 20 20 28 attempts. (
0a90: 28 3e 20 61 74 74 65 6d 70 74 6e 75 6d 20 31 35 (> attemptnum 15
0aa0: 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 ). (debug:p
0ab0: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
0ac0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 52 52 4f 52 log-port* "ERROR
0ad0: 3a 20 31 35 20 74 72 69 65 73 20 74 6f 20 73 74 : 15 tries to st
0ae0: 61 72 74 2f 63 6f 6e 6e 65 63 74 20 74 6f 20 73 art/connect to s
0af0: 65 72 76 65 72 2e 20 47 69 76 69 6e 67 20 75 70 erver. Giving up
0b00: 2e 22 29 0a 20 20 20 20 20 20 28 65 78 69 74 20 ."). (exit
0b10: 31 29 29 0a 20 20 20 20 20 3b 3b 20 72 65 73 65 1)). ;; rese
0b20: 74 20 74 68 65 20 63 6f 6e 6e 65 63 74 69 6f 6e t the connection
0b30: 20 69 66 20 69 74 20 68 61 73 20 62 65 65 6e 20 if it has been
0b40: 75 6e 75 73 65 64 20 74 6f 6f 20 6c 6f 6e 67 0a unused too long.
0b50: 20 20 20 20 20 28 28 61 6e 64 20 2a 72 75 6e 72 ((and *runr
0b60: 65 6d 6f 74 65 2a 0a 20 20 20 20 20 20 20 20 20 emote*.
0b70: 20 20 28 72 65 6d 6f 74 65 2d 63 6f 6e 6e 64 61 (remote-connda
0b80: 74 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 29 0a 09 t *runremote*)..
0b90: 20 20 20 28 6c 65 74 20 28 28 65 78 70 69 72 65 (let ((expire
0ba0: 2d 74 69 6d 65 20 28 2d 20 73 74 61 72 74 2d 74 -time (- start-t
0bb0: 69 6d 65 20 28 72 65 6d 6f 74 65 2d 73 65 72 76 ime (remote-serv
0bc0: 65 72 2d 74 69 6d 65 6f 75 74 20 2a 72 75 6e 72 er-timeout *runr
0bd0: 65 6d 6f 74 65 2a 29 29 29 29 0a 09 20 20 20 20 emote*))))..
0be0: 20 28 3c 20 28 68 74 74 70 2d 74 72 61 6e 73 70 (< (http-transp
0bf0: 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 74 2d 67 ort:server-dat-g
0c00: 65 74 2d 6c 61 73 74 2d 61 63 63 65 73 73 20 28 et-last-access (
0c10: 72 65 6d 6f 74 65 2d 63 6f 6e 6e 64 61 74 20 2a remote-conndat *
0c20: 72 75 6e 72 65 6d 6f 74 65 2a 29 29 20 65 78 70 runremote*)) exp
0c30: 69 72 65 2d 74 69 6d 65 29 29 29 0a 20 20 20 20 ire-time))).
0c40: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
0c50: 6e 66 6f 20 31 32 20 2a 64 65 66 61 75 6c 74 2d nfo 12 *default-
0c60: 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 6d 74 3a 73 log-port* "rmt:s
0c70: 65 6e 64 2d 72 65 63 65 69 76 65 2c 20 63 61 73 end-receive, cas
0c80: 65 20 20 38 22 29 0a 20 20 20 20 20 20 28 72 65 e 8"). (re
0c90: 6d 6f 74 65 2d 63 6f 6e 6e 64 61 74 2d 73 65 74 mote-conndat-set
0ca0: 21 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 23 66 ! *runremote* #f
0cb0: 29 0a 20 20 20 20 20 20 28 6d 75 74 65 78 2d 75 ). (mutex-u
0cc0: 6e 6c 6f 63 6b 21 20 2a 72 6d 74 2d 6d 75 74 65 nlock! *rmt-mute
0cd0: 78 2a 29 0a 20 20 20 20 20 20 28 72 6d 74 3a 73 x*). (rmt:s
0ce0: 65 6e 64 2d 72 65 63 65 69 76 65 20 63 6d 64 20 end-receive cmd
0cf0: 72 69 64 20 70 61 72 61 6d 73 20 61 74 74 65 6d rid params attem
0d00: 70 74 6e 75 6d 3a 20 61 74 74 65 6d 70 74 6e 75 ptnum: attemptnu
0d10: 6d 29 29 0a 20 20 20 20 20 3b 3b 20 65 6e 73 75 m)). ;; ensu
0d20: 72 65 20 77 65 20 68 61 76 65 20 61 20 72 65 63 re we have a rec
0d30: 6f 72 64 20 66 6f 72 20 6f 75 72 20 63 6f 6e 6e ord for our conn
0d40: 65 63 74 69 6f 6e 20 66 6f 72 20 67 69 76 65 6e ection for given
0d50: 20 61 72 65 61 0a 20 20 20 20 20 28 28 6e 6f 74 area. ((not
0d60: 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 29 20 20 20 *runremote*)
0d70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0d80: 20 20 0a 20 20 20 20 20 20 28 73 65 74 21 20 2a . (set! *
0d90: 72 75 6e 72 65 6d 6f 74 65 2a 20 28 6d 61 6b 65 runremote* (make
0da0: 2d 72 65 6d 6f 74 65 29 29 0a 20 20 20 20 20 20 -remote)).
0db0: 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a (mutex-unlock! *
0dc0: 72 6d 74 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 rmt-mutex*).
0dd0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
0de0: 6e 66 6f 20 31 32 20 2a 64 65 66 61 75 6c 74 2d nfo 12 *default-
0df0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 6d 74 3a 73 log-port* "rmt:s
0e00: 65 6e 64 2d 72 65 63 65 69 76 65 2c 20 63 61 73 end-receive, cas
0e10: 65 20 20 31 22 29 0a 20 20 20 20 20 20 28 72 6d e 1"). (rm
0e20: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 63 t:send-receive c
0e30: 6d 64 20 72 69 64 20 70 61 72 61 6d 73 20 61 74 md rid params at
0e40: 74 65 6d 70 74 6e 75 6d 3a 20 61 74 74 65 6d 70 temptnum: attemp
0e50: 74 6e 75 6d 29 29 0a 20 20 20 20 20 3b 3b 20 65 tnum)). ;; e
0e60: 6e 73 75 72 65 20 77 65 20 68 61 76 65 20 61 20 nsure we have a
0e70: 68 6f 6d 65 68 6f 73 74 20 72 65 63 6f 72 64 0a homehost record.
0e80: 20 20 20 20 20 28 28 6e 6f 74 20 28 70 61 69 72 ((not (pair
0e90: 3f 20 28 72 65 6d 6f 74 65 2d 68 68 2d 64 61 74 ? (remote-hh-dat
0ea0: 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 29 29 29 20 *runremote*)))
0eb0: 20 3b 3b 20 68 61 76 65 20 61 20 68 6f 6d 65 68 ;; have a homeh
0ec0: 6f 73 74 20 72 65 63 6f 72 64 3f 0a 20 20 20 20 ost record?.
0ed0: 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
0ee0: 20 30 2e 31 29 20 3b 3b 20 73 69 6e 63 65 20 77 0.1) ;; since w
0ef0: 65 20 73 68 6f 75 6c 64 6e 27 74 20 67 65 74 20 e shouldn't get
0f00: 68 65 72 65 2c 20 64 65 6c 61 79 20 61 20 6c 69 here, delay a li
0f10: 74 74 6c 65 0a 20 20 20 20 20 20 28 72 65 6d 6f ttle. (remo
0f20: 74 65 2d 68 68 2d 64 61 74 2d 73 65 74 21 20 2a te-hh-dat-set! *
0f30: 72 75 6e 72 65 6d 6f 74 65 2a 20 28 63 6f 6d 6d runremote* (comm
0f40: 6f 6e 3a 67 65 74 2d 68 6f 6d 65 68 6f 73 74 29 on:get-homehost)
0f50: 29 0a 20 20 20 20 20 20 28 6d 75 74 65 78 2d 75 ). (mutex-u
0f60: 6e 6c 6f 63 6b 21 20 2a 72 6d 74 2d 6d 75 74 65 nlock! *rmt-mute
0f70: 78 2a 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 x*). (debug
0f80: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 32 20 2a :print-info 12 *
0f90: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
0fa0: 2a 20 22 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 * "rmt:send-rece
0fb0: 69 76 65 2c 20 63 61 73 65 20 20 32 22 29 0a 20 ive, case 2").
0fc0: 20 20 20 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 (rmt:send-r
0fd0: 65 63 65 69 76 65 20 63 6d 64 20 72 69 64 20 70 eceive cmd rid p
0fe0: 61 72 61 6d 73 20 61 74 74 65 6d 70 74 6e 75 6d arams attemptnum
0ff0: 3a 20 61 74 74 65 6d 70 74 6e 75 6d 29 29 0a 20 : attemptnum)).
1000: 20 20 20 20 3b 3b 20 6f 6e 20 68 6f 6d 65 68 6f ;; on homeho
1010: 73 74 20 61 6e 64 20 74 68 69 73 20 69 73 20 61 st and this is a
1020: 20 72 65 61 64 0a 20 20 20 20 20 28 28 61 6e 64 read. ((and
1030: 20 28 63 64 72 20 28 72 65 6d 6f 74 65 2d 68 68 (cdr (remote-hh
1040: 2d 64 61 74 20 2a 72 75 6e 72 65 6d 6f 74 65 2a -dat *runremote*
1050: 29 29 20 20 20 3b 3b 20 6f 6e 20 68 6f 6d 65 68 )) ;; on homeh
1060: 6f 73 74 0a 20 20 20 20 20 20 20 20 20 20 20 28 ost. (
1070: 6d 65 6d 62 65 72 20 63 6d 64 20 61 70 69 3a 72 member cmd api:r
1080: 65 61 64 2d 6f 6e 6c 79 2d 71 75 65 72 69 65 73 ead-only-queries
1090: 29 29 20 3b 3b 20 74 68 69 73 20 69 73 20 61 20 )) ;; this is a
10a0: 72 65 61 64 0a 20 20 20 20 20 20 28 6d 75 74 65 read. (mute
10b0: 78 2d 75 6e 6c 6f 63 6b 21 20 2a 72 6d 74 2d 6d x-unlock! *rmt-m
10c0: 75 74 65 78 2a 29 0a 20 20 20 20 20 20 28 64 65 utex*). (de
10d0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 bug:print-info 1
10e0: 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 2 *default-log-p
10f0: 6f 72 74 2a 20 22 72 6d 74 3a 73 65 6e 64 2d 72 ort* "rmt:send-r
1100: 65 63 65 69 76 65 2c 20 63 61 73 65 20 20 33 22 eceive, case 3"
1110: 29 0a 20 20 20 20 20 20 28 72 6d 74 3a 6f 70 65 ). (rmt:ope
1120: 6e 2d 71 72 79 2d 63 6c 6f 73 65 2d 6c 6f 63 61 n-qry-close-loca
1130: 6c 6c 79 20 63 6d 64 20 30 20 70 61 72 61 6d 73 lly cmd 0 params
1140: 29 29 0a 20 20 20 20 20 3b 3b 20 6f 6e 20 68 6f )). ;; on ho
1150: 6d 65 68 6f 73 74 20 61 6e 64 20 74 68 69 73 20 mehost and this
1160: 69 73 20 61 20 77 72 69 74 65 2c 20 77 65 20 61 is a write, we a
1170: 6c 72 65 61 64 79 20 68 61 76 65 20 61 20 73 65 lready have a se
1180: 72 76 65 72 0a 20 20 20 20 20 28 28 61 6e 64 20 rver. ((and
1190: 28 63 64 72 20 28 72 65 6d 6f 74 65 2d 68 68 2d (cdr (remote-hh-
11a0: 64 61 74 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 29 dat *runremote*)
11b0: 29 20 20 20 20 20 20 20 20 20 3b 3b 20 6f 6e 20 ) ;; on
11c0: 68 6f 6d 65 68 6f 73 74 0a 20 20 20 20 20 20 20 homehost.
11d0: 20 20 20 20 28 6e 6f 74 20 28 6d 65 6d 62 65 72 (not (member
11e0: 20 63 6d 64 20 61 70 69 3a 72 65 61 64 2d 6f 6e cmd api:read-on
11f0: 6c 79 2d 71 75 65 72 69 65 73 29 29 20 20 3b 3b ly-queries)) ;;
1200: 20 74 68 69 73 20 69 73 20 61 20 77 72 69 74 65 this is a write
1210: 0a 20 20 20 20 20 20 20 20 20 20 20 28 72 65 6d . (rem
1220: 6f 74 65 2d 73 65 72 76 65 72 2d 75 72 6c 20 2a ote-server-url *
1230: 72 75 6e 72 65 6d 6f 74 65 2a 29 29 20 20 20 20 runremote*))
1240: 20 20 20 20 20 20 3b 3b 20 68 61 76 65 20 61 20 ;; have a
1250: 73 65 72 76 65 72 0a 20 20 20 20 20 20 28 6d 75 server. (mu
1260: 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 72 6d 74 tex-unlock! *rmt
1270: 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 20 20 28 -mutex*). (
1280: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
1290: 20 31 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 12 *default-log
12a0: 2d 70 6f 72 74 2a 20 22 72 6d 74 3a 73 65 6e 64 -port* "rmt:send
12b0: 2d 72 65 63 65 69 76 65 2c 20 63 61 73 65 20 20 -receive, case
12c0: 34 22 29 0a 20 20 20 20 20 20 28 72 6d 74 3a 6f 4"). (rmt:o
12d0: 70 65 6e 2d 71 72 79 2d 63 6c 6f 73 65 2d 6c 6f pen-qry-close-lo
12e0: 63 61 6c 6c 79 20 63 6d 64 20 30 20 70 61 72 61 cally cmd 0 para
12f0: 6d 73 29 29 0a 20 20 20 20 20 3b 3b 20 6f 6e 20 ms)). ;; on
1300: 68 6f 6d 65 68 6f 73 74 20 61 6e 64 20 74 68 69 homehost and thi
1310: 73 20 69 73 20 61 20 77 72 69 74 65 2c 20 77 65 s is a write, we
1320: 20 68 61 76 65 20 61 20 73 65 72 76 65 72 20 28 have a server (
1330: 77 65 20 6b 6e 6f 77 20 62 65 63 61 75 73 65 20 we know because
1340: 63 61 73 65 20 34 20 63 68 65 63 6b 65 64 29 0a case 4 checked).
1350: 20 20 20 20 20 28 28 61 6e 64 20 28 63 64 72 20 ((and (cdr
1360: 28 72 65 6d 6f 74 65 2d 68 68 2d 64 61 74 20 2a (remote-hh-dat *
1370: 72 75 6e 72 65 6d 6f 74 65 2a 29 29 20 20 20 20 runremote*))
1380: 20 20 20 20 20 3b 3b 20 6f 6e 20 68 6f 6d 65 68 ;; on homeh
1390: 6f 73 74 0a 09 20 20 20 28 6e 6f 74 20 28 6d 65 ost.. (not (me
13a0: 6d 62 65 72 20 63 6d 64 20 61 70 69 3a 72 65 61 mber cmd api:rea
13b0: 64 2d 6f 6e 6c 79 2d 71 75 65 72 69 65 73 29 29 d-only-queries))
13c0: 29 0a 20 20 20 20 20 20 28 6d 75 74 65 78 2d 75 ). (mutex-u
13d0: 6e 6c 6f 63 6b 21 20 2a 72 6d 74 2d 6d 75 74 65 nlock! *rmt-mute
13e0: 78 2a 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 x*). (debug
13f0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 32 20 2a :print-info 12 *
1400: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
1410: 2a 20 22 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 * "rmt:send-rece
1420: 69 76 65 2c 20 63 61 73 65 20 20 34 2e 31 22 29 ive, case 4.1")
1430: 0a 20 20 20 20 20 20 28 72 6d 74 3a 6f 70 65 6e . (rmt:open
1440: 2d 71 72 79 2d 63 6c 6f 73 65 2d 6c 6f 63 61 6c -qry-close-local
1450: 6c 79 20 63 6d 64 20 30 20 70 61 72 61 6d 73 29 ly cmd 0 params)
1460: 29 0a 20 20 20 20 20 3b 3b 20 6e 6f 20 73 65 72 ). ;; no ser
1470: 76 65 72 20 63 6f 6e 74 61 63 74 20 6d 61 64 65 ver contact made
1480: 20 61 6e 64 20 74 68 69 73 20 69 73 20 61 20 77 and this is a w
1490: 72 69 74 65 2c 20 70 61 73 73 69 76 65 6c 79 20 rite, passively
14a0: 73 74 61 72 74 20 61 20 73 65 72 76 65 72 20 0a start a server .
14b0: 20 20 20 20 20 28 28 61 6e 64 20 28 6e 6f 74 20 ((and (not
14c0: 28 72 65 6d 6f 74 65 2d 73 65 72 76 65 72 2d 75 (remote-server-u
14d0: 72 6c 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 29 29 rl *runremote*))
14e0: 0a 09 20 20 20 28 6e 6f 74 20 28 6d 65 6d 62 65 .. (not (membe
14f0: 72 20 63 6d 64 20 61 70 69 3a 72 65 61 64 2d 6f r cmd api:read-o
1500: 6e 6c 79 2d 71 75 65 72 69 65 73 29 29 29 0a 20 nly-queries))).
1510: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
1520: 74 2d 69 6e 66 6f 20 31 32 20 2a 64 65 66 61 75 t-info 12 *defau
1530: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 6d lt-log-port* "rm
1540: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 2c 20 t:send-receive,
1550: 63 61 73 65 20 20 35 22 29 0a 20 20 20 20 20 20 case 5").
1560: 28 6c 65 74 20 28 28 73 65 72 76 65 72 63 6f 6e (let ((servercon
1570: 6e 20 28 73 65 72 76 65 72 3a 72 65 61 64 2d 64 n (server:read-d
1580: 6f 74 73 65 72 76 65 72 20 2a 74 6f 70 70 61 74 otserver *toppat
1590: 68 2a 29 29 29 20 3b 3b 20 28 73 65 72 76 65 72 h*))) ;; (server
15a0: 3a 63 68 65 63 6b 2d 69 66 2d 72 75 6e 6e 69 6e :check-if-runnin
15b0: 67 20 2a 74 6f 70 70 61 74 68 2a 29 29 29 20 3b g *toppath*))) ;
15c0: 3b 20 44 6f 20 4e 4f 54 20 77 61 6e 74 20 74 6f ; Do NOT want to
15d0: 20 72 75 6e 20 73 65 72 76 65 72 3a 63 68 65 63 run server:chec
15e0: 6b 2d 69 66 2d 72 75 6e 6e 69 6e 67 20 2d 20 76 k-if-running - v
15f0: 65 72 79 20 65 78 70 65 6e 73 69 76 65 20 74 6f ery expensive to
1600: 20 64 6f 20 66 6f 72 20 65 76 65 72 79 20 77 72 do for every wr
1610: 69 74 65 20 63 61 6c 6c 0a 09 28 69 66 20 73 65 ite call..(if se
1620: 72 76 65 72 63 6f 6e 6e 0a 09 20 20 20 20 28 72 rverconn.. (r
1630: 65 6d 6f 74 65 2d 73 65 72 76 65 72 2d 75 72 6c emote-server-url
1640: 2d 73 65 74 21 20 2a 72 75 6e 72 65 6d 6f 74 65 -set! *runremote
1650: 2a 20 73 65 72 76 65 72 63 6f 6e 6e 29 20 3b 3b * serverconn) ;;
1660: 20 74 68 65 20 73 74 72 69 6e 67 20 63 61 6e 20 the string can
1670: 62 65 20 63 6f 6e 73 75 6d 65 64 20 62 79 20 74 be consumed by t
1680: 68 65 20 63 6c 69 65 6e 74 20 73 65 74 75 70 20 he client setup
1690: 69 66 20 6e 65 65 64 65 64 0a 09 20 20 20 20 28 if needed.. (
16a0: 69 66 20 28 6e 6f 74 20 28 73 65 72 76 65 72 3a if (not (server:
16b0: 73 74 61 72 74 2d 61 74 74 65 6d 70 74 65 64 3f start-attempted?
16c0: 20 2a 74 6f 70 70 61 74 68 2a 29 29 0a 09 09 28 *toppath*))...(
16d0: 73 65 72 76 65 72 3a 6b 69 6e 64 2d 72 75 6e 20 server:kind-run
16e0: 2a 74 6f 70 70 61 74 68 2a 29 29 29 29 0a 20 20 *toppath*)))).
16f0: 20 20 20 20 28 69 66 20 28 63 64 72 20 28 72 65 (if (cdr (re
1700: 6d 6f 74 65 2d 68 68 2d 64 61 74 20 2a 72 75 6e mote-hh-dat *run
1710: 72 65 6d 6f 74 65 2a 29 29 20 3b 3b 20 77 65 20 remote*)) ;; we
1720: 61 72 65 20 6f 6e 20 74 68 65 20 68 6f 6d 65 68 are on the homeh
1730: 6f 73 74 2c 20 6a 75 73 74 20 64 6f 20 74 68 65 ost, just do the
1740: 20 63 61 6c 6c 0a 20 20 20 20 20 20 20 20 20 20 call.
1750: 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 (begin.
1760: 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b (mutex-unlock
1770: 21 20 2a 72 6d 74 2d 6d 75 74 65 78 2a 29 0a 09 ! *rmt-mutex*)..
1780: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
1790: 2d 69 6e 66 6f 20 31 32 20 2a 64 65 66 61 75 6c -info 12 *defaul
17a0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 6d 74 t-log-port* "rmt
17b0: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 2c 20 63 :send-receive, c
17c0: 61 73 65 20 20 35 2e 31 22 29 0a 20 20 20 20 20 ase 5.1").
17d0: 20 20 20 20 20 20 20 28 72 6d 74 3a 6f 70 65 6e (rmt:open
17e0: 2d 71 72 79 2d 63 6c 6f 73 65 2d 6c 6f 63 61 6c -qry-close-local
17f0: 6c 79 20 63 6d 64 20 30 20 70 61 72 61 6d 73 29 ly cmd 0 params)
1800: 29 0a 20 20 20 20 20 20 20 20 20 20 28 62 65 67 ). (beg
1810: 69 6e 20 20 20 20 20 20 20 20 20 20 20 20 20 20 in
1820: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b ;;
1830: 20 6e 6f 74 20 6f 6e 20 68 6f 6d 65 68 6f 73 74 not on homehost
1840: 2c 20 73 74 61 72 74 20 73 65 72 76 65 72 20 61 , start server a
1850: 6e 64 20 77 61 69 74 0a 20 20 20 20 20 20 20 20 nd wait.
1860: 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 (mutex-unloc
1870: 6b 21 20 2a 72 6d 74 2d 6d 75 74 65 78 2a 29 0a k! *rmt-mutex*).
1880: 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
1890: 74 2d 69 6e 66 6f 20 31 32 20 2a 64 65 66 61 75 t-info 12 *defau
18a0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 6d lt-log-port* "rm
18b0: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 2c 20 t:send-receive,
18c0: 63 61 73 65 20 20 35 2e 32 22 29 0a 09 20 20 20 case 5.2")..
18d0: 20 28 74 61 73 6b 73 3a 73 74 61 72 74 2d 61 6e (tasks:start-an
18e0: 64 2d 77 61 69 74 2d 66 6f 72 2d 73 65 72 76 65 d-wait-for-serve
18f0: 72 20 28 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 r (tasks:open-db
1900: 29 20 30 20 31 35 29 0a 20 20 20 20 20 20 20 20 ) 0 15).
1910: 20 20 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 (rmt:send-re
1920: 63 65 69 76 65 20 63 6d 64 20 72 69 64 20 70 61 ceive cmd rid pa
1930: 72 61 6d 73 20 61 74 74 65 6d 70 74 6e 75 6d 3a rams attemptnum:
1940: 20 61 74 74 65 6d 70 74 6e 75 6d 29 29 29 29 0a attemptnum)))).
1950: 20 20 20 20 20 3b 3b 20 69 66 20 6e 6f 74 20 6f ;; if not o
1960: 6e 20 68 6f 6d 65 68 6f 73 74 20 65 6e 73 75 72 n homehost ensur
1970: 65 20 77 65 20 68 61 76 65 20 61 20 63 6f 6e 6e e we have a conn
1980: 65 63 74 69 6f 6e 20 74 6f 20 61 20 6c 69 76 65 ection to a live
1990: 20 73 65 72 76 65 72 0a 20 20 20 20 20 3b 3b 20 server. ;;
19a0: 4e 4f 54 45 3a 20 77 65 20 2a 68 61 76 65 2a 20 NOTE: we *have*
19b0: 61 20 68 6f 6d 65 68 6f 73 74 20 72 65 63 6f 72 a homehost recor
19c0: 64 20 62 79 20 6e 6f 77 0a 20 20 20 20 20 28 28 d by now. ((
19d0: 61 6e 64 20 28 6e 6f 74 20 28 63 64 72 20 28 72 and (not (cdr (r
19e0: 65 6d 6f 74 65 2d 68 68 2d 64 61 74 20 2a 72 75 emote-hh-dat *ru
19f0: 6e 72 65 6d 6f 74 65 2a 29 29 29 20 20 20 20 20 nremote*)))
1a00: 20 20 20 3b 3b 20 61 72 65 20 77 65 20 6f 6e 20 ;; are we on
1a10: 61 20 68 6f 6d 65 68 6f 73 74 3f 0a 20 20 20 20 a homehost?.
1a20: 20 20 20 20 20 20 20 28 6e 6f 74 20 28 72 65 6d (not (rem
1a30: 6f 74 65 2d 63 6f 6e 6e 64 61 74 20 2a 72 75 6e ote-conndat *run
1a40: 72 65 6d 6f 74 65 2a 29 29 29 20 20 20 20 20 20 remote*)))
1a50: 20 20 20 20 20 20 3b 3b 20 61 6e 64 20 6e 6f 20 ;; and no
1a60: 63 6f 6e 6e 65 63 74 69 6f 6e 0a 20 20 20 20 20 connection.
1a70: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
1a80: 66 6f 20 31 32 20 2a 64 65 66 61 75 6c 74 2d 6c fo 12 *default-l
1a90: 6f 67 2d 70 6f 72 74 2a 20 22 72 6d 74 3a 73 65 og-port* "rmt:se
1aa0: 6e 64 2d 72 65 63 65 69 76 65 2c 20 63 61 73 65 nd-receive, case
1ab0: 20 20 36 20 20 68 68 2d 64 61 74 3a 20 22 20 28 6 hh-dat: " (
1ac0: 72 65 6d 6f 74 65 2d 68 68 2d 64 61 74 20 2a 72 remote-hh-dat *r
1ad0: 75 6e 72 65 6d 6f 74 65 2a 29 20 22 20 63 6f 6e unremote*) " con
1ae0: 6e 64 61 74 3a 20 22 20 28 72 65 6d 6f 74 65 2d ndat: " (remote-
1af0: 63 6f 6e 6e 64 61 74 20 2a 72 75 6e 72 65 6d 6f conndat *runremo
1b00: 74 65 2a 29 29 0a 20 20 20 20 20 20 28 6d 75 74 te*)). (mut
1b10: 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 72 6d 74 2d ex-unlock! *rmt-
1b20: 6d 75 74 65 78 2a 29 0a 20 20 20 20 20 20 28 74 mutex*). (t
1b30: 61 73 6b 73 3a 73 74 61 72 74 2d 61 6e 64 2d 77 asks:start-and-w
1b40: 61 69 74 2d 66 6f 72 2d 73 65 72 76 65 72 20 28 ait-for-server (
1b50: 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 29 20 30 tasks:open-db) 0
1b60: 20 31 35 29 0a 20 20 20 20 20 20 28 72 65 6d 6f 15). (remo
1b70: 74 65 2d 63 6f 6e 6e 64 61 74 2d 73 65 74 21 20 te-conndat-set!
1b80: 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 28 72 6d 74 *runremote* (rmt
1b90: 3a 67 65 74 2d 63 6f 6e 6e 65 63 74 69 6f 6e 2d :get-connection-
1ba0: 69 6e 66 6f 20 30 29 29 20 3b 3b 20 63 61 6c 6c info 0)) ;; call
1bb0: 73 20 63 6c 69 65 6e 74 3a 73 65 74 75 70 20 77 s client:setup w
1bc0: 68 69 63 68 20 63 61 6c 6c 73 20 63 6c 69 65 6e hich calls clien
1bd0: 74 3a 73 65 74 75 70 2d 68 74 74 70 0a 20 20 20 t:setup-http.
1be0: 20 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 (rmt:send-rec
1bf0: 65 69 76 65 20 63 6d 64 20 72 69 64 20 70 61 72 eive cmd rid par
1c00: 61 6d 73 20 61 74 74 65 6d 70 74 6e 75 6d 3a 20 ams attemptnum:
1c10: 61 74 74 65 6d 70 74 6e 75 6d 29 29 0a 20 20 20 attemptnum)).
1c20: 20 20 3b 3b 20 61 6c 6c 20 73 65 74 20 75 70 20 ;; all set up
1c30: 69 66 20 67 65 74 20 74 68 69 73 20 66 61 72 2c if get this far,
1c40: 20 64 69 73 70 61 74 63 68 20 74 68 65 20 71 75 dispatch the qu
1c50: 65 72 79 0a 20 20 20 20 20 28 28 63 64 72 20 28 ery. ((cdr (
1c60: 72 65 6d 6f 74 65 2d 68 68 2d 64 61 74 20 2a 72 remote-hh-dat *r
1c70: 75 6e 72 65 6d 6f 74 65 2a 29 29 20 3b 3b 20 77 unremote*)) ;; w
1c80: 65 20 61 72 65 20 6f 6e 20 68 6f 6d 65 68 6f 73 e are on homehos
1c90: 74 0a 20 20 20 20 20 20 28 6d 75 74 65 78 2d 75 t. (mutex-u
1ca0: 6e 6c 6f 63 6b 21 20 2a 72 6d 74 2d 6d 75 74 65 nlock! *rmt-mute
1cb0: 78 2a 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 x*). (debug
1cc0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 32 20 2a :print-info 12 *
1cd0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
1ce0: 2a 20 22 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 * "rmt:send-rece
1cf0: 69 76 65 2c 20 63 61 73 65 20 20 37 22 29 0a 20 ive, case 7").
1d00: 20 20 20 20 20 28 72 6d 74 3a 6f 70 65 6e 2d 71 (rmt:open-q
1d10: 72 79 2d 63 6c 6f 73 65 2d 6c 6f 63 61 6c 6c 79 ry-close-locally
1d20: 20 63 6d 64 20 28 69 66 20 72 69 64 20 72 69 64 cmd (if rid rid
1d30: 20 30 29 20 70 61 72 61 6d 73 29 29 0a 20 20 20 0) params)).
1d40: 20 20 3b 3b 20 6e 6f 74 20 6f 6e 20 68 6f 6d 65 ;; not on home
1d50: 68 6f 73 74 2c 20 64 6f 20 73 65 72 76 65 72 20 host, do server
1d60: 71 75 65 72 79 0a 20 20 20 20 20 28 65 6c 73 65 query. (else
1d70: 0a 20 20 20 20 20 20 28 6d 75 74 65 78 2d 75 6e . (mutex-un
1d80: 6c 6f 63 6b 21 20 2a 72 6d 74 2d 6d 75 74 65 78 lock! *rmt-mutex
1d90: 2a 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a *). (debug:
1da0: 70 72 69 6e 74 2d 69 6e 66 6f 20 31 32 20 2a 64 print-info 12 *d
1db0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
1dc0: 20 22 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 "rmt:send-recei
1dd0: 76 65 2c 20 63 61 73 65 20 20 39 22 29 0a 20 20 ve, case 9").
1de0: 20 20 20 20 28 6c 65 74 2a 20 28 28 63 6f 6e 6e (let* ((conn
1df0: 69 6e 66 6f 20 28 72 65 6d 6f 74 65 2d 63 6f 6e info (remote-con
1e00: 6e 64 61 74 20 2a 72 75 6e 72 65 6d 6f 74 65 2a ndat *runremote*
1e10: 29 29 0a 09 20 20 20 20 20 28 64 61 74 20 20 20 )).. (dat
1e20: 20 20 20 28 63 61 73 65 20 28 72 65 6d 6f 74 65 (case (remote
1e30: 2d 74 72 61 6e 73 70 6f 72 74 20 2a 72 75 6e 72 -transport *runr
1e40: 65 6d 6f 74 65 2a 29 0a 09 09 09 20 28 28 68 74 emote*).... ((ht
1e50: 74 70 29 20 28 63 6f 6e 64 69 74 69 6f 6e 2d 63 tp) (condition-c
1e60: 61 73 65 20 3b 3b 20 68 61 6e 64 6c 69 6e 67 20 ase ;; handling
1e70: 68 65 72 65 20 68 61 73 20 63 61 75 73 65 64 20 here has caused
1e80: 61 20 6c 6f 74 20 6f 66 20 70 72 6f 62 6c 65 6d a lot of problem
1e90: 73 2e 20 48 6f 77 65 76 65 72 20 69 74 20 69 73 s. However it is
1ea0: 20 6e 65 65 64 65 64 20 74 6f 20 64 65 61 6c 20 needed to deal
1eb0: 77 69 74 68 20 61 74 74 65 6d 74 70 65 64 20 63 with attemtped c
1ec0: 6f 6d 6d 75 6e 69 63 61 74 69 6f 6e 20 74 6f 20 ommunication to
1ed0: 73 65 72 76 65 72 73 20 74 68 61 74 20 68 61 76 servers that hav
1ee0: 65 20 67 6f 6e 65 20 61 77 61 79 0a 20 20 20 20 e gone away.
1ef0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1f00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 68 (h
1f10: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c ttp-transport:cl
1f20: 69 65 6e 74 2d 61 70 69 2d 73 65 6e 64 2d 72 65 ient-api-send-re
1f30: 63 65 69 76 65 20 30 20 63 6f 6e 6e 69 6e 66 6f ceive 0 conninfo
1f40: 20 63 6d 64 20 70 61 72 61 6d 73 29 0a 20 20 20 cmd params).
1f50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1f60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
1f70: 28 63 6f 6d 6d 66 61 69 6c 29 28 76 65 63 74 6f (commfail)(vecto
1f80: 72 20 23 66 20 22 63 6f 6d 6d 75 6e 69 63 61 74 r #f "communicat
1f90: 69 6f 6e 73 20 66 61 69 6c 22 29 29 0a 20 20 20 ions fail")).
1fa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1fb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
1fc0: 28 65 78 6e 29 28 76 65 63 74 6f 72 20 23 66 20 (exn)(vector #f
1fd0: 22 6f 74 68 65 72 20 66 61 69 6c 22 20 28 70 72 "other fail" (pr
1fe0: 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 29 29 int-call-chain))
1ff0: 29 29 29 0a 09 09 09 20 28 65 6c 73 65 0a 09 09 ))).... (else...
2000: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 . (debug:print
2010: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
2020: 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 74 72 61 ort* "ERROR: tra
2030: 6e 73 70 6f 72 74 20 22 20 28 72 65 6d 6f 74 65 nsport " (remote
2040: 2d 74 72 61 6e 73 70 6f 72 74 20 2a 72 75 6e 72 -transport *runr
2050: 65 6d 6f 74 65 2a 29 20 22 20 6e 6f 74 20 73 75 emote*) " not su
2060: 70 70 6f 72 74 65 64 22 29 0a 09 09 09 20 20 28 pported").... (
2070: 65 78 69 74 29 29 29 29 0a 09 20 20 20 20 20 28 exit)))).. (
2080: 73 75 63 63 65 73 73 20 20 28 69 66 20 28 76 65 success (if (ve
2090: 63 74 6f 72 3f 20 64 61 74 29 20 28 76 65 63 74 ctor? dat) (vect
20a0: 6f 72 2d 72 65 66 20 64 61 74 20 30 29 20 23 66 or-ref dat 0) #f
20b0: 29 29 0a 09 20 20 20 20 20 28 72 65 73 20 20 20 )).. (res
20c0: 20 20 20 28 69 66 20 28 76 65 63 74 6f 72 3f 20 (if (vector?
20d0: 64 61 74 29 20 28 76 65 63 74 6f 72 2d 72 65 66 dat) (vector-ref
20e0: 20 64 61 74 20 31 29 20 23 66 29 29 29 0a 09 28 dat 1) #f)))..(
20f0: 69 66 20 28 76 65 63 74 6f 72 3f 20 63 6f 6e 6e if (vector? conn
2100: 69 6e 66 6f 29 28 68 74 74 70 2d 74 72 61 6e 73 info)(http-trans
2110: 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 74 2d port:server-dat-
2120: 75 70 64 61 74 65 2d 6c 61 73 74 2d 61 63 63 65 update-last-acce
2130: 73 73 20 63 6f 6e 6e 69 6e 66 6f 29 29 20 3b 3b ss conninfo)) ;;
2140: 20 72 65 66 72 65 73 68 20 61 63 63 65 73 73 20 refresh access
2150: 74 69 6d 65 0a 20 20 20 20 20 20 20 20 28 64 65 time. (de
2160: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 bug:print-info 1
2170: 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 2 *default-log-p
2180: 6f 72 74 2a 20 22 72 6d 74 3a 73 65 6e 64 2d 72 ort* "rmt:send-r
2190: 65 63 65 69 76 65 2c 20 63 61 73 65 20 20 39 2e eceive, case 9.
21a0: 20 63 6f 6e 6e 69 6e 66 6f 3d 22 20 63 6f 6e 6e conninfo=" conn
21b0: 69 6e 66 6f 20 22 20 64 61 74 3d 22 20 64 61 74 info " dat=" dat
21c0: 29 0a 09 28 69 66 20 73 75 63 63 65 73 73 0a 09 )..(if success..
21d0: 20 20 20 20 28 63 61 73 65 20 28 72 65 6d 6f 74 (case (remot
21e0: 65 2d 74 72 61 6e 73 70 6f 72 74 20 2a 72 75 6e e-transport *run
21f0: 72 65 6d 6f 74 65 2a 29 0a 09 20 20 20 20 20 20 remote*)..
2200: 28 28 68 74 74 70 29 20 72 65 73 29 0a 09 20 20 ((http) res)..
2210: 20 20 20 20 28 65 6c 73 65 0a 09 20 20 20 20 20 (else..
2220: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
2230: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
2240: 72 74 2a 20 22 45 52 52 4f 52 3a 20 74 72 61 6e rt* "ERROR: tran
2250: 73 70 6f 72 74 20 22 20 28 72 65 6d 6f 74 65 2d sport " (remote-
2260: 74 72 61 6e 73 70 6f 72 74 20 2a 72 75 6e 72 65 transport *runre
2270: 6d 6f 74 65 2a 29 20 22 20 69 73 20 75 6e 6b 6e mote*) " is unkn
2280: 6f 77 6e 22 29 0a 09 20 20 20 20 20 20 20 28 65 own").. (e
2290: 78 69 74 20 31 29 29 29 0a 09 20 20 20 20 28 62 xit 1))).. (b
22a0: 65 67 69 6e 0a 09 20 20 20 20 20 20 28 64 65 62 egin.. (deb
22b0: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
22c0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 ult-log-port* "W
22d0: 41 52 4e 49 4e 47 3a 20 63 6f 6d 6d 75 6e 69 63 ARNING: communic
22e0: 61 74 69 6f 6e 20 66 61 69 6c 65 64 2e 20 54 72 ation failed. Tr
22f0: 79 69 6e 67 20 61 67 61 69 6e 2c 20 74 72 79 20 ying again, try
2300: 6e 75 6d 3a 20 22 20 61 74 74 65 6d 70 74 6e 75 num: " attemptnu
2310: 6d 29 0a 09 20 20 20 20 20 20 28 72 65 6d 6f 74 m).. (remot
2320: 65 2d 63 6f 6e 6e 64 61 74 2d 73 65 74 21 20 20 e-conndat-set!
2330: 20 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 23 66 *runremote* #f
2340: 29 0a 09 20 20 20 20 20 20 28 72 65 6d 6f 74 65 ).. (remote
2350: 2d 73 65 72 76 65 72 2d 75 72 6c 2d 73 65 74 21 -server-url-set!
2360: 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 23 66 29 *runremote* #f)
2370: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
2380: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
2390: 20 31 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 12 *default-log
23a0: 2d 70 6f 72 74 2a 20 22 72 6d 74 3a 73 65 6e 64 -port* "rmt:send
23b0: 2d 72 65 63 65 69 76 65 2c 20 63 61 73 65 20 20 -receive, case
23c0: 39 2e 31 22 29 0a 09 20 20 20 20 20 20 28 74 61 9.1").. (ta
23d0: 73 6b 73 3a 73 74 61 72 74 2d 61 6e 64 2d 77 61 sks:start-and-wa
23e0: 69 74 2d 66 6f 72 2d 73 65 72 76 65 72 20 28 74 it-for-server (t
23f0: 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 29 20 30 20 asks:open-db) 0
2400: 31 35 29 0a 09 20 20 20 20 20 20 28 72 6d 74 3a 15).. (rmt:
2410: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 63 6d 64 send-receive cmd
2420: 20 72 69 64 20 70 61 72 61 6d 73 20 61 74 74 65 rid params atte
2430: 6d 70 74 6e 75 6d 3a 20 28 2b 20 61 74 74 65 6d mptnum: (+ attem
2440: 70 74 6e 75 6d 20 31 29 29 29 29 29 29 29 29 29 ptnum 1)))))))))
2450: 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 75 ..(define (rmt:u
2460: 70 64 61 74 65 2d 64 62 2d 73 74 61 74 73 20 72 pdate-db-stats r
2470: 75 6e 2d 69 64 20 72 61 77 63 6d 64 20 70 61 72 un-id rawcmd par
2480: 61 6d 73 20 64 75 72 61 74 69 6f 6e 29 0a 20 20 ams duration).
2490: 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 64 62 (mutex-lock! *db
24a0: 2d 73 74 61 74 73 2d 6d 75 74 65 78 2a 29 0a 20 -stats-mutex*).
24b0: 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 (handle-excepti
24c0: 6f 6e 73 0a 20 20 20 65 78 6e 0a 20 20 20 28 62 ons. exn. (b
24d0: 65 67 69 6e 0a 20 20 20 20 20 28 64 65 62 75 67 egin. (debug
24e0: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
24f0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 t-log-port* "WAR
2500: 4e 49 4e 47 3a 20 73 74 61 74 73 20 63 6f 6c 6c NING: stats coll
2510: 65 63 74 69 6f 6e 20 66 61 69 6c 65 64 20 69 6e ection failed in
2520: 20 75 70 64 61 74 65 2d 64 62 2d 73 74 61 74 73 update-db-stats
2530: 22 29 0a 20 20 20 20 20 28 64 65 62 75 67 3a 70 "). (debug:p
2540: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
2550: 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 6d 65 73 73 log-port* " mess
2560: 61 67 65 3a 20 22 20 28 28 63 6f 6e 64 69 74 69 age: " ((conditi
2570: 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 on-property-acce
2580: 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 ssor 'exn 'messa
2590: 67 65 29 20 65 78 6e 29 29 0a 20 20 20 20 20 28 ge) exn)). (
25a0: 70 72 69 6e 74 20 22 65 78 6e 3d 22 20 28 63 6f print "exn=" (co
25b0: 6e 64 69 74 69 6f 6e 2d 3e 6c 69 73 74 20 65 78 ndition->list ex
25c0: 6e 29 29 0a 20 20 20 20 20 23 66 29 20 3b 3b 20 n)). #f) ;;
25d0: 69 66 20 74 68 69 73 20 66 61 69 6c 73 20 77 65 if this fails we
25e0: 20 64 6f 6e 27 74 20 63 61 72 65 2c 20 69 74 20 don't care, it
25f0: 69 73 20 6a 75 73 74 20 73 74 61 74 73 0a 20 20 is just stats.
2600: 20 28 6c 65 74 2a 20 28 28 63 6d 64 20 20 20 20 (let* ((cmd
2610: 20 20 28 63 6f 6e 63 20 22 72 75 6e 2d 69 64 3d (conc "run-id=
2620: 22 20 72 75 6e 2d 69 64 20 22 20 22 20 28 69 66 " run-id " " (if
2630: 20 28 65 71 3f 20 72 61 77 63 6d 64 20 27 67 65 (eq? rawcmd 'ge
2640: 6e 65 72 61 6c 2d 63 61 6c 6c 29 20 28 63 61 72 neral-call) (car
2650: 20 70 61 72 61 6d 73 29 20 72 61 77 63 6d 64 29 params) rawcmd)
2660: 29 29 0a 09 20 20 28 73 74 61 74 2d 76 65 63 20 )).. (stat-vec
2670: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
2680: 64 65 66 61 75 6c 74 20 2a 64 62 2d 73 74 61 74 default *db-stat
2690: 73 2a 20 63 6d 64 20 23 66 29 29 29 0a 20 20 20 s* cmd #f))).
26a0: 20 20 28 69 66 20 28 6e 6f 74 20 28 76 65 63 74 (if (not (vect
26b0: 6f 72 3f 20 73 74 61 74 2d 76 65 63 29 29 0a 09 or? stat-vec))..
26c0: 20 28 6c 65 74 20 28 28 6e 65 77 76 65 63 20 28 (let ((newvec (
26d0: 76 65 63 74 6f 72 20 30 20 30 29 29 29 0a 09 20 vector 0 0)))..
26e0: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
26f0: 74 21 20 2a 64 62 2d 73 74 61 74 73 2a 20 63 6d t! *db-stats* cm
2700: 64 20 6e 65 77 76 65 63 29 0a 09 20 20 20 28 73 d newvec).. (s
2710: 65 74 21 20 73 74 61 74 2d 76 65 63 20 6e 65 77 et! stat-vec new
2720: 76 65 63 29 29 29 0a 20 20 20 20 20 28 76 65 63 vec))). (vec
2730: 74 6f 72 2d 73 65 74 21 20 73 74 61 74 2d 76 65 tor-set! stat-ve
2740: 63 20 30 20 28 2b 20 28 76 65 63 74 6f 72 2d 72 c 0 (+ (vector-r
2750: 65 66 20 73 74 61 74 2d 76 65 63 20 30 29 20 31 ef stat-vec 0) 1
2760: 29 29 0a 20 20 20 20 20 28 76 65 63 74 6f 72 2d )). (vector-
2770: 73 65 74 21 20 73 74 61 74 2d 76 65 63 20 31 20 set! stat-vec 1
2780: 28 2b 20 28 76 65 63 74 6f 72 2d 72 65 66 20 73 (+ (vector-ref s
2790: 74 61 74 2d 76 65 63 20 31 29 20 64 75 72 61 74 tat-vec 1) durat
27a0: 69 6f 6e 29 29 29 29 0a 20 20 28 6d 75 74 65 78 ion)))). (mutex
27b0: 2d 75 6e 6c 6f 63 6b 21 20 2a 64 62 2d 73 74 61 -unlock! *db-sta
27c0: 74 73 2d 6d 75 74 65 78 2a 29 29 0a 0a 0a 28 64 ts-mutex*))...(d
27d0: 65 66 69 6e 65 20 28 72 6d 74 3a 70 72 69 6e 74 efine (rmt:print
27e0: 2d 64 62 2d 73 74 61 74 73 29 0a 20 20 28 6c 65 -db-stats). (le
27f0: 74 20 28 28 66 6d 74 73 74 72 20 22 7e 34 30 61 t ((fmtstr "~40a
2800: 7e 37 2d 64 7e 39 2d 64 7e 32 30 2c 32 2d 66 22 ~7-d~9-d~20,2-f"
2810: 29 29 20 3b 3b 20 22 7e 32 30 2c 32 2d 66 22 0a )) ;; "~20,2-f".
2820: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
2830: 20 31 38 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 18 *default-log
2840: 2d 70 6f 72 74 2a 20 22 44 42 20 53 74 61 74 73 -port* "DB Stats
2850: 5c 6e 3d 3d 3d 3d 3d 3d 3d 3d 22 29 0a 20 20 20 \n========").
2860: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 38 (debug:print 18
2870: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
2880: 72 74 2a 20 28 66 6f 72 6d 61 74 20 23 66 20 22 rt* (format #f "
2890: 7e 34 30 61 7e 38 61 7e 31 30 61 7e 31 30 61 22 ~40a~8a~10a~10a"
28a0: 20 22 43 6d 64 22 20 22 43 6f 75 6e 74 22 20 22 "Cmd" "Count" "
28b0: 54 6f 74 54 69 6d 65 22 20 22 41 76 67 22 29 29 TotTime" "Avg"))
28c0: 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 . (for-each (
28d0: 6c 61 6d 62 64 61 20 28 63 6d 64 29 0a 09 09 28 lambda (cmd)...(
28e0: 6c 65 74 20 28 28 63 6d 64 2d 64 61 74 20 28 68 let ((cmd-dat (h
28f0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 2a 64 ash-table-ref *d
2900: 62 2d 73 74 61 74 73 2a 20 63 6d 64 29 29 29 0a b-stats* cmd))).
2910: 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
2920: 20 31 38 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 18 *default-log
2930: 2d 70 6f 72 74 2a 20 28 66 6f 72 6d 61 74 20 23 -port* (format #
2940: 66 20 66 6d 74 73 74 72 20 63 6d 64 20 28 76 65 f fmtstr cmd (ve
2950: 63 74 6f 72 2d 72 65 66 20 63 6d 64 2d 64 61 74 ctor-ref cmd-dat
2960: 20 30 29 20 28 76 65 63 74 6f 72 2d 72 65 66 20 0) (vector-ref
2970: 63 6d 64 2d 64 61 74 20 31 29 20 28 2f 20 28 76 cmd-dat 1) (/ (v
2980: 65 63 74 6f 72 2d 72 65 66 20 63 6d 64 2d 64 61 ector-ref cmd-da
2990: 74 20 31 29 28 76 65 63 74 6f 72 2d 72 65 66 20 t 1)(vector-ref
29a0: 63 6d 64 2d 64 61 74 20 30 29 29 29 29 29 29 0a cmd-dat 0)))))).
29b0: 09 20 20 20 20 20 20 28 73 6f 72 74 20 28 68 61 . (sort (ha
29c0: 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 2a 64 sh-table-keys *d
29d0: 62 2d 73 74 61 74 73 2a 29 0a 09 09 20 20 20 20 b-stats*)...
29e0: 28 6c 61 6d 62 64 61 20 28 61 20 62 29 0a 09 09 (lambda (a b)...
29f0: 20 20 20 20 20 20 28 3e 20 28 76 65 63 74 6f 72 (> (vector
2a00: 2d 72 65 66 20 28 68 61 73 68 2d 74 61 62 6c 65 -ref (hash-table
2a10: 2d 72 65 66 20 2a 64 62 2d 73 74 61 74 73 2a 20 -ref *db-stats*
2a20: 61 29 20 30 29 0a 09 09 09 20 28 76 65 63 74 6f a) 0).... (vecto
2a30: 72 2d 72 65 66 20 28 68 61 73 68 2d 74 61 62 6c r-ref (hash-tabl
2a40: 65 2d 72 65 66 20 2a 64 62 2d 73 74 61 74 73 2a e-ref *db-stats*
2a50: 20 62 29 20 30 29 29 29 29 29 29 29 0a 0a 28 64 b) 0)))))))..(d
2a60: 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 6d efine (rmt:get-m
2a70: 61 78 2d 71 75 65 72 79 2d 61 76 65 72 61 67 65 ax-query-average
2a80: 20 72 75 6e 2d 69 64 29 0a 20 20 28 6d 75 74 65 run-id). (mute
2a90: 78 2d 6c 6f 63 6b 21 20 2a 64 62 2d 73 74 61 74 x-lock! *db-stat
2aa0: 73 2d 6d 75 74 65 78 2a 29 0a 20 20 28 6c 65 74 s-mutex*). (let
2ab0: 2a 20 28 28 72 75 6e 6b 65 79 20 28 63 6f 6e 63 * ((runkey (conc
2ac0: 20 22 72 75 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 "run-id=" run-i
2ad0: 64 20 22 20 22 29 29 0a 09 20 28 63 6d 64 73 20 d " ")).. (cmds
2ae0: 20 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 (filter (lambd
2af0: 61 20 28 78 29 0a 09 09 09 20 20 20 28 73 75 62 a (x).... (sub
2b00: 73 74 72 69 6e 67 2d 69 6e 64 65 78 20 72 75 6e string-index run
2b10: 6b 65 79 20 78 29 29 0a 09 09 09 20 28 68 61 73 key x)).... (has
2b20: 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 2a 64 62 h-table-keys *db
2b30: 2d 73 74 61 74 73 2a 29 29 29 0a 09 20 28 72 65 -stats*))).. (re
2b40: 73 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 s (if (null?
2b50: 63 6d 64 73 29 0a 09 09 20 20 20 20 20 28 63 6f cmds)... (co
2b60: 6e 73 20 27 6e 6f 6e 65 20 30 29 0a 09 09 20 20 ns 'none 0)...
2b70: 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 63 (let loop ((c
2b80: 6d 64 20 28 63 61 72 20 63 6d 64 73 29 29 0a 09 md (car cmds))..
2b90: 09 09 09 28 74 61 6c 20 28 63 64 72 20 63 6d 64 ...(tal (cdr cmd
2ba0: 73 29 29 0a 09 09 09 09 28 6d 61 78 2d 63 6d 64 s)).....(max-cmd
2bb0: 20 28 63 61 72 20 63 6d 64 73 29 29 0a 09 09 09 (car cmds))....
2bc0: 09 28 72 65 73 20 30 29 29 0a 09 09 20 20 20 20 .(res 0))...
2bd0: 20 20 20 28 6c 65 74 2a 20 28 28 63 6d 64 2d 64 (let* ((cmd-d
2be0: 61 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 at (hash-table-r
2bf0: 65 66 20 2a 64 62 2d 73 74 61 74 73 2a 20 63 6d ef *db-stats* cm
2c00: 64 29 29 0a 09 09 09 20 20 20 20 20 20 28 74 6f d)).... (to
2c10: 74 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 t (vector-re
2c20: 66 20 63 6d 64 2d 64 61 74 20 30 29 29 0a 09 09 f cmd-dat 0))...
2c30: 09 20 20 20 20 20 20 28 63 75 72 72 61 76 67 20 . (curravg
2c40: 28 2f 20 28 76 65 63 74 6f 72 2d 72 65 66 20 63 (/ (vector-ref c
2c50: 6d 64 2d 64 61 74 20 31 29 20 28 76 65 63 74 6f md-dat 1) (vecto
2c60: 72 2d 72 65 66 20 63 6d 64 2d 64 61 74 20 30 29 r-ref cmd-dat 0)
2c70: 29 29 20 3b 3b 20 63 6f 75 6e 74 20 69 73 20 6e )) ;; count is n
2c80: 65 76 65 72 20 7a 65 72 6f 20 62 79 20 63 6f 6e ever zero by con
2c90: 73 74 72 75 63 74 69 6f 6e 0a 09 09 09 20 20 20 struction....
2ca0: 20 20 20 28 63 75 72 72 6d 61 78 20 28 6d 61 78 (currmax (max
2cb0: 20 72 65 73 20 63 75 72 72 61 76 67 29 29 0a 09 res curravg))..
2cc0: 09 09 20 20 20 20 20 20 28 6e 65 77 6d 61 78 2d .. (newmax-
2cd0: 63 6d 64 20 28 69 66 20 28 3e 20 63 75 72 72 61 cmd (if (> curra
2ce0: 76 67 20 72 65 73 29 20 63 6d 64 20 6d 61 78 2d vg res) cmd max-
2cf0: 63 6d 64 29 29 29 0a 09 09 09 20 28 69 66 20 28 cmd))).... (if (
2d00: 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 09 20 20 null? tal)....
2d10: 20 20 20 28 69 66 20 28 3e 20 74 6f 74 20 31 30 (if (> tot 10
2d20: 29 0a 09 09 09 09 20 28 63 6f 6e 73 20 6e 65 77 )..... (cons new
2d30: 6d 61 78 2d 63 6d 64 20 63 75 72 72 6d 61 78 29 max-cmd currmax)
2d40: 0a 09 09 09 09 20 28 63 6f 6e 73 20 27 6e 6f 6e ..... (cons 'non
2d50: 65 20 30 29 29 0a 09 09 09 20 20 20 20 20 28 6c e 0)).... (l
2d60: 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 oop (car tal)(cd
2d70: 72 20 74 61 6c 29 20 6e 65 77 6d 61 78 2d 63 6d r tal) newmax-cm
2d80: 64 20 63 75 72 72 6d 61 78 29 29 29 29 29 29 29 d currmax)))))))
2d90: 0a 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f . (mutex-unlo
2da0: 63 6b 21 20 2a 64 62 2d 73 74 61 74 73 2d 6d 75 ck! *db-stats-mu
2db0: 74 65 78 2a 29 0a 20 20 20 20 72 65 73 29 29 0a tex*). res)).
2dc0: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 6f 70 .(define (rmt:op
2dd0: 65 6e 2d 71 72 79 2d 63 6c 6f 73 65 2d 6c 6f 63 en-qry-close-loc
2de0: 61 6c 6c 79 20 63 6d 64 20 72 75 6e 2d 69 64 20 ally cmd run-id
2df0: 70 61 72 61 6d 73 20 23 21 6b 65 79 20 28 72 65 params #!key (re
2e00: 6d 72 65 74 72 69 65 73 20 35 29 29 0a 20 20 28 mretries 5)). (
2e10: 6c 65 74 2a 20 28 28 71 72 79 2d 69 73 2d 77 72 let* ((qry-is-wr
2e20: 69 74 65 20 20 20 28 6e 6f 74 20 28 6d 65 6d 62 ite (not (memb
2e30: 65 72 20 63 6d 64 20 61 70 69 3a 72 65 61 64 2d er cmd api:read-
2e40: 6f 6e 6c 79 2d 71 75 65 72 69 65 73 29 29 29 0a only-queries))).
2e50: 09 20 28 64 62 2d 66 69 6c 65 2d 70 61 74 68 20 . (db-file-path
2e60: 20 20 28 64 62 3a 64 62 66 69 6c 65 2d 70 61 74 (db:dbfile-pat
2e70: 68 29 29 20 3b 3b 20 20 30 29 29 0a 09 20 28 64 h)) ;; 0)).. (d
2e80: 62 73 74 72 75 63 74 2d 6c 6f 63 61 6c 20 28 64 bstruct-local (d
2e90: 62 3a 73 65 74 75 70 29 29 20 20 3b 3b 20 6d 61 b:setup)) ;; ma
2ea0: 6b 65 2d 64 62 72 3a 64 62 73 74 72 75 63 74 20 ke-dbr:dbstruct
2eb0: 70 61 74 68 3a 20 20 64 62 64 69 72 20 6c 6f 63 path: dbdir loc
2ec0: 61 6c 3a 20 23 74 29 29 29 0a 09 20 28 72 65 61 al: #t))).. (rea
2ed0: 64 2d 6f 6e 6c 79 20 20 20 20 20 20 28 6e 6f 74 d-only (not
2ee0: 20 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 (file-write-acc
2ef0: 65 73 73 3f 20 64 62 2d 66 69 6c 65 2d 70 61 74 ess? db-file-pat
2f00: 68 29 29 29 0a 09 20 28 73 74 61 72 74 20 20 20 h))).. (start
2f10: 20 20 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d (current-
2f20: 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 29 0a 09 milliseconds))..
2f30: 20 28 72 65 73 64 61 74 20 20 20 20 20 20 20 20 (resdat
2f40: 20 28 69 66 20 28 6e 6f 74 20 28 61 6e 64 20 72 (if (not (and r
2f50: 65 61 64 2d 6f 6e 6c 79 20 71 72 79 2d 69 73 2d ead-only qry-is-
2f60: 77 72 69 74 65 29 29 0a 09 09 09 20 20 20 20 20 write))....
2f70: 28 61 70 69 3a 65 78 65 63 75 74 65 2d 72 65 71 (api:execute-req
2f80: 75 65 73 74 73 20 64 62 73 74 72 75 63 74 2d 6c uests dbstruct-l
2f90: 6f 63 61 6c 20 28 76 65 63 74 6f 72 20 28 73 79 ocal (vector (sy
2fa0: 6d 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 63 6d 64 mbol->string cmd
2fb0: 29 20 70 61 72 61 6d 73 29 29 0a 09 09 09 20 20 ) params))....
2fc0: 20 20 20 28 76 65 63 74 6f 72 20 23 74 20 27 28 (vector #t '(
2fd0: 29 29 29 29 0a 09 20 28 73 75 63 63 65 73 73 20 )))).. (success
2fe0: 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 (vector-r
2ff0: 65 66 20 72 65 73 64 61 74 20 30 29 29 0a 09 20 ef resdat 0))..
3000: 28 72 65 73 20 20 20 20 20 20 20 20 20 20 20 20 (res
3010: 28 76 65 63 74 6f 72 2d 72 65 66 20 72 65 73 64 (vector-ref resd
3020: 61 74 20 31 29 29 0a 09 20 28 64 75 72 61 74 69 at 1)).. (durati
3030: 6f 6e 20 20 20 20 20 20 20 28 2d 20 28 63 75 72 on (- (cur
3040: 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 rent-millisecond
3050: 73 29 20 73 74 61 72 74 29 29 29 0a 20 20 20 20 s) start))).
3060: 28 69 66 20 28 61 6e 64 20 72 65 61 64 2d 6f 6e (if (and read-on
3070: 6c 79 20 71 72 79 2d 69 73 2d 77 72 69 74 65 29 ly qry-is-write)
3080: 0a 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a . (debug:
3090: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
30a0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 52 52 4f -log-port* "ERRO
30b0: 52 3a 20 61 74 74 65 6d 70 74 20 74 6f 20 77 72 R: attempt to wr
30c0: 69 74 65 20 74 6f 20 72 65 61 64 2d 6f 6e 6c 79 ite to read-only
30d0: 20 64 61 74 61 62 61 73 65 20 69 67 6e 6f 72 65 database ignore
30e0: 64 2e 20 63 6d 64 3d 22 20 63 6d 64 29 29 0a 20 d. cmd=" cmd)).
30f0: 20 20 20 28 69 66 20 28 6e 6f 74 20 73 75 63 63 (if (not succ
3100: 65 73 73 29 0a 09 28 69 66 20 28 3e 20 72 65 6d ess)..(if (> rem
3110: 72 65 74 72 69 65 73 20 30 29 0a 09 20 20 20 20 retries 0)..
3120: 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 64 (begin.. (d
3130: 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 ebug:print-error
3140: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
3150: 70 6f 72 74 2a 20 22 6c 6f 63 61 6c 20 71 75 65 port* "local que
3160: 72 79 20 66 61 69 6c 65 64 2e 20 54 72 79 69 6e ry failed. Tryin
3170: 67 20 61 67 61 69 6e 2e 22 29 0a 09 20 20 20 20 g again.")..
3180: 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
3190: 20 28 2f 20 28 72 61 6e 64 6f 6d 20 35 30 30 30 (/ (random 5000
31a0: 29 20 31 30 30 30 29 29 20 3b 3b 20 73 6f 6d 65 ) 1000)) ;; some
31b0: 20 72 61 6e 64 6f 6d 20 64 65 6c 61 79 20 0a 09 random delay ..
31c0: 20 20 20 20 20 20 28 72 6d 74 3a 6f 70 65 6e 2d (rmt:open-
31d0: 71 72 79 2d 63 6c 6f 73 65 2d 6c 6f 63 61 6c 6c qry-close-locall
31e0: 79 20 63 6d 64 20 72 75 6e 2d 69 64 20 70 61 72 y cmd run-id par
31f0: 61 6d 73 20 72 65 6d 72 65 74 72 69 65 73 3a 20 ams remretries:
3200: 28 2d 20 72 65 6d 72 65 74 72 69 65 73 20 31 29 (- remretries 1)
3210: 29 29 0a 09 20 20 20 20 28 62 65 67 69 6e 0a 09 )).. (begin..
3220: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
3230: 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 nt-error 0 *defa
3240: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 74 ult-log-port* "t
3250: 6f 6f 20 6d 61 6e 79 20 72 65 74 72 69 65 73 20 oo many retries
3260: 69 6e 20 72 6d 74 3a 6f 70 65 6e 2d 71 72 79 2d in rmt:open-qry-
3270: 63 6c 6f 73 65 2d 6c 6f 63 61 6c 6c 79 2c 20 67 close-locally, g
3280: 69 76 69 6e 67 20 75 70 22 29 0a 09 20 20 20 20 iving up")..
3290: 20 20 23 66 29 29 0a 09 28 62 65 67 69 6e 0a 09 #f))..(begin..
32a0: 20 20 3b 3b 20 28 72 6d 74 3a 75 70 64 61 74 65 ;; (rmt:update
32b0: 2d 64 62 2d 73 74 61 74 73 20 72 75 6e 2d 69 64 -db-stats run-id
32c0: 20 63 6d 64 20 70 61 72 61 6d 73 20 64 75 72 61 cmd params dura
32d0: 74 69 6f 6e 29 0a 09 20 20 3b 3b 20 6d 61 72 6b tion).. ;; mark
32e0: 20 74 68 69 73 20 72 75 6e 20 61 73 20 64 69 72 this run as dir
32f0: 74 79 20 69 66 20 74 68 69 73 20 77 61 73 20 61 ty if this was a
3300: 20 77 72 69 74 65 2c 20 74 68 65 20 77 61 74 63 write, the watc
3310: 68 64 6f 67 20 69 73 20 72 65 73 70 6f 6e 73 69 hdog is responsi
3320: 62 6c 65 20 66 6f 72 20 73 79 6e 63 69 6e 67 20 ble for syncing
3330: 69 74 0a 09 20 20 28 69 66 20 71 72 79 2d 69 73 it.. (if qry-is
3340: 2d 77 72 69 74 65 0a 09 20 20 20 20 20 20 28 6c -write.. (l
3350: 65 74 20 28 28 73 74 61 72 74 2d 74 69 6d 65 20 et ((start-time
3360: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
3370: 29 29 29 0a 09 09 28 6d 75 74 65 78 2d 6c 6f 63 )))...(mutex-loc
3380: 6b 21 20 2a 64 62 2d 6d 75 6c 74 69 2d 73 79 6e k! *db-multi-syn
3390: 63 2d 6d 75 74 65 78 2a 29 0a 09 09 28 73 65 74 c-mutex*)...(set
33a0: 21 20 2a 64 62 2d 6c 61 73 74 2d 77 72 69 74 65 ! *db-last-write
33b0: 2a 20 73 74 61 72 74 2d 74 69 6d 65 29 20 3b 3b * start-time) ;;
33c0: 20 74 68 65 20 6f 6c 64 65 73 74 20 22 77 72 69 the oldest "wri
33d0: 74 65 22 0a 20 20 20 20 20 20 20 20 20 20 20 20 te".
33e0: 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 (mutex-unloc
33f0: 6b 21 20 2a 64 62 2d 6d 75 6c 74 69 2d 73 79 6e k! *db-multi-syn
3400: 63 2d 6d 75 74 65 78 2a 29 29 29 29 29 0a 20 20 c-mutex*))))).
3410: 20 20 72 65 73 29 29 0a 0a 28 64 65 66 69 6e 65 res))..(define
3420: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
3430: 76 65 2d 6e 6f 2d 61 75 74 6f 2d 63 6c 69 65 6e ve-no-auto-clien
3440: 74 2d 73 65 74 75 70 20 63 6f 6e 6e 65 63 74 69 t-setup connecti
3450: 6f 6e 2d 69 6e 66 6f 20 63 6d 64 20 72 75 6e 2d on-info cmd run-
3460: 69 64 20 70 61 72 61 6d 73 29 0a 20 20 28 6c 65 id params). (le
3470: 74 2a 20 28 28 72 75 6e 2d 69 64 20 20 20 28 69 t* ((run-id (i
3480: 66 20 72 75 6e 2d 69 64 20 72 75 6e 2d 69 64 20 f run-id run-id
3490: 30 29 29 0a 09 20 28 72 65 73 20 20 09 20 20 20 0)).. (res .
34a0: 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f (handle-exceptio
34b0: 6e 73 0a 09 09 20 20 20 20 65 78 6e 0a 09 09 20 ns... exn...
34c0: 20 20 20 23 66 0a 09 09 20 20 20 20 28 68 74 74 #f... (htt
34d0: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 65 p-transport:clie
34e0: 6e 74 2d 61 70 69 2d 73 65 6e 64 2d 72 65 63 65 nt-api-send-rece
34f0: 69 76 65 20 72 75 6e 2d 69 64 20 63 6f 6e 6e 65 ive run-id conne
3500: 63 74 69 6f 6e 2d 69 6e 66 6f 20 63 6d 64 20 70 ction-info cmd p
3510: 61 72 61 6d 73 29 29 29 29 0a 20 20 20 20 28 69 arams)))). (i
3520: 66 20 28 61 6e 64 20 72 65 73 20 28 76 65 63 74 f (and res (vect
3530: 6f 72 2d 72 65 66 20 72 65 73 20 30 29 29 0a 09 or-ref res 0))..
3540: 28 76 65 63 74 6f 72 2d 72 65 66 20 72 65 73 20 (vector-ref res
3550: 31 29 20 3b 3b 3b 20 59 45 53 21 21 20 54 48 49 1) ;;; YES!! THI
3560: 53 20 49 53 20 43 4f 52 52 45 43 54 21 21 20 43 S IS CORRECT!! C
3570: 48 41 4e 47 45 20 49 54 20 48 45 52 45 2c 20 54 HANGE IT HERE, T
3580: 48 45 4e 20 43 48 41 4e 47 45 20 72 6d 74 3a 73 HEN CHANGE rmt:s
3590: 65 6e 64 2d 72 65 63 65 69 76 65 20 41 4c 53 4f end-receive ALSO
35a0: 21 21 21 0a 09 23 66 29 29 29 0a 0a 3b 3b 20 3b !!!..#f)))..;; ;
35b0: 3b 20 57 72 61 70 20 6a 73 6f 6e 20 6c 69 62 72 ; Wrap json libr
35c0: 61 72 79 20 66 6f 72 20 73 74 72 69 6e 67 73 20 ary for strings
35d0: 28 77 68 79 20 74 68 65 20 70 6f 72 74 73 20 63 (why the ports c
35e0: 72 61 70 20 69 6e 20 74 68 65 20 66 69 72 73 74 rap in the first
35f0: 20 70 6c 61 63 65 3f 29 0a 3b 3b 20 28 64 65 66 place?).;; (def
3600: 69 6e 65 20 28 72 6d 74 3a 64 61 74 2d 3e 6a 73 ine (rmt:dat->js
3610: 6f 6e 2d 73 74 72 20 64 61 74 29 0a 3b 3b 20 20 on-str dat).;;
3620: 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f (with-output-to
3630: 2d 73 74 72 69 6e 67 20 0a 3b 3b 20 20 20 20 20 -string .;;
3640: 28 6c 61 6d 62 64 61 20 28 29 0a 3b 3b 20 20 20 (lambda ().;;
3650: 20 20 20 20 28 6a 73 6f 6e 2d 77 72 69 74 65 20 (json-write
3660: 64 61 74 29 29 29 29 0a 3b 3b 20 0a 3b 3b 20 28 dat)))).;; .;; (
3670: 64 65 66 69 6e 65 20 28 72 6d 74 3a 6a 73 6f 6e define (rmt:json
3680: 2d 73 74 72 2d 3e 64 61 74 20 6a 73 6f 6e 2d 73 -str->dat json-s
3690: 74 72 29 0a 3b 3b 20 20 20 28 77 69 74 68 2d 69 tr).;; (with-i
36a0: 6e 70 75 74 2d 66 72 6f 6d 2d 73 74 72 69 6e 67 nput-from-string
36b0: 20 6a 73 6f 6e 2d 73 74 72 0a 3b 3b 20 20 20 20 json-str.;;
36c0: 20 28 6c 61 6d 62 64 61 20 28 29 0a 3b 3b 20 20 (lambda ().;;
36d0: 20 20 20 20 20 28 6a 73 6f 6e 2d 72 65 61 64 29 (json-read)
36e0: 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d )))..;;=========
36f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3700: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3710: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3720: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
3730: 0a 3b 3b 20 41 20 43 20 54 20 55 20 41 20 4c 20 .;; A C T U A L
3740: 20 20 41 20 50 20 49 20 20 20 43 20 41 20 4c 20 A P I C A L
3750: 4c 20 53 20 20 0a 3b 3b 0a 3b 3b 3d 3d 3d 3d 3d L S .;;.;;=====
3760: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3770: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3780: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3790: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
37a0: 3d 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d =..;;===========
37b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
37c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
37d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
37e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 ===========.;;
37f0: 53 20 45 20 52 20 56 20 45 20 52 0a 3b 3b 3d 3d S E R V E R.;;==
3800: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3810: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3820: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3830: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3840: 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 72 ====..(define (r
3850: 6d 74 3a 6b 69 6c 6c 2d 73 65 72 76 65 72 20 72 mt:kill-server r
3860: 75 6e 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 un-id). (rmt:se
3870: 6e 64 2d 72 65 63 65 69 76 65 20 27 6b 69 6c 6c nd-receive 'kill
3880: 2d 73 65 72 76 65 72 20 72 75 6e 2d 69 64 20 28 -server run-id (
3890: 6c 69 73 74 20 72 75 6e 2d 69 64 29 29 29 0a 0a list run-id)))..
38a0: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 73 74 61 (define (rmt:sta
38b0: 72 74 2d 73 65 72 76 65 72 20 72 75 6e 2d 69 64 rt-server run-id
38c0: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
38d0: 63 65 69 76 65 20 27 73 74 61 72 74 2d 73 65 72 ceive 'start-ser
38e0: 76 65 72 20 30 20 28 6c 69 73 74 20 72 75 6e 2d ver 0 (list run-
38f0: 69 64 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d id)))..;;=======
3900: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3910: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3920: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3930: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
3940: 3b 3b 20 20 4d 20 49 20 53 20 43 0a 3b 3b 3d 3d ;; M I S C.;;==
3950: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3960: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3970: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3980: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3990: 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 72 ====..(define (r
39a0: 6d 74 3a 6c 6f 67 69 6e 20 72 75 6e 2d 69 64 29 mt:login run-id)
39b0: 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 . (rmt:send-rec
39c0: 65 69 76 65 20 27 6c 6f 67 69 6e 20 72 75 6e 2d eive 'login run-
39d0: 69 64 20 28 6c 69 73 74 20 2a 74 6f 70 70 61 74 id (list *toppat
39e0: 68 2a 20 6d 65 67 61 74 65 73 74 2d 76 65 72 73 h* megatest-vers
39f0: 69 6f 6e 20 2a 6d 79 2d 63 6c 69 65 6e 74 2d 73 ion *my-client-s
3a00: 69 67 6e 61 74 75 72 65 2a 29 29 29 0a 0a 3b 3b ignature*)))..;;
3a10: 20 54 68 69 73 20 6c 6f 67 69 6e 20 64 6f 65 73 This login does
3a20: 20 6e 6f 20 72 65 74 72 69 65 73 20 75 6e 64 65 no retries unde
3a30: 72 20 74 68 65 20 68 6f 6f 64 20 2d 20 69 74 20 r the hood - it
3a40: 61 63 74 73 20 61 20 62 69 74 20 6c 69 6b 65 20 acts a bit like
3a50: 61 20 70 69 6e 67 2e 0a 3b 3b 20 44 65 70 72 65 a ping..;; Depre
3a60: 63 61 74 65 64 20 66 6f 72 20 6e 6d 73 67 2d 74 cated for nmsg-t
3a70: 72 61 6e 73 70 6f 72 74 2e 0a 3b 3b 0a 28 64 65 ransport..;;.(de
3a80: 66 69 6e 65 20 28 72 6d 74 3a 6c 6f 67 69 6e 2d fine (rmt:login-
3a90: 6e 6f 2d 61 75 74 6f 2d 63 6c 69 65 6e 74 2d 73 no-auto-client-s
3aa0: 65 74 75 70 20 63 6f 6e 6e 65 63 74 69 6f 6e 2d etup connection-
3ab0: 69 6e 66 6f 29 0a 20 20 28 63 61 73 65 20 2a 74 info). (case *t
3ac0: 72 61 6e 73 70 6f 72 74 2d 74 79 70 65 2a 20 3b ransport-type* ;
3ad0: 3b 20 72 75 6e 2d 69 64 20 6f 66 20 30 20 69 73 ; run-id of 0 is
3ae0: 20 6a 75 73 74 20 61 20 70 6c 61 63 65 68 6f 6c just a placehol
3af0: 64 65 72 0a 20 20 20 20 28 28 68 74 74 70 29 28 der. ((http)(
3b00: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
3b10: 2d 6e 6f 2d 61 75 74 6f 2d 63 6c 69 65 6e 74 2d -no-auto-client-
3b20: 73 65 74 75 70 20 63 6f 6e 6e 65 63 74 69 6f 6e setup connection
3b30: 2d 69 6e 66 6f 20 27 6c 6f 67 69 6e 20 30 20 28 -info 'login 0 (
3b40: 6c 69 73 74 20 2a 74 6f 70 70 61 74 68 2a 20 6d list *toppath* m
3b50: 65 67 61 74 65 73 74 2d 76 65 72 73 69 6f 6e 20 egatest-version
3b60: 2a 6d 79 2d 63 6c 69 65 6e 74 2d 73 69 67 6e 61 *my-client-signa
3b70: 74 75 72 65 2a 29 29 29 0a 20 20 20 20 3b 3b 28 ture*))). ;;(
3b80: 28 6e 6d 73 67 29 28 6e 6d 73 67 2d 74 72 61 6e (nmsg)(nmsg-tran
3b90: 73 70 6f 72 74 3a 63 6c 69 65 6e 74 2d 61 70 69 sport:client-api
3ba0: 2d 73 65 6e 64 2d 72 65 63 65 69 76 65 20 72 75 -send-receive ru
3bb0: 6e 2d 69 64 20 63 6f 6e 6e 65 63 74 69 6f 6e 2d n-id connection-
3bc0: 69 6e 66 6f 20 27 6c 6f 67 69 6e 20 28 6c 69 73 info 'login (lis
3bd0: 74 20 2a 74 6f 70 70 61 74 68 2a 20 6d 65 67 61 t *toppath* mega
3be0: 74 65 73 74 2d 76 65 72 73 69 6f 6e 20 72 75 6e test-version run
3bf0: 2d 69 64 20 2a 6d 79 2d 63 6c 69 65 6e 74 2d 73 -id *my-client-s
3c00: 69 67 6e 61 74 75 72 65 2a 29 29 29 0a 20 20 20 ignature*))).
3c10: 20 29 29 0a 0a 3b 3b 20 68 61 6e 64 20 6f 66 66 ))..;; hand off
3c20: 20 61 20 63 61 6c 6c 20 74 6f 20 6f 6e 65 20 6f a call to one o
3c30: 66 20 74 68 65 20 64 62 3a 71 75 65 72 69 65 73 f the db:queries
3c40: 20 73 74 61 74 65 6d 65 6e 74 73 0a 3b 3b 20 61 statements.;; a
3c50: 64 64 65 64 20 72 75 6e 2d 69 64 20 74 6f 20 6d dded run-id to m
3c60: 61 6b 65 20 6c 6f 6f 6b 69 6e 67 20 75 70 20 74 ake looking up t
3c70: 68 65 20 63 6f 72 72 65 63 74 20 64 62 20 70 6f he correct db po
3c80: 73 73 69 62 6c 65 20 0a 3b 3b 0a 28 64 65 66 69 ssible .;;.(defi
3c90: 6e 65 20 28 72 6d 74 3a 67 65 6e 65 72 61 6c 2d ne (rmt:general-
3ca0: 63 61 6c 6c 20 73 74 6d 74 6e 61 6d 65 20 72 75 call stmtname ru
3cb0: 6e 2d 69 64 20 2e 20 70 61 72 61 6d 73 29 0a 20 n-id . params).
3cc0: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
3cd0: 76 65 20 27 67 65 6e 65 72 61 6c 2d 63 61 6c 6c ve 'general-call
3ce0: 20 72 75 6e 2d 69 64 20 28 61 70 70 65 6e 64 20 run-id (append
3cf0: 28 6c 69 73 74 20 73 74 6d 74 6e 61 6d 65 20 72 (list stmtname r
3d00: 75 6e 2d 69 64 29 20 70 61 72 61 6d 73 29 29 29 un-id) params)))
3d10: 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 72 6d ..;; (define (rm
3d20: 74 3a 73 79 6e 63 2d 69 6e 6d 65 6d 2d 3e 64 62 t:sync-inmem->db
3d30: 20 72 75 6e 2d 69 64 29 0a 3b 3b 20 20 20 28 72 run-id).;; (r
3d40: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
3d50: 27 73 79 6e 63 2d 69 6e 6d 65 6d 2d 3e 64 62 20 'sync-inmem->db
3d60: 72 75 6e 2d 69 64 20 27 28 29 29 29 0a 0a 28 64 run-id '()))..(d
3d70: 65 66 69 6e 65 20 28 72 6d 74 3a 73 64 62 2d 71 efine (rmt:sdb-q
3d80: 72 79 20 71 72 79 20 76 61 6c 20 72 75 6e 2d 69 ry qry val run-i
3d90: 64 29 0a 20 20 3b 3b 20 61 64 64 20 63 61 63 68 d). ;; add cach
3da0: 69 6e 67 20 69 66 20 71 72 79 20 69 73 20 27 67 ing if qry is 'g
3db0: 65 74 69 64 20 6f 72 20 27 67 65 74 73 74 72 0a etid or 'getstr.
3dc0: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
3dd0: 69 76 65 20 27 73 64 62 2d 71 72 79 20 72 75 6e ive 'sdb-qry run
3de0: 2d 69 64 20 28 6c 69 73 74 20 71 72 79 20 76 61 -id (list qry va
3df0: 6c 29 29 29 0a 0a 3b 3b 20 4e 4f 54 20 43 4f 4d l)))..;; NOT COM
3e00: 50 4c 45 54 45 44 0a 28 64 65 66 69 6e 65 20 28 PLETED.(define (
3e10: 72 6d 74 3a 72 75 6e 74 65 73 74 73 20 75 73 65 rmt:runtests use
3e20: 72 20 72 75 6e 2d 69 64 20 74 65 73 74 70 61 74 r run-id testpat
3e30: 74 20 70 61 72 61 6d 73 29 0a 20 20 28 72 6d 74 t params). (rmt
3e40: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 72 :send-receive 'r
3e50: 75 6e 74 65 73 74 73 20 72 75 6e 2d 69 64 20 74 untests run-id t
3e60: 65 73 74 70 61 74 74 29 29 0a 0a 3b 3b 3d 3d 3d estpatt))..;;===
3e70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3e80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3e90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3ea0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3eb0: 3d 3d 3d 0a 3b 3b 20 20 4b 20 45 20 59 20 53 20 ===.;; K E Y S
3ec0: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
3ed0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3ee0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3ef0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3f00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 54 68 =========..;; Th
3f10: 65 73 65 20 72 65 71 75 69 72 65 20 72 75 6e 2d ese require run-
3f20: 69 64 20 62 65 63 61 75 73 65 20 74 68 65 20 76 id because the v
3f30: 61 6c 75 65 73 20 63 6f 6d 65 20 66 72 6f 6d 20 alues come from
3f40: 74 68 65 20 72 75 6e 21 0a 3b 3b 0a 28 64 65 66 the run!.;;.(def
3f50: 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 6b 65 79 ine (rmt:get-key
3f60: 2d 76 61 6c 2d 70 61 69 72 73 20 72 75 6e 2d 69 -val-pairs run-i
3f70: 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 d). (rmt:send-r
3f80: 65 63 65 69 76 65 20 27 67 65 74 2d 6b 65 79 2d eceive 'get-key-
3f90: 76 61 6c 2d 70 61 69 72 73 20 72 75 6e 2d 69 64 val-pairs run-id
3fa0: 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 29 29 29 (list run-id)))
3fb0: 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 ..(define (rmt:g
3fc0: 65 74 2d 6b 65 79 73 29 0a 20 20 28 69 66 20 2a et-keys). (if *
3fd0: 64 62 2d 6b 65 79 73 2a 20 2a 64 62 2d 6b 65 79 db-keys* *db-key
3fe0: 73 2a 20 0a 20 20 20 20 20 28 6c 65 74 20 28 28 s* . (let ((
3ff0: 72 65 73 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 res (rmt:send-re
4000: 63 65 69 76 65 20 27 67 65 74 2d 6b 65 79 73 20 ceive 'get-keys
4010: 23 66 20 27 28 29 29 29 29 0a 20 20 20 20 20 20 #f '()))).
4020: 20 28 73 65 74 21 20 2a 64 62 2d 6b 65 79 73 2a (set! *db-keys*
4030: 20 72 65 73 29 0a 20 20 20 20 20 20 20 72 65 73 res). res
4040: 29 29 29 0a 0a 3b 3b 20 77 65 20 64 6f 6e 27 74 )))..;; we don't
4050: 20 72 65 75 73 65 20 72 75 6e 2d 69 64 27 73 20 reuse run-id's
4060: 28 65 78 63 65 70 74 20 70 6f 73 73 69 62 6c 79 (except possibly
4070: 20 2a 61 66 74 65 72 2a 20 61 20 64 62 20 63 6c *after* a db cl
4080: 65 61 6e 75 70 29 20 73 6f 20 69 74 20 69 73 20 eanup) so it is
4090: 73 61 66 65 0a 3b 3b 20 74 6f 20 63 61 63 68 65 safe.;; to cache
40a0: 20 74 68 65 20 72 65 73 75 6c 73 20 69 6e 20 61 the resuls in a
40b0: 20 68 61 73 68 0a 3b 3b 0a 28 64 65 66 69 6e 65 hash.;;.(define
40c0: 20 28 72 6d 74 3a 67 65 74 2d 6b 65 79 2d 76 61 (rmt:get-key-va
40d0: 6c 73 20 72 75 6e 2d 69 64 29 0a 20 20 28 6f 72 ls run-id). (or
40e0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
40f0: 2f 64 65 66 61 75 6c 74 20 2a 6b 65 79 76 61 6c /default *keyval
4100: 73 2a 20 72 75 6e 2d 69 64 20 23 66 29 0a 20 20 s* run-id #f).
4110: 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 20 28 (let ((res (
4120: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
4130: 20 27 67 65 74 2d 6b 65 79 2d 76 61 6c 73 20 23 'get-key-vals #
4140: 66 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 29 29 f (list run-id))
4150: 29 29 0a 20 20 20 20 20 20 20 20 28 68 61 73 68 )). (hash
4160: 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a 6b 65 79 -table-set! *key
4170: 76 61 6c 73 2a 20 72 75 6e 2d 69 64 20 72 65 73 vals* run-id res
4180: 29 0a 20 20 20 20 20 20 20 20 72 65 73 29 29 29 ). res)))
4190: 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 ..(define (rmt:g
41a0: 65 74 2d 74 61 72 67 65 74 73 29 0a 20 20 28 72 et-targets). (r
41b0: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
41c0: 27 67 65 74 2d 74 61 72 67 65 74 73 20 23 66 20 'get-targets #f
41d0: 27 28 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 '()))..(define (
41e0: 72 6d 74 3a 67 65 74 2d 74 61 72 67 65 74 20 72 rmt:get-target r
41f0: 75 6e 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 un-id). (rmt:se
4200: 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d nd-receive 'get-
4210: 74 61 72 67 65 74 20 72 75 6e 2d 69 64 20 28 6c target run-id (l
4220: 69 73 74 20 72 75 6e 2d 69 64 29 29 29 0a 0a 3b ist run-id)))..;
4230: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
4240: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4250: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4260: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4270: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 54 20 45 20 =======.;; T E
4280: 53 20 54 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d S T S.;;========
4290: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
42a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
42b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
42c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
42d0: 3b 3b 20 4a 75 73 74 20 73 6f 6d 65 20 73 79 6e ;; Just some syn
42e0: 74 61 74 69 63 20 73 75 67 61 72 0a 28 64 65 66 tatic sugar.(def
42f0: 69 6e 65 20 28 72 6d 74 3a 72 65 67 69 73 74 65 ine (rmt:registe
4300: 72 2d 74 65 73 74 20 72 75 6e 2d 69 64 20 74 65 r-test run-id te
4310: 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 st-name item-pat
4320: 68 29 0a 20 20 28 72 6d 74 3a 67 65 6e 65 72 61 h). (rmt:genera
4330: 6c 2d 63 61 6c 6c 20 27 72 65 67 69 73 74 65 72 l-call 'register
4340: 2d 74 65 73 74 20 72 75 6e 2d 69 64 20 72 75 6e -test run-id run
4350: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 -id test-name it
4360: 65 6d 2d 70 61 74 68 29 29 0a 0a 28 64 65 66 69 em-path))..(defi
4370: 6e 65 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 ne (rmt:get-test
4380: 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 6e -id run-id testn
4390: 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 0a 20 ame item-path).
43a0: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
43b0: 76 65 20 27 67 65 74 2d 74 65 73 74 2d 69 64 20 ve 'get-test-id
43c0: 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e run-id (list run
43d0: 2d 69 64 20 74 65 73 74 6e 61 6d 65 20 69 74 65 -id testname ite
43e0: 6d 2d 70 61 74 68 29 29 29 0a 0a 28 64 65 66 69 m-path)))..(defi
43f0: 6e 65 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 ne (rmt:get-test
4400: 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 72 75 6e 2d -info-by-id run-
4410: 69 64 20 74 65 73 74 2d 69 64 29 0a 20 20 28 69 id test-id). (i
4420: 66 20 28 61 6e 64 20 28 6e 75 6d 62 65 72 3f 20 f (and (number?
4430: 72 75 6e 2d 69 64 29 28 6e 75 6d 62 65 72 3f 20 run-id)(number?
4440: 74 65 73 74 2d 69 64 29 29 0a 20 20 20 20 20 20 test-id)).
4450: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
4460: 65 20 27 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f e 'get-test-info
4470: 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 28 6c -by-id run-id (l
4480: 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d ist run-id test-
4490: 69 64 29 29 0a 20 20 20 20 20 20 28 62 65 67 69 id)). (begi
44a0: 6e 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 n..(debug:print
44b0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
44c0: 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 42 ort* "WARNING: B
44d0: 61 64 20 64 61 74 61 20 68 61 6e 64 65 64 20 74 ad data handed t
44e0: 6f 20 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 o rmt:get-test-i
44f0: 6e 66 6f 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 nfo-by-id run-id
4500: 3d 22 20 72 75 6e 2d 69 64 20 22 2c 20 74 65 73 =" run-id ", tes
4510: 74 2d 69 64 3d 22 20 74 65 73 74 2d 69 64 29 0a t-id=" test-id).
4520: 09 28 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 .(print-call-cha
4530: 69 6e 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f in (current-erro
4540: 72 2d 70 6f 72 74 29 29 0a 09 23 66 29 29 29 0a r-port))..#f))).
4550: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 65 .(define (rmt:te
4560: 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 2d 66 72 st-get-rundir-fr
4570: 6f 6d 2d 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 om-test-id run-i
4580: 64 20 74 65 73 74 2d 69 64 29 0a 20 20 28 72 6d d test-id). (rm
4590: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
45a0: 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 2d test-get-rundir-
45b0: 66 72 6f 6d 2d 74 65 73 74 2d 69 64 20 72 75 6e from-test-id run
45c0: 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 -id (list run-id
45d0: 20 74 65 73 74 2d 69 64 29 29 29 0a 0a 28 64 65 test-id)))..(de
45e0: 66 69 6e 65 20 28 72 6d 74 3a 6f 70 65 6e 2d 74 fine (rmt:open-t
45f0: 65 73 74 2d 64 62 2d 62 79 2d 74 65 73 74 2d 69 est-db-by-test-i
4600: 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 d run-id test-id
4610: 20 23 21 6b 65 79 20 28 77 6f 72 6b 2d 61 72 65 #!key (work-are
4620: 61 20 23 66 29 29 0a 20 20 28 6c 65 74 2a 20 28 a #f)). (let* (
4630: 28 74 65 73 74 2d 70 61 74 68 20 28 69 66 20 28 (test-path (if (
4640: 73 74 72 69 6e 67 3f 20 77 6f 72 6b 2d 61 72 65 string? work-are
4650: 61 29 0a 09 09 09 77 6f 72 6b 2d 61 72 65 61 0a a)....work-area.
4660: 09 09 09 28 72 6d 74 3a 74 65 73 74 2d 67 65 74 ...(rmt:test-get
4670: 2d 72 75 6e 64 69 72 2d 66 72 6f 6d 2d 74 65 73 -rundir-from-tes
4680: 74 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 t-id run-id test
4690: 2d 69 64 29 29 29 29 0a 20 20 20 20 28 64 65 62 -id)))). (deb
46a0: 75 67 3a 70 72 69 6e 74 20 33 20 2a 64 65 66 61 ug:print 3 *defa
46b0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 54 ult-log-port* "T
46c0: 45 53 54 20 50 41 54 48 3a 20 22 20 74 65 73 74 EST PATH: " test
46d0: 2d 70 61 74 68 29 0a 20 20 20 20 28 6f 70 65 6e -path). (open
46e0: 2d 74 65 73 74 2d 64 62 20 74 65 73 74 2d 70 61 -test-db test-pa
46f0: 74 68 29 29 29 0a 0a 3b 3b 20 57 41 52 4e 49 4e th)))..;; WARNIN
4700: 47 3a 20 54 68 69 73 20 63 75 72 72 65 6e 74 6c G: This currentl
4710: 79 20 62 79 70 61 73 73 65 73 20 74 68 65 20 74 y bypasses the t
4720: 72 61 6e 73 61 63 74 69 6f 6e 20 77 72 61 70 70 ransaction wrapp
4730: 65 64 20 77 72 69 74 65 73 20 73 79 73 74 65 6d ed writes system
4740: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 65 .(define (rmt:te
4750: 73 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 st-set-state-sta
4760: 74 75 73 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 tus-by-id run-id
4770: 20 74 65 73 74 2d 69 64 20 6e 65 77 73 74 61 74 test-id newstat
4780: 65 20 6e 65 77 73 74 61 74 75 73 20 6e 65 77 63 e newstatus newc
4790: 6f 6d 6d 65 6e 74 29 0a 20 20 28 72 6d 74 3a 73 omment). (rmt:s
47a0: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 74 65 73 end-receive 'tes
47b0: 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 t-set-state-stat
47c0: 75 73 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 us-by-id run-id
47d0: 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 (list run-id tes
47e0: 74 2d 69 64 20 6e 65 77 73 74 61 74 65 20 6e 65 t-id newstate ne
47f0: 77 73 74 61 74 75 73 20 6e 65 77 63 6f 6d 6d 65 wstatus newcomme
4800: 6e 74 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 nt)))..(define (
4810: 72 6d 74 3a 73 65 74 2d 74 65 73 74 73 2d 73 74 rmt:set-tests-st
4820: 61 74 65 2d 73 74 61 74 75 73 20 72 75 6e 2d 69 ate-status run-i
4830: 64 20 74 65 73 74 6e 61 6d 65 73 20 63 75 72 72 d testnames curr
4840: 73 74 61 74 65 20 63 75 72 72 73 74 61 74 75 73 state currstatus
4850: 20 6e 65 77 73 74 61 74 65 20 6e 65 77 73 74 61 newstate newsta
4860: 74 75 73 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 tus). (rmt:send
4870: 2d 72 65 63 65 69 76 65 20 27 73 65 74 2d 74 65 -receive 'set-te
4880: 73 74 73 2d 73 74 61 74 65 2d 73 74 61 74 75 73 sts-state-status
4890: 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 run-id (list ru
48a0: 6e 2d 69 64 20 74 65 73 74 6e 61 6d 65 73 20 63 n-id testnames c
48b0: 75 72 72 73 74 61 74 65 20 63 75 72 72 73 74 61 urrstate currsta
48c0: 74 75 73 20 6e 65 77 73 74 61 74 65 20 6e 65 77 tus newstate new
48d0: 73 74 61 74 75 73 29 29 29 0a 0a 28 64 65 66 69 status)))..(defi
48e0: 6e 65 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 ne (rmt:get-test
48f0: 73 2d 66 6f 72 2d 72 75 6e 20 72 75 6e 2d 69 64 s-for-run run-id
4900: 20 74 65 73 74 70 61 74 74 20 73 74 61 74 65 73 testpatt states
4910: 20 73 74 61 74 75 73 65 73 20 6f 66 66 73 65 74 statuses offset
4920: 20 6c 69 6d 69 74 20 6e 6f 74 2d 69 6e 20 73 6f limit not-in so
4930: 72 74 2d 62 79 20 73 6f 72 74 2d 6f 72 64 65 72 rt-by sort-order
4940: 20 71 72 79 76 61 6c 73 20 6c 61 73 74 2d 75 70 qryvals last-up
4950: 64 61 74 65 20 6d 6f 64 65 29 0a 20 20 28 69 66 date mode). (if
4960: 20 28 6e 75 6d 62 65 72 3f 20 72 75 6e 2d 69 64 (number? run-id
4970: 29 0a 20 20 20 20 20 20 28 72 6d 74 3a 73 65 6e ). (rmt:sen
4980: 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 74 d-receive 'get-t
4990: 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 72 75 6e ests-for-run run
49a0: 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 -id (list run-id
49b0: 20 74 65 73 74 70 61 74 74 20 73 74 61 74 65 73 testpatt states
49c0: 20 73 74 61 74 75 73 65 73 20 6f 66 66 73 65 74 statuses offset
49d0: 20 6c 69 6d 69 74 20 6e 6f 74 2d 69 6e 20 73 6f limit not-in so
49e0: 72 74 2d 62 79 20 73 6f 72 74 2d 6f 72 64 65 72 rt-by sort-order
49f0: 20 71 72 79 76 61 6c 73 20 6c 61 73 74 2d 75 70 qryvals last-up
4a00: 64 61 74 65 20 6d 6f 64 65 29 29 0a 20 20 20 20 date mode)).
4a10: 20 20 28 62 65 67 69 6e 0a 09 28 64 65 62 75 67 (begin..(debug
4a20: 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a :print-error 0 *
4a30: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
4a40: 2a 20 22 72 6d 74 3a 67 65 74 2d 74 65 73 74 73 * "rmt:get-tests
4a50: 2d 66 6f 72 2d 72 75 6e 20 63 61 6c 6c 65 64 20 -for-run called
4a60: 77 69 74 68 20 62 61 64 20 72 75 6e 2d 69 64 3d with bad run-id=
4a70: 22 20 72 75 6e 2d 69 64 29 0a 09 28 70 72 69 6e " run-id)..(prin
4a80: 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 20 28 63 75 t-call-chain (cu
4a90: 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 rrent-error-port
4aa0: 29 29 0a 09 27 28 29 29 29 29 0a 0a 3b 3b 20 67 ))..'())))..;; g
4ab0: 65 74 20 73 74 75 66 66 20 76 69 61 20 73 79 6e et stuff via syn
4ac0: 63 68 61 73 68 20 0a 28 64 65 66 69 6e 65 20 28 chash .(define (
4ad0: 72 6d 74 3a 73 79 6e 63 68 61 73 68 2d 67 65 74 rmt:synchash-get
4ae0: 20 72 75 6e 2d 69 64 20 70 72 6f 63 20 73 79 6e run-id proc syn
4af0: 63 6b 65 79 20 6b 65 79 6e 75 6d 20 70 61 72 61 ckey keynum para
4b00: 6d 73 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d ms). (rmt:send-
4b10: 72 65 63 65 69 76 65 20 27 73 79 6e 63 68 61 73 receive 'synchas
4b20: 68 2d 67 65 74 20 72 75 6e 2d 69 64 20 28 6c 69 h-get run-id (li
4b30: 73 74 20 72 75 6e 2d 69 64 20 70 72 6f 63 20 73 st run-id proc s
4b40: 79 6e 63 6b 65 79 20 6b 65 79 6e 75 6d 20 70 61 ynckey keynum pa
4b50: 72 61 6d 73 29 29 29 0a 0a 3b 3b 20 49 44 45 41 rams)))..;; IDEA
4b60: 3a 20 54 68 72 65 61 64 69 66 79 20 74 68 65 73 : Threadify thes
4b70: 65 20 2d 20 74 68 65 79 20 73 70 65 6e 64 20 61 e - they spend a
4b80: 20 6c 6f 74 20 6f 66 20 74 69 6d 65 20 77 61 69 lot of time wai
4b90: 74 69 6e 67 20 2e 2e 2e 0a 3b 3b 0a 28 64 65 66 ting ....;;.(def
4ba0: 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 ine (rmt:get-tes
4bb0: 74 73 2d 66 6f 72 2d 72 75 6e 73 2d 6d 69 6e 64 ts-for-runs-mind
4bc0: 61 74 61 20 72 75 6e 2d 69 64 73 20 74 65 73 74 ata run-ids test
4bd0: 70 61 74 74 20 73 74 61 74 65 73 20 73 74 61 74 patt states stat
4be0: 75 73 20 6e 6f 74 2d 69 6e 29 0a 20 20 28 6c 65 us not-in). (le
4bf0: 74 20 28 28 6d 75 6c 74 69 2d 72 75 6e 2d 6d 75 t ((multi-run-mu
4c00: 74 65 78 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 tex (make-mutex)
4c10: 29 0a 09 28 72 75 6e 2d 69 64 2d 6c 69 73 74 20 )..(run-id-list
4c20: 28 69 66 20 72 75 6e 2d 69 64 73 0a 09 09 09 20 (if run-ids....
4c30: 72 75 6e 2d 69 64 73 0a 09 09 09 20 28 72 6d 74 run-ids.... (rmt
4c40: 3a 67 65 74 2d 61 6c 6c 2d 72 75 6e 2d 69 64 73 :get-all-run-ids
4c50: 29 29 29 0a 09 28 72 65 73 75 6c 74 20 20 20 20 )))..(result
4c60: 20 20 27 28 29 29 29 0a 20 20 20 20 28 69 66 20 '())). (if
4c70: 28 6e 75 6c 6c 3f 20 72 75 6e 2d 69 64 2d 6c 69 (null? run-id-li
4c80: 73 74 29 0a 09 27 28 29 0a 09 28 6c 65 74 20 6c st)..'()..(let l
4c90: 6f 6f 70 20 28 28 68 65 64 20 20 20 20 20 28 63 oop ((hed (c
4ca0: 61 72 20 72 75 6e 2d 69 64 2d 6c 69 73 74 29 29 ar run-id-list))
4cb0: 0a 09 09 20 20 20 28 74 61 6c 20 20 20 20 20 28 ... (tal (
4cc0: 63 64 72 20 72 75 6e 2d 69 64 2d 6c 69 73 74 29 cdr run-id-list)
4cd0: 29 0a 09 09 20 20 20 28 74 68 72 65 61 64 73 20 )... (threads
4ce0: 27 28 29 29 29 0a 09 20 20 28 69 66 20 28 3e 20 '())).. (if (>
4cf0: 28 6c 65 6e 67 74 68 20 74 68 72 65 61 64 73 29 (length threads)
4d00: 20 35 29 0a 09 20 20 20 20 20 20 28 6c 6f 6f 70 5).. (loop
4d10: 20 68 65 64 20 74 61 6c 20 28 66 69 6c 74 65 72 hed tal (filter
4d20: 20 28 6c 61 6d 62 64 61 20 28 74 68 29 28 6e 6f (lambda (th)(no
4d30: 74 20 28 6d 65 6d 62 65 72 20 28 74 68 72 65 61 t (member (threa
4d40: 64 2d 73 74 61 74 65 20 74 68 29 20 27 28 74 65 d-state th) '(te
4d50: 72 6d 69 6e 61 74 65 64 20 64 65 61 64 29 29 29 rminated dead)))
4d60: 29 20 74 68 72 65 61 64 73 29 29 0a 09 20 20 20 ) threads))..
4d70: 20 20 20 28 6c 65 74 2a 20 28 28 6e 65 77 74 68 (let* ((newth
4d80: 72 65 61 64 20 28 6d 61 6b 65 2d 74 68 72 65 61 read (make-threa
4d90: 64 0a 09 09 09 09 20 28 6c 61 6d 62 64 61 20 28 d..... (lambda (
4da0: 29 0a 09 09 09 09 20 20 20 28 6c 65 74 20 28 28 )..... (let ((
4db0: 72 65 73 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 res (rmt:send-re
4dc0: 63 65 69 76 65 20 27 67 65 74 2d 74 65 73 74 73 ceive 'get-tests
4dd0: 2d 66 6f 72 2d 72 75 6e 2d 6d 69 6e 64 61 74 61 -for-run-mindata
4de0: 20 68 65 64 20 28 6c 69 73 74 20 68 65 64 20 74 hed (list hed t
4df0: 65 73 74 70 61 74 74 20 73 74 61 74 65 73 20 73 estpatt states s
4e00: 74 61 74 75 73 20 6e 6f 74 2d 69 6e 29 29 29 29 tatus not-in))))
4e10: 0a 09 09 09 09 20 20 20 20 20 28 69 66 20 28 6c ..... (if (l
4e20: 69 73 74 3f 20 72 65 73 29 0a 09 09 09 09 09 20 ist? res)......
4e30: 28 62 65 67 69 6e 0a 09 09 09 09 09 20 20 20 28 (begin...... (
4e40: 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 6d 75 6c 74 mutex-lock! mult
4e50: 69 2d 72 75 6e 2d 6d 75 74 65 78 29 0a 09 09 09 i-run-mutex)....
4e60: 09 09 20 20 20 28 73 65 74 21 20 72 65 73 75 6c .. (set! resul
4e70: 74 20 28 61 70 70 65 6e 64 20 72 65 73 75 6c 74 t (append result
4e80: 20 72 65 73 29 29 0a 09 09 09 09 09 20 20 20 28 res))...... (
4e90: 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 6d 75 mutex-unlock! mu
4ea0: 6c 74 69 2d 72 75 6e 2d 6d 75 74 65 78 29 29 0a lti-run-mutex)).
4eb0: 09 09 09 09 09 20 28 64 65 62 75 67 3a 70 72 69 ..... (debug:pri
4ec0: 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 nt-error 0 *defa
4ed0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 67 ult-log-port* "g
4ee0: 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e et-tests-for-run
4ef0: 2d 6d 69 6e 64 61 74 61 20 66 61 69 6c 65 64 20 -mindata failed
4f00: 66 6f 72 20 72 75 6e 2d 69 64 20 22 20 68 65 64 for run-id " hed
4f10: 20 22 2c 20 74 65 73 74 70 61 74 74 20 22 20 74 ", testpatt " t
4f20: 65 73 74 70 61 74 74 20 22 2c 20 73 74 61 74 65 estpatt ", state
4f30: 73 20 22 20 73 74 61 74 65 73 20 22 2c 20 73 74 s " states ", st
4f40: 61 74 75 73 20 22 20 73 74 61 74 75 73 20 22 2c atus " status ",
4f50: 20 6e 6f 74 2d 69 6e 20 22 20 6e 6f 74 2d 69 6e not-in " not-in
4f60: 29 29 29 29 0a 09 09 09 09 20 28 63 6f 6e 63 20 ))))..... (conc
4f70: 22 6d 75 6c 74 69 2d 72 75 6e 2d 74 68 72 65 61 "multi-run-threa
4f80: 64 20 66 6f 72 20 72 75 6e 2d 69 64 20 22 20 68 d for run-id " h
4f90: 65 64 29 29 29 0a 09 09 20 20 20 20 20 28 6e 65 ed)))... (ne
4fa0: 77 74 68 72 65 61 64 73 20 28 63 6f 6e 73 20 6e wthreads (cons n
4fb0: 65 77 74 68 72 65 61 64 20 74 68 72 65 61 64 73 ewthread threads
4fc0: 29 29 29 0a 09 09 28 74 68 72 65 61 64 2d 73 74 )))...(thread-st
4fd0: 61 72 74 21 20 6e 65 77 74 68 72 65 61 64 29 0a art! newthread).
4fe0: 09 09 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 ..(thread-sleep!
4ff0: 20 30 2e 30 35 29 20 3b 3b 20 67 69 76 65 20 74 0.05) ;; give t
5000: 68 61 74 20 74 68 72 65 61 64 20 73 6f 6d 65 20 hat thread some
5010: 74 69 6d 65 20 74 6f 20 73 74 61 72 74 0a 09 09 time to start...
5020: 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a (if (null? tal).
5030: 09 09 20 20 20 20 6e 65 77 74 68 72 65 61 64 73 .. newthreads
5040: 0a 09 09 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 ... (loop (ca
5050: 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 20 r tal)(cdr tal)
5060: 6e 65 77 74 68 72 65 61 64 73 29 29 29 29 29 29 newthreads))))))
5070: 0a 20 20 20 20 72 65 73 75 6c 74 29 29 0a 0a 3b . result))..;
5080: 3b 20 3b 3b 20 49 44 45 41 3a 20 54 68 72 65 61 ; ;; IDEA: Threa
5090: 64 69 66 79 20 74 68 65 73 65 20 2d 20 74 68 65 dify these - the
50a0: 79 20 73 70 65 6e 64 20 61 20 6c 6f 74 20 6f 66 y spend a lot of
50b0: 20 74 69 6d 65 20 77 61 69 74 69 6e 67 20 2e 2e time waiting ..
50c0: 2e 0a 3b 3b 20 3b 3b 0a 3b 3b 20 28 64 65 66 69 ..;; ;;.;; (defi
50d0: 6e 65 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 ne (rmt:get-test
50e0: 73 2d 66 6f 72 2d 72 75 6e 73 2d 6d 69 6e 64 61 s-for-runs-minda
50f0: 74 61 20 72 75 6e 2d 69 64 73 20 74 65 73 74 70 ta run-ids testp
5100: 61 74 74 20 73 74 61 74 65 73 20 73 74 61 74 75 att states statu
5110: 73 20 6e 6f 74 2d 69 6e 29 0a 3b 3b 20 20 20 28 s not-in).;; (
5120: 6c 65 74 20 28 28 72 75 6e 2d 69 64 2d 6c 69 73 let ((run-id-lis
5130: 74 20 28 69 66 20 72 75 6e 2d 69 64 73 0a 3b 3b t (if run-ids.;;
5140: 20 09 09 09 20 72 75 6e 2d 69 64 73 0a 3b 3b 20 ... run-ids.;;
5150: 09 09 09 20 28 72 6d 74 3a 67 65 74 2d 61 6c 6c ... (rmt:get-all
5160: 2d 72 75 6e 2d 69 64 73 29 29 29 29 0a 3b 3b 20 -run-ids)))).;;
5170: 20 20 20 20 28 61 70 70 6c 79 20 61 70 70 65 6e (apply appen
5180: 64 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 d (map (lambda (
5190: 72 75 6e 2d 69 64 29 0a 3b 3b 20 09 09 09 20 28 run-id).;; ... (
51a0: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
51b0: 20 27 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 'get-tests-for-
51c0: 72 75 6e 2d 6d 69 6e 64 61 74 61 20 72 75 6e 2d run-mindata run-
51d0: 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 73 id (list run-ids
51e0: 20 74 65 73 74 70 61 74 74 20 73 74 61 74 65 73 testpatt states
51f0: 20 73 74 61 74 75 73 20 6e 6f 74 2d 69 6e 29 29 status not-in))
5200: 29 0a 3b 3b 20 09 09 20 20 20 20 20 20 20 72 75 ).;; .. ru
5210: 6e 2d 69 64 2d 6c 69 73 74 29 29 29 29 0a 0a 28 n-id-list))))..(
5220: 64 65 66 69 6e 65 20 28 72 6d 74 3a 64 65 6c 65 define (rmt:dele
5230: 74 65 2d 74 65 73 74 2d 72 65 63 6f 72 64 73 20 te-test-records
5240: 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 0a run-id test-id).
5250: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
5260: 69 76 65 20 27 64 65 6c 65 74 65 2d 74 65 73 74 ive 'delete-test
5270: 2d 72 65 63 6f 72 64 73 20 72 75 6e 2d 69 64 20 -records run-id
5280: 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 (list run-id tes
5290: 74 2d 69 64 29 29 29 0a 0a 3b 3b 20 54 68 69 73 t-id)))..;; This
52a0: 20 69 73 20 6e 6f 74 20 6e 65 65 64 65 64 20 61 is not needed a
52b0: 73 20 74 65 73 74 20 73 74 65 70 73 20 61 72 65 s test steps are
52c0: 20 64 65 6c 65 74 65 64 20 6f 6e 20 74 65 73 74 deleted on test
52d0: 20 64 65 6c 65 74 65 20 63 61 6c 6c 0a 3b 3b 0a delete call.;;.
52e0: 3b 3b 20 28 64 65 66 69 6e 65 20 28 72 6d 74 3a ;; (define (rmt:
52f0: 64 65 6c 65 74 65 2d 74 65 73 74 2d 73 74 65 70 delete-test-step
5300: 2d 72 65 63 6f 72 64 73 20 72 75 6e 2d 69 64 20 -records run-id
5310: 74 65 73 74 2d 69 64 29 0a 3b 3b 20 20 20 28 72 test-id).;; (r
5320: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
5330: 27 64 65 6c 65 74 65 2d 74 65 73 74 2d 73 74 65 'delete-test-ste
5340: 70 2d 72 65 63 6f 72 64 73 20 72 75 6e 2d 69 64 p-records run-id
5350: 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 (list run-id te
5360: 73 74 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 6e st-id)))..(defin
5370: 65 20 28 72 6d 74 3a 74 65 73 74 2d 73 65 74 2d e (rmt:test-set-
5380: 73 74 61 74 75 73 2d 73 74 61 74 65 20 72 75 6e status-state run
5390: 2d 69 64 20 74 65 73 74 2d 69 64 20 73 74 61 74 -id test-id stat
53a0: 75 73 20 73 74 61 74 65 20 6d 73 67 29 0a 20 20 us state msg).
53b0: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
53c0: 65 20 27 74 65 73 74 2d 73 65 74 2d 73 74 61 74 e 'test-set-stat
53d0: 75 73 2d 73 74 61 74 65 20 72 75 6e 2d 69 64 20 us-state run-id
53e0: 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 (list run-id tes
53f0: 74 2d 69 64 20 73 74 61 74 75 73 20 73 74 61 74 t-id status stat
5400: 65 20 6d 73 67 29 29 29 0a 0a 28 64 65 66 69 6e e msg)))..(defin
5410: 65 20 28 72 6d 74 3a 74 65 73 74 2d 74 6f 70 6c e (rmt:test-topl
5420: 65 76 65 6c 2d 6e 75 6d 2d 69 74 65 6d 73 20 72 evel-num-items r
5430: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 29 un-id test-name)
5440: 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 . (rmt:send-rec
5450: 65 69 76 65 20 27 74 65 73 74 2d 74 6f 70 6c 65 eive 'test-tople
5460: 76 65 6c 2d 6e 75 6d 2d 69 74 65 6d 73 20 72 75 vel-num-items ru
5470: 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 n-id (list run-i
5480: 64 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a 0a d test-name)))..
5490: 3b 3b 20 28 64 65 66 69 6e 65 20 28 72 6d 74 3a ;; (define (rmt:
54a0: 67 65 74 2d 70 72 65 76 69 6f 75 73 2d 74 65 73 get-previous-tes
54b0: 74 2d 72 75 6e 2d 72 65 63 6f 72 64 20 72 75 6e t-run-record run
54c0: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 -id test-name it
54d0: 65 6d 2d 70 61 74 68 29 0a 3b 3b 20 20 20 28 72 em-path).;; (r
54e0: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
54f0: 27 67 65 74 2d 70 72 65 76 69 6f 75 73 2d 74 65 'get-previous-te
5500: 73 74 2d 72 75 6e 2d 72 65 63 6f 72 64 20 72 75 st-run-record ru
5510: 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 n-id (list run-i
5520: 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d d test-name item
5530: 2d 70 61 74 68 29 29 29 0a 0a 28 64 65 66 69 6e -path)))..(defin
5540: 65 20 28 72 6d 74 3a 67 65 74 2d 6d 61 74 63 68 e (rmt:get-match
5550: 69 6e 67 2d 70 72 65 76 69 6f 75 73 2d 74 65 73 ing-previous-tes
5560: 74 2d 72 75 6e 2d 72 65 63 6f 72 64 73 20 72 75 t-run-records ru
5570: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 n-id test-name i
5580: 74 65 6d 2d 70 61 74 68 29 0a 20 20 28 72 6d 74 tem-path). (rmt
5590: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 :send-receive 'g
55a0: 65 74 2d 6d 61 74 63 68 69 6e 67 2d 70 72 65 76 et-matching-prev
55b0: 69 6f 75 73 2d 74 65 73 74 2d 72 75 6e 2d 72 65 ious-test-run-re
55c0: 63 6f 72 64 73 20 72 75 6e 2d 69 64 20 28 6c 69 cords run-id (li
55d0: 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e st run-id test-n
55e0: 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 29 ame item-path)))
55f0: 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 ..(define (rmt:t
5600: 65 73 74 2d 67 65 74 2d 6c 6f 67 66 69 6c 65 2d est-get-logfile-
5610: 69 6e 66 6f 20 72 75 6e 2d 69 64 20 74 65 73 74 info run-id test
5620: 2d 6e 61 6d 65 29 0a 20 20 28 72 6d 74 3a 73 65 -name). (rmt:se
5630: 6e 64 2d 72 65 63 65 69 76 65 20 27 74 65 73 74 nd-receive 'test
5640: 2d 67 65 74 2d 6c 6f 67 66 69 6c 65 2d 69 6e 66 -get-logfile-inf
5650: 6f 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 o run-id (list r
5660: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 29 un-id test-name)
5670: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
5680: 3a 74 65 73 74 2d 67 65 74 2d 72 65 63 6f 72 64 :test-get-record
5690: 73 2d 66 6f 72 2d 69 6e 64 65 78 2d 66 69 6c 65 s-for-index-file
56a0: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
56b0: 65 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 e). (rmt:send-r
56c0: 65 63 65 69 76 65 20 27 74 65 73 74 2d 67 65 74 eceive 'test-get
56d0: 2d 72 65 63 6f 72 64 73 2d 66 6f 72 2d 69 6e 64 -records-for-ind
56e0: 65 78 2d 66 69 6c 65 20 72 75 6e 2d 69 64 20 28 ex-file run-id (
56f0: 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 list run-id test
5700: 2d 6e 61 6d 65 29 29 29 0a 0a 28 64 65 66 69 6e -name)))..(defin
5710: 65 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 69 e (rmt:get-testi
5720: 6e 66 6f 2d 73 74 61 74 65 2d 73 74 61 74 75 73 nfo-state-status
5730: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 run-id test-id)
5740: 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 . (rmt:send-rec
5750: 65 69 76 65 20 27 67 65 74 2d 74 65 73 74 69 6e eive 'get-testin
5760: 66 6f 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 fo-state-status
5770: 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e run-id (list run
5780: 2d 69 64 20 74 65 73 74 2d 69 64 29 29 29 0a 0a -id test-id)))..
5790: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 65 73 (define (rmt:tes
57a0: 74 2d 73 65 74 2d 6c 6f 67 21 20 72 75 6e 2d 69 t-set-log! run-i
57b0: 64 20 74 65 73 74 2d 69 64 20 6c 6f 67 66 29 0a d test-id logf).
57c0: 20 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 6c (if (string? l
57d0: 6f 67 66 29 28 72 6d 74 3a 67 65 6e 65 72 61 6c ogf)(rmt:general
57e0: 2d 63 61 6c 6c 20 27 74 65 73 74 2d 73 65 74 2d -call 'test-set-
57f0: 6c 6f 67 20 72 75 6e 2d 69 64 20 6c 6f 67 66 20 log run-id logf
5800: 74 65 73 74 2d 69 64 29 29 29 0a 0a 28 64 65 66 test-id)))..(def
5810: 69 6e 65 20 28 72 6d 74 3a 74 65 73 74 2d 73 65 ine (rmt:test-se
5820: 74 2d 74 6f 70 2d 70 72 6f 63 65 73 73 2d 70 69 t-top-process-pi
5830: 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 d run-id test-id
5840: 20 70 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e pid). (rmt:sen
5850: 64 2d 72 65 63 65 69 76 65 20 27 74 65 73 74 2d d-receive 'test-
5860: 73 65 74 2d 74 6f 70 2d 70 72 6f 63 65 73 73 2d set-top-process-
5870: 70 69 64 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 pid run-id (list
5880: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 run-id test-id
5890: 70 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 pid)))..(define
58a0: 28 72 6d 74 3a 74 65 73 74 2d 67 65 74 2d 74 6f (rmt:test-get-to
58b0: 70 2d 70 72 6f 63 65 73 73 2d 70 69 64 20 72 75 p-process-pid ru
58c0: 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 0a 20 20 n-id test-id).
58d0: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
58e0: 65 20 27 74 65 73 74 2d 67 65 74 2d 74 6f 70 2d e 'test-get-top-
58f0: 70 72 6f 63 65 73 73 2d 70 69 64 20 72 75 6e 2d process-pid run-
5900: 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 id (list run-id
5910: 74 65 73 74 2d 69 64 29 29 29 0a 0a 28 64 65 66 test-id)))..(def
5920: 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e ine (rmt:get-run
5930: 2d 69 64 73 2d 6d 61 74 63 68 69 6e 67 2d 74 61 -ids-matching-ta
5940: 72 67 65 74 20 6b 65 79 6e 61 6d 65 73 20 74 61 rget keynames ta
5950: 72 67 65 74 20 72 65 73 20 72 75 6e 6e 61 6d 65 rget res runname
5960: 20 74 65 73 74 70 61 74 74 20 73 74 61 74 65 70 testpatt statep
5970: 61 74 74 20 73 74 61 74 75 73 70 61 74 74 29 0a att statuspatt).
5980: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
5990: 69 76 65 20 27 67 65 74 2d 72 75 6e 2d 69 64 73 ive 'get-run-ids
59a0: 2d 6d 61 74 63 68 69 6e 67 2d 74 61 72 67 65 74 -matching-target
59b0: 20 23 66 20 28 6c 69 73 74 20 6b 65 79 6e 61 6d #f (list keynam
59c0: 65 73 20 74 61 72 67 65 74 20 72 65 73 20 72 75 es target res ru
59d0: 6e 6e 61 6d 65 20 74 65 73 74 70 61 74 74 20 73 nname testpatt s
59e0: 74 61 74 65 70 61 74 74 20 73 74 61 74 75 73 70 tatepatt statusp
59f0: 61 74 74 29 29 29 0a 0a 3b 3b 20 4e 4f 54 45 3a att)))..;; NOTE:
5a00: 20 54 68 69 73 20 77 69 6c 6c 20 6f 70 65 6e 20 This will open
5a10: 61 6e 64 20 61 63 63 65 73 73 20 41 4c 4c 20 72 and access ALL r
5a20: 75 6e 20 64 61 74 61 62 61 73 65 73 2e 20 0a 3b un databases. .;
5a30: 3b 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 ;.(define (rmt:t
5a40: 65 73 74 2d 67 65 74 2d 70 61 74 68 73 2d 6d 61 est-get-paths-ma
5a50: 74 63 68 69 6e 67 2d 6b 65 79 6e 61 6d 65 73 2d tching-keynames-
5a60: 74 61 72 67 65 74 2d 6e 65 77 20 6b 65 79 6e 61 target-new keyna
5a70: 6d 65 73 20 74 61 72 67 65 74 20 72 65 73 20 74 mes target res t
5a80: 65 73 74 70 61 74 74 20 73 74 61 74 65 70 61 74 estpatt statepat
5a90: 74 20 73 74 61 74 75 73 70 61 74 74 20 72 75 6e t statuspatt run
5aa0: 6e 61 6d 65 29 0a 20 20 28 6c 65 74 20 28 28 72 name). (let ((r
5ab0: 75 6e 2d 69 64 73 20 28 72 6d 74 3a 67 65 74 2d un-ids (rmt:get-
5ac0: 72 75 6e 2d 69 64 73 2d 6d 61 74 63 68 69 6e 67 run-ids-matching
5ad0: 2d 74 61 72 67 65 74 20 6b 65 79 6e 61 6d 65 73 -target keynames
5ae0: 20 74 61 72 67 65 74 20 72 65 73 20 72 75 6e 6e target res runn
5af0: 61 6d 65 20 74 65 73 74 70 61 74 74 20 73 74 61 ame testpatt sta
5b00: 74 65 70 61 74 74 20 73 74 61 74 75 73 70 61 74 tepatt statuspat
5b10: 74 29 29 29 0a 20 20 20 20 28 61 70 70 6c 79 20 t))). (apply
5b20: 61 70 70 65 6e 64 20 0a 09 20 20 20 28 6d 61 70 append .. (map
5b30: 20 28 6c 61 6d 62 64 61 20 28 72 75 6e 2d 69 64 (lambda (run-id
5b40: 29 0a 09 09 20 20 28 72 6d 74 3a 73 65 6e 64 2d )... (rmt:send-
5b50: 72 65 63 65 69 76 65 20 27 74 65 73 74 2d 67 65 receive 'test-ge
5b60: 74 2d 70 61 74 68 73 2d 6d 61 74 63 68 69 6e 67 t-paths-matching
5b70: 2d 6b 65 79 6e 61 6d 65 73 2d 74 61 72 67 65 74 -keynames-target
5b80: 2d 6e 65 77 20 72 75 6e 2d 69 64 20 28 6c 69 73 -new run-id (lis
5b90: 74 20 72 75 6e 2d 69 64 20 6b 65 79 6e 61 6d 65 t run-id keyname
5ba0: 73 20 74 61 72 67 65 74 20 72 65 73 20 74 65 73 s target res tes
5bb0: 74 70 61 74 74 20 73 74 61 74 65 70 61 74 74 20 tpatt statepatt
5bc0: 73 74 61 74 75 73 70 61 74 74 20 72 75 6e 6e 61 statuspatt runna
5bd0: 6d 65 29 29 29 0a 09 20 20 20 72 75 6e 2d 69 64 me))).. run-id
5be0: 73 29 29 29 29 0a 0a 3b 3b 20 28 64 65 66 69 6e s))))..;; (defin
5bf0: 65 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e 2d 69 e (rmt:get-run-i
5c00: 64 73 2d 6d 61 74 63 68 69 6e 67 20 6b 65 79 6e ds-matching keyn
5c10: 61 6d 65 73 20 74 61 72 67 65 74 20 72 65 73 29 ames target res)
5c20: 0a 3b 3b 20 20 20 28 72 6d 74 3a 73 65 6e 64 2d .;; (rmt:send-
5c30: 72 65 63 65 69 76 65 20 23 66 20 27 67 65 74 2d receive #f 'get-
5c40: 72 75 6e 2d 69 64 73 2d 6d 61 74 63 68 69 6e 67 run-ids-matching
5c50: 20 28 6c 69 73 74 20 6b 65 79 6e 61 6d 65 73 20 (list keynames
5c60: 74 61 72 67 65 74 20 72 65 73 29 29 29 0a 0a 28 target res)))..(
5c70: 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d define (rmt:get-
5c80: 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 prereqs-not-met
5c90: 72 75 6e 2d 69 64 20 77 61 69 74 6f 6e 73 20 72 run-id waitons r
5ca0: 65 66 2d 74 65 73 74 2d 6e 61 6d 65 20 72 65 66 ef-test-name ref
5cb0: 2d 69 74 65 6d 2d 70 61 74 68 20 23 21 6b 65 79 -item-path #!key
5cc0: 20 28 6d 6f 64 65 20 27 28 6e 6f 72 6d 61 6c 29 (mode '(normal)
5cd0: 29 28 69 74 65 6d 6d 61 70 73 20 23 66 29 29 0a )(itemmaps #f)).
5ce0: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
5cf0: 69 76 65 20 27 67 65 74 2d 70 72 65 72 65 71 73 ive 'get-prereqs
5d00: 2d 6e 6f 74 2d 6d 65 74 20 72 75 6e 2d 69 64 20 -not-met run-id
5d10: 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 77 61 69 (list run-id wai
5d20: 74 6f 6e 73 20 72 65 66 2d 74 65 73 74 2d 6e 61 tons ref-test-na
5d30: 6d 65 20 72 65 66 2d 69 74 65 6d 2d 70 61 74 68 me ref-item-path
5d40: 20 6d 6f 64 65 20 69 74 65 6d 6d 61 70 73 29 29 mode itemmaps))
5d50: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a )..(define (rmt:
5d60: 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d get-count-tests-
5d70: 72 75 6e 6e 69 6e 67 2d 66 6f 72 2d 72 75 6e 2d running-for-run-
5d80: 69 64 20 72 75 6e 2d 69 64 29 0a 20 20 28 72 6d id run-id). (rm
5d90: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
5da0: 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d get-count-tests-
5db0: 72 75 6e 6e 69 6e 67 2d 66 6f 72 2d 72 75 6e 2d running-for-run-
5dc0: 69 64 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 id run-id (list
5dd0: 72 75 6e 2d 69 64 29 29 29 0a 0a 3b 3b 20 53 74 run-id)))..;; St
5de0: 61 74 69 73 74 69 63 61 6c 20 71 75 65 72 69 65 atistical querie
5df0: 73 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a s..(define (rmt:
5e00: 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d get-count-tests-
5e10: 72 75 6e 6e 69 6e 67 20 72 75 6e 2d 69 64 29 0a running run-id).
5e20: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
5e30: 69 76 65 20 27 67 65 74 2d 63 6f 75 6e 74 2d 74 ive 'get-count-t
5e40: 65 73 74 73 2d 72 75 6e 6e 69 6e 67 20 72 75 6e ests-running run
5e50: 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 -id (list run-id
5e60: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d )))..(define (rm
5e70: 74 3a 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 t:get-count-test
5e80: 73 2d 72 75 6e 6e 69 6e 67 2d 66 6f 72 2d 74 65 s-running-for-te
5e90: 73 74 6e 61 6d 65 20 72 75 6e 2d 69 64 20 74 65 stname run-id te
5ea0: 73 74 6e 61 6d 65 29 0a 20 20 28 72 6d 74 3a 73 stname). (rmt:s
5eb0: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 end-receive 'get
5ec0: 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e -count-tests-run
5ed0: 6e 69 6e 67 2d 66 6f 72 2d 74 65 73 74 6e 61 6d ning-for-testnam
5ee0: 65 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 e run-id (list r
5ef0: 75 6e 2d 69 64 20 74 65 73 74 6e 61 6d 65 29 29 un-id testname))
5f00: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a )..(define (rmt:
5f10: 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d get-count-tests-
5f20: 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 running-in-jobgr
5f30: 6f 75 70 20 72 75 6e 2d 69 64 20 6a 6f 62 67 72 oup run-id jobgr
5f40: 6f 75 70 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 oup). (rmt:send
5f50: 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 63 6f -receive 'get-co
5f60: 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e unt-tests-runnin
5f70: 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 72 75 g-in-jobgroup ru
5f80: 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 n-id (list run-i
5f90: 64 20 6a 6f 62 67 72 6f 75 70 29 29 29 0a 0a 3b d jobgroup)))..;
5fa0: 3b 20 73 74 61 74 65 20 61 6e 64 20 73 74 61 74 ; state and stat
5fb0: 75 73 20 61 72 65 20 65 78 74 72 61 20 68 69 6e us are extra hin
5fc0: 74 73 20 6e 6f 74 20 75 73 75 61 6c 6c 79 20 75 ts not usually u
5fd0: 73 65 64 20 69 6e 20 74 68 65 20 63 61 6c 63 75 sed in the calcu
5fe0: 6c 61 74 69 6f 6e 0a 3b 3b 0a 28 64 65 66 69 6e lation.;;.(defin
5ff0: 65 20 28 72 6d 74 3a 72 6f 6c 6c 2d 75 70 2d 70 e (rmt:roll-up-p
6000: 61 73 73 2d 66 61 69 6c 2d 63 6f 75 6e 74 73 20 ass-fail-counts
6010: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
6020: 20 69 74 65 6d 2d 70 61 74 68 20 73 74 61 74 65 item-path state
6030: 20 73 74 61 74 75 73 20 63 6f 6d 6d 65 6e 74 29 status comment)
6040: 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 . (rmt:send-rec
6050: 65 69 76 65 20 27 72 6f 6c 6c 2d 75 70 2d 70 61 eive 'roll-up-pa
6060: 73 73 2d 66 61 69 6c 2d 63 6f 75 6e 74 73 20 72 ss-fail-counts r
6070: 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d un-id (list run-
6080: 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 id test-name ite
6090: 6d 2d 70 61 74 68 20 73 74 61 74 65 20 73 74 61 m-path state sta
60a0: 74 75 73 20 63 6f 6d 6d 65 6e 74 29 29 29 0a 0a tus comment)))..
60b0: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 75 70 64 (define (rmt:upd
60c0: 61 74 65 2d 70 61 73 73 2d 66 61 69 6c 2d 63 6f ate-pass-fail-co
60d0: 75 6e 74 73 20 72 75 6e 2d 69 64 20 74 65 73 74 unts run-id test
60e0: 2d 6e 61 6d 65 29 0a 20 20 28 72 6d 74 3a 67 65 -name). (rmt:ge
60f0: 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 75 70 64 61 neral-call 'upda
6100: 74 65 2d 70 61 73 73 2d 66 61 69 6c 2d 63 6f 75 te-pass-fail-cou
6110: 6e 74 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d nts run-id test-
6120: 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 74 name test-name t
6130: 65 73 74 2d 6e 61 6d 65 29 29 0a 0a 28 64 65 66 est-name))..(def
6140: 69 6e 65 20 28 72 6d 74 3a 74 6f 70 2d 74 65 73 ine (rmt:top-tes
6150: 74 2d 73 65 74 2d 70 65 72 2d 70 66 2d 63 6f 75 t-set-per-pf-cou
6160: 6e 74 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d nts run-id test-
6170: 6e 61 6d 65 29 0a 20 20 28 72 6d 74 3a 73 65 6e name). (rmt:sen
6180: 64 2d 72 65 63 65 69 76 65 20 27 74 6f 70 2d 74 d-receive 'top-t
6190: 65 73 74 2d 73 65 74 2d 70 65 72 2d 70 66 2d 63 est-set-per-pf-c
61a0: 6f 75 6e 74 73 20 72 75 6e 2d 69 64 20 28 6c 69 ounts run-id (li
61b0: 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e st run-id test-n
61c0: 61 6d 65 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ame)))..(define
61d0: 28 72 6d 74 3a 67 65 74 2d 72 61 77 2d 72 75 6e (rmt:get-raw-run
61e0: 2d 73 74 61 74 73 20 72 75 6e 2d 69 64 29 0a 20 -stats run-id).
61f0: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
6200: 76 65 20 27 67 65 74 2d 72 61 77 2d 72 75 6e 2d ve 'get-raw-run-
6210: 73 74 61 74 73 20 72 75 6e 2d 69 64 20 28 6c 69 stats run-id (li
6220: 73 74 20 72 75 6e 2d 69 64 29 29 29 0a 0a 3b 3b st run-id)))..;;
6230: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6240: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6250: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6260: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6270: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 52 20 55 20 4e ======.;; R U N
6280: 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d S.;;===========
6290: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
62a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
62b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
62c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 ===========..(de
62d0: 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 72 75 fine (rmt:get-ru
62e0: 6e 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 29 0a 20 n-info run-id).
62f0: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
6300: 76 65 20 27 67 65 74 2d 72 75 6e 2d 69 6e 66 6f ve 'get-run-info
6310: 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 run-id (list ru
6320: 6e 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 n-id)))..(define
6330: 20 28 72 6d 74 3a 67 65 74 2d 6e 75 6d 2d 72 75 (rmt:get-num-ru
6340: 6e 73 20 72 75 6e 70 61 74 74 29 0a 20 20 28 72 ns runpatt). (r
6350: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
6360: 27 67 65 74 2d 6e 75 6d 2d 72 75 6e 73 20 23 66 'get-num-runs #f
6370: 20 28 6c 69 73 74 20 72 75 6e 70 61 74 74 29 29 (list runpatt))
6380: 29 0a 0a 3b 3b 20 55 73 65 20 74 68 65 20 73 70 )..;; Use the sp
6390: 65 63 69 61 6c 20 72 75 6e 2d 69 64 20 3d 3d 20 ecial run-id ==
63a0: 23 66 20 73 63 65 6e 61 72 69 6f 20 68 65 72 65 #f scenario here
63b0: 20 73 69 6e 63 65 20 74 68 65 72 65 20 69 73 20 since there is
63c0: 6e 6f 20 72 75 6e 20 79 65 74 0a 28 64 65 66 69 no run yet.(defi
63d0: 6e 65 20 28 72 6d 74 3a 72 65 67 69 73 74 65 72 ne (rmt:register
63e0: 2d 72 75 6e 20 6b 65 79 76 61 6c 73 20 72 75 6e -run keyvals run
63f0: 6e 61 6d 65 20 73 74 61 74 65 20 73 74 61 74 75 name state statu
6400: 73 20 75 73 65 72 29 0a 20 20 28 72 6d 74 3a 73 s user). (rmt:s
6410: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 72 65 67 end-receive 'reg
6420: 69 73 74 65 72 2d 72 75 6e 20 23 66 20 28 6c 69 ister-run #f (li
6430: 73 74 20 6b 65 79 76 61 6c 73 20 72 75 6e 6e 61 st keyvals runna
6440: 6d 65 20 73 74 61 74 65 20 73 74 61 74 75 73 20 me state status
6450: 75 73 65 72 29 29 29 0a 20 20 20 20 0a 28 64 65 user))). .(de
6460: 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 72 75 fine (rmt:get-ru
6470: 6e 2d 6e 61 6d 65 2d 66 72 6f 6d 2d 69 64 20 72 n-name-from-id r
6480: 75 6e 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 un-id). (rmt:se
6490: 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d nd-receive 'get-
64a0: 72 75 6e 2d 6e 61 6d 65 2d 66 72 6f 6d 2d 69 64 run-name-from-id
64b0: 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 run-id (list ru
64c0: 6e 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 n-id)))..(define
64d0: 20 28 72 6d 74 3a 64 65 6c 65 74 65 2d 72 75 6e (rmt:delete-run
64e0: 20 72 75 6e 2d 69 64 29 0a 20 20 28 72 6d 74 3a run-id). (rmt:
64f0: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 64 65 send-receive 'de
6500: 6c 65 74 65 2d 72 75 6e 20 72 75 6e 2d 69 64 20 lete-run run-id
6510: 28 6c 69 73 74 20 72 75 6e 2d 69 64 29 29 29 0a (list run-id))).
6520: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 75 70 .(define (rmt:up
6530: 64 61 74 65 2d 72 75 6e 2d 73 74 61 74 73 20 72 date-run-stats r
6540: 75 6e 2d 69 64 20 73 74 61 74 73 29 0a 20 20 28 un-id stats). (
6550: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
6560: 20 27 75 70 64 61 74 65 2d 72 75 6e 2d 73 74 61 'update-run-sta
6570: 74 73 20 23 66 20 28 6c 69 73 74 20 72 75 6e 2d ts #f (list run-
6580: 69 64 20 73 74 61 74 73 29 29 29 0a 0a 28 64 65 id stats)))..(de
6590: 66 69 6e 65 20 28 72 6d 74 3a 64 65 6c 65 74 65 fine (rmt:delete
65a0: 2d 6f 6c 64 2d 64 65 6c 65 74 65 64 2d 74 65 73 -old-deleted-tes
65b0: 74 2d 72 65 63 6f 72 64 73 29 0a 20 20 28 72 6d t-records). (rm
65c0: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
65d0: 64 65 6c 65 74 65 2d 6f 6c 64 2d 64 65 6c 65 74 delete-old-delet
65e0: 65 64 2d 74 65 73 74 2d 72 65 63 6f 72 64 73 20 ed-test-records
65f0: 23 66 20 27 28 29 29 29 0a 0a 28 64 65 66 69 6e #f '()))..(defin
6600: 65 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e 73 20 e (rmt:get-runs
6610: 72 75 6e 70 61 74 74 20 63 6f 75 6e 74 20 6f 66 runpatt count of
6620: 66 73 65 74 20 6b 65 79 70 61 74 74 73 29 0a 20 fset keypatts).
6630: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
6640: 76 65 20 27 67 65 74 2d 72 75 6e 73 20 23 66 20 ve 'get-runs #f
6650: 28 6c 69 73 74 20 72 75 6e 70 61 74 74 20 63 6f (list runpatt co
6660: 75 6e 74 20 6f 66 66 73 65 74 20 6b 65 79 70 61 unt offset keypa
6670: 74 74 73 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 tts)))..(define
6680: 28 72 6d 74 3a 67 65 74 2d 61 6c 6c 2d 72 75 6e (rmt:get-all-run
6690: 2d 69 64 73 29 0a 20 20 28 72 6d 74 3a 73 65 6e -ids). (rmt:sen
66a0: 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 61 d-receive 'get-a
66b0: 6c 6c 2d 72 75 6e 2d 69 64 73 20 23 66 20 27 28 ll-run-ids #f '(
66c0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d )))..(define (rm
66d0: 74 3a 67 65 74 2d 70 72 65 76 2d 72 75 6e 2d 69 t:get-prev-run-i
66e0: 64 73 20 72 75 6e 2d 69 64 29 0a 20 20 28 72 6d ds run-id). (rm
66f0: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
6700: 67 65 74 2d 70 72 65 76 2d 72 75 6e 2d 69 64 73 get-prev-run-ids
6710: 20 23 66 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 #f (list run-id
6720: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d )))..(define (rm
6730: 74 3a 6c 6f 63 6b 2f 75 6e 6c 6f 63 6b 2d 72 75 t:lock/unlock-ru
6740: 6e 20 72 75 6e 2d 69 64 20 6c 6f 63 6b 20 75 6e n run-id lock un
6750: 6c 6f 63 6b 20 75 73 65 72 29 0a 20 20 28 72 6d lock user). (rm
6760: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
6770: 6c 6f 63 6b 2f 75 6e 6c 6f 63 6b 2d 72 75 6e 20 lock/unlock-run
6780: 23 66 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 #f (list run-id
6790: 6c 6f 63 6b 20 75 6e 6c 6f 63 6b 20 75 73 65 72 lock unlock user
67a0: 29 29 29 0a 0a 3b 3b 20 73 65 74 2f 67 65 74 20 )))..;; set/get
67b0: 73 74 61 74 75 73 0a 28 64 65 66 69 6e 65 20 28 status.(define (
67c0: 72 6d 74 3a 67 65 74 2d 72 75 6e 2d 73 74 61 74 rmt:get-run-stat
67d0: 75 73 20 72 75 6e 2d 69 64 29 0a 20 20 28 72 6d us run-id). (rm
67e0: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
67f0: 67 65 74 2d 72 75 6e 2d 73 74 61 74 75 73 20 23 get-run-status #
6800: 66 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 29 29 f (list run-id))
6810: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a )..(define (rmt:
6820: 73 65 74 2d 72 75 6e 2d 73 74 61 74 75 73 20 72 set-run-status r
6830: 75 6e 2d 69 64 20 72 75 6e 2d 73 74 61 74 75 73 un-id run-status
6840: 20 23 21 6b 65 79 20 28 6d 73 67 20 23 66 29 29 #!key (msg #f))
6850: 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 . (rmt:send-rec
6860: 65 69 76 65 20 27 73 65 74 2d 72 75 6e 2d 73 74 eive 'set-run-st
6870: 61 74 75 73 20 23 66 20 28 6c 69 73 74 20 72 75 atus #f (list ru
6880: 6e 2d 69 64 20 72 75 6e 2d 73 74 61 74 75 73 20 n-id run-status
6890: 6d 73 67 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 msg)))..(define
68a0: 28 72 6d 74 3a 75 70 64 61 74 65 2d 72 75 6e 2d (rmt:update-run-
68b0: 65 76 65 6e 74 5f 74 69 6d 65 20 72 75 6e 2d 69 event_time run-i
68c0: 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 d). (rmt:send-r
68d0: 65 63 65 69 76 65 20 27 75 70 64 61 74 65 2d 72 eceive 'update-r
68e0: 75 6e 2d 65 76 65 6e 74 5f 74 69 6d 65 20 23 66 un-event_time #f
68f0: 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 29 29 29 (list run-id)))
6900: 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 ..(define (rmt:g
6910: 65 74 2d 72 75 6e 73 2d 62 79 2d 70 61 74 74 20 et-runs-by-patt
6920: 20 6b 65 79 73 20 72 75 6e 6e 61 6d 65 70 61 74 keys runnamepat
6930: 74 20 74 61 72 67 70 61 74 74 20 6f 66 66 73 65 t targpatt offse
6940: 74 20 6c 69 6d 69 74 20 66 69 65 6c 64 73 20 6c t limit fields l
6950: 61 73 74 2d 72 75 6e 73 2d 75 70 64 61 74 65 29 ast-runs-update)
6960: 20 3b 3b 20 66 69 65 6c 64 73 20 6f 66 20 23 66 ;; fields of #f
6970: 20 75 73 65 73 20 64 65 66 61 75 6c 74 0a 20 20 uses default.
6980: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
6990: 65 20 27 67 65 74 2d 72 75 6e 73 2d 62 79 2d 70 e 'get-runs-by-p
69a0: 61 74 74 20 23 66 20 28 6c 69 73 74 20 6b 65 79 att #f (list key
69b0: 73 20 72 75 6e 6e 61 6d 65 70 61 74 74 20 74 61 s runnamepatt ta
69c0: 72 67 70 61 74 74 20 6f 66 66 73 65 74 20 6c 69 rgpatt offset li
69d0: 6d 69 74 20 66 69 65 6c 64 73 20 6c 61 73 74 2d mit fields last-
69e0: 72 75 6e 73 2d 75 70 64 61 74 65 29 29 29 0a 0a runs-update)))..
69f0: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 66 69 6e (define (rmt:fin
6a00: 64 2d 61 6e 64 2d 6d 61 72 6b 2d 69 6e 63 6f 6d d-and-mark-incom
6a10: 70 6c 65 74 65 20 72 75 6e 2d 69 64 20 6f 76 72 plete run-id ovr
6a20: 2d 64 65 61 64 74 69 6d 65 29 0a 20 20 28 69 66 -deadtime). (if
6a30: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
6a40: 76 65 20 27 68 61 76 65 2d 69 6e 63 6f 6d 70 6c ve 'have-incompl
6a50: 65 74 65 73 3f 20 72 75 6e 2d 69 64 20 28 6c 69 etes? run-id (li
6a60: 73 74 20 72 75 6e 2d 69 64 20 6f 76 72 2d 64 65 st run-id ovr-de
6a70: 61 64 74 69 6d 65 29 29 0a 20 20 20 20 20 20 28 adtime)). (
6a80: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
6a90: 20 27 6d 61 72 6b 2d 69 6e 63 6f 6d 70 6c 65 74 'mark-incomplet
6aa0: 65 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 e run-id (list r
6ab0: 75 6e 2d 69 64 20 6f 76 72 2d 64 65 61 64 74 69 un-id ovr-deadti
6ac0: 6d 65 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 me))))..(define
6ad0: 28 72 6d 74 3a 67 65 74 2d 6d 61 69 6e 2d 72 75 (rmt:get-main-ru
6ae0: 6e 2d 73 74 61 74 73 20 72 75 6e 2d 69 64 29 0a n-stats run-id).
6af0: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
6b00: 69 76 65 20 27 67 65 74 2d 6d 61 69 6e 2d 72 75 ive 'get-main-ru
6b10: 6e 2d 73 74 61 74 73 20 23 66 20 28 6c 69 73 74 n-stats #f (list
6b20: 20 72 75 6e 2d 69 64 29 29 29 0a 0a 28 64 65 66 run-id)))..(def
6b30: 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 76 61 72 ine (rmt:get-var
6b40: 20 76 61 72 6e 61 6d 65 29 0a 20 20 28 72 6d 74 varname). (rmt
6b50: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 :send-receive 'g
6b60: 65 74 2d 76 61 72 20 23 66 20 28 6c 69 73 74 20 et-var #f (list
6b70: 76 61 72 6e 61 6d 65 29 29 29 0a 0a 28 64 65 66 varname)))..(def
6b80: 69 6e 65 20 28 72 6d 74 3a 73 65 74 2d 76 61 72 ine (rmt:set-var
6b90: 20 76 61 72 6e 61 6d 65 20 76 61 6c 75 65 29 0a varname value).
6ba0: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
6bb0: 69 76 65 20 27 73 65 74 2d 76 61 72 20 23 66 20 ive 'set-var #f
6bc0: 28 6c 69 73 74 20 76 61 72 6e 61 6d 65 20 76 61 (list varname va
6bd0: 6c 75 65 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d lue)))..;;======
6be0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6bf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6c00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6c10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6c20: 0a 3b 3b 20 4d 20 55 20 4c 20 54 20 49 20 52 20 .;; M U L T I R
6c30: 55 20 4e 20 20 20 51 20 55 20 45 20 52 20 49 20 U N Q U E R I
6c40: 45 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d E S.;;==========
6c50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6c60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6c70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6c80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b ============..;;
6c90: 20 4e 65 65 64 20 74 6f 20 6d 6f 76 65 20 74 68 Need to move th
6ca0: 69 73 20 74 6f 20 6d 75 6c 74 69 2d 72 75 6e 20 is to multi-run
6cb0: 73 65 63 74 69 6f 6e 20 61 6e 64 20 6d 61 6b 65 section and make
6cc0: 20 61 73 73 6f 63 69 61 74 65 64 20 63 68 61 6e associated chan
6cd0: 67 65 73 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ges.(define (rmt
6ce0: 3a 66 69 6e 64 2d 61 6e 64 2d 6d 61 72 6b 2d 69 :find-and-mark-i
6cf0: 6e 63 6f 6d 70 6c 65 74 65 2d 61 6c 6c 2d 72 75 ncomplete-all-ru
6d00: 6e 73 20 23 21 6b 65 79 20 28 6f 76 72 2d 64 65 ns #!key (ovr-de
6d10: 61 64 74 69 6d 65 20 23 66 29 29 0a 20 20 28 6c adtime #f)). (l
6d20: 65 74 20 28 28 72 75 6e 2d 69 64 73 20 28 72 6d et ((run-ids (rm
6d30: 74 3a 67 65 74 2d 61 6c 6c 2d 72 75 6e 2d 69 64 t:get-all-run-id
6d40: 73 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 s))). (for-ea
6d50: 63 68 20 28 6c 61 6d 62 64 61 20 28 72 75 6e 2d ch (lambda (run-
6d60: 69 64 29 0a 09 20 20 20 20 20 20 20 28 72 6d 74 id).. (rmt
6d70: 3a 66 69 6e 64 2d 61 6e 64 2d 6d 61 72 6b 2d 69 :find-and-mark-i
6d80: 6e 63 6f 6d 70 6c 65 74 65 20 72 75 6e 2d 69 64 ncomplete run-id
6d90: 20 6f 76 72 2d 64 65 61 64 74 69 6d 65 29 29 0a ovr-deadtime)).
6da0: 09 20 20 20 20 20 72 75 6e 2d 69 64 73 29 29 29 . run-ids)))
6db0: 0a 0a 3b 3b 20 67 65 74 20 74 68 65 20 70 72 65 ..;; get the pre
6dc0: 76 69 6f 75 73 20 72 65 63 6f 72 64 20 66 6f 72 vious record for
6dd0: 20 77 68 65 6e 20 74 68 69 73 20 74 65 73 74 20 when this test
6de0: 77 61 73 20 72 75 6e 20 77 68 65 72 65 20 61 6c was run where al
6df0: 6c 20 6b 65 79 73 20 6d 61 74 63 68 20 62 75 74 l keys match but
6e00: 20 72 75 6e 6e 61 6d 65 0a 3b 3b 20 72 65 74 75 runname.;; retu
6e10: 72 6e 73 20 23 66 20 69 66 20 6e 6f 20 73 75 63 rns #f if no suc
6e20: 68 20 74 65 73 74 20 66 6f 75 6e 64 2c 20 72 65 h test found, re
6e30: 74 75 72 6e 73 20 61 20 73 69 6e 67 6c 65 20 74 turns a single t
6e40: 65 73 74 20 72 65 63 6f 72 64 20 69 66 20 66 6f est record if fo
6e50: 75 6e 64 0a 3b 3b 20 0a 3b 3b 20 52 75 6e 20 74 und.;; .;; Run t
6e60: 68 69 73 20 61 74 20 74 68 65 20 63 6c 69 65 6e his at the clien
6e70: 74 20 65 6e 64 20 73 69 6e 63 65 20 77 65 20 68 t end since we h
6e80: 61 76 65 20 74 6f 20 63 6f 6e 6e 65 63 74 20 74 ave to connect t
6e90: 6f 20 6d 75 6c 74 69 70 6c 65 20 72 75 6e 2d 69 o multiple run-i
6ea0: 64 20 64 62 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 d dbs.;;.(define
6eb0: 20 28 72 6d 74 3a 67 65 74 2d 70 72 65 76 69 6f (rmt:get-previo
6ec0: 75 73 2d 74 65 73 74 2d 72 75 6e 2d 72 65 63 6f us-test-run-reco
6ed0: 72 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e rd run-id test-n
6ee0: 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 0a 20 ame item-path).
6ef0: 20 28 6c 65 74 2a 20 28 28 6b 65 79 76 61 6c 73 (let* ((keyvals
6f00: 20 28 72 6d 74 3a 67 65 74 2d 6b 65 79 2d 76 61 (rmt:get-key-va
6f10: 6c 2d 70 61 69 72 73 20 72 75 6e 2d 69 64 29 29 l-pairs run-id))
6f20: 0a 09 20 28 6b 65 79 73 20 20 20 20 28 72 6d 74 .. (keys (rmt
6f30: 3a 67 65 74 2d 6b 65 79 73 29 29 0a 09 20 28 73 :get-keys)).. (s
6f40: 65 6c 73 74 72 20 20 28 73 74 72 69 6e 67 2d 69 elstr (string-i
6f50: 6e 74 65 72 73 70 65 72 73 65 20 20 6b 65 79 73 ntersperse keys
6f60: 20 22 2c 22 29 29 0a 09 20 28 71 72 79 73 74 72 ",")).. (qrystr
6f70: 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 (string-inters
6f80: 70 65 72 73 65 20 28 6d 61 70 20 28 6c 61 6d 62 perse (map (lamb
6f90: 64 61 20 28 78 29 28 63 6f 6e 63 20 78 20 22 3d da (x)(conc x "=
6fa0: 3f 22 29 29 20 6b 65 79 73 29 20 22 20 41 4e 44 ?")) keys) " AND
6fb0: 20 22 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e "))). (if (n
6fc0: 6f 74 20 6b 65 79 76 61 6c 73 29 0a 09 23 66 0a ot keyvals)..#f.
6fd0: 09 28 6c 65 74 20 28 28 70 72 65 76 2d 72 75 6e .(let ((prev-run
6fe0: 2d 69 64 73 20 28 72 6d 74 3a 67 65 74 2d 70 72 -ids (rmt:get-pr
6ff0: 65 76 2d 72 75 6e 2d 69 64 73 20 72 75 6e 2d 69 ev-run-ids run-i
7000: 64 29 29 29 0a 09 20 20 3b 3b 20 66 6f 72 20 65 d))).. ;; for e
7010: 61 63 68 20 72 75 6e 20 73 74 61 72 74 69 6e 67 ach run starting
7020: 20 77 69 74 68 20 74 68 65 20 6d 6f 73 74 20 72 with the most r
7030: 65 63 65 6e 74 20 6c 6f 6f 6b 20 74 6f 20 73 65 ecent look to se
7040: 65 20 69 66 20 74 68 65 72 65 20 69 73 20 61 20 e if there is a
7050: 6d 61 74 63 68 69 6e 67 20 74 65 73 74 0a 09 20 matching test..
7060: 20 3b 3b 20 69 66 20 66 6f 75 6e 64 20 74 68 65 ;; if found the
7070: 6e 20 72 65 74 75 72 6e 20 74 68 61 74 20 6d 61 n return that ma
7080: 74 63 68 69 6e 67 20 74 65 73 74 20 72 65 63 6f tching test reco
7090: 72 64 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 rd.. (debug:pri
70a0: 6e 74 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 4 *default-lo
70b0: 67 2d 70 6f 72 74 2a 20 22 73 65 6c 73 74 72 3a g-port* "selstr:
70c0: 20 22 20 73 65 6c 73 74 72 20 22 2c 20 71 72 79 " selstr ", qry
70d0: 73 74 72 3a 20 22 20 71 72 79 73 74 72 20 22 2c str: " qrystr ",
70e0: 20 6b 65 79 76 61 6c 73 3a 20 22 20 6b 65 79 76 keyvals: " keyv
70f0: 61 6c 73 20 22 2c 20 70 72 65 76 69 6f 75 73 20 als ", previous
7100: 72 75 6e 20 69 64 73 20 66 6f 75 6e 64 3a 20 22 run ids found: "
7110: 20 70 72 65 76 2d 72 75 6e 2d 69 64 73 29 0a 09 prev-run-ids)..
7120: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 70 72 65 (if (null? pre
7130: 76 2d 72 75 6e 2d 69 64 73 29 20 23 66 0a 09 20 v-run-ids) #f..
7140: 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 (let loop (
7150: 28 68 65 64 20 28 63 61 72 20 70 72 65 76 2d 72 (hed (car prev-r
7160: 75 6e 2d 69 64 73 29 29 0a 09 09 09 20 28 74 61 un-ids)).... (ta
7170: 6c 20 28 63 64 72 20 70 72 65 76 2d 72 75 6e 2d l (cdr prev-run-
7180: 69 64 73 29 29 29 0a 09 09 28 6c 65 74 20 28 28 ids)))...(let ((
7190: 72 65 73 75 6c 74 73 20 28 72 6d 74 3a 67 65 74 results (rmt:get
71a0: 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 68 -tests-for-run h
71b0: 65 64 20 28 63 6f 6e 63 20 74 65 73 74 2d 6e 61 ed (conc test-na
71c0: 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 me "/" item-path
71d0: 29 20 27 28 29 20 27 28 29 20 3b 3b 20 72 75 6e ) '() '() ;; run
71e0: 2d 69 64 20 74 65 73 74 70 61 74 74 20 73 74 61 -id testpatt sta
71f0: 74 65 73 20 73 74 61 74 75 73 65 73 0a 09 09 09 tes statuses....
7200: 09 09 09 20 20 20 20 20 20 23 66 20 23 66 20 23 ... #f #f #
7210: 66 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 f
7220: 3b 3b 20 6f 66 66 73 65 74 20 6c 69 6d 69 74 20 ;; offset limit
7230: 6e 6f 74 2d 69 6e 20 68 69 64 65 2f 6e 6f 74 2d not-in hide/not-
7240: 68 69 64 65 0a 09 09 09 09 09 09 20 20 20 20 20 hide.......
7250: 20 23 66 20 23 66 20 23 66 20 23 66 20 27 6e 6f #f #f #f #f 'no
7260: 72 6d 61 6c 29 29 29 20 3b 3b 20 73 6f 72 74 2d rmal))) ;; sort-
7270: 62 79 20 73 6f 72 74 2d 6f 72 64 65 72 20 71 72 by sort-order qr
7280: 79 76 61 6c 73 20 6c 61 73 74 2d 75 70 64 61 74 yvals last-updat
7290: 65 20 6d 6f 64 65 0a 09 09 20 20 28 64 65 62 75 e mode... (debu
72a0: 67 3a 70 72 69 6e 74 20 34 20 2a 64 65 66 61 75 g:print 4 *defau
72b0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 47 6f lt-log-port* "Go
72c0: 74 20 74 65 73 74 73 20 66 6f 72 20 72 75 6e 2d t tests for run-
72d0: 69 64 20 22 20 72 75 6e 2d 69 64 20 22 2c 20 74 id " run-id ", t
72e0: 65 73 74 2d 6e 61 6d 65 20 22 20 74 65 73 74 2d est-name " test-
72f0: 6e 61 6d 65 20 22 2c 20 69 74 65 6d 2d 70 61 74 name ", item-pat
7300: 68 20 22 20 69 74 65 6d 2d 70 61 74 68 20 22 3a h " item-path ":
7310: 20 22 20 72 65 73 75 6c 74 73 29 0a 09 09 20 20 " results)...
7320: 28 69 66 20 28 61 6e 64 20 28 6e 75 6c 6c 3f 20 (if (and (null?
7330: 72 65 73 75 6c 74 73 29 0a 09 09 09 20 20 20 28 results).... (
7340: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 not (null? tal))
7350: 29 0a 09 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 )... (loop
7360: 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 (car tal)(cdr ta
7370: 6c 29 29 0a 09 09 20 20 20 20 20 20 28 69 66 20 l))... (if
7380: 28 6e 75 6c 6c 3f 20 72 65 73 75 6c 74 73 29 20 (null? results)
7390: 23 66 0a 09 09 09 20 20 28 63 61 72 20 72 65 73 #f.... (car res
73a0: 75 6c 74 73 29 29 29 29 29 29 29 29 29 29 0a 0a ults))))))))))..
73b0: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 (define (rmt:get
73c0: 2d 72 75 6e 2d 73 74 61 74 73 29 0a 20 20 28 72 -run-stats). (r
73d0: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
73e0: 27 67 65 74 2d 72 75 6e 2d 73 74 61 74 73 20 23 'get-run-stats #
73f0: 66 20 27 28 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d f '()))..;;=====
7400: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7410: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7420: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7430: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7440: 3d 0a 3b 3b 20 20 53 20 54 20 45 20 50 20 53 0a =.;; S T E P S.
7450: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
7460: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7470: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7480: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7490: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 47 65 74 ========..;; Get
74a0: 74 69 6e 67 20 73 74 65 70 73 20 69 73 20 6d 6f ting steps is mo
74b0: 72 65 20 63 6f 6d 70 6c 69 63 61 74 65 64 2e 0a re complicated..
74c0: 3b 3b 0a 3b 3b 20 49 66 20 67 69 76 65 6e 20 77 ;;.;; If given w
74d0: 6f 72 6b 20 61 72 65 61 20 0a 3b 3b 20 20 31 2e ork area .;; 1.
74e0: 20 46 69 6e 64 20 74 68 65 20 74 65 73 74 64 61 Find the testda
74f0: 74 2e 64 62 20 66 69 6c 65 0a 3b 3b 20 20 32 2e t.db file.;; 2.
7500: 20 4f 70 65 6e 20 74 68 65 20 74 65 73 74 64 61 Open the testda
7510: 74 2e 64 62 20 66 69 6c 65 20 61 6e 64 20 64 6f t.db file and do
7520: 20 74 68 65 20 71 75 65 72 79 0a 3b 3b 20 49 66 the query.;; If
7530: 20 6e 6f 74 20 67 69 76 65 6e 20 74 68 65 20 77 not given the w
7540: 6f 72 6b 20 61 72 65 61 0a 3b 3b 20 20 31 2e 20 ork area.;; 1.
7550: 44 6f 20 61 20 72 65 6d 6f 74 65 20 63 61 6c 6c Do a remote call
7560: 20 74 6f 20 67 65 74 20 74 68 65 20 74 65 73 74 to get the test
7570: 20 70 61 74 68 0a 3b 3b 20 20 32 2e 20 43 6f 6e path.;; 2. Con
7580: 74 69 6e 75 65 20 61 73 20 61 62 6f 76 65 0a 3b tinue as above.;
7590: 3b 20 0a 3b 3b 28 64 65 66 69 6e 65 20 28 72 6d ; .;;(define (rm
75a0: 74 3a 67 65 74 2d 73 74 65 70 73 2d 66 6f 72 2d t:get-steps-for-
75b0: 74 65 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 test run-id test
75c0: 2d 69 64 29 0a 3b 3b 20 20 28 72 6d 74 3a 73 65 -id).;; (rmt:se
75d0: 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d nd-receive 'get-
75e0: 73 74 65 70 73 2d 64 61 74 61 20 72 75 6e 2d 69 steps-data run-i
75f0: 64 20 28 6c 69 73 74 20 74 65 73 74 2d 69 64 29 d (list test-id)
7600: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
7610: 3a 74 65 73 74 73 74 65 70 2d 73 65 74 2d 73 74 :teststep-set-st
7620: 61 74 75 73 21 20 72 75 6e 2d 69 64 20 74 65 73 atus! run-id tes
7630: 74 2d 69 64 20 74 65 73 74 73 74 65 70 2d 6e 61 t-id teststep-na
7640: 6d 65 20 73 74 61 74 65 2d 69 6e 20 73 74 61 74 me state-in stat
7650: 75 73 2d 69 6e 20 63 6f 6d 6d 65 6e 74 20 6c 6f us-in comment lo
7660: 67 66 69 6c 65 29 0a 20 20 28 6c 65 74 2a 20 28 gfile). (let* (
7670: 28 73 74 61 74 65 20 20 20 20 20 28 69 74 65 6d (state (item
7680: 73 3a 63 68 65 63 6b 2d 76 61 6c 69 64 2d 69 74 s:check-valid-it
7690: 65 6d 73 20 22 73 74 61 74 65 22 20 73 74 61 74 ems "state" stat
76a0: 65 2d 69 6e 29 29 0a 09 20 28 73 74 61 74 75 73 e-in)).. (status
76b0: 20 20 20 20 28 69 74 65 6d 73 3a 63 68 65 63 6b (items:check
76c0: 2d 76 61 6c 69 64 2d 69 74 65 6d 73 20 22 73 74 -valid-items "st
76d0: 61 74 75 73 22 20 73 74 61 74 75 73 2d 69 6e 29 atus" status-in)
76e0: 29 29 0a 20 20 20 20 28 69 66 20 28 6f 72 20 28 )). (if (or (
76f0: 6e 6f 74 20 73 74 61 74 65 29 28 6e 6f 74 20 73 not state)(not s
7700: 74 61 74 75 73 29 29 0a 09 28 64 65 62 75 67 3a tatus))..(debug:
7710: 70 72 69 6e 74 20 33 20 2a 64 65 66 61 75 6c 74 print 3 *default
7720: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e -log-port* "WARN
7730: 49 4e 47 3a 20 49 6e 76 61 6c 69 64 20 22 20 28 ING: Invalid " (
7740: 69 66 20 73 74 61 74 75 73 20 22 73 74 61 74 75 if status "statu
7750: 73 22 20 22 73 74 61 74 65 22 29 0a 09 09 20 20 s" "state")...
7760: 20 20 20 22 20 76 61 6c 75 65 20 5c 22 22 20 28 " value \"" (
7770: 69 66 20 73 74 61 74 75 73 20 73 74 61 74 65 2d if status state-
7780: 69 6e 20 73 74 61 74 75 73 2d 69 6e 29 20 22 5c in status-in) "\
7790: 22 2c 20 75 70 64 61 74 65 20 79 6f 75 72 20 76 ", update your v
77a0: 61 6c 69 64 76 61 6c 75 65 73 20 73 65 63 74 69 alidvalues secti
77b0: 6f 6e 20 69 6e 20 6d 65 67 61 74 65 73 74 2e 63 on in megatest.c
77c0: 6f 6e 66 69 67 22 29 29 0a 20 20 20 20 28 72 6d onfig")). (rm
77d0: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
77e0: 74 65 73 74 73 74 65 70 2d 73 65 74 2d 73 74 61 teststep-set-sta
77f0: 74 75 73 21 20 72 75 6e 2d 69 64 20 28 6c 69 73 tus! run-id (lis
7800: 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 t run-id test-id
7810: 20 74 65 73 74 73 74 65 70 2d 6e 61 6d 65 20 73 teststep-name s
7820: 74 61 74 65 2d 69 6e 20 73 74 61 74 75 73 2d 69 tate-in status-i
7830: 6e 20 63 6f 6d 6d 65 6e 74 20 6c 6f 67 66 69 6c n comment logfil
7840: 65 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 e))))..(define (
7850: 72 6d 74 3a 67 65 74 2d 73 74 65 70 73 2d 66 6f rmt:get-steps-fo
7860: 72 2d 74 65 73 74 20 72 75 6e 2d 69 64 20 74 65 r-test run-id te
7870: 73 74 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 st-id). (rmt:se
7880: 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d nd-receive 'get-
7890: 73 74 65 70 73 2d 66 6f 72 2d 74 65 73 74 20 72 steps-for-test r
78a0: 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d un-id (list run-
78b0: 69 64 20 74 65 73 74 2d 69 64 29 29 29 0a 0a 3b id test-id)))..;
78c0: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
78d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
78e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
78f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7900: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 54 20 45 20 =======.;; T E
7910: 53 20 54 20 20 20 44 20 41 20 54 20 41 20 0a 3b S T D A T A .;
7920: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
7930: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7940: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7950: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7960: 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 =======..(define
7970: 20 28 72 6d 74 3a 72 65 61 64 2d 74 65 73 74 2d (rmt:read-test-
7980: 64 61 74 61 20 72 75 6e 2d 69 64 20 74 65 73 74 data run-id test
7990: 2d 69 64 20 63 61 74 65 67 6f 72 79 70 61 74 74 -id categorypatt
79a0: 20 23 21 6b 65 79 20 28 77 6f 72 6b 2d 61 72 65 #!key (work-are
79b0: 61 20 23 66 29 29 20 0a 20 20 28 72 6d 74 3a 73 a #f)) . (rmt:s
79c0: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 72 65 61 end-receive 'rea
79d0: 64 2d 74 65 73 74 2d 64 61 74 61 20 72 75 6e 2d d-test-data run-
79e0: 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 id (list run-id
79f0: 74 65 73 74 2d 69 64 20 63 61 74 65 67 6f 72 79 test-id category
7a00: 70 61 74 74 29 29 29 0a 3b 3b 20 20 20 28 6c 65 patt))).;; (le
7a10: 74 20 28 28 74 64 62 20 20 28 72 6d 74 3a 6f 70 t ((tdb (rmt:op
7a20: 65 6e 2d 74 65 73 74 2d 64 62 2d 62 79 2d 74 65 en-test-db-by-te
7a30: 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 st-id run-id tes
7a40: 74 2d 69 64 20 77 6f 72 6b 2d 61 72 65 61 3a 20 t-id work-area:
7a50: 77 6f 72 6b 2d 61 72 65 61 29 29 29 0a 3b 3b 20 work-area))).;;
7a60: 20 20 20 20 28 69 66 20 74 64 62 0a 3b 3b 20 09 (if tdb.;; .
7a70: 28 74 64 62 3a 72 65 61 64 2d 74 65 73 74 2d 64 (tdb:read-test-d
7a80: 61 74 61 20 74 64 62 20 74 65 73 74 2d 69 64 20 ata tdb test-id
7a90: 63 61 74 65 67 6f 72 79 70 61 74 74 29 0a 3b 3b categorypatt).;;
7aa0: 20 09 27 28 29 29 29 29 0a 0a 28 64 65 66 69 6e .'())))..(defin
7ab0: 65 20 28 72 6d 74 3a 74 65 73 74 6d 65 74 61 2d e (rmt:testmeta-
7ac0: 61 64 64 2d 72 65 63 6f 72 64 20 74 65 73 74 6e add-record testn
7ad0: 61 6d 65 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 ame). (rmt:send
7ae0: 2d 72 65 63 65 69 76 65 20 27 74 65 73 74 6d 65 -receive 'testme
7af0: 74 61 2d 61 64 64 2d 72 65 63 6f 72 64 20 23 66 ta-add-record #f
7b00: 20 28 6c 69 73 74 20 74 65 73 74 6e 61 6d 65 29 (list testname)
7b10: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
7b20: 3a 74 65 73 74 6d 65 74 61 2d 67 65 74 2d 72 65 :testmeta-get-re
7b30: 63 6f 72 64 20 74 65 73 74 6e 61 6d 65 29 0a 20 cord testname).
7b40: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
7b50: 76 65 20 27 74 65 73 74 6d 65 74 61 2d 67 65 74 ve 'testmeta-get
7b60: 2d 72 65 63 6f 72 64 20 23 66 20 28 6c 69 73 74 -record #f (list
7b70: 20 74 65 73 74 6e 61 6d 65 29 29 29 0a 0a 28 64 testname)))..(d
7b80: 65 66 69 6e 65 20 28 72 6d 74 3a 74 65 73 74 6d efine (rmt:testm
7b90: 65 74 61 2d 75 70 64 61 74 65 2d 66 69 65 6c 64 eta-update-field
7ba0: 20 74 65 73 74 2d 6e 61 6d 65 20 66 6c 64 20 76 test-name fld v
7bb0: 61 6c 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d al). (rmt:send-
7bc0: 72 65 63 65 69 76 65 20 27 74 65 73 74 6d 65 74 receive 'testmet
7bd0: 61 2d 75 70 64 61 74 65 2d 66 69 65 6c 64 20 23 a-update-field #
7be0: 66 20 28 6c 69 73 74 20 74 65 73 74 2d 6e 61 6d f (list test-nam
7bf0: 65 20 66 6c 64 20 76 61 6c 29 29 29 0a 0a 28 64 e fld val)))..(d
7c00: 65 66 69 6e 65 20 28 72 6d 74 3a 74 65 73 74 2d efine (rmt:test-
7c10: 64 61 74 61 2d 72 6f 6c 6c 75 70 20 72 75 6e 2d data-rollup run-
7c20: 69 64 20 74 65 73 74 2d 69 64 20 73 74 61 74 75 id test-id statu
7c30: 73 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 s). (rmt:send-r
7c40: 65 63 65 69 76 65 20 27 74 65 73 74 2d 64 61 74 eceive 'test-dat
7c50: 61 2d 72 6f 6c 6c 75 70 20 72 75 6e 2d 69 64 20 a-rollup run-id
7c60: 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 (list run-id tes
7c70: 74 2d 69 64 20 73 74 61 74 75 73 29 29 29 0a 0a t-id status)))..
7c80: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 63 73 76 (define (rmt:csv
7c90: 2d 3e 74 65 73 74 2d 64 61 74 61 20 72 75 6e 2d ->test-data run-
7ca0: 69 64 20 74 65 73 74 2d 69 64 20 63 73 76 64 61 id test-id csvda
7cb0: 74 61 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d ta). (rmt:send-
7cc0: 72 65 63 65 69 76 65 20 27 63 73 76 2d 3e 74 65 receive 'csv->te
7cd0: 73 74 2d 64 61 74 61 20 72 75 6e 2d 69 64 20 28 st-data run-id (
7ce0: 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 list run-id test
7cf0: 2d 69 64 20 63 73 76 64 61 74 61 29 29 29 0a 0a -id csvdata)))..
7d00: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
7d10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7d20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7d30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7d40: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 54 20 41 ========.;; T A
7d50: 20 53 20 4b 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d S K S.;;=======
7d60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7d70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7d80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7d90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
7da0: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 61 .(define (rmt:ta
7db0: 73 6b 73 2d 66 69 6e 64 2d 74 61 73 6b 2d 71 75 sks-find-task-qu
7dc0: 65 75 65 2d 72 65 63 6f 72 64 73 20 74 61 72 67 eue-records targ
7dd0: 65 74 20 72 75 6e 2d 6e 61 6d 65 20 74 65 73 74 et run-name test
7de0: 2d 70 61 74 74 20 73 74 61 74 65 2d 70 61 74 74 -patt state-patt
7df0: 20 61 63 74 69 6f 6e 2d 70 61 74 74 29 0a 20 20 action-patt).
7e00: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
7e10: 65 20 27 66 69 6e 64 2d 74 61 73 6b 2d 71 75 65 e 'find-task-que
7e20: 75 65 2d 72 65 63 6f 72 64 73 20 23 66 20 28 6c ue-records #f (l
7e30: 69 73 74 20 74 61 72 67 65 74 20 72 75 6e 2d 6e ist target run-n
7e40: 61 6d 65 20 74 65 73 74 2d 70 61 74 74 20 73 74 ame test-patt st
7e50: 61 74 65 2d 70 61 74 74 20 61 63 74 69 6f 6e 2d ate-patt action-
7e60: 70 61 74 74 29 29 29 0a 0a 28 64 65 66 69 6e 65 patt)))..(define
7e70: 20 28 72 6d 74 3a 74 61 73 6b 73 2d 61 64 64 20 (rmt:tasks-add
7e80: 61 63 74 69 6f 6e 20 6f 77 6e 65 72 20 74 61 72 action owner tar
7e90: 67 65 74 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 get runname test
7ea0: 70 61 74 74 20 70 61 72 61 6d 73 29 0a 20 20 28 patt params). (
7eb0: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
7ec0: 20 27 74 61 73 6b 73 2d 61 64 64 20 23 66 20 28 'tasks-add #f (
7ed0: 6c 69 73 74 20 61 63 74 69 6f 6e 20 6f 77 6e 65 list action owne
7ee0: 72 20 74 61 72 67 65 74 20 72 75 6e 6e 61 6d 65 r target runname
7ef0: 20 74 65 73 74 70 61 74 74 20 70 61 72 61 6d 73 testpatt params
7f00: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d )))..(define (rm
7f10: 74 3a 74 61 73 6b 73 2d 73 65 74 2d 73 74 61 74 t:tasks-set-stat
7f20: 65 2d 67 69 76 65 6e 2d 70 61 72 61 6d 2d 6b 65 e-given-param-ke
7f30: 79 20 70 61 72 61 6d 2d 6b 65 79 20 6e 65 77 2d y param-key new-
7f40: 73 74 61 74 65 29 0a 20 20 28 72 6d 74 3a 73 65 state). (rmt:se
7f50: 6e 64 2d 72 65 63 65 69 76 65 20 27 74 61 73 6b nd-receive 'task
7f60: 73 2d 73 65 74 2d 73 74 61 74 65 2d 67 69 76 65 s-set-state-give
7f70: 6e 2d 70 61 72 61 6d 2d 6b 65 79 20 23 66 20 28 n-param-key #f (
7f80: 6c 69 73 74 20 20 70 61 72 61 6d 2d 6b 65 79 20 list param-key
7f90: 6e 65 77 2d 73 74 61 74 65 29 29 29 0a 0a 28 64 new-state)))..(d
7fa0: 65 66 69 6e 65 20 28 72 6d 74 3a 74 61 73 6b 73 efine (rmt:tasks
7fb0: 2d 67 65 74 2d 6c 61 73 74 20 74 61 72 67 65 74 -get-last target
7fc0: 20 72 75 6e 6e 61 6d 65 29 0a 20 20 28 72 6d 74 runname). (rmt
7fd0: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 74 :send-receive 't
7fe0: 61 73 6b 73 2d 67 65 74 2d 6c 61 73 74 20 23 66 asks-get-last #f
7ff0: 20 28 6c 69 73 74 20 74 61 72 67 65 74 20 72 75 (list target ru
8000: 6e 6e 61 6d 65 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d nname)))..;;====
8010: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8020: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8030: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8040: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8050: 3d 3d 0a 3b 3b 20 41 20 52 20 43 20 48 20 49 20 ==.;; A R C H I
8060: 56 20 45 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d V E S.;;========
8070: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8080: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8090: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
80a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
80b0: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 61 72 63 (define (rmt:arc
80c0: 68 69 76 65 2d 67 65 74 2d 61 6c 6c 6f 63 61 74 hive-get-allocat
80d0: 69 6f 6e 73 20 20 74 65 73 74 6e 61 6d 65 20 69 ions testname i
80e0: 74 65 6d 70 61 74 68 20 64 6e 65 65 64 65 64 29 tempath dneeded)
80f0: 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 . (rmt:send-rec
8100: 65 69 76 65 20 27 61 72 63 68 69 76 65 2d 67 65 eive 'archive-ge
8110: 74 2d 61 6c 6c 6f 63 61 74 69 6f 6e 73 20 23 66 t-allocations #f
8120: 20 28 6c 69 73 74 20 74 65 73 74 6e 61 6d 65 20 (list testname
8130: 69 74 65 6d 70 61 74 68 20 64 6e 65 65 64 65 64 itempath dneeded
8140: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d )))..(define (rm
8150: 74 3a 61 72 63 68 69 76 65 2d 72 65 67 69 73 74 t:archive-regist
8160: 65 72 2d 62 6c 6f 63 6b 2d 6e 61 6d 65 20 62 64 er-block-name bd
8170: 69 73 6b 2d 69 64 20 61 72 63 68 69 76 65 2d 70 isk-id archive-p
8180: 61 74 68 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 ath). (rmt:send
8190: 2d 72 65 63 65 69 76 65 20 27 61 72 63 68 69 76 -receive 'archiv
81a0: 65 2d 72 65 67 69 73 74 65 72 2d 62 6c 6f 63 6b e-register-block
81b0: 2d 6e 61 6d 65 20 23 66 20 28 6c 69 73 74 20 62 -name #f (list b
81c0: 64 69 73 6b 2d 69 64 20 61 72 63 68 69 76 65 2d disk-id archive-
81d0: 70 61 74 68 29 29 29 0a 0a 28 64 65 66 69 6e 65 path)))..(define
81e0: 20 28 72 6d 74 3a 61 72 63 68 69 76 65 2d 61 6c (rmt:archive-al
81f0: 6c 6f 63 61 74 65 2d 74 65 73 74 73 75 69 74 65 locate-testsuite
8200: 2f 61 72 65 61 2d 74 6f 2d 62 6c 6f 63 6b 20 62 /area-to-block b
8210: 6c 6f 63 6b 2d 69 64 20 74 65 73 74 73 75 69 74 lock-id testsuit
8220: 65 2d 6e 61 6d 65 20 61 72 65 61 6b 65 79 29 0a e-name areakey).
8230: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
8240: 69 76 65 20 27 61 72 63 68 69 76 65 2d 61 6c 6c ive 'archive-all
8250: 6f 63 61 74 65 2d 74 65 73 74 2d 74 6f 2d 62 6c ocate-test-to-bl
8260: 6f 63 6b 20 23 66 20 28 6c 69 73 74 20 20 62 6c ock #f (list bl
8270: 6f 63 6b 2d 69 64 20 74 65 73 74 73 75 69 74 65 ock-id testsuite
8280: 2d 6e 61 6d 65 20 61 72 65 61 6b 65 79 29 29 29 -name areakey)))
8290: 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 61 ..(define (rmt:a
82a0: 72 63 68 69 76 65 2d 72 65 67 69 73 74 65 72 2d rchive-register-
82b0: 64 69 73 6b 20 62 64 69 73 6b 2d 6e 61 6d 65 20 disk bdisk-name
82c0: 62 64 69 73 6b 2d 70 61 74 68 20 64 66 29 0a 20 bdisk-path df).
82d0: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
82e0: 76 65 20 27 61 72 63 68 69 76 65 2d 72 65 67 69 ve 'archive-regi
82f0: 73 74 65 72 2d 64 69 73 6b 20 23 66 20 28 6c 69 ster-disk #f (li
8300: 73 74 20 62 64 69 73 6b 2d 6e 61 6d 65 20 62 64 st bdisk-name bd
8310: 69 73 6b 2d 70 61 74 68 20 64 66 29 29 29 0a 0a isk-path df)))..
8320: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 65 73 (define (rmt:tes
8330: 74 2d 73 65 74 2d 61 72 63 68 69 76 65 2d 62 6c t-set-archive-bl
8340: 6f 63 6b 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 ock-id run-id te
8350: 73 74 2d 69 64 20 61 72 63 68 69 76 65 2d 62 6c st-id archive-bl
8360: 6f 63 6b 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 ock-id). (rmt:s
8370: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 74 65 73 end-receive 'tes
8380: 74 2d 73 65 74 2d 61 72 63 68 69 76 65 2d 62 6c t-set-archive-bl
8390: 6f 63 6b 2d 69 64 20 72 75 6e 2d 69 64 20 28 6c ock-id run-id (l
83a0: 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d ist run-id test-
83b0: 69 64 20 61 72 63 68 69 76 65 2d 62 6c 6f 63 6b id archive-block
83c0: 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 -id)))..(define
83d0: 28 72 6d 74 3a 74 65 73 74 2d 67 65 74 2d 61 72 (rmt:test-get-ar
83e0: 63 68 69 76 65 2d 62 6c 6f 63 6b 2d 69 6e 66 6f chive-block-info
83f0: 20 61 72 63 68 69 76 65 2d 62 6c 6f 63 6b 2d 69 archive-block-i
8400: 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 d). (rmt:send-r
8410: 65 63 65 69 76 65 20 27 74 65 73 74 2d 67 65 74 eceive 'test-get
8420: 2d 61 72 63 68 69 76 65 2d 62 6c 6f 63 6b 2d 69 -archive-block-i
8430: 6e 66 6f 20 23 66 20 28 6c 69 73 74 20 61 72 63 nfo #f (list arc
8440: 68 69 76 65 2d 62 6c 6f 63 6b 2d 69 64 29 29 29 hive-block-id)))
8450: 0a .