Artifact
6df9c72b71e76e703ba6610361ab9880f353be9d:
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 61 0a 3b megatestrc.;;a.;
02e0: 3b 20 28 72 65 71 75 69 72 65 2d 6c 69 62 72 61 ; (require-libra
02f0: 72 79 20 74 72 61 63 65 29 0a 3b 3b 20 28 69 6d ry trace).;; (im
0300: 70 6f 72 74 20 74 72 61 63 65 29 0a 3b 3b 20 28 port trace).;; (
0310: 74 72 61 63 65 0a 3b 3b 20 72 6d 74 3a 73 65 6e trace.;; rmt:sen
0320: 64 2d 72 65 63 65 69 76 65 0a 3b 3b 20 61 70 69 d-receive.;; api
0330: 3a 65 78 65 63 75 74 65 2d 72 65 71 75 65 73 74 :execute-request
0340: 73 0a 3b 3b 20 29 0a 0a 3b 3b 20 67 65 6e 65 72 s.;; )..;; gener
0350: 61 74 65 20 65 6e 74 72 69 65 73 20 66 6f 72 20 ate entries for
0360: 7e 2f 2e 6d 65 67 61 74 65 73 74 72 63 20 77 69 ~/.megatestrc wi
0370: 74 68 20 74 68 65 20 66 6f 6c 6c 6f 77 69 6e 67 th the following
0380: 0a 3b 3b 0a 3b 3b 20 20 67 72 65 70 20 64 65 66 .;;.;; grep def
0390: 69 6e 65 20 2e 2e 2f 72 6d 74 2e 73 63 6d 20 7c ine ../rmt.scm |
03a0: 20 67 72 65 70 20 72 6d 74 3a 20 7c 70 65 72 6c grep rmt: |perl
03b0: 20 2d 70 69 20 2d 65 20 27 73 2f 5c 28 64 65 66 -pi -e 's/\(def
03c0: 69 6e 65 5c 73 2b 5c 28 28 5c 53 2b 29 5c 57 2e ine\s+\((\S+)\W.
03d0: 2a 24 2f 5c 31 2f 27 7c 73 6f 72 74 20 2d 75 0a *$/\1/'|sort -u.
03e0: 0a 0a 3b 3b 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 3d 0a 3b 3b 20 20 53 ==========.;; S
0430: 20 55 20 50 20 50 20 4f 20 52 20 54 20 20 20 46 U P P O R T F
0440: 20 55 20 4e 20 43 20 54 20 49 20 4f 20 4e 20 53 U N C T I O N S
0450: 0a 3b 3b 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 3d 0a 0a 3b 3b 20 4e 4f =========..;; NO
04a0: 54 20 55 53 45 44 3f 0a 3b 3b 0a 3b 3b 20 28 64 T USED?.;;.;; (d
04b0: 65 66 69 6e 65 20 28 72 6d 74 3a 63 61 6c 6c 2d efine (rmt:call-
04c0: 74 72 61 6e 73 70 6f 72 74 20 72 75 6e 2d 69 64 transport run-id
04d0: 20 63 6f 6e 6e 65 63 74 69 6f 6e 2d 69 6e 66 6f connection-info
04e0: 20 63 6d 64 20 6a 70 61 72 61 6d 73 29 0a 3b 3b cmd jparams).;;
04f0: 20 20 20 28 63 61 73 65 20 28 73 65 72 76 65 72 (case (server
0500: 3a 67 65 74 2d 74 72 61 6e 73 70 6f 72 74 29 0a :get-transport).
0510: 3b 3b 20 20 20 20 20 28 28 72 70 63 29 20 20 28 ;; ((rpc) (
0520: 20 72 70 63 2d 74 72 61 6e 73 70 6f 72 74 3a 63 rpc-transport:c
0530: 6c 69 65 6e 74 2d 61 70 69 2d 73 65 6e 64 2d 72 lient-api-send-r
0540: 65 63 65 69 76 65 20 72 75 6e 2d 69 64 20 63 6f eceive run-id co
0550: 6e 6e 65 63 74 69 6f 6e 2d 69 6e 66 6f 20 63 6d nnection-info cm
0560: 64 20 6a 70 61 72 61 6d 73 29 29 0a 3b 3b 20 20 d jparams)).;;
0570: 20 20 20 28 28 68 74 74 70 29 20 28 68 74 74 70 ((http) (http
0580: 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 65 6e -transport:clien
0590: 74 2d 61 70 69 2d 73 65 6e 64 2d 72 65 63 65 69 t-api-send-recei
05a0: 76 65 20 72 75 6e 2d 69 64 20 63 6f 6e 6e 65 63 ve run-id connec
05b0: 74 69 6f 6e 2d 69 6e 66 6f 20 63 6d 64 20 6a 70 tion-info cmd jp
05c0: 61 72 61 6d 73 29 29 0a 3b 3b 20 20 20 20 20 28 arams)).;; (
05d0: 28 66 73 29 20 20 20 28 20 66 73 2d 74 72 61 6e (fs) ( fs-tran
05e0: 73 70 6f 72 74 3a 63 6c 69 65 6e 74 2d 61 70 69 sport:client-api
05f0: 2d 73 65 6e 64 2d 72 65 63 65 69 76 65 20 72 75 -send-receive ru
0600: 6e 2d 69 64 20 63 6f 6e 6e 65 63 74 69 6f 6e 2d n-id connection-
0610: 69 6e 66 6f 20 63 6d 64 20 6a 70 61 72 61 6d 73 info cmd jparams
0620: 29 29 0a 3b 3b 20 20 20 20 20 28 28 7a 6d 71 29 )).;; ((zmq)
0630: 20 20 28 7a 6d 71 2d 74 72 61 6e 73 70 6f 72 74 (zmq-transport
0640: 3a 63 6c 69 65 6e 74 2d 61 70 69 2d 73 65 6e 64 :client-api-send
0650: 2d 72 65 63 65 69 76 65 20 72 75 6e 2d 69 64 20 -receive run-id
0660: 63 6f 6e 6e 65 63 74 69 6f 6e 2d 69 6e 66 6f 20 connection-info
0670: 63 6d 64 20 6a 70 61 72 61 6d 73 29 29 0a 3b 3b cmd jparams)).;;
0680: 20 20 20 20 20 28 65 6c 73 65 20 20 20 28 20 72 (else ( r
0690: 70 63 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 pc-transport:cli
06a0: 65 6e 74 2d 61 70 69 2d 73 65 6e 64 2d 72 65 63 ent-api-send-rec
06b0: 65 69 76 65 20 72 75 6e 2d 69 64 20 63 6f 6e 6e eive run-id conn
06c0: 65 63 74 69 6f 6e 2d 69 6e 66 6f 20 63 6d 64 20 ection-info cmd
06d0: 6a 70 61 72 61 6d 73 29 29 29 29 0a 0a 3b 3b 0a jparams))))..;;.
06e0: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 77 72 69 (define (rmt:wri
06f0: 74 65 2d 66 72 65 71 75 65 6e 63 79 2d 6f 76 65 te-frequency-ove
0700: 72 2d 6c 69 6d 69 74 3f 20 63 6d 64 20 72 75 6e r-limit? cmd run
0710: 2d 69 64 29 0a 20 20 28 61 6e 64 20 28 6e 6f 74 -id). (and (not
0720: 20 28 6d 65 6d 62 65 72 20 63 6d 64 20 61 70 69 (member cmd api
0730: 3a 72 65 61 64 2d 6f 6e 6c 79 2d 71 75 65 72 69 :read-only-queri
0740: 65 73 29 29 0a 20 20 20 20 20 20 20 28 6c 65 74 es)). (let
0750: 2a 20 28 28 74 6d 70 72 65 63 20 28 68 61 73 68 * ((tmprec (hash
0760: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
0770: 6c 74 20 2a 77 72 69 74 65 2d 66 72 65 71 75 65 lt *write-freque
0780: 6e 63 79 2a 20 72 75 6e 2d 69 64 20 23 66 29 29 ncy* run-id #f))
0790: 0a 09 20 20 20 20 20 20 28 72 65 63 6f 72 64 20 .. (record
07a0: 28 69 66 20 74 6d 70 72 65 63 20 74 6d 70 72 65 (if tmprec tmpre
07b0: 63 20 0a 09 09 09 20 20 28 6c 65 74 20 28 28 76 c .... (let ((v
07c0: 20 28 76 65 63 74 6f 72 20 28 63 75 72 72 65 6e (vector (curren
07d0: 74 2d 73 65 63 6f 6e 64 73 29 20 30 29 29 29 0a t-seconds) 0))).
07e0: 09 09 09 20 20 20 20 28 68 61 73 68 2d 74 61 62 ... (hash-tab
07f0: 6c 65 2d 73 65 74 21 20 2a 77 72 69 74 65 2d 66 le-set! *write-f
0800: 72 65 71 75 65 6e 63 79 2a 20 72 75 6e 2d 69 64 requency* run-id
0810: 20 76 29 0a 09 09 09 20 20 20 20 76 29 29 29 0a v).... v))).
0820: 09 20 20 20 20 20 20 28 63 6f 75 6e 74 20 20 28 . (count (
0830: 2b 20 31 20 28 76 65 63 74 6f 72 2d 72 65 66 20 + 1 (vector-ref
0840: 72 65 63 6f 72 64 20 31 29 29 29 0a 09 20 20 20 record 1)))..
0850: 20 20 20 28 73 74 61 72 74 20 20 28 76 65 63 74 (start (vect
0860: 6f 72 2d 72 65 66 20 72 65 63 6f 72 64 20 30 29 or-ref record 0)
0870: 29 0a 09 20 20 20 20 20 20 28 71 75 65 72 69 65 ).. (querie
0880: 73 2d 70 65 72 2d 73 65 63 6f 6e 64 20 28 2f 20 s-per-second (/
0890: 28 2a 20 63 6f 75 6e 74 20 31 2e 30 29 0a 09 09 (* count 1.0)...
08a0: 09 09 20 20 20 20 20 28 6d 61 78 20 28 2d 20 28 .. (max (- (
08b0: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
08c0: 20 73 74 61 72 74 29 20 31 29 29 29 29 0a 09 20 start) 1))))..
08d0: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 72 65 63 (vector-set! rec
08e0: 6f 72 64 20 31 20 63 6f 75 6e 74 29 0a 09 20 28 ord 1 count).. (
08f0: 69 66 20 28 61 6e 64 20 28 3e 20 63 6f 75 6e 74 if (and (> count
0900: 20 31 30 29 0a 09 09 20 20 28 3e 20 71 75 65 72 10)... (> quer
0910: 69 65 73 2d 70 65 72 2d 73 65 63 6f 6e 64 20 31 ies-per-second 1
0920: 30 29 29 0a 09 20 20 20 20 20 28 62 65 67 69 6e 0)).. (begin
0930: 0a 09 20 20 20 20 20 20 20 28 64 65 62 75 67 3a .. (debug:
0940: 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 22 64 62 print-info 1 "db
0950: 20 77 72 69 74 65 20 72 61 74 65 20 74 6f 6f 20 write rate too
0960: 68 69 67 68 2c 20 73 74 61 72 74 69 6e 67 20 61 high, starting a
0970: 20 73 65 72 76 65 72 2c 20 63 6f 75 6e 74 3d 22 server, count="
0980: 20 63 6f 75 6e 74 20 22 20 73 74 61 72 74 3d 22 count " start="
0990: 20 73 74 61 72 74 20 22 20 72 75 6e 2d 69 64 3d start " run-id=
09a0: 22 20 72 75 6e 2d 69 64 20 22 20 71 75 65 72 69 " run-id " queri
09b0: 65 73 2d 70 65 72 2d 73 65 63 6f 6e 64 3d 22 20 es-per-second="
09c0: 71 75 65 72 69 65 73 2d 70 65 72 2d 73 65 63 6f queries-per-seco
09d0: 6e 64 29 0a 09 20 20 20 20 20 20 20 23 74 29 0a nd).. #t).
09e0: 09 20 20 20 20 20 23 66 29 29 29 29 0a 0a 3b 3b . #f))))..;;
09f0: 20 69 66 20 61 20 73 65 72 76 65 72 20 69 73 20 if a server is
0a00: 65 69 74 68 65 72 20 72 75 6e 6e 69 6e 67 20 6f either running o
0a10: 72 20 69 6e 20 74 68 65 20 70 72 6f 63 65 73 73 r in the process
0a20: 20 6f 66 20 73 74 61 72 74 69 6e 67 20 63 61 6c of starting cal
0a30: 6c 20 63 6c 69 65 6e 74 3a 73 65 74 75 70 0a 3b l client:setup.;
0a40: 3b 20 65 6c 73 65 20 72 65 74 75 72 6e 20 23 66 ; else return #f
0a50: 20 74 6f 20 6c 65 74 20 74 68 65 20 63 61 6c 6c to let the call
0a60: 69 6e 67 20 70 72 6f 63 20 6b 6e 6f 77 20 74 68 ing proc know th
0a70: 61 74 20 74 68 65 72 65 20 69 73 20 6e 6f 20 73 at there is no s
0a80: 65 72 76 65 72 20 61 76 61 69 6c 61 62 6c 65 0a erver available.
0a90: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a ;;.(define (rmt:
0aa0: 67 65 74 2d 63 6f 6e 6e 65 63 74 69 6f 6e 2d 69 get-connection-i
0ab0: 6e 66 6f 20 72 75 6e 2d 69 64 20 61 72 65 61 2d nfo run-id area-
0ac0: 64 61 74 20 23 21 6b 65 79 20 28 72 65 6d 6f 74 dat #!key (remot
0ad0: 65 20 23 66 29 29 0a 20 20 28 6c 65 74 20 28 28 e #f)). (let ((
0ae0: 63 69 6e 66 6f 20 28 63 6f 6d 6d 6f 6e 3a 67 65 cinfo (common:ge
0af0: 74 2d 72 65 6d 6f 74 65 20 72 65 6d 6f 74 65 20 t-remote remote
0b00: 72 75 6e 2d 69 64 29 29 29 0a 20 20 20 20 28 69 run-id))). (i
0b10: 66 20 63 69 6e 66 6f 0a 09 63 69 6e 66 6f 0a 09 f cinfo..cinfo..
0b20: 3b 3b 20 4e 42 2f 2f 20 63 61 6e 20 63 61 63 68 ;; NB// can cach
0b30: 65 20 74 68 65 20 61 6e 73 77 65 72 20 66 6f 72 e the answer for
0b40: 20 73 65 72 76 65 72 20 72 75 6e 6e 69 6e 67 20 server running
0b50: 66 6f 72 20 31 30 20 73 65 63 6f 6e 64 73 20 2e for 10 seconds .
0b60: 2e 2e 0a 09 3b 3b 20 20 3b 3b 20 28 61 6e 64 20 ....;; ;; (and
0b70: 28 6e 6f 74 20 28 72 6d 74 3a 77 72 69 74 65 2d (not (rmt:write-
0b80: 66 72 65 71 75 65 6e 63 79 2d 6f 76 65 72 2d 6c frequency-over-l
0b90: 69 6d 69 74 3f 20 63 6d 64 20 72 75 6e 2d 69 64 imit? cmd run-id
0ba0: 29 29 0a 09 28 69 66 20 28 74 61 73 6b 73 3a 73 ))..(if (tasks:s
0bb0: 65 72 76 65 72 2d 72 75 6e 6e 69 6e 67 2d 6f 72 erver-running-or
0bc0: 2d 73 74 61 72 74 69 6e 67 3f 20 28 64 62 3a 64 -starting? (db:d
0bd0: 65 6c 61 79 2d 69 66 2d 62 75 73 79 20 28 74 61 elay-if-busy (ta
0be0: 73 6b 73 3a 6f 70 65 6e 2d 64 62 20 61 72 65 61 sks:open-db area
0bf0: 2d 64 61 74 29 20 61 72 65 61 2d 64 61 74 29 20 -dat) area-dat)
0c00: 72 75 6e 2d 69 64 29 0a 09 20 20 20 20 28 63 6c run-id).. (cl
0c10: 69 65 6e 74 3a 73 65 74 75 70 20 72 75 6e 2d 69 ient:setup run-i
0c20: 64 20 61 72 65 61 2d 64 61 74 20 72 65 6d 6f 74 d area-dat remot
0c30: 65 3a 20 72 65 6d 6f 74 65 29 0a 09 20 20 20 20 e: remote)..
0c40: 23 66 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 #f))))..(define
0c50: 28 72 6d 74 3a 64 69 73 63 61 72 64 2d 6f 6c 64 (rmt:discard-old
0c60: 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 20 61 72 65 -connections are
0c70: 61 2d 64 61 74 29 0a 20 20 3b 3b 20 63 6c 65 61 a-dat). ;; clea
0c80: 6e 20 6f 75 74 20 6f 6c 64 20 63 6f 6e 6e 65 63 n out old connec
0c90: 74 69 6f 6e 73 0a 20 20 28 6d 75 74 65 78 2d 6c tions. (mutex-l
0ca0: 6f 63 6b 21 20 2a 64 62 2d 6d 75 6c 74 69 2d 73 ock! *db-multi-s
0cb0: 79 6e 63 2d 6d 75 74 65 78 2a 29 0a 20 20 28 6c ync-mutex*). (l
0cc0: 65 74 20 28 28 72 65 6d 6f 74 65 20 20 20 20 20 et ((remote
0cd0: 20 28 6d 65 67 61 74 65 73 74 3a 61 72 65 61 2d (megatest:area-
0ce0: 72 65 6d 6f 74 65 20 61 72 65 61 2d 64 61 74 29 remote area-dat)
0cf0: 29 0a 09 28 65 78 70 69 72 65 2d 74 69 6d 65 20 )..(expire-time
0d00: 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f (- (current-seco
0d10: 6e 64 73 29 20 28 73 65 72 76 65 72 3a 67 65 74 nds) (server:get
0d20: 2d 74 69 6d 65 6f 75 74 20 61 72 65 61 2d 64 61 -timeout area-da
0d30: 74 29 20 31 30 29 29 29 20 3b 3b 20 64 6f 6e 27 t) 10))) ;; don'
0d40: 74 20 66 6f 72 67 65 74 20 74 68 65 20 31 30 20 t forget the 10
0d50: 73 65 63 6f 6e 64 20 6d 61 72 67 69 6e 0a 20 20 second margin.
0d60: 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 (for-each .
0d70: 20 20 28 6c 61 6d 62 64 61 20 28 72 75 6e 2d 69 (lambda (run-i
0d80: 64 29 0a 20 20 20 20 20 20 20 28 6c 65 74 20 28 d). (let (
0d90: 28 63 6f 6e 6e 65 63 74 69 6f 6e 20 28 63 6f 6d (connection (com
0da0: 6d 6f 6e 3a 67 65 74 2d 72 65 6d 6f 74 65 20 72 mon:get-remote r
0db0: 65 6d 6f 74 65 20 72 75 6e 2d 69 64 29 29 29 0a emote run-id))).
0dc0: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 61 6e (if (an
0dd0: 64 20 28 76 65 63 74 6f 72 3f 20 63 6f 6e 6e 65 d (vector? conne
0de0: 63 74 69 6f 6e 29 0a 20 20 20 20 20 20 20 20 09 ction). .
0df0: 20 20 28 3c 20 28 68 74 74 70 2d 74 72 61 6e 73 (< (http-trans
0e00: 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 74 2d port:server-dat-
0e10: 67 65 74 2d 6c 61 73 74 2d 61 63 63 65 73 73 20 get-last-access
0e20: 63 6f 6e 6e 65 63 74 69 6f 6e 29 20 65 78 70 69 connection) expi
0e30: 72 65 2d 74 69 6d 65 29 29 0a 20 20 20 20 20 20 re-time)).
0e40: 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 (begin.
0e50: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 65 (de
0e60: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
0e70: 20 22 44 69 73 63 61 72 64 69 6e 67 20 63 6f 6e "Discarding con
0e80: 6e 65 63 74 69 6f 6e 20 74 6f 20 73 65 72 76 65 nection to serve
0e90: 72 20 66 6f 72 20 72 75 6e 2d 69 64 20 22 20 72 r for run-id " r
0ea0: 75 6e 2d 69 64 20 22 2c 20 74 6f 6f 20 6c 6f 6e un-id ", too lon
0eb0: 67 20 62 65 74 77 65 65 6e 20 61 63 63 65 73 73 g between access
0ec0: 65 73 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 es").
0ed0: 20 20 20 20 3b 3b 20 53 48 4f 55 4c 44 20 43 4c ;; SHOULD CL
0ee0: 4f 53 45 20 54 48 45 20 43 4f 4e 4e 45 43 54 49 OSE THE CONNECTI
0ef0: 4f 4e 20 48 45 52 45 0a 09 20 20 20 20 20 20 20 ON HERE..
0f00: 28 63 61 73 65 20 28 6d 65 67 61 74 65 73 74 3a (case (megatest:
0f10: 61 72 65 61 2d 74 72 61 6e 73 70 6f 72 74 20 61 area-transport a
0f20: 72 65 61 2d 64 61 74 29 0a 09 09 20 28 28 6e 6d rea-dat)... ((nm
0f30: 73 67 29 28 6e 6e 2d 63 6c 6f 73 65 20 28 68 74 sg)(nn-close (ht
0f40: 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 tp-transport:ser
0f50: 76 65 72 2d 64 61 74 2d 67 65 74 2d 73 6f 63 6b ver-dat-get-sock
0f60: 65 74 20 0a 09 09 09 09 20 20 20 28 63 6f 6d 6d et ..... (comm
0f70: 6f 6e 3a 67 65 74 2d 72 65 6d 6f 74 65 20 72 65 on:get-remote re
0f80: 6d 6f 74 65 20 72 75 6e 2d 69 64 29 29 29 29 29 mote run-id)))))
0f90: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
0fa0: 28 63 6f 6d 6d 6f 6e 3a 64 65 6c 2d 72 65 6d 6f (common:del-remo
0fb0: 74 65 21 20 72 65 6d 6f 74 65 20 72 75 6e 2d 69 te! remote run-i
0fc0: 64 29 29 29 29 29 0a 20 20 20 20 20 28 63 6f 6d d))))). (com
0fd0: 6d 6f 6e 3a 67 65 74 2d 72 65 6d 6f 74 65 2d 61 mon:get-remote-a
0fe0: 6c 6c 20 72 65 6d 6f 74 65 29 29 29 0a 20 20 28 ll remote))). (
0ff0: 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 64 mutex-unlock! *d
1000: 62 2d 6d 75 6c 74 69 2d 73 79 6e 63 2d 6d 75 74 b-multi-sync-mut
1010: 65 78 2a 29 29 0a 0a 28 64 65 66 69 6e 65 20 2a ex*))..(define *
1020: 73 65 6e 64 2d 72 65 63 65 69 76 65 2d 6d 75 74 send-receive-mut
1030: 65 78 2a 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 ex* (make-mutex)
1040: 29 20 3b 3b 20 73 68 6f 75 6c 64 20 68 61 76 65 ) ;; should have
1050: 20 73 65 70 61 72 61 74 65 20 6d 75 74 65 78 20 separate mutex
1060: 70 65 72 20 72 75 6e 2d 69 64 0a 0a 28 64 65 66 per run-id..(def
1070: 69 6e 65 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ine (rmt:send-re
1080: 63 65 69 76 65 20 63 6d 64 20 72 69 64 20 70 61 ceive cmd rid pa
1090: 72 61 6d 73 20 61 72 65 61 2d 64 61 74 20 23 21 rams area-dat #!
10a0: 6b 65 79 20 28 61 74 74 65 6d 70 74 6e 75 6d 20 key (attemptnum
10b0: 31 29 28 72 65 6d 6f 74 65 20 23 66 29 29 20 3b 1)(remote #f)) ;
10c0: 3b 20 73 74 61 72 74 20 61 74 74 65 6d 70 74 6e ; start attemptn
10d0: 75 6d 20 61 74 20 31 20 73 6f 20 74 68 65 20 6d um at 1 so the m
10e0: 6f 64 75 6c 6f 20 62 65 6c 6f 77 20 77 6f 72 6b odulo below work
10f0: 73 20 61 73 20 65 78 70 65 63 74 65 64 0a 20 20 s as expected.
1100: 28 72 6d 74 3a 64 69 73 63 61 72 64 2d 6f 6c 64 (rmt:discard-old
1110: 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 20 61 72 65 -connections are
1120: 61 2d 64 61 74 29 0a 20 20 3b 3b 20 28 6d 75 74 a-dat). ;; (mut
1130: 65 78 2d 6c 6f 63 6b 21 20 2a 73 65 6e 64 2d 72 ex-lock! *send-r
1140: 65 63 65 69 76 65 2d 6d 75 74 65 78 2a 29 0a 20 eceive-mutex*).
1150: 20 28 6c 65 74 2a 20 28 28 74 72 61 6e 73 70 6f (let* ((transpo
1160: 72 74 2d 74 79 70 65 20 20 28 6d 65 67 61 74 65 rt-type (megate
1170: 73 74 3a 61 72 65 61 2d 74 72 61 6e 73 70 6f 72 st:area-transpor
1180: 74 20 61 72 65 61 2d 64 61 74 29 29 0a 09 20 28 t area-dat)).. (
1190: 72 75 6e 2d 69 64 20 20 20 20 20 20 20 20 20 20 run-id
11a0: 28 69 66 20 72 69 64 20 72 69 64 20 30 29 29 0a (if rid rid 0)).
11b0: 09 20 28 63 6f 6e 66 69 67 64 61 74 20 20 20 20 . (configdat
11c0: 20 20 20 28 6d 65 67 61 74 65 73 74 3a 61 72 65 (megatest:are
11d0: 61 2d 63 6f 6e 66 69 67 64 61 74 20 61 72 65 61 a-configdat area
11e0: 2d 64 61 74 29 29 0a 09 20 28 63 6f 6e 6e 65 63 -dat)).. (connec
11f0: 74 69 6f 6e 2d 69 6e 66 6f 20 28 72 6d 74 3a 67 tion-info (rmt:g
1200: 65 74 2d 63 6f 6e 6e 65 63 74 69 6f 6e 2d 69 6e et-connection-in
1210: 66 6f 20 72 75 6e 2d 69 64 20 61 72 65 61 2d 64 fo run-id area-d
1220: 61 74 29 29 29 0a 20 20 20 20 3b 3b 20 74 68 65 at))). ;; the
1230: 20 6e 6d 73 67 20 6d 65 74 68 6f 64 20 64 6f 65 nmsg method doe
1240: 73 20 74 68 65 20 65 6e 63 6f 64 69 6e 67 20 75 s the encoding u
1250: 6e 64 65 72 20 74 68 65 20 68 6f 6f 64 20 28 74 nder the hood (t
1260: 68 65 20 68 74 74 70 20 6d 65 74 68 6f 64 20 73 he http method s
1270: 68 6f 75 6c 64 20 62 65 20 63 68 61 6e 67 65 64 hould be changed
1280: 20 74 6f 20 64 6f 20 74 68 69 73 20 61 6c 73 6f to do this also
1290: 29 0a 20 20 20 20 28 69 66 20 63 6f 6e 6e 65 63 ). (if connec
12a0: 74 69 6f 6e 2d 69 6e 66 6f 0a 09 3b 3b 20 75 73 tion-info..;; us
12b0: 65 20 74 68 65 20 73 65 72 76 65 72 20 69 66 20 e the server if
12c0: 68 61 76 65 20 63 6f 6e 6e 65 63 74 69 6f 6e 20 have connection
12d0: 69 6e 66 6f 0a 09 28 6c 65 74 2a 20 28 28 64 61 info..(let* ((da
12e0: 74 20 20 20 20 20 28 63 61 73 65 20 74 72 61 6e t (case tran
12f0: 73 70 6f 72 74 2d 74 79 70 65 0a 09 09 09 20 20 sport-type....
1300: 28 28 68 74 74 70 29 28 63 6f 6e 64 69 74 69 6f ((http)(conditio
1310: 6e 2d 63 61 73 65 0a 09 09 09 09 20 20 28 68 74 n-case..... (ht
1320: 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 tp-transport:cli
1330: 65 6e 74 2d 61 70 69 2d 73 65 6e 64 2d 72 65 63 ent-api-send-rec
1340: 65 69 76 65 20 72 75 6e 2d 69 64 20 63 6f 6e 6e eive run-id conn
1350: 65 63 74 69 6f 6e 2d 69 6e 66 6f 20 63 6d 64 20 ection-info cmd
1360: 70 61 72 61 6d 73 29 0a 09 09 09 09 20 20 28 28 params)..... ((
1370: 63 6f 6d 6d 66 61 69 6c 29 28 76 65 63 74 6f 72 commfail)(vector
1380: 20 23 66 20 22 63 6f 6d 6d 75 6e 69 63 61 74 69 #f "communicati
1390: 6f 6e 73 20 66 61 69 6c 22 29 29 0a 09 09 09 09 ons fail")).....
13a0: 20 20 28 28 65 78 6e 29 28 76 65 63 74 6f 72 20 ((exn)(vector
13b0: 23 66 20 22 6f 74 68 65 72 20 66 61 69 6c 22 29 #f "other fail")
13c0: 29 29 29 0a 09 09 09 20 20 28 28 6e 6d 73 67 29 ))).... ((nmsg)
13d0: 28 63 6f 6e 64 69 74 69 6f 6e 2d 63 61 73 65 0a (condition-case.
13e0: 09 09 09 09 20 20 28 6e 6d 73 67 2d 74 72 61 6e .... (nmsg-tran
13f0: 73 70 6f 72 74 3a 63 6c 69 65 6e 74 2d 61 70 69 sport:client-api
1400: 2d 73 65 6e 64 2d 72 65 63 65 69 76 65 20 72 75 -send-receive ru
1410: 6e 2d 69 64 20 63 6f 6e 6e 65 63 74 69 6f 6e 2d n-id connection-
1420: 69 6e 66 6f 20 63 6d 64 20 70 61 72 61 6d 73 29 info cmd params)
1430: 0a 09 09 09 09 20 20 28 28 74 69 6d 65 6f 75 74 ..... ((timeout
1440: 29 28 76 65 63 74 6f 72 20 23 66 20 22 74 69 6d )(vector #f "tim
1450: 65 6f 75 74 20 74 61 6c 6b 69 6e 67 20 74 6f 20 eout talking to
1460: 73 65 72 76 65 72 22 29 29 29 29 0a 09 09 09 20 server"))))....
1470: 20 28 65 6c 73 65 20 20 28 65 78 69 74 29 29 29 (else (exit)))
1480: 29 0a 09 20 20 20 20 20 20 20 28 73 75 63 63 65 ).. (succe
1490: 73 73 20 28 69 66 20 28 76 65 63 74 6f 72 3f 20 ss (if (vector?
14a0: 64 61 74 29 20 28 76 65 63 74 6f 72 2d 72 65 66 dat) (vector-ref
14b0: 20 64 61 74 20 30 29 20 23 66 29 29 0a 09 20 20 dat 0) #f))..
14c0: 20 20 20 20 20 28 72 65 73 20 20 20 20 20 28 69 (res (i
14d0: 66 20 28 76 65 63 74 6f 72 3f 20 64 61 74 29 20 f (vector? dat)
14e0: 28 76 65 63 74 6f 72 2d 72 65 66 20 64 61 74 20 (vector-ref dat
14f0: 31 29 20 23 66 29 29 29 0a 09 20 20 28 69 66 20 1) #f))).. (if
1500: 28 76 65 63 74 6f 72 3f 20 63 6f 6e 6e 65 63 74 (vector? connect
1510: 69 6f 6e 2d 69 6e 66 6f 29 28 68 74 74 70 2d 74 ion-info)(http-t
1520: 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 2d ransport:server-
1530: 64 61 74 2d 75 70 64 61 74 65 2d 6c 61 73 74 2d dat-update-last-
1540: 61 63 63 65 73 73 20 63 6f 6e 6e 65 63 74 69 6f access connectio
1550: 6e 2d 69 6e 66 6f 29 29 0a 09 20 20 28 69 66 20 n-info)).. (if
1560: 73 75 63 63 65 73 73 0a 09 20 20 20 20 20 20 28 success.. (
1570: 62 65 67 69 6e 0a 09 09 3b 3b 20 28 6d 75 74 65 begin...;; (mute
1580: 78 2d 75 6e 6c 6f 63 6b 21 20 2a 73 65 6e 64 2d x-unlock! *send-
1590: 72 65 63 65 69 76 65 2d 6d 75 74 65 78 2a 29 0a receive-mutex*).
15a0: 09 09 28 63 61 73 65 20 0a 09 09 20 20 28 28 68 ..(case ... ((h
15b0: 74 74 70 29 20 72 65 73 29 20 3b 3b 20 28 64 62 ttp) res) ;; (db
15c0: 3a 73 74 72 69 6e 67 2d 3e 6f 62 6a 20 72 65 73 :string->obj res
15d0: 29 29 0a 09 09 20 20 28 28 6e 6d 73 67 29 20 72 ))... ((nmsg) r
15e0: 65 73 29 29 29 20 3b 3b 20 28 76 65 63 74 6f 72 es))) ;; (vector
15f0: 2d 72 65 66 20 72 65 73 20 31 29 29 29 0a 09 20 -ref res 1)))..
1600: 20 20 20 20 20 28 62 65 67 69 6e 20 3b 3b 20 6c (begin ;; l
1610: 65 74 20 28 28 6e 65 77 2d 63 6f 6e 6e 65 63 74 et ((new-connect
1620: 69 6f 6e 2d 69 6e 66 6f 20 28 63 6c 69 65 6e 74 ion-info (client
1630: 3a 73 65 74 75 70 20 72 75 6e 2d 69 64 29 29 29 :setup run-id)))
1640: 0a 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 ...(debug:print
1650: 30 20 22 57 41 52 4e 49 4e 47 3a 20 43 6f 6d 6d 0 "WARNING: Comm
1660: 75 6e 69 63 61 74 69 6f 6e 20 66 61 69 6c 65 64 unication failed
1670: 2c 20 74 72 79 69 6e 67 20 63 61 6c 6c 20 74 6f , trying call to
1680: 20 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 rmt:send-receiv
1690: 65 20 61 67 61 69 6e 2e 22 29 0a 09 09 3b 3b 20 e again.")...;;
16a0: 28 63 61 73 65 20 2a 74 72 61 6e 73 70 6f 72 74 (case *transport
16b0: 2d 74 79 70 65 2a 0a 09 09 3b 3b 20 20 20 28 28 -type*...;; ((
16c0: 6e 6d 73 67 29 28 6e 6e 2d 63 6c 6f 73 65 20 28 nmsg)(nn-close (
16d0: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 http-transport:s
16e0: 65 72 76 65 72 2d 64 61 74 2d 67 65 74 2d 73 6f erver-dat-get-so
16f0: 63 6b 65 74 20 63 6f 6e 6e 65 63 74 69 6f 6e 2d cket connection-
1700: 69 6e 66 6f 29 29 29 29 0a 09 09 28 63 6f 6d 6d info))))...(comm
1710: 6f 6e 3a 64 65 6c 2d 72 65 6d 6f 74 65 21 20 72 on:del-remote! r
1720: 65 6d 6f 74 65 20 72 75 6e 2d 69 64 29 20 3b 3b emote run-id) ;;
1730: 20 64 6f 6e 27 74 20 6b 65 65 70 20 75 73 69 6e don't keep usin
1740: 67 20 74 68 65 20 73 61 6d 65 20 63 6f 6e 6e 65 g the same conne
1750: 63 74 69 6f 6e 0a 09 09 3b 3b 20 4e 4f 54 45 3a ction...;; NOTE:
1760: 20 6b 69 6c 6c 69 6e 67 20 73 65 72 76 65 72 20 killing server
1770: 63 61 75 73 65 73 20 74 68 69 73 20 70 72 6f 63 causes this proc
1780: 65 73 73 20 74 6f 20 62 6c 6f 63 6b 20 66 6f 72 ess to block for
1790: 65 76 65 72 2e 20 4e 6f 20 69 64 65 61 20 77 68 ever. No idea wh
17a0: 79 2e 20 44 65 63 20 32 2e 20 0a 09 09 3b 3b 20 y. Dec 2. ...;;
17b0: 28 69 66 20 28 65 71 3f 20 28 6d 6f 64 75 6c 6f (if (eq? (modulo
17c0: 20 61 74 74 65 6d 70 74 6e 75 6d 20 35 29 20 30 attemptnum 5) 0
17d0: 29 0a 09 09 3b 3b 20 20 20 20 20 28 74 61 73 6b )...;; (task
17e0: 73 3a 6b 69 6c 6c 2d 73 65 72 76 65 72 2d 72 75 s:kill-server-ru
17f0: 6e 2d 69 64 20 72 75 6e 2d 69 64 20 74 61 67 3a n-id run-id tag:
1800: 20 22 61 70 69 2d 73 65 6e 64 2d 72 65 63 65 69 "api-send-recei
1810: 76 65 2d 66 61 69 6c 65 64 22 29 29 0a 09 09 3b ve-failed"))...;
1820: 3b 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 ; (mutex-unlock!
1830: 20 2a 73 65 6e 64 2d 72 65 63 65 69 76 65 2d 6d *send-receive-m
1840: 75 74 65 78 2a 29 20 3b 3b 20 63 6c 6f 73 65 20 utex*) ;; close
1850: 74 68 65 20 6d 75 74 65 78 20 68 65 72 65 20 74 the mutex here t
1860: 6f 20 61 6c 6c 6f 77 20 6f 74 68 65 72 20 74 68 o allow other th
1870: 72 65 61 64 73 20 61 63 63 65 73 73 20 74 6f 20 reads access to
1880: 63 6f 6d 6d 75 6e 69 63 61 74 69 6f 6e 73 0a 09 communications..
1890: 09 28 74 61 73 6b 73 3a 73 74 61 72 74 2d 61 6e .(tasks:start-an
18a0: 64 2d 77 61 69 74 2d 66 6f 72 2d 73 65 72 76 65 d-wait-for-serve
18b0: 72 20 28 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 62 r (tasks:open-db
18c0: 20 61 72 65 61 2d 64 61 74 29 20 72 75 6e 2d 69 area-dat) run-i
18d0: 64 20 31 35 29 0a 09 09 3b 3b 20 28 6e 6d 73 67 d 15)...;; (nmsg
18e0: 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 65 6e -transport:clien
18f0: 74 2d 61 70 69 2d 73 65 6e 64 2d 72 65 63 65 69 t-api-send-recei
1900: 76 65 20 72 75 6e 2d 69 64 20 63 6f 6e 6e 65 63 ve run-id connec
1910: 74 69 6f 6e 2d 69 6e 66 6f 20 63 6d 64 20 70 61 tion-info cmd pa
1920: 72 61 6d 20 72 65 6d 74 72 69 65 73 3a 20 28 2d ram remtries: (-
1930: 20 72 65 6d 74 72 69 65 73 20 31 29 29 29 29 29 remtries 1)))))
1940: 29 0a 0a 09 09 3b 3b 20 6e 6f 20 6c 6f 6e 67 65 )....;; no longe
1950: 72 20 6b 69 6c 6c 69 6e 67 20 74 68 65 20 73 65 r killing the se
1960: 72 76 65 72 20 69 6e 20 68 74 74 70 2d 74 72 61 rver in http-tra
1970: 6e 73 70 6f 72 74 3a 63 6c 69 65 6e 74 2d 61 70 nsport:client-ap
1980: 69 2d 73 65 6e 64 2d 72 65 63 65 69 76 65 0a 09 i-send-receive..
1990: 09 3b 3b 20 6d 61 79 20 6b 69 6c 6c 20 69 74 20 .;; may kill it
19a0: 68 65 72 65 20 62 75 74 20 77 68 61 74 20 61 72 here but what ar
19b0: 65 20 74 68 65 20 63 72 69 74 65 72 69 61 3f 0a e the criteria?.
19c0: 09 09 3b 3b 20 73 74 61 72 74 20 77 69 74 68 20 ..;; start with
19d0: 74 68 72 65 65 20 63 61 6c 6c 73 20 74 68 65 6e three calls then
19e0: 20 6b 69 6c 6c 20 73 65 72 76 65 72 0a 09 09 3b kill server...;
19f0: 3b 20 28 69 66 20 28 65 71 3f 20 61 74 74 65 6d ; (if (eq? attem
1a00: 70 74 6e 75 6d 20 33 29 28 74 61 73 6b 73 3a 6b ptnum 3)(tasks:k
1a10: 69 6c 6c 2d 73 65 72 76 65 72 2d 72 75 6e 2d 69 ill-server-run-i
1a20: 64 20 72 75 6e 2d 69 64 29 29 0a 09 09 3b 3b 20 d run-id))...;;
1a30: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 32 (thread-sleep! 2
1a40: 29 0a 09 09 28 72 6d 74 3a 73 65 6e 64 2d 72 65 )...(rmt:send-re
1a50: 63 65 69 76 65 20 63 6d 64 20 72 75 6e 2d 69 64 ceive cmd run-id
1a60: 20 70 61 72 61 6d 73 20 61 72 65 61 2d 64 61 74 params area-dat
1a70: 20 61 74 74 65 6d 70 74 6e 75 6d 3a 20 28 2b 20 attemptnum: (+
1a80: 61 74 74 65 6d 70 74 6e 75 6d 20 31 29 29 29 29 attemptnum 1))))
1a90: 29 0a 09 3b 3b 20 6e 6f 20 63 6f 6e 6e 65 63 74 )..;; no connect
1aa0: 69 6f 6e 20 69 6e 66 6f 3f 20 74 72 79 20 74 6f ion info? try to
1ab0: 20 73 74 61 72 74 20 61 20 73 65 72 76 65 72 2c start a server,
1ac0: 20 6f 72 20 61 63 63 65 73 73 20 6c 6f 63 61 6c or access local
1ad0: 6c 79 20 69 66 20 6e 6f 0a 09 3b 3b 20 73 65 72 ly if no..;; ser
1ae0: 76 65 72 20 61 6e 64 20 74 68 65 20 71 75 65 72 ver and the quer
1af0: 79 20 69 73 20 72 65 61 64 2d 6f 6e 6c 79 0a 09 y is read-only..
1b00: 3b 3b 0a 09 3b 3b 20 4e 6f 74 65 3a 20 54 68 65 ;;..;; Note: The
1b10: 20 74 61 73 6b 73 20 64 62 20 77 61 73 20 63 68 tasks db was ch
1b20: 65 63 6b 65 64 20 66 6f 72 20 61 20 73 65 72 76 ecked for a serv
1b30: 65 72 20 69 6e 20 73 74 61 72 74 69 6e 67 20 6d er in starting m
1b40: 6f 64 65 20 69 6e 20 74 68 65 20 72 6d 74 3a 67 ode in the rmt:g
1b50: 65 74 2d 63 6f 6e 6e 65 63 74 69 6f 6e 2d 69 6e et-connection-in
1b60: 66 6f 20 63 61 6c 6c 0a 09 3b 3b 0a 09 28 69 66 fo call..;;..(if
1b70: 20 28 61 6e 64 20 28 3c 20 61 74 74 65 6d 70 74 (and (< attempt
1b80: 6e 75 6d 20 31 35 29 0a 09 09 20 28 6d 65 6d 62 num 15)... (memb
1b90: 65 72 20 63 6d 64 20 61 70 69 3a 77 72 69 74 65 er cmd api:write
1ba0: 2d 71 75 65 72 69 65 73 29 29 0a 09 20 20 20 20 -queries))..
1bb0: 28 6c 65 74 20 28 28 66 61 73 74 73 74 61 72 74 (let ((faststart
1bc0: 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 (configf:lookup
1bd0: 20 63 6f 6e 66 69 67 64 61 74 20 22 73 65 72 76 configdat "serv
1be0: 65 72 22 20 22 66 61 73 74 73 74 61 72 74 22 29 er" "faststart")
1bf0: 29 29 0a 09 20 20 20 20 20 20 28 63 6f 6d 6d 6f )).. (commo
1c00: 6e 3a 64 65 6c 2d 72 65 6d 6f 74 65 21 20 72 65 n:del-remote! re
1c10: 6d 6f 74 65 20 72 75 6e 2d 69 64 29 0a 09 20 20 mote run-id)..
1c20: 20 20 20 20 3b 3b 20 28 6d 75 74 65 78 2d 75 6e ;; (mutex-un
1c30: 6c 6f 63 6b 21 20 2a 73 65 6e 64 2d 72 65 63 65 lock! *send-rece
1c40: 69 76 65 2d 6d 75 74 65 78 2a 29 0a 09 20 20 20 ive-mutex*)..
1c50: 20 20 20 28 69 66 20 28 61 6e 64 20 66 61 73 74 (if (and fast
1c60: 73 74 61 72 74 20 28 65 71 75 61 6c 3f 20 66 61 start (equal? fa
1c70: 73 74 73 74 61 72 74 20 22 6e 6f 22 29 29 0a 09 ststart "no"))..
1c80: 09 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 . (begin...
1c90: 28 74 61 73 6b 73 3a 73 74 61 72 74 2d 61 6e 64 (tasks:start-and
1ca0: 2d 77 61 69 74 2d 66 6f 72 2d 73 65 72 76 65 72 -wait-for-server
1cb0: 20 28 64 62 3a 64 65 6c 61 79 2d 69 66 2d 62 75 (db:delay-if-bu
1cc0: 73 79 20 28 74 61 73 6b 73 3a 6f 70 65 6e 2d 64 sy (tasks:open-d
1cd0: 62 20 61 72 65 61 2d 64 61 74 29 29 20 72 75 6e b area-dat)) run
1ce0: 2d 69 64 20 31 30 29 0a 09 09 20 20 20 20 28 74 -id 10)... (t
1cf0: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 28 72 61 hread-sleep! (ra
1d00: 6e 64 6f 6d 20 35 29 29 20 3b 3b 20 67 69 76 65 ndom 5)) ;; give
1d10: 20 73 6f 6d 65 20 74 69 6d 65 20 74 6f 20 73 65 some time to se
1d20: 74 74 6c 65 20 61 6e 64 20 6d 69 6e 69 6d 69 7a ttle and minimiz
1d30: 65 20 63 6f 6c 6c 69 73 6f 6e 3f 0a 09 09 20 20 e collison?...
1d40: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
1d50: 69 76 65 20 63 6d 64 20 72 69 64 20 70 61 72 61 ive cmd rid para
1d60: 6d 73 20 61 72 65 61 2d 64 61 74 20 61 74 74 65 ms area-dat atte
1d70: 6d 70 74 6e 75 6d 3a 20 28 2b 20 61 74 74 65 6d mptnum: (+ attem
1d80: 70 74 6e 75 6d 20 31 29 29 29 0a 09 09 20 20 28 ptnum 1)))... (
1d90: 62 65 67 69 6e 0a 09 09 20 20 20 20 28 73 65 72 begin... (ser
1da0: 76 65 72 3a 6b 69 6e 64 2d 72 75 6e 20 72 75 6e ver:kind-run run
1db0: 2d 69 64 20 61 72 65 61 2d 64 61 74 29 0a 09 09 -id area-dat)...
1dc0: 20 20 20 20 28 72 6d 74 3a 6f 70 65 6e 2d 71 72 (rmt:open-qr
1dd0: 79 2d 63 6c 6f 73 65 2d 6c 6f 63 61 6c 6c 79 20 y-close-locally
1de0: 63 6d 64 20 72 75 6e 2d 69 64 20 61 72 65 61 2d cmd run-id area-
1df0: 64 61 74 20 70 61 72 61 6d 73 20 61 72 65 61 2d dat params area-
1e00: 64 61 74 29 29 29 29 0a 09 20 20 20 20 28 62 65 dat)))).. (be
1e10: 67 69 6e 0a 09 20 20 20 20 20 20 3b 3b 20 28 64 gin.. ;; (d
1e20: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 ebug:print 0 "ER
1e30: 52 4f 52 3a 20 43 6f 6d 6d 75 6e 69 63 61 74 69 ROR: Communicati
1e40: 6f 6e 20 66 61 69 6c 65 64 21 22 29 0a 09 20 20 on failed!")..
1e50: 20 20 20 20 3b 3b 20 28 6d 75 74 65 78 2d 75 6e ;; (mutex-un
1e60: 6c 6f 63 6b 21 20 2a 73 65 6e 64 2d 72 65 63 65 lock! *send-rece
1e70: 69 76 65 2d 6d 75 74 65 78 2a 29 0a 09 20 20 20 ive-mutex*)..
1e80: 20 20 20 3b 3b 20 28 65 78 69 74 29 0a 09 20 20 ;; (exit)..
1e90: 20 20 20 20 28 72 6d 74 3a 6f 70 65 6e 2d 71 72 (rmt:open-qr
1ea0: 79 2d 63 6c 6f 73 65 2d 6c 6f 63 61 6c 6c 79 20 y-close-locally
1eb0: 63 6d 64 20 72 75 6e 2d 69 64 20 61 72 65 61 2d cmd run-id area-
1ec0: 64 61 74 20 70 61 72 61 6d 73 20 61 72 65 61 2d dat params area-
1ed0: 64 61 74 29 0a 09 20 20 20 20 20 20 29 29 29 29 dat).. ))))
1ee0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a )..(define (rmt:
1ef0: 75 70 64 61 74 65 2d 64 62 2d 73 74 61 74 73 20 update-db-stats
1f00: 72 75 6e 2d 69 64 20 72 61 77 63 6d 64 20 70 61 run-id rawcmd pa
1f10: 72 61 6d 73 20 64 75 72 61 74 69 6f 6e 29 0a 20 rams duration).
1f20: 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 64 (mutex-lock! *d
1f30: 62 2d 73 74 61 74 73 2d 6d 75 74 65 78 2a 29 0a b-stats-mutex*).
1f40: 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 (handle-except
1f50: 69 6f 6e 73 0a 20 20 20 65 78 6e 0a 20 20 20 28 ions. exn. (
1f60: 62 65 67 69 6e 0a 20 20 20 20 20 28 64 65 62 75 begin. (debu
1f70: 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 g:print 0 "WARNI
1f80: 4e 47 3a 20 73 74 61 74 73 20 63 6f 6c 6c 65 63 NG: stats collec
1f90: 74 69 6f 6e 20 66 61 69 6c 65 64 20 69 6e 20 75 tion failed in u
1fa0: 70 64 61 74 65 2d 64 62 2d 73 74 61 74 73 22 29 pdate-db-stats")
1fb0: 0a 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 . (debug:pri
1fc0: 6e 74 20 30 20 22 20 6d 65 73 73 61 67 65 3a 20 nt 0 " message:
1fd0: 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 " ((condition-pr
1fe0: 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 operty-accessor
1ff0: 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 'exn 'message) e
2000: 78 6e 29 29 0a 20 20 20 20 20 28 70 72 69 6e 74 xn)). (print
2010: 20 22 65 78 6e 3d 22 20 28 63 6f 6e 64 69 74 69 "exn=" (conditi
2020: 6f 6e 2d 3e 6c 69 73 74 20 65 78 6e 29 29 0a 20 on->list exn)).
2030: 20 20 20 20 23 66 29 20 3b 3b 20 69 66 20 74 68 #f) ;; if th
2040: 69 73 20 66 61 69 6c 73 20 77 65 20 64 6f 6e 27 is fails we don'
2050: 74 20 63 61 72 65 2c 20 69 74 20 69 73 20 6a 75 t care, it is ju
2060: 73 74 20 73 74 61 74 73 0a 20 20 20 28 6c 65 74 st stats. (let
2070: 2a 20 28 28 63 6d 64 20 20 20 20 20 20 28 63 6f * ((cmd (co
2080: 6e 63 20 22 72 75 6e 2d 69 64 3d 22 20 72 75 6e nc "run-id=" run
2090: 2d 69 64 20 22 20 22 20 28 69 66 20 28 65 71 3f -id " " (if (eq?
20a0: 20 72 61 77 63 6d 64 20 27 67 65 6e 65 72 61 6c rawcmd 'general
20b0: 2d 63 61 6c 6c 29 20 28 63 61 72 20 70 61 72 61 -call) (car para
20c0: 6d 73 29 20 72 61 77 63 6d 64 29 29 29 0a 09 20 ms) rawcmd)))..
20d0: 20 28 73 74 61 74 2d 76 65 63 20 28 68 61 73 68 (stat-vec (hash
20e0: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
20f0: 6c 74 20 2a 64 62 2d 73 74 61 74 73 2a 20 63 6d lt *db-stats* cm
2100: 64 20 23 66 29 29 29 0a 20 20 20 20 20 28 69 66 d #f))). (if
2110: 20 28 6e 6f 74 20 28 76 65 63 74 6f 72 3f 20 73 (not (vector? s
2120: 74 61 74 2d 76 65 63 29 29 0a 09 20 28 6c 65 74 tat-vec)).. (let
2130: 20 28 28 6e 65 77 76 65 63 20 28 76 65 63 74 6f ((newvec (vecto
2140: 72 20 30 20 30 29 29 29 0a 09 20 20 20 28 68 61 r 0 0))).. (ha
2150: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a 64 sh-table-set! *d
2160: 62 2d 73 74 61 74 73 2a 20 63 6d 64 20 6e 65 77 b-stats* cmd new
2170: 76 65 63 29 0a 09 20 20 20 28 73 65 74 21 20 73 vec).. (set! s
2180: 74 61 74 2d 76 65 63 20 6e 65 77 76 65 63 29 29 tat-vec newvec))
2190: 29 0a 20 20 20 20 20 28 76 65 63 74 6f 72 2d 73 ). (vector-s
21a0: 65 74 21 20 73 74 61 74 2d 76 65 63 20 30 20 28 et! stat-vec 0 (
21b0: 2b 20 28 76 65 63 74 6f 72 2d 72 65 66 20 73 74 + (vector-ref st
21c0: 61 74 2d 76 65 63 20 30 29 20 31 29 29 0a 20 20 at-vec 0) 1)).
21d0: 20 20 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 (vector-set!
21e0: 73 74 61 74 2d 76 65 63 20 31 20 28 2b 20 28 76 stat-vec 1 (+ (v
21f0: 65 63 74 6f 72 2d 72 65 66 20 73 74 61 74 2d 76 ector-ref stat-v
2200: 65 63 20 31 29 20 64 75 72 61 74 69 6f 6e 29 29 ec 1) duration))
2210: 29 29 0a 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f )). (mutex-unlo
2220: 63 6b 21 20 2a 64 62 2d 73 74 61 74 73 2d 6d 75 ck! *db-stats-mu
2230: 74 65 78 2a 29 29 0a 0a 0a 28 64 65 66 69 6e 65 tex*))...(define
2240: 20 28 72 6d 74 3a 70 72 69 6e 74 2d 64 62 2d 73 (rmt:print-db-s
2250: 74 61 74 73 20 61 72 65 61 2d 64 61 74 29 0a 20 tats area-dat).
2260: 20 28 6c 65 74 20 28 28 66 6d 74 73 74 72 20 22 (let ((fmtstr "
2270: 7e 34 30 61 7e 37 2d 64 7e 39 2d 64 7e 32 30 2c ~40a~7-d~9-d~20,
2280: 32 2d 66 22 29 29 20 3b 3b 20 22 7e 32 30 2c 32 2-f")) ;; "~20,2
2290: 2d 66 22 0a 20 20 20 20 28 64 65 62 75 67 3a 70 -f". (debug:p
22a0: 72 69 6e 74 20 31 38 20 22 44 42 20 53 74 61 74 rint 18 "DB Stat
22b0: 73 5c 6e 3d 3d 3d 3d 3d 3d 3d 3d 22 29 0a 20 20 s\n========").
22c0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 (debug:print 1
22d0: 38 20 28 66 6f 72 6d 61 74 20 23 66 20 22 7e 34 8 (format #f "~4
22e0: 30 61 7e 38 61 7e 31 30 61 7e 31 30 61 22 20 22 0a~8a~10a~10a" "
22f0: 43 6d 64 22 20 22 43 6f 75 6e 74 22 20 22 54 6f Cmd" "Count" "To
2300: 74 54 69 6d 65 22 20 22 41 76 67 22 29 29 0a 20 tTime" "Avg")).
2310: 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 (for-each (la
2320: 6d 62 64 61 20 28 63 6d 64 29 0a 09 09 28 6c 65 mbda (cmd)...(le
2330: 74 20 28 28 63 6d 64 2d 64 61 74 20 28 68 61 73 t ((cmd-dat (has
2340: 68 2d 74 61 62 6c 65 2d 72 65 66 20 2a 64 62 2d h-table-ref *db-
2350: 73 74 61 74 73 2a 20 63 6d 64 29 29 29 0a 09 09 stats* cmd)))...
2360: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 (debug:print 1
2370: 38 20 28 66 6f 72 6d 61 74 20 23 66 20 66 6d 74 8 (format #f fmt
2380: 73 74 72 20 63 6d 64 20 28 76 65 63 74 6f 72 2d str cmd (vector-
2390: 72 65 66 20 63 6d 64 2d 64 61 74 20 30 29 20 28 ref cmd-dat 0) (
23a0: 76 65 63 74 6f 72 2d 72 65 66 20 63 6d 64 2d 64 vector-ref cmd-d
23b0: 61 74 20 31 29 20 28 2f 20 28 76 65 63 74 6f 72 at 1) (/ (vector
23c0: 2d 72 65 66 20 63 6d 64 2d 64 61 74 20 31 29 28 -ref cmd-dat 1)(
23d0: 76 65 63 74 6f 72 2d 72 65 66 20 63 6d 64 2d 64 vector-ref cmd-d
23e0: 61 74 20 30 29 29 29 29 29 29 0a 09 20 20 20 20 at 0))))))..
23f0: 20 20 28 73 6f 72 74 20 28 68 61 73 68 2d 74 61 (sort (hash-ta
2400: 62 6c 65 2d 6b 65 79 73 20 2a 64 62 2d 73 74 61 ble-keys *db-sta
2410: 74 73 2a 29 0a 09 09 20 20 20 20 28 6c 61 6d 62 ts*)... (lamb
2420: 64 61 20 28 61 20 62 29 0a 09 09 20 20 20 20 20 da (a b)...
2430: 20 28 3e 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (> (vector-ref
2440: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 (hash-table-ref
2450: 2a 64 62 2d 73 74 61 74 73 2a 20 61 29 20 30 29 *db-stats* a) 0)
2460: 0a 09 09 09 20 28 76 65 63 74 6f 72 2d 72 65 66 .... (vector-ref
2470: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
2480: 20 2a 64 62 2d 73 74 61 74 73 2a 20 62 29 20 30 *db-stats* b) 0
2490: 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 )))))))..(define
24a0: 20 28 72 6d 74 3a 67 65 74 2d 6d 61 78 2d 71 75 (rmt:get-max-qu
24b0: 65 72 79 2d 61 76 65 72 61 67 65 20 72 75 6e 2d ery-average run-
24c0: 69 64 29 0a 20 20 28 6d 75 74 65 78 2d 6c 6f 63 id). (mutex-loc
24d0: 6b 21 20 2a 64 62 2d 73 74 61 74 73 2d 6d 75 74 k! *db-stats-mut
24e0: 65 78 2a 29 0a 20 20 28 6c 65 74 2a 20 28 28 72 ex*). (let* ((r
24f0: 75 6e 6b 65 79 20 28 63 6f 6e 63 20 22 72 75 6e unkey (conc "run
2500: 2d 69 64 3d 22 20 72 75 6e 2d 69 64 20 22 20 22 -id=" run-id " "
2510: 29 29 0a 09 20 28 63 6d 64 73 20 20 20 28 66 69 )).. (cmds (fi
2520: 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 lter (lambda (x)
2530: 0a 09 09 09 20 20 20 28 73 75 62 73 74 72 69 6e .... (substrin
2540: 67 2d 69 6e 64 65 78 20 72 75 6e 6b 65 79 20 78 g-index runkey x
2550: 29 29 0a 09 09 09 20 28 68 61 73 68 2d 74 61 62 )).... (hash-tab
2560: 6c 65 2d 6b 65 79 73 20 2a 64 62 2d 73 74 61 74 le-keys *db-stat
2570: 73 2a 29 29 29 0a 09 20 28 72 65 73 20 20 20 20 s*))).. (res
2580: 28 69 66 20 28 6e 75 6c 6c 3f 20 63 6d 64 73 29 (if (null? cmds)
2590: 0a 09 09 20 20 20 20 20 28 63 6f 6e 73 20 27 6e ... (cons 'n
25a0: 6f 6e 65 20 30 29 0a 09 09 20 20 20 20 20 28 6c one 0)... (l
25b0: 65 74 20 6c 6f 6f 70 20 28 28 63 6d 64 20 28 63 et loop ((cmd (c
25c0: 61 72 20 63 6d 64 73 29 29 0a 09 09 09 09 28 74 ar cmds)).....(t
25d0: 61 6c 20 28 63 64 72 20 63 6d 64 73 29 29 0a 09 al (cdr cmds))..
25e0: 09 09 09 28 6d 61 78 2d 63 6d 64 20 28 63 61 72 ...(max-cmd (car
25f0: 20 63 6d 64 73 29 29 0a 09 09 09 09 28 72 65 73 cmds)).....(res
2600: 20 30 29 29 0a 09 09 20 20 20 20 20 20 20 28 6c 0))... (l
2610: 65 74 2a 20 28 28 63 6d 64 2d 64 61 74 20 28 68 et* ((cmd-dat (h
2620: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 2a 64 ash-table-ref *d
2630: 62 2d 73 74 61 74 73 2a 20 63 6d 64 29 29 0a 09 b-stats* cmd))..
2640: 09 09 20 20 20 20 20 20 28 74 6f 74 20 20 20 20 .. (tot
2650: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 63 6d 64 (vector-ref cmd
2660: 2d 64 61 74 20 30 29 29 0a 09 09 09 20 20 20 20 -dat 0))....
2670: 20 20 28 63 75 72 72 61 76 67 20 28 2f 20 28 76 (curravg (/ (v
2680: 65 63 74 6f 72 2d 72 65 66 20 63 6d 64 2d 64 61 ector-ref cmd-da
2690: 74 20 31 29 20 28 76 65 63 74 6f 72 2d 72 65 66 t 1) (vector-ref
26a0: 20 63 6d 64 2d 64 61 74 20 30 29 29 29 20 3b 3b cmd-dat 0))) ;;
26b0: 20 63 6f 75 6e 74 20 69 73 20 6e 65 76 65 72 20 count is never
26c0: 7a 65 72 6f 20 62 79 20 63 6f 6e 73 74 72 75 63 zero by construc
26d0: 74 69 6f 6e 0a 09 09 09 20 20 20 20 20 20 28 63 tion.... (c
26e0: 75 72 72 6d 61 78 20 28 6d 61 78 20 72 65 73 20 urrmax (max res
26f0: 63 75 72 72 61 76 67 29 29 0a 09 09 09 20 20 20 curravg))....
2700: 20 20 20 28 6e 65 77 6d 61 78 2d 63 6d 64 20 28 (newmax-cmd (
2710: 69 66 20 28 3e 20 63 75 72 72 61 76 67 20 72 65 if (> curravg re
2720: 73 29 20 63 6d 64 20 6d 61 78 2d 63 6d 64 29 29 s) cmd max-cmd))
2730: 29 0a 09 09 09 20 28 69 66 20 28 6e 75 6c 6c 3f ).... (if (null?
2740: 20 74 61 6c 29 0a 09 09 09 20 20 20 20 20 28 69 tal).... (i
2750: 66 20 28 3e 20 74 6f 74 20 31 30 29 0a 09 09 09 f (> tot 10)....
2760: 09 20 28 63 6f 6e 73 20 6e 65 77 6d 61 78 2d 63 . (cons newmax-c
2770: 6d 64 20 63 75 72 72 6d 61 78 29 0a 09 09 09 09 md currmax).....
2780: 20 28 63 6f 6e 73 20 27 6e 6f 6e 65 20 30 29 29 (cons 'none 0))
2790: 0a 09 09 09 20 20 20 20 20 28 6c 6f 6f 70 20 28 .... (loop (
27a0: 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c car tal)(cdr tal
27b0: 29 20 6e 65 77 6d 61 78 2d 63 6d 64 20 63 75 72 ) newmax-cmd cur
27c0: 72 6d 61 78 29 29 29 29 29 29 29 0a 20 20 20 20 rmax))))))).
27d0: 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a (mutex-unlock! *
27e0: 64 62 2d 73 74 61 74 73 2d 6d 75 74 65 78 2a 29 db-stats-mutex*)
27f0: 0a 20 20 20 20 72 65 73 29 29 0a 09 20 20 0a 28 . res)).. .(
2800: 64 65 66 69 6e 65 20 28 72 6d 74 3a 6f 70 65 6e define (rmt:open
2810: 2d 71 72 79 2d 63 6c 6f 73 65 2d 6c 6f 63 61 6c -qry-close-local
2820: 6c 79 20 63 6d 64 20 72 75 6e 2d 69 64 20 61 72 ly cmd run-id ar
2830: 65 61 2d 64 61 74 20 70 61 72 61 6d 73 20 23 21 ea-dat params #!
2840: 6b 65 79 20 28 72 65 6d 72 65 74 72 69 65 73 20 key (remretries
2850: 35 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 62 5)). (let* ((db
2860: 73 74 72 75 63 74 2d 6c 6f 63 61 6c 20 28 69 66 struct-local (if
2870: 20 2a 64 62 73 74 72 75 63 74 2d 64 62 2a 0a 09 *dbstruct-db*..
2880: 09 09 20 20 20 20 20 2a 64 62 73 74 72 75 63 74 .. *dbstruct
2890: 2d 64 62 2a 0a 09 09 09 20 20 20 20 20 28 6c 65 -db*.... (le
28a0: 74 2a 20 28 28 64 62 64 69 72 20 28 64 62 3a 64 t* ((dbdir (db:d
28b0: 62 66 69 6c 65 2d 70 61 74 68 20 23 66 20 61 72 bfile-path #f ar
28c0: 65 61 2d 64 61 74 29 29 0a 09 09 09 09 20 20 20 ea-dat)).....
28d0: 20 28 64 62 20 28 6d 61 6b 65 2d 64 62 72 3a 64 (db (make-dbr:d
28e0: 62 73 74 72 75 63 74 20 70 61 74 68 3a 20 20 64 bstruct path: d
28f0: 62 64 69 72 20 6c 6f 63 61 6c 3a 20 23 74 29 29 bdir local: #t))
2900: 29 0a 09 09 09 20 20 20 20 20 20 20 28 73 65 74 ).... (set
2910: 21 20 2a 64 62 73 74 72 75 63 74 2d 64 62 2a 20 ! *dbstruct-db*
2920: 64 62 29 0a 09 09 09 20 20 20 20 20 20 20 64 62 db).... db
2930: 29 29 29 0a 09 20 28 64 62 2d 66 69 6c 65 2d 70 ))).. (db-file-p
2940: 61 74 68 20 20 20 28 64 62 3a 64 62 66 69 6c 65 ath (db:dbfile
2950: 2d 70 61 74 68 20 30 20 61 72 65 61 2d 64 61 74 -path 0 area-dat
2960: 29 29 0a 09 20 3b 3b 20 28 72 65 61 64 2d 6f 6e )).. ;; (read-on
2970: 6c 79 20 20 20 20 20 20 28 6e 6f 74 20 28 66 69 ly (not (fi
2980: 6c 65 2d 72 65 61 64 2d 61 63 63 65 73 73 3f 20 le-read-access?
2990: 64 62 2d 66 69 6c 65 2d 70 61 74 68 29 29 29 0a db-file-path))).
29a0: 09 20 28 73 74 61 72 74 20 20 20 20 20 20 20 20 . (start
29b0: 20 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 (current-milli
29c0: 73 65 63 6f 6e 64 73 29 29 0a 09 20 28 72 65 73 seconds)).. (res
29d0: 64 61 74 20 20 20 20 20 20 20 20 20 28 61 70 69 dat (api
29e0: 3a 65 78 65 63 75 74 65 2d 72 65 71 75 65 73 74 :execute-request
29f0: 73 20 64 62 73 74 72 75 63 74 2d 6c 6f 63 61 6c s dbstruct-local
2a00: 20 61 72 65 61 2d 64 61 74 20 28 76 65 63 74 6f area-dat (vecto
2a10: 72 20 28 73 79 6d 62 6f 6c 2d 3e 73 74 72 69 6e r (symbol->strin
2a20: 67 20 63 6d 64 29 20 70 61 72 61 6d 73 29 29 29 g cmd) params)))
2a30: 0a 09 20 28 73 75 63 63 65 73 73 20 20 20 20 20 .. (success
2a40: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 (vector-ref r
2a50: 65 73 64 61 74 20 30 29 29 0a 09 20 28 72 65 73 esdat 0)).. (res
2a60: 20 20 20 20 20 20 20 20 20 20 20 20 28 76 65 63 (vec
2a70: 74 6f 72 2d 72 65 66 20 72 65 73 64 61 74 20 31 tor-ref resdat 1
2a80: 29 29 0a 09 20 28 64 75 72 61 74 69 6f 6e 20 20 )).. (duration
2a90: 20 20 20 20 20 28 2d 20 28 63 75 72 72 65 6e 74 (- (current
2aa0: 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 20 73 -milliseconds) s
2ab0: 74 61 72 74 29 29 29 0a 20 20 20 20 28 69 66 20 tart))). (if
2ac0: 28 6e 6f 74 20 73 75 63 63 65 73 73 29 0a 09 28 (not success)..(
2ad0: 69 66 20 28 3e 20 72 65 6d 72 65 74 72 69 65 73 if (> remretries
2ae0: 20 30 29 0a 09 20 20 20 20 28 62 65 67 69 6e 0a 0).. (begin.
2af0: 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
2b00: 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 6c 6f int 0 "ERROR: lo
2b10: 63 61 6c 20 71 75 65 72 79 20 66 61 69 6c 65 64 cal query failed
2b20: 2e 20 54 72 79 69 6e 67 20 61 67 61 69 6e 2e 22 . Trying again."
2b30: 29 0a 09 20 20 20 20 20 20 28 74 68 72 65 61 64 ).. (thread
2b40: 2d 73 6c 65 65 70 21 20 28 2f 20 28 72 61 6e 64 -sleep! (/ (rand
2b50: 6f 6d 20 35 30 30 30 29 20 31 30 30 30 29 29 20 om 5000) 1000))
2b60: 3b 3b 20 73 6f 6d 65 20 72 61 6e 64 6f 6d 20 64 ;; some random d
2b70: 65 6c 61 79 20 0a 09 20 20 20 20 20 20 28 72 6d elay .. (rm
2b80: 74 3a 6f 70 65 6e 2d 71 72 79 2d 63 6c 6f 73 65 t:open-qry-close
2b90: 2d 6c 6f 63 61 6c 6c 79 20 63 6d 64 20 72 75 6e -locally cmd run
2ba0: 2d 69 64 20 61 72 65 61 2d 64 61 74 20 70 61 72 -id area-dat par
2bb0: 61 6d 73 20 72 65 6d 72 65 74 72 69 65 73 3a 20 ams remretries:
2bc0: 28 2d 20 72 65 6d 72 65 74 72 69 65 73 20 31 29 (- remretries 1)
2bd0: 29 29 0a 09 20 20 20 20 28 62 65 67 69 6e 0a 09 )).. (begin..
2be0: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
2bf0: 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 74 6f 6f nt 0 "ERROR: too
2c00: 20 6d 61 6e 79 20 72 65 74 72 69 65 73 20 69 6e many retries in
2c10: 20 72 6d 74 3a 6f 70 65 6e 2d 71 72 79 2d 63 6c rmt:open-qry-cl
2c20: 6f 73 65 2d 6c 6f 63 61 6c 6c 79 2c 20 67 69 76 ose-locally, giv
2c30: 69 6e 67 20 75 70 22 29 0a 09 20 20 20 20 20 20 ing up")..
2c40: 23 66 29 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 #f))..(begin..
2c50: 28 72 6d 74 3a 75 70 64 61 74 65 2d 64 62 2d 73 (rmt:update-db-s
2c60: 74 61 74 73 20 72 75 6e 2d 69 64 20 63 6d 64 20 tats run-id cmd
2c70: 70 61 72 61 6d 73 20 64 75 72 61 74 69 6f 6e 29 params duration)
2c80: 0a 09 20 20 3b 3b 20 6d 61 72 6b 20 74 68 69 73 .. ;; mark this
2c90: 20 72 75 6e 20 61 73 20 64 69 72 74 79 20 69 66 run as dirty if
2ca0: 20 74 68 69 73 20 77 61 73 20 61 20 77 72 69 74 this was a writ
2cb0: 65 0a 09 20 20 28 69 66 20 28 6e 6f 74 20 28 6d e.. (if (not (m
2cc0: 65 6d 62 65 72 20 63 6d 64 20 61 70 69 3a 72 65 ember cmd api:re
2cd0: 61 64 2d 6f 6e 6c 79 2d 71 75 65 72 69 65 73 29 ad-only-queries)
2ce0: 29 0a 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 ).. (let ((
2cf0: 73 74 61 72 74 2d 74 69 6d 65 20 28 63 75 72 72 start-time (curr
2d00: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 0a 09 ent-seconds)))..
2d10: 09 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 64 .(mutex-lock! *d
2d20: 62 2d 6d 75 6c 74 69 2d 73 79 6e 63 2d 6d 75 74 b-multi-sync-mut
2d30: 65 78 2a 29 0a 09 09 3b 3b 20 28 69 66 20 28 6e ex*)...;; (if (n
2d40: 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 ot (hash-table-r
2d50: 65 66 2f 64 65 66 61 75 6c 74 20 2a 64 62 2d 6c ef/default *db-l
2d60: 6f 63 61 6c 2d 73 79 6e 63 2a 20 72 75 6e 2d 69 ocal-sync* run-i
2d70: 64 20 23 66 29 29 0a 09 09 3b 3b 20 6a 75 73 74 d #f))...;; just
2d80: 20 73 65 74 20 69 74 20 65 76 65 72 79 20 74 69 set it every ti
2d90: 6d 65 2e 20 49 73 20 61 20 77 72 69 74 65 20 6d me. Is a write m
2da0: 6f 72 65 20 65 78 70 65 6e 73 69 76 65 20 74 68 ore expensive th
2db0: 61 6e 20 61 20 72 65 61 64 20 61 6e 64 20 64 6f an a read and do
2dc0: 65 73 20 69 74 20 6d 61 74 74 65 72 3f 0a 09 09 es it matter?...
2dd0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
2de0: 20 2a 64 62 2d 6c 6f 63 61 6c 2d 73 79 6e 63 2a *db-local-sync*
2df0: 20 28 6f 72 20 72 75 6e 2d 69 64 20 30 29 20 73 (or run-id 0) s
2e00: 74 61 72 74 2d 74 69 6d 65 29 20 3b 3b 20 74 68 tart-time) ;; th
2e10: 65 20 6f 6c 64 65 73 74 20 22 77 72 69 74 65 22 e oldest "write"
2e20: 0a 09 09 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b ...(mutex-unlock
2e30: 21 20 2a 64 62 2d 6d 75 6c 74 69 2d 73 79 6e 63 ! *db-multi-sync
2e40: 2d 6d 75 74 65 78 2a 29 29 29 0a 09 20 20 72 65 -mutex*))).. re
2e50: 73 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 s))))..(define (
2e60: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
2e70: 2d 6e 6f 2d 61 75 74 6f 2d 63 6c 69 65 6e 74 2d -no-auto-client-
2e80: 73 65 74 75 70 20 63 6f 6e 6e 65 63 74 69 6f 6e setup connection
2e90: 2d 69 6e 66 6f 20 63 6d 64 20 72 75 6e 2d 69 64 -info cmd run-id
2ea0: 20 70 61 72 61 6d 73 20 61 72 65 61 2d 64 61 74 params area-dat
2eb0: 29 0a 20 20 28 6c 65 74 2a 20 28 28 72 75 6e 2d ). (let* ((run-
2ec0: 69 64 20 20 20 28 69 66 20 72 75 6e 2d 69 64 20 id (if run-id
2ed0: 72 75 6e 2d 69 64 20 30 29 29 0a 09 20 3b 3b 20 run-id 0)).. ;;
2ee0: 28 6a 70 61 72 61 6d 73 20 20 28 64 62 3a 6f 62 (jparams (db:ob
2ef0: 6a 2d 3e 73 74 72 69 6e 67 20 70 61 72 61 6d 73 j->string params
2f00: 29 29 20 3b 3b 20 28 72 6d 74 3a 64 61 74 2d 3e )) ;; (rmt:dat->
2f10: 6a 73 6f 6e 2d 73 74 72 20 70 61 72 61 6d 73 29 json-str params)
2f20: 29 0a 09 20 28 72 65 73 20 20 09 20 20 20 28 68 ).. (res . (h
2f30: 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 andle-exceptions
2f40: 0a 09 09 20 20 20 20 65 78 6e 0a 09 09 20 20 20 ... exn...
2f50: 20 23 66 0a 09 09 20 20 20 20 28 68 74 74 70 2d #f... (http-
2f60: 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 65 6e 74 transport:client
2f70: 2d 61 70 69 2d 73 65 6e 64 2d 72 65 63 65 69 76 -api-send-receiv
2f80: 65 20 72 75 6e 2d 69 64 20 63 6f 6e 6e 65 63 74 e run-id connect
2f90: 69 6f 6e 2d 69 6e 66 6f 20 63 6d 64 20 70 61 72 ion-info cmd par
2fa0: 61 6d 73 29 29 29 29 0a 3b 3b 09 09 20 20 20 20 ams)))).;;..
2fb0: 28 28 63 6f 6d 6d 66 61 69 6c 29 20 28 76 65 63 ((commfail) (vec
2fc0: 74 6f 72 20 23 66 20 22 63 6f 6d 6d 75 6e 69 63 tor #f "communic
2fd0: 61 74 69 6f 6e 73 20 66 61 69 6c 22 29 29 29 29 ations fail"))))
2fe0: 29 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 72 ). (if (and r
2ff0: 65 73 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 es (vector-ref r
3000: 65 73 20 30 29 29 0a 09 28 76 65 63 74 6f 72 2d es 0))..(vector-
3010: 72 65 66 20 72 65 73 20 31 29 20 3b 3b 3b 20 59 ref res 1) ;;; Y
3020: 45 53 21 21 20 54 48 49 53 20 49 53 20 43 4f 52 ES!! THIS IS COR
3030: 52 45 43 54 21 21 20 43 48 41 4e 47 45 20 49 54 RECT!! CHANGE IT
3040: 20 48 45 52 45 2c 20 54 48 45 4e 20 43 48 41 4e HERE, THEN CHAN
3050: 47 45 20 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 GE rmt:send-rece
3060: 69 76 65 20 41 4c 53 4f 21 21 21 0a 09 23 66 29 ive ALSO!!!..#f)
3070: 29 29 0a 3b 3b 20 09 28 64 62 3a 73 74 72 69 6e )).;; .(db:strin
3080: 67 2d 3e 6f 62 6a 20 28 76 65 63 74 6f 72 2d 72 g->obj (vector-r
3090: 65 66 20 64 61 74 20 31 29 29 0a 3b 3b 20 09 28 ef dat 1)).;; .(
30a0: 62 65 67 69 6e 0a 3b 3b 20 09 20 20 28 64 65 62 begin.;; . (deb
30b0: 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO
30c0: 52 3a 20 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 R: rmt:send-rece
30d0: 69 76 65 2d 6e 6f 2d 61 75 74 6f 2d 63 6c 69 65 ive-no-auto-clie
30e0: 6e 74 2d 73 65 74 75 70 20 66 61 69 6c 65 64 2c nt-setup failed,
30f0: 20 61 74 74 65 6d 70 74 69 6e 67 20 74 6f 20 63 attempting to c
3100: 6f 6e 74 69 6e 75 65 2e 20 47 6f 74 20 22 20 64 ontinue. Got " d
3110: 61 74 29 0a 3b 3b 20 09 20 20 64 61 74 29 29 29 at).;; . dat)))
3120: 29 0a 0a 3b 3b 20 57 72 61 70 20 6a 73 6f 6e 20 )..;; Wrap json
3130: 6c 69 62 72 61 72 79 20 66 6f 72 20 73 74 72 69 library for stri
3140: 6e 67 73 20 28 77 68 79 20 74 68 65 20 70 6f 72 ngs (why the por
3150: 74 73 20 63 72 61 70 20 69 6e 20 74 68 65 20 66 ts crap in the f
3160: 69 72 73 74 20 70 6c 61 63 65 3f 29 0a 28 64 65 irst place?).(de
3170: 66 69 6e 65 20 28 72 6d 74 3a 64 61 74 2d 3e 6a fine (rmt:dat->j
3180: 73 6f 6e 2d 73 74 72 20 64 61 74 29 0a 20 20 28 son-str dat). (
3190: 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 73 with-output-to-s
31a0: 74 72 69 6e 67 20 0a 20 20 20 20 28 6c 61 6d 62 tring . (lamb
31b0: 64 61 20 28 29 0a 20 20 20 20 20 20 28 6a 73 6f da (). (jso
31c0: 6e 2d 77 72 69 74 65 20 64 61 74 29 29 29 29 0a n-write dat)))).
31d0: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 6a 73 .(define (rmt:js
31e0: 6f 6e 2d 73 74 72 2d 3e 64 61 74 20 6a 73 6f 6e on-str->dat json
31f0: 2d 73 74 72 29 0a 20 20 28 77 69 74 68 2d 69 6e -str). (with-in
3200: 70 75 74 2d 66 72 6f 6d 2d 73 74 72 69 6e 67 20 put-from-string
3210: 6a 73 6f 6e 2d 73 74 72 0a 20 20 20 20 28 6c 61 json-str. (la
3220: 6d 62 64 61 20 28 29 0a 20 20 20 20 20 20 28 6a mbda (). (j
3230: 73 6f 6e 2d 72 65 61 64 29 29 29 29 0a 0a 3b 3b son-read))))..;;
3240: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3250: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3260: 3d 3d 3d 3d 3d 3d 3d 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 0a 3b 3b 0a 3b 3b 20 41 20 43 ======.;;.;; A C
3290: 20 54 20 55 20 41 20 4c 20 20 20 41 20 50 20 49 T U A L A P I
32a0: 20 20 20 43 20 41 20 4c 20 4c 20 53 20 20 0a 3b C A L L S .;
32b0: 3b 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;.;;============
32c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
32d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
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 0a 0a 3b 3b 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 3d 3d 3d 3d 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 0a 3b 3b 20 20 53 20 45 20 52 20 56 ====.;; S E R V
3350: 20 45 20 52 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d E R.;;=========
3360: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3370: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
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 0a 0a 28 =============..(
33a0: 64 65 66 69 6e 65 20 28 72 6d 74 3a 6b 69 6c 6c define (rmt:kill
33b0: 2d 73 65 72 76 65 72 20 72 75 6e 2d 69 64 29 0a -server run-id).
33c0: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
33d0: 69 76 65 20 27 6b 69 6c 6c 2d 73 65 72 76 65 72 ive 'kill-server
33e0: 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 run-id (list ru
33f0: 6e 2d 69 64 29 20 61 72 65 61 2d 64 61 74 29 29 n-id) area-dat))
3400: 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 73 ..(define (rmt:s
3410: 74 61 72 74 2d 73 65 72 76 65 72 20 72 75 6e 2d tart-server run-
3420: 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d id). (rmt:send-
3430: 72 65 63 65 69 76 65 20 27 73 74 61 72 74 2d 73 receive 'start-s
3440: 65 72 76 65 72 20 30 20 28 6c 69 73 74 20 72 75 erver 0 (list ru
3450: 6e 2d 69 64 29 20 61 72 65 61 2d 64 61 74 29 29 n-id) area-dat))
3460: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
3470: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
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 0a 3b 3b 20 20 4d ==========.;; M
34b0: 20 49 20 53 20 43 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d I S C.;;=======
34c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
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 0a ===============.
3500: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 6c 6f .(define (rmt:lo
3510: 67 69 6e 20 72 75 6e 2d 69 64 20 61 72 65 61 2d gin run-id area-
3520: 64 61 74 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 dat). (rmt:send
3530: 2d 72 65 63 65 69 76 65 20 27 6c 6f 67 69 6e 20 -receive 'login
3540: 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 28 6d 65 run-id (list (me
3550: 67 61 74 65 73 74 3a 61 72 65 61 2d 70 61 74 68 gatest:area-path
3560: 20 61 72 65 61 2d 64 61 74 29 20 6d 65 67 61 74 area-dat) megat
3570: 65 73 74 2d 76 65 72 73 69 6f 6e 20 72 75 6e 2d est-version run-
3580: 69 64 20 2a 6d 79 2d 63 6c 69 65 6e 74 2d 73 69 id *my-client-si
3590: 67 6e 61 74 75 72 65 2a 29 20 61 72 65 61 2d 64 gnature*) area-d
35a0: 61 74 29 29 0a 0a 3b 3b 20 54 68 69 73 20 6c 6f at))..;; This lo
35b0: 67 69 6e 20 64 6f 65 73 20 6e 6f 20 72 65 74 72 gin does no retr
35c0: 69 65 73 20 75 6e 64 65 72 20 74 68 65 20 68 6f ies under the ho
35d0: 6f 64 20 2d 20 69 74 20 61 63 74 73 20 61 20 62 od - it acts a b
35e0: 69 74 20 6c 69 6b 65 20 61 20 70 69 6e 67 2e 0a it like a ping..
35f0: 3b 3b 20 44 65 70 72 65 63 61 74 65 64 20 66 6f ;; Deprecated fo
3600: 72 20 6e 6d 73 67 2d 74 72 61 6e 73 70 6f 72 74 r nmsg-transport
3610: 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 72 6d ..;;.(define (rm
3620: 74 3a 6c 6f 67 69 6e 2d 6e 6f 2d 61 75 74 6f 2d t:login-no-auto-
3630: 63 6c 69 65 6e 74 2d 73 65 74 75 70 20 63 6f 6e client-setup con
3640: 6e 65 63 74 69 6f 6e 2d 69 6e 66 6f 20 72 75 6e nection-info run
3650: 2d 69 64 20 61 72 65 61 2d 64 61 74 29 0a 20 20 -id area-dat).
3660: 28 6c 65 74 20 28 28 74 72 61 6e 73 70 6f 72 74 (let ((transport
3670: 20 28 6d 65 67 61 74 65 73 74 3a 61 72 65 61 2d (megatest:area-
3680: 74 72 61 6e 73 70 6f 72 74 20 61 72 65 61 2d 64 transport area-d
3690: 61 74 29 29 0a 09 28 74 6f 70 70 61 74 68 20 20 at))..(toppath
36a0: 20 28 6d 65 67 61 74 65 73 74 3a 61 72 65 61 2d (megatest:area-
36b0: 70 61 74 68 20 20 20 20 20 20 61 72 65 61 2d 64 path area-d
36c0: 61 74 29 29 29 0a 20 20 20 20 28 63 61 73 65 20 at))). (case
36d0: 74 72 61 6e 73 70 6f 72 74 0a 20 20 20 20 20 20 transport.
36e0: 28 28 68 74 74 70 29 28 72 6d 74 3a 73 65 6e 64 ((http)(rmt:send
36f0: 2d 72 65 63 65 69 76 65 2d 6e 6f 2d 61 75 74 6f -receive-no-auto
3700: 2d 63 6c 69 65 6e 74 2d 73 65 74 75 70 20 63 6f -client-setup co
3710: 6e 6e 65 63 74 69 6f 6e 2d 69 6e 66 6f 20 27 6c nnection-info 'l
3720: 6f 67 69 6e 20 72 75 6e 2d 69 64 20 20 28 6c 69 ogin run-id (li
3730: 73 74 20 74 6f 70 70 61 74 68 20 6d 65 67 61 74 st toppath megat
3740: 65 73 74 2d 76 65 72 73 69 6f 6e 20 72 75 6e 2d est-version run-
3750: 69 64 20 2a 6d 79 2d 63 6c 69 65 6e 74 2d 73 69 id *my-client-si
3760: 67 6e 61 74 75 72 65 2a 29 20 61 72 65 61 2d 64 gnature*) area-d
3770: 61 74 29 29 0a 20 20 20 20 20 20 28 28 6e 6d 73 at)). ((nms
3780: 67 29 28 6e 6d 73 67 2d 74 72 61 6e 73 70 6f 72 g)(nmsg-transpor
3790: 74 3a 63 6c 69 65 6e 74 2d 61 70 69 2d 73 65 6e t:client-api-sen
37a0: 64 2d 72 65 63 65 69 76 65 20 72 75 6e 2d 69 64 d-receive run-id
37b0: 20 63 6f 6e 6e 65 63 74 69 6f 6e 2d 69 6e 66 6f connection-info
37c0: 20 27 6c 6f 67 69 6e 20 28 6c 69 73 74 20 74 6f 'login (list to
37d0: 70 70 61 74 68 20 6d 65 67 61 74 65 73 74 2d 76 ppath megatest-v
37e0: 65 72 73 69 6f 6e 20 72 75 6e 2d 69 64 20 2a 6d ersion run-id *m
37f0: 79 2d 63 6c 69 65 6e 74 2d 73 69 67 6e 61 74 75 y-client-signatu
3800: 72 65 2a 29 20 61 72 65 61 2d 64 61 74 29 29 29 re*) area-dat)))
3810: 29 29 0a 0a 3b 3b 20 68 61 6e 64 20 6f 66 66 20 ))..;; hand off
3820: 61 20 63 61 6c 6c 20 74 6f 20 6f 6e 65 20 6f 66 a call to one of
3830: 20 74 68 65 20 64 62 3a 71 75 65 72 69 65 73 20 the db:queries
3840: 73 74 61 74 65 6d 65 6e 74 73 0a 3b 3b 20 61 64 statements.;; ad
3850: 64 65 64 20 72 75 6e 2d 69 64 20 74 6f 20 6d 61 ded run-id to ma
3860: 6b 65 20 6c 6f 6f 6b 69 6e 67 20 75 70 20 74 68 ke looking up th
3870: 65 20 63 6f 72 72 65 63 74 20 64 62 20 70 6f 73 e correct db pos
3880: 73 69 62 6c 65 20 0a 3b 3b 0a 28 64 65 66 69 6e sible .;;.(defin
3890: 65 20 28 72 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 e (rmt:general-c
38a0: 61 6c 6c 20 73 74 6d 74 6e 61 6d 65 20 72 75 6e all stmtname run
38b0: 2d 69 64 20 61 72 65 61 2d 64 61 74 20 2e 20 70 -id area-dat . p
38c0: 61 72 61 6d 73 29 0a 20 20 28 72 6d 74 3a 73 65 arams). (rmt:se
38d0: 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 6e 65 nd-receive 'gene
38e0: 72 61 6c 2d 63 61 6c 6c 20 72 75 6e 2d 69 64 20 ral-call run-id
38f0: 28 61 70 70 65 6e 64 20 28 6c 69 73 74 20 73 74 (append (list st
3900: 6d 74 6e 61 6d 65 20 72 75 6e 2d 69 64 29 20 70 mtname run-id) p
3910: 61 72 61 6d 73 29 20 61 72 65 61 2d 64 61 74 29 arams) area-dat)
3920: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a )..(define (rmt:
3930: 73 79 6e 63 2d 69 6e 6d 65 6d 2d 3e 64 62 20 72 sync-inmem->db r
3940: 75 6e 2d 69 64 20 61 72 65 61 2d 64 61 74 29 0a un-id area-dat).
3950: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
3960: 69 76 65 20 27 73 79 6e 63 2d 69 6e 6d 65 6d 2d ive 'sync-inmem-
3970: 3e 64 62 20 72 75 6e 2d 69 64 20 27 28 29 20 61 >db run-id '() a
3980: 72 65 61 2d 64 61 74 29 29 0a 0a 28 64 65 66 69 rea-dat))..(defi
3990: 6e 65 20 28 72 6d 74 3a 73 64 62 2d 71 72 79 20 ne (rmt:sdb-qry
39a0: 71 72 79 20 76 61 6c 20 72 75 6e 2d 69 64 20 61 qry val run-id a
39b0: 72 65 61 2d 64 61 74 29 0a 20 20 3b 3b 20 61 64 rea-dat). ;; ad
39c0: 64 20 63 61 63 68 69 6e 67 20 69 66 20 71 72 79 d caching if qry
39d0: 20 69 73 20 27 67 65 74 69 64 20 6f 72 20 27 67 is 'getid or 'g
39e0: 65 74 73 74 72 0a 20 20 28 72 6d 74 3a 73 65 6e etstr. (rmt:sen
39f0: 64 2d 72 65 63 65 69 76 65 20 27 73 64 62 2d 71 d-receive 'sdb-q
3a00: 72 79 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 ry run-id (list
3a10: 71 72 79 20 76 61 6c 29 20 61 72 65 61 2d 64 61 qry val) area-da
3a20: 74 29 29 0a 0a 3b 3b 20 4e 4f 54 20 43 4f 4d 50 t))..;; NOT COMP
3a30: 4c 45 54 45 44 0a 28 64 65 66 69 6e 65 20 28 72 LETED.(define (r
3a40: 6d 74 3a 72 75 6e 74 65 73 74 73 20 75 73 65 72 mt:runtests user
3a50: 20 72 75 6e 2d 69 64 20 74 65 73 74 70 61 74 74 run-id testpatt
3a60: 20 70 61 72 61 6d 73 20 61 72 65 61 2d 64 61 74 params area-dat
3a70: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
3a80: 63 65 69 76 65 20 27 72 75 6e 74 65 73 74 73 20 ceive 'runtests
3a90: 72 75 6e 2d 69 64 20 74 65 73 74 70 61 74 74 20 run-id testpatt
3aa0: 61 72 65 61 2d 64 61 74 29 29 0a 0a 3b 3b 3d 3d area-dat))..;;==
3ab0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3ac0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3ad0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3ae0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3af0: 3d 3d 3d 3d 0a 3b 3b 20 20 4b 20 45 20 59 20 53 ====.;; K E Y S
3b00: 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;============
3b10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3b20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3b30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3b40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 54 ==========..;; T
3b50: 68 65 73 65 20 72 65 71 75 69 72 65 20 72 75 6e hese require run
3b60: 2d 69 64 20 62 65 63 61 75 73 65 20 74 68 65 20 -id because the
3b70: 76 61 6c 75 65 73 20 63 6f 6d 65 20 66 72 6f 6d values come from
3b80: 20 74 68 65 20 72 75 6e 21 0a 3b 3b 0a 28 64 65 the run!.;;.(de
3b90: 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 6b 65 fine (rmt:get-ke
3ba0: 79 2d 76 61 6c 2d 70 61 69 72 73 20 72 75 6e 2d y-val-pairs run-
3bb0: 69 64 20 61 72 65 61 2d 64 61 74 29 0a 20 20 28 id area-dat). (
3bc0: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
3bd0: 20 27 67 65 74 2d 6b 65 79 2d 76 61 6c 2d 70 61 'get-key-val-pa
3be0: 69 72 73 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 irs run-id (list
3bf0: 20 72 75 6e 2d 69 64 29 20 61 72 65 61 2d 64 61 run-id) area-da
3c00: 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d t))..(define (rm
3c10: 74 3a 67 65 74 2d 6b 65 79 73 20 61 72 65 61 2d t:get-keys area-
3c20: 64 61 74 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 dat). (rmt:send
3c30: 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 6b 65 -receive 'get-ke
3c40: 79 73 20 23 66 20 27 28 29 20 61 72 65 61 2d 64 ys #f '() area-d
3c50: 61 74 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d at))..;;========
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 3d 3d 3d 0a 3b ==============.;
3ca0: 3b 20 20 54 20 45 20 53 20 54 20 53 0a 3b 3b 3d ; T E S T S.;;=
3cb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3cc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3cd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3ce0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3cf0: 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 =====..(define (
3d00: 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 64 20 rmt:get-test-id
3d10: 72 75 6e 2d 69 64 20 74 65 73 74 6e 61 6d 65 20 run-id testname
3d20: 69 74 65 6d 2d 70 61 74 68 20 61 72 65 61 2d 64 item-path area-d
3d30: 61 74 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d at). (rmt:send-
3d40: 72 65 63 65 69 76 65 20 27 67 65 74 2d 74 65 73 receive 'get-tes
3d50: 74 2d 69 64 20 72 75 6e 2d 69 64 20 28 6c 69 73 t-id run-id (lis
3d60: 74 20 72 75 6e 2d 69 64 20 74 65 73 74 6e 61 6d t run-id testnam
3d70: 65 20 69 74 65 6d 2d 70 61 74 68 29 20 61 72 65 e item-path) are
3d80: 61 2d 64 61 74 29 29 0a 0a 28 64 65 66 69 6e 65 a-dat))..(define
3d90: 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 (rmt:get-test-i
3da0: 6e 66 6f 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 nfo-by-id run-id
3db0: 20 74 65 73 74 2d 69 64 20 61 72 65 61 2d 64 61 test-id area-da
3dc0: 74 29 0a 20 20 28 69 66 20 28 61 6e 64 20 28 6e t). (if (and (n
3dd0: 75 6d 62 65 72 3f 20 72 75 6e 2d 69 64 29 28 6e umber? run-id)(n
3de0: 75 6d 62 65 72 3f 20 74 65 73 74 2d 69 64 29 29 umber? test-id))
3df0: 0a 20 20 20 20 20 20 28 72 6d 74 3a 73 65 6e 64 . (rmt:send
3e00: 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 74 65 -receive 'get-te
3e10: 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 72 75 st-info-by-id ru
3e20: 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 n-id (list run-i
3e30: 64 20 74 65 73 74 2d 69 64 29 20 61 72 65 61 2d d test-id) area-
3e40: 64 61 74 29 0a 20 20 20 20 20 20 28 62 65 67 69 dat). (begi
3e50: 6e 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 n..(debug:print
3e60: 30 20 22 57 41 52 4e 49 4e 47 3a 20 42 61 64 20 0 "WARNING: Bad
3e70: 64 61 74 61 20 68 61 6e 64 65 64 20 74 6f 20 72 data handed to r
3e80: 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f mt:get-test-info
3e90: 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 3d 22 20 -by-id run-id="
3ea0: 72 75 6e 2d 69 64 20 22 2c 20 74 65 73 74 2d 69 run-id ", test-i
3eb0: 64 3d 22 20 74 65 73 74 2d 69 64 29 0a 09 28 70 d=" test-id)..(p
3ec0: 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 20 rint-call-chain
3ed0: 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 (current-error-p
3ee0: 6f 72 74 29 29 0a 09 23 66 29 29 29 0a 0a 28 64 ort))..#f)))..(d
3ef0: 65 66 69 6e 65 20 28 72 6d 74 3a 74 65 73 74 2d efine (rmt:test-
3f00: 67 65 74 2d 72 75 6e 64 69 72 2d 66 72 6f 6d 2d get-rundir-from-
3f10: 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 74 test-id run-id t
3f20: 65 73 74 2d 69 64 20 61 72 65 61 2d 64 61 74 29 est-id area-dat)
3f30: 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 . (rmt:send-rec
3f40: 65 69 76 65 20 27 74 65 73 74 2d 67 65 74 2d 72 eive 'test-get-r
3f50: 75 6e 64 69 72 2d 66 72 6f 6d 2d 74 65 73 74 2d undir-from-test-
3f60: 69 64 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 id run-id (list
3f70: 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 20 run-id test-id)
3f80: 61 72 65 61 2d 64 61 74 29 29 0a 0a 28 64 65 66 area-dat))..(def
3f90: 69 6e 65 20 28 72 6d 74 3a 6f 70 65 6e 2d 74 65 ine (rmt:open-te
3fa0: 73 74 2d 64 62 2d 62 79 2d 74 65 73 74 2d 69 64 st-db-by-test-id
3fb0: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 run-id test-id
3fc0: 61 72 65 61 2d 64 61 74 20 23 21 6b 65 79 20 28 area-dat #!key (
3fd0: 77 6f 72 6b 2d 61 72 65 61 20 23 66 29 29 0a 20 work-area #f)).
3fe0: 20 28 6c 65 74 2a 20 28 28 74 65 73 74 2d 70 61 (let* ((test-pa
3ff0: 74 68 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 th (if (string?
4000: 77 6f 72 6b 2d 61 72 65 61 29 0a 09 09 09 77 6f work-area)....wo
4010: 72 6b 2d 61 72 65 61 0a 09 09 09 28 72 6d 74 3a rk-area....(rmt:
4020: 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 2d test-get-rundir-
4030: 66 72 6f 6d 2d 74 65 73 74 2d 69 64 20 72 75 6e from-test-id run
4040: 2d 69 64 20 74 65 73 74 2d 69 64 20 61 72 65 61 -id test-id area
4050: 2d 64 61 74 29 29 29 29 0a 20 20 20 20 28 64 65 -dat)))). (de
4060: 62 75 67 3a 70 72 69 6e 74 20 33 20 22 54 45 53 bug:print 3 "TES
4070: 54 20 50 41 54 48 3a 20 22 20 74 65 73 74 2d 70 T PATH: " test-p
4080: 61 74 68 29 0a 20 20 20 20 28 6f 70 65 6e 2d 74 ath). (open-t
4090: 65 73 74 2d 64 62 20 74 65 73 74 2d 70 61 74 68 est-db test-path
40a0: 20 61 72 65 61 2d 64 61 74 29 29 29 0a 0a 3b 3b area-dat)))..;;
40b0: 20 57 41 52 4e 49 4e 47 3a 20 54 68 69 73 20 63 WARNING: This c
40c0: 75 72 72 65 6e 74 6c 79 20 62 79 70 61 73 73 65 urrently bypasse
40d0: 73 20 74 68 65 20 74 72 61 6e 73 61 63 74 69 6f s the transactio
40e0: 6e 20 77 72 61 70 70 65 64 20 77 72 69 74 65 73 n wrapped writes
40f0: 20 73 79 73 74 65 6d 0a 28 64 65 66 69 6e 65 20 system.(define
4100: 28 72 6d 74 3a 74 65 73 74 2d 73 65 74 2d 73 74 (rmt:test-set-st
4110: 61 74 65 2d 73 74 61 74 75 73 2d 62 79 2d 69 64 ate-status-by-id
4120: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 run-id test-id
4130: 6e 65 77 73 74 61 74 65 20 6e 65 77 73 74 61 74 newstate newstat
4140: 75 73 20 6e 65 77 63 6f 6d 6d 65 6e 74 20 61 72 us newcomment ar
4150: 65 61 2d 64 61 74 29 0a 20 20 28 72 6d 74 3a 73 ea-dat). (rmt:s
4160: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 74 65 73 end-receive 'tes
4170: 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 t-set-state-stat
4180: 75 73 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 us-by-id run-id
4190: 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 (list run-id tes
41a0: 74 2d 69 64 20 6e 65 77 73 74 61 74 65 20 6e 65 t-id newstate ne
41b0: 77 73 74 61 74 75 73 20 6e 65 77 63 6f 6d 6d 65 wstatus newcomme
41c0: 6e 74 29 20 61 72 65 61 2d 64 61 74 29 29 0a 0a nt) area-dat))..
41d0: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 73 65 74 (define (rmt:set
41e0: 2d 74 65 73 74 73 2d 73 74 61 74 65 2d 73 74 61 -tests-state-sta
41f0: 74 75 73 20 72 75 6e 2d 69 64 20 74 65 73 74 6e tus run-id testn
4200: 61 6d 65 73 20 63 75 72 72 73 74 61 74 65 20 63 ames currstate c
4210: 75 72 72 73 74 61 74 75 73 20 6e 65 77 73 74 61 urrstatus newsta
4220: 74 65 20 6e 65 77 73 74 61 74 75 73 20 61 72 65 te newstatus are
4230: 61 2d 64 61 74 29 0a 20 20 28 72 6d 74 3a 73 65 a-dat). (rmt:se
4240: 6e 64 2d 72 65 63 65 69 76 65 20 27 73 65 74 2d nd-receive 'set-
4250: 74 65 73 74 73 2d 73 74 61 74 65 2d 73 74 61 74 tests-state-stat
4260: 75 73 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 us run-id (list
4270: 72 75 6e 2d 69 64 20 74 65 73 74 6e 61 6d 65 73 run-id testnames
4280: 20 63 75 72 72 73 74 61 74 65 20 63 75 72 72 73 currstate currs
4290: 74 61 74 75 73 20 6e 65 77 73 74 61 74 65 20 6e tatus newstate n
42a0: 65 77 73 74 61 74 75 73 29 20 61 72 65 61 2d 64 ewstatus) area-d
42b0: 61 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 at))..(define (r
42c0: 6d 74 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 mt:get-tests-for
42d0: 2d 72 75 6e 20 72 75 6e 2d 69 64 20 74 65 73 74 -run run-id test
42e0: 70 61 74 74 20 73 74 61 74 65 73 20 73 74 61 74 patt states stat
42f0: 75 73 65 73 20 6f 66 66 73 65 74 20 6c 69 6d 69 uses offset limi
4300: 74 20 6e 6f 74 2d 69 6e 20 73 6f 72 74 2d 62 79 t not-in sort-by
4310: 20 73 6f 72 74 2d 6f 72 64 65 72 20 71 72 79 76 sort-order qryv
4320: 61 6c 73 20 61 72 65 61 2d 64 61 74 29 0a 20 20 als area-dat).
4330: 28 69 66 20 28 6e 75 6d 62 65 72 3f 20 72 75 6e (if (number? run
4340: 2d 69 64 29 0a 20 20 20 20 20 20 28 72 6d 74 3a -id). (rmt:
4350: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 send-receive 'ge
4360: 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 t-tests-for-run
4370: 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e run-id (list run
4380: 2d 69 64 20 74 65 73 74 70 61 74 74 20 73 74 61 -id testpatt sta
4390: 74 65 73 20 73 74 61 74 75 73 65 73 20 6f 66 66 tes statuses off
43a0: 73 65 74 20 6c 69 6d 69 74 20 6e 6f 74 2d 69 6e set limit not-in
43b0: 20 73 6f 72 74 2d 62 79 20 73 6f 72 74 2d 6f 72 sort-by sort-or
43c0: 64 65 72 20 71 72 79 76 61 6c 73 29 20 61 72 65 der qryvals) are
43d0: 61 2d 64 61 74 29 0a 20 20 20 20 20 20 28 62 65 a-dat). (be
43e0: 67 69 6e 0a 09 28 64 65 62 75 67 3a 70 72 69 6e gin..(debug:prin
43f0: 74 20 22 45 52 52 4f 52 3a 20 72 6d 74 3a 67 65 t "ERROR: rmt:ge
4400: 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 t-tests-for-run
4410: 63 61 6c 6c 65 64 20 77 69 74 68 20 62 61 64 20 called with bad
4420: 72 75 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 64 29 run-id=" run-id)
4430: 0a 09 28 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 ..(print-call-ch
4440: 61 69 6e 20 28 63 75 72 72 65 6e 74 2d 65 72 72 ain (current-err
4450: 6f 72 2d 70 6f 72 74 29 29 0a 09 27 28 29 29 29 or-port))..'()))
4460: 29 0a 0a 3b 3b 20 67 65 74 20 73 74 75 66 66 20 )..;; get stuff
4470: 76 69 61 20 73 79 6e 63 68 61 73 68 20 0a 28 64 via synchash .(d
4480: 65 66 69 6e 65 20 28 72 6d 74 3a 73 79 6e 63 68 efine (rmt:synch
4490: 61 73 68 2d 67 65 74 20 72 75 6e 2d 69 64 20 70 ash-get run-id p
44a0: 72 6f 63 20 73 79 6e 63 6b 65 79 20 6b 65 79 6e roc synckey keyn
44b0: 75 6d 20 70 61 72 61 6d 73 20 61 72 65 61 2d 64 um params area-d
44c0: 61 74 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d at). (rmt:send-
44d0: 72 65 63 65 69 76 65 20 27 73 79 6e 63 68 61 73 receive 'synchas
44e0: 68 2d 67 65 74 20 72 75 6e 2d 69 64 20 28 6c 69 h-get run-id (li
44f0: 73 74 20 72 75 6e 2d 69 64 20 70 72 6f 63 20 73 st run-id proc s
4500: 79 6e 63 6b 65 79 20 6b 65 79 6e 75 6d 20 70 61 ynckey keynum pa
4510: 72 61 6d 73 29 20 61 72 65 61 2d 64 61 74 29 29 rams) area-dat))
4520: 0a 0a 3b 3b 20 49 44 45 41 3a 20 54 68 72 65 61 ..;; IDEA: Threa
4530: 64 69 66 79 20 74 68 65 73 65 20 2d 20 74 68 65 dify these - the
4540: 79 20 73 70 65 6e 64 20 61 20 6c 6f 74 20 6f 66 y spend a lot of
4550: 20 74 69 6d 65 20 77 61 69 74 69 6e 67 20 2e 2e time waiting ..
4560: 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 72 6d ..;;.(define (rm
4570: 74 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d t:get-tests-for-
4580: 72 75 6e 73 2d 6d 69 6e 64 61 74 61 20 72 75 6e runs-mindata run
4590: 2d 69 64 73 20 74 65 73 74 70 61 74 74 20 73 74 -ids testpatt st
45a0: 61 74 65 73 20 73 74 61 74 75 73 20 6e 6f 74 2d ates status not-
45b0: 69 6e 20 61 72 65 61 2d 64 61 74 29 0a 20 20 28 in area-dat). (
45c0: 6c 65 74 20 28 28 6d 75 6c 74 69 2d 72 75 6e 2d let ((multi-run-
45d0: 6d 75 74 65 78 20 28 6d 61 6b 65 2d 6d 75 74 65 mutex (make-mute
45e0: 78 29 29 0a 09 28 72 75 6e 2d 69 64 2d 6c 69 73 x))..(run-id-lis
45f0: 74 20 28 69 66 20 72 75 6e 2d 69 64 73 0a 09 09 t (if run-ids...
4600: 09 20 72 75 6e 2d 69 64 73 0a 09 09 09 20 28 72 . run-ids.... (r
4610: 6d 74 3a 67 65 74 2d 61 6c 6c 2d 72 75 6e 2d 69 mt:get-all-run-i
4620: 64 73 29 29 29 0a 09 28 72 65 73 75 6c 74 20 20 ds)))..(result
4630: 20 20 20 20 27 28 29 29 29 0a 20 20 20 20 28 69 '())). (i
4640: 66 20 28 6e 75 6c 6c 3f 20 72 75 6e 2d 69 64 2d f (null? run-id-
4650: 6c 69 73 74 29 0a 09 27 28 29 0a 09 28 6c 65 74 list)..'()..(let
4660: 20 6c 6f 6f 70 20 28 28 68 65 64 20 20 20 20 20 loop ((hed
4670: 28 63 61 72 20 72 75 6e 2d 69 64 2d 6c 69 73 74 (car run-id-list
4680: 29 29 0a 09 09 20 20 20 28 74 61 6c 20 20 20 20 ))... (tal
4690: 20 28 63 64 72 20 72 75 6e 2d 69 64 2d 6c 69 73 (cdr run-id-lis
46a0: 74 29 29 0a 09 09 20 20 20 28 74 68 72 65 61 64 t))... (thread
46b0: 73 20 27 28 29 29 29 0a 09 20 20 28 69 66 20 28 s '())).. (if (
46c0: 3e 20 28 6c 65 6e 67 74 68 20 74 68 72 65 61 64 > (length thread
46d0: 73 29 20 35 29 0a 09 20 20 20 20 20 20 28 6c 6f s) 5).. (lo
46e0: 6f 70 20 68 65 64 20 74 61 6c 20 28 66 69 6c 74 op hed tal (filt
46f0: 65 72 20 28 6c 61 6d 62 64 61 20 28 74 68 29 28 er (lambda (th)(
4700: 6e 6f 74 20 28 6d 65 6d 62 65 72 20 28 74 68 72 not (member (thr
4710: 65 61 64 2d 73 74 61 74 65 20 74 68 29 20 27 28 ead-state th) '(
4720: 74 65 72 6d 69 6e 61 74 65 64 20 64 65 61 64 29 terminated dead)
4730: 29 29 29 20 74 68 72 65 61 64 73 29 29 0a 09 20 ))) threads))..
4740: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 6e 65 77 (let* ((new
4750: 74 68 72 65 61 64 20 28 6d 61 6b 65 2d 74 68 72 thread (make-thr
4760: 65 61 64 0a 09 09 09 09 20 28 6c 61 6d 62 64 61 ead..... (lambda
4770: 20 28 29 0a 09 09 09 09 20 20 20 28 6c 65 74 20 ()..... (let
4780: 28 28 72 65 73 20 28 72 6d 74 3a 73 65 6e 64 2d ((res (rmt:send-
4790: 72 65 63 65 69 76 65 20 27 67 65 74 2d 74 65 73 receive 'get-tes
47a0: 74 73 2d 66 6f 72 2d 72 75 6e 2d 6d 69 6e 64 61 ts-for-run-minda
47b0: 74 61 20 68 65 64 20 28 6c 69 73 74 20 68 65 64 ta hed (list hed
47c0: 20 74 65 73 74 70 61 74 74 20 73 74 61 74 65 73 testpatt states
47d0: 20 73 74 61 74 75 73 20 6e 6f 74 2d 69 6e 29 20 status not-in)
47e0: 61 72 65 61 2d 64 61 74 29 29 29 0a 09 09 09 09 area-dat))).....
47f0: 20 20 20 20 20 28 69 66 20 28 6c 69 73 74 3f 20 (if (list?
4800: 72 65 73 29 0a 09 09 09 09 09 20 28 62 65 67 69 res)...... (begi
4810: 6e 0a 09 09 09 09 09 20 20 20 28 6d 75 74 65 78 n...... (mutex
4820: 2d 6c 6f 63 6b 21 20 6d 75 6c 74 69 2d 72 75 6e -lock! multi-run
4830: 2d 6d 75 74 65 78 29 0a 09 09 09 09 09 20 20 20 -mutex)......
4840: 28 73 65 74 21 20 72 65 73 75 6c 74 20 28 61 70 (set! result (ap
4850: 70 65 6e 64 20 72 65 73 75 6c 74 20 72 65 73 29 pend result res)
4860: 29 0a 09 09 09 09 09 20 20 20 28 6d 75 74 65 78 )...... (mutex
4870: 2d 75 6e 6c 6f 63 6b 21 20 6d 75 6c 74 69 2d 72 -unlock! multi-r
4880: 75 6e 2d 6d 75 74 65 78 29 29 0a 09 09 09 09 09 un-mutex))......
4890: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
48a0: 22 45 52 52 4f 52 3a 20 67 65 74 2d 74 65 73 74 "ERROR: get-test
48b0: 73 2d 66 6f 72 2d 72 75 6e 2d 6d 69 6e 64 61 74 s-for-run-mindat
48c0: 61 20 66 61 69 6c 65 64 20 66 6f 72 20 72 75 6e a failed for run
48d0: 2d 69 64 20 22 20 68 65 64 20 22 2c 20 74 65 73 -id " hed ", tes
48e0: 74 70 61 74 74 20 22 20 74 65 73 74 70 61 74 74 tpatt " testpatt
48f0: 20 22 2c 20 73 74 61 74 65 73 20 22 20 73 74 61 ", states " sta
4900: 74 65 73 20 22 2c 20 73 74 61 74 75 73 20 22 20 tes ", status "
4910: 73 74 61 74 75 73 20 22 2c 20 6e 6f 74 2d 69 6e status ", not-in
4920: 20 22 20 6e 6f 74 2d 69 6e 29 29 29 29 0a 09 09 " not-in))))...
4930: 09 09 20 28 63 6f 6e 63 20 22 6d 75 6c 74 69 2d .. (conc "multi-
4940: 72 75 6e 2d 74 68 72 65 61 64 20 66 6f 72 20 72 run-thread for r
4950: 75 6e 2d 69 64 20 22 20 68 65 64 29 29 29 0a 09 un-id " hed)))..
4960: 09 20 20 20 20 20 28 6e 65 77 74 68 72 65 61 64 . (newthread
4970: 73 20 28 63 6f 6e 73 20 6e 65 77 74 68 72 65 61 s (cons newthrea
4980: 64 20 74 68 72 65 61 64 73 29 29 29 0a 09 09 28 d threads)))...(
4990: 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 6e 65 thread-start! ne
49a0: 77 74 68 72 65 61 64 29 0a 09 09 28 74 68 72 65 wthread)...(thre
49b0: 61 64 2d 73 6c 65 65 70 21 20 30 2e 35 29 20 3b ad-sleep! 0.5) ;
49c0: 3b 20 67 69 76 65 20 74 68 61 74 20 74 68 72 65 ; give that thre
49d0: 61 64 20 73 6f 6d 65 20 74 69 6d 65 20 74 6f 20 ad some time to
49e0: 73 74 61 72 74 0a 09 09 28 69 66 20 28 6e 75 6c start...(if (nul
49f0: 6c 3f 20 74 61 6c 29 0a 09 09 20 20 20 20 6e 65 l? tal)... ne
4a00: 77 74 68 72 65 61 64 73 0a 09 09 20 20 20 20 28 wthreads... (
4a10: 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 loop (car tal)(c
4a20: 64 72 20 74 61 6c 29 20 6e 65 77 74 68 72 65 61 dr tal) newthrea
4a30: 64 73 29 29 29 29 29 29 0a 20 20 20 20 72 65 73 ds)))))). res
4a40: 75 6c 74 29 29 0a 0a 3b 3b 20 3b 3b 20 49 44 45 ult))..;; ;; IDE
4a50: 41 3a 20 54 68 72 65 61 64 69 66 79 20 74 68 65 A: Threadify the
4a60: 73 65 20 2d 20 74 68 65 79 20 73 70 65 6e 64 20 se - they spend
4a70: 61 20 6c 6f 74 20 6f 66 20 74 69 6d 65 20 77 61 a lot of time wa
4a80: 69 74 69 6e 67 20 2e 2e 2e 0a 3b 3b 20 3b 3b 0a iting ....;; ;;.
4a90: 3b 3b 20 28 64 65 66 69 6e 65 20 28 72 6d 74 3a ;; (define (rmt:
4aa0: 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 get-tests-for-ru
4ab0: 6e 73 2d 6d 69 6e 64 61 74 61 20 72 75 6e 2d 69 ns-mindata run-i
4ac0: 64 73 20 74 65 73 74 70 61 74 74 20 73 74 61 74 ds testpatt stat
4ad0: 65 73 20 73 74 61 74 75 73 20 6e 6f 74 2d 69 6e es status not-in
4ae0: 29 0a 3b 3b 20 20 20 28 6c 65 74 20 28 28 72 75 ).;; (let ((ru
4af0: 6e 2d 69 64 2d 6c 69 73 74 20 28 69 66 20 72 75 n-id-list (if ru
4b00: 6e 2d 69 64 73 0a 3b 3b 20 09 09 09 20 72 75 6e n-ids.;; ... run
4b10: 2d 69 64 73 0a 3b 3b 20 09 09 09 20 28 72 6d 74 -ids.;; ... (rmt
4b20: 3a 67 65 74 2d 61 6c 6c 2d 72 75 6e 2d 69 64 73 :get-all-run-ids
4b30: 29 29 29 29 0a 3b 3b 20 20 20 20 20 28 61 70 70 )))).;; (app
4b40: 6c 79 20 61 70 70 65 6e 64 20 28 6d 61 70 20 28 ly append (map (
4b50: 6c 61 6d 62 64 61 20 28 72 75 6e 2d 69 64 29 0a lambda (run-id).
4b60: 3b 3b 20 09 09 09 20 28 72 6d 74 3a 73 65 6e 64 ;; ... (rmt:send
4b70: 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 74 65 -receive 'get-te
4b80: 73 74 73 2d 66 6f 72 2d 72 75 6e 2d 6d 69 6e 64 sts-for-run-mind
4b90: 61 74 61 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 ata run-id (list
4ba0: 20 72 75 6e 2d 69 64 73 20 74 65 73 74 70 61 74 run-ids testpat
4bb0: 74 20 73 74 61 74 65 73 20 73 74 61 74 75 73 20 t states status
4bc0: 6e 6f 74 2d 69 6e 29 29 29 0a 3b 3b 20 09 09 20 not-in))).;; ..
4bd0: 20 20 20 20 20 20 72 75 6e 2d 69 64 2d 6c 69 73 run-id-lis
4be0: 74 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 t))))..(define (
4bf0: 72 6d 74 3a 64 65 6c 65 74 65 2d 74 65 73 74 2d rmt:delete-test-
4c00: 72 65 63 6f 72 64 73 20 72 75 6e 2d 69 64 20 74 records run-id t
4c10: 65 73 74 2d 69 64 20 61 72 65 61 2d 64 61 74 29 est-id area-dat)
4c20: 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 . (rmt:send-rec
4c30: 65 69 76 65 20 27 64 65 6c 65 74 65 2d 74 65 73 eive 'delete-tes
4c40: 74 2d 72 65 63 6f 72 64 73 20 72 75 6e 2d 69 64 t-records run-id
4c50: 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 (list run-id te
4c60: 73 74 2d 69 64 29 20 61 72 65 61 2d 64 61 74 29 st-id) area-dat)
4c70: 29 0a 0a 3b 3b 20 54 68 69 73 20 69 73 20 6e 6f )..;; This is no
4c80: 74 20 6e 65 65 64 65 64 20 61 73 20 74 65 73 74 t needed as test
4c90: 20 73 74 65 70 73 20 61 72 65 20 64 65 6c 65 74 steps are delet
4ca0: 65 64 20 6f 6e 20 74 65 73 74 20 64 65 6c 65 74 ed on test delet
4cb0: 65 20 63 61 6c 6c 0a 3b 3b 0a 3b 3b 20 28 64 65 e call.;;.;; (de
4cc0: 66 69 6e 65 20 28 72 6d 74 3a 64 65 6c 65 74 65 fine (rmt:delete
4cd0: 2d 74 65 73 74 2d 73 74 65 70 2d 72 65 63 6f 72 -test-step-recor
4ce0: 64 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 ds run-id test-i
4cf0: 64 29 0a 3b 3b 20 20 20 28 72 6d 74 3a 73 65 6e d).;; (rmt:sen
4d00: 64 2d 72 65 63 65 69 76 65 20 27 64 65 6c 65 74 d-receive 'delet
4d10: 65 2d 74 65 73 74 2d 73 74 65 70 2d 72 65 63 6f e-test-step-reco
4d20: 72 64 73 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 rds run-id (list
4d30: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 run-id test-id)
4d40: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
4d50: 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 75 73 :test-set-status
4d60: 2d 73 74 61 74 65 20 72 75 6e 2d 69 64 20 74 65 -state run-id te
4d70: 73 74 2d 69 64 20 73 74 61 74 75 73 20 73 74 61 st-id status sta
4d80: 74 65 20 6d 73 67 20 61 72 65 61 2d 64 61 74 29 te msg area-dat)
4d90: 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 . (rmt:send-rec
4da0: 65 69 76 65 20 27 74 65 73 74 2d 73 65 74 2d 73 eive 'test-set-s
4db0: 74 61 74 75 73 2d 73 74 61 74 65 20 72 75 6e 2d tatus-state run-
4dc0: 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 id (list run-id
4dd0: 74 65 73 74 2d 69 64 20 73 74 61 74 75 73 20 73 test-id status s
4de0: 74 61 74 65 20 6d 73 67 29 20 61 72 65 61 2d 64 tate msg) area-d
4df0: 61 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 at))..(define (r
4e00: 6d 74 3a 74 65 73 74 2d 74 6f 70 6c 65 76 65 6c mt:test-toplevel
4e10: 2d 6e 75 6d 2d 69 74 65 6d 73 20 72 75 6e 2d 69 -num-items run-i
4e20: 64 20 74 65 73 74 2d 6e 61 6d 65 20 61 72 65 61 d test-name area
4e30: 2d 64 61 74 29 0a 20 20 28 72 6d 74 3a 73 65 6e -dat). (rmt:sen
4e40: 64 2d 72 65 63 65 69 76 65 20 27 74 65 73 74 2d d-receive 'test-
4e50: 74 6f 70 6c 65 76 65 6c 2d 6e 75 6d 2d 69 74 65 toplevel-num-ite
4e60: 6d 73 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 ms run-id (list
4e70: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
4e80: 29 20 61 72 65 61 2d 64 61 74 29 29 0a 0a 3b 3b ) area-dat))..;;
4e90: 20 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 (define (rmt:ge
4ea0: 74 2d 70 72 65 76 69 6f 75 73 2d 74 65 73 74 2d t-previous-test-
4eb0: 72 75 6e 2d 72 65 63 6f 72 64 20 72 75 6e 2d 69 run-record run-i
4ec0: 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d d test-name item
4ed0: 2d 70 61 74 68 29 0a 3b 3b 20 20 20 28 72 6d 74 -path).;; (rmt
4ee0: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 :send-receive 'g
4ef0: 65 74 2d 70 72 65 76 69 6f 75 73 2d 74 65 73 74 et-previous-test
4f00: 2d 72 75 6e 2d 72 65 63 6f 72 64 20 72 75 6e 2d -run-record run-
4f10: 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 id (list run-id
4f20: 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 test-name item-p
4f30: 61 74 68 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ath)))..(define
4f40: 28 72 6d 74 3a 67 65 74 2d 6d 61 74 63 68 69 6e (rmt:get-matchin
4f50: 67 2d 70 72 65 76 69 6f 75 73 2d 74 65 73 74 2d g-previous-test-
4f60: 72 75 6e 2d 72 65 63 6f 72 64 73 20 72 75 6e 2d run-records run-
4f70: 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 id test-name ite
4f80: 6d 2d 70 61 74 68 20 61 72 65 61 2d 64 61 74 29 m-path area-dat)
4f90: 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 . (rmt:send-rec
4fa0: 65 69 76 65 20 27 67 65 74 2d 6d 61 74 63 68 69 eive 'get-matchi
4fb0: 6e 67 2d 70 72 65 76 69 6f 75 73 2d 74 65 73 74 ng-previous-test
4fc0: 2d 72 75 6e 2d 72 65 63 6f 72 64 73 20 72 75 6e -run-records run
4fd0: 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 -id (list run-id
4fe0: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item-
4ff0: 70 61 74 68 29 20 61 72 65 61 2d 64 61 74 29 29 path) area-dat))
5000: 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 ..(define (rmt:t
5010: 65 73 74 2d 67 65 74 2d 6c 6f 67 66 69 6c 65 2d est-get-logfile-
5020: 69 6e 66 6f 20 72 75 6e 2d 69 64 20 74 65 73 74 info run-id test
5030: 2d 6e 61 6d 65 20 61 72 65 61 2d 64 61 74 29 0a -name area-dat).
5040: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
5050: 69 76 65 20 27 74 65 73 74 2d 67 65 74 2d 6c 6f ive 'test-get-lo
5060: 67 66 69 6c 65 2d 69 6e 66 6f 20 72 75 6e 2d 69 gfile-info run-i
5070: 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 d (list run-id t
5080: 65 73 74 2d 6e 61 6d 65 29 20 61 72 65 61 2d 64 est-name) area-d
5090: 61 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 at))..(define (r
50a0: 6d 74 3a 74 65 73 74 2d 67 65 74 2d 72 65 63 6f mt:test-get-reco
50b0: 72 64 73 2d 66 6f 72 2d 69 6e 64 65 78 2d 66 69 rds-for-index-fi
50c0: 6c 65 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e le run-id test-n
50d0: 61 6d 65 20 61 72 65 61 2d 64 61 74 29 0a 20 20 ame area-dat).
50e0: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
50f0: 65 20 27 74 65 73 74 2d 67 65 74 2d 72 65 63 6f e 'test-get-reco
5100: 72 64 73 2d 66 6f 72 2d 69 6e 64 65 78 2d 66 69 rds-for-index-fi
5110: 6c 65 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 le run-id (list
5120: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
5130: 29 20 61 72 65 61 2d 64 61 74 29 29 0a 0a 28 64 ) area-dat))..(d
5140: 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 74 efine (rmt:get-t
5150: 65 73 74 69 6e 66 6f 2d 73 74 61 74 65 2d 73 74 estinfo-state-st
5160: 61 74 75 73 20 72 75 6e 2d 69 64 20 74 65 73 74 atus run-id test
5170: 2d 69 64 20 61 72 65 61 2d 64 61 74 29 0a 20 20 -id area-dat).
5180: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
5190: 65 20 27 67 65 74 2d 74 65 73 74 69 6e 66 6f 2d e 'get-testinfo-
51a0: 73 74 61 74 65 2d 73 74 61 74 75 73 20 72 75 6e state-status run
51b0: 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 -id (list run-id
51c0: 20 74 65 73 74 2d 69 64 29 20 61 72 65 61 2d 64 test-id) area-d
51d0: 61 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 at))..(define (r
51e0: 6d 74 3a 74 65 73 74 2d 73 65 74 2d 6c 6f 67 21 mt:test-set-log!
51f0: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 run-id test-id
5200: 6c 6f 67 66 20 61 72 65 61 2d 64 61 74 29 0a 20 logf area-dat).
5210: 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 6c 6f (if (string? lo
5220: 67 66 29 28 72 6d 74 3a 67 65 6e 65 72 61 6c 2d gf)(rmt:general-
5230: 63 61 6c 6c 20 27 74 65 73 74 2d 73 65 74 2d 6c call 'test-set-l
5240: 6f 67 20 72 75 6e 2d 69 64 20 6c 6f 67 66 20 74 og run-id logf t
5250: 65 73 74 2d 69 64 20 61 72 65 61 2d 64 61 74 29 est-id area-dat)
5260: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
5270: 3a 74 65 73 74 2d 73 65 74 2d 74 6f 70 2d 70 72 :test-set-top-pr
5280: 6f 63 65 73 73 2d 70 69 64 20 72 75 6e 2d 69 64 ocess-pid run-id
5290: 20 74 65 73 74 2d 69 64 20 70 69 64 20 61 72 65 test-id pid are
52a0: 61 2d 64 61 74 29 0a 20 20 28 72 6d 74 3a 73 65 a-dat). (rmt:se
52b0: 6e 64 2d 72 65 63 65 69 76 65 20 27 74 65 73 74 nd-receive 'test
52c0: 2d 73 65 74 2d 74 6f 70 2d 70 72 6f 63 65 73 73 -set-top-process
52d0: 2d 70 69 64 20 72 75 6e 2d 69 64 20 28 6c 69 73 -pid run-id (lis
52e0: 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 t run-id test-id
52f0: 20 70 69 64 29 20 61 72 65 61 2d 64 61 74 29 29 pid) area-dat))
5300: 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 ..(define (rmt:t
5310: 65 73 74 2d 67 65 74 2d 74 6f 70 2d 70 72 6f 63 est-get-top-proc
5320: 65 73 73 2d 70 69 64 20 72 75 6e 2d 69 64 20 74 ess-pid run-id t
5330: 65 73 74 2d 69 64 20 61 72 65 61 2d 64 61 74 29 est-id area-dat)
5340: 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 . (rmt:send-rec
5350: 65 69 76 65 20 27 74 65 73 74 2d 67 65 74 2d 74 eive 'test-get-t
5360: 6f 70 2d 70 72 6f 63 65 73 73 2d 70 69 64 20 72 op-process-pid r
5370: 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d un-id (list run-
5380: 69 64 20 74 65 73 74 2d 69 64 29 20 61 72 65 61 id test-id) area
5390: 2d 64 61 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 -dat))..(define
53a0: 28 72 6d 74 3a 67 65 74 2d 72 75 6e 2d 69 64 73 (rmt:get-run-ids
53b0: 2d 6d 61 74 63 68 69 6e 67 2d 74 61 72 67 65 74 -matching-target
53c0: 20 6b 65 79 6e 61 6d 65 73 20 74 61 72 67 65 74 keynames target
53d0: 20 72 65 73 20 72 75 6e 6e 61 6d 65 20 74 65 73 res runname tes
53e0: 74 70 61 74 74 20 73 74 61 74 65 70 61 74 74 20 tpatt statepatt
53f0: 73 74 61 74 75 73 70 61 74 74 20 61 72 65 61 2d statuspatt area-
5400: 64 61 74 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 dat). (rmt:send
5410: 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 72 75 -receive 'get-ru
5420: 6e 2d 69 64 73 2d 6d 61 74 63 68 69 6e 67 2d 74 n-ids-matching-t
5430: 61 72 67 65 74 20 23 66 20 28 6c 69 73 74 20 6b arget #f (list k
5440: 65 79 6e 61 6d 65 73 20 74 61 72 67 65 74 20 72 eynames target r
5450: 65 73 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 70 es runname testp
5460: 61 74 74 20 73 74 61 74 65 70 61 74 74 20 73 74 att statepatt st
5470: 61 74 75 73 70 61 74 74 29 20 61 72 65 61 2d 64 atuspatt) area-d
5480: 61 74 29 29 0a 0a 3b 3b 20 4e 4f 54 45 3a 20 54 at))..;; NOTE: T
5490: 68 69 73 20 77 69 6c 6c 20 6f 70 65 6e 20 61 6e his will open an
54a0: 64 20 61 63 63 65 73 73 20 41 4c 4c 20 72 75 6e d access ALL run
54b0: 20 64 61 74 61 62 61 73 65 73 2e 20 0a 3b 3b 0a databases. .;;.
54c0: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 65 73 (define (rmt:tes
54d0: 74 2d 67 65 74 2d 70 61 74 68 73 2d 6d 61 74 63 t-get-paths-matc
54e0: 68 69 6e 67 2d 6b 65 79 6e 61 6d 65 73 2d 74 61 hing-keynames-ta
54f0: 72 67 65 74 2d 6e 65 77 20 6b 65 79 6e 61 6d 65 rget-new keyname
5500: 73 20 74 61 72 67 65 74 20 72 65 73 20 74 65 73 s target res tes
5510: 74 70 61 74 74 20 73 74 61 74 65 70 61 74 74 20 tpatt statepatt
5520: 73 74 61 74 75 73 70 61 74 74 20 72 75 6e 6e 61 statuspatt runna
5530: 6d 65 20 61 72 65 61 2d 64 61 74 29 0a 20 20 28 me area-dat). (
5540: 6c 65 74 20 28 28 72 75 6e 2d 69 64 73 20 28 72 let ((run-ids (r
5550: 6d 74 3a 67 65 74 2d 72 75 6e 2d 69 64 73 2d 6d mt:get-run-ids-m
5560: 61 74 63 68 69 6e 67 2d 74 61 72 67 65 74 20 6b atching-target k
5570: 65 79 6e 61 6d 65 73 20 74 61 72 67 65 74 20 72 eynames target r
5580: 65 73 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 70 es runname testp
5590: 61 74 74 20 73 74 61 74 65 70 61 74 74 20 73 74 att statepatt st
55a0: 61 74 75 73 70 61 74 74 20 61 72 65 61 2d 64 61 atuspatt area-da
55b0: 74 29 29 29 0a 20 20 20 20 28 61 70 70 6c 79 20 t))). (apply
55c0: 61 70 70 65 6e 64 20 0a 09 20 20 20 28 6d 61 70 append .. (map
55d0: 20 28 6c 61 6d 62 64 61 20 28 72 75 6e 2d 69 64 (lambda (run-id
55e0: 29 0a 09 09 20 20 28 72 6d 74 3a 73 65 6e 64 2d )... (rmt:send-
55f0: 72 65 63 65 69 76 65 20 27 74 65 73 74 2d 67 65 receive 'test-ge
5600: 74 2d 70 61 74 68 73 2d 6d 61 74 63 68 69 6e 67 t-paths-matching
5610: 2d 6b 65 79 6e 61 6d 65 73 2d 74 61 72 67 65 74 -keynames-target
5620: 2d 6e 65 77 20 72 75 6e 2d 69 64 20 28 6c 69 73 -new run-id (lis
5630: 74 20 72 75 6e 2d 69 64 20 6b 65 79 6e 61 6d 65 t run-id keyname
5640: 73 20 74 61 72 67 65 74 20 72 65 73 20 74 65 73 s target res tes
5650: 74 70 61 74 74 20 73 74 61 74 65 70 61 74 74 20 tpatt statepatt
5660: 73 74 61 74 75 73 70 61 74 74 20 72 75 6e 6e 61 statuspatt runna
5670: 6d 65 29 20 61 72 65 61 2d 64 61 74 29 29 0a 09 me) area-dat))..
5680: 20 20 20 72 75 6e 2d 69 64 73 29 29 29 29 0a 0a run-ids))))..
5690: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 (define (rmt:get
56a0: 2d 72 75 6e 2d 69 64 73 2d 6d 61 74 63 68 69 6e -run-ids-matchin
56b0: 67 20 6b 65 79 6e 61 6d 65 73 20 74 61 72 67 65 g keynames targe
56c0: 74 20 72 65 73 20 61 72 65 61 2d 64 61 74 29 0a t res area-dat).
56d0: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
56e0: 69 76 65 20 23 66 20 27 67 65 74 2d 72 75 6e 2d ive #f 'get-run-
56f0: 69 64 73 2d 6d 61 74 63 68 69 6e 67 20 28 6c 69 ids-matching (li
5700: 73 74 20 6b 65 79 6e 61 6d 65 73 20 74 61 72 67 st keynames targ
5710: 65 74 20 72 65 73 29 20 61 72 65 61 2d 64 61 74 et res) area-dat
5720: 29 20 61 72 65 61 2d 64 61 74 29 0a 0a 28 64 65 ) area-dat)..(de
5730: 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 70 72 fine (rmt:get-pr
5740: 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 72 75 ereqs-not-met ru
5750: 6e 2d 69 64 20 77 61 69 74 6f 6e 73 20 72 65 66 n-id waitons ref
5760: 2d 69 74 65 6d 2d 70 61 74 68 20 61 72 65 61 2d -item-path area-
5770: 64 61 74 20 23 21 6b 65 79 20 28 6d 6f 64 65 20 dat #!key (mode
5780: 27 28 6e 6f 72 6d 61 6c 29 29 29 0a 20 20 28 72 '(normal))). (r
5790: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
57a0: 27 67 65 74 2d 70 72 65 72 65 71 73 2d 6e 6f 74 'get-prereqs-not
57b0: 2d 6d 65 74 20 72 75 6e 2d 69 64 20 28 6c 69 73 -met run-id (lis
57c0: 74 20 72 75 6e 2d 69 64 20 77 61 69 74 6f 6e 73 t run-id waitons
57d0: 20 72 65 66 2d 69 74 65 6d 2d 70 61 74 68 20 6d ref-item-path m
57e0: 6f 64 65 29 20 61 72 65 61 2d 64 61 74 29 29 0a ode) area-dat)).
57f0: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 .(define (rmt: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 72 75 6e 2d 69 64 nning-for-run-id
5820: 20 72 75 6e 2d 69 64 20 61 72 65 61 2d 64 61 74 run-id area-dat
5830: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
5840: 63 65 69 76 65 20 27 67 65 74 2d 63 6f 75 6e 74 ceive 'get-count
5850: 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 2d 66 -tests-running-f
5860: 6f 72 2d 72 75 6e 2d 69 64 20 72 75 6e 2d 69 64 or-run-id run-id
5870: 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 29 20 61 (list run-id) a
5880: 72 65 61 2d 64 61 74 29 29 0a 0a 3b 3b 20 53 74 rea-dat))..;; St
5890: 61 74 69 73 74 69 63 61 6c 20 71 75 65 72 69 65 atistical querie
58a0: 73 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a s..(define (rmt:
58b0: 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d get-count-tests-
58c0: 72 75 6e 6e 69 6e 67 20 72 75 6e 2d 69 64 20 61 running run-id a
58d0: 72 65 61 2d 64 61 74 29 0a 20 20 28 72 6d 74 3a rea-dat). (rmt:
58e0: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 send-receive 'ge
58f0: 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d 72 75 t-count-tests-ru
5900: 6e 6e 69 6e 67 20 72 75 6e 2d 69 64 20 28 6c 69 nning run-id (li
5910: 73 74 20 72 75 6e 2d 69 64 29 20 61 72 65 61 2d st run-id) area-
5920: 64 61 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 dat))..(define (
5930: 72 6d 74 3a 67 65 74 2d 63 6f 75 6e 74 2d 74 65 rmt:get-count-te
5940: 73 74 73 2d 72 75 6e 6e 69 6e 67 2d 66 6f 72 2d sts-running-for-
5950: 74 65 73 74 6e 61 6d 65 20 72 75 6e 2d 69 64 20 testname run-id
5960: 74 65 73 74 6e 61 6d 65 20 61 72 65 61 2d 64 61 testname area-da
5970: 74 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 t). (rmt:send-r
5980: 65 63 65 69 76 65 20 27 67 65 74 2d 63 6f 75 6e eceive 'get-coun
5990: 74 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 2d t-tests-running-
59a0: 66 6f 72 2d 74 65 73 74 6e 61 6d 65 20 72 75 6e for-testname run
59b0: 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 -id (list run-id
59c0: 20 74 65 73 74 6e 61 6d 65 29 20 61 72 65 61 2d testname) area-
59d0: 64 61 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 dat))..(define (
59e0: 72 6d 74 3a 67 65 74 2d 63 6f 75 6e 74 2d 74 65 rmt:get-count-te
59f0: 73 74 73 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a sts-running-in-j
5a00: 6f 62 67 72 6f 75 70 20 72 75 6e 2d 69 64 20 6a obgroup run-id j
5a10: 6f 62 67 72 6f 75 70 20 61 72 65 61 2d 64 61 74 obgroup area-dat
5a20: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
5a30: 63 65 69 76 65 20 27 67 65 74 2d 63 6f 75 6e 74 ceive 'get-count
5a40: 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 2d 69 -tests-running-i
5a50: 6e 2d 6a 6f 62 67 72 6f 75 70 20 72 75 6e 2d 69 n-jobgroup run-i
5a60: 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 6a d (list run-id j
5a70: 6f 62 67 72 6f 75 70 29 20 61 72 65 61 2d 64 61 obgroup) area-da
5a80: 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d t))..(define (rm
5a90: 74 3a 72 6f 6c 6c 2d 75 70 2d 70 61 73 73 2d 66 t:roll-up-pass-f
5aa0: 61 69 6c 2d 63 6f 75 6e 74 73 20 72 75 6e 2d 69 ail-counts run-i
5ab0: 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d d test-name item
5ac0: 2d 70 61 74 68 20 73 74 61 74 75 73 20 61 72 65 -path status are
5ad0: 61 2d 64 61 74 29 0a 20 20 28 72 6d 74 3a 73 65 a-dat). (rmt:se
5ae0: 6e 64 2d 72 65 63 65 69 76 65 20 27 72 6f 6c 6c nd-receive 'roll
5af0: 2d 75 70 2d 70 61 73 73 2d 66 61 69 6c 2d 63 6f -up-pass-fail-co
5b00: 75 6e 74 73 20 72 75 6e 2d 69 64 20 28 6c 69 73 unts run-id (lis
5b10: 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 t run-id test-na
5b20: 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 73 74 61 me item-path sta
5b30: 74 75 73 29 20 61 72 65 61 2d 64 61 74 29 29 0a tus) area-dat)).
5b40: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 75 70 .(define (rmt:up
5b50: 64 61 74 65 2d 70 61 73 73 2d 66 61 69 6c 2d 63 date-pass-fail-c
5b60: 6f 75 6e 74 73 20 72 75 6e 2d 69 64 20 74 65 73 ounts run-id tes
5b70: 74 2d 6e 61 6d 65 20 61 72 65 61 2d 64 61 74 29 t-name area-dat)
5b80: 0a 20 20 28 72 6d 74 3a 67 65 6e 65 72 61 6c 2d . (rmt:general-
5b90: 63 61 6c 6c 20 27 75 70 64 61 74 65 2d 66 61 69 call 'update-fai
5ba0: 6c 2d 70 61 73 73 2d 63 6f 75 6e 74 73 20 72 75 l-pass-counts ru
5bb0: 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 n-id (list run-i
5bc0: 64 20 74 65 73 74 2d 6e 61 6d 65 20 72 75 6e 2d d test-name run-
5bd0: 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 72 75 6e id test-name run
5be0: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 29 20 61 -id test-name) a
5bf0: 72 65 61 2d 64 61 74 29 29 0a 0a 3b 3b 3d 3d 3d rea-dat))..;;===
5c00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5c10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5c20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5c30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5c40: 3d 3d 3d 0a 3b 3b 20 20 52 20 55 20 4e 20 53 0a ===.;; R U N S.
5c50: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
5c60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5c70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5c80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5c90: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e ========..(defin
5ca0: 65 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e 2d 69 e (rmt:get-run-i
5cb0: 6e 66 6f 20 72 75 6e 2d 69 64 20 61 72 65 61 2d nfo run-id area-
5cc0: 64 61 74 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 dat). (rmt:send
5cd0: 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 72 75 -receive 'get-ru
5ce0: 6e 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 20 28 6c n-info run-id (l
5cf0: 69 73 74 20 72 75 6e 2d 69 64 29 20 61 72 65 61 ist run-id) area
5d00: 2d 64 61 74 29 29 0a 0a 3b 3b 20 55 73 65 20 74 -dat))..;; Use t
5d10: 68 65 20 73 70 65 63 69 61 6c 20 72 75 6e 2d 69 he special run-i
5d20: 64 20 3d 3d 20 23 66 20 73 63 65 6e 61 72 69 6f d == #f scenario
5d30: 20 68 65 72 65 20 73 69 6e 63 65 20 74 68 65 72 here since ther
5d40: 65 20 69 73 20 6e 6f 20 72 75 6e 20 79 65 74 0a e is no run yet.
5d50: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 72 65 67 (define (rmt:reg
5d60: 69 73 74 65 72 2d 72 75 6e 20 6b 65 79 76 61 6c ister-run keyval
5d70: 73 20 72 75 6e 6e 61 6d 65 20 73 74 61 74 65 20 s runname state
5d80: 73 74 61 74 75 73 20 75 73 65 72 20 61 72 65 61 status user area
5d90: 2d 64 61 74 29 0a 20 20 28 72 6d 74 3a 73 65 6e -dat). (rmt:sen
5da0: 64 2d 72 65 63 65 69 76 65 20 27 72 65 67 69 73 d-receive 'regis
5db0: 74 65 72 2d 72 75 6e 20 23 66 20 28 6c 69 73 74 ter-run #f (list
5dc0: 20 6b 65 79 76 61 6c 73 20 72 75 6e 6e 61 6d 65 keyvals runname
5dd0: 20 73 74 61 74 65 20 73 74 61 74 75 73 20 75 73 state status us
5de0: 65 72 29 20 61 72 65 61 2d 64 61 74 29 29 0a 20 er) area-dat)).
5df0: 20 20 20 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 .(define (rmt
5e00: 3a 67 65 74 2d 72 75 6e 2d 6e 61 6d 65 2d 66 72 :get-run-name-fr
5e10: 6f 6d 2d 69 64 20 72 75 6e 2d 69 64 20 61 72 65 om-id run-id are
5e20: 61 2d 64 61 74 29 0a 20 20 28 72 6d 74 3a 73 65 a-dat). (rmt:se
5e30: 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d nd-receive 'get-
5e40: 72 75 6e 2d 6e 61 6d 65 2d 66 72 6f 6d 2d 69 64 run-name-from-id
5e50: 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 run-id (list ru
5e60: 6e 2d 69 64 29 20 61 72 65 61 2d 64 61 74 29 29 n-id) area-dat))
5e70: 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 64 ..(define (rmt:d
5e80: 65 6c 65 74 65 2d 72 75 6e 20 72 75 6e 2d 69 64 elete-run run-id
5e90: 20 61 72 65 61 2d 64 61 74 29 0a 20 20 28 72 6d area-dat). (rm
5ea0: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
5eb0: 64 65 6c 65 74 65 2d 72 75 6e 20 72 75 6e 2d 69 delete-run run-i
5ec0: 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 29 20 d (list run-id)
5ed0: 61 72 65 61 2d 64 61 74 29 29 0a 0a 28 64 65 66 area-dat))..(def
5ee0: 69 6e 65 20 28 72 6d 74 3a 64 65 6c 65 74 65 2d ine (rmt:delete-
5ef0: 6f 6c 64 2d 64 65 6c 65 74 65 64 2d 74 65 73 74 old-deleted-test
5f00: 2d 72 65 63 6f 72 64 73 20 61 72 65 61 2d 64 61 -records area-da
5f10: 74 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 t). (rmt:send-r
5f20: 65 63 65 69 76 65 20 27 64 65 6c 65 74 65 2d 6f eceive 'delete-o
5f30: 6c 64 2d 64 65 6c 65 74 65 64 2d 74 65 73 74 2d ld-deleted-test-
5f40: 72 65 63 6f 72 64 73 20 23 66 20 27 28 29 20 61 records #f '() a
5f50: 72 65 61 2d 64 61 74 29 29 0a 0a 28 64 65 66 69 rea-dat))..(defi
5f60: 6e 65 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e 73 ne (rmt:get-runs
5f70: 20 72 75 6e 70 61 74 74 20 63 6f 75 6e 74 20 6f runpatt count o
5f80: 66 66 73 65 74 20 6b 65 79 70 61 74 74 73 20 61 ffset keypatts a
5f90: 72 65 61 2d 64 61 74 29 0a 20 20 28 72 6d 74 3a rea-dat). (rmt:
5fa0: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 send-receive 'ge
5fb0: 74 2d 72 75 6e 73 20 23 66 20 28 6c 69 73 74 20 t-runs #f (list
5fc0: 72 75 6e 70 61 74 74 20 63 6f 75 6e 74 20 6f 66 runpatt count of
5fd0: 66 73 65 74 20 6b 65 79 70 61 74 74 73 29 20 61 fset keypatts) a
5fe0: 72 65 61 2d 64 61 74 29 29 0a 0a 28 64 65 66 69 rea-dat))..(defi
5ff0: 6e 65 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e 73 ne (rmt:get-runs
6000: 20 72 75 6e 70 61 74 74 20 63 6f 75 6e 74 20 6f runpatt count o
6010: 66 66 73 65 74 20 6b 65 79 70 61 74 74 73 20 61 ffset keypatts a
6020: 72 65 61 2d 64 61 74 29 0a 20 20 28 72 6d 74 3a rea-dat). (rmt:
6030: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 send-receive 'ge
6040: 74 2d 72 75 6e 73 20 23 66 20 28 6c 69 73 74 20 t-runs #f (list
6050: 72 75 6e 70 61 74 74 20 63 6f 75 6e 74 20 6f 66 runpatt count of
6060: 66 73 65 74 20 6b 65 79 70 61 74 74 73 29 20 61 fset keypatts) a
6070: 72 65 61 2d 64 61 74 29 29 0a 0a 28 64 65 66 69 rea-dat))..(defi
6080: 6e 65 20 28 72 6d 74 3a 67 65 74 2d 61 6c 6c 2d ne (rmt:get-all-
6090: 72 75 6e 2d 69 64 73 20 61 72 65 61 2d 64 61 74 run-ids area-dat
60a0: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
60b0: 63 65 69 76 65 20 27 67 65 74 2d 61 6c 6c 2d 72 ceive 'get-all-r
60c0: 75 6e 2d 69 64 73 20 23 66 20 27 28 29 20 61 72 un-ids #f '() ar
60d0: 65 61 2d 64 61 74 29 29 0a 0a 28 64 65 66 69 6e ea-dat))..(defin
60e0: 65 20 28 72 6d 74 3a 67 65 74 2d 70 72 65 76 2d e (rmt:get-prev-
60f0: 72 75 6e 2d 69 64 73 20 72 75 6e 2d 69 64 20 61 run-ids run-id a
6100: 72 65 61 2d 64 61 74 29 0a 20 20 28 72 6d 74 3a rea-dat). (rmt:
6110: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 send-receive 'ge
6120: 74 2d 70 72 65 76 2d 72 75 6e 2d 69 64 73 20 23 t-prev-run-ids #
6130: 66 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 29 20 f (list run-id)
6140: 61 72 65 61 2d 64 61 74 29 29 0a 0a 28 64 65 66 area-dat))..(def
6150: 69 6e 65 20 28 72 6d 74 3a 6c 6f 63 6b 2f 75 6e ine (rmt:lock/un
6160: 6c 6f 63 6b 2d 72 75 6e 20 72 75 6e 2d 69 64 20 lock-run run-id
6170: 6c 6f 63 6b 20 75 6e 6c 6f 63 6b 20 75 73 65 72 lock unlock user
6180: 20 61 72 65 61 2d 64 61 74 29 0a 20 20 28 72 6d area-dat). (rm
6190: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
61a0: 6c 6f 63 6b 2f 75 6e 6c 6f 63 6b 2d 72 75 6e 20 lock/unlock-run
61b0: 23 66 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 #f (list run-id
61c0: 6c 6f 63 6b 20 75 6e 6c 6f 63 6b 20 75 73 65 72 lock unlock user
61d0: 29 20 61 72 65 61 2d 64 61 74 29 29 0a 0a 3b 3b ) area-dat))..;;
61e0: 20 73 65 74 2f 67 65 74 20 73 74 61 74 75 73 0a set/get status.
61f0: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 (define (rmt:get
6200: 2d 72 75 6e 2d 73 74 61 74 75 73 20 72 75 6e 2d -run-status run-
6210: 69 64 20 61 72 65 61 2d 64 61 74 29 0a 20 20 28 id area-dat). (
6220: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
6230: 20 27 67 65 74 2d 72 75 6e 2d 73 74 61 74 75 73 'get-run-status
6240: 20 23 66 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 #f (list run-id
6250: 29 20 61 72 65 61 2d 64 61 74 29 29 0a 0a 28 64 ) area-dat))..(d
6260: 65 66 69 6e 65 20 28 72 6d 74 3a 73 65 74 2d 72 efine (rmt:set-r
6270: 75 6e 2d 73 74 61 74 75 73 20 72 75 6e 2d 69 64 un-status run-id
6280: 20 72 75 6e 2d 73 74 61 74 75 73 20 61 72 65 61 run-status area
6290: 2d 64 61 74 20 23 21 6b 65 79 20 28 6d 73 67 20 -dat #!key (msg
62a0: 23 66 29 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 #f)). (rmt:send
62b0: 2d 72 65 63 65 69 76 65 20 27 73 65 74 2d 72 75 -receive 'set-ru
62c0: 6e 2d 73 74 61 74 75 73 20 23 66 20 28 6c 69 73 n-status #f (lis
62d0: 74 20 72 75 6e 2d 69 64 20 72 75 6e 2d 73 74 61 t run-id run-sta
62e0: 74 75 73 20 6d 73 67 29 20 61 72 65 61 2d 64 61 tus msg) area-da
62f0: 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d t))..(define (rm
6300: 74 3a 75 70 64 61 74 65 2d 72 75 6e 2d 65 76 65 t:update-run-eve
6310: 6e 74 5f 74 69 6d 65 20 72 75 6e 2d 69 64 20 61 nt_time run-id a
6320: 72 65 61 2d 64 61 74 29 0a 20 20 28 72 6d 74 3a rea-dat). (rmt:
6330: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 75 70 send-receive 'up
6340: 64 61 74 65 2d 72 75 6e 2d 65 76 65 6e 74 5f 74 date-run-event_t
6350: 69 6d 65 20 23 66 20 28 6c 69 73 74 20 72 75 6e ime #f (list run
6360: 2d 69 64 29 20 61 72 65 61 2d 64 61 74 29 29 0a -id) area-dat)).
6370: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 .(define (rmt:ge
6380: 74 2d 72 75 6e 73 2d 62 79 2d 70 61 74 74 20 20 t-runs-by-patt
6390: 6b 65 79 73 20 72 75 6e 6e 61 6d 65 70 61 74 74 keys runnamepatt
63a0: 20 74 61 72 67 70 61 74 74 20 6f 66 66 73 65 74 targpatt offset
63b0: 20 6c 69 6d 69 74 20 61 72 65 61 2d 64 61 74 29 limit area-dat)
63c0: 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 . (rmt:send-rec
63d0: 65 69 76 65 20 27 67 65 74 2d 72 75 6e 73 2d 62 eive 'get-runs-b
63e0: 79 2d 70 61 74 74 20 23 66 20 28 6c 69 73 74 20 y-patt #f (list
63f0: 6b 65 79 73 20 72 75 6e 6e 61 6d 65 70 61 74 74 keys runnamepatt
6400: 20 74 61 72 67 70 61 74 74 20 6f 66 66 73 65 74 targpatt offset
6410: 20 6c 69 6d 69 74 29 20 61 72 65 61 2d 64 61 74 limit) area-dat
6420: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
6430: 3a 66 69 6e 64 2d 61 6e 64 2d 6d 61 72 6b 2d 69 :find-and-mark-i
6440: 6e 63 6f 6d 70 6c 65 74 65 20 72 75 6e 2d 69 64 ncomplete run-id
6450: 20 6f 76 72 2d 64 65 61 64 74 69 6d 65 20 61 72 ovr-deadtime ar
6460: 65 61 2d 64 61 74 29 0a 20 20 28 69 66 20 28 72 ea-dat). (if (r
6470: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
6480: 27 68 61 76 65 2d 69 6e 63 6f 6d 70 6c 65 74 65 'have-incomplete
6490: 73 3f 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 s? run-id (list
64a0: 72 75 6e 2d 69 64 20 6f 76 72 2d 64 65 61 64 74 run-id ovr-deadt
64b0: 69 6d 65 29 20 61 72 65 61 2d 64 61 74 29 0a 20 ime) area-dat).
64c0: 20 20 20 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 (rmt:send-r
64d0: 65 63 65 69 76 65 20 27 6d 61 72 6b 2d 69 6e 63 eceive 'mark-inc
64e0: 6f 6d 70 6c 65 74 65 20 72 75 6e 2d 69 64 20 28 omplete run-id (
64f0: 6c 69 73 74 20 72 75 6e 2d 69 64 20 6f 76 72 2d list run-id ovr-
6500: 64 65 61 64 74 69 6d 65 29 20 61 72 65 61 2d 64 deadtime) area-d
6510: 61 74 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d at)))..;;=======
6520: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6530: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6540: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6550: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
6560: 3b 3b 20 4d 20 55 20 4c 20 54 20 49 20 52 20 55 ;; M U L T I R U
6570: 20 4e 20 20 20 51 20 55 20 45 20 52 20 49 20 45 N Q U E R I E
6580: 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d S.;;===========
6590: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
65a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
65b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
65c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 ===========..;;
65d0: 4e 65 65 64 20 74 6f 20 6d 6f 76 65 20 74 68 69 Need to move thi
65e0: 73 20 74 6f 20 6d 75 6c 74 69 2d 72 75 6e 20 73 s to multi-run s
65f0: 65 63 74 69 6f 6e 20 61 6e 64 20 6d 61 6b 65 20 ection and make
6600: 61 73 73 6f 63 69 61 74 65 64 20 63 68 61 6e 67 associated chang
6610: 65 73 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a es.(define (rmt:
6620: 66 69 6e 64 2d 61 6e 64 2d 6d 61 72 6b 2d 69 6e find-and-mark-in
6630: 63 6f 6d 70 6c 65 74 65 2d 61 6c 6c 2d 72 75 6e complete-all-run
6640: 73 20 61 72 65 61 2d 64 61 74 20 23 21 6b 65 79 s area-dat #!key
6650: 20 28 6f 76 72 2d 64 65 61 64 74 69 6d 65 20 23 (ovr-deadtime #
6660: 66 29 29 0a 20 20 28 6c 65 74 20 28 28 72 75 6e f)). (let ((run
6670: 2d 69 64 73 20 28 72 6d 74 3a 67 65 74 2d 61 6c -ids (rmt:get-al
6680: 6c 2d 72 75 6e 2d 69 64 73 20 61 72 65 61 2d 64 l-run-ids area-d
6690: 61 74 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 at))). (for-e
66a0: 61 63 68 20 28 6c 61 6d 62 64 61 20 28 72 75 6e ach (lambda (run
66b0: 2d 69 64 29 0a 09 20 20 20 20 20 20 20 28 72 6d -id).. (rm
66c0: 74 3a 66 69 6e 64 2d 61 6e 64 2d 6d 61 72 6b 2d t:find-and-mark-
66d0: 69 6e 63 6f 6d 70 6c 65 74 65 20 72 75 6e 2d 69 incomplete run-i
66e0: 64 20 6f 76 72 2d 64 65 61 64 74 69 6d 65 20 61 d ovr-deadtime a
66f0: 72 65 61 2d 64 61 74 29 29 0a 09 20 20 20 20 20 rea-dat))..
6700: 72 75 6e 2d 69 64 73 29 29 29 0a 0a 3b 3b 20 67 run-ids)))..;; g
6710: 65 74 20 74 68 65 20 70 72 65 76 69 6f 75 73 20 et the previous
6720: 72 65 63 6f 72 64 20 66 6f 72 20 77 68 65 6e 20 record for when
6730: 74 68 69 73 20 74 65 73 74 20 77 61 73 20 72 75 this test was ru
6740: 6e 20 77 68 65 72 65 20 61 6c 6c 20 6b 65 79 73 n where all keys
6750: 20 6d 61 74 63 68 20 62 75 74 20 72 75 6e 6e 61 match but runna
6760: 6d 65 0a 3b 3b 20 72 65 74 75 72 6e 73 20 23 66 me.;; returns #f
6770: 20 69 66 20 6e 6f 20 73 75 63 68 20 74 65 73 74 if no such test
6780: 20 66 6f 75 6e 64 2c 20 72 65 74 75 72 6e 73 20 found, returns
6790: 61 20 73 69 6e 67 6c 65 20 74 65 73 74 20 72 65 a single test re
67a0: 63 6f 72 64 20 69 66 20 66 6f 75 6e 64 0a 3b 3b cord if found.;;
67b0: 20 0a 3b 3b 20 52 75 6e 20 74 68 69 73 20 61 74 .;; Run this at
67c0: 20 74 68 65 20 63 6c 69 65 6e 74 20 65 6e 64 20 the client end
67d0: 73 69 6e 63 65 20 77 65 20 68 61 76 65 20 74 6f since we have to
67e0: 20 63 6f 6e 6e 65 63 74 20 74 6f 20 6d 75 6c 74 connect to mult
67f0: 69 70 6c 65 20 72 75 6e 2d 69 64 20 64 62 73 0a iple run-id dbs.
6800: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a ;;.(define (rmt:
6810: 67 65 74 2d 70 72 65 76 69 6f 75 73 2d 74 65 73 get-previous-tes
6820: 74 2d 72 75 6e 2d 72 65 63 6f 72 64 20 72 75 6e t-run-record run
6830: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 -id test-name it
6840: 65 6d 2d 70 61 74 68 20 61 72 65 61 2d 64 61 74 em-path area-dat
6850: 29 0a 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 76 ). (let* ((keyv
6860: 61 6c 73 20 28 72 6d 74 3a 67 65 74 2d 6b 65 79 als (rmt:get-key
6870: 2d 76 61 6c 2d 70 61 69 72 73 20 72 75 6e 2d 69 -val-pairs run-i
6880: 64 20 61 72 65 61 2d 64 61 74 29 29 0a 09 20 28 d area-dat)).. (
6890: 6b 65 79 73 20 20 20 20 28 72 6d 74 3a 67 65 74 keys (rmt:get
68a0: 2d 6b 65 79 73 20 61 72 65 61 2d 64 61 74 29 29 -keys area-dat))
68b0: 0a 09 20 28 73 65 6c 73 74 72 20 20 28 73 74 72 .. (selstr (str
68c0: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
68d0: 20 6b 65 79 73 20 22 2c 22 29 29 0a 09 20 28 71 keys ",")).. (q
68e0: 72 79 73 74 72 20 20 28 73 74 72 69 6e 67 2d 69 rystr (string-i
68f0: 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 20 ntersperse (map
6900: 28 6c 61 6d 62 64 61 20 28 78 29 28 63 6f 6e 63 (lambda (x)(conc
6910: 20 78 20 22 3d 3f 22 29 29 20 6b 65 79 73 29 20 x "=?")) keys)
6920: 22 20 41 4e 44 20 22 29 29 29 0a 20 20 20 20 28 " AND "))). (
6930: 69 66 20 28 6e 6f 74 20 6b 65 79 76 61 6c 73 29 if (not keyvals)
6940: 0a 09 23 66 0a 09 28 6c 65 74 20 28 28 70 72 65 ..#f..(let ((pre
6950: 76 2d 72 75 6e 2d 69 64 73 20 28 72 6d 74 3a 67 v-run-ids (rmt:g
6960: 65 74 2d 70 72 65 76 2d 72 75 6e 2d 69 64 73 20 et-prev-run-ids
6970: 72 75 6e 2d 69 64 20 61 72 65 61 2d 64 61 74 29 run-id area-dat)
6980: 29 29 0a 09 20 20 3b 3b 20 66 6f 72 20 65 61 63 )).. ;; for eac
6990: 68 20 72 75 6e 20 73 74 61 72 74 69 6e 67 20 77 h run starting w
69a0: 69 74 68 20 74 68 65 20 6d 6f 73 74 20 72 65 63 ith the most rec
69b0: 65 6e 74 20 6c 6f 6f 6b 20 74 6f 20 73 65 65 20 ent look to see
69c0: 69 66 20 74 68 65 72 65 20 69 73 20 61 20 6d 61 if there is a ma
69d0: 74 63 68 69 6e 67 20 74 65 73 74 0a 09 20 20 3b tching test.. ;
69e0: 3b 20 69 66 20 66 6f 75 6e 64 20 74 68 65 6e 20 ; if found then
69f0: 72 65 74 75 72 6e 20 74 68 61 74 20 6d 61 74 63 return that matc
6a00: 68 69 6e 67 20 74 65 73 74 20 72 65 63 6f 72 64 hing test record
6a10: 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
6a20: 20 34 20 22 73 65 6c 73 74 72 3a 20 22 20 73 65 4 "selstr: " se
6a30: 6c 73 74 72 20 22 2c 20 71 72 79 73 74 72 3a 20 lstr ", qrystr:
6a40: 22 20 71 72 79 73 74 72 20 22 2c 20 6b 65 79 76 " qrystr ", keyv
6a50: 61 6c 73 3a 20 22 20 6b 65 79 76 61 6c 73 20 22 als: " keyvals "
6a60: 2c 20 70 72 65 76 69 6f 75 73 20 72 75 6e 20 69 , previous run i
6a70: 64 73 20 66 6f 75 6e 64 3a 20 22 20 70 72 65 76 ds found: " prev
6a80: 2d 72 75 6e 2d 69 64 73 29 0a 09 20 20 28 69 66 -run-ids).. (if
6a90: 20 28 6e 75 6c 6c 3f 20 70 72 65 76 2d 72 75 6e (null? prev-run
6aa0: 2d 69 64 73 29 20 23 66 0a 09 20 20 20 20 20 20 -ids) #f..
6ab0: 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 (let loop ((hed
6ac0: 28 63 61 72 20 70 72 65 76 2d 72 75 6e 2d 69 64 (car prev-run-id
6ad0: 73 29 29 0a 09 09 09 20 28 74 61 6c 20 28 63 64 s)).... (tal (cd
6ae0: 72 20 70 72 65 76 2d 72 75 6e 2d 69 64 73 29 29 r prev-run-ids))
6af0: 29 0a 09 09 28 6c 65 74 20 28 28 72 65 73 75 6c )...(let ((resul
6b00: 74 73 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 ts (rmt:get-test
6b10: 73 2d 66 6f 72 2d 72 75 6e 20 68 65 64 20 28 63 s-for-run hed (c
6b20: 6f 6e 63 20 74 65 73 74 2d 6e 61 6d 65 20 22 2f onc test-name "/
6b30: 22 20 69 74 65 6d 2d 70 61 74 68 29 20 27 28 29 " item-path) '()
6b40: 20 27 28 29 20 23 66 20 23 66 20 23 66 20 23 66 '() #f #f #f #f
6b50: 20 23 66 20 23 66 20 61 72 65 61 2d 64 61 74 29 #f #f area-dat)
6b60: 29 29 0a 09 09 20 20 28 64 65 62 75 67 3a 70 72 ))... (debug:pr
6b70: 69 6e 74 20 34 20 22 47 6f 74 20 74 65 73 74 73 int 4 "Got tests
6b80: 20 66 6f 72 20 72 75 6e 2d 69 64 20 22 20 72 75 for run-id " ru
6b90: 6e 2d 69 64 20 22 2c 20 74 65 73 74 2d 6e 61 6d n-id ", test-nam
6ba0: 65 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 2c e " test-name ",
6bb0: 20 69 74 65 6d 2d 70 61 74 68 20 22 20 69 74 65 item-path " ite
6bc0: 6d 2d 70 61 74 68 20 22 3a 20 22 20 72 65 73 75 m-path ": " resu
6bd0: 6c 74 73 29 0a 09 09 20 20 28 69 66 20 28 61 6e lts)... (if (an
6be0: 64 20 28 6e 75 6c 6c 3f 20 72 65 73 75 6c 74 73 d (null? results
6bf0: 29 0a 09 09 09 20 20 20 28 6e 6f 74 20 28 6e 75 ).... (not (nu
6c00: 6c 6c 3f 20 74 61 6c 29 29 29 0a 09 09 20 20 20 ll? tal)))...
6c10: 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 (loop (car ta
6c20: 6c 29 28 63 64 72 20 74 61 6c 29 29 0a 09 09 20 l)(cdr tal))...
6c30: 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 (if (null?
6c40: 72 65 73 75 6c 74 73 29 20 23 66 0a 09 09 09 20 results) #f....
6c50: 20 28 63 61 72 20 72 65 73 75 6c 74 73 29 29 29 (car results)))
6c60: 29 29 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d )))))))..;;=====
6c70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6c80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6c90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6ca0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6cb0: 3d 0a 3b 3b 20 20 53 20 54 20 45 20 50 20 53 0a =.;; S T E P S.
6cc0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
6cd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6ce0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6cf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6d00: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 47 65 74 ========..;; Get
6d10: 74 69 6e 67 20 73 74 65 70 73 20 69 73 20 6d 6f ting steps is mo
6d20: 72 65 20 63 6f 6d 70 6c 69 63 61 74 65 64 2e 0a re complicated..
6d30: 3b 3b 0a 3b 3b 20 49 66 20 67 69 76 65 6e 20 77 ;;.;; If given w
6d40: 6f 72 6b 20 61 72 65 61 20 0a 3b 3b 20 20 31 2e ork area .;; 1.
6d50: 20 46 69 6e 64 20 74 68 65 20 74 65 73 74 64 61 Find the testda
6d60: 74 2e 64 62 20 66 69 6c 65 0a 3b 3b 20 20 32 2e t.db file.;; 2.
6d70: 20 4f 70 65 6e 20 74 68 65 20 74 65 73 74 64 61 Open the testda
6d80: 74 2e 64 62 20 66 69 6c 65 20 61 6e 64 20 64 6f t.db file and do
6d90: 20 74 68 65 20 71 75 65 72 79 0a 3b 3b 20 49 66 the query.;; If
6da0: 20 6e 6f 74 20 67 69 76 65 6e 20 74 68 65 20 77 not given the w
6db0: 6f 72 6b 20 61 72 65 61 0a 3b 3b 20 20 31 2e 20 ork area.;; 1.
6dc0: 44 6f 20 61 20 72 65 6d 6f 74 65 20 63 61 6c 6c Do a remote call
6dd0: 20 74 6f 20 67 65 74 20 74 68 65 20 74 65 73 74 to get the test
6de0: 20 70 61 74 68 0a 3b 3b 20 20 32 2e 20 43 6f 6e path.;; 2. Con
6df0: 74 69 6e 75 65 20 61 73 20 61 62 6f 76 65 0a 3b tinue as above.;
6e00: 3b 20 0a 3b 3b 28 64 65 66 69 6e 65 20 28 72 6d ; .;;(define (rm
6e10: 74 3a 67 65 74 2d 73 74 65 70 73 2d 66 6f 72 2d t:get-steps-for-
6e20: 74 65 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 test run-id test
6e30: 2d 69 64 29 0a 3b 3b 20 20 28 72 6d 74 3a 73 65 -id).;; (rmt:se
6e40: 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d nd-receive 'get-
6e50: 73 74 65 70 73 2d 64 61 74 61 20 72 75 6e 2d 69 steps-data run-i
6e60: 64 20 28 6c 69 73 74 20 74 65 73 74 2d 69 64 29 d (list test-id)
6e70: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
6e80: 3a 74 65 73 74 73 74 65 70 2d 73 65 74 2d 73 74 :teststep-set-st
6e90: 61 74 75 73 21 20 72 75 6e 2d 69 64 20 74 65 73 atus! run-id tes
6ea0: 74 2d 69 64 20 74 65 73 74 73 74 65 70 2d 6e 61 t-id teststep-na
6eb0: 6d 65 20 73 74 61 74 65 2d 69 6e 20 73 74 61 74 me state-in stat
6ec0: 75 73 2d 69 6e 20 63 6f 6d 6d 65 6e 74 20 6c 6f us-in comment lo
6ed0: 67 66 69 6c 65 20 61 72 65 61 2d 64 61 74 29 0a gfile area-dat).
6ee0: 20 20 28 6c 65 74 2a 20 28 28 73 74 61 74 65 20 (let* ((state
6ef0: 20 20 20 20 28 69 74 65 6d 73 3a 63 68 65 63 6b (items:check
6f00: 2d 76 61 6c 69 64 2d 69 74 65 6d 73 20 22 73 74 -valid-items "st
6f10: 61 74 65 22 20 73 74 61 74 65 2d 69 6e 29 29 0a ate" state-in)).
6f20: 09 20 28 73 74 61 74 75 73 20 20 20 20 28 69 74 . (status (it
6f30: 65 6d 73 3a 63 68 65 63 6b 2d 76 61 6c 69 64 2d ems:check-valid-
6f40: 69 74 65 6d 73 20 22 73 74 61 74 75 73 22 20 73 items "status" s
6f50: 74 61 74 75 73 2d 69 6e 29 29 29 0a 20 20 20 20 tatus-in))).
6f60: 28 69 66 20 28 6f 72 20 28 6e 6f 74 20 73 74 61 (if (or (not sta
6f70: 74 65 29 28 6e 6f 74 20 73 74 61 74 75 73 29 29 te)(not status))
6f80: 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 33 ..(debug:print 3
6f90: 20 22 57 41 52 4e 49 4e 47 3a 20 49 6e 76 61 6c "WARNING: Inval
6fa0: 69 64 20 22 20 28 69 66 20 73 74 61 74 75 73 20 id " (if status
6fb0: 22 73 74 61 74 75 73 22 20 22 73 74 61 74 65 22 "status" "state"
6fc0: 29 0a 09 09 20 20 20 20 20 22 20 76 61 6c 75 65 )... " value
6fd0: 20 5c 22 22 20 28 69 66 20 73 74 61 74 75 73 20 \"" (if status
6fe0: 73 74 61 74 65 2d 69 6e 20 73 74 61 74 75 73 2d state-in status-
6ff0: 69 6e 29 20 22 5c 22 2c 20 75 70 64 61 74 65 20 in) "\", update
7000: 79 6f 75 72 20 76 61 6c 69 64 76 61 6c 75 65 73 your validvalues
7010: 20 73 65 63 74 69 6f 6e 20 69 6e 20 6d 65 67 61 section in mega
7020: 74 65 73 74 2e 63 6f 6e 66 69 67 22 29 29 0a 20 test.config")).
7030: 20 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 (rmt:send-rec
7040: 65 69 76 65 20 27 74 65 73 74 73 74 65 70 2d 73 eive 'teststep-s
7050: 65 74 2d 73 74 61 74 75 73 21 20 72 75 6e 2d 69 et-status! run-i
7060: 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 d (list run-id t
7070: 65 73 74 2d 69 64 20 74 65 73 74 73 74 65 70 2d est-id teststep-
7080: 6e 61 6d 65 20 73 74 61 74 65 2d 69 6e 20 73 74 name state-in st
7090: 61 74 75 73 2d 69 6e 20 63 6f 6d 6d 65 6e 74 20 atus-in comment
70a0: 6c 6f 67 66 69 6c 65 29 20 61 72 65 61 2d 64 61 logfile) area-da
70b0: 74 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 t)))..(define (r
70c0: 6d 74 3a 67 65 74 2d 73 74 65 70 73 2d 66 6f 72 mt:get-steps-for
70d0: 2d 74 65 73 74 20 72 75 6e 2d 69 64 20 74 65 73 -test run-id tes
70e0: 74 2d 69 64 20 61 72 65 61 2d 64 61 74 29 0a 20 t-id area-dat).
70f0: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
7100: 76 65 20 27 67 65 74 2d 73 74 65 70 73 2d 66 6f ve 'get-steps-fo
7110: 72 2d 74 65 73 74 20 72 75 6e 2d 69 64 20 28 6c r-test run-id (l
7120: 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d ist run-id test-
7130: 69 64 29 20 61 72 65 61 2d 64 61 74 29 29 0a 0a id) area-dat))..
7140: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
7150: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7160: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7170: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7180: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 54 20 45 ========.;; T E
7190: 20 53 20 54 20 20 20 44 20 41 20 54 20 41 20 0a S T D A T A .
71a0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
71b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
71c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
71d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
71e0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e ========..(defin
71f0: 65 20 28 72 6d 74 3a 72 65 61 64 2d 74 65 73 74 e (rmt:read-test
7200: 2d 64 61 74 61 20 72 75 6e 2d 69 64 20 74 65 73 -data run-id tes
7210: 74 2d 69 64 20 63 61 74 65 67 6f 72 79 70 61 74 t-id categorypat
7220: 74 20 61 72 65 61 2d 64 61 74 20 23 21 6b 65 79 t area-dat #!key
7230: 20 28 77 6f 72 6b 2d 61 72 65 61 20 23 66 29 29 (work-area #f))
7240: 20 0a 20 20 28 6c 65 74 20 28 28 74 64 62 20 20 . (let ((tdb
7250: 28 72 6d 74 3a 6f 70 65 6e 2d 74 65 73 74 2d 64 (rmt:open-test-d
7260: 62 2d 62 79 2d 74 65 73 74 2d 69 64 20 72 75 6e b-by-test-id run
7270: 2d 69 64 20 74 65 73 74 2d 69 64 20 61 72 65 61 -id test-id area
7280: 2d 64 61 74 20 77 6f 72 6b 2d 61 72 65 61 3a 20 -dat work-area:
7290: 77 6f 72 6b 2d 61 72 65 61 29 29 29 0a 20 20 20 work-area))).
72a0: 20 28 69 66 20 74 64 62 0a 09 28 74 64 62 3a 72 (if tdb..(tdb:r
72b0: 65 61 64 2d 74 65 73 74 2d 64 61 74 61 20 74 64 ead-test-data td
72c0: 62 20 74 65 73 74 2d 69 64 20 63 61 74 65 67 6f b test-id catego
72d0: 72 79 70 61 74 74 20 61 72 65 61 2d 64 61 74 29 rypatt area-dat)
72e0: 0a 09 27 28 29 29 29 29 0a 0a 28 64 65 66 69 6e ..'())))..(defin
72f0: 65 20 28 72 6d 74 3a 74 65 73 74 6d 65 74 61 2d e (rmt:testmeta-
7300: 61 64 64 2d 72 65 63 6f 72 64 20 74 65 73 74 6e add-record testn
7310: 61 6d 65 20 61 72 65 61 2d 64 61 74 29 0a 20 20 ame area-dat).
7320: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
7330: 65 20 27 74 65 73 74 6d 65 74 61 2d 61 64 64 2d e 'testmeta-add-
7340: 72 65 63 6f 72 64 20 23 66 20 28 6c 69 73 74 20 record #f (list
7350: 74 65 73 74 6e 61 6d 65 29 20 61 72 65 61 2d 64 testname) area-d
7360: 61 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 at))..(define (r
7370: 6d 74 3a 74 65 73 74 6d 65 74 61 2d 67 65 74 2d mt:testmeta-get-
7380: 72 65 63 6f 72 64 20 74 65 73 74 6e 61 6d 65 20 record testname
7390: 61 72 65 61 2d 64 61 74 29 0a 20 20 28 72 6d 74 area-dat). (rmt
73a0: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 74 :send-receive 't
73b0: 65 73 74 6d 65 74 61 2d 67 65 74 2d 72 65 63 6f estmeta-get-reco
73c0: 72 64 20 23 66 20 28 6c 69 73 74 20 74 65 73 74 rd #f (list test
73d0: 6e 61 6d 65 29 20 61 72 65 61 2d 64 61 74 29 29 name) area-dat))
73e0: 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 ..(define (rmt:t
73f0: 65 73 74 6d 65 74 61 2d 75 70 64 61 74 65 2d 66 estmeta-update-f
7400: 69 65 6c 64 20 74 65 73 74 2d 6e 61 6d 65 20 66 ield test-name f
7410: 6c 64 20 76 61 6c 20 61 72 65 61 2d 64 61 74 29 ld val area-dat)
7420: 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 . (rmt:send-rec
7430: 65 69 76 65 20 27 74 65 73 74 6d 65 74 61 2d 75 eive 'testmeta-u
7440: 70 64 61 74 65 2d 66 69 65 6c 64 20 23 66 20 28 pdate-field #f (
7450: 6c 69 73 74 20 74 65 73 74 2d 6e 61 6d 65 20 66 list test-name f
7460: 6c 64 20 76 61 6c 29 20 61 72 65 61 2d 64 61 74 ld val) area-dat
7470: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
7480: 3a 74 65 73 74 2d 64 61 74 61 2d 72 6f 6c 6c 75 :test-data-rollu
7490: 70 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 p run-id test-id
74a0: 20 73 74 61 74 75 73 20 61 72 65 61 2d 64 61 74 status area-dat
74b0: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
74c0: 63 65 69 76 65 20 27 74 65 73 74 2d 64 61 74 61 ceive 'test-data
74d0: 2d 72 6f 6c 6c 75 70 20 72 75 6e 2d 69 64 20 28 -rollup run-id (
74e0: 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 list run-id test
74f0: 2d 69 64 20 73 74 61 74 75 73 29 20 61 72 65 61 -id status) area
7500: 2d 64 61 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 -dat))..(define
7510: 28 72 6d 74 3a 63 73 76 2d 3e 74 65 73 74 2d 64 (rmt:csv->test-d
7520: 61 74 61 20 72 75 6e 2d 69 64 20 74 65 73 74 2d ata run-id test-
7530: 69 64 20 63 73 76 64 61 74 61 20 61 72 65 61 2d id csvdata area-
7540: 64 61 74 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 dat). (rmt:send
7550: 2d 72 65 63 65 69 76 65 20 27 63 73 76 2d 3e 74 -receive 'csv->t
7560: 65 73 74 2d 64 61 74 61 20 72 75 6e 2d 69 64 20 est-data run-id
7570: 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 (list run-id tes
7580: 74 2d 69 64 20 63 73 76 64 61 74 61 29 20 61 72 t-id csvdata) ar
7590: 65 61 2d 64 61 74 29 29 0a 0a 3b 3b 3d 3d 3d 3d ea-dat))..;;====
75a0: 3d 3d 3d 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 0a 3b 3b 20 20 54 20 41 20 53 20 4b 20 53 ==.;; T A S K S
75f0: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
7600: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7610: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7620: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7630: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 =========..(defi
7640: 6e 65 20 28 72 6d 74 3a 74 61 73 6b 73 2d 66 69 ne (rmt:tasks-fi
7650: 6e 64 2d 74 61 73 6b 2d 71 75 65 75 65 2d 72 65 nd-task-queue-re
7660: 63 6f 72 64 73 20 74 61 72 67 65 74 20 72 75 6e cords target run
7670: 2d 6e 61 6d 65 20 74 65 73 74 2d 70 61 74 74 20 -name test-patt
7680: 73 74 61 74 65 2d 70 61 74 74 20 61 63 74 69 6f state-patt actio
7690: 6e 2d 70 61 74 74 20 61 72 65 61 2d 64 61 74 29 n-patt area-dat)
76a0: 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 . (rmt:send-rec
76b0: 65 69 76 65 20 27 66 69 6e 64 2d 74 61 73 6b 2d eive 'find-task-
76c0: 71 75 65 75 65 2d 72 65 63 6f 72 64 73 20 23 66 queue-records #f
76d0: 20 28 6c 69 73 74 20 74 61 72 67 65 74 20 72 75 (list target ru
76e0: 6e 2d 6e 61 6d 65 20 74 65 73 74 2d 70 61 74 74 n-name test-patt
76f0: 20 73 74 61 74 65 2d 70 61 74 74 20 61 63 74 69 state-patt acti
7700: 6f 6e 2d 70 61 74 74 29 20 61 72 65 61 2d 64 61 on-patt) area-da
7710: 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d t))..(define (rm
7720: 74 3a 74 61 73 6b 73 2d 61 64 64 20 61 63 74 69 t:tasks-add acti
7730: 6f 6e 20 6f 77 6e 65 72 20 74 61 72 67 65 74 20 on owner target
7740: 72 75 6e 6e 61 6d 65 20 74 65 73 74 70 61 74 74 runname testpatt
7750: 20 70 61 72 61 6d 73 20 61 72 65 61 2d 64 61 74 params area-dat
7760: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
7770: 63 65 69 76 65 20 27 74 61 73 6b 73 2d 61 64 64 ceive 'tasks-add
7780: 20 23 66 20 28 6c 69 73 74 20 61 63 74 69 6f 6e #f (list action
7790: 20 6f 77 6e 65 72 20 74 61 72 67 65 74 20 72 75 owner target ru
77a0: 6e 6e 61 6d 65 20 74 65 73 74 70 61 74 74 20 70 nname testpatt p
77b0: 61 72 61 6d 73 29 20 61 72 65 61 2d 64 61 74 29 arams) area-dat)
77c0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a )..(define (rmt:
77d0: 74 61 73 6b 73 2d 73 65 74 2d 73 74 61 74 65 2d tasks-set-state-
77e0: 67 69 76 65 6e 2d 70 61 72 61 6d 2d 6b 65 79 20 given-param-key
77f0: 70 61 72 61 6d 2d 6b 65 79 20 6e 65 77 2d 73 74 param-key new-st
7800: 61 74 65 20 61 72 65 61 2d 64 61 74 29 0a 20 20 ate area-dat).
7810: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
7820: 65 20 27 74 61 73 6b 73 2d 73 65 74 2d 73 74 61 e 'tasks-set-sta
7830: 74 65 2d 67 69 76 65 6e 2d 70 61 72 61 6d 2d 6b te-given-param-k
7840: 65 79 20 23 66 20 28 6c 69 73 74 20 20 70 61 72 ey #f (list par
7850: 61 6d 2d 6b 65 79 20 6e 65 77 2d 73 74 61 74 65 am-key new-state
7860: 29 20 61 72 65 61 2d 64 61 74 29 29 0a 0a 3b 3b ) area-dat))..;;
7870: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7880: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7890: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
78a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
78b0: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 41 20 52 20 43 20 ======.;; A R C
78c0: 48 20 49 20 56 20 45 20 53 0a 3b 3b 3d 3d 3d 3d H I V E S.;;====
78d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
78e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
78f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7900: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7910: 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ==..(define (rmt
7920: 3a 61 72 63 68 69 76 65 2d 67 65 74 2d 61 6c 6c :archive-get-all
7930: 6f 63 61 74 69 6f 6e 73 20 20 74 65 73 74 6e 61 ocations testna
7940: 6d 65 20 69 74 65 6d 70 61 74 68 20 64 6e 65 65 me itempath dnee
7950: 64 65 64 20 61 72 65 61 2d 64 61 74 29 0a 20 20 ded area-dat).
7960: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
7970: 65 20 27 61 72 63 68 69 76 65 2d 67 65 74 2d 61 e 'archive-get-a
7980: 6c 6c 6f 63 61 74 69 6f 6e 73 20 23 66 20 28 6c llocations #f (l
7990: 69 73 74 20 74 65 73 74 6e 61 6d 65 20 69 74 65 ist testname ite
79a0: 6d 70 61 74 68 20 64 6e 65 65 64 65 64 29 20 61 mpath dneeded) a
79b0: 72 65 61 2d 64 61 74 29 29 0a 0a 28 64 65 66 69 rea-dat))..(defi
79c0: 6e 65 20 28 72 6d 74 3a 61 72 63 68 69 76 65 2d ne (rmt:archive-
79d0: 72 65 67 69 73 74 65 72 2d 62 6c 6f 63 6b 2d 6e register-block-n
79e0: 61 6d 65 20 62 64 69 73 6b 2d 69 64 20 61 72 63 ame bdisk-id arc
79f0: 68 69 76 65 2d 70 61 74 68 20 61 72 65 61 2d 64 hive-path area-d
7a00: 61 74 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d at). (rmt:send-
7a10: 72 65 63 65 69 76 65 20 27 61 72 63 68 69 76 65 receive 'archive
7a20: 2d 72 65 67 69 73 74 65 72 2d 62 6c 6f 63 6b 2d -register-block-
7a30: 6e 61 6d 65 20 23 66 20 28 6c 69 73 74 20 62 64 name #f (list bd
7a40: 69 73 6b 2d 69 64 20 61 72 63 68 69 76 65 2d 70 isk-id archive-p
7a50: 61 74 68 29 20 61 72 65 61 2d 64 61 74 29 29 0a ath) area-dat)).
7a60: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 61 72 .(define (rmt:ar
7a70: 63 68 69 76 65 2d 61 6c 6c 6f 63 61 74 65 2d 74 chive-allocate-t
7a80: 65 73 74 73 75 69 74 65 2f 61 72 65 61 2d 74 6f estsuite/area-to
7a90: 2d 62 6c 6f 63 6b 20 62 6c 6f 63 6b 2d 69 64 20 -block block-id
7aa0: 74 65 73 74 73 75 69 74 65 2d 6e 61 6d 65 20 61 testsuite-name a
7ab0: 72 65 61 6b 65 79 20 61 72 65 61 2d 64 61 74 29 reakey area-dat)
7ac0: 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 . (rmt:send-rec
7ad0: 65 69 76 65 20 27 61 72 63 68 69 76 65 2d 61 6c eive 'archive-al
7ae0: 6c 6f 63 61 74 65 2d 74 65 73 74 2d 74 6f 2d 62 locate-test-to-b
7af0: 6c 6f 63 6b 20 23 66 20 28 6c 69 73 74 20 20 62 lock #f (list b
7b00: 6c 6f 63 6b 2d 69 64 20 74 65 73 74 73 75 69 74 lock-id testsuit
7b10: 65 2d 6e 61 6d 65 20 61 72 65 61 6b 65 79 29 20 e-name areakey)
7b20: 61 72 65 61 2d 64 61 74 29 29 0a 0a 28 64 65 66 area-dat))..(def
7b30: 69 6e 65 20 28 72 6d 74 3a 61 72 63 68 69 76 65 ine (rmt:archive
7b40: 2d 72 65 67 69 73 74 65 72 2d 64 69 73 6b 20 62 -register-disk b
7b50: 64 69 73 6b 2d 6e 61 6d 65 20 62 64 69 73 6b 2d disk-name bdisk-
7b60: 70 61 74 68 20 64 66 20 61 72 65 61 2d 64 61 74 path df area-dat
7b70: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
7b80: 63 65 69 76 65 20 27 61 72 63 68 69 76 65 2d 72 ceive 'archive-r
7b90: 65 67 69 73 74 65 72 2d 64 69 73 6b 20 23 66 20 egister-disk #f
7ba0: 28 6c 69 73 74 20 62 64 69 73 6b 2d 6e 61 6d 65 (list bdisk-name
7bb0: 20 62 64 69 73 6b 2d 70 61 74 68 20 64 66 29 20 bdisk-path df)
7bc0: 61 72 65 61 2d 64 61 74 29 29 0a 0a 28 64 65 66 area-dat))..(def
7bd0: 69 6e 65 20 28 72 6d 74 3a 74 65 73 74 2d 73 65 ine (rmt:test-se
7be0: 74 2d 61 72 63 68 69 76 65 2d 62 6c 6f 63 6b 2d t-archive-block-
7bf0: 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 id run-id test-i
7c00: 64 20 61 72 63 68 69 76 65 2d 62 6c 6f 63 6b 2d d archive-block-
7c10: 69 64 20 61 72 65 61 2d 64 61 74 29 0a 20 20 28 id area-dat). (
7c20: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
7c30: 20 27 74 65 73 74 2d 73 65 74 2d 61 72 63 68 69 'test-set-archi
7c40: 76 65 2d 62 6c 6f 63 6b 2d 69 64 20 72 75 6e 2d ve-block-id run-
7c50: 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 id (list run-id
7c60: 74 65 73 74 2d 69 64 20 61 72 63 68 69 76 65 2d test-id archive-
7c70: 62 6c 6f 63 6b 2d 69 64 29 20 61 72 65 61 2d 64 block-id) area-d
7c80: 61 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 at))..(define (r
7c90: 6d 74 3a 74 65 73 74 2d 67 65 74 2d 61 72 63 68 mt:test-get-arch
7ca0: 69 76 65 2d 62 6c 6f 63 6b 2d 69 6e 66 6f 20 61 ive-block-info a
7cb0: 72 63 68 69 76 65 2d 62 6c 6f 63 6b 2d 69 64 20 rchive-block-id
7cc0: 61 72 65 61 2d 64 61 74 29 0a 20 20 28 72 6d 74 area-dat). (rmt
7cd0: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 74 :send-receive 't
7ce0: 65 73 74 2d 67 65 74 2d 61 72 63 68 69 76 65 2d est-get-archive-
7cf0: 62 6c 6f 63 6b 2d 69 6e 66 6f 20 23 66 20 28 6c block-info #f (l
7d00: 69 73 74 20 61 72 63 68 69 76 65 2d 62 6c 6f 63 ist archive-bloc
7d10: 6b 2d 69 64 29 20 61 72 65 61 2d 64 61 74 29 29 k-id) area-dat))
7d20: 0a .