Artifact
2a4800a8d6cafeb5287653fe4812e4aa12fab761:
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 6a 73 6f 6e 20 66 6f 72 6d 61 74 29 0a 0a 28 json format)..(
01f0: 64 65 63 6c 61 72 65 20 28 75 6e 69 74 20 72 6d declare (unit rm
0200: 74 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 t)).(declare (us
0210: 65 73 20 61 70 69 29 29 0a 28 64 65 63 6c 61 72 es api)).(declar
0220: 65 20 28 75 73 65 73 20 74 64 62 29 29 0a 28 64 e (uses tdb)).(d
0230: 65 63 6c 61 72 65 20 28 75 73 65 73 20 68 74 74 eclare (uses htt
0240: 70 2d 74 72 61 6e 73 70 6f 72 74 29 29 0a 28 64 p-transport)).(d
0250: 65 63 6c 61 72 65 20 28 75 73 65 73 20 6e 6d 73 eclare (uses nms
0260: 67 2d 74 72 61 6e 73 70 6f 72 74 29 29 0a 0a 3b g-transport))..;
0270: 3b 0a 3b 3b 20 54 48 45 53 45 20 41 52 45 20 41 ;.;; THESE ARE A
0280: 4c 4c 20 43 41 4c 4c 45 44 20 4f 4e 20 54 48 45 LL CALLED ON THE
0290: 20 43 4c 49 45 4e 54 20 53 49 44 45 21 21 21 0a CLIENT SIDE!!!.
02a0: 3b 3b 0a 0a 3b 3b 20 3b 3b 20 46 6f 72 20 64 65 ;;..;; ;; For de
02b0: 62 75 67 67 69 6e 67 20 61 64 64 20 74 68 65 20 bugging add the
02c0: 66 6f 6c 6c 6f 77 69 6e 67 20 74 6f 20 7e 2f 2e following to ~/.
02d0: 6d 65 67 61 74 65 73 74 72 63 0a 3b 3b 0a 3b 3b megatestrc.;;.;;
02e0: 20 28 72 65 71 75 69 72 65 2d 6c 69 62 72 61 72 (require-librar
02f0: 79 20 74 72 61 63 65 29 0a 3b 3b 20 28 69 6d 70 y trace).;; (imp
0300: 6f 72 74 20 74 72 61 63 65 29 0a 3b 3b 20 28 74 ort trace).;; (t
0310: 72 61 63 65 0a 3b 3b 20 72 6d 74 3a 73 65 6e 64 race.;; rmt:send
0320: 2d 72 65 63 65 69 76 65 0a 3b 3b 20 61 70 69 3a -receive.;; api:
0330: 65 78 65 63 75 74 65 2d 72 65 71 75 65 73 74 73 execute-requests
0340: 0a 3b 3b 20 29 0a 0a 3b 3b 20 67 65 6e 65 72 61 .;; )..;; genera
0350: 74 65 20 65 6e 74 72 69 65 73 20 66 6f 72 20 7e te entries for ~
0360: 2f 2e 6d 65 67 61 74 65 73 74 72 63 20 77 69 74 /.megatestrc wit
0370: 68 20 74 68 65 20 66 6f 6c 6c 6f 77 69 6e 67 0a h the following.
0380: 3b 3b 0a 3b 3b 20 20 67 72 65 70 20 64 65 66 69 ;;.;; grep defi
0390: 6e 65 20 2e 2e 2f 72 6d 74 2e 73 63 6d 20 7c 20 ne ../rmt.scm |
03a0: 67 72 65 70 20 72 6d 74 3a 20 7c 70 65 72 6c 20 grep rmt: |perl
03b0: 2d 70 69 20 2d 65 20 27 73 2f 5c 28 64 65 66 69 -pi -e 's/\(defi
03c0: 6e 65 5c 73 2b 5c 28 28 5c 53 2b 29 5c 57 2e 2a ne\s+\((\S+)\W.*
03d0: 24 2f 5c 31 2f 27 7c 73 6f 72 74 20 2d 75 0a 0a $/\1/'|sort -u..
03e0: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
03f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0400: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0410: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0420: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 53 20 =========.;; S
0430: 55 20 50 20 50 20 4f 20 52 20 54 20 20 20 46 20 U P P O R T F
0440: 55 20 4e 20 43 20 54 20 49 20 4f 20 4e 20 53 0a U N C T I O N S.
0450: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
0460: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0470: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0480: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0490: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 4e 4f 54 ========..;; NOT
04a0: 20 55 53 45 44 3f 0a 3b 3b 0a 3b 3b 20 28 64 65 USED?.;;.;; (de
04b0: 66 69 6e 65 20 28 72 6d 74 3a 63 61 6c 6c 2d 74 fine (rmt:call-t
04c0: 72 61 6e 73 70 6f 72 74 20 72 75 6e 2d 69 64 20 ransport run-id
04d0: 63 6f 6e 6e 65 63 74 69 6f 6e 2d 69 6e 66 6f 20 connection-info
04e0: 63 6d 64 20 6a 70 61 72 61 6d 73 29 0a 3b 3b 20 cmd jparams).;;
04f0: 20 20 28 63 61 73 65 20 28 73 65 72 76 65 72 3a (case (server:
0500: 67 65 74 2d 74 72 61 6e 73 70 6f 72 74 29 0a 3b get-transport).;
0510: 3b 20 20 20 20 20 28 28 72 70 63 29 20 20 28 20 ; ((rpc) (
0520: 72 70 63 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c rpc-transport:cl
0530: 69 65 6e 74 2d 61 70 69 2d 73 65 6e 64 2d 72 65 ient-api-send-re
0540: 63 65 69 76 65 20 72 75 6e 2d 69 64 20 63 6f 6e ceive run-id con
0550: 6e 65 63 74 69 6f 6e 2d 69 6e 66 6f 20 63 6d 64 nection-info cmd
0560: 20 6a 70 61 72 61 6d 73 29 29 0a 3b 3b 20 20 20 jparams)).;;
0570: 20 20 28 28 68 74 74 70 29 20 28 68 74 74 70 2d ((http) (http-
0580: 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 65 6e 74 transport:client
0590: 2d 61 70 69 2d 73 65 6e 64 2d 72 65 63 65 69 76 -api-send-receiv
05a0: 65 20 72 75 6e 2d 69 64 20 63 6f 6e 6e 65 63 74 e run-id connect
05b0: 69 6f 6e 2d 69 6e 66 6f 20 63 6d 64 20 6a 70 61 ion-info cmd jpa
05c0: 72 61 6d 73 29 29 0a 3b 3b 20 20 20 20 20 28 28 rams)).;; ((
05d0: 66 73 29 20 20 20 28 20 66 73 2d 74 72 61 6e 73 fs) ( fs-trans
05e0: 70 6f 72 74 3a 63 6c 69 65 6e 74 2d 61 70 69 2d port:client-api-
05f0: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 72 75 6e send-receive run
0600: 2d 69 64 20 63 6f 6e 6e 65 63 74 69 6f 6e 2d 69 -id connection-i
0610: 6e 66 6f 20 63 6d 64 20 6a 70 61 72 61 6d 73 29 nfo cmd jparams)
0620: 29 0a 3b 3b 20 20 20 20 20 28 28 7a 6d 71 29 20 ).;; ((zmq)
0630: 20 28 7a 6d 71 2d 74 72 61 6e 73 70 6f 72 74 3a (zmq-transport:
0640: 63 6c 69 65 6e 74 2d 61 70 69 2d 73 65 6e 64 2d client-api-send-
0650: 72 65 63 65 69 76 65 20 72 75 6e 2d 69 64 20 63 receive run-id c
0660: 6f 6e 6e 65 63 74 69 6f 6e 2d 69 6e 66 6f 20 63 onnection-info c
0670: 6d 64 20 6a 70 61 72 61 6d 73 29 29 0a 3b 3b 20 md jparams)).;;
0680: 20 20 20 20 28 65 6c 73 65 20 20 20 28 20 72 70 (else ( rp
0690: 63 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 65 c-transport:clie
06a0: 6e 74 2d 61 70 69 2d 73 65 6e 64 2d 72 65 63 65 nt-api-send-rece
06b0: 69 76 65 20 72 75 6e 2d 69 64 20 63 6f 6e 6e 65 ive run-id conne
06c0: 63 74 69 6f 6e 2d 69 6e 66 6f 20 63 6d 64 20 6a ction-info cmd j
06d0: 70 61 72 61 6d 73 29 29 29 29 0a 0a 3b 3b 0a 28 params))))..;;.(
06e0: 64 65 66 69 6e 65 20 28 72 6d 74 3a 77 72 69 74 define (rmt:writ
06f0: 65 2d 66 72 65 71 75 65 6e 63 79 2d 6f 76 65 72 e-frequency-over
0700: 2d 6c 69 6d 69 74 3f 20 63 6d 64 20 72 75 6e 2d -limit? cmd run-
0710: 69 64 29 0a 20 20 28 61 6e 64 20 28 6e 6f 74 20 id). (and (not
0720: 28 6d 65 6d 62 65 72 20 63 6d 64 20 61 70 69 3a (member cmd api:
0730: 72 65 61 64 2d 6f 6e 6c 79 2d 71 75 65 72 69 65 read-only-querie
0740: 73 29 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a s)). (let*
0750: 20 28 28 74 6d 70 72 65 63 20 28 68 61 73 68 2d ((tmprec (hash-
0760: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
0770: 74 20 2a 77 72 69 74 65 2d 66 72 65 71 75 65 6e t *write-frequen
0780: 63 79 2a 20 72 75 6e 2d 69 64 20 23 66 29 29 0a cy* run-id #f)).
0790: 09 20 20 20 20 20 20 28 72 65 63 6f 72 64 20 28 . (record (
07a0: 69 66 20 74 6d 70 72 65 63 20 74 6d 70 72 65 63 if tmprec tmprec
07b0: 20 0a 09 09 09 20 20 28 6c 65 74 20 28 28 76 20 .... (let ((v
07c0: 28 76 65 63 74 6f 72 20 28 63 75 72 72 65 6e 74 (vector (current
07d0: 2d 73 65 63 6f 6e 64 73 29 20 30 29 29 29 0a 09 -seconds) 0)))..
07e0: 09 09 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c .. (hash-tabl
07f0: 65 2d 73 65 74 21 20 2a 77 72 69 74 65 2d 66 72 e-set! *write-fr
0800: 65 71 75 65 6e 63 79 2a 20 72 75 6e 2d 69 64 20 equency* run-id
0810: 76 29 0a 09 09 09 20 20 20 20 76 29 29 29 0a 09 v).... v)))..
0820: 20 20 20 20 20 20 28 63 6f 75 6e 74 20 20 28 2b (count (+
0830: 20 31 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 1 (vector-ref r
0840: 65 63 6f 72 64 20 31 29 29 29 0a 09 20 20 20 20 ecord 1)))..
0850: 20 20 28 73 74 61 72 74 20 20 28 76 65 63 74 6f (start (vecto
0860: 72 2d 72 65 66 20 72 65 63 6f 72 64 20 30 29 29 r-ref record 0))
0870: 0a 09 20 20 20 20 20 20 28 71 75 65 72 69 65 73 .. (queries
0880: 2d 70 65 72 2d 73 65 63 6f 6e 64 20 28 2f 20 28 -per-second (/ (
0890: 2a 20 63 6f 75 6e 74 20 31 2e 30 29 0a 09 09 09 * count 1.0)....
08a0: 09 20 20 20 20 20 28 6d 61 78 20 28 2d 20 28 63 . (max (- (c
08b0: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 urrent-seconds)
08c0: 73 74 61 72 74 29 20 31 29 29 29 29 0a 09 20 28 start) 1)))).. (
08d0: 76 65 63 74 6f 72 2d 73 65 74 21 20 72 65 63 6f vector-set! reco
08e0: 72 64 20 31 20 63 6f 75 6e 74 29 0a 09 20 28 69 rd 1 count).. (i
08f0: 66 20 28 61 6e 64 20 28 3e 20 63 6f 75 6e 74 20 f (and (> count
0900: 31 30 29 0a 09 09 20 20 28 3e 20 71 75 65 72 69 10)... (> queri
0910: 65 73 2d 70 65 72 2d 73 65 63 6f 6e 64 20 31 30 es-per-second 10
0920: 29 29 0a 09 20 20 20 20 20 28 62 65 67 69 6e 0a )).. (begin.
0930: 09 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 . (debug:p
0940: 72 69 6e 74 2d 69 6e 66 6f 20 31 20 22 64 62 20 rint-info 1 "db
0950: 77 72 69 74 65 20 72 61 74 65 20 74 6f 6f 20 68 write rate too h
0960: 69 67 68 2c 20 73 74 61 72 74 69 6e 67 20 61 20 igh, starting a
0970: 73 65 72 76 65 72 2c 20 63 6f 75 6e 74 3d 22 20 server, count="
0980: 63 6f 75 6e 74 20 22 20 73 74 61 72 74 3d 22 20 count " start="
0990: 73 74 61 72 74 20 22 20 72 75 6e 2d 69 64 3d 22 start " run-id="
09a0: 20 72 75 6e 2d 69 64 20 22 20 71 75 65 72 69 65 run-id " querie
09b0: 73 2d 70 65 72 2d 73 65 63 6f 6e 64 3d 22 20 71 s-per-second=" q
09c0: 75 65 72 69 65 73 2d 70 65 72 2d 73 65 63 6f 6e ueries-per-secon
09d0: 64 29 0a 09 20 20 20 20 20 20 20 23 74 29 0a 09 d).. #t)..
09e0: 20 20 20 20 20 23 66 29 29 29 29 0a 0a 3b 3b 20 #f))))..;;
09f0: 69 66 20 61 20 73 65 72 76 65 72 20 69 73 20 65 if a server is e
0a00: 69 74 68 65 72 20 72 75 6e 6e 69 6e 67 20 6f 72 ither running or
0a10: 20 69 6e 20 74 68 65 20 70 72 6f 63 65 73 73 20 in the process
0a20: 6f 66 20 73 74 61 72 74 69 6e 67 20 63 61 6c 6c of starting call
0a30: 20 63 6c 69 65 6e 74 3a 73 65 74 75 70 0a 3b 3b client:setup.;;
0a40: 20 65 6c 73 65 20 72 65 74 75 72 6e 20 23 66 20 else return #f
0a50: 74 6f 20 6c 65 74 20 74 68 65 20 63 61 6c 6c 69 to let the calli
0a60: 6e 67 20 70 72 6f 63 20 6b 6e 6f 77 20 74 68 61 ng proc know tha
0a70: 74 20 74 68 65 72 65 20 69 73 20 6e 6f 20 73 65 t there is no se
0a80: 72 76 65 72 20 61 76 61 69 6c 61 62 6c 65 0a 3b rver available.;
0a90: 3b 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 ;.(define (rmt:g
0aa0: 65 74 2d 63 6f 6e 6e 65 63 74 69 6f 6e 2d 69 6e et-connection-in
0ab0: 66 6f 20 72 75 6e 2d 69 64 29 0a 20 20 28 6c 65 fo run-id). (le
0ac0: 74 20 28 28 63 69 6e 66 6f 20 28 68 61 73 68 2d t ((cinfo (hash-
0ad0: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
0ae0: 74 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 72 75 t *runremote* ru
0af0: 6e 2d 69 64 20 23 66 29 29 29 0a 20 20 20 20 28 n-id #f))). (
0b00: 69 66 20 63 69 6e 66 6f 0a 09 63 69 6e 66 6f 0a if cinfo..cinfo.
0b10: 09 3b 3b 20 4e 42 2f 2f 20 63 61 6e 20 63 61 63 .;; NB// can cac
0b20: 68 65 20 74 68 65 20 61 6e 73 77 65 72 20 66 6f he the answer fo
0b30: 72 20 73 65 72 76 65 72 20 72 75 6e 6e 69 6e 67 r server running
0b40: 20 66 6f 72 20 31 30 20 73 65 63 6f 6e 64 73 20 for 10 seconds
0b50: 2e 2e 2e 0a 09 3b 3b 20 20 3b 3b 20 28 61 6e 64 .....;; ;; (and
0b60: 20 28 6e 6f 74 20 28 72 6d 74 3a 77 72 69 74 65 (not (rmt:write
0b70: 2d 66 72 65 71 75 65 6e 63 79 2d 6f 76 65 72 2d -frequency-over-
0b80: 6c 69 6d 69 74 3f 20 63 6d 64 20 72 75 6e 2d 69 limit? cmd run-i
0b90: 64 29 29 0a 09 28 69 66 20 28 74 61 73 6b 73 3a d))..(if (tasks:
0ba0: 73 65 72 76 65 72 2d 72 75 6e 6e 69 6e 67 2d 6f server-running-o
0bb0: 72 2d 73 74 61 72 74 69 6e 67 3f 20 28 64 62 3a r-starting? (db:
0bc0: 64 65 6c 61 79 2d 69 66 2d 62 75 73 79 20 28 74 delay-if-busy (t
0bd0: 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 29 29 20 72 asks:open-db)) r
0be0: 75 6e 2d 69 64 29 0a 09 20 20 20 20 28 63 6c 69 un-id).. (cli
0bf0: 65 6e 74 3a 73 65 74 75 70 20 72 75 6e 2d 69 64 ent:setup run-id
0c00: 29 0a 09 20 20 20 20 23 66 29 29 29 29 0a 0a 28 ).. #f))))..(
0c10: 64 65 66 69 6e 65 20 2a 73 65 6e 64 2d 72 65 63 define *send-rec
0c20: 65 69 76 65 2d 6d 75 74 65 78 2a 20 28 6d 61 6b eive-mutex* (mak
0c30: 65 2d 6d 75 74 65 78 29 29 20 3b 3b 20 73 68 6f e-mutex)) ;; sho
0c40: 75 6c 64 20 68 61 76 65 20 73 65 70 61 72 61 74 uld have separat
0c50: 65 20 6d 75 74 65 78 20 70 65 72 20 72 75 6e 2d e mutex per run-
0c60: 69 64 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a id.(define (rmt:
0c70: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 63 6d 64 send-receive cmd
0c80: 20 72 69 64 20 70 61 72 61 6d 73 20 23 21 6b 65 rid params #!ke
0c90: 79 20 28 61 74 74 65 6d 70 74 6e 75 6d 20 31 29 y (attemptnum 1)
0ca0: 29 20 3b 3b 20 73 74 61 72 74 20 61 74 74 65 6d ) ;; start attem
0cb0: 70 74 6e 75 6d 20 61 74 20 31 20 73 6f 20 74 68 ptnum at 1 so th
0cc0: 65 20 6d 6f 64 75 6c 6f 20 62 65 6c 6f 77 20 77 e modulo below w
0cd0: 6f 72 6b 73 20 61 73 20 65 78 70 65 63 74 65 64 orks as expected
0ce0: 0a 20 20 3b 3b 20 63 6c 65 61 6e 20 6f 75 74 20 . ;; clean out
0cf0: 6f 6c 64 20 63 6f 6e 6e 65 63 74 69 6f 6e 73 0a old connections.
0d00: 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a (mutex-lock! *
0d10: 64 62 2d 6d 75 6c 74 69 2d 73 79 6e 63 2d 6d 75 db-multi-sync-mu
0d20: 74 65 78 2a 29 0a 20 20 28 6c 65 74 20 28 28 65 tex*). (let ((e
0d30: 78 70 69 72 65 2d 74 69 6d 65 20 28 2d 20 28 63 xpire-time (- (c
0d40: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 urrent-seconds)
0d50: 28 73 65 72 76 65 72 3a 67 65 74 2d 74 69 6d 65 (server:get-time
0d60: 6f 75 74 29 20 31 30 29 29 29 20 3b 3b 20 64 6f out) 10))) ;; do
0d70: 6e 27 74 20 66 6f 72 67 65 74 20 74 68 65 20 31 n't forget the 1
0d80: 30 20 73 65 63 6f 6e 64 20 6d 61 72 67 69 6e 0a 0 second margin.
0d90: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 (for-each .
0da0: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 72 75 6e (lambda (run
0db0: 2d 69 64 29 0a 20 20 20 20 20 20 20 28 6c 65 74 -id). (let
0dc0: 20 28 28 63 6f 6e 6e 65 63 74 69 6f 6e 20 28 68 ((connection (h
0dd0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
0de0: 66 61 75 6c 74 20 2a 72 75 6e 72 65 6d 6f 74 65 fault *runremote
0df0: 2a 20 72 75 6e 2d 69 64 20 23 66 29 29 29 0a 20 * run-id #f))).
0e00: 20 20 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 (if (and
0e10: 20 28 76 65 63 74 6f 72 3f 20 63 6f 6e 6e 65 63 (vector? connec
0e20: 74 69 6f 6e 29 0a 20 20 20 20 20 20 20 20 09 20 tion). .
0e30: 20 28 3c 20 28 68 74 74 70 2d 74 72 61 6e 73 70 (< (http-transp
0e40: 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 74 2d 67 ort:server-dat-g
0e50: 65 74 2d 6c 61 73 74 2d 61 63 63 65 73 73 20 63 et-last-access c
0e60: 6f 6e 6e 65 63 74 69 6f 6e 29 20 65 78 70 69 72 onnection) expir
0e70: 65 2d 74 69 6d 65 29 29 0a 20 20 20 20 20 20 20 e-time)).
0e80: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 (begin.
0e90: 20 20 20 20 20 20 20 20 20 20 20 20 28 64 65 62 (deb
0ea0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
0eb0: 22 44 69 73 63 61 72 64 69 6e 67 20 63 6f 6e 6e "Discarding conn
0ec0: 65 63 74 69 6f 6e 20 74 6f 20 73 65 72 76 65 72 ection to server
0ed0: 20 66 6f 72 20 72 75 6e 2d 69 64 20 22 20 72 75 for run-id " ru
0ee0: 6e 2d 69 64 20 22 2c 20 74 6f 6f 20 6c 6f 6e 67 n-id ", too long
0ef0: 20 62 65 74 77 65 65 6e 20 61 63 63 65 73 73 65 between accesse
0f00: 73 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 s").
0f10: 20 20 20 3b 3b 20 53 48 4f 55 4c 44 20 43 4c 4f ;; SHOULD CLO
0f20: 53 45 20 54 48 45 20 43 4f 4e 4e 45 43 54 49 4f SE THE CONNECTIO
0f30: 4e 20 48 45 52 45 0a 09 20 20 20 20 20 20 20 28 N HERE.. (
0f40: 63 61 73 65 20 2a 74 72 61 6e 73 70 6f 72 74 2d case *transport-
0f50: 74 79 70 65 2a 0a 09 09 20 28 28 6e 6d 73 67 29 type*... ((nmsg)
0f60: 28 6e 6e 2d 63 6c 6f 73 65 20 28 68 74 74 70 2d (nn-close (http-
0f70: 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 transport:server
0f80: 2d 64 61 74 2d 67 65 74 2d 73 6f 63 6b 65 74 20 -dat-get-socket
0f90: 0a 09 09 09 09 20 20 20 28 68 61 73 68 2d 74 61 ..... (hash-ta
0fa0: 62 6c 65 2d 72 65 66 20 2a 72 75 6e 72 65 6d 6f ble-ref *runremo
0fb0: 74 65 2a 20 72 75 6e 2d 69 64 29 29 29 29 29 0a te* run-id))))).
0fc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
0fd0: 68 61 73 68 2d 74 61 62 6c 65 2d 64 65 6c 65 74 hash-table-delet
0fe0: 65 21 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 72 e! *runremote* r
0ff0: 75 6e 2d 69 64 29 29 29 29 29 0a 20 20 20 20 20 un-id))))).
1000: 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 (hash-table-keys
1010: 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 29 29 29 0a *runremote*))).
1020: 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 (mutex-unlock!
1030: 20 2a 64 62 2d 6d 75 6c 74 69 2d 73 79 6e 63 2d *db-multi-sync-
1040: 6d 75 74 65 78 2a 29 0a 20 20 3b 3b 20 28 6d 75 mutex*). ;; (mu
1050: 74 65 78 2d 6c 6f 63 6b 21 20 2a 73 65 6e 64 2d tex-lock! *send-
1060: 72 65 63 65 69 76 65 2d 6d 75 74 65 78 2a 29 0a receive-mutex*).
1070: 20 20 28 6c 65 74 2a 20 28 28 72 75 6e 2d 69 64 (let* ((run-id
1080: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 72 69 (if ri
1090: 64 20 72 69 64 20 30 29 29 0a 09 20 28 63 6f 6e d rid 0)).. (con
10a0: 6e 65 63 74 69 6f 6e 2d 69 6e 66 6f 20 28 72 6d nection-info (rm
10b0: 74 3a 67 65 74 2d 63 6f 6e 6e 65 63 74 69 6f 6e t:get-connection
10c0: 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 29 29 29 0a -info run-id))).
10d0: 20 20 20 20 3b 3b 20 74 68 65 20 6e 6d 73 67 20 ;; the nmsg
10e0: 6d 65 74 68 6f 64 20 64 6f 65 73 20 74 68 65 20 method does the
10f0: 65 6e 63 6f 64 69 6e 67 20 75 6e 64 65 72 20 74 encoding under t
1100: 68 65 20 68 6f 6f 64 20 28 74 68 65 20 68 74 74 he hood (the htt
1110: 70 20 6d 65 74 68 6f 64 20 73 68 6f 75 6c 64 20 p method should
1120: 62 65 20 63 68 61 6e 67 65 64 20 74 6f 20 64 6f be changed to do
1130: 20 74 68 69 73 20 61 6c 73 6f 29 0a 20 20 20 20 this also).
1140: 28 69 66 20 63 6f 6e 6e 65 63 74 69 6f 6e 2d 69 (if connection-i
1150: 6e 66 6f 0a 09 3b 3b 20 75 73 65 20 74 68 65 20 nfo..;; use the
1160: 73 65 72 76 65 72 20 69 66 20 68 61 76 65 20 63 server if have c
1170: 6f 6e 6e 65 63 74 69 6f 6e 20 69 6e 66 6f 0a 09 onnection info..
1180: 28 6c 65 74 2a 20 28 28 64 61 74 20 20 20 20 20 (let* ((dat
1190: 28 63 61 73 65 20 2a 74 72 61 6e 73 70 6f 72 74 (case *transport
11a0: 2d 74 79 70 65 2a 0a 09 09 09 20 20 28 28 68 74 -type*.... ((ht
11b0: 74 70 29 28 63 6f 6e 64 69 74 69 6f 6e 2d 63 61 tp)(condition-ca
11c0: 73 65 0a 09 09 09 09 20 20 28 68 74 74 70 2d 74 se..... (http-t
11d0: 72 61 6e 73 70 6f 72 74 3a 63 6c 69 65 6e 74 2d ransport:client-
11e0: 61 70 69 2d 73 65 6e 64 2d 72 65 63 65 69 76 65 api-send-receive
11f0: 20 72 75 6e 2d 69 64 20 63 6f 6e 6e 65 63 74 69 run-id connecti
1200: 6f 6e 2d 69 6e 66 6f 20 63 6d 64 20 70 61 72 61 on-info cmd para
1210: 6d 73 29 0a 09 09 09 09 20 20 28 28 63 6f 6d 6d ms)..... ((comm
1220: 66 61 69 6c 29 28 76 65 63 74 6f 72 20 23 66 20 fail)(vector #f
1230: 22 63 6f 6d 6d 75 6e 69 63 61 74 69 6f 6e 73 20 "communications
1240: 66 61 69 6c 22 29 29 0a 09 09 09 09 20 20 28 28 fail"))..... ((
1250: 65 78 6e 29 28 76 65 63 74 6f 72 20 23 66 20 22 exn)(vector #f "
1260: 6f 74 68 65 72 20 66 61 69 6c 22 29 29 29 29 0a other fail")))).
1270: 09 09 09 20 20 28 28 6e 6d 73 67 29 28 63 6f 6e ... ((nmsg)(con
1280: 64 69 74 69 6f 6e 2d 63 61 73 65 0a 09 09 09 09 dition-case.....
1290: 20 20 28 6e 6d 73 67 2d 74 72 61 6e 73 70 6f 72 (nmsg-transpor
12a0: 74 3a 63 6c 69 65 6e 74 2d 61 70 69 2d 73 65 6e t:client-api-sen
12b0: 64 2d 72 65 63 65 69 76 65 20 72 75 6e 2d 69 64 d-receive run-id
12c0: 20 63 6f 6e 6e 65 63 74 69 6f 6e 2d 69 6e 66 6f connection-info
12d0: 20 63 6d 64 20 70 61 72 61 6d 73 29 0a 09 09 09 cmd params)....
12e0: 09 20 20 28 28 74 69 6d 65 6f 75 74 29 28 76 65 . ((timeout)(ve
12f0: 63 74 6f 72 20 23 66 20 22 74 69 6d 65 6f 75 74 ctor #f "timeout
1300: 20 74 61 6c 6b 69 6e 67 20 74 6f 20 73 65 72 76 talking to serv
1310: 65 72 22 29 29 29 29 0a 09 09 09 20 20 28 65 6c er")))).... (el
1320: 73 65 20 20 28 65 78 69 74 29 29 29 29 0a 09 20 se (exit))))..
1330: 20 20 20 20 20 20 28 73 75 63 63 65 73 73 20 28 (success (
1340: 69 66 20 28 76 65 63 74 6f 72 3f 20 64 61 74 29 if (vector? dat)
1350: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 64 61 74 (vector-ref dat
1360: 20 30 29 20 23 66 29 29 0a 09 20 20 20 20 20 20 0) #f))..
1370: 20 28 72 65 73 20 20 20 20 20 28 69 66 20 28 76 (res (if (v
1380: 65 63 74 6f 72 3f 20 64 61 74 29 20 28 76 65 63 ector? dat) (vec
1390: 74 6f 72 2d 72 65 66 20 64 61 74 20 31 29 20 23 tor-ref dat 1) #
13a0: 66 29 29 29 0a 09 20 20 28 69 66 20 28 76 65 63 f))).. (if (vec
13b0: 74 6f 72 3f 20 63 6f 6e 6e 65 63 74 69 6f 6e 2d tor? connection-
13c0: 69 6e 66 6f 29 28 68 74 74 70 2d 74 72 61 6e 73 info)(http-trans
13d0: 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 74 2d port:server-dat-
13e0: 75 70 64 61 74 65 2d 6c 61 73 74 2d 61 63 63 65 update-last-acce
13f0: 73 73 20 63 6f 6e 6e 65 63 74 69 6f 6e 2d 69 6e ss connection-in
1400: 66 6f 29 29 0a 09 20 20 28 69 66 20 73 75 63 63 fo)).. (if succ
1410: 65 73 73 0a 09 20 20 20 20 20 20 28 62 65 67 69 ess.. (begi
1420: 6e 0a 09 09 3b 3b 20 28 6d 75 74 65 78 2d 75 6e n...;; (mutex-un
1430: 6c 6f 63 6b 21 20 2a 73 65 6e 64 2d 72 65 63 65 lock! *send-rece
1440: 69 76 65 2d 6d 75 74 65 78 2a 29 0a 09 09 28 63 ive-mutex*)...(c
1450: 61 73 65 20 2a 74 72 61 6e 73 70 6f 72 74 2d 74 ase *transport-t
1460: 79 70 65 2a 20 0a 09 09 20 20 28 28 68 74 74 70 ype* ... ((http
1470: 29 20 72 65 73 29 20 3b 3b 20 28 64 62 3a 73 74 ) res) ;; (db:st
1480: 72 69 6e 67 2d 3e 6f 62 6a 20 72 65 73 29 29 0a ring->obj res)).
1490: 09 09 20 20 28 28 6e 6d 73 67 29 20 72 65 73 29 .. ((nmsg) res)
14a0: 29 29 20 3b 3b 20 28 76 65 63 74 6f 72 2d 72 65 )) ;; (vector-re
14b0: 66 20 72 65 73 20 31 29 29 29 0a 09 20 20 20 20 f res 1)))..
14c0: 20 20 28 62 65 67 69 6e 20 3b 3b 20 6c 65 74 20 (begin ;; let
14d0: 28 28 6e 65 77 2d 63 6f 6e 6e 65 63 74 69 6f 6e ((new-connection
14e0: 2d 69 6e 66 6f 20 28 63 6c 69 65 6e 74 3a 73 65 -info (client:se
14f0: 74 75 70 20 72 75 6e 2d 69 64 29 29 29 0a 09 09 tup run-id)))...
1500: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
1510: 57 41 52 4e 49 4e 47 3a 20 43 6f 6d 6d 75 6e 69 WARNING: Communi
1520: 63 61 74 69 6f 6e 20 66 61 69 6c 65 64 2c 20 74 cation failed, t
1530: 72 79 69 6e 67 20 63 61 6c 6c 20 74 6f 20 72 6d rying call to rm
1540: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 61 t:send-receive a
1550: 67 61 69 6e 2e 22 29 0a 09 09 3b 3b 20 28 63 61 gain.")...;; (ca
1560: 73 65 20 2a 74 72 61 6e 73 70 6f 72 74 2d 74 79 se *transport-ty
1570: 70 65 2a 0a 09 09 3b 3b 20 20 20 28 28 6e 6d 73 pe*...;; ((nms
1580: 67 29 28 6e 6e 2d 63 6c 6f 73 65 20 28 68 74 74 g)(nn-close (htt
1590: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 p-transport:serv
15a0: 65 72 2d 64 61 74 2d 67 65 74 2d 73 6f 63 6b 65 er-dat-get-socke
15b0: 74 20 63 6f 6e 6e 65 63 74 69 6f 6e 2d 69 6e 66 t connection-inf
15c0: 6f 29 29 29 29 0a 09 09 28 68 61 73 68 2d 74 61 o))))...(hash-ta
15d0: 62 6c 65 2d 64 65 6c 65 74 65 21 20 2a 72 75 6e ble-delete! *run
15e0: 72 65 6d 6f 74 65 2a 20 72 75 6e 2d 69 64 29 20 remote* run-id)
15f0: 3b 3b 20 64 6f 6e 27 74 20 6b 65 65 70 20 75 73 ;; don't keep us
1600: 69 6e 67 20 74 68 65 20 73 61 6d 65 20 63 6f 6e ing the same con
1610: 6e 65 63 74 69 6f 6e 0a 09 09 3b 3b 20 4e 4f 54 nection...;; NOT
1620: 45 3a 20 6b 69 6c 6c 69 6e 67 20 73 65 72 76 65 E: killing serve
1630: 72 20 63 61 75 73 65 73 20 74 68 69 73 20 70 72 r causes this pr
1640: 6f 63 65 73 73 20 74 6f 20 62 6c 6f 63 6b 20 66 ocess to block f
1650: 6f 72 65 76 65 72 2e 20 4e 6f 20 69 64 65 61 20 orever. No idea
1660: 77 68 79 2e 20 44 65 63 20 32 2e 20 0a 09 09 3b why. Dec 2. ...;
1670: 3b 20 28 69 66 20 28 65 71 3f 20 28 6d 6f 64 75 ; (if (eq? (modu
1680: 6c 6f 20 61 74 74 65 6d 70 74 6e 75 6d 20 35 29 lo attemptnum 5)
1690: 20 30 29 0a 09 09 3b 3b 20 20 20 20 20 28 74 61 0)...;; (ta
16a0: 73 6b 73 3a 6b 69 6c 6c 2d 73 65 72 76 65 72 2d sks:kill-server-
16b0: 72 75 6e 2d 69 64 20 72 75 6e 2d 69 64 20 74 61 run-id run-id ta
16c0: 67 3a 20 22 61 70 69 2d 73 65 6e 64 2d 72 65 63 g: "api-send-rec
16d0: 65 69 76 65 2d 66 61 69 6c 65 64 22 29 29 0a 09 eive-failed"))..
16e0: 09 3b 3b 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 .;; (mutex-unloc
16f0: 6b 21 20 2a 73 65 6e 64 2d 72 65 63 65 69 76 65 k! *send-receive
1700: 2d 6d 75 74 65 78 2a 29 20 3b 3b 20 63 6c 6f 73 -mutex*) ;; clos
1710: 65 20 74 68 65 20 6d 75 74 65 78 20 68 65 72 65 e the mutex here
1720: 20 74 6f 20 61 6c 6c 6f 77 20 6f 74 68 65 72 20 to allow other
1730: 74 68 72 65 61 64 73 20 61 63 63 65 73 73 20 74 threads access t
1740: 6f 20 63 6f 6d 6d 75 6e 69 63 61 74 69 6f 6e 73 o communications
1750: 0a 09 09 28 74 61 73 6b 73 3a 73 74 61 72 74 2d ...(tasks:start-
1760: 61 6e 64 2d 77 61 69 74 2d 66 6f 72 2d 73 65 72 and-wait-for-ser
1770: 76 65 72 20 28 74 61 73 6b 73 3a 6f 70 65 6e 2d ver (tasks:open-
1780: 64 62 29 20 72 75 6e 2d 69 64 20 31 35 29 0a 09 db) run-id 15)..
1790: 09 3b 3b 20 28 6e 6d 73 67 2d 74 72 61 6e 73 70 .;; (nmsg-transp
17a0: 6f 72 74 3a 63 6c 69 65 6e 74 2d 61 70 69 2d 73 ort:client-api-s
17b0: 65 6e 64 2d 72 65 63 65 69 76 65 20 72 75 6e 2d end-receive run-
17c0: 69 64 20 63 6f 6e 6e 65 63 74 69 6f 6e 2d 69 6e id connection-in
17d0: 66 6f 20 63 6d 64 20 70 61 72 61 6d 20 72 65 6d fo cmd param rem
17e0: 74 72 69 65 73 3a 20 28 2d 20 72 65 6d 74 72 69 tries: (- remtri
17f0: 65 73 20 31 29 29 29 29 29 29 0a 0a 09 09 3b 3b es 1))))))....;;
1800: 20 6e 6f 20 6c 6f 6e 67 65 72 20 6b 69 6c 6c 69 no longer killi
1810: 6e 67 20 74 68 65 20 73 65 72 76 65 72 20 69 6e ng the server in
1820: 20 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a http-transport:
1830: 63 6c 69 65 6e 74 2d 61 70 69 2d 73 65 6e 64 2d client-api-send-
1840: 72 65 63 65 69 76 65 0a 09 09 3b 3b 20 6d 61 79 receive...;; may
1850: 20 6b 69 6c 6c 20 69 74 20 68 65 72 65 20 62 75 kill it here bu
1860: 74 20 77 68 61 74 20 61 72 65 20 74 68 65 20 63 t what are the c
1870: 72 69 74 65 72 69 61 3f 0a 09 09 3b 3b 20 73 74 riteria?...;; st
1880: 61 72 74 20 77 69 74 68 20 74 68 72 65 65 20 63 art with three c
1890: 61 6c 6c 73 20 74 68 65 6e 20 6b 69 6c 6c 20 73 alls then kill s
18a0: 65 72 76 65 72 0a 09 09 3b 3b 20 28 69 66 20 28 erver...;; (if (
18b0: 65 71 3f 20 61 74 74 65 6d 70 74 6e 75 6d 20 33 eq? attemptnum 3
18c0: 29 28 74 61 73 6b 73 3a 6b 69 6c 6c 2d 73 65 72 )(tasks:kill-ser
18d0: 76 65 72 2d 72 75 6e 2d 69 64 20 72 75 6e 2d 69 ver-run-id run-i
18e0: 64 29 29 0a 09 09 3b 3b 20 28 74 68 72 65 61 64 d))...;; (thread
18f0: 2d 73 6c 65 65 70 21 20 32 29 0a 09 09 28 72 6d -sleep! 2)...(rm
1900: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 63 t:send-receive c
1910: 6d 64 20 72 75 6e 2d 69 64 20 70 61 72 61 6d 73 md run-id params
1920: 20 61 74 74 65 6d 70 74 6e 75 6d 3a 20 28 2b 20 attemptnum: (+
1930: 61 74 74 65 6d 70 74 6e 75 6d 20 31 29 29 29 29 attemptnum 1))))
1940: 29 0a 09 3b 3b 20 6e 6f 20 63 6f 6e 6e 65 63 74 )..;; no connect
1950: 69 6f 6e 20 69 6e 66 6f 3f 20 74 72 79 20 74 6f ion info? try to
1960: 20 73 74 61 72 74 20 61 20 73 65 72 76 65 72 2c start a server,
1970: 20 6f 72 20 61 63 63 65 73 73 20 6c 6f 63 61 6c or access local
1980: 6c 79 20 69 66 20 6e 6f 0a 09 3b 3b 20 73 65 72 ly if no..;; ser
1990: 76 65 72 20 61 6e 64 20 74 68 65 20 71 75 65 72 ver and the quer
19a0: 79 20 69 73 20 72 65 61 64 2d 6f 6e 6c 79 0a 09 y is read-only..
19b0: 3b 3b 0a 09 3b 3b 20 4e 6f 74 65 3a 20 54 68 65 ;;..;; Note: The
19c0: 20 74 61 73 6b 73 20 64 62 20 77 61 73 20 63 68 tasks db was ch
19d0: 65 63 6b 65 64 20 66 6f 72 20 61 20 73 65 72 76 ecked for a serv
19e0: 65 72 20 69 6e 20 73 74 61 72 74 69 6e 67 20 6d er in starting m
19f0: 6f 64 65 20 69 6e 20 74 68 65 20 72 6d 74 3a 67 ode in the rmt:g
1a00: 65 74 2d 63 6f 6e 6e 65 63 74 69 6f 6e 2d 69 6e et-connection-in
1a10: 66 6f 20 63 61 6c 6c 0a 09 3b 3b 0a 09 28 69 66 fo call..;;..(if
1a20: 20 28 61 6e 64 20 28 3c 20 61 74 74 65 6d 70 74 (and (< attempt
1a30: 6e 75 6d 20 31 35 29 0a 09 09 20 28 6d 65 6d 62 num 15)... (memb
1a40: 65 72 20 63 6d 64 20 61 70 69 3a 77 72 69 74 65 er cmd api:write
1a50: 2d 71 75 65 72 69 65 73 29 29 0a 09 20 20 20 20 -queries))..
1a60: 28 6c 65 74 20 28 28 66 61 73 74 73 74 61 72 74 (let ((faststart
1a70: 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 (configf:lookup
1a80: 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 *configdat* "se
1a90: 72 76 65 72 22 20 22 66 61 73 74 73 74 61 72 74 rver" "faststart
1aa0: 22 29 29 29 0a 09 20 20 20 20 20 20 28 68 61 73 "))).. (has
1ab0: 68 2d 74 61 62 6c 65 2d 64 65 6c 65 74 65 21 20 h-table-delete!
1ac0: 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 72 75 6e 2d *runremote* run-
1ad0: 69 64 29 0a 09 20 20 20 20 20 20 3b 3b 20 28 6d id).. ;; (m
1ae0: 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 73 65 utex-unlock! *se
1af0: 6e 64 2d 72 65 63 65 69 76 65 2d 6d 75 74 65 78 nd-receive-mutex
1b00: 2a 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 61 *).. (if (a
1b10: 6e 64 20 66 61 73 74 73 74 61 72 74 20 28 65 71 nd faststart (eq
1b20: 75 61 6c 3f 20 66 61 73 74 73 74 61 72 74 20 22 ual? faststart "
1b30: 6e 6f 22 29 29 0a 09 09 20 20 28 62 65 67 69 6e no"))... (begin
1b40: 0a 09 09 20 20 20 20 28 74 61 73 6b 73 3a 73 74 ... (tasks:st
1b50: 61 72 74 2d 61 6e 64 2d 77 61 69 74 2d 66 6f 72 art-and-wait-for
1b60: 2d 73 65 72 76 65 72 20 28 64 62 3a 64 65 6c 61 -server (db:dela
1b70: 79 2d 69 66 2d 62 75 73 79 20 28 74 61 73 6b 73 y-if-busy (tasks
1b80: 3a 6f 70 65 6e 2d 64 62 29 29 20 72 75 6e 2d 69 :open-db)) run-i
1b90: 64 20 31 30 29 0a 09 09 20 20 20 20 28 74 68 72 d 10)... (thr
1ba0: 65 61 64 2d 73 6c 65 65 70 21 20 28 72 61 6e 64 ead-sleep! (rand
1bb0: 6f 6d 20 35 29 29 20 3b 3b 20 67 69 76 65 20 73 om 5)) ;; give s
1bc0: 6f 6d 65 20 74 69 6d 65 20 74 6f 20 73 65 74 74 ome time to sett
1bd0: 6c 65 20 61 6e 64 20 6d 69 6e 69 6d 69 7a 65 20 le and minimize
1be0: 63 6f 6c 6c 69 73 6f 6e 3f 0a 09 09 20 20 20 20 collison?...
1bf0: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
1c00: 65 20 63 6d 64 20 72 69 64 20 70 61 72 61 6d 73 e cmd rid params
1c10: 20 61 74 74 65 6d 70 74 6e 75 6d 3a 20 28 2b 20 attemptnum: (+
1c20: 61 74 74 65 6d 70 74 6e 75 6d 20 31 29 29 29 0a attemptnum 1))).
1c30: 09 09 20 20 28 6c 65 74 20 28 28 73 74 61 72 74 .. (let ((start
1c40: 2d 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d 6d -time (current-m
1c50: 69 6c 6c 69 73 65 63 6f 6e 64 73 29 29 0a 09 09 illiseconds))...
1c60: 09 28 6d 61 78 2d 71 75 65 72 79 20 20 28 73 74 .(max-query (st
1c70: 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 6f 72 ring->number (or
1c80: 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 (configf:lookup
1c90: 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 *configdat* "se
1ca0: 72 76 65 72 22 20 22 73 65 72 76 65 72 2d 71 75 rver" "server-qu
1cb0: 65 72 79 2d 74 68 72 65 73 68 6f 6c 64 22 29 0a ery-threshold").
1cc0: 09 09 09 09 09 09 09 22 33 30 30 22 29 29 29 0a ......."300"))).
1cd0: 09 09 09 28 6e 65 77 72 65 73 20 20 20 20 20 28 ...(newres (
1ce0: 72 6d 74 3a 6f 70 65 6e 2d 71 72 79 2d 63 6c 6f rmt:open-qry-clo
1cf0: 73 65 2d 6c 6f 63 61 6c 6c 79 20 63 6d 64 20 72 se-locally cmd r
1d00: 75 6e 2d 69 64 20 70 61 72 61 6d 73 29 29 29 0a un-id params))).
1d10: 09 09 20 20 20 20 28 6c 65 74 20 28 28 64 65 6c .. (let ((del
1d20: 74 61 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 6d ta (- (current-m
1d30: 69 6c 6c 69 73 65 63 6f 6e 64 73 29 20 73 74 61 illiseconds) sta
1d40: 72 74 2d 74 69 6d 65 29 29 29 0a 09 09 20 20 20 rt-time)))...
1d50: 20 20 20 28 69 66 20 28 3e 20 64 65 6c 74 61 20 (if (> delta
1d60: 6d 61 78 2d 71 75 65 72 79 29 0a 09 09 09 20 20 max-query)....
1d70: 28 62 65 67 69 6e 0a 09 09 09 20 20 20 20 28 64 (begin.... (d
1d80: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
1d90: 30 20 22 53 74 61 72 74 69 6e 67 20 73 65 72 76 0 "Starting serv
1da0: 65 72 20 61 73 20 71 75 65 72 79 20 74 69 6d 65 er as query time
1db0: 20 22 20 64 65 6c 74 61 20 22 20 69 73 20 6f 76 " delta " is ov
1dc0: 65 72 20 74 68 65 20 6c 69 6d 69 74 20 6f 66 20 er the limit of
1dd0: 22 20 6d 61 78 2d 71 75 65 72 79 29 0a 09 09 09 " max-query)....
1de0: 20 20 20 20 28 73 65 72 76 65 72 3a 6b 69 6e 64 (server:kind
1df0: 2d 72 75 6e 20 72 75 6e 2d 69 64 29 29 29 0a 09 -run run-id)))..
1e00: 09 20 20 20 20 20 20 3b 3b 20 72 65 74 75 72 6e . ;; return
1e10: 20 74 68 65 20 72 65 73 75 6c 74 21 0a 09 09 20 the result!...
1e20: 20 20 20 20 20 6e 65 77 72 65 73 29 0a 09 09 20 newres)...
1e30: 20 20 20 29 29 29 0a 09 20 20 20 20 28 62 65 67 ))).. (beg
1e40: 69 6e 0a 09 20 20 20 20 20 20 3b 3b 20 28 64 65 in.. ;; (de
1e50: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 bug:print 0 "ERR
1e60: 4f 52 3a 20 43 6f 6d 6d 75 6e 69 63 61 74 69 6f OR: Communicatio
1e70: 6e 20 66 61 69 6c 65 64 21 22 29 0a 09 20 20 20 n failed!")..
1e80: 20 20 20 3b 3b 20 28 6d 75 74 65 78 2d 75 6e 6c ;; (mutex-unl
1e90: 6f 63 6b 21 20 2a 73 65 6e 64 2d 72 65 63 65 69 ock! *send-recei
1ea0: 76 65 2d 6d 75 74 65 78 2a 29 0a 09 20 20 20 20 ve-mutex*)..
1eb0: 20 20 3b 3b 20 28 65 78 69 74 29 0a 09 20 20 20 ;; (exit)..
1ec0: 20 20 20 28 72 6d 74 3a 6f 70 65 6e 2d 71 72 79 (rmt:open-qry
1ed0: 2d 63 6c 6f 73 65 2d 6c 6f 63 61 6c 6c 79 20 63 -close-locally c
1ee0: 6d 64 20 72 75 6e 2d 69 64 20 70 61 72 61 6d 73 md run-id params
1ef0: 29 0a 09 20 20 20 20 20 20 29 29 29 29 29 0a 0a ).. )))))..
1f00: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 75 70 64 (define (rmt:upd
1f10: 61 74 65 2d 64 62 2d 73 74 61 74 73 20 72 75 6e ate-db-stats run
1f20: 2d 69 64 20 72 61 77 63 6d 64 20 70 61 72 61 6d -id rawcmd param
1f30: 73 20 64 75 72 61 74 69 6f 6e 29 0a 20 20 28 6d s duration). (m
1f40: 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 64 62 2d 73 utex-lock! *db-s
1f50: 74 61 74 73 2d 6d 75 74 65 78 2a 29 0a 20 20 28 tats-mutex*). (
1f60: 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e handle-exception
1f70: 73 0a 20 20 20 65 78 6e 0a 20 20 20 28 62 65 67 s. exn. (beg
1f80: 69 6e 0a 20 20 20 20 20 28 64 65 62 75 67 3a 70 in. (debug:p
1f90: 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a rint 0 "WARNING:
1fa0: 20 73 74 61 74 73 20 63 6f 6c 6c 65 63 74 69 6f stats collectio
1fb0: 6e 20 66 61 69 6c 65 64 20 69 6e 20 75 70 64 61 n failed in upda
1fc0: 74 65 2d 64 62 2d 73 74 61 74 73 22 29 0a 20 20 te-db-stats").
1fd0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
1fe0: 30 20 22 20 6d 65 73 73 61 67 65 3a 20 22 20 28 0 " message: " (
1ff0: 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 (condition-prope
2000: 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 rty-accessor 'ex
2010: 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 n 'message) exn)
2020: 29 0a 20 20 20 20 20 28 70 72 69 6e 74 20 22 65 ). (print "e
2030: 78 6e 3d 22 20 28 63 6f 6e 64 69 74 69 6f 6e 2d xn=" (condition-
2040: 3e 6c 69 73 74 20 65 78 6e 29 29 0a 20 20 20 20 >list exn)).
2050: 20 23 66 29 20 3b 3b 20 69 66 20 74 68 69 73 20 #f) ;; if this
2060: 66 61 69 6c 73 20 77 65 20 64 6f 6e 27 74 20 63 fails we don't c
2070: 61 72 65 2c 20 69 74 20 69 73 20 6a 75 73 74 20 are, it is just
2080: 73 74 61 74 73 0a 20 20 20 28 6c 65 74 2a 20 28 stats. (let* (
2090: 28 63 6d 64 20 20 20 20 20 20 28 63 6f 6e 63 20 (cmd (conc
20a0: 22 72 75 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 64 "run-id=" run-id
20b0: 20 22 20 22 20 28 69 66 20 28 65 71 3f 20 72 61 " " (if (eq? ra
20c0: 77 63 6d 64 20 27 67 65 6e 65 72 61 6c 2d 63 61 wcmd 'general-ca
20d0: 6c 6c 29 20 28 63 61 72 20 70 61 72 61 6d 73 29 ll) (car params)
20e0: 20 72 61 77 63 6d 64 29 29 29 0a 09 20 20 28 73 rawcmd))).. (s
20f0: 74 61 74 2d 76 65 63 20 28 68 61 73 68 2d 74 61 tat-vec (hash-ta
2100: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
2110: 2a 64 62 2d 73 74 61 74 73 2a 20 63 6d 64 20 23 *db-stats* cmd #
2120: 66 29 29 29 0a 20 20 20 20 20 28 69 66 20 28 6e f))). (if (n
2130: 6f 74 20 28 76 65 63 74 6f 72 3f 20 73 74 61 74 ot (vector? stat
2140: 2d 76 65 63 29 29 0a 09 20 28 6c 65 74 20 28 28 -vec)).. (let ((
2150: 6e 65 77 76 65 63 20 28 76 65 63 74 6f 72 20 30 newvec (vector 0
2160: 20 30 29 29 29 0a 09 20 20 20 28 68 61 73 68 2d 0))).. (hash-
2170: 74 61 62 6c 65 2d 73 65 74 21 20 2a 64 62 2d 73 table-set! *db-s
2180: 74 61 74 73 2a 20 63 6d 64 20 6e 65 77 76 65 63 tats* cmd newvec
2190: 29 0a 09 20 20 20 28 73 65 74 21 20 73 74 61 74 ).. (set! stat
21a0: 2d 76 65 63 20 6e 65 77 76 65 63 29 29 29 0a 20 -vec newvec))).
21b0: 20 20 20 20 28 76 65 63 74 6f 72 2d 73 65 74 21 (vector-set!
21c0: 20 73 74 61 74 2d 76 65 63 20 30 20 28 2b 20 28 stat-vec 0 (+ (
21d0: 76 65 63 74 6f 72 2d 72 65 66 20 73 74 61 74 2d vector-ref stat-
21e0: 76 65 63 20 30 29 20 31 29 29 0a 20 20 20 20 20 vec 0) 1)).
21f0: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 73 74 61 (vector-set! sta
2200: 74 2d 76 65 63 20 31 20 28 2b 20 28 76 65 63 74 t-vec 1 (+ (vect
2210: 6f 72 2d 72 65 66 20 73 74 61 74 2d 76 65 63 20 or-ref stat-vec
2220: 31 29 20 64 75 72 61 74 69 6f 6e 29 29 29 29 0a 1) duration)))).
2230: 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 (mutex-unlock!
2240: 20 2a 64 62 2d 73 74 61 74 73 2d 6d 75 74 65 78 *db-stats-mutex
2250: 2a 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 72 *))...(define (r
2260: 6d 74 3a 70 72 69 6e 74 2d 64 62 2d 73 74 61 74 mt:print-db-stat
2270: 73 29 0a 20 20 28 6c 65 74 20 28 28 66 6d 74 73 s). (let ((fmts
2280: 74 72 20 22 7e 34 30 61 7e 37 2d 64 7e 39 2d 64 tr "~40a~7-d~9-d
2290: 7e 32 30 2c 32 2d 66 22 29 29 20 3b 3b 20 22 7e ~20,2-f")) ;; "~
22a0: 32 30 2c 32 2d 66 22 0a 20 20 20 20 28 64 65 62 20,2-f". (deb
22b0: 75 67 3a 70 72 69 6e 74 20 31 38 20 22 44 42 20 ug:print 18 "DB
22c0: 53 74 61 74 73 5c 6e 3d 3d 3d 3d 3d 3d 3d 3d 22 Stats\n========"
22d0: 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 ). (debug:pri
22e0: 6e 74 20 31 38 20 28 66 6f 72 6d 61 74 20 23 66 nt 18 (format #f
22f0: 20 22 7e 34 30 61 7e 38 61 7e 31 30 61 7e 31 30 "~40a~8a~10a~10
2300: 61 22 20 22 43 6d 64 22 20 22 43 6f 75 6e 74 22 a" "Cmd" "Count"
2310: 20 22 54 6f 74 54 69 6d 65 22 20 22 41 76 67 22 "TotTime" "Avg"
2320: 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 )). (for-each
2330: 20 28 6c 61 6d 62 64 61 20 28 63 6d 64 29 0a 09 (lambda (cmd)..
2340: 09 28 6c 65 74 20 28 28 63 6d 64 2d 64 61 74 20 .(let ((cmd-dat
2350: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 (hash-table-ref
2360: 2a 64 62 2d 73 74 61 74 73 2a 20 63 6d 64 29 29 *db-stats* cmd))
2370: 29 0a 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 )... (debug:pri
2380: 6e 74 20 31 38 20 28 66 6f 72 6d 61 74 20 23 66 nt 18 (format #f
2390: 20 66 6d 74 73 74 72 20 63 6d 64 20 28 76 65 63 fmtstr cmd (vec
23a0: 74 6f 72 2d 72 65 66 20 63 6d 64 2d 64 61 74 20 tor-ref cmd-dat
23b0: 30 29 20 28 76 65 63 74 6f 72 2d 72 65 66 20 63 0) (vector-ref c
23c0: 6d 64 2d 64 61 74 20 31 29 20 28 2f 20 28 76 65 md-dat 1) (/ (ve
23d0: 63 74 6f 72 2d 72 65 66 20 63 6d 64 2d 64 61 74 ctor-ref cmd-dat
23e0: 20 31 29 28 76 65 63 74 6f 72 2d 72 65 66 20 63 1)(vector-ref c
23f0: 6d 64 2d 64 61 74 20 30 29 29 29 29 29 29 0a 09 md-dat 0))))))..
2400: 20 20 20 20 20 20 28 73 6f 72 74 20 28 68 61 73 (sort (has
2410: 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 2a 64 62 h-table-keys *db
2420: 2d 73 74 61 74 73 2a 29 0a 09 09 20 20 20 20 28 -stats*)... (
2430: 6c 61 6d 62 64 61 20 28 61 20 62 29 0a 09 09 20 lambda (a b)...
2440: 20 20 20 20 20 28 3e 20 28 76 65 63 74 6f 72 2d (> (vector-
2450: 72 65 66 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ref (hash-table-
2460: 72 65 66 20 2a 64 62 2d 73 74 61 74 73 2a 20 61 ref *db-stats* a
2470: 29 20 30 29 0a 09 09 09 20 28 76 65 63 74 6f 72 ) 0).... (vector
2480: 2d 72 65 66 20 28 68 61 73 68 2d 74 61 62 6c 65 -ref (hash-table
2490: 2d 72 65 66 20 2a 64 62 2d 73 74 61 74 73 2a 20 -ref *db-stats*
24a0: 62 29 20 30 29 29 29 29 29 29 29 0a 0a 28 64 65 b) 0)))))))..(de
24b0: 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 6d 61 fine (rmt:get-ma
24c0: 78 2d 71 75 65 72 79 2d 61 76 65 72 61 67 65 20 x-query-average
24d0: 72 75 6e 2d 69 64 29 0a 20 20 28 6d 75 74 65 78 run-id). (mutex
24e0: 2d 6c 6f 63 6b 21 20 2a 64 62 2d 73 74 61 74 73 -lock! *db-stats
24f0: 2d 6d 75 74 65 78 2a 29 0a 20 20 28 6c 65 74 2a -mutex*). (let*
2500: 20 28 28 72 75 6e 6b 65 79 20 28 63 6f 6e 63 20 ((runkey (conc
2510: 22 72 75 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 64 "run-id=" run-id
2520: 20 22 20 22 29 29 0a 09 20 28 63 6d 64 73 20 20 " ")).. (cmds
2530: 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 (filter (lambda
2540: 20 28 78 29 0a 09 09 09 20 20 20 28 73 75 62 73 (x).... (subs
2550: 74 72 69 6e 67 2d 69 6e 64 65 78 20 72 75 6e 6b tring-index runk
2560: 65 79 20 78 29 29 0a 09 09 09 20 28 68 61 73 68 ey x)).... (hash
2570: 2d 74 61 62 6c 65 2d 6b 65 79 73 20 2a 64 62 2d -table-keys *db-
2580: 73 74 61 74 73 2a 29 29 29 0a 09 20 28 72 65 73 stats*))).. (res
2590: 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 63 (if (null? c
25a0: 6d 64 73 29 0a 09 09 20 20 20 20 20 28 63 6f 6e mds)... (con
25b0: 73 20 27 6e 6f 6e 65 20 30 29 0a 09 09 20 20 20 s 'none 0)...
25c0: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 63 6d (let loop ((cm
25d0: 64 20 28 63 61 72 20 63 6d 64 73 29 29 0a 09 09 d (car cmds))...
25e0: 09 09 28 74 61 6c 20 28 63 64 72 20 63 6d 64 73 ..(tal (cdr cmds
25f0: 29 29 0a 09 09 09 09 28 6d 61 78 2d 63 6d 64 20 )).....(max-cmd
2600: 28 63 61 72 20 63 6d 64 73 29 29 0a 09 09 09 09 (car cmds)).....
2610: 28 72 65 73 20 30 29 29 0a 09 09 20 20 20 20 20 (res 0))...
2620: 20 20 28 6c 65 74 2a 20 28 28 63 6d 64 2d 64 61 (let* ((cmd-da
2630: 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 t (hash-table-re
2640: 66 20 2a 64 62 2d 73 74 61 74 73 2a 20 63 6d 64 f *db-stats* cmd
2650: 29 29 0a 09 09 09 20 20 20 20 20 20 28 74 6f 74 )).... (tot
2660: 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 (vector-ref
2670: 20 63 6d 64 2d 64 61 74 20 30 29 29 0a 09 09 09 cmd-dat 0))....
2680: 20 20 20 20 20 20 28 63 75 72 72 61 76 67 20 28 (curravg (
2690: 2f 20 28 76 65 63 74 6f 72 2d 72 65 66 20 63 6d / (vector-ref cm
26a0: 64 2d 64 61 74 20 31 29 20 28 76 65 63 74 6f 72 d-dat 1) (vector
26b0: 2d 72 65 66 20 63 6d 64 2d 64 61 74 20 30 29 29 -ref cmd-dat 0))
26c0: 29 20 3b 3b 20 63 6f 75 6e 74 20 69 73 20 6e 65 ) ;; count is ne
26d0: 76 65 72 20 7a 65 72 6f 20 62 79 20 63 6f 6e 73 ver zero by cons
26e0: 74 72 75 63 74 69 6f 6e 0a 09 09 09 20 20 20 20 truction....
26f0: 20 20 28 63 75 72 72 6d 61 78 20 28 6d 61 78 20 (currmax (max
2700: 72 65 73 20 63 75 72 72 61 76 67 29 29 0a 09 09 res curravg))...
2710: 09 20 20 20 20 20 20 28 6e 65 77 6d 61 78 2d 63 . (newmax-c
2720: 6d 64 20 28 69 66 20 28 3e 20 63 75 72 72 61 76 md (if (> currav
2730: 67 20 72 65 73 29 20 63 6d 64 20 6d 61 78 2d 63 g res) cmd max-c
2740: 6d 64 29 29 29 0a 09 09 09 20 28 69 66 20 28 6e md))).... (if (n
2750: 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 09 20 20 20 ull? tal)....
2760: 20 20 28 69 66 20 28 3e 20 74 6f 74 20 31 30 29 (if (> tot 10)
2770: 0a 09 09 09 09 20 28 63 6f 6e 73 20 6e 65 77 6d ..... (cons newm
2780: 61 78 2d 63 6d 64 20 63 75 72 72 6d 61 78 29 0a ax-cmd currmax).
2790: 09 09 09 09 20 28 63 6f 6e 73 20 27 6e 6f 6e 65 .... (cons 'none
27a0: 20 30 29 29 0a 09 09 09 20 20 20 20 20 28 6c 6f 0)).... (lo
27b0: 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 op (car tal)(cdr
27c0: 20 74 61 6c 29 20 6e 65 77 6d 61 78 2d 63 6d 64 tal) newmax-cmd
27d0: 20 63 75 72 72 6d 61 78 29 29 29 29 29 29 29 0a currmax))))))).
27e0: 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 (mutex-unloc
27f0: 6b 21 20 2a 64 62 2d 73 74 61 74 73 2d 6d 75 74 k! *db-stats-mut
2800: 65 78 2a 29 0a 20 20 20 20 72 65 73 29 29 0a 09 ex*). res))..
2810: 20 20 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a .(define (rmt:
2820: 6f 70 65 6e 2d 71 72 79 2d 63 6c 6f 73 65 2d 6c open-qry-close-l
2830: 6f 63 61 6c 6c 79 20 63 6d 64 20 72 75 6e 2d 69 ocally cmd run-i
2840: 64 20 70 61 72 61 6d 73 20 23 21 6b 65 79 20 28 d params #!key (
2850: 72 65 6d 72 65 74 72 69 65 73 20 35 29 29 0a 20 remretries 5)).
2860: 20 28 6c 65 74 2a 20 28 28 64 62 73 74 72 75 63 (let* ((dbstruc
2870: 74 2d 6c 6f 63 61 6c 20 28 69 66 20 2a 64 62 73 t-local (if *dbs
2880: 74 72 75 63 74 2d 64 62 2a 0a 09 09 09 20 20 20 truct-db*....
2890: 20 20 2a 64 62 73 74 72 75 63 74 2d 64 62 2a 0a *dbstruct-db*.
28a0: 09 09 09 20 20 20 20 20 28 6c 65 74 2a 20 28 28 ... (let* ((
28b0: 64 62 64 69 72 20 28 64 62 3a 64 62 66 69 6c 65 dbdir (db:dbfile
28c0: 2d 70 61 74 68 20 23 66 29 29 20 3b 3b 20 20 28 -path #f)) ;; (
28d0: 63 6f 6e 63 20 20 20 20 28 63 6f 6e 66 69 67 66 conc (configf
28e0: 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 :lookup *configd
28f0: 61 74 2a 20 22 73 65 74 75 70 22 20 22 6c 69 6e at* "setup" "lin
2900: 6b 74 72 65 65 22 29 20 22 2f 2e 64 62 22 29 29 ktree") "/.db"))
2910: 0a 09 09 09 09 20 20 20 20 28 64 62 20 28 6d 61 ..... (db (ma
2920: 6b 65 2d 64 62 72 3a 64 62 73 74 72 75 63 74 20 ke-dbr:dbstruct
2930: 70 61 74 68 3a 20 20 64 62 64 69 72 20 6c 6f 63 path: dbdir loc
2940: 61 6c 3a 20 23 74 29 29 29 0a 09 09 09 20 20 20 al: #t)))....
2950: 20 20 20 20 28 73 65 74 21 20 2a 64 62 73 74 72 (set! *dbstr
2960: 75 63 74 2d 64 62 2a 20 64 62 29 0a 09 09 09 20 uct-db* db)....
2970: 20 20 20 20 20 20 64 62 29 29 29 0a 09 20 28 64 db))).. (d
2980: 62 2d 66 69 6c 65 2d 70 61 74 68 20 20 20 28 64 b-file-path (d
2990: 62 3a 64 62 66 69 6c 65 2d 70 61 74 68 20 30 29 b:dbfile-path 0)
29a0: 29 0a 09 20 3b 3b 20 28 72 65 61 64 2d 6f 6e 6c ).. ;; (read-onl
29b0: 79 20 20 20 20 20 20 28 6e 6f 74 20 28 66 69 6c y (not (fil
29c0: 65 2d 72 65 61 64 2d 61 63 63 65 73 73 3f 20 64 e-read-access? d
29d0: 62 2d 66 69 6c 65 2d 70 61 74 68 29 29 29 0a 09 b-file-path)))..
29e0: 20 28 73 74 61 72 74 20 20 20 20 20 20 20 20 20 (start
29f0: 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 (current-millis
2a00: 65 63 6f 6e 64 73 29 29 0a 09 20 28 72 65 73 64 econds)).. (resd
2a10: 61 74 20 20 20 20 20 20 20 20 20 28 61 70 69 3a at (api:
2a20: 65 78 65 63 75 74 65 2d 72 65 71 75 65 73 74 73 execute-requests
2a30: 20 64 62 73 74 72 75 63 74 2d 6c 6f 63 61 6c 20 dbstruct-local
2a40: 28 76 65 63 74 6f 72 20 28 73 79 6d 62 6f 6c 2d (vector (symbol-
2a50: 3e 73 74 72 69 6e 67 20 63 6d 64 29 20 70 61 72 >string cmd) par
2a60: 61 6d 73 29 29 29 0a 09 20 28 73 75 63 63 65 73 ams))).. (succes
2a70: 73 20 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 s (vector
2a80: 2d 72 65 66 20 72 65 73 64 61 74 20 30 29 29 0a -ref resdat 0)).
2a90: 09 20 28 72 65 73 20 20 20 20 20 20 20 20 20 20 . (res
2aa0: 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 65 (vector-ref re
2ab0: 73 64 61 74 20 31 29 29 0a 09 20 28 64 75 72 61 sdat 1)).. (dura
2ac0: 74 69 6f 6e 20 20 20 20 20 20 20 28 2d 20 28 63 tion (- (c
2ad0: 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f urrent-milliseco
2ae0: 6e 64 73 29 20 73 74 61 72 74 29 29 29 0a 20 20 nds) start))).
2af0: 20 20 28 69 66 20 28 6e 6f 74 20 73 75 63 63 65 (if (not succe
2b00: 73 73 29 0a 09 28 69 66 20 28 3e 20 72 65 6d 72 ss)..(if (> remr
2b10: 65 74 72 69 65 73 20 30 29 0a 09 20 20 20 20 28 etries 0).. (
2b20: 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 64 65 begin.. (de
2b30: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 bug:print 0 "ERR
2b40: 4f 52 3a 20 6c 6f 63 61 6c 20 71 75 65 72 79 20 OR: local query
2b50: 66 61 69 6c 65 64 2e 20 54 72 79 69 6e 67 20 61 failed. Trying a
2b60: 67 61 69 6e 2e 22 29 0a 09 20 20 20 20 20 20 28 gain.").. (
2b70: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 28 2f thread-sleep! (/
2b80: 20 28 72 61 6e 64 6f 6d 20 35 30 30 30 29 20 31 (random 5000) 1
2b90: 30 30 30 29 29 20 3b 3b 20 73 6f 6d 65 20 72 61 000)) ;; some ra
2ba0: 6e 64 6f 6d 20 64 65 6c 61 79 20 0a 09 20 20 20 ndom delay ..
2bb0: 20 20 20 28 72 6d 74 3a 6f 70 65 6e 2d 71 72 79 (rmt:open-qry
2bc0: 2d 63 6c 6f 73 65 2d 6c 6f 63 61 6c 6c 79 20 63 -close-locally c
2bd0: 6d 64 20 72 75 6e 2d 69 64 20 70 61 72 61 6d 73 md run-id params
2be0: 20 72 65 6d 72 65 74 72 69 65 73 3a 20 28 2d 20 remretries: (-
2bf0: 72 65 6d 72 65 74 72 69 65 73 20 31 29 29 29 0a remretries 1))).
2c00: 09 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 . (begin..
2c10: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
2c20: 30 20 22 45 52 52 4f 52 3a 20 74 6f 6f 20 6d 61 0 "ERROR: too ma
2c30: 6e 79 20 72 65 74 72 69 65 73 20 69 6e 20 72 6d ny retries in rm
2c40: 74 3a 6f 70 65 6e 2d 71 72 79 2d 63 6c 6f 73 65 t:open-qry-close
2c50: 2d 6c 6f 63 61 6c 6c 79 2c 20 67 69 76 69 6e 67 -locally, giving
2c60: 20 75 70 22 29 0a 09 20 20 20 20 20 20 23 66 29 up").. #f)
2c70: 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 3b 3b 20 )..(begin.. ;;
2c80: 28 72 6d 74 3a 75 70 64 61 74 65 2d 64 62 2d 73 (rmt:update-db-s
2c90: 74 61 74 73 20 72 75 6e 2d 69 64 20 63 6d 64 20 tats run-id cmd
2ca0: 70 61 72 61 6d 73 20 64 75 72 61 74 69 6f 6e 29 params duration)
2cb0: 0a 09 20 20 3b 3b 20 6d 61 72 6b 20 74 68 69 73 .. ;; mark this
2cc0: 20 72 75 6e 20 61 73 20 64 69 72 74 79 20 69 66 run as dirty if
2cd0: 20 74 68 69 73 20 77 61 73 20 61 20 77 72 69 74 this was a writ
2ce0: 65 0a 09 20 20 28 69 66 20 28 6e 6f 74 20 28 6d e.. (if (not (m
2cf0: 65 6d 62 65 72 20 63 6d 64 20 61 70 69 3a 72 65 ember cmd api:re
2d00: 61 64 2d 6f 6e 6c 79 2d 71 75 65 72 69 65 73 29 ad-only-queries)
2d10: 29 0a 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 ).. (let ((
2d20: 73 74 61 72 74 2d 74 69 6d 65 20 28 63 75 72 72 start-time (curr
2d30: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 0a 09 ent-seconds)))..
2d40: 09 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 64 .(mutex-lock! *d
2d50: 62 2d 6d 75 6c 74 69 2d 73 79 6e 63 2d 6d 75 74 b-multi-sync-mut
2d60: 65 78 2a 29 0a 09 09 3b 3b 20 28 69 66 20 28 6e ex*)...;; (if (n
2d70: 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 ot (hash-table-r
2d80: 65 66 2f 64 65 66 61 75 6c 74 20 2a 64 62 2d 6c ef/default *db-l
2d90: 6f 63 61 6c 2d 73 79 6e 63 2a 20 72 75 6e 2d 69 ocal-sync* run-i
2da0: 64 20 23 66 29 29 0a 09 09 3b 3b 20 6a 75 73 74 d #f))...;; just
2db0: 20 73 65 74 20 69 74 20 65 76 65 72 79 20 74 69 set it every ti
2dc0: 6d 65 2e 20 49 73 20 61 20 77 72 69 74 65 20 6d me. Is a write m
2dd0: 6f 72 65 20 65 78 70 65 6e 73 69 76 65 20 74 68 ore expensive th
2de0: 61 6e 20 61 20 72 65 61 64 20 61 6e 64 20 64 6f an a read and do
2df0: 65 73 20 69 74 20 6d 61 74 74 65 72 3f 0a 09 09 es it matter?...
2e00: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
2e10: 20 2a 64 62 2d 6c 6f 63 61 6c 2d 73 79 6e 63 2a *db-local-sync*
2e20: 20 28 6f 72 20 72 75 6e 2d 69 64 20 30 29 20 73 (or run-id 0) s
2e30: 74 61 72 74 2d 74 69 6d 65 29 20 3b 3b 20 74 68 tart-time) ;; th
2e40: 65 20 6f 6c 64 65 73 74 20 22 77 72 69 74 65 22 e oldest "write"
2e50: 0a 09 09 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b ...(mutex-unlock
2e60: 21 20 2a 64 62 2d 6d 75 6c 74 69 2d 73 79 6e 63 ! *db-multi-sync
2e70: 2d 6d 75 74 65 78 2a 29 29 29 0a 09 20 20 72 65 -mutex*))).. re
2e80: 73 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 s))))..(define (
2e90: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
2ea0: 2d 6e 6f 2d 61 75 74 6f 2d 63 6c 69 65 6e 74 2d -no-auto-client-
2eb0: 73 65 74 75 70 20 63 6f 6e 6e 65 63 74 69 6f 6e setup connection
2ec0: 2d 69 6e 66 6f 20 63 6d 64 20 72 75 6e 2d 69 64 -info cmd run-id
2ed0: 20 70 61 72 61 6d 73 29 0a 20 20 28 6c 65 74 2a params). (let*
2ee0: 20 28 28 72 75 6e 2d 69 64 20 20 20 28 69 66 20 ((run-id (if
2ef0: 72 75 6e 2d 69 64 20 72 75 6e 2d 69 64 20 30 29 run-id run-id 0)
2f00: 29 0a 09 20 3b 3b 20 28 6a 70 61 72 61 6d 73 20 ).. ;; (jparams
2f10: 20 28 64 62 3a 6f 62 6a 2d 3e 73 74 72 69 6e 67 (db:obj->string
2f20: 20 70 61 72 61 6d 73 29 29 20 3b 3b 20 28 72 6d params)) ;; (rm
2f30: 74 3a 64 61 74 2d 3e 6a 73 6f 6e 2d 73 74 72 20 t:dat->json-str
2f40: 70 61 72 61 6d 73 29 29 0a 09 20 28 72 65 73 20 params)).. (res
2f50: 20 09 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 . (handle-exc
2f60: 65 70 74 69 6f 6e 73 0a 09 09 20 20 20 20 65 78 eptions... ex
2f70: 6e 0a 09 09 20 20 20 20 23 66 0a 09 09 20 20 20 n... #f...
2f80: 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 (http-transport
2f90: 3a 63 6c 69 65 6e 74 2d 61 70 69 2d 73 65 6e 64 :client-api-send
2fa0: 2d 72 65 63 65 69 76 65 20 72 75 6e 2d 69 64 20 -receive run-id
2fb0: 63 6f 6e 6e 65 63 74 69 6f 6e 2d 69 6e 66 6f 20 connection-info
2fc0: 63 6d 64 20 70 61 72 61 6d 73 29 29 29 29 0a 3b cmd params)))).;
2fd0: 3b 09 09 20 20 20 20 28 28 63 6f 6d 6d 66 61 69 ;.. ((commfai
2fe0: 6c 29 20 28 76 65 63 74 6f 72 20 23 66 20 22 63 l) (vector #f "c
2ff0: 6f 6d 6d 75 6e 69 63 61 74 69 6f 6e 73 20 66 61 ommunications fa
3000: 69 6c 22 29 29 29 29 29 0a 20 20 20 20 28 69 66 il"))))). (if
3010: 20 28 61 6e 64 20 72 65 73 20 28 76 65 63 74 6f (and res (vecto
3020: 72 2d 72 65 66 20 72 65 73 20 30 29 29 0a 09 28 r-ref res 0))..(
3030: 76 65 63 74 6f 72 2d 72 65 66 20 72 65 73 20 31 vector-ref res 1
3040: 29 20 3b 3b 3b 20 59 45 53 21 21 20 54 48 49 53 ) ;;; YES!! THIS
3050: 20 49 53 20 43 4f 52 52 45 43 54 21 21 20 43 48 IS CORRECT!! CH
3060: 41 4e 47 45 20 49 54 20 48 45 52 45 2c 20 54 48 ANGE IT HERE, TH
3070: 45 4e 20 43 48 41 4e 47 45 20 72 6d 74 3a 73 65 EN CHANGE rmt:se
3080: 6e 64 2d 72 65 63 65 69 76 65 20 41 4c 53 4f 21 nd-receive ALSO!
3090: 21 21 0a 09 23 66 29 29 29 0a 3b 3b 20 09 28 64 !!..#f))).;; .(d
30a0: 62 3a 73 74 72 69 6e 67 2d 3e 6f 62 6a 20 28 76 b:string->obj (v
30b0: 65 63 74 6f 72 2d 72 65 66 20 64 61 74 20 31 29 ector-ref dat 1)
30c0: 29 0a 3b 3b 20 09 28 62 65 67 69 6e 0a 3b 3b 20 ).;; .(begin.;;
30d0: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 . (debug:print
30e0: 30 20 22 45 52 52 4f 52 3a 20 72 6d 74 3a 73 65 0 "ERROR: rmt:se
30f0: 6e 64 2d 72 65 63 65 69 76 65 2d 6e 6f 2d 61 75 nd-receive-no-au
3100: 74 6f 2d 63 6c 69 65 6e 74 2d 73 65 74 75 70 20 to-client-setup
3110: 66 61 69 6c 65 64 2c 20 61 74 74 65 6d 70 74 69 failed, attempti
3120: 6e 67 20 74 6f 20 63 6f 6e 74 69 6e 75 65 2e 20 ng to continue.
3130: 47 6f 74 20 22 20 64 61 74 29 0a 3b 3b 20 09 20 Got " dat).;; .
3140: 20 64 61 74 29 29 29 29 0a 0a 3b 3b 20 57 72 61 dat))))..;; Wra
3150: 70 20 6a 73 6f 6e 20 6c 69 62 72 61 72 79 20 66 p json library f
3160: 6f 72 20 73 74 72 69 6e 67 73 20 28 77 68 79 20 or strings (why
3170: 74 68 65 20 70 6f 72 74 73 20 63 72 61 70 20 69 the ports crap i
3180: 6e 20 74 68 65 20 66 69 72 73 74 20 70 6c 61 63 n the first plac
3190: 65 3f 29 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 e?).(define (rmt
31a0: 3a 64 61 74 2d 3e 6a 73 6f 6e 2d 73 74 72 20 64 :dat->json-str d
31b0: 61 74 29 0a 20 20 28 77 69 74 68 2d 6f 75 74 70 at). (with-outp
31c0: 75 74 2d 74 6f 2d 73 74 72 69 6e 67 20 0a 20 20 ut-to-string .
31d0: 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 20 20 20 (lambda ().
31e0: 20 20 20 28 6a 73 6f 6e 2d 77 72 69 74 65 20 64 (json-write d
31f0: 61 74 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 at))))..(define
3200: 28 72 6d 74 3a 6a 73 6f 6e 2d 73 74 72 2d 3e 64 (rmt:json-str->d
3210: 61 74 20 6a 73 6f 6e 2d 73 74 72 29 0a 20 20 28 at json-str). (
3220: 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d with-input-from-
3230: 73 74 72 69 6e 67 20 6a 73 6f 6e 2d 73 74 72 0a string json-str.
3240: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 20 (lambda ().
3250: 20 20 20 20 20 28 6a 73 6f 6e 2d 72 65 61 64 29 (json-read)
3260: 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d )))..;;=========
3270: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3280: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3290: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
32a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
32b0: 0a 3b 3b 20 41 20 43 20 54 20 55 20 41 20 4c 20 .;; A C T U A L
32c0: 20 20 41 20 50 20 49 20 20 20 43 20 41 20 4c 20 A P I C A L
32d0: 4c 20 53 20 20 0a 3b 3b 0a 3b 3b 3d 3d 3d 3d 3d L S .;;.;;=====
32e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
32f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3300: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3310: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3320: 3d 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d =..;;===========
3330: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3340: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3350: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3360: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 ===========.;;
3370: 53 20 45 20 52 20 56 20 45 20 52 0a 3b 3b 3d 3d S E R V E R.;;==
3380: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3390: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
33a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
33b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
33c0: 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 72 ====..(define (r
33d0: 6d 74 3a 6b 69 6c 6c 2d 73 65 72 76 65 72 20 72 mt:kill-server r
33e0: 75 6e 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 un-id). (rmt:se
33f0: 6e 64 2d 72 65 63 65 69 76 65 20 27 6b 69 6c 6c nd-receive 'kill
3400: 2d 73 65 72 76 65 72 20 72 75 6e 2d 69 64 20 28 -server run-id (
3410: 6c 69 73 74 20 72 75 6e 2d 69 64 29 29 29 0a 0a list run-id)))..
3420: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 73 74 61 (define (rmt:sta
3430: 72 74 2d 73 65 72 76 65 72 20 72 75 6e 2d 69 64 rt-server run-id
3440: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
3450: 63 65 69 76 65 20 27 73 74 61 72 74 2d 73 65 72 ceive 'start-ser
3460: 76 65 72 20 30 20 28 6c 69 73 74 20 72 75 6e 2d ver 0 (list run-
3470: 69 64 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d id)))..;;=======
3480: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3490: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
34a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
34b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
34c0: 3b 3b 20 20 4d 20 49 20 53 20 43 0a 3b 3b 3d 3d ;; M I S C.;;==
34d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
34e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
34f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3500: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3510: 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 72 ====..(define (r
3520: 6d 74 3a 6c 6f 67 69 6e 20 72 75 6e 2d 69 64 29 mt:login run-id)
3530: 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 . (rmt:send-rec
3540: 65 69 76 65 20 27 6c 6f 67 69 6e 20 72 75 6e 2d eive 'login run-
3550: 69 64 20 28 6c 69 73 74 20 2a 74 6f 70 70 61 74 id (list *toppat
3560: 68 2a 20 6d 65 67 61 74 65 73 74 2d 76 65 72 73 h* megatest-vers
3570: 69 6f 6e 20 72 75 6e 2d 69 64 20 2a 6d 79 2d 63 ion run-id *my-c
3580: 6c 69 65 6e 74 2d 73 69 67 6e 61 74 75 72 65 2a lient-signature*
3590: 29 29 29 0a 0a 3b 3b 20 54 68 69 73 20 6c 6f 67 )))..;; This log
35a0: 69 6e 20 64 6f 65 73 20 6e 6f 20 72 65 74 72 69 in does no retri
35b0: 65 73 20 75 6e 64 65 72 20 74 68 65 20 68 6f 6f es under the hoo
35c0: 64 20 2d 20 69 74 20 61 63 74 73 20 61 20 62 69 d - it acts a bi
35d0: 74 20 6c 69 6b 65 20 61 20 70 69 6e 67 2e 0a 3b t like a ping..;
35e0: 3b 20 44 65 70 72 65 63 61 74 65 64 20 66 6f 72 ; Deprecated for
35f0: 20 6e 6d 73 67 2d 74 72 61 6e 73 70 6f 72 74 2e nmsg-transport.
3600: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 .;;.(define (rmt
3610: 3a 6c 6f 67 69 6e 2d 6e 6f 2d 61 75 74 6f 2d 63 :login-no-auto-c
3620: 6c 69 65 6e 74 2d 73 65 74 75 70 20 63 6f 6e 6e lient-setup conn
3630: 65 63 74 69 6f 6e 2d 69 6e 66 6f 20 72 75 6e 2d ection-info run-
3640: 69 64 29 0a 20 20 28 63 61 73 65 20 2a 74 72 61 id). (case *tra
3650: 6e 73 70 6f 72 74 2d 74 79 70 65 2a 0a 20 20 20 nsport-type*.
3660: 20 28 28 68 74 74 70 29 28 72 6d 74 3a 73 65 6e ((http)(rmt:sen
3670: 64 2d 72 65 63 65 69 76 65 2d 6e 6f 2d 61 75 74 d-receive-no-aut
3680: 6f 2d 63 6c 69 65 6e 74 2d 73 65 74 75 70 20 63 o-client-setup c
3690: 6f 6e 6e 65 63 74 69 6f 6e 2d 69 6e 66 6f 20 27 onnection-info '
36a0: 6c 6f 67 69 6e 20 72 75 6e 2d 69 64 20 28 6c 69 login run-id (li
36b0: 73 74 20 2a 74 6f 70 70 61 74 68 2a 20 6d 65 67 st *toppath* meg
36c0: 61 74 65 73 74 2d 76 65 72 73 69 6f 6e 20 72 75 atest-version ru
36d0: 6e 2d 69 64 20 2a 6d 79 2d 63 6c 69 65 6e 74 2d n-id *my-client-
36e0: 73 69 67 6e 61 74 75 72 65 2a 29 29 29 0a 20 20 signature*))).
36f0: 20 20 28 28 6e 6d 73 67 29 28 6e 6d 73 67 2d 74 ((nmsg)(nmsg-t
3700: 72 61 6e 73 70 6f 72 74 3a 63 6c 69 65 6e 74 2d ransport:client-
3710: 61 70 69 2d 73 65 6e 64 2d 72 65 63 65 69 76 65 api-send-receive
3720: 20 72 75 6e 2d 69 64 20 63 6f 6e 6e 65 63 74 69 run-id connecti
3730: 6f 6e 2d 69 6e 66 6f 20 27 6c 6f 67 69 6e 20 28 on-info 'login (
3740: 6c 69 73 74 20 2a 74 6f 70 70 61 74 68 2a 20 6d list *toppath* m
3750: 65 67 61 74 65 73 74 2d 76 65 72 73 69 6f 6e 20 egatest-version
3760: 72 75 6e 2d 69 64 20 2a 6d 79 2d 63 6c 69 65 6e run-id *my-clien
3770: 74 2d 73 69 67 6e 61 74 75 72 65 2a 29 29 29 29 t-signature*))))
3780: 29 0a 0a 3b 3b 20 68 61 6e 64 20 6f 66 66 20 61 )..;; hand off a
3790: 20 63 61 6c 6c 20 74 6f 20 6f 6e 65 20 6f 66 20 call to one of
37a0: 74 68 65 20 64 62 3a 71 75 65 72 69 65 73 20 73 the db:queries s
37b0: 74 61 74 65 6d 65 6e 74 73 0a 3b 3b 20 61 64 64 tatements.;; add
37c0: 65 64 20 72 75 6e 2d 69 64 20 74 6f 20 6d 61 6b ed run-id to mak
37d0: 65 20 6c 6f 6f 6b 69 6e 67 20 75 70 20 74 68 65 e looking up the
37e0: 20 63 6f 72 72 65 63 74 20 64 62 20 70 6f 73 73 correct db poss
37f0: 69 62 6c 65 20 0a 3b 3b 0a 28 64 65 66 69 6e 65 ible .;;.(define
3800: 20 28 72 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 61 (rmt:general-ca
3810: 6c 6c 20 73 74 6d 74 6e 61 6d 65 20 72 75 6e 2d ll stmtname run-
3820: 69 64 20 2e 20 70 61 72 61 6d 73 29 0a 20 20 28 id . params). (
3830: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
3840: 20 27 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 72 'general-call r
3850: 75 6e 2d 69 64 20 28 61 70 70 65 6e 64 20 28 6c un-id (append (l
3860: 69 73 74 20 73 74 6d 74 6e 61 6d 65 20 72 75 6e ist stmtname run
3870: 2d 69 64 29 20 70 61 72 61 6d 73 29 29 29 0a 0a -id) params)))..
3880: 3b 3b 20 28 64 65 66 69 6e 65 20 28 72 6d 74 3a ;; (define (rmt:
3890: 73 79 6e 63 2d 69 6e 6d 65 6d 2d 3e 64 62 20 72 sync-inmem->db r
38a0: 75 6e 2d 69 64 29 0a 3b 3b 20 20 20 28 72 6d 74 un-id).;; (rmt
38b0: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 73 :send-receive 's
38c0: 79 6e 63 2d 69 6e 6d 65 6d 2d 3e 64 62 20 72 75 ync-inmem->db ru
38d0: 6e 2d 69 64 20 27 28 29 29 29 0a 0a 28 64 65 66 n-id '()))..(def
38e0: 69 6e 65 20 28 72 6d 74 3a 73 64 62 2d 71 72 79 ine (rmt:sdb-qry
38f0: 20 71 72 79 20 76 61 6c 20 72 75 6e 2d 69 64 29 qry val run-id)
3900: 0a 20 20 3b 3b 20 61 64 64 20 63 61 63 68 69 6e . ;; add cachin
3910: 67 20 69 66 20 71 72 79 20 69 73 20 27 67 65 74 g if qry is 'get
3920: 69 64 20 6f 72 20 27 67 65 74 73 74 72 0a 20 20 id or 'getstr.
3930: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
3940: 65 20 27 73 64 62 2d 71 72 79 20 72 75 6e 2d 69 e 'sdb-qry run-i
3950: 64 20 28 6c 69 73 74 20 71 72 79 20 76 61 6c 29 d (list qry val)
3960: 29 29 0a 0a 3b 3b 20 4e 4f 54 20 43 4f 4d 50 4c ))..;; NOT COMPL
3970: 45 54 45 44 0a 28 64 65 66 69 6e 65 20 28 72 6d ETED.(define (rm
3980: 74 3a 72 75 6e 74 65 73 74 73 20 75 73 65 72 20 t:runtests user
3990: 72 75 6e 2d 69 64 20 74 65 73 74 70 61 74 74 20 run-id testpatt
39a0: 70 61 72 61 6d 73 29 0a 20 20 28 72 6d 74 3a 73 params). (rmt:s
39b0: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 72 75 6e end-receive 'run
39c0: 74 65 73 74 73 20 72 75 6e 2d 69 64 20 74 65 73 tests run-id tes
39d0: 74 70 61 74 74 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d tpatt))..;;=====
39e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
39f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3a00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3a10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3a20: 3d 0a 3b 3b 20 20 4b 20 45 20 59 20 53 20 0a 3b =.;; K E Y S .;
3a30: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
3a40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3a50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3a60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3a70: 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 54 68 65 73 =======..;; Thes
3a80: 65 20 72 65 71 75 69 72 65 20 72 75 6e 2d 69 64 e require run-id
3a90: 20 62 65 63 61 75 73 65 20 74 68 65 20 76 61 6c because the val
3aa0: 75 65 73 20 63 6f 6d 65 20 66 72 6f 6d 20 74 68 ues come from th
3ab0: 65 20 72 75 6e 21 0a 3b 3b 0a 28 64 65 66 69 6e e run!.;;.(defin
3ac0: 65 20 28 72 6d 74 3a 67 65 74 2d 6b 65 79 2d 76 e (rmt:get-key-v
3ad0: 61 6c 2d 70 61 69 72 73 20 72 75 6e 2d 69 64 29 al-pairs run-id)
3ae0: 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 . (rmt:send-rec
3af0: 65 69 76 65 20 27 67 65 74 2d 6b 65 79 2d 76 61 eive 'get-key-va
3b00: 6c 2d 70 61 69 72 73 20 72 75 6e 2d 69 64 20 28 l-pairs run-id (
3b10: 6c 69 73 74 20 72 75 6e 2d 69 64 29 29 29 0a 0a list run-id)))..
3b20: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 (define (rmt:get
3b30: 2d 6b 65 79 73 29 0a 20 20 28 72 6d 74 3a 73 65 -keys). (rmt:se
3b40: 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d nd-receive 'get-
3b50: 6b 65 79 73 20 23 66 20 27 28 29 29 29 0a 0a 28 keys #f '()))..(
3b60: 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d define (rmt:get-
3b70: 6b 65 79 2d 76 61 6c 73 20 72 75 6e 2d 69 64 29 key-vals run-id)
3b80: 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 . (rmt:send-rec
3b90: 65 69 76 65 20 27 67 65 74 2d 6b 65 79 2d 76 61 eive 'get-key-va
3ba0: 6c 73 20 23 66 20 28 6c 69 73 74 20 72 75 6e 2d ls #f (list run-
3bb0: 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 id)))..(define (
3bc0: 72 6d 74 3a 67 65 74 2d 74 61 72 67 65 74 73 29 rmt:get-targets)
3bd0: 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 . (rmt:send-rec
3be0: 65 69 76 65 20 27 67 65 74 2d 74 61 72 67 65 74 eive 'get-target
3bf0: 73 20 23 66 20 27 28 29 29 29 0a 0a 3b 3b 3d 3d s #f '()))..;;==
3c00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3c10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3c20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3c30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3c40: 3d 3d 3d 3d 0a 3b 3b 20 20 54 20 45 20 53 20 54 ====.;; T E S T
3c50: 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d S.;;===========
3c60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3c70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3c80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3c90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 ===========..;;
3ca0: 4a 75 73 74 20 73 6f 6d 65 20 73 79 6e 74 61 74 Just some syntat
3cb0: 69 63 20 73 75 67 61 72 0a 28 64 65 66 69 6e 65 ic sugar.(define
3cc0: 20 28 72 6d 74 3a 72 65 67 69 73 74 65 72 2d 74 (rmt:register-t
3cd0: 65 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d est run-id test-
3ce0: 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 0a name item-path).
3cf0: 20 20 28 72 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 (rmt:general-c
3d00: 61 6c 6c 20 27 72 65 67 69 73 74 65 72 2d 74 65 all 'register-te
3d10: 73 74 20 72 75 6e 2d 69 64 20 72 75 6e 2d 69 64 st run-id run-id
3d20: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item-
3d30: 70 61 74 68 29 29 0a 0a 28 64 65 66 69 6e 65 20 path))..(define
3d40: 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 64 (rmt:get-test-id
3d50: 20 72 75 6e 2d 69 64 20 74 65 73 74 6e 61 6d 65 run-id testname
3d60: 20 69 74 65 6d 2d 70 61 74 68 29 0a 20 20 28 72 item-path). (r
3d70: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
3d80: 27 67 65 74 2d 74 65 73 74 2d 69 64 20 72 75 6e 'get-test-id run
3d90: 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 -id (list run-id
3da0: 20 74 65 73 74 6e 61 6d 65 20 69 74 65 6d 2d 70 testname item-p
3db0: 61 74 68 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ath)))..(define
3dc0: 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 6e (rmt:get-test-in
3dd0: 66 6f 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 fo-by-id run-id
3de0: 74 65 73 74 2d 69 64 29 0a 20 20 28 69 66 20 28 test-id). (if (
3df0: 61 6e 64 20 28 6e 75 6d 62 65 72 3f 20 72 75 6e and (number? run
3e00: 2d 69 64 29 28 6e 75 6d 62 65 72 3f 20 74 65 73 -id)(number? tes
3e10: 74 2d 69 64 29 29 0a 20 20 20 20 20 20 28 72 6d t-id)). (rm
3e20: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
3e30: 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 get-test-info-by
3e40: 2d 69 64 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 -id run-id (list
3e50: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 run-id test-id)
3e60: 29 0a 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 ). (begin..
3e70: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
3e80: 57 41 52 4e 49 4e 47 3a 20 42 61 64 20 64 61 74 WARNING: Bad dat
3e90: 61 20 68 61 6e 64 65 64 20 74 6f 20 72 6d 74 3a a handed to rmt:
3ea0: 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 get-test-info-by
3eb0: 2d 69 64 20 72 75 6e 2d 69 64 3d 22 20 72 75 6e -id run-id=" run
3ec0: 2d 69 64 20 22 2c 20 74 65 73 74 2d 69 64 3d 22 -id ", test-id="
3ed0: 20 74 65 73 74 2d 69 64 29 0a 09 28 70 72 69 6e test-id)..(prin
3ee0: 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 20 28 63 75 t-call-chain (cu
3ef0: 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 rrent-error-port
3f00: 29 29 0a 09 23 66 29 29 29 0a 0a 28 64 65 66 69 ))..#f)))..(defi
3f10: 6e 65 20 28 72 6d 74 3a 74 65 73 74 2d 67 65 74 ne (rmt:test-get
3f20: 2d 72 75 6e 64 69 72 2d 66 72 6f 6d 2d 74 65 73 -rundir-from-tes
3f30: 74 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 t-id run-id test
3f40: 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 -id). (rmt:send
3f50: 2d 72 65 63 65 69 76 65 20 27 74 65 73 74 2d 67 -receive 'test-g
3f60: 65 74 2d 72 75 6e 64 69 72 2d 66 72 6f 6d 2d 74 et-rundir-from-t
3f70: 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 28 6c est-id run-id (l
3f80: 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d ist run-id test-
3f90: 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 id)))..(define (
3fa0: 72 6d 74 3a 6f 70 65 6e 2d 74 65 73 74 2d 64 62 rmt:open-test-db
3fb0: 2d 62 79 2d 74 65 73 74 2d 69 64 20 72 75 6e 2d -by-test-id run-
3fc0: 69 64 20 74 65 73 74 2d 69 64 20 23 21 6b 65 79 id test-id #!key
3fd0: 20 28 77 6f 72 6b 2d 61 72 65 61 20 23 66 29 29 (work-area #f))
3fe0: 0a 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 2d . (let* ((test-
3ff0: 70 61 74 68 20 28 69 66 20 28 73 74 72 69 6e 67 path (if (string
4000: 3f 20 77 6f 72 6b 2d 61 72 65 61 29 0a 09 09 09 ? work-area)....
4010: 77 6f 72 6b 2d 61 72 65 61 0a 09 09 09 28 72 6d work-area....(rm
4020: 74 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 t:test-get-rundi
4030: 72 2d 66 72 6f 6d 2d 74 65 73 74 2d 69 64 20 72 r-from-test-id r
4040: 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 29 29 un-id test-id)))
4050: 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 ). (debug:pri
4060: 6e 74 20 33 20 22 54 45 53 54 20 50 41 54 48 3a nt 3 "TEST PATH:
4070: 20 22 20 74 65 73 74 2d 70 61 74 68 29 0a 20 20 " test-path).
4080: 20 20 28 6f 70 65 6e 2d 74 65 73 74 2d 64 62 20 (open-test-db
4090: 74 65 73 74 2d 70 61 74 68 29 29 29 0a 0a 3b 3b test-path)))..;;
40a0: 20 57 41 52 4e 49 4e 47 3a 20 54 68 69 73 20 63 WARNING: This c
40b0: 75 72 72 65 6e 74 6c 79 20 62 79 70 61 73 73 65 urrently bypasse
40c0: 73 20 74 68 65 20 74 72 61 6e 73 61 63 74 69 6f s the transactio
40d0: 6e 20 77 72 61 70 70 65 64 20 77 72 69 74 65 73 n wrapped writes
40e0: 20 73 79 73 74 65 6d 0a 28 64 65 66 69 6e 65 20 system.(define
40f0: 28 72 6d 74 3a 74 65 73 74 2d 73 65 74 2d 73 74 (rmt:test-set-st
4100: 61 74 65 2d 73 74 61 74 75 73 2d 62 79 2d 69 64 ate-status-by-id
4110: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 run-id test-id
4120: 6e 65 77 73 74 61 74 65 20 6e 65 77 73 74 61 74 newstate newstat
4130: 75 73 20 6e 65 77 63 6f 6d 6d 65 6e 74 29 0a 20 us newcomment).
4140: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
4150: 76 65 20 27 74 65 73 74 2d 73 65 74 2d 73 74 61 ve 'test-set-sta
4160: 74 65 2d 73 74 61 74 75 73 2d 62 79 2d 69 64 20 te-status-by-id
4170: 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e run-id (list run
4180: 2d 69 64 20 74 65 73 74 2d 69 64 20 6e 65 77 73 -id test-id news
4190: 74 61 74 65 20 6e 65 77 73 74 61 74 75 73 20 6e tate newstatus n
41a0: 65 77 63 6f 6d 6d 65 6e 74 29 29 29 0a 0a 28 64 ewcomment)))..(d
41b0: 65 66 69 6e 65 20 28 72 6d 74 3a 73 65 74 2d 74 efine (rmt:set-t
41c0: 65 73 74 73 2d 73 74 61 74 65 2d 73 74 61 74 75 ests-state-statu
41d0: 73 20 72 75 6e 2d 69 64 20 74 65 73 74 6e 61 6d s run-id testnam
41e0: 65 73 20 63 75 72 72 73 74 61 74 65 20 63 75 72 es currstate cur
41f0: 72 73 74 61 74 75 73 20 6e 65 77 73 74 61 74 65 rstatus newstate
4200: 20 6e 65 77 73 74 61 74 75 73 29 0a 20 20 28 72 newstatus). (r
4210: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
4220: 27 73 65 74 2d 74 65 73 74 73 2d 73 74 61 74 65 'set-tests-state
4230: 2d 73 74 61 74 75 73 20 72 75 6e 2d 69 64 20 28 -status run-id (
4240: 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 list run-id test
4250: 6e 61 6d 65 73 20 63 75 72 72 73 74 61 74 65 20 names currstate
4260: 63 75 72 72 73 74 61 74 75 73 20 6e 65 77 73 74 currstatus newst
4270: 61 74 65 20 6e 65 77 73 74 61 74 75 73 29 29 29 ate newstatus)))
4280: 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 ..(define (rmt:g
4290: 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e et-tests-for-run
42a0: 20 72 75 6e 2d 69 64 20 74 65 73 74 70 61 74 74 run-id testpatt
42b0: 20 73 74 61 74 65 73 20 73 74 61 74 75 73 65 73 states statuses
42c0: 20 6f 66 66 73 65 74 20 6c 69 6d 69 74 20 6e 6f offset limit no
42d0: 74 2d 69 6e 20 73 6f 72 74 2d 62 79 20 73 6f 72 t-in sort-by sor
42e0: 74 2d 6f 72 64 65 72 20 71 72 79 76 61 6c 73 29 t-order qryvals)
42f0: 0a 20 20 28 69 66 20 28 6e 75 6d 62 65 72 3f 20 . (if (number?
4300: 72 75 6e 2d 69 64 29 0a 20 20 20 20 20 20 28 72 run-id). (r
4310: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
4320: 27 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 'get-tests-for-r
4330: 75 6e 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 un run-id (list
4340: 72 75 6e 2d 69 64 20 74 65 73 74 70 61 74 74 20 run-id testpatt
4350: 73 74 61 74 65 73 20 73 74 61 74 75 73 65 73 20 states statuses
4360: 6f 66 66 73 65 74 20 6c 69 6d 69 74 20 6e 6f 74 offset limit not
4370: 2d 69 6e 20 73 6f 72 74 2d 62 79 20 73 6f 72 74 -in sort-by sort
4380: 2d 6f 72 64 65 72 20 71 72 79 76 61 6c 73 29 29 -order qryvals))
4390: 0a 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 28 . (begin..(
43a0: 64 65 62 75 67 3a 70 72 69 6e 74 20 22 45 52 52 debug:print "ERR
43b0: 4f 52 3a 20 72 6d 74 3a 67 65 74 2d 74 65 73 74 OR: rmt:get-test
43c0: 73 2d 66 6f 72 2d 72 75 6e 20 63 61 6c 6c 65 64 s-for-run called
43d0: 20 77 69 74 68 20 62 61 64 20 72 75 6e 2d 69 64 with bad run-id
43e0: 3d 22 20 72 75 6e 2d 69 64 29 0a 09 28 70 72 69 =" run-id)..(pri
43f0: 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 20 28 63 nt-call-chain (c
4400: 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 urrent-error-por
4410: 74 29 29 0a 09 27 28 29 29 29 29 0a 0a 3b 3b 20 t))..'())))..;;
4420: 67 65 74 20 73 74 75 66 66 20 76 69 61 20 73 79 get stuff via sy
4430: 6e 63 68 61 73 68 20 0a 28 64 65 66 69 6e 65 20 nchash .(define
4440: 28 72 6d 74 3a 73 79 6e 63 68 61 73 68 2d 67 65 (rmt:synchash-ge
4450: 74 20 72 75 6e 2d 69 64 20 70 72 6f 63 20 73 79 t run-id proc sy
4460: 6e 63 6b 65 79 20 6b 65 79 6e 75 6d 20 70 61 72 nckey keynum par
4470: 61 6d 73 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 ams). (rmt:send
4480: 2d 72 65 63 65 69 76 65 20 27 73 79 6e 63 68 61 -receive 'syncha
4490: 73 68 2d 67 65 74 20 72 75 6e 2d 69 64 20 28 6c sh-get run-id (l
44a0: 69 73 74 20 72 75 6e 2d 69 64 20 70 72 6f 63 20 ist run-id proc
44b0: 73 79 6e 63 6b 65 79 20 6b 65 79 6e 75 6d 20 70 synckey keynum p
44c0: 61 72 61 6d 73 29 29 29 0a 0a 3b 3b 20 49 44 45 arams)))..;; IDE
44d0: 41 3a 20 54 68 72 65 61 64 69 66 79 20 74 68 65 A: Threadify the
44e0: 73 65 20 2d 20 74 68 65 79 20 73 70 65 6e 64 20 se - they spend
44f0: 61 20 6c 6f 74 20 6f 66 20 74 69 6d 65 20 77 61 a lot of time wa
4500: 69 74 69 6e 67 20 2e 2e 2e 0a 3b 3b 0a 28 64 65 iting ....;;.(de
4510: 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 74 65 fine (rmt:get-te
4520: 73 74 73 2d 66 6f 72 2d 72 75 6e 73 2d 6d 69 6e sts-for-runs-min
4530: 64 61 74 61 20 72 75 6e 2d 69 64 73 20 74 65 73 data run-ids tes
4540: 74 70 61 74 74 20 73 74 61 74 65 73 20 73 74 61 tpatt states sta
4550: 74 75 73 20 6e 6f 74 2d 69 6e 29 0a 20 20 28 6c tus not-in). (l
4560: 65 74 20 28 28 6d 75 6c 74 69 2d 72 75 6e 2d 6d et ((multi-run-m
4570: 75 74 65 78 20 28 6d 61 6b 65 2d 6d 75 74 65 78 utex (make-mutex
4580: 29 29 0a 09 28 72 75 6e 2d 69 64 2d 6c 69 73 74 ))..(run-id-list
4590: 20 28 69 66 20 72 75 6e 2d 69 64 73 0a 09 09 09 (if run-ids....
45a0: 20 72 75 6e 2d 69 64 73 0a 09 09 09 20 28 72 6d run-ids.... (rm
45b0: 74 3a 67 65 74 2d 61 6c 6c 2d 72 75 6e 2d 69 64 t:get-all-run-id
45c0: 73 29 29 29 0a 09 28 72 65 73 75 6c 74 20 20 20 s)))..(result
45d0: 20 20 20 27 28 29 29 29 0a 20 20 20 20 28 69 66 '())). (if
45e0: 20 28 6e 75 6c 6c 3f 20 72 75 6e 2d 69 64 2d 6c (null? run-id-l
45f0: 69 73 74 29 0a 09 27 28 29 0a 09 28 6c 65 74 20 ist)..'()..(let
4600: 6c 6f 6f 70 20 28 28 68 65 64 20 20 20 20 20 28 loop ((hed (
4610: 63 61 72 20 72 75 6e 2d 69 64 2d 6c 69 73 74 29 car run-id-list)
4620: 29 0a 09 09 20 20 20 28 74 61 6c 20 20 20 20 20 )... (tal
4630: 28 63 64 72 20 72 75 6e 2d 69 64 2d 6c 69 73 74 (cdr run-id-list
4640: 29 29 0a 09 09 20 20 20 28 74 68 72 65 61 64 73 ))... (threads
4650: 20 27 28 29 29 29 0a 09 20 20 28 69 66 20 28 3e '())).. (if (>
4660: 20 28 6c 65 6e 67 74 68 20 74 68 72 65 61 64 73 (length threads
4670: 29 20 35 29 0a 09 20 20 20 20 20 20 28 6c 6f 6f ) 5).. (loo
4680: 70 20 68 65 64 20 74 61 6c 20 28 66 69 6c 74 65 p hed tal (filte
4690: 72 20 28 6c 61 6d 62 64 61 20 28 74 68 29 28 6e r (lambda (th)(n
46a0: 6f 74 20 28 6d 65 6d 62 65 72 20 28 74 68 72 65 ot (member (thre
46b0: 61 64 2d 73 74 61 74 65 20 74 68 29 20 27 28 74 ad-state th) '(t
46c0: 65 72 6d 69 6e 61 74 65 64 20 64 65 61 64 29 29 erminated dead))
46d0: 29 29 20 74 68 72 65 61 64 73 29 29 0a 09 20 20 )) threads))..
46e0: 20 20 20 20 28 6c 65 74 2a 20 28 28 6e 65 77 74 (let* ((newt
46f0: 68 72 65 61 64 20 28 6d 61 6b 65 2d 74 68 72 65 hread (make-thre
4700: 61 64 0a 09 09 09 09 20 28 6c 61 6d 62 64 61 20 ad..... (lambda
4710: 28 29 0a 09 09 09 09 20 20 20 28 6c 65 74 20 28 ()..... (let (
4720: 28 72 65 73 20 28 72 6d 74 3a 73 65 6e 64 2d 72 (res (rmt:send-r
4730: 65 63 65 69 76 65 20 27 67 65 74 2d 74 65 73 74 eceive 'get-test
4740: 73 2d 66 6f 72 2d 72 75 6e 2d 6d 69 6e 64 61 74 s-for-run-mindat
4750: 61 20 68 65 64 20 28 6c 69 73 74 20 68 65 64 20 a hed (list hed
4760: 74 65 73 74 70 61 74 74 20 73 74 61 74 65 73 20 testpatt states
4770: 73 74 61 74 75 73 20 6e 6f 74 2d 69 6e 29 29 29 status not-in)))
4780: 29 0a 09 09 09 09 20 20 20 20 20 28 69 66 20 28 )..... (if (
4790: 6c 69 73 74 3f 20 72 65 73 29 0a 09 09 09 09 09 list? res)......
47a0: 20 28 62 65 67 69 6e 0a 09 09 09 09 09 20 20 20 (begin......
47b0: 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 6d 75 6c (mutex-lock! mul
47c0: 74 69 2d 72 75 6e 2d 6d 75 74 65 78 29 0a 09 09 ti-run-mutex)...
47d0: 09 09 09 20 20 20 28 73 65 74 21 20 72 65 73 75 ... (set! resu
47e0: 6c 74 20 28 61 70 70 65 6e 64 20 72 65 73 75 6c lt (append resul
47f0: 74 20 72 65 73 29 29 0a 09 09 09 09 09 20 20 20 t res))......
4800: 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 6d (mutex-unlock! m
4810: 75 6c 74 69 2d 72 75 6e 2d 6d 75 74 65 78 29 29 ulti-run-mutex))
4820: 0a 09 09 09 09 09 20 28 64 65 62 75 67 3a 70 72 ...... (debug:pr
4830: 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 67 65 int 0 "ERROR: ge
4840: 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 2d t-tests-for-run-
4850: 6d 69 6e 64 61 74 61 20 66 61 69 6c 65 64 20 66 mindata failed f
4860: 6f 72 20 72 75 6e 2d 69 64 20 22 20 68 65 64 20 or run-id " hed
4870: 22 2c 20 74 65 73 74 70 61 74 74 20 22 20 74 65 ", testpatt " te
4880: 73 74 70 61 74 74 20 22 2c 20 73 74 61 74 65 73 stpatt ", states
4890: 20 22 20 73 74 61 74 65 73 20 22 2c 20 73 74 61 " states ", sta
48a0: 74 75 73 20 22 20 73 74 61 74 75 73 20 22 2c 20 tus " status ",
48b0: 6e 6f 74 2d 69 6e 20 22 20 6e 6f 74 2d 69 6e 29 not-in " not-in)
48c0: 29 29 29 0a 09 09 09 09 20 28 63 6f 6e 63 20 22 )))..... (conc "
48d0: 6d 75 6c 74 69 2d 72 75 6e 2d 74 68 72 65 61 64 multi-run-thread
48e0: 20 66 6f 72 20 72 75 6e 2d 69 64 20 22 20 68 65 for run-id " he
48f0: 64 29 29 29 0a 09 09 20 20 20 20 20 28 6e 65 77 d)))... (new
4900: 74 68 72 65 61 64 73 20 28 63 6f 6e 73 20 6e 65 threads (cons ne
4910: 77 74 68 72 65 61 64 20 74 68 72 65 61 64 73 29 wthread threads)
4920: 29 29 0a 09 09 28 74 68 72 65 61 64 2d 73 74 61 ))...(thread-sta
4930: 72 74 21 20 6e 65 77 74 68 72 65 61 64 29 0a 09 rt! newthread)..
4940: 09 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 .(thread-sleep!
4950: 30 2e 30 35 29 20 3b 3b 20 67 69 76 65 20 74 68 0.05) ;; give th
4960: 61 74 20 74 68 72 65 61 64 20 73 6f 6d 65 20 74 at thread some t
4970: 69 6d 65 20 74 6f 20 73 74 61 72 74 0a 09 09 28 ime to start...(
4980: 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 if (null? tal)..
4990: 09 20 20 20 20 6e 65 77 74 68 72 65 61 64 73 0a . newthreads.
49a0: 09 09 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 .. (loop (car
49b0: 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 20 6e tal)(cdr tal) n
49c0: 65 77 74 68 72 65 61 64 73 29 29 29 29 29 29 0a ewthreads)))))).
49d0: 20 20 20 20 72 65 73 75 6c 74 29 29 0a 0a 3b 3b result))..;;
49e0: 20 3b 3b 20 49 44 45 41 3a 20 54 68 72 65 61 64 ;; IDEA: Thread
49f0: 69 66 79 20 74 68 65 73 65 20 2d 20 74 68 65 79 ify these - they
4a00: 20 73 70 65 6e 64 20 61 20 6c 6f 74 20 6f 66 20 spend a lot of
4a10: 74 69 6d 65 20 77 61 69 74 69 6e 67 20 2e 2e 2e time waiting ...
4a20: 0a 3b 3b 20 3b 3b 0a 3b 3b 20 28 64 65 66 69 6e .;; ;;.;; (defin
4a30: 65 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 73 e (rmt:get-tests
4a40: 2d 66 6f 72 2d 72 75 6e 73 2d 6d 69 6e 64 61 74 -for-runs-mindat
4a50: 61 20 72 75 6e 2d 69 64 73 20 74 65 73 74 70 61 a run-ids testpa
4a60: 74 74 20 73 74 61 74 65 73 20 73 74 61 74 75 73 tt states status
4a70: 20 6e 6f 74 2d 69 6e 29 0a 3b 3b 20 20 20 28 6c not-in).;; (l
4a80: 65 74 20 28 28 72 75 6e 2d 69 64 2d 6c 69 73 74 et ((run-id-list
4a90: 20 28 69 66 20 72 75 6e 2d 69 64 73 0a 3b 3b 20 (if run-ids.;;
4aa0: 09 09 09 20 72 75 6e 2d 69 64 73 0a 3b 3b 20 09 ... run-ids.;; .
4ab0: 09 09 20 28 72 6d 74 3a 67 65 74 2d 61 6c 6c 2d .. (rmt:get-all-
4ac0: 72 75 6e 2d 69 64 73 29 29 29 29 0a 3b 3b 20 20 run-ids)))).;;
4ad0: 20 20 20 28 61 70 70 6c 79 20 61 70 70 65 6e 64 (apply append
4ae0: 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 72 (map (lambda (r
4af0: 75 6e 2d 69 64 29 0a 3b 3b 20 09 09 09 20 28 72 un-id).;; ... (r
4b00: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
4b10: 27 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 'get-tests-for-r
4b20: 75 6e 2d 6d 69 6e 64 61 74 61 20 72 75 6e 2d 69 un-mindata run-i
4b30: 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 73 20 d (list run-ids
4b40: 74 65 73 74 70 61 74 74 20 73 74 61 74 65 73 20 testpatt states
4b50: 73 74 61 74 75 73 20 6e 6f 74 2d 69 6e 29 29 29 status not-in)))
4b60: 0a 3b 3b 20 09 09 20 20 20 20 20 20 20 72 75 6e .;; .. run
4b70: 2d 69 64 2d 6c 69 73 74 29 29 29 29 0a 0a 28 64 -id-list))))..(d
4b80: 65 66 69 6e 65 20 28 72 6d 74 3a 64 65 6c 65 74 efine (rmt:delet
4b90: 65 2d 74 65 73 74 2d 72 65 63 6f 72 64 73 20 72 e-test-records r
4ba0: 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 0a 20 un-id test-id).
4bb0: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
4bc0: 76 65 20 27 64 65 6c 65 74 65 2d 74 65 73 74 2d ve 'delete-test-
4bd0: 72 65 63 6f 72 64 73 20 72 75 6e 2d 69 64 20 28 records run-id (
4be0: 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 list run-id test
4bf0: 2d 69 64 29 29 29 0a 0a 3b 3b 20 54 68 69 73 20 -id)))..;; This
4c00: 69 73 20 6e 6f 74 20 6e 65 65 64 65 64 20 61 73 is not needed as
4c10: 20 74 65 73 74 20 73 74 65 70 73 20 61 72 65 20 test steps are
4c20: 64 65 6c 65 74 65 64 20 6f 6e 20 74 65 73 74 20 deleted on test
4c30: 64 65 6c 65 74 65 20 63 61 6c 6c 0a 3b 3b 0a 3b delete call.;;.;
4c40: 3b 20 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 64 ; (define (rmt:d
4c50: 65 6c 65 74 65 2d 74 65 73 74 2d 73 74 65 70 2d elete-test-step-
4c60: 72 65 63 6f 72 64 73 20 72 75 6e 2d 69 64 20 74 records run-id t
4c70: 65 73 74 2d 69 64 29 0a 3b 3b 20 20 20 28 72 6d est-id).;; (rm
4c80: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
4c90: 64 65 6c 65 74 65 2d 74 65 73 74 2d 73 74 65 70 delete-test-step
4ca0: 2d 72 65 63 6f 72 64 73 20 72 75 6e 2d 69 64 20 -records run-id
4cb0: 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 (list run-id tes
4cc0: 74 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 t-id)))..(define
4cd0: 20 28 72 6d 74 3a 74 65 73 74 2d 73 65 74 2d 73 (rmt:test-set-s
4ce0: 74 61 74 75 73 2d 73 74 61 74 65 20 72 75 6e 2d tatus-state run-
4cf0: 69 64 20 74 65 73 74 2d 69 64 20 73 74 61 74 75 id test-id statu
4d00: 73 20 73 74 61 74 65 20 6d 73 67 29 0a 20 20 28 s state msg). (
4d10: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
4d20: 20 27 74 65 73 74 2d 73 65 74 2d 73 74 61 74 75 'test-set-statu
4d30: 73 2d 73 74 61 74 65 20 72 75 6e 2d 69 64 20 28 s-state run-id (
4d40: 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 list run-id test
4d50: 2d 69 64 20 73 74 61 74 75 73 20 73 74 61 74 65 -id status state
4d60: 20 6d 73 67 29 29 29 0a 0a 28 64 65 66 69 6e 65 msg)))..(define
4d70: 20 28 72 6d 74 3a 74 65 73 74 2d 74 6f 70 6c 65 (rmt:test-tople
4d80: 76 65 6c 2d 6e 75 6d 2d 69 74 65 6d 73 20 72 75 vel-num-items ru
4d90: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 29 0a n-id test-name).
4da0: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
4db0: 69 76 65 20 27 74 65 73 74 2d 74 6f 70 6c 65 76 ive 'test-toplev
4dc0: 65 6c 2d 6e 75 6d 2d 69 74 65 6d 73 20 72 75 6e el-num-items run
4dd0: 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 -id (list run-id
4de0: 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a 0a 3b test-name)))..;
4df0: 3b 20 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 ; (define (rmt:g
4e00: 65 74 2d 70 72 65 76 69 6f 75 73 2d 74 65 73 74 et-previous-test
4e10: 2d 72 75 6e 2d 72 65 63 6f 72 64 20 72 75 6e 2d -run-record run-
4e20: 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 id test-name ite
4e30: 6d 2d 70 61 74 68 29 0a 3b 3b 20 20 20 28 72 6d m-path).;; (rm
4e40: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
4e50: 67 65 74 2d 70 72 65 76 69 6f 75 73 2d 74 65 73 get-previous-tes
4e60: 74 2d 72 75 6e 2d 72 65 63 6f 72 64 20 72 75 6e t-run-record run
4e70: 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 -id (list run-id
4e80: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item-
4e90: 70 61 74 68 29 29 29 0a 0a 28 64 65 66 69 6e 65 path)))..(define
4ea0: 20 28 72 6d 74 3a 67 65 74 2d 6d 61 74 63 68 69 (rmt:get-matchi
4eb0: 6e 67 2d 70 72 65 76 69 6f 75 73 2d 74 65 73 74 ng-previous-test
4ec0: 2d 72 75 6e 2d 72 65 63 6f 72 64 73 20 72 75 6e -run-records run
4ed0: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 -id test-name it
4ee0: 65 6d 2d 70 61 74 68 29 0a 20 20 28 72 6d 74 3a em-path). (rmt:
4ef0: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 send-receive 'ge
4f00: 74 2d 6d 61 74 63 68 69 6e 67 2d 70 72 65 76 69 t-matching-previ
4f10: 6f 75 73 2d 74 65 73 74 2d 72 75 6e 2d 72 65 63 ous-test-run-rec
4f20: 6f 72 64 73 20 72 75 6e 2d 69 64 20 28 6c 69 73 ords run-id (lis
4f30: 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 t run-id test-na
4f40: 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 29 0a me item-path))).
4f50: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 65 .(define (rmt:te
4f60: 73 74 2d 67 65 74 2d 6c 6f 67 66 69 6c 65 2d 69 st-get-logfile-i
4f70: 6e 66 6f 20 72 75 6e 2d 69 64 20 74 65 73 74 2d nfo run-id test-
4f80: 6e 61 6d 65 29 0a 20 20 28 72 6d 74 3a 73 65 6e name). (rmt:sen
4f90: 64 2d 72 65 63 65 69 76 65 20 27 74 65 73 74 2d d-receive 'test-
4fa0: 67 65 74 2d 6c 6f 67 66 69 6c 65 2d 69 6e 66 6f get-logfile-info
4fb0: 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 run-id (list ru
4fc0: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 29 29 n-id test-name))
4fd0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a )..(define (rmt:
4fe0: 74 65 73 74 2d 67 65 74 2d 72 65 63 6f 72 64 73 test-get-records
4ff0: 2d 66 6f 72 2d 69 6e 64 65 78 2d 66 69 6c 65 20 -for-index-file
5000: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
5010: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
5020: 63 65 69 76 65 20 27 74 65 73 74 2d 67 65 74 2d ceive 'test-get-
5030: 72 65 63 6f 72 64 73 2d 66 6f 72 2d 69 6e 64 65 records-for-inde
5040: 78 2d 66 69 6c 65 20 72 75 6e 2d 69 64 20 28 6c x-file run-id (l
5050: 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d ist run-id test-
5060: 6e 61 6d 65 29 29 29 0a 0a 28 64 65 66 69 6e 65 name)))..(define
5070: 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 69 6e (rmt:get-testin
5080: 66 6f 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 fo-state-status
5090: 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 0a run-id test-id).
50a0: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
50b0: 69 76 65 20 27 67 65 74 2d 74 65 73 74 69 6e 66 ive 'get-testinf
50c0: 6f 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 72 o-state-status r
50d0: 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d un-id (list run-
50e0: 69 64 20 74 65 73 74 2d 69 64 29 29 29 0a 0a 28 id test-id)))..(
50f0: 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 65 73 74 define (rmt:test
5100: 2d 73 65 74 2d 6c 6f 67 21 20 72 75 6e 2d 69 64 -set-log! run-id
5110: 20 74 65 73 74 2d 69 64 20 6c 6f 67 66 29 0a 20 test-id logf).
5120: 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 6c 6f (if (string? lo
5130: 67 66 29 28 72 6d 74 3a 67 65 6e 65 72 61 6c 2d gf)(rmt:general-
5140: 63 61 6c 6c 20 27 74 65 73 74 2d 73 65 74 2d 6c call 'test-set-l
5150: 6f 67 20 72 75 6e 2d 69 64 20 6c 6f 67 66 20 74 og run-id logf t
5160: 65 73 74 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 est-id)))..(defi
5170: 6e 65 20 28 72 6d 74 3a 74 65 73 74 2d 73 65 74 ne (rmt:test-set
5180: 2d 74 6f 70 2d 70 72 6f 63 65 73 73 2d 70 69 64 -top-process-pid
5190: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 run-id test-id
51a0: 70 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 pid). (rmt:send
51b0: 2d 72 65 63 65 69 76 65 20 27 74 65 73 74 2d 73 -receive 'test-s
51c0: 65 74 2d 74 6f 70 2d 70 72 6f 63 65 73 73 2d 70 et-top-process-p
51d0: 69 64 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 id run-id (list
51e0: 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 70 run-id test-id p
51f0: 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 id)))..(define (
5200: 72 6d 74 3a 74 65 73 74 2d 67 65 74 2d 74 6f 70 rmt:test-get-top
5210: 2d 70 72 6f 63 65 73 73 2d 70 69 64 20 72 75 6e -process-pid run
5220: 2d 69 64 20 74 65 73 74 2d 69 64 29 0a 20 20 28 -id test-id). (
5230: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
5240: 20 27 74 65 73 74 2d 67 65 74 2d 74 6f 70 2d 70 'test-get-top-p
5250: 72 6f 63 65 73 73 2d 70 69 64 20 72 75 6e 2d 69 rocess-pid run-i
5260: 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 d (list run-id t
5270: 65 73 74 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 est-id)))..(defi
5280: 6e 65 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e 2d ne (rmt:get-run-
5290: 69 64 73 2d 6d 61 74 63 68 69 6e 67 2d 74 61 72 ids-matching-tar
52a0: 67 65 74 20 6b 65 79 6e 61 6d 65 73 20 74 61 72 get keynames tar
52b0: 67 65 74 20 72 65 73 20 72 75 6e 6e 61 6d 65 20 get res runname
52c0: 74 65 73 74 70 61 74 74 20 73 74 61 74 65 70 61 testpatt statepa
52d0: 74 74 20 73 74 61 74 75 73 70 61 74 74 29 0a 20 tt statuspatt).
52e0: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
52f0: 76 65 20 27 67 65 74 2d 72 75 6e 2d 69 64 73 2d ve 'get-run-ids-
5300: 6d 61 74 63 68 69 6e 67 2d 74 61 72 67 65 74 20 matching-target
5310: 23 66 20 28 6c 69 73 74 20 6b 65 79 6e 61 6d 65 #f (list keyname
5320: 73 20 74 61 72 67 65 74 20 72 65 73 20 72 75 6e s target res run
5330: 6e 61 6d 65 20 74 65 73 74 70 61 74 74 20 73 74 name testpatt st
5340: 61 74 65 70 61 74 74 20 73 74 61 74 75 73 70 61 atepatt statuspa
5350: 74 74 29 29 29 0a 0a 3b 3b 20 4e 4f 54 45 3a 20 tt)))..;; NOTE:
5360: 54 68 69 73 20 77 69 6c 6c 20 6f 70 65 6e 20 61 This will open a
5370: 6e 64 20 61 63 63 65 73 73 20 41 4c 4c 20 72 75 nd access ALL ru
5380: 6e 20 64 61 74 61 62 61 73 65 73 2e 20 0a 3b 3b n databases. .;;
5390: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 65 .(define (rmt:te
53a0: 73 74 2d 67 65 74 2d 70 61 74 68 73 2d 6d 61 74 st-get-paths-mat
53b0: 63 68 69 6e 67 2d 6b 65 79 6e 61 6d 65 73 2d 74 ching-keynames-t
53c0: 61 72 67 65 74 2d 6e 65 77 20 6b 65 79 6e 61 6d arget-new keynam
53d0: 65 73 20 74 61 72 67 65 74 20 72 65 73 20 74 65 es target res te
53e0: 73 74 70 61 74 74 20 73 74 61 74 65 70 61 74 74 stpatt statepatt
53f0: 20 73 74 61 74 75 73 70 61 74 74 20 72 75 6e 6e statuspatt runn
5400: 61 6d 65 29 0a 20 20 28 6c 65 74 20 28 28 72 75 ame). (let ((ru
5410: 6e 2d 69 64 73 20 28 72 6d 74 3a 67 65 74 2d 72 n-ids (rmt:get-r
5420: 75 6e 2d 69 64 73 2d 6d 61 74 63 68 69 6e 67 2d un-ids-matching-
5430: 74 61 72 67 65 74 20 6b 65 79 6e 61 6d 65 73 20 target keynames
5440: 74 61 72 67 65 74 20 72 65 73 20 72 75 6e 6e 61 target res runna
5450: 6d 65 20 74 65 73 74 70 61 74 74 20 73 74 61 74 me testpatt stat
5460: 65 70 61 74 74 20 73 74 61 74 75 73 70 61 74 74 epatt statuspatt
5470: 29 29 29 0a 20 20 20 20 28 61 70 70 6c 79 20 61 ))). (apply a
5480: 70 70 65 6e 64 20 0a 09 20 20 20 28 6d 61 70 20 ppend .. (map
5490: 28 6c 61 6d 62 64 61 20 28 72 75 6e 2d 69 64 29 (lambda (run-id)
54a0: 0a 09 09 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 ... (rmt:send-r
54b0: 65 63 65 69 76 65 20 27 74 65 73 74 2d 67 65 74 eceive 'test-get
54c0: 2d 70 61 74 68 73 2d 6d 61 74 63 68 69 6e 67 2d -paths-matching-
54d0: 6b 65 79 6e 61 6d 65 73 2d 74 61 72 67 65 74 2d keynames-target-
54e0: 6e 65 77 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 new run-id (list
54f0: 20 72 75 6e 2d 69 64 20 6b 65 79 6e 61 6d 65 73 run-id keynames
5500: 20 74 61 72 67 65 74 20 72 65 73 20 74 65 73 74 target res test
5510: 70 61 74 74 20 73 74 61 74 65 70 61 74 74 20 73 patt statepatt s
5520: 74 61 74 75 73 70 61 74 74 20 72 75 6e 6e 61 6d tatuspatt runnam
5530: 65 29 29 29 0a 09 20 20 20 72 75 6e 2d 69 64 73 e))).. run-ids
5540: 29 29 29 29 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 ))))..;; (define
5550: 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e 2d 69 64 (rmt:get-run-id
5560: 73 2d 6d 61 74 63 68 69 6e 67 20 6b 65 79 6e 61 s-matching keyna
5570: 6d 65 73 20 74 61 72 67 65 74 20 72 65 73 29 0a mes target res).
5580: 3b 3b 20 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 ;; (rmt:send-r
5590: 65 63 65 69 76 65 20 23 66 20 27 67 65 74 2d 72 eceive #f 'get-r
55a0: 75 6e 2d 69 64 73 2d 6d 61 74 63 68 69 6e 67 20 un-ids-matching
55b0: 28 6c 69 73 74 20 6b 65 79 6e 61 6d 65 73 20 74 (list keynames t
55c0: 61 72 67 65 74 20 72 65 73 29 29 29 0a 0a 28 64 arget res)))..(d
55d0: 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 70 efine (rmt:get-p
55e0: 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 72 rereqs-not-met r
55f0: 75 6e 2d 69 64 20 77 61 69 74 6f 6e 73 20 72 65 un-id waitons re
5600: 66 2d 69 74 65 6d 2d 70 61 74 68 20 23 21 6b 65 f-item-path #!ke
5610: 79 20 28 6d 6f 64 65 20 27 28 6e 6f 72 6d 61 6c y (mode '(normal
5620: 29 29 28 69 74 65 6d 6d 61 70 20 23 66 29 29 0a ))(itemmap #f)).
5630: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
5640: 69 76 65 20 27 67 65 74 2d 70 72 65 72 65 71 73 ive 'get-prereqs
5650: 2d 6e 6f 74 2d 6d 65 74 20 72 75 6e 2d 69 64 20 -not-met run-id
5660: 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 77 61 69 (list run-id wai
5670: 74 6f 6e 73 20 72 65 66 2d 69 74 65 6d 2d 70 61 tons ref-item-pa
5680: 74 68 20 6d 6f 64 65 20 69 74 65 6d 6d 61 70 29 th mode itemmap)
5690: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
56a0: 3a 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 :get-count-tests
56b0: 2d 72 75 6e 6e 69 6e 67 2d 66 6f 72 2d 72 75 6e -running-for-run
56c0: 2d 69 64 20 72 75 6e 2d 69 64 29 0a 20 20 28 72 -id run-id). (r
56d0: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
56e0: 27 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 'get-count-tests
56f0: 2d 72 75 6e 6e 69 6e 67 2d 66 6f 72 2d 72 75 6e -running-for-run
5700: 2d 69 64 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 -id run-id (list
5710: 20 72 75 6e 2d 69 64 29 29 29 0a 0a 3b 3b 20 53 run-id)))..;; S
5720: 74 61 74 69 73 74 69 63 61 6c 20 71 75 65 72 69 tatistical queri
5730: 65 73 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 es..(define (rmt
5740: 3a 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 :get-count-tests
5750: 2d 72 75 6e 6e 69 6e 67 20 72 75 6e 2d 69 64 29 -running run-id)
5760: 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 . (rmt:send-rec
5770: 65 69 76 65 20 27 67 65 74 2d 63 6f 75 6e 74 2d eive 'get-count-
5780: 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 20 72 75 tests-running ru
5790: 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 n-id (list run-i
57a0: 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 d)))..(define (r
57b0: 6d 74 3a 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 mt:get-count-tes
57c0: 74 73 2d 72 75 6e 6e 69 6e 67 2d 66 6f 72 2d 74 ts-running-for-t
57d0: 65 73 74 6e 61 6d 65 20 72 75 6e 2d 69 64 20 74 estname run-id t
57e0: 65 73 74 6e 61 6d 65 29 0a 20 20 28 72 6d 74 3a estname). (rmt:
57f0: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 send-receive 'ge
5800: 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d 72 75 t-count-tests-ru
5810: 6e 6e 69 6e 67 2d 66 6f 72 2d 74 65 73 74 6e 61 nning-for-testna
5820: 6d 65 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 me run-id (list
5830: 72 75 6e 2d 69 64 20 74 65 73 74 6e 61 6d 65 29 run-id testname)
5840: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
5850: 3a 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 :get-count-tests
5860: 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 -running-in-jobg
5870: 72 6f 75 70 20 72 75 6e 2d 69 64 20 6a 6f 62 67 roup run-id jobg
5880: 72 6f 75 70 29 0a 20 20 28 72 6d 74 3a 73 65 6e roup). (rmt:sen
5890: 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 63 d-receive 'get-c
58a0: 6f 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e 6e 69 ount-tests-runni
58b0: 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 72 ng-in-jobgroup r
58c0: 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d un-id (list run-
58d0: 69 64 20 6a 6f 62 67 72 6f 75 70 29 29 29 0a 0a id jobgroup)))..
58e0: 3b 3b 20 73 74 61 74 65 20 61 6e 64 20 73 74 61 ;; state and sta
58f0: 74 75 73 20 61 72 65 20 65 78 74 72 61 20 68 69 tus are extra hi
5900: 6e 74 73 20 6e 6f 74 20 75 73 75 61 6c 6c 79 20 nts not usually
5910: 75 73 65 64 20 69 6e 20 74 68 65 20 63 61 6c 63 used in the calc
5920: 75 6c 61 74 69 6f 6e 0a 3b 3b 0a 28 64 65 66 69 ulation.;;.(defi
5930: 6e 65 20 28 72 6d 74 3a 72 6f 6c 6c 2d 75 70 2d ne (rmt:roll-up-
5940: 70 61 73 73 2d 66 61 69 6c 2d 63 6f 75 6e 74 73 pass-fail-counts
5950: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
5960: 65 20 69 74 65 6d 2d 70 61 74 68 20 73 74 61 74 e item-path stat
5970: 65 20 73 74 61 74 75 73 29 0a 20 20 28 72 6d 74 e status). (rmt
5980: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 72 :send-receive 'r
5990: 6f 6c 6c 2d 75 70 2d 70 61 73 73 2d 66 61 69 6c oll-up-pass-fail
59a0: 2d 63 6f 75 6e 74 73 20 72 75 6e 2d 69 64 20 28 -counts run-id (
59b0: 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 list run-id test
59c0: 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 -name item-path
59d0: 73 74 61 74 65 20 73 74 61 74 75 73 29 29 29 0a state status))).
59e0: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 75 70 .(define (rmt:up
59f0: 64 61 74 65 2d 70 61 73 73 2d 66 61 69 6c 2d 63 date-pass-fail-c
5a00: 6f 75 6e 74 73 20 72 75 6e 2d 69 64 20 74 65 73 ounts run-id tes
5a10: 74 2d 6e 61 6d 65 29 0a 20 20 28 72 6d 74 3a 67 t-name). (rmt:g
5a20: 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 75 70 64 eneral-call 'upd
5a30: 61 74 65 2d 70 61 73 73 2d 66 61 69 6c 2d 63 6f ate-pass-fail-co
5a40: 75 6e 74 73 20 72 75 6e 2d 69 64 20 74 65 73 74 unts run-id test
5a50: 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 20 -name test-name
5a60: 74 65 73 74 2d 6e 61 6d 65 29 29 0a 0a 28 64 65 test-name))..(de
5a70: 66 69 6e 65 20 28 72 6d 74 3a 74 6f 70 2d 74 65 fine (rmt:top-te
5a80: 73 74 2d 73 65 74 2d 70 65 72 2d 70 66 2d 63 6f st-set-per-pf-co
5a90: 75 6e 74 73 20 72 75 6e 2d 69 64 20 74 65 73 74 unts run-id test
5aa0: 2d 6e 61 6d 65 29 0a 20 20 28 72 6d 74 3a 73 65 -name). (rmt:se
5ab0: 6e 64 2d 72 65 63 65 69 76 65 20 27 74 6f 70 2d nd-receive 'top-
5ac0: 74 65 73 74 2d 73 65 74 2d 70 65 72 2d 70 66 2d test-set-per-pf-
5ad0: 63 6f 75 6e 74 73 20 72 75 6e 2d 69 64 20 28 6c counts run-id (l
5ae0: 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d ist run-id test-
5af0: 6e 61 6d 65 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d name)))..;;=====
5b00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5b10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5b20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5b30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5b40: 3d 0a 3b 3b 20 20 52 20 55 20 4e 20 53 0a 3b 3b =.;; R U N S.;;
5b50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5b60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5b70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5b80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5b90: 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 ======..(define
5ba0: 28 72 6d 74 3a 67 65 74 2d 72 75 6e 2d 69 6e 66 (rmt:get-run-inf
5bb0: 6f 20 72 75 6e 2d 69 64 29 0a 20 20 28 72 6d 74 o run-id). (rmt
5bc0: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 :send-receive 'g
5bd0: 65 74 2d 72 75 6e 2d 69 6e 66 6f 20 72 75 6e 2d et-run-info run-
5be0: 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 29 id (list run-id)
5bf0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
5c00: 3a 67 65 74 2d 6e 75 6d 2d 72 75 6e 73 20 72 75 :get-num-runs ru
5c10: 6e 70 61 74 74 29 0a 20 20 28 72 6d 74 3a 73 65 npatt). (rmt:se
5c20: 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d nd-receive 'get-
5c30: 6e 75 6d 2d 72 75 6e 73 20 23 66 20 28 6c 69 73 num-runs #f (lis
5c40: 74 20 72 75 6e 70 61 74 74 29 29 29 0a 0a 3b 3b t runpatt)))..;;
5c50: 20 55 73 65 20 74 68 65 20 73 70 65 63 69 61 6c Use the special
5c60: 20 72 75 6e 2d 69 64 20 3d 3d 20 23 66 20 73 63 run-id == #f sc
5c70: 65 6e 61 72 69 6f 20 68 65 72 65 20 73 69 6e 63 enario here sinc
5c80: 65 20 74 68 65 72 65 20 69 73 20 6e 6f 20 72 75 e there is no ru
5c90: 6e 20 79 65 74 0a 28 64 65 66 69 6e 65 20 28 72 n yet.(define (r
5ca0: 6d 74 3a 72 65 67 69 73 74 65 72 2d 72 75 6e 20 mt:register-run
5cb0: 6b 65 79 76 61 6c 73 20 72 75 6e 6e 61 6d 65 20 keyvals runname
5cc0: 73 74 61 74 65 20 73 74 61 74 75 73 20 75 73 65 state status use
5cd0: 72 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 r). (rmt:send-r
5ce0: 65 63 65 69 76 65 20 27 72 65 67 69 73 74 65 72 eceive 'register
5cf0: 2d 72 75 6e 20 23 66 20 28 6c 69 73 74 20 6b 65 -run #f (list ke
5d00: 79 76 61 6c 73 20 72 75 6e 6e 61 6d 65 20 73 74 yvals runname st
5d10: 61 74 65 20 73 74 61 74 75 73 20 75 73 65 72 29 ate status user)
5d20: 29 29 0a 20 20 20 20 0a 28 64 65 66 69 6e 65 20 )). .(define
5d30: 28 72 6d 74 3a 67 65 74 2d 72 75 6e 2d 6e 61 6d (rmt:get-run-nam
5d40: 65 2d 66 72 6f 6d 2d 69 64 20 72 75 6e 2d 69 64 e-from-id run-id
5d50: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
5d60: 63 65 69 76 65 20 27 67 65 74 2d 72 75 6e 2d 6e ceive 'get-run-n
5d70: 61 6d 65 2d 66 72 6f 6d 2d 69 64 20 72 75 6e 2d ame-from-id run-
5d80: 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 29 id (list run-id)
5d90: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
5da0: 3a 64 65 6c 65 74 65 2d 72 75 6e 20 72 75 6e 2d :delete-run run-
5db0: 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d id). (rmt:send-
5dc0: 72 65 63 65 69 76 65 20 27 64 65 6c 65 74 65 2d receive 'delete-
5dd0: 72 75 6e 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 run run-id (list
5de0: 20 72 75 6e 2d 69 64 29 29 29 0a 0a 28 64 65 66 run-id)))..(def
5df0: 69 6e 65 20 28 72 6d 74 3a 64 65 6c 65 74 65 2d ine (rmt:delete-
5e00: 6f 6c 64 2d 64 65 6c 65 74 65 64 2d 74 65 73 74 old-deleted-test
5e10: 2d 72 65 63 6f 72 64 73 29 0a 20 20 28 72 6d 74 -records). (rmt
5e20: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 64 :send-receive 'd
5e30: 65 6c 65 74 65 2d 6f 6c 64 2d 64 65 6c 65 74 65 elete-old-delete
5e40: 64 2d 74 65 73 74 2d 72 65 63 6f 72 64 73 20 23 d-test-records #
5e50: 66 20 27 28 29 29 29 0a 0a 28 64 65 66 69 6e 65 f '()))..(define
5e60: 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e 73 20 72 (rmt:get-runs r
5e70: 75 6e 70 61 74 74 20 63 6f 75 6e 74 20 6f 66 66 unpatt count off
5e80: 73 65 74 20 6b 65 79 70 61 74 74 73 29 0a 20 20 set keypatts).
5e90: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
5ea0: 65 20 27 67 65 74 2d 72 75 6e 73 20 23 66 20 28 e 'get-runs #f (
5eb0: 6c 69 73 74 20 72 75 6e 70 61 74 74 20 63 6f 75 list runpatt cou
5ec0: 6e 74 20 6f 66 66 73 65 74 20 6b 65 79 70 61 74 nt offset keypat
5ed0: 74 73 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 ts)))..(define (
5ee0: 72 6d 74 3a 67 65 74 2d 61 6c 6c 2d 72 75 6e 2d rmt:get-all-run-
5ef0: 69 64 73 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 ids). (rmt:send
5f00: 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 61 6c -receive 'get-al
5f10: 6c 2d 72 75 6e 2d 69 64 73 20 23 66 20 27 28 29 l-run-ids #f '()
5f20: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
5f30: 3a 67 65 74 2d 70 72 65 76 2d 72 75 6e 2d 69 64 :get-prev-run-id
5f40: 73 20 72 75 6e 2d 69 64 29 0a 20 20 28 72 6d 74 s run-id). (rmt
5f50: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 :send-receive 'g
5f60: 65 74 2d 70 72 65 76 2d 72 75 6e 2d 69 64 73 20 et-prev-run-ids
5f70: 23 66 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 29 #f (list run-id)
5f80: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
5f90: 3a 6c 6f 63 6b 2f 75 6e 6c 6f 63 6b 2d 72 75 6e :lock/unlock-run
5fa0: 20 72 75 6e 2d 69 64 20 6c 6f 63 6b 20 75 6e 6c run-id lock unl
5fb0: 6f 63 6b 20 75 73 65 72 29 0a 20 20 28 72 6d 74 ock user). (rmt
5fc0: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 6c :send-receive 'l
5fd0: 6f 63 6b 2f 75 6e 6c 6f 63 6b 2d 72 75 6e 20 23 ock/unlock-run #
5fe0: 66 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 6c f (list run-id l
5ff0: 6f 63 6b 20 75 6e 6c 6f 63 6b 20 75 73 65 72 29 ock unlock user)
6000: 29 29 0a 0a 3b 3b 20 73 65 74 2f 67 65 74 20 73 ))..;; set/get s
6010: 74 61 74 75 73 0a 28 64 65 66 69 6e 65 20 28 72 tatus.(define (r
6020: 6d 74 3a 67 65 74 2d 72 75 6e 2d 73 74 61 74 75 mt:get-run-statu
6030: 73 20 72 75 6e 2d 69 64 29 0a 20 20 28 72 6d 74 s run-id). (rmt
6040: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 :send-receive 'g
6050: 65 74 2d 72 75 6e 2d 73 74 61 74 75 73 20 23 66 et-run-status #f
6060: 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 29 29 29 (list run-id)))
6070: 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 73 ..(define (rmt:s
6080: 65 74 2d 72 75 6e 2d 73 74 61 74 75 73 20 72 75 et-run-status ru
6090: 6e 2d 69 64 20 72 75 6e 2d 73 74 61 74 75 73 20 n-id run-status
60a0: 23 21 6b 65 79 20 28 6d 73 67 20 23 66 29 29 0a #!key (msg #f)).
60b0: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
60c0: 69 76 65 20 27 73 65 74 2d 72 75 6e 2d 73 74 61 ive 'set-run-sta
60d0: 74 75 73 20 23 66 20 28 6c 69 73 74 20 72 75 6e tus #f (list run
60e0: 2d 69 64 20 72 75 6e 2d 73 74 61 74 75 73 20 6d -id run-status m
60f0: 73 67 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 sg)))..(define (
6100: 72 6d 74 3a 75 70 64 61 74 65 2d 72 75 6e 2d 65 rmt:update-run-e
6110: 76 65 6e 74 5f 74 69 6d 65 20 72 75 6e 2d 69 64 vent_time run-id
6120: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
6130: 63 65 69 76 65 20 27 75 70 64 61 74 65 2d 72 75 ceive 'update-ru
6140: 6e 2d 65 76 65 6e 74 5f 74 69 6d 65 20 23 66 20 n-event_time #f
6150: 28 6c 69 73 74 20 72 75 6e 2d 69 64 29 29 29 0a (list run-id))).
6160: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 .(define (rmt:ge
6170: 74 2d 72 75 6e 73 2d 62 79 2d 70 61 74 74 20 20 t-runs-by-patt
6180: 6b 65 79 73 20 72 75 6e 6e 61 6d 65 70 61 74 74 keys runnamepatt
6190: 20 74 61 72 67 70 61 74 74 20 6f 66 66 73 65 74 targpatt offset
61a0: 20 6c 69 6d 69 74 20 66 69 65 6c 64 73 29 20 3b limit fields) ;
61b0: 3b 20 66 69 65 6c 64 73 20 6f 66 20 23 66 20 75 ; fields of #f u
61c0: 73 65 73 20 64 65 66 61 75 6c 74 0a 20 20 28 72 ses default. (r
61d0: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
61e0: 27 67 65 74 2d 72 75 6e 73 2d 62 79 2d 70 61 74 'get-runs-by-pat
61f0: 74 20 23 66 20 28 6c 69 73 74 20 6b 65 79 73 20 t #f (list keys
6200: 72 75 6e 6e 61 6d 65 70 61 74 74 20 74 61 72 67 runnamepatt targ
6210: 70 61 74 74 20 6f 66 66 73 65 74 20 6c 69 6d 69 patt offset limi
6220: 74 20 66 69 65 6c 64 73 29 29 29 0a 0a 28 64 65 t fields)))..(de
6230: 66 69 6e 65 20 28 72 6d 74 3a 66 69 6e 64 2d 61 fine (rmt:find-a
6240: 6e 64 2d 6d 61 72 6b 2d 69 6e 63 6f 6d 70 6c 65 nd-mark-incomple
6250: 74 65 20 72 75 6e 2d 69 64 20 6f 76 72 2d 64 65 te run-id ovr-de
6260: 61 64 74 69 6d 65 29 0a 20 20 28 69 66 20 28 72 adtime). (if (r
6270: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
6280: 27 68 61 76 65 2d 69 6e 63 6f 6d 70 6c 65 74 65 'have-incomplete
6290: 73 3f 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 s? run-id (list
62a0: 72 75 6e 2d 69 64 20 6f 76 72 2d 64 65 61 64 74 run-id ovr-deadt
62b0: 69 6d 65 29 29 0a 20 20 20 20 20 20 28 72 6d 74 ime)). (rmt
62c0: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 6d :send-receive 'm
62d0: 61 72 6b 2d 69 6e 63 6f 6d 70 6c 65 74 65 20 72 ark-incomplete r
62e0: 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d un-id (list run-
62f0: 69 64 20 6f 76 72 2d 64 65 61 64 74 69 6d 65 29 id ovr-deadtime)
6300: 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d )))..;;=========
6310: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6320: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6330: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6340: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
6350: 20 4d 20 55 20 4c 20 54 20 49 20 52 20 55 20 4e M U L T I R U N
6360: 20 20 20 51 20 55 20 45 20 52 20 49 20 45 20 53 Q U E R I E S
6370: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
6380: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6390: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
63a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
63b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 4e 65 =========..;; Ne
63c0: 65 64 20 74 6f 20 6d 6f 76 65 20 74 68 69 73 20 ed to move this
63d0: 74 6f 20 6d 75 6c 74 69 2d 72 75 6e 20 73 65 63 to multi-run sec
63e0: 74 69 6f 6e 20 61 6e 64 20 6d 61 6b 65 20 61 73 tion and make as
63f0: 73 6f 63 69 61 74 65 64 20 63 68 61 6e 67 65 73 sociated changes
6400: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 66 69 .(define (rmt:fi
6410: 6e 64 2d 61 6e 64 2d 6d 61 72 6b 2d 69 6e 63 6f nd-and-mark-inco
6420: 6d 70 6c 65 74 65 2d 61 6c 6c 2d 72 75 6e 73 20 mplete-all-runs
6430: 23 21 6b 65 79 20 28 6f 76 72 2d 64 65 61 64 74 #!key (ovr-deadt
6440: 69 6d 65 20 23 66 29 29 0a 20 20 28 6c 65 74 20 ime #f)). (let
6450: 28 28 72 75 6e 2d 69 64 73 20 28 72 6d 74 3a 67 ((run-ids (rmt:g
6460: 65 74 2d 61 6c 6c 2d 72 75 6e 2d 69 64 73 29 29 et-all-run-ids))
6470: 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 ). (for-each
6480: 28 6c 61 6d 62 64 61 20 28 72 75 6e 2d 69 64 29 (lambda (run-id)
6490: 0a 09 20 20 20 20 20 20 20 28 72 6d 74 3a 66 69 .. (rmt:fi
64a0: 6e 64 2d 61 6e 64 2d 6d 61 72 6b 2d 69 6e 63 6f nd-and-mark-inco
64b0: 6d 70 6c 65 74 65 20 72 75 6e 2d 69 64 20 6f 76 mplete run-id ov
64c0: 72 2d 64 65 61 64 74 69 6d 65 29 29 0a 09 20 20 r-deadtime))..
64d0: 20 20 20 72 75 6e 2d 69 64 73 29 29 29 0a 0a 3b run-ids)))..;
64e0: 3b 20 67 65 74 20 74 68 65 20 70 72 65 76 69 6f ; get the previo
64f0: 75 73 20 72 65 63 6f 72 64 20 66 6f 72 20 77 68 us record for wh
6500: 65 6e 20 74 68 69 73 20 74 65 73 74 20 77 61 73 en this test was
6510: 20 72 75 6e 20 77 68 65 72 65 20 61 6c 6c 20 6b run where all k
6520: 65 79 73 20 6d 61 74 63 68 20 62 75 74 20 72 75 eys match but ru
6530: 6e 6e 61 6d 65 0a 3b 3b 20 72 65 74 75 72 6e 73 nname.;; returns
6540: 20 23 66 20 69 66 20 6e 6f 20 73 75 63 68 20 74 #f if no such t
6550: 65 73 74 20 66 6f 75 6e 64 2c 20 72 65 74 75 72 est found, retur
6560: 6e 73 20 61 20 73 69 6e 67 6c 65 20 74 65 73 74 ns a single test
6570: 20 72 65 63 6f 72 64 20 69 66 20 66 6f 75 6e 64 record if found
6580: 0a 3b 3b 20 0a 3b 3b 20 52 75 6e 20 74 68 69 73 .;; .;; Run this
6590: 20 61 74 20 74 68 65 20 63 6c 69 65 6e 74 20 65 at the client e
65a0: 6e 64 20 73 69 6e 63 65 20 77 65 20 68 61 76 65 nd since we have
65b0: 20 74 6f 20 63 6f 6e 6e 65 63 74 20 74 6f 20 6d to connect to m
65c0: 75 6c 74 69 70 6c 65 20 72 75 6e 2d 69 64 20 64 ultiple run-id d
65d0: 62 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 72 bs.;;.(define (r
65e0: 6d 74 3a 67 65 74 2d 70 72 65 76 69 6f 75 73 2d mt:get-previous-
65f0: 74 65 73 74 2d 72 75 6e 2d 72 65 63 6f 72 64 20 test-run-record
6600: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
6610: 20 69 74 65 6d 2d 70 61 74 68 29 0a 20 20 28 6c item-path). (l
6620: 65 74 2a 20 28 28 6b 65 79 76 61 6c 73 20 28 72 et* ((keyvals (r
6630: 6d 74 3a 67 65 74 2d 6b 65 79 2d 76 61 6c 2d 70 mt:get-key-val-p
6640: 61 69 72 73 20 72 75 6e 2d 69 64 29 29 0a 09 20 airs run-id))..
6650: 28 6b 65 79 73 20 20 20 20 28 72 6d 74 3a 67 65 (keys (rmt:ge
6660: 74 2d 6b 65 79 73 29 29 0a 09 20 28 73 65 6c 73 t-keys)).. (sels
6670: 74 72 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 tr (string-inte
6680: 72 73 70 65 72 73 65 20 20 6b 65 79 73 20 22 2c rsperse keys ",
6690: 22 29 29 0a 09 20 28 71 72 79 73 74 72 20 20 28 ")).. (qrystr (
66a0: 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
66b0: 73 65 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 se (map (lambda
66c0: 28 78 29 28 63 6f 6e 63 20 78 20 22 3d 3f 22 29 (x)(conc x "=?")
66d0: 29 20 6b 65 79 73 29 20 22 20 41 4e 44 20 22 29 ) keys) " AND ")
66e0: 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 )). (if (not
66f0: 6b 65 79 76 61 6c 73 29 0a 09 23 66 0a 09 28 6c keyvals)..#f..(l
6700: 65 74 20 28 28 70 72 65 76 2d 72 75 6e 2d 69 64 et ((prev-run-id
6710: 73 20 28 72 6d 74 3a 67 65 74 2d 70 72 65 76 2d s (rmt:get-prev-
6720: 72 75 6e 2d 69 64 73 20 72 75 6e 2d 69 64 29 29 run-ids run-id))
6730: 29 0a 09 20 20 3b 3b 20 66 6f 72 20 65 61 63 68 ).. ;; for each
6740: 20 72 75 6e 20 73 74 61 72 74 69 6e 67 20 77 69 run starting wi
6750: 74 68 20 74 68 65 20 6d 6f 73 74 20 72 65 63 65 th the most rece
6760: 6e 74 20 6c 6f 6f 6b 20 74 6f 20 73 65 65 20 69 nt look to see i
6770: 66 20 74 68 65 72 65 20 69 73 20 61 20 6d 61 74 f there is a mat
6780: 63 68 69 6e 67 20 74 65 73 74 0a 09 20 20 3b 3b ching test.. ;;
6790: 20 69 66 20 66 6f 75 6e 64 20 74 68 65 6e 20 72 if found then r
67a0: 65 74 75 72 6e 20 74 68 61 74 20 6d 61 74 63 68 eturn that match
67b0: 69 6e 67 20 74 65 73 74 20 72 65 63 6f 72 64 0a ing test record.
67c0: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 . (debug:print
67d0: 34 20 22 73 65 6c 73 74 72 3a 20 22 20 73 65 6c 4 "selstr: " sel
67e0: 73 74 72 20 22 2c 20 71 72 79 73 74 72 3a 20 22 str ", qrystr: "
67f0: 20 71 72 79 73 74 72 20 22 2c 20 6b 65 79 76 61 qrystr ", keyva
6800: 6c 73 3a 20 22 20 6b 65 79 76 61 6c 73 20 22 2c ls: " keyvals ",
6810: 20 70 72 65 76 69 6f 75 73 20 72 75 6e 20 69 64 previous run id
6820: 73 20 66 6f 75 6e 64 3a 20 22 20 70 72 65 76 2d s found: " prev-
6830: 72 75 6e 2d 69 64 73 29 0a 09 20 20 28 69 66 20 run-ids).. (if
6840: 28 6e 75 6c 6c 3f 20 70 72 65 76 2d 72 75 6e 2d (null? prev-run-
6850: 69 64 73 29 20 23 66 0a 09 20 20 20 20 20 20 28 ids) #f.. (
6860: 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 let loop ((hed (
6870: 63 61 72 20 70 72 65 76 2d 72 75 6e 2d 69 64 73 car prev-run-ids
6880: 29 29 0a 09 09 09 20 28 74 61 6c 20 28 63 64 72 )).... (tal (cdr
6890: 20 70 72 65 76 2d 72 75 6e 2d 69 64 73 29 29 29 prev-run-ids)))
68a0: 0a 09 09 28 6c 65 74 20 28 28 72 65 73 75 6c 74 ...(let ((result
68b0: 73 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 73 s (rmt:get-tests
68c0: 2d 66 6f 72 2d 72 75 6e 20 68 65 64 20 28 63 6f -for-run hed (co
68d0: 6e 63 20 74 65 73 74 2d 6e 61 6d 65 20 22 2f 22 nc test-name "/"
68e0: 20 69 74 65 6d 2d 70 61 74 68 29 20 27 28 29 20 item-path) '()
68f0: 27 28 29 20 23 66 20 23 66 20 23 66 20 23 66 20 '() #f #f #f #f
6900: 23 66 20 23 66 29 29 29 0a 09 09 20 20 28 64 65 #f #f)))... (de
6910: 62 75 67 3a 70 72 69 6e 74 20 34 20 22 47 6f 74 bug:print 4 "Got
6920: 20 74 65 73 74 73 20 66 6f 72 20 72 75 6e 2d 69 tests for run-i
6930: 64 20 22 20 72 75 6e 2d 69 64 20 22 2c 20 74 65 d " run-id ", te
6940: 73 74 2d 6e 61 6d 65 20 22 20 74 65 73 74 2d 6e st-name " test-n
6950: 61 6d 65 20 22 2c 20 69 74 65 6d 2d 70 61 74 68 ame ", item-path
6960: 20 22 20 69 74 65 6d 2d 70 61 74 68 20 22 3a 20 " item-path ":
6970: 22 20 72 65 73 75 6c 74 73 29 0a 09 09 20 20 28 " results)... (
6980: 69 66 20 28 61 6e 64 20 28 6e 75 6c 6c 3f 20 72 if (and (null? r
6990: 65 73 75 6c 74 73 29 0a 09 09 09 20 20 20 28 6e esults).... (n
69a0: 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 29 ot (null? tal)))
69b0: 0a 09 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 ... (loop (
69c0: 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c car tal)(cdr tal
69d0: 29 29 0a 09 09 20 20 20 20 20 20 28 69 66 20 28 ))... (if (
69e0: 6e 75 6c 6c 3f 20 72 65 73 75 6c 74 73 29 20 23 null? results) #
69f0: 66 0a 09 09 09 20 20 28 63 61 72 20 72 65 73 75 f.... (car resu
6a00: 6c 74 73 29 29 29 29 29 29 29 29 29 29 0a 0a 3b lts))))))))))..;
6a10: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
6a20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6a30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6a40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6a50: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 53 20 54 20 =======.;; S T
6a60: 45 20 50 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d E P S.;;========
6a70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6a80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6a90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6aa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
6ab0: 3b 3b 20 47 65 74 74 69 6e 67 20 73 74 65 70 73 ;; Getting steps
6ac0: 20 69 73 20 6d 6f 72 65 20 63 6f 6d 70 6c 69 63 is more complic
6ad0: 61 74 65 64 2e 0a 3b 3b 0a 3b 3b 20 49 66 20 67 ated..;;.;; If g
6ae0: 69 76 65 6e 20 77 6f 72 6b 20 61 72 65 61 20 0a iven work area .
6af0: 3b 3b 20 20 31 2e 20 46 69 6e 64 20 74 68 65 20 ;; 1. Find the
6b00: 74 65 73 74 64 61 74 2e 64 62 20 66 69 6c 65 0a testdat.db file.
6b10: 3b 3b 20 20 32 2e 20 4f 70 65 6e 20 74 68 65 20 ;; 2. Open the
6b20: 74 65 73 74 64 61 74 2e 64 62 20 66 69 6c 65 20 testdat.db file
6b30: 61 6e 64 20 64 6f 20 74 68 65 20 71 75 65 72 79 and do the query
6b40: 0a 3b 3b 20 49 66 20 6e 6f 74 20 67 69 76 65 6e .;; If not given
6b50: 20 74 68 65 20 77 6f 72 6b 20 61 72 65 61 0a 3b the work area.;
6b60: 3b 20 20 31 2e 20 44 6f 20 61 20 72 65 6d 6f 74 ; 1. Do a remot
6b70: 65 20 63 61 6c 6c 20 74 6f 20 67 65 74 20 74 68 e call to get th
6b80: 65 20 74 65 73 74 20 70 61 74 68 0a 3b 3b 20 20 e test path.;;
6b90: 32 2e 20 43 6f 6e 74 69 6e 75 65 20 61 73 20 61 2. Continue as a
6ba0: 62 6f 76 65 0a 3b 3b 20 0a 3b 3b 28 64 65 66 69 bove.;; .;;(defi
6bb0: 6e 65 20 28 72 6d 74 3a 67 65 74 2d 73 74 65 70 ne (rmt:get-step
6bc0: 73 2d 66 6f 72 2d 74 65 73 74 20 72 75 6e 2d 69 s-for-test run-i
6bd0: 64 20 74 65 73 74 2d 69 64 29 0a 3b 3b 20 20 28 d test-id).;; (
6be0: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
6bf0: 20 27 67 65 74 2d 73 74 65 70 73 2d 64 61 74 61 'get-steps-data
6c00: 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 74 65 run-id (list te
6c10: 73 74 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 6e st-id)))..(defin
6c20: 65 20 28 72 6d 74 3a 74 65 73 74 73 74 65 70 2d e (rmt:teststep-
6c30: 73 65 74 2d 73 74 61 74 75 73 21 20 72 75 6e 2d set-status! run-
6c40: 69 64 20 74 65 73 74 2d 69 64 20 74 65 73 74 73 id test-id tests
6c50: 74 65 70 2d 6e 61 6d 65 20 73 74 61 74 65 2d 69 tep-name state-i
6c60: 6e 20 73 74 61 74 75 73 2d 69 6e 20 63 6f 6d 6d n status-in comm
6c70: 65 6e 74 20 6c 6f 67 66 69 6c 65 29 0a 20 20 28 ent logfile). (
6c80: 6c 65 74 2a 20 28 28 73 74 61 74 65 20 20 20 20 let* ((state
6c90: 20 28 69 74 65 6d 73 3a 63 68 65 63 6b 2d 76 61 (items:check-va
6ca0: 6c 69 64 2d 69 74 65 6d 73 20 22 73 74 61 74 65 lid-items "state
6cb0: 22 20 73 74 61 74 65 2d 69 6e 29 29 0a 09 20 28 " state-in)).. (
6cc0: 73 74 61 74 75 73 20 20 20 20 28 69 74 65 6d 73 status (items
6cd0: 3a 63 68 65 63 6b 2d 76 61 6c 69 64 2d 69 74 65 :check-valid-ite
6ce0: 6d 73 20 22 73 74 61 74 75 73 22 20 73 74 61 74 ms "status" stat
6cf0: 75 73 2d 69 6e 29 29 29 0a 20 20 20 20 28 69 66 us-in))). (if
6d00: 20 28 6f 72 20 28 6e 6f 74 20 73 74 61 74 65 29 (or (not state)
6d10: 28 6e 6f 74 20 73 74 61 74 75 73 29 29 0a 09 28 (not status))..(
6d20: 64 65 62 75 67 3a 70 72 69 6e 74 20 33 20 22 57 debug:print 3 "W
6d30: 41 52 4e 49 4e 47 3a 20 49 6e 76 61 6c 69 64 20 ARNING: Invalid
6d40: 22 20 28 69 66 20 73 74 61 74 75 73 20 22 73 74 " (if status "st
6d50: 61 74 75 73 22 20 22 73 74 61 74 65 22 29 0a 09 atus" "state")..
6d60: 09 20 20 20 20 20 22 20 76 61 6c 75 65 20 5c 22 . " value \"
6d70: 22 20 28 69 66 20 73 74 61 74 75 73 20 73 74 61 " (if status sta
6d80: 74 65 2d 69 6e 20 73 74 61 74 75 73 2d 69 6e 29 te-in status-in)
6d90: 20 22 5c 22 2c 20 75 70 64 61 74 65 20 79 6f 75 "\", update you
6da0: 72 20 76 61 6c 69 64 76 61 6c 75 65 73 20 73 65 r validvalues se
6db0: 63 74 69 6f 6e 20 69 6e 20 6d 65 67 61 74 65 73 ction in megates
6dc0: 74 2e 63 6f 6e 66 69 67 22 29 29 0a 20 20 20 20 t.config")).
6dd0: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
6de0: 65 20 27 74 65 73 74 73 74 65 70 2d 73 65 74 2d e 'teststep-set-
6df0: 73 74 61 74 75 73 21 20 72 75 6e 2d 69 64 20 28 status! run-id (
6e00: 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 list run-id test
6e10: 2d 69 64 20 74 65 73 74 73 74 65 70 2d 6e 61 6d -id teststep-nam
6e20: 65 20 73 74 61 74 65 2d 69 6e 20 73 74 61 74 75 e state-in statu
6e30: 73 2d 69 6e 20 63 6f 6d 6d 65 6e 74 20 6c 6f 67 s-in comment log
6e40: 66 69 6c 65 29 29 29 29 0a 0a 28 64 65 66 69 6e file))))..(defin
6e50: 65 20 28 72 6d 74 3a 67 65 74 2d 73 74 65 70 73 e (rmt:get-steps
6e60: 2d 66 6f 72 2d 74 65 73 74 20 72 75 6e 2d 69 64 -for-test run-id
6e70: 20 74 65 73 74 2d 69 64 29 0a 20 20 28 72 6d 74 test-id). (rmt
6e80: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 :send-receive 'g
6e90: 65 74 2d 73 74 65 70 73 2d 66 6f 72 2d 74 65 73 et-steps-for-tes
6ea0: 74 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 t run-id (list r
6eb0: 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 29 29 un-id test-id)))
6ec0: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
6ed0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6ee0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6ef0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6f00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 54 ==========.;; T
6f10: 20 45 20 53 20 54 20 20 20 44 20 41 20 54 20 41 E S T D A T A
6f20: 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;============
6f30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6f40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6f50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6f60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 ==========..(def
6f70: 69 6e 65 20 28 72 6d 74 3a 72 65 61 64 2d 74 65 ine (rmt:read-te
6f80: 73 74 2d 64 61 74 61 20 72 75 6e 2d 69 64 20 74 st-data run-id t
6f90: 65 73 74 2d 69 64 20 63 61 74 65 67 6f 72 79 70 est-id categoryp
6fa0: 61 74 74 20 23 21 6b 65 79 20 28 77 6f 72 6b 2d att #!key (work-
6fb0: 61 72 65 61 20 23 66 29 29 20 0a 20 20 28 6c 65 area #f)) . (le
6fc0: 74 20 28 28 74 64 62 20 20 28 72 6d 74 3a 6f 70 t ((tdb (rmt:op
6fd0: 65 6e 2d 74 65 73 74 2d 64 62 2d 62 79 2d 74 65 en-test-db-by-te
6fe0: 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 st-id run-id tes
6ff0: 74 2d 69 64 20 77 6f 72 6b 2d 61 72 65 61 3a 20 t-id work-area:
7000: 77 6f 72 6b 2d 61 72 65 61 29 29 29 0a 20 20 20 work-area))).
7010: 20 28 69 66 20 74 64 62 0a 09 28 74 64 62 3a 72 (if tdb..(tdb:r
7020: 65 61 64 2d 74 65 73 74 2d 64 61 74 61 20 74 64 ead-test-data td
7030: 62 20 74 65 73 74 2d 69 64 20 63 61 74 65 67 6f b test-id catego
7040: 72 79 70 61 74 74 29 0a 09 27 28 29 29 29 29 0a rypatt)..'()))).
7050: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 65 .(define (rmt:te
7060: 73 74 6d 65 74 61 2d 61 64 64 2d 72 65 63 6f 72 stmeta-add-recor
7070: 64 20 74 65 73 74 6e 61 6d 65 29 0a 20 20 28 72 d testname). (r
7080: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
7090: 27 74 65 73 74 6d 65 74 61 2d 61 64 64 2d 72 65 'testmeta-add-re
70a0: 63 6f 72 64 20 23 66 20 28 6c 69 73 74 20 74 65 cord #f (list te
70b0: 73 74 6e 61 6d 65 29 29 29 0a 0a 28 64 65 66 69 stname)))..(defi
70c0: 6e 65 20 28 72 6d 74 3a 74 65 73 74 6d 65 74 61 ne (rmt:testmeta
70d0: 2d 67 65 74 2d 72 65 63 6f 72 64 20 74 65 73 74 -get-record test
70e0: 6e 61 6d 65 29 0a 20 20 28 72 6d 74 3a 73 65 6e name). (rmt:sen
70f0: 64 2d 72 65 63 65 69 76 65 20 27 74 65 73 74 6d d-receive 'testm
7100: 65 74 61 2d 67 65 74 2d 72 65 63 6f 72 64 20 23 eta-get-record #
7110: 66 20 28 6c 69 73 74 20 74 65 73 74 6e 61 6d 65 f (list testname
7120: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d )))..(define (rm
7130: 74 3a 74 65 73 74 6d 65 74 61 2d 75 70 64 61 74 t:testmeta-updat
7140: 65 2d 66 69 65 6c 64 20 74 65 73 74 2d 6e 61 6d e-field test-nam
7150: 65 20 66 6c 64 20 76 61 6c 29 0a 20 20 28 72 6d e fld val). (rm
7160: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
7170: 74 65 73 74 6d 65 74 61 2d 75 70 64 61 74 65 2d testmeta-update-
7180: 66 69 65 6c 64 20 23 66 20 28 6c 69 73 74 20 74 field #f (list t
7190: 65 73 74 2d 6e 61 6d 65 20 66 6c 64 20 76 61 6c est-name fld val
71a0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d )))..(define (rm
71b0: 74 3a 74 65 73 74 2d 64 61 74 61 2d 72 6f 6c 6c t:test-data-roll
71c0: 75 70 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 up run-id test-i
71d0: 64 20 73 74 61 74 75 73 29 0a 20 20 28 72 6d 74 d status). (rmt
71e0: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 74 :send-receive 't
71f0: 65 73 74 2d 64 61 74 61 2d 72 6f 6c 6c 75 70 20 est-data-rollup
7200: 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e run-id (list run
7210: 2d 69 64 20 74 65 73 74 2d 69 64 20 73 74 61 74 -id test-id stat
7220: 75 73 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 us)))..(define (
7230: 72 6d 74 3a 63 73 76 2d 3e 74 65 73 74 2d 64 61 rmt:csv->test-da
7240: 74 61 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 ta run-id test-i
7250: 64 20 63 73 76 64 61 74 61 29 0a 20 20 28 72 6d d csvdata). (rm
7260: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
7270: 63 73 76 2d 3e 74 65 73 74 2d 64 61 74 61 20 72 csv->test-data r
7280: 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d un-id (list run-
7290: 69 64 20 74 65 73 74 2d 69 64 20 63 73 76 64 61 id test-id csvda
72a0: 74 61 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d ta)))..;;=======
72b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
72c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
72d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
72e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
72f0: 3b 3b 20 20 54 20 41 20 53 20 4b 20 53 0a 3b 3b ;; T A S K S.;;
7300: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7310: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7320: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7330: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7340: 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 ======..(define
7350: 28 72 6d 74 3a 74 61 73 6b 73 2d 66 69 6e 64 2d (rmt:tasks-find-
7360: 74 61 73 6b 2d 71 75 65 75 65 2d 72 65 63 6f 72 task-queue-recor
7370: 64 73 20 74 61 72 67 65 74 20 72 75 6e 2d 6e 61 ds target run-na
7380: 6d 65 20 74 65 73 74 2d 70 61 74 74 20 73 74 61 me test-patt sta
7390: 74 65 2d 70 61 74 74 20 61 63 74 69 6f 6e 2d 70 te-patt action-p
73a0: 61 74 74 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 att). (rmt:send
73b0: 2d 72 65 63 65 69 76 65 20 27 66 69 6e 64 2d 74 -receive 'find-t
73c0: 61 73 6b 2d 71 75 65 75 65 2d 72 65 63 6f 72 64 ask-queue-record
73d0: 73 20 23 66 20 28 6c 69 73 74 20 74 61 72 67 65 s #f (list targe
73e0: 74 20 72 75 6e 2d 6e 61 6d 65 20 74 65 73 74 2d t run-name test-
73f0: 70 61 74 74 20 73 74 61 74 65 2d 70 61 74 74 20 patt state-patt
7400: 61 63 74 69 6f 6e 2d 70 61 74 74 29 29 29 0a 0a action-patt)))..
7410: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 61 73 (define (rmt:tas
7420: 6b 73 2d 61 64 64 20 61 63 74 69 6f 6e 20 6f 77 ks-add action ow
7430: 6e 65 72 20 74 61 72 67 65 74 20 72 75 6e 6e 61 ner target runna
7440: 6d 65 20 74 65 73 74 70 61 74 74 20 70 61 72 61 me testpatt para
7450: 6d 73 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d ms). (rmt:send-
7460: 72 65 63 65 69 76 65 20 27 74 61 73 6b 73 2d 61 receive 'tasks-a
7470: 64 64 20 23 66 20 28 6c 69 73 74 20 61 63 74 69 dd #f (list acti
7480: 6f 6e 20 6f 77 6e 65 72 20 74 61 72 67 65 74 20 on owner target
7490: 72 75 6e 6e 61 6d 65 20 74 65 73 74 70 61 74 74 runname testpatt
74a0: 20 70 61 72 61 6d 73 29 29 29 0a 0a 28 64 65 66 params)))..(def
74b0: 69 6e 65 20 28 72 6d 74 3a 74 61 73 6b 73 2d 73 ine (rmt:tasks-s
74c0: 65 74 2d 73 74 61 74 65 2d 67 69 76 65 6e 2d 70 et-state-given-p
74d0: 61 72 61 6d 2d 6b 65 79 20 70 61 72 61 6d 2d 6b aram-key param-k
74e0: 65 79 20 6e 65 77 2d 73 74 61 74 65 29 0a 20 20 ey new-state).
74f0: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
7500: 65 20 27 74 61 73 6b 73 2d 73 65 74 2d 73 74 61 e 'tasks-set-sta
7510: 74 65 2d 67 69 76 65 6e 2d 70 61 72 61 6d 2d 6b te-given-param-k
7520: 65 79 20 23 66 20 28 6c 69 73 74 20 20 70 61 72 ey #f (list par
7530: 61 6d 2d 6b 65 79 20 6e 65 77 2d 73 74 61 74 65 am-key new-state
7540: 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d )))..;;=========
7550: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7560: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7570: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7580: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
7590: 20 41 20 52 20 43 20 48 20 49 20 56 20 45 20 53 A R C H I V E S
75a0: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
75b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
75c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
75d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
75e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 =========..(defi
75f0: 6e 65 20 28 72 6d 74 3a 61 72 63 68 69 76 65 2d ne (rmt:archive-
7600: 67 65 74 2d 61 6c 6c 6f 63 61 74 69 6f 6e 73 20 get-allocations
7610: 20 74 65 73 74 6e 61 6d 65 20 69 74 65 6d 70 61 testname itempa
7620: 74 68 20 64 6e 65 65 64 65 64 29 0a 20 20 28 72 th dneeded). (r
7630: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
7640: 27 61 72 63 68 69 76 65 2d 67 65 74 2d 61 6c 6c 'archive-get-all
7650: 6f 63 61 74 69 6f 6e 73 20 23 66 20 28 6c 69 73 ocations #f (lis
7660: 74 20 74 65 73 74 6e 61 6d 65 20 69 74 65 6d 70 t testname itemp
7670: 61 74 68 20 64 6e 65 65 64 65 64 29 29 29 0a 0a ath dneeded)))..
7680: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 61 72 63 (define (rmt:arc
7690: 68 69 76 65 2d 72 65 67 69 73 74 65 72 2d 62 6c hive-register-bl
76a0: 6f 63 6b 2d 6e 61 6d 65 20 62 64 69 73 6b 2d 69 ock-name bdisk-i
76b0: 64 20 61 72 63 68 69 76 65 2d 70 61 74 68 29 0a d archive-path).
76c0: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
76d0: 69 76 65 20 27 61 72 63 68 69 76 65 2d 72 65 67 ive 'archive-reg
76e0: 69 73 74 65 72 2d 62 6c 6f 63 6b 2d 6e 61 6d 65 ister-block-name
76f0: 20 23 66 20 28 6c 69 73 74 20 62 64 69 73 6b 2d #f (list bdisk-
7700: 69 64 20 61 72 63 68 69 76 65 2d 70 61 74 68 29 id archive-path)
7710: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
7720: 3a 61 72 63 68 69 76 65 2d 61 6c 6c 6f 63 61 74 :archive-allocat
7730: 65 2d 74 65 73 74 73 75 69 74 65 2f 61 72 65 61 e-testsuite/area
7740: 2d 74 6f 2d 62 6c 6f 63 6b 20 62 6c 6f 63 6b 2d -to-block block-
7750: 69 64 20 74 65 73 74 73 75 69 74 65 2d 6e 61 6d id testsuite-nam
7760: 65 20 61 72 65 61 6b 65 79 29 0a 20 20 28 72 6d e areakey). (rm
7770: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
7780: 61 72 63 68 69 76 65 2d 61 6c 6c 6f 63 61 74 65 archive-allocate
7790: 2d 74 65 73 74 2d 74 6f 2d 62 6c 6f 63 6b 20 23 -test-to-block #
77a0: 66 20 28 6c 69 73 74 20 20 62 6c 6f 63 6b 2d 69 f (list block-i
77b0: 64 20 74 65 73 74 73 75 69 74 65 2d 6e 61 6d 65 d testsuite-name
77c0: 20 61 72 65 61 6b 65 79 29 29 29 0a 0a 28 64 65 areakey)))..(de
77d0: 66 69 6e 65 20 28 72 6d 74 3a 61 72 63 68 69 76 fine (rmt:archiv
77e0: 65 2d 72 65 67 69 73 74 65 72 2d 64 69 73 6b 20 e-register-disk
77f0: 62 64 69 73 6b 2d 6e 61 6d 65 20 62 64 69 73 6b bdisk-name bdisk
7800: 2d 70 61 74 68 20 64 66 29 0a 20 20 28 72 6d 74 -path df). (rmt
7810: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 61 :send-receive 'a
7820: 72 63 68 69 76 65 2d 72 65 67 69 73 74 65 72 2d rchive-register-
7830: 64 69 73 6b 20 23 66 20 28 6c 69 73 74 20 62 64 disk #f (list bd
7840: 69 73 6b 2d 6e 61 6d 65 20 62 64 69 73 6b 2d 70 isk-name bdisk-p
7850: 61 74 68 20 64 66 29 29 29 0a 0a 28 64 65 66 69 ath df)))..(defi
7860: 6e 65 20 28 72 6d 74 3a 74 65 73 74 2d 73 65 74 ne (rmt:test-set
7870: 2d 61 72 63 68 69 76 65 2d 62 6c 6f 63 6b 2d 69 -archive-block-i
7880: 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 d run-id test-id
7890: 20 61 72 63 68 69 76 65 2d 62 6c 6f 63 6b 2d 69 archive-block-i
78a0: 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 d). (rmt:send-r
78b0: 65 63 65 69 76 65 20 27 74 65 73 74 2d 73 65 74 eceive 'test-set
78c0: 2d 61 72 63 68 69 76 65 2d 62 6c 6f 63 6b 2d 69 -archive-block-i
78d0: 64 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 d run-id (list r
78e0: 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 61 72 un-id test-id ar
78f0: 63 68 69 76 65 2d 62 6c 6f 63 6b 2d 69 64 29 29 chive-block-id))
7900: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a )..(define (rmt:
7910: 74 65 73 74 2d 67 65 74 2d 61 72 63 68 69 76 65 test-get-archive
7920: 2d 62 6c 6f 63 6b 2d 69 6e 66 6f 20 61 72 63 68 -block-info arch
7930: 69 76 65 2d 62 6c 6f 63 6b 2d 69 64 29 0a 20 20 ive-block-id).
7940: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
7950: 65 20 27 74 65 73 74 2d 67 65 74 2d 61 72 63 68 e 'test-get-arch
7960: 69 76 65 2d 62 6c 6f 63 6b 2d 69 6e 66 6f 20 23 ive-block-info #
7970: 66 20 28 6c 69 73 74 20 61 72 63 68 69 76 65 2d f (list archive-
7980: 62 6c 6f 63 6b 2d 69 64 29 29 29 0a block-id))).