0000: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
0010: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0020: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0030: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0040: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 43 6f 70 79 ========.;; Copy
0050: 72 69 67 68 74 20 32 30 30 36 2d 32 30 31 37 2c right 2006-2017,
0060: 20 4d 61 74 74 68 65 77 20 57 65 6c 6c 61 6e 64 Matthew Welland
0070: 2e 0a 3b 3b 20 0a 3b 3b 20 20 54 68 69 73 20 70 ..;; .;; This p
0080: 72 6f 67 72 61 6d 20 69 73 20 6d 61 64 65 20 61 rogram is made a
0090: 76 61 69 6c 61 62 6c 65 20 75 6e 64 65 72 20 74 vailable under t
00a0: 68 65 20 47 4e 55 20 47 50 4c 20 76 65 72 73 69 he GNU GPL versi
00b0: 6f 6e 20 32 2e 30 20 6f 72 0a 3b 3b 20 20 67 72 on 2.0 or.;; gr
00c0: 65 61 74 65 72 2e 20 53 65 65 20 74 68 65 20 61 eater. See the a
00d0: 63 63 6f 6d 70 61 6e 79 69 6e 67 20 66 69 6c 65 ccompanying file
00e0: 20 43 4f 50 59 49 4e 47 20 66 6f 72 20 64 65 74 COPYING for det
00f0: 61 69 6c 73 2e 0a 3b 3b 20 0a 3b 3b 20 20 54 68 ails..;; .;; Th
0100: 69 73 20 70 72 6f 67 72 61 6d 20 69 73 20 64 69 is program is di
0110: 73 74 72 69 62 75 74 65 64 20 57 49 54 48 4f 55 stributed WITHOU
0120: 54 20 41 4e 59 20 57 41 52 52 41 4e 54 59 3b 20 T ANY WARRANTY;
0130: 77 69 74 68 6f 75 74 20 65 76 65 6e 20 74 68 65 without even the
0140: 0a 3b 3b 20 20 69 6d 70 6c 69 65 64 20 77 61 72 .;; implied war
0150: 72 61 6e 74 79 20 6f 66 20 4d 45 52 43 48 41 4e ranty of MERCHAN
0160: 54 41 42 49 4c 49 54 59 20 6f 72 20 46 49 54 4e TABILITY or FITN
0170: 45 53 53 20 46 4f 52 20 41 20 50 41 52 54 49 43 ESS FOR A PARTIC
0180: 55 4c 41 52 0a 3b 3b 20 20 50 55 52 50 4f 53 45 ULAR.;; PURPOSE
0190: 2e 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
01a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 75 73 65 ==========..(use
01e0: 20 66 6f 72 6d 61 74 20 74 79 70 65 64 2d 72 65 format typed-re
01f0: 63 6f 72 64 73 29 20 3b 3b 20 52 41 44 54 20 3d cords) ;; RADT =
0200: 3e 20 70 75 72 70 6f 73 65 20 6f 66 20 6a 73 6f > purpose of jso
0210: 6e 20 66 6f 72 6d 61 74 3f 3f 0a 0a 28 64 65 63 n format??..(dec
0220: 6c 61 72 65 20 28 75 6e 69 74 20 6d 72 6d 74 29 lare (unit mrmt)
0230: 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 ).(declare (uses
0240: 20 61 70 69 29 29 0a 3b 3b 20 28 64 65 63 6c 61 api)).;; (decla
0250: 72 65 20 28 75 73 65 73 20 74 64 62 29 29 0a 28 re (uses tdb)).(
0260: 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 68 74 declare (uses ht
0270: 74 70 2d 74 72 61 6e 73 70 6f 72 74 29 29 0a 3b tp-transport)).;
0280: 3b 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 ;(declare (uses
0290: 6e 6d 73 67 2d 74 72 61 6e 73 70 6f 72 74 29 29 nmsg-transport))
02a0: 0a 28 69 6e 63 6c 75 64 65 20 22 63 6f 6d 6d 6f .(include "commo
02b0: 6e 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a n_records.scm").
02c0: 0a 3b 3b 0a 3b 3b 20 54 48 45 53 45 20 41 52 45 .;;.;; THESE ARE
02d0: 20 41 4c 4c 20 43 41 4c 4c 45 44 20 4f 4e 20 54 ALL CALLED ON T
02e0: 48 45 20 43 4c 49 45 4e 54 20 53 49 44 45 21 21 HE CLIENT SIDE!!
02f0: 21 0a 3b 3b 0a 0a 3b 3b 20 67 65 6e 65 72 61 74 !.;;..;; generat
0300: 65 20 65 6e 74 72 69 65 73 20 66 6f 72 20 7e 2f e entries for ~/
0310: 2e 6d 65 67 61 74 65 73 74 72 63 20 77 69 74 68 .megatestrc with
0320: 20 74 68 65 20 66 6f 6c 6c 6f 77 69 6e 67 0a 3b the following.;
0330: 3b 0a 3b 3b 20 20 67 72 65 70 20 64 65 66 69 6e ;.;; grep defin
0340: 65 20 2e 2e 2f 72 6d 74 2e 73 63 6d 20 7c 20 67 e ../rmt.scm | g
0350: 72 65 70 20 6d 72 6d 74 3a 20 7c 70 65 72 6c 20 rep mrmt: |perl
0360: 2d 70 69 20 2d 65 20 27 73 2f 5c 28 64 65 66 69 -pi -e 's/\(defi
0370: 6e 65 5c 73 2b 5c 28 28 5c 53 2b 29 5c 57 2e 2a ne\s+\((\S+)\W.*
0380: 24 2f 5c 31 2f 27 7c 73 6f 72 74 20 2d 75 0a 0a $/\1/'|sort -u..
0390: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
03a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
03b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
03c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
03d0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 53 20 55 ========.;; S U
03e0: 20 50 20 50 20 4f 20 52 20 54 20 20 20 46 20 55 P P O R T F U
03f0: 20 4e 20 43 20 54 20 49 20 4f 20 4e 20 53 0a 3b N C T I O N S.;
0400: 3b 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 3d 3d 3d 3d 3d 3d ================
0430: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0440: 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 69 66 20 61 =======..;; if a
0450: 20 73 65 72 76 65 72 20 69 73 20 65 69 74 68 65 server is eithe
0460: 72 20 72 75 6e 6e 69 6e 67 20 6f 72 20 69 6e 20 r running or in
0470: 74 68 65 20 70 72 6f 63 65 73 73 20 6f 66 20 73 the process of s
0480: 74 61 72 74 69 6e 67 20 63 61 6c 6c 20 63 6c 69 tarting call cli
0490: 65 6e 74 3a 73 65 74 75 70 0a 3b 3b 20 65 6c 73 ent:setup.;; els
04a0: 65 20 72 65 74 75 72 6e 20 23 66 20 74 6f 20 6c e return #f to l
04b0: 65 74 20 74 68 65 20 63 61 6c 6c 69 6e 67 20 70 et the calling p
04c0: 72 6f 63 20 6b 6e 6f 77 20 74 68 61 74 20 74 68 roc know that th
04d0: 65 72 65 20 69 73 20 6e 6f 20 73 65 72 76 65 72 ere is no server
04e0: 20 61 76 61 69 6c 61 62 6c 65 0a 3b 3b 0a 28 64 available.;;.(d
04f0: 65 66 69 6e 65 20 28 6d 72 6d 74 3a 67 65 74 2d efine (mrmt:get-
0500: 63 6f 6e 6e 65 63 74 69 6f 6e 2d 69 6e 66 6f 20 connection-info
0510: 61 72 65 61 70 61 74 68 20 23 21 6b 65 79 20 28 areapath #!key (
0520: 61 72 65 61 2d 64 61 74 20 23 66 29 29 20 3b 3b area-dat #f)) ;;
0530: 20 54 4f 44 4f 3a 20 70 75 73 68 20 61 72 65 61 TODO: push area
0540: 70 61 74 68 20 64 6f 77 6e 2e 0a 20 20 28 6c 65 path down.. (le
0550: 74 2a 20 28 28 72 75 6e 72 65 6d 6f 74 65 20 28 t* ((runremote (
0560: 6f 72 20 61 72 65 61 2d 64 61 74 20 2a 72 75 6e or area-dat *run
0570: 72 65 6d 6f 74 65 2a 29 29 0a 09 20 28 63 69 6e remote*)).. (cin
0580: 66 6f 20 20 20 20 20 28 69 66 20 28 72 65 6d 6f fo (if (remo
0590: 74 65 3f 20 72 75 6e 72 65 6d 6f 74 65 29 0a 09 te? runremote)..
05a0: 09 09 28 72 65 6d 6f 74 65 2d 63 6f 6e 6e 64 61 ..(remote-connda
05b0: 74 20 72 75 6e 72 65 6d 6f 74 65 29 0a 09 09 09 t runremote)....
05c0: 23 66 29 29 29 0a 09 20 20 28 69 66 20 63 69 6e #f))).. (if cin
05d0: 66 6f 0a 09 20 20 20 20 20 20 63 69 6e 66 6f 0a fo.. cinfo.
05e0: 09 20 20 20 20 20 20 28 69 66 20 28 73 65 72 76 . (if (serv
05f0: 65 72 3a 63 68 65 63 6b 2d 69 66 2d 72 75 6e 6e er:check-if-runn
0600: 69 6e 67 20 61 72 65 61 70 61 74 68 29 0a 09 09 ing areapath)...
0610: 20 20 28 63 6c 69 65 6e 74 3a 73 65 74 75 70 20 (client:setup
0620: 61 72 65 61 70 61 74 68 29 0a 09 09 20 20 23 66 areapath)... #f
0630: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 2a 73 ))))..(define *s
0640: 65 6e 64 2d 72 65 63 65 69 76 65 2d 6d 75 74 65 end-receive-mute
0650: 78 2a 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 x* (make-mutex))
0660: 20 3b 3b 20 73 68 6f 75 6c 64 20 68 61 76 65 20 ;; should have
0670: 73 65 70 61 72 61 74 65 20 6d 75 74 65 78 20 70 separate mutex p
0680: 65 72 20 72 75 6e 2d 69 64 0a 0a 3b 3b 20 52 41 er run-id..;; RA
0690: 20 3d 3e 20 65 2e 67 2e 20 75 73 61 67 65 20 28 => e.g. usage (
06a0: 6d 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 mrmt:send-receiv
06b0: 65 20 27 67 65 74 2d 76 61 72 20 23 66 20 28 6c e 'get-var #f (l
06c0: 69 73 74 20 76 61 72 6e 61 6d 65 29 29 0a 3b 3b ist varname)).;;
06d0: 0a 28 64 65 66 69 6e 65 20 28 6d 72 6d 74 3a 73 .(define (mrmt:s
06e0: 65 6e 64 2d 72 65 63 65 69 76 65 20 63 6d 64 20 end-receive cmd
06f0: 72 69 64 20 70 61 72 61 6d 73 20 23 21 6b 65 79 rid params #!key
0700: 20 28 61 74 74 65 6d 70 74 6e 75 6d 20 31 29 28 (attemptnum 1)(
0710: 61 72 65 61 2d 64 61 74 20 23 66 29 29 20 3b 3b area-dat #f)) ;;
0720: 20 73 74 61 72 74 20 61 74 74 65 6d 70 74 6e 75 start attemptnu
0730: 6d 20 61 74 20 31 20 73 6f 20 74 68 65 20 6d 6f m at 1 so the mo
0740: 64 75 6c 6f 20 62 65 6c 6f 77 20 77 6f 72 6b 73 dulo below works
0750: 20 61 73 20 65 78 70 65 63 74 65 64 0a 0a 20 20 as expected..
0760: 3b 3b 44 4f 54 20 64 69 67 72 61 70 68 20 6d 65 ;;DOT digraph me
0770: 67 61 74 65 73 74 5f 73 74 61 74 65 5f 73 74 61 gatest_state_sta
0780: 74 75 73 20 7b 0a 20 20 3b 3b 44 4f 54 20 20 20 tus {. ;;DOT
0790: 72 61 6e 6b 73 65 70 3d 30 3b 0a 20 20 3b 3b 44 ranksep=0;. ;;D
07a0: 4f 54 20 20 20 2f 2f 20 72 61 6e 6b 64 69 72 3d OT // rankdir=
07b0: 4c 52 3b 0a 20 20 3b 3b 44 4f 54 20 20 20 6e 6f LR;. ;;DOT no
07c0: 64 65 20 5b 73 68 61 70 65 3d 22 62 6f 78 22 5d de [shape="box"]
07d0: 3b 0a 20 20 3b 3b 44 4f 54 20 22 6d 72 6d 74 3a ;. ;;DOT "mrmt:
07e0: 73 65 6e 64 2d 72 65 63 65 69 76 65 22 20 2d 3e send-receive" ->
07f0: 20 4d 55 54 45 58 4c 4f 43 4b 3b 0a 20 20 3b 3b MUTEXLOCK;. ;;
0800: 44 4f 54 20 7b 20 65 64 67 65 20 5b 73 74 79 6c DOT { edge [styl
0810: 65 3d 69 6e 76 69 73 5d 3b 22 63 61 73 65 20 31 e=invis];"case 1
0820: 22 20 2d 3e 20 22 63 61 73 65 20 32 22 20 2d 3e " -> "case 2" ->
0830: 20 22 63 61 73 65 20 33 22 20 2d 3e 20 22 63 61 "case 3" -> "ca
0840: 73 65 20 34 22 20 2d 3e 20 22 63 61 73 65 20 35 se 4" -> "case 5
0850: 22 20 2d 3e 20 22 63 61 73 65 20 36 22 20 2d 3e " -> "case 6" ->
0860: 20 22 63 61 73 65 20 37 22 20 2d 3e 20 22 63 61 "case 7" -> "ca
0870: 73 65 20 38 22 20 2d 3e 20 22 63 61 73 65 20 39 se 8" -> "case 9
0880: 22 20 2d 3e 20 22 63 61 73 65 20 31 30 22 20 2d " -> "case 10" -
0890: 3e 20 22 63 61 73 65 20 31 31 22 3b 20 7d 0a 20 > "case 11"; }.
08a0: 20 3b 3b 20 64 6f 20 61 6c 6c 20 74 68 65 20 70 ;; do all the p
08b0: 72 65 70 20 6c 6f 63 6b 65 64 20 75 6e 64 65 72 rep locked under
08c0: 20 74 68 65 20 72 6d 74 2d 6d 75 74 65 78 0a 20 the rmt-mutex.
08d0: 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 72 (mutex-lock! *r
08e0: 6d 74 2d 6d 75 74 65 78 2a 29 0a 20 20 0a 20 20 mt-mutex*). .
08f0: 3b 3b 20 31 2e 20 63 68 65 63 6b 20 69 66 20 73 ;; 1. check if s
0900: 65 72 76 65 72 20 69 73 20 73 74 61 72 74 65 64 erver is started
0910: 20 49 46 46 20 63 6d 64 20 69 73 20 61 20 77 72 IFF cmd is a wr
0920: 69 74 65 20 4f 52 20 69 66 20 77 65 20 61 72 65 ite OR if we are
0930: 20 6e 6f 74 20 6f 6e 20 74 68 65 20 68 6f 6d 65 not on the home
0940: 68 6f 73 74 2c 20 73 74 6f 72 65 20 69 6e 20 72 host, store in r
0950: 75 6e 72 65 6d 6f 74 65 0a 20 20 3b 3b 20 32 2e unremote. ;; 2.
0960: 20 63 68 65 63 6b 20 74 68 65 20 61 67 65 20 6f check the age o
0970: 66 20 74 68 65 20 63 6f 6e 6e 65 63 74 69 6f 6e f the connection
0980: 73 2e 20 72 65 66 72 65 73 68 20 74 68 65 20 63 s. refresh the c
0990: 6f 6e 6e 65 63 74 69 6f 6e 20 69 66 20 69 74 20 onnection if it
09a0: 69 73 20 6f 6c 64 65 72 20 74 68 61 6e 20 74 69 is older than ti
09b0: 6d 65 6f 75 74 2d 32 30 20 73 65 63 6f 6e 64 73 meout-20 seconds
09c0: 2e 0a 20 20 3b 3b 20 33 2e 20 64 6f 20 74 68 65 .. ;; 3. do the
09d0: 20 71 75 65 72 79 2c 20 69 66 20 6f 6e 20 68 6f query, if on ho
09e0: 6d 65 68 6f 73 74 20 75 73 65 20 6c 6f 63 61 6c mehost use local
09f0: 20 61 63 63 65 73 73 0a 20 20 3b 3b 0a 20 20 28 access. ;;. (
0a00: 6c 65 74 2a 20 28 28 73 74 61 72 74 2d 74 69 6d let* ((start-tim
0a10: 65 20 20 20 20 28 63 75 72 72 65 6e 74 2d 73 65 e (current-se
0a20: 63 6f 6e 64 73 29 29 20 3b 3b 20 73 6e 61 70 73 conds)) ;; snaps
0a30: 68 6f 74 20 74 69 6d 65 20 73 6f 20 61 6c 6c 20 hot time so all
0a40: 75 73 65 20 63 61 73 65 73 20 67 65 74 20 73 61 use cases get sa
0a50: 6d 65 20 76 61 6c 75 65 0a 20 20 20 20 20 20 20 me value.
0a60: 20 20 28 61 72 65 61 70 61 74 68 20 20 20 20 20 (areapath
0a70: 20 2a 74 6f 70 70 61 74 68 2a 29 3b 3b 20 54 4f *toppath*);; TO
0a80: 44 4f 20 2d 20 72 65 73 6f 6c 76 65 20 66 72 6f DO - resolve fro
0a90: 6d 20 64 62 73 74 72 75 63 74 20 74 6f 20 62 65 m dbstruct to be
0aa0: 20 63 6f 6d 70 61 74 69 62 6c 65 20 77 69 74 68 compatible with
0ab0: 20 6d 75 6c 74 69 70 6c 65 20 61 72 65 61 73 0a multiple areas.
0ac0: 09 20 28 72 75 6e 72 65 6d 6f 74 65 20 20 20 20 . (runremote
0ad0: 20 28 6f 72 20 61 72 65 61 2d 64 61 74 0a 09 09 (or area-dat...
0ae0: 09 20 20 20 20 2a 72 75 6e 72 65 6d 6f 74 65 2a . *runremote*
0af0: 29 29 0a 09 20 28 72 65 61 64 6f 6e 6c 79 2d 6d )).. (readonly-m
0b00: 6f 64 65 20 28 69 66 20 28 61 6e 64 20 72 75 6e ode (if (and run
0b10: 72 65 6d 6f 74 65 0a 09 09 09 09 20 28 72 65 6d remote..... (rem
0b20: 6f 74 65 2d 72 6f 2d 6d 6f 64 65 2d 63 68 65 63 ote-ro-mode-chec
0b30: 6b 65 64 20 72 75 6e 72 65 6d 6f 74 65 29 29 0a ked runremote)).
0b40: 09 09 09 20 20 20 20 28 72 65 6d 6f 74 65 2d 72 ... (remote-r
0b50: 6f 2d 6d 6f 64 65 20 72 75 6e 72 65 6d 6f 74 65 o-mode runremote
0b60: 29 0a 09 09 09 20 20 20 20 28 6c 65 74 2a 20 28 ).... (let* (
0b70: 28 64 62 66 69 6c 65 20 20 28 63 6f 6e 63 20 2a (dbfile (conc *
0b80: 74 6f 70 70 61 74 68 2a 20 22 2f 6d 65 67 61 74 toppath* "/megat
0b90: 65 73 74 2e 64 62 22 29 29 0a 09 09 09 09 20 20 est.db")).....
0ba0: 20 28 72 6f 2d 6d 6f 64 65 20 28 6e 6f 74 20 28 (ro-mode (not (
0bb0: 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 73 file-write-acces
0bc0: 73 3f 20 64 62 66 69 6c 65 29 29 29 29 20 3b 3b s? dbfile)))) ;;
0bd0: 20 54 4f 44 4f 3a 20 75 73 65 20 64 62 73 74 72 TODO: use dbstr
0be0: 75 63 74 20 6f 72 20 72 75 6e 72 65 6d 6f 74 65 uct or runremote
0bf0: 20 74 6f 20 66 69 67 75 72 65 20 74 68 69 73 20 to figure this
0c00: 6f 75 74 20 69 6e 20 66 75 74 75 72 65 0a 09 09 out in future...
0c10: 09 20 20 20 20 20 20 28 69 66 20 72 75 6e 72 65 . (if runre
0c20: 6d 6f 74 65 0a 09 09 09 09 20 20 28 62 65 67 69 mote..... (begi
0c30: 6e 0a 09 09 09 09 20 20 20 20 28 72 65 6d 6f 74 n..... (remot
0c40: 65 2d 72 6f 2d 6d 6f 64 65 2d 73 65 74 21 20 72 e-ro-mode-set! r
0c50: 75 6e 72 65 6d 6f 74 65 20 72 6f 2d 6d 6f 64 65 unremote ro-mode
0c60: 29 0a 09 09 09 09 20 20 20 20 28 72 65 6d 6f 74 )..... (remot
0c70: 65 2d 72 6f 2d 6d 6f 64 65 2d 63 68 65 63 6b 65 e-ro-mode-checke
0c80: 64 2d 73 65 74 21 20 72 75 6e 72 65 6d 6f 74 65 d-set! runremote
0c90: 20 23 74 29 0a 09 09 09 09 20 20 20 20 72 6f 2d #t)..... ro-
0ca0: 6d 6f 64 65 29 0a 09 09 09 09 20 20 72 6f 2d 6d mode)..... ro-m
0cb0: 6f 64 65 29 29 29 29 29 0a 0a 20 20 20 20 3b 3b ode))))).. ;;
0cc0: 20 44 4f 54 20 49 4e 49 54 5f 52 55 4e 52 45 4d DOT INIT_RUNREM
0cd0: 4f 54 45 3b 20 2f 2f 20 6c 65 61 76 69 6e 67 20 OTE; // leaving
0ce0: 6f 66 66 20 2d 20 64 6f 65 73 6e 27 74 20 72 65 off - doesn't re
0cf0: 61 6c 6c 79 20 61 64 64 20 74 6f 20 74 68 65 20 ally add to the
0d00: 63 6c 61 72 69 74 79 0a 20 20 20 20 3b 3b 20 44 clarity. ;; D
0d10: 4f 54 20 4d 55 54 45 58 4c 4f 43 4b 20 2d 3e 20 OT MUTEXLOCK ->
0d20: 49 4e 49 54 5f 52 55 4e 52 45 4d 4f 54 45 20 5b INIT_RUNREMOTE [
0d30: 6c 61 62 65 6c 3d 22 6e 6f 20 72 65 6d 6f 74 65 label="no remote
0d40: 3f 22 5d 3b 0a 20 20 20 20 3b 3b 20 44 4f 54 20 ?"];. ;; DOT
0d50: 49 4e 49 54 5f 52 55 4e 52 45 4d 4f 54 45 20 2d INIT_RUNREMOTE -
0d60: 3e 20 4d 55 54 45 58 4c 4f 43 4b 3b 0a 20 20 20 > MUTEXLOCK;.
0d70: 20 3b 3b 20 65 6e 73 75 72 65 20 77 65 20 68 61 ;; ensure we ha
0d80: 76 65 20 61 20 72 65 63 6f 72 64 20 66 6f 72 20 ve a record for
0d90: 6f 75 72 20 63 6f 6e 6e 65 63 74 69 6f 6e 20 66 our connection f
0da0: 6f 72 20 67 69 76 65 6e 20 61 72 65 61 0a 20 20 or given area.
0db0: 20 20 28 69 66 20 28 6e 6f 74 20 72 75 6e 72 65 (if (not runre
0dc0: 6d 6f 74 65 29 20 20 20 20 20 20 20 20 20 20 20 mote)
0dd0: 20 20 20 20 20 20 20 20 3b 3b 20 63 61 6e 20 72 ;; can r
0de0: 65 6d 6f 76 65 20 74 68 69 73 20 6f 6e 65 2e 20 emove this one.
0df0: 73 68 6f 75 6c 64 20 6e 65 76 65 72 20 67 65 74 should never get
0e00: 20 68 65 72 65 2e 20 20 20 20 20 20 20 20 20 0a here. .
0e10: 09 28 62 65 67 69 6e 0a 09 20 20 28 73 65 74 21 .(begin.. (set!
0e20: 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 28 6d 61 *runremote* (ma
0e30: 6b 65 2d 72 65 6d 6f 74 65 29 29 0a 09 20 20 28 ke-remote)).. (
0e40: 73 65 74 21 20 72 75 6e 72 65 6d 6f 74 65 20 20 set! runremote
0e50: 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 29 29 29 20 *runremote*)))
0e60: 3b 3b 20 6e 65 77 20 72 75 6e 72 65 6d 6f 74 65 ;; new runremote
0e70: 20 77 69 6c 6c 20 63 6f 6d 65 20 66 72 6f 6d 20 will come from
0e80: 74 68 69 73 20 6f 6e 20 6e 65 78 74 20 69 74 65 this on next ite
0e90: 72 61 74 69 6f 6e 0a 20 20 20 20 0a 20 20 20 20 ration. .
0ea0: 3b 3b 20 44 4f 54 20 53 45 54 5f 48 4f 4d 45 48 ;; DOT SET_HOMEH
0eb0: 4f 53 54 3b 20 2f 2f 20 6c 65 61 76 69 6e 67 20 OST; // leaving
0ec0: 6f 66 66 20 2d 20 64 6f 65 73 6e 27 74 20 72 65 off - doesn't re
0ed0: 61 6c 6c 79 20 61 64 64 20 74 6f 20 74 68 65 20 ally add to the
0ee0: 63 6c 61 72 69 74 79 0a 20 20 20 20 3b 3b 20 44 clarity. ;; D
0ef0: 4f 54 20 4d 55 54 45 58 4c 4f 43 4b 20 2d 3e 20 OT MUTEXLOCK ->
0f00: 53 45 54 5f 48 4f 4d 45 48 4f 53 54 20 5b 6c 61 SET_HOMEHOST [la
0f10: 62 65 6c 3d 22 6e 6f 20 68 6f 6d 65 68 6f 73 74 bel="no homehost
0f20: 3f 22 5d 3b 0a 20 20 20 20 3b 3b 20 44 4f 54 20 ?"];. ;; DOT
0f30: 53 45 54 5f 48 4f 4d 45 48 4f 53 54 20 2d 3e 20 SET_HOMEHOST ->
0f40: 4d 55 54 45 58 4c 4f 43 4b 3b 0a 20 20 20 20 3b MUTEXLOCK;. ;
0f50: 3b 20 65 6e 73 75 72 65 20 77 65 20 68 61 76 65 ; ensure we have
0f60: 20 61 20 68 6f 6d 65 68 6f 73 74 20 72 65 63 6f a homehost reco
0f70: 72 64 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 rd. (if (not
0f80: 28 70 61 69 72 3f 20 28 72 65 6d 6f 74 65 2d 68 (pair? (remote-h
0f90: 68 2d 64 61 74 20 72 75 6e 72 65 6d 6f 74 65 29 h-dat runremote)
0fa0: 29 29 20 20 3b 3b 20 6e 6f 74 20 6f 6e 20 68 6f )) ;; not on ho
0fb0: 6d 65 68 6f 73 74 0a 09 28 74 68 72 65 61 64 2d mehost..(thread-
0fc0: 73 6c 65 65 70 21 20 30 2e 31 29 20 3b 3b 20 73 sleep! 0.1) ;; s
0fd0: 69 6e 63 65 20 77 65 20 73 68 6f 75 6c 64 6e 27 ince we shouldn'
0fe0: 74 20 67 65 74 20 68 65 72 65 2c 20 64 65 6c 61 t get here, dela
0ff0: 79 20 61 20 6c 69 74 74 6c 65 0a 09 28 72 65 6d y a little..(rem
1000: 6f 74 65 2d 68 68 2d 64 61 74 2d 73 65 74 21 20 ote-hh-dat-set!
1010: 72 75 6e 72 65 6d 6f 74 65 20 28 63 6f 6d 6d 6f runremote (commo
1020: 6e 3a 67 65 74 2d 68 6f 6d 65 68 6f 73 74 29 29 n:get-homehost))
1030: 29 0a 20 20 20 20 0a 20 20 20 20 3b 3b 28 70 72 ). . ;;(pr
1040: 69 6e 74 20 22 42 42 3e 20 72 65 61 64 6f 6e 6c int "BB> readonl
1050: 79 2d 6d 6f 64 65 20 69 73 20 22 72 65 61 64 6f y-mode is "reado
1060: 6e 6c 79 2d 6d 6f 64 65 22 20 64 62 66 69 6c 65 nly-mode" dbfile
1070: 20 69 73 20 22 64 62 66 69 6c 65 29 0a 20 20 20 is "dbfile).
1080: 20 28 63 6f 6e 64 0a 20 20 20 20 20 3b 3b 44 4f (cond. ;;DO
1090: 54 20 45 58 49 54 3b 0a 20 20 20 20 20 3b 3b 44 T EXIT;. ;;D
10a0: 4f 54 20 4d 55 54 45 58 4c 4f 43 4b 20 2d 3e 20 OT MUTEXLOCK ->
10b0: 45 58 49 54 20 5b 6c 61 62 65 6c 3d 22 3e 20 31 EXIT [label="> 1
10c0: 35 20 61 74 74 65 6d 70 74 73 22 5d 3b 20 7b 72 5 attempts"]; {r
10d0: 61 6e 6b 3d 73 61 6d 65 20 22 63 61 73 65 20 31 ank=same "case 1
10e0: 22 20 22 45 58 49 54 22 20 7d 0a 20 20 20 20 20 " "EXIT" }.
10f0: 3b 3b 20 67 69 76 65 20 75 70 20 69 66 20 6d 6f ;; give up if mo
1100: 72 65 20 74 68 61 6e 20 31 35 20 61 74 74 65 6d re than 15 attem
1110: 70 74 73 0a 20 20 20 20 20 28 28 3e 20 61 74 74 pts. ((> att
1120: 65 6d 70 74 6e 75 6d 20 31 35 29 0a 20 20 20 20 emptnum 15).
1130: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
1140: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
1150: 72 74 2a 20 22 45 52 52 4f 52 3a 20 31 35 20 74 rt* "ERROR: 15 t
1160: 72 69 65 73 20 74 6f 20 73 74 61 72 74 2f 63 6f ries to start/co
1170: 6e 6e 65 63 74 20 74 6f 20 73 65 72 76 65 72 2e nnect to server.
1180: 20 47 69 76 69 6e 67 20 75 70 2e 22 29 0a 20 20 Giving up.").
1190: 20 20 20 20 28 65 78 69 74 20 31 29 29 0a 0a 20 (exit 1))..
11a0: 20 20 20 20 3b 3b 44 4f 54 20 43 41 53 45 32 20 ;;DOT CASE2
11b0: 5b 6c 61 62 65 6c 3d 22 6c 6f 63 61 6c 5c 6e 72 [label="local\nr
11c0: 65 61 64 6f 6e 6c 79 5c 6e 71 75 65 72 79 22 5d eadonly\nquery"]
11d0: 3b 0a 20 20 20 20 20 3b 3b 44 4f 54 20 4d 55 54 ;. ;;DOT MUT
11e0: 45 58 4c 4f 43 4b 20 2d 3e 20 43 41 53 45 32 3b EXLOCK -> CASE2;
11f0: 20 7b 72 61 6e 6b 3d 73 61 6d 65 20 22 63 61 73 {rank=same "cas
1200: 65 20 32 22 20 43 41 53 45 32 7d 0a 20 20 20 20 e 2" CASE2}.
1210: 20 3b 3b 44 4f 54 20 43 41 53 45 32 20 2d 3e 20 ;;DOT CASE2 ->
1220: 22 6d 72 6d 74 3a 6f 70 65 6e 2d 71 72 79 2d 63 "mrmt:open-qry-c
1230: 6c 6f 73 65 2d 6c 6f 63 61 6c 6c 79 22 3b 0a 20 lose-locally";.
1240: 20 20 20 20 3b 3b 20 72 65 61 64 6f 6e 6c 79 20 ;; readonly
1250: 6d 6f 64 65 2c 20 72 65 61 64 20 72 65 71 75 65 mode, read reque
1260: 73 74 2d 20 20 68 61 6e 64 6c 65 20 69 74 20 2d st- handle it -
1270: 20 63 61 73 65 20 32 0a 20 20 20 20 20 28 28 61 case 2. ((a
1280: 6e 64 20 72 65 61 64 6f 6e 6c 79 2d 6d 6f 64 65 nd readonly-mode
1290: 0a 20 20 20 20 20 20 20 20 20 20 20 28 6d 65 6d . (mem
12a0: 62 65 72 20 63 6d 64 20 61 70 69 3a 72 65 61 64 ber cmd api:read
12b0: 2d 6f 6e 6c 79 2d 71 75 65 72 69 65 73 29 29 20 -only-queries))
12c0: 0a 20 20 20 20 20 20 28 6d 75 74 65 78 2d 75 6e . (mutex-un
12d0: 6c 6f 63 6b 21 20 2a 72 6d 74 2d 6d 75 74 65 78 lock! *rmt-mutex
12e0: 2a 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a *). (debug:
12f0: 70 72 69 6e 74 2d 69 6e 66 6f 20 31 32 20 2a 64 print-info 12 *d
1300: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
1310: 20 22 6d 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 "mrmt:send-rece
1320: 69 76 65 2c 20 63 61 73 65 20 32 22 29 0a 20 20 ive, case 2").
1330: 20 20 20 20 28 6d 72 6d 74 3a 6f 70 65 6e 2d 71 (mrmt:open-q
1340: 72 79 2d 63 6c 6f 73 65 2d 6c 6f 63 61 6c 6c 79 ry-close-locally
1350: 20 63 6d 64 20 30 20 70 61 72 61 6d 73 29 0a 20 cmd 0 params).
1360: 20 20 20 20 20 29 0a 0a 20 20 20 20 20 3b 3b 44 ).. ;;D
1370: 4f 54 20 43 41 53 45 33 20 5b 6c 61 62 65 6c 3d OT CASE3 [label=
1380: 22 77 72 69 74 65 20 69 6e 5c 6e 72 65 61 64 2d "write in\nread-
1390: 6f 6e 6c 79 20 6d 6f 64 65 22 5d 3b 0a 20 20 20 only mode"];.
13a0: 20 20 3b 3b 44 4f 54 20 4d 55 54 45 58 4c 4f 43 ;;DOT MUTEXLOC
13b0: 4b 20 2d 3e 20 43 41 53 45 33 20 5b 6c 61 62 65 K -> CASE3 [labe
13c0: 6c 3d 22 72 65 61 64 6f 6e 6c 79 5c 6e 6d 6f 64 l="readonly\nmod
13d0: 65 3f 22 5d 3b 20 7b 72 61 6e 6b 3d 73 61 6d 65 e?"]; {rank=same
13e0: 20 22 63 61 73 65 20 33 22 20 43 41 53 45 33 7d "case 3" CASE3}
13f0: 0a 20 20 20 20 20 3b 3b 44 4f 54 20 43 41 53 45 . ;;DOT CASE
1400: 33 20 2d 3e 20 22 23 66 22 3b 0a 20 20 20 20 20 3 -> "#f";.
1410: 3b 3b 20 72 65 61 64 6f 6e 6c 79 20 6d 6f 64 65 ;; readonly mode
1420: 2c 20 77 72 69 74 65 20 72 65 71 75 65 73 74 2e , write request.
1430: 20 20 44 6f 20 6e 6f 74 68 69 6e 67 2c 20 72 65 Do nothing, re
1440: 74 75 72 6e 20 23 66 0a 20 20 20 20 20 28 72 65 turn #f. (re
1450: 61 64 6f 6e 6c 79 2d 6d 6f 64 65 0a 20 20 20 20 adonly-mode.
1460: 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 (mutex-unlock!
1470: 20 2a 72 6d 74 2d 6d 75 74 65 78 2a 29 0a 20 20 *rmt-mutex*).
1480: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
1490: 2d 69 6e 66 6f 20 31 32 20 2a 64 65 66 61 75 6c -info 12 *defaul
14a0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 6d 72 6d t-log-port* "mrm
14b0: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 2c 20 t:send-receive,
14c0: 63 61 73 65 20 33 22 29 0a 20 20 20 20 20 20 28 case 3"). (
14d0: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
14e0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
14f0: 20 22 57 41 52 4e 49 4e 47 3a 20 77 72 69 74 65 "WARNING: write
1500: 20 74 72 61 6e 73 61 63 74 69 6f 6e 20 72 65 71 transaction req
1510: 75 65 73 74 65 64 20 6f 6e 20 61 20 72 65 61 64 uested on a read
1520: 6f 6e 6c 79 20 61 72 65 61 2e 20 20 63 6d 64 3d only area. cmd=
1530: 22 63 6d 64 22 20 70 61 72 61 6d 73 3d 22 70 61 "cmd" params="pa
1540: 72 61 6d 73 29 0a 20 20 20 20 20 20 23 66 29 0a rams). #f).
1550: 0a 20 20 20 20 20 3b 3b 20 54 68 69 73 20 62 6c . ;; This bl
1560: 6f 63 6b 20 77 61 73 20 66 6f 72 20 70 72 65 2d ock was for pre-
1570: 65 6d 70 74 69 76 65 6c 79 20 72 65 73 65 74 74 emptively resett
1580: 69 6e 67 20 74 68 65 20 63 6f 6e 6e 65 63 74 69 ing the connecti
1590: 6f 6e 20 69 66 20 74 68 65 72 65 20 68 61 64 20 on if there had
15a0: 62 65 65 6e 20 6e 6f 20 63 6f 6d 6d 75 6e 69 63 been no communic
15b0: 61 74 69 6f 6e 20 66 6f 72 20 73 6f 6d 65 20 74 ation for some t
15c0: 69 6d 65 2e 0a 20 20 20 20 20 3b 3b 20 49 20 64 ime.. ;; I d
15d0: 6f 6e 27 74 20 74 68 69 6e 6b 20 69 74 20 61 64 on't think it ad
15e0: 64 73 20 61 6e 79 20 76 61 6c 75 65 2e 20 49 66 ds any value. If
15f0: 20 74 68 65 20 73 65 72 76 65 72 20 69 73 20 6e the server is n
1600: 6f 74 20 74 68 65 72 65 2c 20 6a 75 73 74 20 66 ot there, just f
1610: 61 69 6c 20 61 6e 64 20 73 74 61 72 74 20 61 20 ail and start a
1620: 6e 65 77 20 63 6f 6e 6e 65 63 74 69 6f 6e 2e 0a new connection..
1630: 20 20 20 20 20 3b 3b 20 61 6c 73 6f 2c 20 74 68 ;; also, th
1640: 65 20 65 78 70 69 72 65 2d 74 69 6d 65 20 63 61 e expire-time ca
1650: 6c 63 75 6c 61 74 69 6f 6e 20 6d 69 67 68 74 20 lculation might
1660: 6e 6f 74 20 62 65 20 63 6f 72 72 65 63 74 2e 20 not be correct.
1670: 57 65 20 77 61 6e 74 2c 20 74 69 6d 65 2d 73 69 We want, time-si
1680: 6e 63 65 2d 6c 61 73 74 2d 73 65 72 76 65 72 2d nce-last-server-
1690: 61 63 63 65 73 73 20 3e 20 28 73 65 72 76 65 72 access > (server
16a0: 3a 67 65 74 2d 74 69 6d 65 6f 75 74 29 0a 20 20 :get-timeout).
16b0: 20 20 20 3b 3b 0a 20 20 20 20 20 3b 3b 44 4f 54 ;;. ;;DOT
16c0: 20 43 41 53 45 34 20 5b 6c 61 62 65 6c 3d 22 72 CASE4 [label="r
16d0: 65 73 65 74 5c 6e 63 6f 6e 6e 65 63 74 69 6f 6e eset\nconnection
16e0: 22 5d 3b 0a 20 20 20 20 20 3b 3b 44 4f 54 20 4d "];. ;;DOT M
16f0: 55 54 45 58 4c 4f 43 4b 20 2d 3e 20 43 41 53 45 UTEXLOCK -> CASE
1700: 34 20 5b 6c 61 62 65 6c 3d 22 68 61 76 65 20 63 4 [label="have c
1710: 6f 6e 6e 65 63 74 69 6f 6e 2c 5c 6e 6c 61 73 74 onnection,\nlast
1720: 5f 61 63 63 65 73 73 20 3e 20 65 78 70 69 72 65 _access > expire
1730: 5f 74 69 6d 65 22 5d 3b 20 7b 72 61 6e 6b 3d 73 _time"]; {rank=s
1740: 61 6d 65 20 22 63 61 73 65 20 34 22 20 43 41 53 ame "case 4" CAS
1750: 45 34 7d 0a 20 20 20 20 20 3b 3b 44 4f 54 20 43 E4}. ;;DOT C
1760: 41 53 45 34 20 2d 3e 20 22 6d 72 6d 74 3a 73 65 ASE4 -> "mrmt:se
1770: 6e 64 2d 72 65 63 65 69 76 65 22 3b 0a 20 20 20 nd-receive";.
1780: 20 20 3b 3b 20 72 65 73 65 74 20 74 68 65 20 63 ;; reset the c
1790: 6f 6e 6e 65 63 74 69 6f 6e 20 69 66 20 69 74 20 onnection if it
17a0: 68 61 73 20 62 65 65 6e 20 75 6e 75 73 65 64 20 has been unused
17b0: 74 6f 6f 20 6c 6f 6e 67 0a 20 20 20 20 20 28 28 too long. ((
17c0: 61 6e 64 20 72 75 6e 72 65 6d 6f 74 65 0a 20 20 and runremote.
17d0: 20 20 20 20 20 20 20 20 20 28 72 65 6d 6f 74 65 (remote
17e0: 2d 63 6f 6e 6e 64 61 74 20 72 75 6e 72 65 6d 6f -conndat runremo
17f0: 74 65 29 0a 09 20 20 20 28 3e 20 28 63 75 72 72 te).. (> (curr
1800: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 3b 3b 20 ent-seconds) ;;
1810: 69 66 20 69 74 20 68 61 73 20 62 65 65 6e 20 6d if it has been m
1820: 6f 72 65 20 74 68 61 6e 20 73 65 72 76 65 72 2d ore than server-
1830: 74 69 6d 65 6f 75 74 20 73 65 63 6f 6e 64 73 20 timeout seconds
1840: 73 69 6e 63 65 20 6c 61 73 74 20 63 6f 6e 74 61 since last conta
1850: 63 74 2c 20 63 6c 6f 73 65 20 74 68 69 73 20 63 ct, close this c
1860: 6f 6e 6e 65 63 74 69 6f 6e 20 61 6e 64 20 73 74 onnection and st
1870: 61 72 74 20 61 20 6e 65 77 20 6f 6e 0a 09 20 20 art a new on..
1880: 20 20 20 20 28 2b 20 28 68 74 74 70 2d 74 72 61 (+ (http-tra
1890: 6e 73 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 nsport:server-da
18a0: 74 2d 67 65 74 2d 6c 61 73 74 2d 61 63 63 65 73 t-get-last-acces
18b0: 73 20 28 72 65 6d 6f 74 65 2d 63 6f 6e 6e 64 61 s (remote-connda
18c0: 74 20 72 75 6e 72 65 6d 6f 74 65 29 29 0a 09 09 t runremote))...
18d0: 20 28 72 65 6d 6f 74 65 2d 73 65 72 76 65 72 2d (remote-server-
18e0: 74 69 6d 65 6f 75 74 20 72 75 6e 72 65 6d 6f 74 timeout runremot
18f0: 65 29 29 29 29 0a 20 20 20 20 20 20 28 64 65 62 e)))). (deb
1900: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
1910: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
1920: 74 2a 20 22 43 6f 6e 6e 65 63 74 69 6f 6e 20 74 t* "Connection t
1930: 6f 20 22 20 28 72 65 6d 6f 74 65 2d 73 65 72 76 o " (remote-serv
1940: 65 72 2d 75 72 6c 20 72 75 6e 72 65 6d 6f 74 65 er-url runremote
1950: 29 20 22 20 65 78 70 69 72 65 64 20 64 75 65 20 ) " expired due
1960: 74 6f 20 6e 6f 20 61 63 63 65 73 73 65 73 2c 20 to no accesses,
1970: 66 6f 72 63 69 6e 67 20 6e 65 77 20 63 6f 6e 6e forcing new conn
1980: 65 63 74 69 6f 6e 2e 22 29 0a 20 20 20 20 20 20 ection.").
1990: 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a (http-transport:
19a0: 63 6c 6f 73 65 2d 63 6f 6e 6e 65 63 74 69 6f 6e close-connection
19b0: 73 20 61 72 65 61 2d 64 61 74 3a 20 72 75 6e 72 s area-dat: runr
19c0: 65 6d 6f 74 65 29 0a 20 20 20 20 20 20 28 72 65 emote). (re
19d0: 6d 6f 74 65 2d 63 6f 6e 6e 64 61 74 2d 73 65 74 mote-conndat-set
19e0: 21 20 72 75 6e 72 65 6d 6f 74 65 20 23 66 29 20 ! runremote #f)
19f0: 3b 3b 20 69 6e 76 61 6c 69 64 61 74 65 20 74 68 ;; invalidate th
1a00: 65 20 63 6f 6e 6e 65 63 74 69 6f 6e 2c 20 74 68 e connection, th
1a10: 75 73 20 66 6f 72 63 69 6e 67 20 61 20 6e 65 77 us forcing a new
1a20: 20 63 6f 6e 6e 65 63 74 69 6f 6e 2e 0a 20 20 20 connection..
1a30: 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b (mutex-unlock
1a40: 21 20 2a 72 6d 74 2d 6d 75 74 65 78 2a 29 0a 20 ! *rmt-mutex*).
1a50: 20 20 20 20 20 28 6d 72 6d 74 3a 73 65 6e 64 2d (mrmt:send-
1a60: 72 65 63 65 69 76 65 20 63 6d 64 20 72 69 64 20 receive cmd rid
1a70: 70 61 72 61 6d 73 20 61 74 74 65 6d 70 74 6e 75 params attemptnu
1a80: 6d 3a 20 61 74 74 65 6d 70 74 6e 75 6d 29 29 0a m: attemptnum)).
1a90: 20 20 20 20 20 0a 20 20 20 20 20 3b 3b 44 4f 54 . ;;DOT
1aa0: 20 43 41 53 45 35 20 5b 6c 61 62 65 6c 3d 22 6c CASE5 [label="l
1ab0: 6f 63 61 6c 5c 6e 72 65 61 64 22 5d 3b 0a 20 20 ocal\nread"];.
1ac0: 20 20 20 3b 3b 44 4f 54 20 4d 55 54 45 58 4c 4f ;;DOT MUTEXLO
1ad0: 43 4b 20 2d 3e 20 43 41 53 45 35 20 5b 6c 61 62 CK -> CASE5 [lab
1ae0: 65 6c 3d 22 73 65 72 76 65 72 20 6e 6f 74 20 72 el="server not r
1af0: 65 71 75 69 72 65 64 2c 5c 6e 6f 6e 20 68 6f 6d equired,\non hom
1b00: 65 68 6f 73 74 2c 5c 6e 72 65 61 64 2d 6f 6e 6c ehost,\nread-onl
1b10: 79 20 71 75 65 72 79 22 5d 3b 20 7b 72 61 6e 6b y query"]; {rank
1b20: 3d 73 61 6d 65 20 22 63 61 73 65 20 35 22 20 43 =same "case 5" C
1b30: 41 53 45 35 7d 3b 0a 20 20 20 20 20 3b 3b 44 4f ASE5};. ;;DO
1b40: 54 20 43 41 53 45 35 20 2d 3e 20 22 6d 72 6d 74 T CASE5 -> "mrmt
1b50: 3a 6f 70 65 6e 2d 71 72 79 2d 63 6c 6f 73 65 2d :open-qry-close-
1b60: 6c 6f 63 61 6c 6c 79 22 3b 0a 20 20 20 20 20 3b locally";. ;
1b70: 3b 20 6f 6e 20 68 6f 6d 65 68 6f 73 74 20 61 6e ; on homehost an
1b80: 64 20 74 68 69 73 20 69 73 20 61 20 72 65 61 64 d this is a read
1b90: 0a 20 20 20 20 20 28 28 61 6e 64 20 28 6e 6f 74 . ((and (not
1ba0: 20 28 72 65 6d 6f 74 65 2d 66 6f 72 63 65 2d 73 (remote-force-s
1bb0: 65 72 76 65 72 20 72 75 6e 72 65 6d 6f 74 65 29 erver runremote)
1bc0: 29 20 3b 3b 20 68 6f 6e 6f 72 20 66 6f 72 63 65 ) ;; honor force
1bd0: 64 20 75 73 65 20 6f 66 20 73 65 72 76 65 72 2c d use of server,
1be0: 20 69 2e 65 2e 20 73 65 72 76 65 72 20 4e 4f 54 i.e. server NOT
1bf0: 20 72 65 71 75 69 72 65 64 0a 09 20 20 20 28 63 required.. (c
1c00: 64 72 20 28 72 65 6d 6f 74 65 2d 68 68 2d 64 61 dr (remote-hh-da
1c10: 74 20 72 75 6e 72 65 6d 6f 74 65 29 29 20 20 20 t runremote))
1c20: 20 20 20 20 3b 3b 20 6f 6e 20 68 6f 6d 65 68 6f ;; on homeho
1c30: 73 74 0a 20 20 20 20 20 20 20 20 20 20 20 28 6d st. (m
1c40: 65 6d 62 65 72 20 63 6d 64 20 61 70 69 3a 72 65 ember cmd api:re
1c50: 61 64 2d 6f 6e 6c 79 2d 71 75 65 72 69 65 73 29 ad-only-queries)
1c60: 29 20 20 20 3b 3b 20 74 68 69 73 20 69 73 20 61 ) ;; this is a
1c70: 20 72 65 61 64 0a 20 20 20 20 20 20 28 6d 75 74 read. (mut
1c80: 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 72 6d 74 2d ex-unlock! *rmt-
1c90: 6d 75 74 65 78 2a 29 0a 20 20 20 20 20 20 28 64 mutex*). (d
1ca0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
1cb0: 31 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 12 *default-log-
1cc0: 70 6f 72 74 2a 20 22 6d 72 6d 74 3a 73 65 6e 64 port* "mrmt:send
1cd0: 2d 72 65 63 65 69 76 65 2c 20 63 61 73 65 20 20 -receive, case
1ce0: 35 22 29 0a 20 20 20 20 20 20 28 6d 72 6d 74 3a 5"). (mrmt:
1cf0: 6f 70 65 6e 2d 71 72 79 2d 63 6c 6f 73 65 2d 6c open-qry-close-l
1d00: 6f 63 61 6c 6c 79 20 63 6d 64 20 30 20 70 61 72 ocally cmd 0 par
1d10: 61 6d 73 29 29 0a 0a 20 20 20 20 20 3b 3b 44 4f ams)).. ;;DO
1d20: 54 20 43 41 53 45 36 20 5b 6c 61 62 65 6c 3d 22 T CASE6 [label="
1d30: 69 6e 69 74 5c 6e 72 65 6d 6f 74 65 22 5d 3b 0a init\nremote"];.
1d40: 20 20 20 20 20 3b 3b 44 4f 54 20 4d 55 54 45 58 ;;DOT MUTEX
1d50: 4c 4f 43 4b 20 2d 3e 20 43 41 53 45 36 20 5b 6c LOCK -> CASE6 [l
1d60: 61 62 65 6c 3d 22 6f 6e 20 68 6f 6d 65 68 6f 73 abel="on homehos
1d70: 74 2c 5c 6e 77 72 69 74 65 20 71 75 65 72 79 2c t,\nwrite query,
1d80: 5c 6e 68 61 76 65 20 73 65 72 76 65 72 2c 5c 6e \nhave server,\n
1d90: 63 61 6e 27 74 20 72 65 61 63 68 20 69 74 22 5d can't reach it"]
1da0: 3b 20 7b 72 61 6e 6b 3d 73 61 6d 65 20 22 63 61 ; {rank=same "ca
1db0: 73 65 20 36 22 20 43 41 53 45 36 7d 3b 0a 20 20 se 6" CASE6};.
1dc0: 20 20 20 3b 3b 44 4f 54 20 43 41 53 45 36 20 2d ;;DOT CASE6 -
1dd0: 3e 20 22 6d 72 6d 74 3a 73 65 6e 64 2d 72 65 63 > "mrmt:send-rec
1de0: 65 69 76 65 22 3b 0a 20 20 20 20 20 3b 3b 20 6f eive";. ;; o
1df0: 6e 20 68 6f 6d 65 68 6f 73 74 20 61 6e 64 20 74 n homehost and t
1e00: 68 69 73 20 69 73 20 61 20 77 72 69 74 65 2c 20 his is a write,
1e10: 77 65 20 61 6c 72 65 61 64 79 20 68 61 76 65 20 we already have
1e20: 61 20 73 65 72 76 65 72 2c 20 62 75 74 20 73 65 a server, but se
1e30: 72 76 65 72 20 68 61 73 20 64 69 65 64 0a 20 20 rver has died.
1e40: 20 20 20 28 28 61 6e 64 20 28 63 64 72 20 28 72 ((and (cdr (r
1e50: 65 6d 6f 74 65 2d 68 68 2d 64 61 74 20 72 75 6e emote-hh-dat run
1e60: 72 65 6d 6f 74 65 29 29 20 20 20 20 20 20 20 20 remote))
1e70: 20 20 20 3b 3b 20 6f 6e 20 68 6f 6d 65 68 6f 73 ;; on homehos
1e80: 74 0a 20 20 20 20 20 20 20 20 20 20 20 28 6e 6f t. (no
1e90: 74 20 28 6d 65 6d 62 65 72 20 63 6d 64 20 61 70 t (member cmd ap
1ea0: 69 3a 72 65 61 64 2d 6f 6e 6c 79 2d 71 75 65 72 i:read-only-quer
1eb0: 69 65 73 29 29 20 20 3b 3b 20 74 68 69 73 20 69 ies)) ;; this i
1ec0: 73 20 61 20 77 72 69 74 65 0a 20 20 20 20 20 20 s a write.
1ed0: 20 20 20 20 20 28 72 65 6d 6f 74 65 2d 73 65 72 (remote-ser
1ee0: 76 65 72 2d 75 72 6c 20 72 75 6e 72 65 6d 6f 74 ver-url runremot
1ef0: 65 29 20 20 20 20 20 20 20 20 20 20 20 20 20 3b e) ;
1f00: 3b 20 68 61 76 65 20 61 20 73 65 72 76 65 72 0a ; have a server.
1f10: 20 20 20 20 20 20 20 20 20 20 20 28 6e 6f 74 20 (not
1f20: 28 73 65 72 76 65 72 3a 70 69 6e 67 20 28 72 65 (server:ping (re
1f30: 6d 6f 74 65 2d 73 65 72 76 65 72 2d 75 72 6c 20 mote-server-url
1f40: 72 75 6e 72 65 6d 6f 74 65 29 29 29 29 20 20 3b runremote)))) ;
1f50: 3b 20 73 65 72 76 65 72 20 68 61 73 20 64 69 65 ; server has die
1f60: 64 2e 20 4e 4f 54 45 3a 20 74 68 69 73 20 69 73 d. NOTE: this is
1f70: 20 6e 6f 74 20 61 20 63 68 65 61 70 20 63 61 6c not a cheap cal
1f80: 6c 21 20 4e 65 65 64 20 62 65 74 74 65 72 20 61 l! Need better a
1f90: 70 70 72 6f 61 63 68 2e 0a 20 20 20 20 20 20 28 pproach.. (
1fa0: 73 65 74 21 20 2a 72 75 6e 72 65 6d 6f 74 65 2a set! *runremote*
1fb0: 20 28 6d 61 6b 65 2d 72 65 6d 6f 74 65 29 29 0a (make-remote)).
1fc0: 20 20 20 20 20 20 28 72 65 6d 6f 74 65 2d 66 6f (remote-fo
1fd0: 72 63 65 2d 73 65 72 76 65 72 2d 73 65 74 21 20 rce-server-set!
1fe0: 72 75 6e 72 65 6d 6f 74 65 20 28 63 6f 6d 6d 6f runremote (commo
1ff0: 6e 3a 66 6f 72 63 65 2d 73 65 72 76 65 72 3f 29 n:force-server?)
2000: 29 0a 20 20 20 20 20 20 28 6d 75 74 65 78 2d 75 ). (mutex-u
2010: 6e 6c 6f 63 6b 21 20 2a 72 6d 74 2d 6d 75 74 65 nlock! *rmt-mute
2020: 78 2a 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 x*). (debug
2030: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 32 20 2a :print-info 12 *
2040: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
2050: 2a 20 22 6d 72 6d 74 3a 73 65 6e 64 2d 72 65 63 * "mrmt:send-rec
2060: 65 69 76 65 2c 20 63 61 73 65 20 20 36 22 29 0a eive, case 6").
2070: 20 20 20 20 20 20 28 6d 72 6d 74 3a 73 65 6e 64 (mrmt:send
2080: 2d 72 65 63 65 69 76 65 20 63 6d 64 20 72 69 64 -receive cmd rid
2090: 20 70 61 72 61 6d 73 20 61 74 74 65 6d 70 74 6e params attemptn
20a0: 75 6d 3a 20 61 74 74 65 6d 70 74 6e 75 6d 29 29 um: attemptnum))
20b0: 0a 0a 20 20 20 20 20 3b 3b 44 4f 54 20 43 41 53 .. ;;DOT CAS
20c0: 45 37 20 5b 6c 61 62 65 6c 3d 22 68 6f 6d 65 68 E7 [label="homeh
20d0: 6f 73 74 5c 6e 77 72 69 74 65 22 5d 3b 0a 20 20 ost\nwrite"];.
20e0: 20 20 20 3b 3b 44 4f 54 20 4d 55 54 45 58 4c 4f ;;DOT MUTEXLO
20f0: 43 4b 20 2d 3e 20 43 41 53 45 37 20 5b 6c 61 62 CK -> CASE7 [lab
2100: 65 6c 3d 22 73 65 72 76 65 72 20 6e 6f 74 20 72 el="server not r
2110: 65 71 75 69 72 65 64 2c 5c 6e 6f 6e 20 68 6f 6d equired,\non hom
2120: 65 68 6f 73 74 2c 5c 6e 61 20 77 72 69 74 65 2c ehost,\na write,
2130: 5c 6e 68 61 76 65 20 61 20 73 65 72 76 65 72 22 \nhave a server"
2140: 5d 3b 20 7b 72 61 6e 6b 3d 73 61 6d 65 20 22 63 ]; {rank=same "c
2150: 61 73 65 20 37 22 20 43 41 53 45 37 7d 3b 0a 20 ase 7" CASE7};.
2160: 20 20 20 20 3b 3b 44 4f 54 20 43 41 53 45 37 20 ;;DOT CASE7
2170: 2d 3e 20 22 6d 72 6d 74 3a 6f 70 65 6e 2d 71 72 -> "mrmt:open-qr
2180: 79 2d 63 6c 6f 73 65 2d 6c 6f 63 61 6c 6c 79 22 y-close-locally"
2190: 3b 0a 20 20 20 20 20 3b 3b 20 6f 6e 20 68 6f 6d ;. ;; on hom
21a0: 65 68 6f 73 74 20 61 6e 64 20 74 68 69 73 20 69 ehost and this i
21b0: 73 20 61 20 77 72 69 74 65 2c 20 77 65 20 61 6c s a write, we al
21c0: 72 65 61 64 79 20 68 61 76 65 20 61 20 73 65 72 ready have a ser
21d0: 76 65 72 0a 20 20 20 20 20 28 28 61 6e 64 20 28 ver. ((and (
21e0: 6e 6f 74 20 28 72 65 6d 6f 74 65 2d 66 6f 72 63 not (remote-forc
21f0: 65 2d 73 65 72 76 65 72 20 72 75 6e 72 65 6d 6f e-server runremo
2200: 74 65 29 29 20 20 20 20 20 3b 3b 20 68 6f 6e 6f te)) ;; hono
2210: 72 20 66 6f 72 63 65 64 20 75 73 65 20 6f 66 20 r forced use of
2220: 73 65 72 76 65 72 2c 20 69 2e 65 2e 20 73 65 72 server, i.e. ser
2230: 76 65 72 20 4e 4f 54 20 72 65 71 75 69 72 65 64 ver NOT required
2240: 0a 09 20 20 20 28 63 64 72 20 28 72 65 6d 6f 74 .. (cdr (remot
2250: 65 2d 68 68 2d 64 61 74 20 72 75 6e 72 65 6d 6f e-hh-dat runremo
2260: 74 65 29 29 20 20 20 20 20 20 20 20 20 20 20 3b te)) ;
2270: 3b 20 6f 6e 20 68 6f 6d 65 68 6f 73 74 0a 20 20 ; on homehost.
2280: 20 20 20 20 20 20 20 20 20 28 6e 6f 74 20 28 6d (not (m
2290: 65 6d 62 65 72 20 63 6d 64 20 61 70 69 3a 72 65 ember cmd api:re
22a0: 61 64 2d 6f 6e 6c 79 2d 71 75 65 72 69 65 73 29 ad-only-queries)
22b0: 29 20 20 3b 3b 20 74 68 69 73 20 69 73 20 61 20 ) ;; this is a
22c0: 77 72 69 74 65 0a 20 20 20 20 20 20 20 20 20 20 write.
22d0: 20 28 72 65 6d 6f 74 65 2d 73 65 72 76 65 72 2d (remote-server-
22e0: 75 72 6c 20 72 75 6e 72 65 6d 6f 74 65 29 29 20 url runremote))
22f0: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 68 61 ;; ha
2300: 76 65 20 61 20 73 65 72 76 65 72 0a 20 20 20 20 ve a server.
2310: 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 (mutex-unlock!
2320: 20 2a 72 6d 74 2d 6d 75 74 65 78 2a 29 0a 20 20 *rmt-mutex*).
2330: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
2340: 2d 69 6e 66 6f 20 31 32 20 2a 64 65 66 61 75 6c -info 12 *defaul
2350: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 6d 72 6d t-log-port* "mrm
2360: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 2c 20 t:send-receive,
2370: 63 61 73 65 20 20 34 2e 31 22 29 0a 20 20 20 20 case 4.1").
2380: 20 20 28 6d 72 6d 74 3a 6f 70 65 6e 2d 71 72 79 (mrmt:open-qry
2390: 2d 63 6c 6f 73 65 2d 6c 6f 63 61 6c 6c 79 20 63 -close-locally c
23a0: 6d 64 20 30 20 70 61 72 61 6d 73 29 29 0a 0a 20 md 0 params))..
23b0: 20 20 20 20 3b 3b 44 4f 54 20 43 41 53 45 38 20 ;;DOT CASE8
23c0: 5b 6c 61 62 65 6c 3d 22 66 6f 72 63 65 5c 6e 73 [label="force\ns
23d0: 65 72 76 65 72 22 5d 3b 0a 20 20 20 20 20 3b 3b erver"];. ;;
23e0: 44 4f 54 20 4d 55 54 45 58 4c 4f 43 4b 20 2d 3e DOT MUTEXLOCK ->
23f0: 20 43 41 53 45 38 20 5b 6c 61 62 65 6c 3d 22 73 CASE8 [label="s
2400: 65 72 76 65 72 20 6e 6f 74 20 72 65 71 75 69 72 erver not requir
2410: 65 64 2c 5c 6e 68 61 76 65 20 68 6f 6d 65 68 6f ed,\nhave homeho
2420: 73 74 20 69 6e 66 6f 2c 5c 6e 6e 6f 20 63 6f 6e st info,\nno con
2430: 6e 65 63 74 69 6f 6e 20 79 65 74 2c 5c 6e 6e 6f nection yet,\nno
2440: 74 20 61 20 72 65 61 64 2d 6f 6e 6c 79 20 71 75 t a read-only qu
2450: 65 72 79 22 5d 3b 20 7b 72 61 6e 6b 3d 73 61 6d ery"]; {rank=sam
2460: 65 20 22 63 61 73 65 20 38 22 20 43 41 53 45 38 e "case 8" CASE8
2470: 7d 3b 0a 20 20 20 20 20 3b 3b 44 4f 54 20 43 41 };. ;;DOT CA
2480: 53 45 38 20 2d 3e 20 22 6d 72 6d 74 3a 6f 70 65 SE8 -> "mrmt:ope
2490: 6e 2d 71 72 79 2d 63 6c 6f 73 65 2d 6c 6f 63 61 n-qry-close-loca
24a0: 6c 6c 79 22 3b 0a 20 20 20 20 20 3b 3b 20 20 6f lly";. ;; o
24b0: 6e 20 68 6f 6d 65 68 6f 73 74 2c 20 6e 6f 20 73 n homehost, no s
24c0: 65 72 76 65 72 20 63 6f 6e 74 61 63 74 20 6d 61 erver contact ma
24d0: 64 65 20 61 6e 64 20 74 68 69 73 20 69 73 20 61 de and this is a
24e0: 20 77 72 69 74 65 2c 20 70 61 73 73 69 76 65 6c write, passivel
24f0: 79 20 73 74 61 72 74 20 61 20 73 65 72 76 65 72 y start a server
2500: 20 0a 20 20 20 20 20 28 28 61 6e 64 20 28 6e 6f . ((and (no
2510: 74 20 28 72 65 6d 6f 74 65 2d 66 6f 72 63 65 2d t (remote-force-
2520: 73 65 72 76 65 72 20 72 75 6e 72 65 6d 6f 74 65 server runremote
2530: 29 29 20 20 20 20 20 3b 3b 20 68 6f 6e 6f 72 20 )) ;; honor
2540: 66 6f 72 63 65 64 20 75 73 65 20 6f 66 20 73 65 forced use of se
2550: 72 76 65 72 2c 20 69 2e 65 2e 20 73 65 72 76 65 rver, i.e. serve
2560: 72 20 4e 4f 54 20 72 65 71 75 69 72 65 64 0a 09 r NOT required..
2570: 20 20 20 28 63 64 72 20 28 72 65 6d 6f 74 65 2d (cdr (remote-
2580: 68 68 2d 64 61 74 20 72 75 6e 72 65 6d 6f 74 65 hh-dat runremote
2590: 29 29 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 )) ;;
25a0: 68 61 76 65 20 68 6f 6d 65 68 6f 73 74 0a 20 20 have homehost.
25b0: 20 20 20 20 20 20 20 20 20 28 6e 6f 74 20 28 72 (not (r
25c0: 65 6d 6f 74 65 2d 73 65 72 76 65 72 2d 75 72 6c emote-server-url
25d0: 20 72 75 6e 72 65 6d 6f 74 65 29 29 20 20 20 20 runremote))
25e0: 20 20 20 3b 3b 20 6e 6f 20 63 6f 6e 6e 65 63 74 ;; no connect
25f0: 69 6f 6e 20 79 65 74 0a 09 20 20 20 28 6e 6f 74 ion yet.. (not
2600: 20 28 6d 65 6d 62 65 72 20 63 6d 64 20 61 70 69 (member cmd api
2610: 3a 72 65 61 64 2d 6f 6e 6c 79 2d 71 75 65 72 69 :read-only-queri
2620: 65 73 29 29 29 20 3b 3b 20 6e 6f 74 20 61 20 72 es))) ;; not a r
2630: 65 61 64 2d 6f 6e 6c 79 20 71 75 65 72 79 0a 20 ead-only query.
2640: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
2650: 74 2d 69 6e 66 6f 20 31 32 20 2a 64 65 66 61 75 t-info 12 *defau
2660: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 6d 72 lt-log-port* "mr
2670: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 2c mt:send-receive,
2680: 20 63 61 73 65 20 20 38 22 29 0a 20 20 20 20 20 case 8").
2690: 20 28 6c 65 74 20 28 28 73 65 72 76 65 72 2d 75 (let ((server-u
26a0: 72 6c 20 20 28 73 65 72 76 65 72 3a 63 68 65 63 rl (server:chec
26b0: 6b 2d 69 66 2d 72 75 6e 6e 69 6e 67 20 2a 74 6f k-if-running *to
26c0: 70 70 61 74 68 2a 29 29 29 20 3b 3b 20 28 73 65 ppath*))) ;; (se
26d0: 72 76 65 72 3a 72 65 61 64 2d 64 6f 74 73 65 72 rver:read-dotser
26e0: 76 65 72 2d 3e 75 72 6c 20 2a 74 6f 70 70 61 74 ver->url *toppat
26f0: 68 2a 29 29 29 20 3b 3b 20 28 73 65 72 76 65 72 h*))) ;; (server
2700: 3a 63 68 65 63 6b 2d 69 66 2d 72 75 6e 6e 69 6e :check-if-runnin
2710: 67 20 2a 74 6f 70 70 61 74 68 2a 29 29 29 20 3b g *toppath*))) ;
2720: 3b 20 44 6f 20 4e 4f 54 20 77 61 6e 74 20 74 6f ; Do NOT want to
2730: 20 72 75 6e 20 73 65 72 76 65 72 3a 63 68 65 63 run server:chec
2740: 6b 2d 69 66 2d 72 75 6e 6e 69 6e 67 20 2d 20 76 k-if-running - v
2750: 65 72 79 20 65 78 70 65 6e 73 69 76 65 20 74 6f ery expensive to
2760: 20 64 6f 20 66 6f 72 20 65 76 65 72 79 20 77 72 do for every wr
2770: 69 74 65 20 63 61 6c 6c 0a 09 28 69 66 20 73 65 ite call..(if se
2780: 72 76 65 72 2d 75 72 6c 0a 09 20 20 20 20 28 72 rver-url.. (r
2790: 65 6d 6f 74 65 2d 73 65 72 76 65 72 2d 75 72 6c emote-server-url
27a0: 2d 73 65 74 21 20 72 75 6e 72 65 6d 6f 74 65 20 -set! runremote
27b0: 73 65 72 76 65 72 2d 75 72 6c 29 20 3b 3b 20 74 server-url) ;; t
27c0: 68 65 20 73 74 72 69 6e 67 20 63 61 6e 20 62 65 he string can be
27d0: 20 63 6f 6e 73 75 6d 65 64 20 62 79 20 74 68 65 consumed by the
27e0: 20 63 6c 69 65 6e 74 20 73 65 74 75 70 20 69 66 client setup if
27f0: 20 6e 65 65 64 65 64 0a 09 20 20 20 20 28 69 66 needed.. (if
2800: 20 28 63 6f 6d 6d 6f 6e 3a 66 6f 72 63 65 2d 73 (common:force-s
2810: 65 72 76 65 72 3f 29 0a 09 09 28 73 65 72 76 65 erver?)...(serve
2820: 72 3a 73 74 61 72 74 2d 61 6e 64 2d 77 61 69 74 r:start-and-wait
2830: 20 2a 74 6f 70 70 61 74 68 2a 29 0a 09 09 28 73 *toppath*)...(s
2840: 65 72 76 65 72 3a 6b 69 6e 64 2d 72 75 6e 20 2a erver:kind-run *
2850: 74 6f 70 70 61 74 68 2a 29 29 29 29 0a 20 20 20 toppath*)))).
2860: 20 20 20 28 72 65 6d 6f 74 65 2d 66 6f 72 63 65 (remote-force
2870: 2d 73 65 72 76 65 72 2d 73 65 74 21 20 72 75 6e -server-set! run
2880: 72 65 6d 6f 74 65 20 28 63 6f 6d 6d 6f 6e 3a 66 remote (common:f
2890: 6f 72 63 65 2d 73 65 72 76 65 72 3f 29 29 0a 20 orce-server?)).
28a0: 20 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f (mutex-unlo
28b0: 63 6b 21 20 2a 72 6d 74 2d 6d 75 74 65 78 2a 29 ck! *rmt-mutex*)
28c0: 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
28d0: 69 6e 74 2d 69 6e 66 6f 20 31 32 20 2a 64 65 66 int-info 12 *def
28e0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
28f0: 6d 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 mrmt:send-receiv
2900: 65 2c 20 63 61 73 65 20 20 38 2e 31 22 29 0a 20 e, case 8.1").
2910: 20 20 20 20 20 28 6d 72 6d 74 3a 6f 70 65 6e 2d (mrmt:open-
2920: 71 72 79 2d 63 6c 6f 73 65 2d 6c 6f 63 61 6c 6c qry-close-locall
2930: 79 20 63 6d 64 20 30 20 70 61 72 61 6d 73 29 29 y cmd 0 params))
2940: 0a 0a 20 20 20 20 20 3b 3b 44 4f 54 20 43 41 53 .. ;;DOT CAS
2950: 45 39 20 5b 6c 61 62 65 6c 3d 22 66 6f 72 63 65 E9 [label="force
2960: 20 73 65 72 76 65 72 5c 6e 6e 6f 74 20 6f 6e 20 server\nnot on
2970: 68 6f 6d 65 68 6f 73 74 22 5d 3b 0a 20 20 20 20 homehost"];.
2980: 20 3b 3b 44 4f 54 20 4d 55 54 45 58 4c 4f 43 4b ;;DOT MUTEXLOCK
2990: 20 2d 3e 20 43 41 53 45 39 20 5b 6c 61 62 65 6c -> CASE9 [label
29a0: 3d 22 6e 6f 20 63 6f 6e 6e 65 63 74 69 6f 6e 5c ="no connection\
29b0: 6e 61 6e 64 20 65 69 74 68 65 72 20 72 65 71 75 nand either requ
29c0: 69 72 65 20 73 65 72 76 65 72 5c 6e 6f 72 20 6e ire server\nor n
29d0: 6f 74 20 6f 6e 20 68 6f 6d 65 68 6f 73 74 22 5d ot on homehost"]
29e0: 3b 20 7b 72 61 6e 6b 3d 73 61 6d 65 20 22 63 61 ; {rank=same "ca
29f0: 73 65 20 39 22 20 43 41 53 45 39 7d 3b 0a 20 20 se 9" CASE9};.
2a00: 20 20 20 3b 3b 44 4f 54 20 43 41 53 45 39 20 2d ;;DOT CASE9 -
2a10: 3e 20 22 73 74 61 72 74 5c 6e 73 65 72 76 65 72 > "start\nserver
2a20: 22 20 2d 3e 20 22 6d 72 6d 74 3a 73 65 6e 64 2d " -> "mrmt:send-
2a30: 72 65 63 65 69 76 65 22 3b 0a 20 20 20 20 20 28 receive";. (
2a40: 28 6f 72 20 28 61 6e 64 20 28 72 65 6d 6f 74 65 (or (and (remote
2a50: 2d 66 6f 72 63 65 2d 73 65 72 76 65 72 20 72 75 -force-server ru
2a60: 6e 72 65 6d 6f 74 65 29 20 20 20 20 20 20 20 20 nremote)
2a70: 20 20 20 20 20 20 3b 3b 20 77 65 20 61 72 65 20 ;; we are
2a80: 66 6f 72 63 69 6e 67 20 61 20 73 65 72 76 65 72 forcing a server
2a90: 20 61 6e 64 20 64 6f 6e 27 74 20 79 65 74 20 68 and don't yet h
2aa0: 61 76 65 20 61 20 63 6f 6e 6e 65 63 74 69 6f 6e ave a connection
2ab0: 20 74 6f 20 6f 6e 65 0a 09 20 20 20 20 20 20 20 to one..
2ac0: 28 6e 6f 74 20 28 72 65 6d 6f 74 65 2d 63 6f 6e (not (remote-con
2ad0: 6e 64 61 74 20 72 75 6e 72 65 6d 6f 74 65 29 29 ndat runremote))
2ae0: 29 0a 09 20 20 28 61 6e 64 20 28 6e 6f 74 20 28 ).. (and (not (
2af0: 63 64 72 20 28 72 65 6d 6f 74 65 2d 68 68 2d 64 cdr (remote-hh-d
2b00: 61 74 20 72 75 6e 72 65 6d 6f 74 65 29 29 29 20 at runremote)))
2b10: 20 20 20 20 20 20 20 3b 3b 20 6e 6f 74 20 6f 6e ;; not on
2b20: 20 61 20 68 6f 6d 65 68 6f 73 74 20 0a 09 20 20 a homehost ..
2b30: 20 20 20 20 20 28 6e 6f 74 20 28 72 65 6d 6f 74 (not (remot
2b40: 65 2d 63 6f 6e 6e 64 61 74 20 72 75 6e 72 65 6d e-conndat runrem
2b50: 6f 74 65 29 29 29 29 20 20 20 20 20 20 20 20 20 ote))))
2b60: 20 20 3b 3b 20 61 6e 64 20 6e 6f 20 63 6f 6e 6e ;; and no conn
2b70: 65 63 74 69 6f 6e 0a 20 20 20 20 20 20 28 64 65 ection. (de
2b80: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 bug:print-info 1
2b90: 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 2 *default-log-p
2ba0: 6f 72 74 2a 20 22 6d 72 6d 74 3a 73 65 6e 64 2d ort* "mrmt:send-
2bb0: 72 65 63 65 69 76 65 2c 20 63 61 73 65 20 39 2c receive, case 9,
2bc0: 20 68 68 2d 64 61 74 3a 20 22 20 28 72 65 6d 6f hh-dat: " (remo
2bd0: 74 65 2d 68 68 2d 64 61 74 20 72 75 6e 72 65 6d te-hh-dat runrem
2be0: 6f 74 65 29 20 22 20 63 6f 6e 6e 64 61 74 3a 20 ote) " conndat:
2bf0: 22 20 28 72 65 6d 6f 74 65 2d 63 6f 6e 6e 64 61 " (remote-connda
2c00: 74 20 72 75 6e 72 65 6d 6f 74 65 29 29 0a 20 20 t runremote)).
2c10: 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 (mutex-unloc
2c20: 6b 21 20 2a 72 6d 74 2d 6d 75 74 65 78 2a 29 0a k! *rmt-mutex*).
2c30: 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 (if (not (
2c40: 73 65 72 76 65 72 3a 63 68 65 63 6b 2d 69 66 2d server:check-if-
2c50: 72 75 6e 6e 69 6e 67 20 2a 74 6f 70 70 61 74 68 running *toppath
2c60: 2a 29 29 20 3b 3b 20 77 68 6f 20 6b 6e 6f 77 73 *)) ;; who knows
2c70: 2c 20 6d 61 79 62 65 20 6f 6e 65 20 68 61 73 20 , maybe one has
2c80: 73 74 61 72 74 65 64 20 75 70 3f 0a 09 20 20 28 started up?.. (
2c90: 73 65 72 76 65 72 3a 73 74 61 72 74 2d 61 6e 64 server:start-and
2ca0: 2d 77 61 69 74 20 2a 74 6f 70 70 61 74 68 2a 29 -wait *toppath*)
2cb0: 29 0a 20 20 20 20 20 20 28 72 65 6d 6f 74 65 2d ). (remote-
2cc0: 63 6f 6e 6e 64 61 74 2d 73 65 74 21 20 72 75 6e conndat-set! run
2cd0: 72 65 6d 6f 74 65 20 28 6d 72 6d 74 3a 67 65 74 remote (mrmt:get
2ce0: 2d 63 6f 6e 6e 65 63 74 69 6f 6e 2d 69 6e 66 6f -connection-info
2cf0: 20 2a 74 6f 70 70 61 74 68 2a 29 29 20 3b 3b 20 *toppath*)) ;;
2d00: 63 61 6c 6c 73 20 63 6c 69 65 6e 74 3a 73 65 74 calls client:set
2d10: 75 70 20 77 68 69 63 68 20 63 61 6c 6c 73 20 63 up which calls c
2d20: 6c 69 65 6e 74 3a 73 65 74 75 70 2d 68 74 74 70 lient:setup-http
2d30: 0a 20 20 20 20 20 20 28 6d 72 6d 74 3a 73 65 6e . (mrmt:sen
2d40: 64 2d 72 65 63 65 69 76 65 20 63 6d 64 20 72 69 d-receive cmd ri
2d50: 64 20 70 61 72 61 6d 73 20 61 74 74 65 6d 70 74 d params attempt
2d60: 6e 75 6d 3a 20 61 74 74 65 6d 70 74 6e 75 6d 29 num: attemptnum)
2d70: 29 20 3b 3b 20 54 4f 44 4f 3a 20 61 64 64 20 62 ) ;; TODO: add b
2d80: 61 63 6b 2d 6f 66 66 20 74 69 6d 65 6f 75 74 20 ack-off timeout
2d90: 61 73 0a 0a 20 20 20 20 20 3b 3b 44 4f 54 20 43 as.. ;;DOT C
2da0: 41 53 45 31 30 20 5b 6c 61 62 65 6c 3d 22 6f 6e ASE10 [label="on
2db0: 20 68 6f 6d 65 68 6f 73 74 22 5d 3b 0a 20 20 20 homehost"];.
2dc0: 20 20 3b 3b 44 4f 54 20 4d 55 54 45 58 4c 4f 43 ;;DOT MUTEXLOC
2dd0: 4b 20 2d 3e 20 43 41 53 45 31 30 20 5b 6c 61 62 K -> CASE10 [lab
2de0: 65 6c 3d 22 73 65 72 76 65 72 20 6e 6f 74 20 72 el="server not r
2df0: 65 71 75 69 72 65 64 2c 5c 6e 6f 6e 20 68 6f 6d equired,\non hom
2e00: 65 68 6f 73 74 22 5d 3b 20 7b 72 61 6e 6b 3d 73 ehost"]; {rank=s
2e10: 61 6d 65 20 22 63 61 73 65 20 31 30 22 20 43 41 ame "case 10" CA
2e20: 53 45 31 30 7d 3b 0a 20 20 20 20 20 3b 3b 44 4f SE10};. ;;DO
2e30: 54 20 43 41 53 45 31 30 20 2d 3e 20 22 6d 72 6d T CASE10 -> "mrm
2e40: 74 3a 6f 70 65 6e 2d 71 72 79 2d 63 6c 6f 73 65 t:open-qry-close
2e50: 2d 6c 6f 63 61 6c 6c 79 22 3b 0a 20 20 20 20 20 -locally";.
2e60: 3b 3b 20 61 6c 6c 20 73 65 74 20 75 70 20 69 66 ;; all set up if
2e70: 20 67 65 74 20 74 68 69 73 20 66 61 72 2c 20 64 get this far, d
2e80: 69 73 70 61 74 63 68 20 74 68 65 20 71 75 65 72 ispatch the quer
2e90: 79 0a 20 20 20 20 20 28 28 61 6e 64 20 28 6e 6f y. ((and (no
2ea0: 74 20 28 72 65 6d 6f 74 65 2d 66 6f 72 63 65 2d t (remote-force-
2eb0: 73 65 72 76 65 72 20 72 75 6e 72 65 6d 6f 74 65 server runremote
2ec0: 29 29 0a 09 20 20 20 28 63 64 72 20 28 72 65 6d )).. (cdr (rem
2ed0: 6f 74 65 2d 68 68 2d 64 61 74 20 72 75 6e 72 65 ote-hh-dat runre
2ee0: 6d 6f 74 65 29 29 29 20 3b 3b 20 77 65 20 61 72 mote))) ;; we ar
2ef0: 65 20 6f 6e 20 68 6f 6d 65 68 6f 73 74 0a 20 20 e on homehost.
2f00: 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 (mutex-unloc
2f10: 6b 21 20 2a 72 6d 74 2d 6d 75 74 65 78 2a 29 0a k! *rmt-mutex*).
2f20: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
2f30: 6e 74 2d 69 6e 66 6f 20 31 32 20 2a 64 65 66 61 nt-info 12 *defa
2f40: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 6d ult-log-port* "m
2f50: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
2f60: 2c 20 63 61 73 65 20 31 30 22 29 0a 20 20 20 20 , case 10").
2f70: 20 20 28 6d 72 6d 74 3a 6f 70 65 6e 2d 71 72 79 (mrmt:open-qry
2f80: 2d 63 6c 6f 73 65 2d 6c 6f 63 61 6c 6c 79 20 63 -close-locally c
2f90: 6d 64 20 28 69 66 20 72 69 64 20 72 69 64 20 30 md (if rid rid 0
2fa0: 29 20 70 61 72 61 6d 73 29 29 0a 0a 20 20 20 20 ) params))..
2fb0: 20 3b 3b 44 4f 54 20 43 41 53 45 31 31 20 5b 6c ;;DOT CASE11 [l
2fc0: 61 62 65 6c 3d 22 73 65 6e 64 5f 72 65 63 65 69 abel="send_recei
2fd0: 76 65 22 5d 3b 0a 20 20 20 20 20 3b 3b 44 4f 54 ve"];. ;;DOT
2fe0: 20 4d 55 54 45 58 4c 4f 43 4b 20 2d 3e 20 43 41 MUTEXLOCK -> CA
2ff0: 53 45 31 31 20 5b 6c 61 62 65 6c 3d 22 65 6c 73 SE11 [label="els
3000: 65 22 5d 3b 20 7b 72 61 6e 6b 3d 73 61 6d 65 20 e"]; {rank=same
3010: 22 63 61 73 65 20 31 31 22 20 43 41 53 45 31 31 "case 11" CASE11
3020: 7d 3b 0a 20 20 20 20 20 3b 3b 44 4f 54 20 43 41 };. ;;DOT CA
3030: 53 45 31 31 20 2d 3e 20 22 6d 72 6d 74 3a 73 65 SE11 -> "mrmt:se
3040: 6e 64 2d 72 65 63 65 69 76 65 22 20 5b 6c 61 62 nd-receive" [lab
3050: 65 6c 3d 22 63 61 6c 6c 20 66 61 69 6c 65 64 22 el="call failed"
3060: 5d 3b 0a 20 20 20 20 20 3b 3b 44 4f 54 20 43 41 ];. ;;DOT CA
3070: 53 45 31 31 20 2d 3e 20 22 52 45 53 55 4c 54 22 SE11 -> "RESULT"
3080: 20 5b 6c 61 62 65 6c 3d 22 63 61 6c 6c 20 73 75 [label="call su
3090: 63 63 65 65 64 65 64 22 5d 3b 0a 20 20 20 20 20 cceeded"];.
30a0: 3b 3b 20 6e 6f 74 20 6f 6e 20 68 6f 6d 65 68 6f ;; not on homeho
30b0: 73 74 2c 20 64 6f 20 73 65 72 76 65 72 20 71 75 st, do server qu
30c0: 65 72 79 0a 20 20 20 20 20 28 65 6c 73 65 0a 20 ery. (else.
30d0: 20 20 20 20 20 3b 3b 20 28 6d 75 74 65 78 2d 75 ;; (mutex-u
30e0: 6e 6c 6f 63 6b 21 20 2a 72 6d 74 2d 6d 75 74 65 nlock! *rmt-mute
30f0: 78 2a 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 x*). (debug
3100: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 32 20 2a :print-info 12 *
3110: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
3120: 2a 20 22 6d 72 6d 74 3a 73 65 6e 64 2d 72 65 63 * "mrmt:send-rec
3130: 65 69 76 65 2c 20 63 61 73 65 20 20 39 22 29 0a eive, case 9").
3140: 20 20 20 20 20 20 3b 3b 20 28 6d 75 74 65 78 2d ;; (mutex-
3150: 6c 6f 63 6b 21 20 2a 72 6d 74 2d 6d 75 74 65 78 lock! *rmt-mutex
3160: 2a 29 0a 20 20 20 20 20 20 28 6c 65 74 2a 20 28 *). (let* (
3170: 28 63 6f 6e 6e 69 6e 66 6f 20 28 72 65 6d 6f 74 (conninfo (remot
3180: 65 2d 63 6f 6e 6e 64 61 74 20 72 75 6e 72 65 6d e-conndat runrem
3190: 6f 74 65 29 29 0a 09 20 20 20 20 20 28 64 61 74 ote)).. (dat
31a0: 20 20 20 20 20 20 28 63 61 73 65 20 28 72 65 6d (case (rem
31b0: 6f 74 65 2d 74 72 61 6e 73 70 6f 72 74 20 72 75 ote-transport ru
31c0: 6e 72 65 6d 6f 74 65 29 0a 09 09 09 20 28 28 68 nremote).... ((h
31d0: 74 74 70 29 20 28 63 6f 6e 64 69 74 69 6f 6e 2d ttp) (condition-
31e0: 63 61 73 65 20 3b 3b 20 68 61 6e 64 6c 69 6e 67 case ;; handling
31f0: 20 68 65 72 65 20 68 61 73 20 63 61 75 73 65 64 here has caused
3200: 20 61 20 6c 6f 74 20 6f 66 20 70 72 6f 62 6c 65 a lot of proble
3210: 6d 73 2e 20 48 6f 77 65 76 65 72 20 69 74 20 69 ms. However it i
3220: 73 20 6e 65 65 64 65 64 20 74 6f 20 64 65 61 6c s needed to deal
3230: 20 77 69 74 68 20 61 74 74 65 6d 74 70 65 64 20 with attemtped
3240: 63 6f 6d 6d 75 6e 69 63 61 74 69 6f 6e 20 74 6f communication to
3250: 20 73 65 72 76 65 72 73 20 74 68 61 74 20 68 61 servers that ha
3260: 76 65 20 67 6f 6e 65 20 61 77 61 79 0a 20 20 20 ve gone away.
3270: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3280: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
3290: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 63 http-transport:c
32a0: 6c 69 65 6e 74 2d 61 70 69 2d 73 65 6e 64 2d 72 lient-api-send-r
32b0: 65 63 65 69 76 65 20 30 20 63 6f 6e 6e 69 6e 66 eceive 0 conninf
32c0: 6f 20 63 6d 64 20 70 61 72 61 6d 73 29 0a 20 20 o cmd params).
32d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
32e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
32f0: 28 28 63 6f 6d 6d 66 61 69 6c 29 28 76 65 63 74 ((commfail)(vect
3300: 6f 72 20 23 66 20 22 63 6f 6d 6d 75 6e 69 63 61 or #f "communica
3310: 74 69 6f 6e 73 20 66 61 69 6c 22 29 29 0a 20 20 tions fail")).
3320: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3330: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3340: 28 28 65 78 6e 29 28 76 65 63 74 6f 72 20 23 66 ((exn)(vector #f
3350: 20 22 6f 74 68 65 72 20 66 61 69 6c 22 20 28 70 "other fail" (p
3360: 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 29 rint-call-chain)
3370: 29 29 29 29 0a 09 09 09 20 28 65 6c 73 65 0a 09 )))).... (else..
3380: 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
3390: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
33a0: 70 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 74 72 port* "ERROR: tr
33b0: 61 6e 73 70 6f 72 74 20 22 20 28 72 65 6d 6f 74 ansport " (remot
33c0: 65 2d 74 72 61 6e 73 70 6f 72 74 20 72 75 6e 72 e-transport runr
33d0: 65 6d 6f 74 65 29 20 22 20 6e 6f 74 20 73 75 70 emote) " not sup
33e0: 70 6f 72 74 65 64 22 29 0a 09 09 09 20 20 28 65 ported").... (e
33f0: 78 69 74 29 29 29 29 0a 09 20 20 20 20 20 28 73 xit)))).. (s
3400: 75 63 63 65 73 73 20 20 28 69 66 20 28 76 65 63 uccess (if (vec
3410: 74 6f 72 3f 20 64 61 74 29 20 28 76 65 63 74 6f tor? dat) (vecto
3420: 72 2d 72 65 66 20 64 61 74 20 30 29 20 23 66 29 r-ref dat 0) #f)
3430: 29 0a 09 20 20 20 20 20 28 72 65 73 20 20 20 20 ).. (res
3440: 20 20 28 69 66 20 28 76 65 63 74 6f 72 3f 20 64 (if (vector? d
3450: 61 74 29 20 28 76 65 63 74 6f 72 2d 72 65 66 20 at) (vector-ref
3460: 64 61 74 20 31 29 20 23 66 29 29 29 0a 09 28 69 dat 1) #f)))..(i
3470: 66 20 28 61 6e 64 20 28 76 65 63 74 6f 72 3f 20 f (and (vector?
3480: 63 6f 6e 6e 69 6e 66 6f 29 20 28 3c 20 35 20 28 conninfo) (< 5 (
3490: 76 65 63 74 6f 72 2d 6c 65 6e 67 74 68 20 63 6f vector-length co
34a0: 6e 6e 69 6e 66 6f 29 29 29 0a 20 20 20 20 20 20 nninfo))).
34b0: 20 20 20 20 20 20 28 68 74 74 70 2d 74 72 61 6e (http-tran
34c0: 73 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 74 sport:server-dat
34d0: 2d 75 70 64 61 74 65 2d 6c 61 73 74 2d 61 63 63 -update-last-acc
34e0: 65 73 73 20 63 6f 6e 6e 69 6e 66 6f 29 20 3b 3b ess conninfo) ;;
34f0: 20 72 65 66 72 65 73 68 20 61 63 63 65 73 73 20 refresh access
3500: 74 69 6d 65 0a 09 20 20 20 20 28 62 65 67 69 6e time.. (begin
3510: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
3520: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
3530: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
3540: 20 22 49 4e 46 4f 3a 20 53 68 6f 75 6c 64 20 6e "INFO: Should n
3550: 6f 74 20 67 65 74 20 68 65 72 65 21 20 63 6f 6e ot get here! con
3560: 6e 69 6e 66 6f 3d 22 20 63 6f 6e 6e 69 6e 66 6f ninfo=" conninfo
3570: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
3580: 28 73 65 74 21 20 63 6f 6e 6e 69 6e 66 6f 20 23 (set! conninfo #
3590: 66 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 f).
35a0: 20 28 72 65 6d 6f 74 65 2d 63 6f 6e 6e 64 61 74 (remote-conndat
35b0: 2d 73 65 74 21 20 2a 72 75 6e 72 65 6d 6f 74 65 -set! *runremote
35c0: 2a 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 * #f).
35d0: 20 20 20 20 28 68 74 74 70 2d 74 72 61 6e 73 70 (http-transp
35e0: 6f 72 74 3a 63 6c 6f 73 65 2d 63 6f 6e 6e 65 63 ort:close-connec
35f0: 74 69 6f 6e 73 20 20 61 72 65 61 2d 64 61 74 3a tions area-dat:
3600: 20 72 75 6e 72 65 6d 6f 74 65 29 29 29 0a 09 3b runremote)))..;
3610: 3b 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 ; (mutex-unlock!
3620: 20 2a 72 6d 74 2d 6d 75 74 65 78 2a 29 0a 20 20 *rmt-mutex*).
3630: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
3640: 6e 74 2d 69 6e 66 6f 20 31 33 20 2a 64 65 66 61 nt-info 13 *defa
3650: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 6d ult-log-port* "m
3660: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
3670: 2c 20 63 61 73 65 20 20 39 2e 20 63 6f 6e 6e 69 , case 9. conni
3680: 6e 66 6f 3d 22 20 63 6f 6e 6e 69 6e 66 6f 20 22 nfo=" conninfo "
3690: 20 64 61 74 3d 22 20 64 61 74 20 22 20 72 75 6e dat=" dat " run
36a0: 72 65 6d 6f 74 65 20 3d 20 22 20 72 75 6e 72 65 remote = " runre
36b0: 6d 6f 74 65 29 0a 09 28 6d 75 74 65 78 2d 75 6e mote)..(mutex-un
36c0: 6c 6f 63 6b 21 20 2a 72 6d 74 2d 6d 75 74 65 78 lock! *rmt-mutex
36d0: 2a 29 0a 09 28 69 66 20 73 75 63 63 65 73 73 20 *)..(if success
36e0: 3b 3b 20 73 75 63 63 65 73 73 20 6f 6e 6c 79 20 ;; success only
36f0: 74 65 6c 6c 73 20 75 73 20 74 68 61 74 20 74 68 tells us that th
3700: 65 20 74 72 61 6e 73 70 6f 72 74 20 77 61 73 20 e transport was
3710: 73 75 63 63 65 73 73 66 75 6c 2c 20 68 61 76 65 successful, have
3720: 20 74 6f 20 65 78 61 6d 69 6e 65 20 74 68 65 20 to examine the
3730: 64 61 74 61 20 74 6f 20 73 65 65 20 69 66 20 74 data to see if t
3740: 68 65 72 65 20 77 61 73 20 61 20 64 65 74 65 63 here was a detec
3750: 74 65 64 20 69 73 73 75 65 20 61 74 20 74 68 65 ted issue at the
3760: 20 6f 74 68 65 72 20 65 6e 64 0a 09 20 20 20 20 other end..
3770: 28 69 66 20 28 61 6e 64 20 28 76 65 63 74 6f 72 (if (and (vector
3780: 3f 20 72 65 73 29 0a 09 09 20 20 20 20 20 28 65 ? res)... (e
3790: 71 3f 20 28 76 65 63 74 6f 72 2d 6c 65 6e 67 74 q? (vector-lengt
37a0: 68 20 72 65 73 29 20 32 29 0a 09 09 20 20 20 20 h res) 2)...
37b0: 20 28 65 71 3f 20 28 76 65 63 74 6f 72 2d 72 65 (eq? (vector-re
37c0: 66 20 72 65 73 20 31 29 20 27 6f 76 65 72 6c 6f f res 1) 'overlo
37d0: 61 64 65 64 29 29 20 3b 3b 20 73 69 6e 63 65 20 aded)) ;; since
37e0: 77 65 20 61 72 65 20 6c 6f 6f 6b 69 6e 67 20 61 we are looking a
37f0: 74 20 74 68 65 20 64 61 74 61 20 74 6f 20 63 61 t the data to ca
3800: 72 72 79 20 74 68 65 20 65 72 72 6f 72 20 77 65 rry the error we
3810: 27 6c 6c 20 75 73 65 20 61 20 66 61 69 72 6c 79 'll use a fairly
3820: 20 6f 62 74 75 73 65 20 63 6f 6d 62 6f 20 74 6f obtuse combo to
3830: 20 6d 69 6e 69 6d 69 73 65 20 74 68 65 20 63 68 minimise the ch
3840: 61 6e 63 65 73 20 6f 66 20 73 6f 6d 65 20 73 6f ances of some so
3850: 72 74 20 6f 66 20 63 6f 6c 6c 69 73 69 6f 6e 2e rt of collision.
3860: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
3870: 20 3b 3b 20 74 68 69 73 20 69 73 20 74 68 65 20 ;; this is the
3880: 63 61 73 65 20 77 68 65 72 65 20 74 68 65 20 72 case where the r
3890: 65 74 75 72 6e 65 64 20 64 61 74 61 20 69 73 20 eturned data is
38a0: 62 61 64 20 6f 72 20 74 68 65 20 73 65 72 76 65 bad or the serve
38b0: 72 20 69 73 20 6f 76 65 72 6c 6f 61 64 65 64 20 r is overloaded
38c0: 61 6e 64 20 77 65 20 77 61 6e 74 0a 20 20 20 20 and we want.
38d0: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 74 ;; t
38e0: 6f 20 65 61 73 65 20 6f 66 66 20 74 68 65 20 71 o ease off the q
38f0: 75 65 72 69 65 73 0a 09 09 28 6c 65 74 20 28 28 ueries...(let ((
3900: 77 61 69 74 2d 64 65 6c 61 79 20 28 2b 20 61 74 wait-delay (+ at
3910: 74 65 6d 70 74 6e 75 6d 20 28 2a 20 61 74 74 65 temptnum (* atte
3920: 6d 70 74 6e 75 6d 20 31 30 29 29 29 29 0a 09 09 mptnum 10))))...
3930: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
3940: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
3950: 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 73 65 rt* "WARNING: se
3960: 72 76 65 72 20 69 73 20 6f 76 65 72 6c 6f 61 64 rver is overload
3970: 65 64 2e 20 44 65 6c 61 79 69 6e 67 20 22 20 77 ed. Delaying " w
3980: 61 69 74 2d 64 65 6c 61 79 20 22 20 73 65 63 6f ait-delay " seco
3990: 6e 64 73 20 61 6e 64 20 74 72 79 69 6e 67 20 63 nds and trying c
39a0: 61 6c 6c 20 61 67 61 69 6e 2e 22 29 0a 09 09 20 all again.")...
39b0: 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 72 (mutex-lock! *r
39c0: 6d 74 2d 6d 75 74 65 78 2a 29 0a 09 09 20 20 28 mt-mutex*)... (
39d0: 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 63 http-transport:c
39e0: 6c 6f 73 65 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 lose-connections
39f0: 20 61 72 65 61 2d 64 61 74 3a 20 72 75 6e 72 65 area-dat: runre
3a00: 6d 6f 74 65 29 0a 09 09 20 20 28 73 65 74 21 20 mote)... (set!
3a10: 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 23 66 29 20 *runremote* #f)
3a20: 3b 3b 20 66 6f 72 63 65 20 73 74 61 72 74 69 6e ;; force startin
3a30: 67 20 6f 76 65 72 0a 09 09 20 20 28 6d 75 74 65 g over... (mute
3a40: 78 2d 75 6e 6c 6f 63 6b 21 20 2a 72 6d 74 2d 6d x-unlock! *rmt-m
3a50: 75 74 65 78 2a 29 0a 09 09 20 20 28 74 68 72 65 utex*)... (thre
3a60: 61 64 2d 73 6c 65 65 70 21 20 77 61 69 74 2d 64 ad-sleep! wait-d
3a70: 65 6c 61 79 29 0a 09 09 20 20 28 6d 72 6d 74 3a elay)... (mrmt:
3a80: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 63 6d 64 send-receive cmd
3a90: 20 72 69 64 20 70 61 72 61 6d 73 20 61 74 74 65 rid params atte
3aa0: 6d 70 74 6e 75 6d 3a 20 28 2b 20 61 74 74 65 6d mptnum: (+ attem
3ab0: 70 74 6e 75 6d 20 31 29 29 29 0a 09 09 72 65 73 ptnum 1)))...res
3ac0: 29 20 3b 3b 20 41 6c 6c 20 67 6f 6f 64 2c 20 72 ) ;; All good, r
3ad0: 65 74 75 72 6e 20 72 65 73 0a 09 20 20 20 20 28 eturn res.. (
3ae0: 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 64 65 begin.. (de
3af0: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
3b00: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
3b10: 57 41 52 4e 49 4e 47 3a 20 63 6f 6d 6d 75 6e 69 WARNING: communi
3b20: 63 61 74 69 6f 6e 20 66 61 69 6c 65 64 2e 20 54 cation failed. T
3b30: 72 79 69 6e 67 20 61 67 61 69 6e 2c 20 74 72 79 rying again, try
3b40: 20 6e 75 6d 3a 20 22 20 61 74 74 65 6d 70 74 6e num: " attemptn
3b50: 75 6d 29 0a 09 20 20 20 20 20 20 28 6d 75 74 65 um).. (mute
3b60: 78 2d 6c 6f 63 6b 21 20 2a 72 6d 74 2d 6d 75 74 x-lock! *rmt-mut
3b70: 65 78 2a 29 0a 20 20 20 20 20 20 20 20 20 20 20 ex*).
3b80: 20 20 20 28 72 65 6d 6f 74 65 2d 63 6f 6e 6e 64 (remote-connd
3b90: 61 74 2d 73 65 74 21 20 20 20 20 72 75 6e 72 65 at-set! runre
3ba0: 6d 6f 74 65 20 23 66 29 0a 09 20 20 20 20 20 20 mote #f)..
3bb0: 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a (http-transport:
3bc0: 63 6c 6f 73 65 2d 63 6f 6e 6e 65 63 74 69 6f 6e close-connection
3bd0: 73 20 61 72 65 61 2d 64 61 74 3a 20 72 75 6e 72 s area-dat: runr
3be0: 65 6d 6f 74 65 29 0a 09 20 20 20 20 20 20 28 72 emote).. (r
3bf0: 65 6d 6f 74 65 2d 73 65 72 76 65 72 2d 75 72 6c emote-server-url
3c00: 2d 73 65 74 21 20 72 75 6e 72 65 6d 6f 74 65 20 -set! runremote
3c10: 23 66 29 0a 09 20 20 20 20 20 20 28 6d 75 74 65 #f).. (mute
3c20: 78 2d 75 6e 6c 6f 63 6b 21 20 2a 72 6d 74 2d 6d x-unlock! *rmt-m
3c30: 75 74 65 78 2a 29 0a 20 20 20 20 20 20 20 20 20 utex*).
3c40: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
3c50: 74 2d 69 6e 66 6f 20 31 32 20 2a 64 65 66 61 75 t-info 12 *defau
3c60: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 6d 72 lt-log-port* "mr
3c70: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 2c mt:send-receive,
3c80: 20 63 61 73 65 20 20 39 2e 31 22 29 0a 09 20 20 case 9.1")..
3c90: 20 20 20 20 3b 3b 20 28 69 66 20 28 6e 6f 74 20 ;; (if (not
3ca0: 28 73 65 72 76 65 72 3a 63 68 65 63 6b 2d 69 66 (server:check-if
3cb0: 2d 72 75 6e 6e 69 6e 67 20 2a 74 6f 70 70 61 74 -running *toppat
3cc0: 68 2a 29 29 0a 09 20 20 20 20 20 20 3b 3b 20 09 h*)).. ;; .
3cd0: 20 20 28 73 65 72 76 65 72 3a 73 74 61 72 74 2d (server:start-
3ce0: 61 6e 64 2d 77 61 69 74 20 2a 74 6f 70 70 61 74 and-wait *toppat
3cf0: 68 2a 29 29 0a 09 20 20 20 20 20 20 28 6d 72 6d h*)).. (mrm
3d00: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 63 t:send-receive c
3d10: 6d 64 20 72 69 64 20 70 61 72 61 6d 73 20 61 74 md rid params at
3d20: 74 65 6d 70 74 6e 75 6d 3a 20 28 2b 20 61 74 74 temptnum: (+ att
3d30: 65 6d 70 74 6e 75 6d 20 31 29 29 29 29 29 29 29 emptnum 1)))))))
3d40: 29 29 0a 0a 20 20 20 20 3b 3b 44 4f 54 20 7d 0a )).. ;;DOT }.
3d50: 20 20 20 20 0a 3b 3b 20 28 64 65 66 69 6e 65 20 .;; (define
3d60: 28 6d 72 6d 74 3a 75 70 64 61 74 65 2d 64 62 2d (mrmt:update-db-
3d70: 73 74 61 74 73 20 72 75 6e 2d 69 64 20 72 61 77 stats run-id raw
3d80: 63 6d 64 20 70 61 72 61 6d 73 20 64 75 72 61 74 cmd params durat
3d90: 69 6f 6e 29 0a 3b 3b 20 20 20 28 6d 75 74 65 78 ion).;; (mutex
3da0: 2d 6c 6f 63 6b 21 20 2a 64 62 2d 73 74 61 74 73 -lock! *db-stats
3db0: 2d 6d 75 74 65 78 2a 29 0a 3b 3b 20 20 20 28 68 -mutex*).;; (h
3dc0: 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 andle-exceptions
3dd0: 0a 3b 3b 20 20 20 20 65 78 6e 0a 3b 3b 20 20 20 .;; exn.;;
3de0: 20 28 62 65 67 69 6e 0a 3b 3b 20 20 20 20 20 20 (begin.;;
3df0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
3e00: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
3e10: 2a 20 22 57 41 52 4e 49 4e 47 3a 20 73 74 61 74 * "WARNING: stat
3e20: 73 20 63 6f 6c 6c 65 63 74 69 6f 6e 20 66 61 69 s collection fai
3e30: 6c 65 64 20 69 6e 20 75 70 64 61 74 65 2d 64 62 led in update-db
3e40: 2d 73 74 61 74 73 22 29 0a 3b 3b 20 20 20 20 20 -stats").;;
3e50: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
3e60: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
3e70: 74 2a 20 22 20 6d 65 73 73 61 67 65 3a 20 22 20 t* " message: "
3e80: 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 ((condition-prop
3e90: 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 erty-accessor 'e
3ea0: 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e xn 'message) exn
3eb0: 29 29 0a 3b 3b 20 20 20 20 20 20 28 70 72 69 6e )).;; (prin
3ec0: 74 20 22 65 78 6e 3d 22 20 28 63 6f 6e 64 69 74 t "exn=" (condit
3ed0: 69 6f 6e 2d 3e 6c 69 73 74 20 65 78 6e 29 29 0a ion->list exn)).
3ee0: 3b 3b 20 20 20 20 20 20 23 66 29 20 3b 3b 20 69 ;; #f) ;; i
3ef0: 66 20 74 68 69 73 20 66 61 69 6c 73 20 77 65 20 f this fails we
3f00: 64 6f 6e 27 74 20 63 61 72 65 2c 20 69 74 20 69 don't care, it i
3f10: 73 20 6a 75 73 74 20 73 74 61 74 73 0a 3b 3b 20 s just stats.;;
3f20: 20 20 20 28 6c 65 74 2a 20 28 28 63 6d 64 20 20 (let* ((cmd
3f30: 20 20 20 20 28 63 6f 6e 63 20 22 72 75 6e 2d 69 (conc "run-i
3f40: 64 3d 22 20 72 75 6e 2d 69 64 20 22 20 22 20 28 d=" run-id " " (
3f50: 69 66 20 28 65 71 3f 20 72 61 77 63 6d 64 20 27 if (eq? rawcmd '
3f60: 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 29 20 28 63 general-call) (c
3f70: 61 72 20 70 61 72 61 6d 73 29 20 72 61 77 63 6d ar params) rawcm
3f80: 64 29 29 29 0a 3b 3b 20 09 20 20 28 73 74 61 74 d))).;; . (stat
3f90: 2d 76 65 63 20 28 68 61 73 68 2d 74 61 62 6c 65 -vec (hash-table
3fa0: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 64 62 -ref/default *db
3fb0: 2d 73 74 61 74 73 2a 20 63 6d 64 20 23 66 29 29 -stats* cmd #f))
3fc0: 29 0a 3b 3b 20 20 20 20 20 20 28 69 66 20 28 6e ).;; (if (n
3fd0: 6f 74 20 28 76 65 63 74 6f 72 3f 20 73 74 61 74 ot (vector? stat
3fe0: 2d 76 65 63 29 29 0a 3b 3b 20 09 20 28 6c 65 74 -vec)).;; . (let
3ff0: 20 28 28 6e 65 77 76 65 63 20 28 76 65 63 74 6f ((newvec (vecto
4000: 72 20 30 20 30 29 29 29 0a 3b 3b 20 09 20 20 20 r 0 0))).;; .
4010: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
4020: 20 2a 64 62 2d 73 74 61 74 73 2a 20 63 6d 64 20 *db-stats* cmd
4030: 6e 65 77 76 65 63 29 0a 3b 3b 20 09 20 20 20 28 newvec).;; . (
4040: 73 65 74 21 20 73 74 61 74 2d 76 65 63 20 6e 65 set! stat-vec ne
4050: 77 76 65 63 29 29 29 0a 3b 3b 20 20 20 20 20 20 wvec))).;;
4060: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 73 74 61 (vector-set! sta
4070: 74 2d 76 65 63 20 30 20 28 2b 20 28 76 65 63 74 t-vec 0 (+ (vect
4080: 6f 72 2d 72 65 66 20 73 74 61 74 2d 76 65 63 20 or-ref stat-vec
4090: 30 29 20 31 29 29 0a 3b 3b 20 20 20 20 20 20 28 0) 1)).;; (
40a0: 76 65 63 74 6f 72 2d 73 65 74 21 20 73 74 61 74 vector-set! stat
40b0: 2d 76 65 63 20 31 20 28 2b 20 28 76 65 63 74 6f -vec 1 (+ (vecto
40c0: 72 2d 72 65 66 20 73 74 61 74 2d 76 65 63 20 31 r-ref stat-vec 1
40d0: 29 20 64 75 72 61 74 69 6f 6e 29 29 29 29 0a 3b ) duration)))).;
40e0: 3b 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 ; (mutex-unloc
40f0: 6b 21 20 2a 64 62 2d 73 74 61 74 73 2d 6d 75 74 k! *db-stats-mut
4100: 65 78 2a 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 ex*))..(define (
4110: 6d 72 6d 74 3a 70 72 69 6e 74 2d 64 62 2d 73 74 mrmt:print-db-st
4120: 61 74 73 29 0a 20 20 28 6c 65 74 20 28 28 66 6d ats). (let ((fm
4130: 74 73 74 72 20 22 7e 34 30 61 7e 37 2d 64 7e 39 tstr "~40a~7-d~9
4140: 2d 64 7e 32 30 2c 32 2d 66 22 29 29 20 3b 3b 20 -d~20,2-f")) ;;
4150: 22 7e 32 30 2c 32 2d 66 22 0a 20 20 20 20 28 64 "~20,2-f". (d
4160: 65 62 75 67 3a 70 72 69 6e 74 20 31 38 20 2a 64 ebug:print 18 *d
4170: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
4180: 20 22 44 42 20 53 74 61 74 73 5c 6e 3d 3d 3d 3d "DB Stats\n====
4190: 3d 3d 3d 3d 22 29 0a 20 20 20 20 28 64 65 62 75 ===="). (debu
41a0: 67 3a 70 72 69 6e 74 20 31 38 20 2a 64 65 66 61 g:print 18 *defa
41b0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 28 66 ult-log-port* (f
41c0: 6f 72 6d 61 74 20 23 66 20 22 7e 34 30 61 7e 38 ormat #f "~40a~8
41d0: 61 7e 31 30 61 7e 31 30 61 22 20 22 43 6d 64 22 a~10a~10a" "Cmd"
41e0: 20 22 43 6f 75 6e 74 22 20 22 54 6f 74 54 69 6d "Count" "TotTim
41f0: 65 22 20 22 41 76 67 22 29 29 0a 20 20 20 20 28 e" "Avg")). (
4200: 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 for-each (lambda
4210: 20 28 63 6d 64 29 0a 09 09 28 6c 65 74 20 28 28 (cmd)...(let ((
4220: 63 6d 64 2d 64 61 74 20 28 68 61 73 68 2d 74 61 cmd-dat (hash-ta
4230: 62 6c 65 2d 72 65 66 20 2a 64 62 2d 73 74 61 74 ble-ref *db-stat
4240: 73 2a 20 63 6d 64 29 29 29 0a 09 09 20 20 28 64 s* cmd)))... (d
4250: 65 62 75 67 3a 70 72 69 6e 74 20 31 38 20 2a 64 ebug:print 18 *d
4260: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
4270: 20 28 66 6f 72 6d 61 74 20 23 66 20 66 6d 74 73 (format #f fmts
4280: 74 72 20 63 6d 64 20 28 76 65 63 74 6f 72 2d 72 tr cmd (vector-r
4290: 65 66 20 63 6d 64 2d 64 61 74 20 30 29 20 28 76 ef cmd-dat 0) (v
42a0: 65 63 74 6f 72 2d 72 65 66 20 63 6d 64 2d 64 61 ector-ref cmd-da
42b0: 74 20 31 29 20 28 2f 20 28 76 65 63 74 6f 72 2d t 1) (/ (vector-
42c0: 72 65 66 20 63 6d 64 2d 64 61 74 20 31 29 28 76 ref cmd-dat 1)(v
42d0: 65 63 74 6f 72 2d 72 65 66 20 63 6d 64 2d 64 61 ector-ref cmd-da
42e0: 74 20 30 29 29 29 29 29 29 0a 09 20 20 20 20 20 t 0))))))..
42f0: 20 28 73 6f 72 74 20 28 68 61 73 68 2d 74 61 62 (sort (hash-tab
4300: 6c 65 2d 6b 65 79 73 20 2a 64 62 2d 73 74 61 74 le-keys *db-stat
4310: 73 2a 29 0a 09 09 20 20 20 20 28 6c 61 6d 62 64 s*)... (lambd
4320: 61 20 28 61 20 62 29 0a 09 09 20 20 20 20 20 20 a (a b)...
4330: 28 3e 20 28 76 65 63 74 6f 72 2d 72 65 66 20 28 (> (vector-ref (
4340: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 2a hash-table-ref *
4350: 64 62 2d 73 74 61 74 73 2a 20 61 29 20 30 29 0a db-stats* a) 0).
4360: 09 09 09 20 28 76 65 63 74 6f 72 2d 72 65 66 20 ... (vector-ref
4370: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 (hash-table-ref
4380: 2a 64 62 2d 73 74 61 74 73 2a 20 62 29 20 30 29 *db-stats* b) 0)
4390: 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ))))))..(define
43a0: 28 6d 72 6d 74 3a 67 65 74 2d 6d 61 78 2d 71 75 (mrmt:get-max-qu
43b0: 65 72 79 2d 61 76 65 72 61 67 65 20 72 75 6e 2d ery-average run-
43c0: 69 64 29 0a 20 20 28 6d 75 74 65 78 2d 6c 6f 63 id). (mutex-loc
43d0: 6b 21 20 2a 64 62 2d 73 74 61 74 73 2d 6d 75 74 k! *db-stats-mut
43e0: 65 78 2a 29 0a 20 20 28 6c 65 74 2a 20 28 28 72 ex*). (let* ((r
43f0: 75 6e 6b 65 79 20 28 63 6f 6e 63 20 22 72 75 6e unkey (conc "run
4400: 2d 69 64 3d 22 20 72 75 6e 2d 69 64 20 22 20 22 -id=" run-id " "
4410: 29 29 0a 09 20 28 63 6d 64 73 20 20 20 28 66 69 )).. (cmds (fi
4420: 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 lter (lambda (x)
4430: 0a 09 09 09 20 20 20 28 73 75 62 73 74 72 69 6e .... (substrin
4440: 67 2d 69 6e 64 65 78 20 72 75 6e 6b 65 79 20 78 g-index runkey x
4450: 29 29 0a 09 09 09 20 28 68 61 73 68 2d 74 61 62 )).... (hash-tab
4460: 6c 65 2d 6b 65 79 73 20 2a 64 62 2d 73 74 61 74 le-keys *db-stat
4470: 73 2a 29 29 29 0a 09 20 28 72 65 73 20 20 20 20 s*))).. (res
4480: 28 69 66 20 28 6e 75 6c 6c 3f 20 63 6d 64 73 29 (if (null? cmds)
4490: 0a 09 09 20 20 20 20 20 28 63 6f 6e 73 20 27 6e ... (cons 'n
44a0: 6f 6e 65 20 30 29 0a 09 09 20 20 20 20 20 28 6c one 0)... (l
44b0: 65 74 20 6c 6f 6f 70 20 28 28 63 6d 64 20 28 63 et loop ((cmd (c
44c0: 61 72 20 63 6d 64 73 29 29 0a 09 09 09 09 28 74 ar cmds)).....(t
44d0: 61 6c 20 28 63 64 72 20 63 6d 64 73 29 29 0a 09 al (cdr cmds))..
44e0: 09 09 09 28 6d 61 78 2d 63 6d 64 20 28 63 61 72 ...(max-cmd (car
44f0: 20 63 6d 64 73 29 29 0a 09 09 09 09 28 72 65 73 cmds)).....(res
4500: 20 30 29 29 0a 09 09 20 20 20 20 20 20 20 28 6c 0))... (l
4510: 65 74 2a 20 28 28 63 6d 64 2d 64 61 74 20 28 68 et* ((cmd-dat (h
4520: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 2a 64 ash-table-ref *d
4530: 62 2d 73 74 61 74 73 2a 20 63 6d 64 29 29 0a 09 b-stats* cmd))..
4540: 09 09 20 20 20 20 20 20 28 74 6f 74 20 20 20 20 .. (tot
4550: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 63 6d 64 (vector-ref cmd
4560: 2d 64 61 74 20 30 29 29 0a 09 09 09 20 20 20 20 -dat 0))....
4570: 20 20 28 63 75 72 72 61 76 67 20 28 2f 20 28 76 (curravg (/ (v
4580: 65 63 74 6f 72 2d 72 65 66 20 63 6d 64 2d 64 61 ector-ref cmd-da
4590: 74 20 31 29 20 28 76 65 63 74 6f 72 2d 72 65 66 t 1) (vector-ref
45a0: 20 63 6d 64 2d 64 61 74 20 30 29 29 29 20 3b 3b cmd-dat 0))) ;;
45b0: 20 63 6f 75 6e 74 20 69 73 20 6e 65 76 65 72 20 count is never
45c0: 7a 65 72 6f 20 62 79 20 63 6f 6e 73 74 72 75 63 zero by construc
45d0: 74 69 6f 6e 0a 09 09 09 20 20 20 20 20 20 28 63 tion.... (c
45e0: 75 72 72 6d 61 78 20 28 6d 61 78 20 72 65 73 20 urrmax (max res
45f0: 63 75 72 72 61 76 67 29 29 0a 09 09 09 20 20 20 curravg))....
4600: 20 20 20 28 6e 65 77 6d 61 78 2d 63 6d 64 20 28 (newmax-cmd (
4610: 69 66 20 28 3e 20 63 75 72 72 61 76 67 20 72 65 if (> curravg re
4620: 73 29 20 63 6d 64 20 6d 61 78 2d 63 6d 64 29 29 s) cmd max-cmd))
4630: 29 0a 09 09 09 20 28 69 66 20 28 6e 75 6c 6c 3f ).... (if (null?
4640: 20 74 61 6c 29 0a 09 09 09 20 20 20 20 20 28 69 tal).... (i
4650: 66 20 28 3e 20 74 6f 74 20 31 30 29 0a 09 09 09 f (> tot 10)....
4660: 09 20 28 63 6f 6e 73 20 6e 65 77 6d 61 78 2d 63 . (cons newmax-c
4670: 6d 64 20 63 75 72 72 6d 61 78 29 0a 09 09 09 09 md currmax).....
4680: 20 28 63 6f 6e 73 20 27 6e 6f 6e 65 20 30 29 29 (cons 'none 0))
4690: 0a 09 09 09 20 20 20 20 20 28 6c 6f 6f 70 20 28 .... (loop (
46a0: 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c car tal)(cdr tal
46b0: 29 20 6e 65 77 6d 61 78 2d 63 6d 64 20 63 75 72 ) newmax-cmd cur
46c0: 72 6d 61 78 29 29 29 29 29 29 29 0a 20 20 20 20 rmax))))))).
46d0: 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a (mutex-unlock! *
46e0: 64 62 2d 73 74 61 74 73 2d 6d 75 74 65 78 2a 29 db-stats-mutex*)
46f0: 0a 20 20 20 20 72 65 73 29 29 0a 0a 28 64 65 66 . res))..(def
4700: 69 6e 65 20 28 6d 72 6d 74 3a 6f 70 65 6e 2d 71 ine (mrmt:open-q
4710: 72 79 2d 63 6c 6f 73 65 2d 6c 6f 63 61 6c 6c 79 ry-close-locally
4720: 20 63 6d 64 20 72 75 6e 2d 69 64 20 70 61 72 61 cmd run-id para
4730: 6d 73 20 23 21 6b 65 79 20 28 72 65 6d 72 65 74 ms #!key (remret
4740: 72 69 65 73 20 35 29 29 0a 20 20 28 6c 65 74 2a ries 5)). (let*
4750: 20 28 28 71 72 79 2d 69 73 2d 77 72 69 74 65 20 ((qry-is-write
4760: 20 20 28 6e 6f 74 20 28 6d 65 6d 62 65 72 20 63 (not (member c
4770: 6d 64 20 61 70 69 3a 72 65 61 64 2d 6f 6e 6c 79 md api:read-only
4780: 2d 71 75 65 72 69 65 73 29 29 29 0a 09 20 28 64 -queries))).. (d
4790: 62 2d 66 69 6c 65 2d 70 61 74 68 20 20 20 28 64 b-file-path (d
47a0: 62 3a 64 62 66 69 6c 65 2d 70 61 74 68 29 29 20 b:dbfile-path))
47b0: 3b 3b 20 20 30 29 29 0a 09 20 28 64 62 73 74 72 ;; 0)).. (dbstr
47c0: 75 63 74 2d 6c 6f 63 61 6c 20 28 64 62 3a 73 65 uct-local (db:se
47d0: 74 75 70 20 23 74 29 29 20 20 3b 3b 20 6d 61 6b tup #t)) ;; mak
47e0: 65 2d 64 62 72 3a 64 62 73 74 72 75 63 74 20 70 e-dbr:dbstruct p
47f0: 61 74 68 3a 20 20 64 62 64 69 72 20 6c 6f 63 61 ath: dbdir loca
4800: 6c 3a 20 23 74 29 29 29 0a 09 20 28 72 65 61 64 l: #t))).. (read
4810: 2d 6f 6e 6c 79 20 20 20 20 20 20 28 6e 6f 74 20 -only (not
4820: 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 (file-write-acce
4830: 73 73 3f 20 64 62 2d 66 69 6c 65 2d 70 61 74 68 ss? db-file-path
4840: 29 29 29 0a 09 20 28 73 74 61 72 74 20 20 20 20 ))).. (start
4850: 20 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d 6d (current-m
4860: 69 6c 6c 69 73 65 63 6f 6e 64 73 29 29 0a 09 20 illiseconds))..
4870: 28 72 65 73 64 61 74 20 20 20 20 20 20 20 20 20 (resdat
4880: 28 69 66 20 28 6e 6f 74 20 28 61 6e 64 20 72 65 (if (not (and re
4890: 61 64 2d 6f 6e 6c 79 20 71 72 79 2d 69 73 2d 77 ad-only qry-is-w
48a0: 72 69 74 65 29 29 0a 09 09 09 20 20 20 20 20 28 rite)).... (
48b0: 6c 65 74 20 28 28 76 20 28 61 70 69 3a 65 78 65 let ((v (api:exe
48c0: 63 75 74 65 2d 72 65 71 75 65 73 74 73 20 64 62 cute-requests db
48d0: 73 74 72 75 63 74 2d 6c 6f 63 61 6c 20 28 76 65 struct-local (ve
48e0: 63 74 6f 72 20 28 73 79 6d 62 6f 6c 2d 3e 73 74 ctor (symbol->st
48f0: 72 69 6e 67 20 63 6d 64 29 20 70 61 72 61 6d 73 ring cmd) params
4900: 29 29 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 )))).... (
4910: 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e handle-exception
4920: 73 20 3b 3b 20 74 68 65 72 65 20 68 61 73 20 62 s ;; there has b
4930: 65 65 6e 20 61 20 6c 6f 6e 67 20 68 69 73 74 6f een a long histo
4940: 72 79 20 6f 66 20 72 65 63 65 69 76 69 6e 67 20 ry of receiving
4950: 73 74 72 61 6e 67 65 20 65 72 72 6f 72 73 20 66 strange errors f
4960: 72 6f 6d 20 76 61 6c 75 65 73 20 72 65 74 75 72 rom values retur
4970: 6e 65 64 20 62 79 20 74 68 65 20 63 6c 69 65 6e ned by the clien
4980: 74 20 77 68 65 6e 20 74 68 69 6e 67 73 20 67 6f t when things go
4990: 20 77 72 6f 6e 67 2e 2e 0a 09 09 09 09 65 78 6e wrong.......exn
49a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
49b0: 3b 20 20 54 68 69 73 20 69 73 20 61 6e 20 61 74 ; This is an at
49c0: 74 65 6d 70 74 20 74 6f 20 64 65 74 65 63 74 20 tempt to detect
49d0: 74 68 61 74 20 73 69 74 75 61 74 69 6f 6e 20 61 that situation a
49e0: 6e 64 20 72 65 63 6f 76 65 72 20 67 72 61 63 65 nd recover grace
49f0: 66 75 6c 6c 79 0a 09 09 09 09 28 62 65 67 69 6e fully.....(begin
4a00: 0a 09 09 09 09 20 20 28 64 65 62 75 67 3a 70 72 ..... (debug:pr
4a10: 69 6e 74 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f int0 *default-lo
4a20: 67 2d 70 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 g-port* "ERROR:
4a30: 62 61 64 20 64 61 74 61 20 66 72 6f 6d 20 73 65 bad data from se
4a40: 72 76 65 72 20 22 20 76 20 22 20 6d 65 73 73 61 rver " v " messa
4a50: 67 65 3a 20 22 20 20 28 28 63 6f 6e 64 69 74 69 ge: " ((conditi
4a60: 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 on-property-acce
4a70: 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 ssor 'exn 'messa
4a80: 67 65 29 20 65 78 6e 29 29 0a 09 09 09 09 20 20 ge) exn)).....
4a90: 28 76 65 63 74 6f 72 20 23 74 20 27 28 29 29 29 (vector #t '()))
4aa0: 20 3b 3b 20 73 68 6f 75 6c 64 20 61 6c 77 61 79 ;; should alway
4ab0: 73 20 67 65 74 20 61 20 76 65 63 74 6f 72 20 62 s get a vector b
4ac0: 75 74 20 69 66 20 73 6f 6d 65 74 68 69 6e 67 20 ut if something
4ad0: 67 6f 65 73 20 77 72 6f 6e 67 20 72 65 74 75 72 goes wrong retur
4ae0: 6e 20 61 20 64 75 6d 6d 79 0a 09 09 09 09 28 69 n a dummy.....(i
4af0: 66 20 28 61 6e 64 20 28 76 65 63 74 6f 72 3f 20 f (and (vector?
4b00: 76 29 0a 09 09 09 09 09 20 28 3e 20 28 76 65 63 v)...... (> (vec
4b10: 74 6f 72 2d 6c 65 6e 67 74 68 20 76 29 20 31 29 tor-length v) 1)
4b20: 29 0a 09 09 09 09 20 20 20 20 28 6c 65 74 20 28 )..... (let (
4b30: 28 6e 65 77 76 65 63 20 28 76 65 63 74 6f 72 20 (newvec (vector
4b40: 28 76 65 63 74 6f 72 2d 72 65 66 20 76 20 30 29 (vector-ref v 0)
4b50: 28 76 65 63 74 6f 72 2d 72 65 66 20 76 20 31 29 (vector-ref v 1)
4b60: 29 29 29 0a 09 09 09 09 20 20 20 20 20 20 6e 65 )))..... ne
4b70: 77 76 65 63 29 20 20 20 20 20 20 20 20 20 20 20 wvec)
4b80: 3b 3b 20 62 79 20 63 6f 70 79 69 6e 67 20 74 68 ;; by copying th
4b90: 65 20 76 65 63 74 6f 72 20 77 68 69 6c 65 20 69 e vector while i
4ba0: 6e 73 69 64 65 20 74 68 65 20 65 72 72 6f 72 20 nside the error
4bb0: 68 61 6e 64 6c 65 72 20 77 65 20 73 68 6f 75 6c handler we shoul
4bc0: 64 20 66 6f 72 63 65 20 74 68 65 20 64 65 74 65 d force the dete
4bd0: 63 74 69 6f 6e 20 6f 66 20 61 20 63 6f 72 72 75 ction of a corru
4be0: 70 74 65 64 20 72 65 63 6f 72 64 0a 09 09 09 09 pted record.....
4bf0: 20 20 20 20 28 76 65 63 74 6f 72 20 23 74 20 27 (vector #t '
4c00: 28 29 29 29 29 29 20 20 3b 3b 20 77 65 20 63 6f ())))) ;; we co
4c10: 75 6c 64 20 61 6c 73 6f 20 63 68 65 63 6b 20 74 uld also check t
4c20: 68 61 74 20 74 68 65 20 72 65 74 75 72 6e 65 64 hat the returned
4c30: 20 74 79 70 65 73 20 61 72 65 20 76 61 6c 69 64 types are valid
4c40: 0a 09 09 09 20 20 20 20 20 28 76 65 63 74 6f 72 .... (vector
4c50: 20 23 74 20 27 28 29 29 29 29 0a 09 20 28 73 75 #t '()))).. (su
4c60: 63 63 65 73 73 20 20 20 20 20 20 20 20 28 76 65 ccess (ve
4c70: 63 74 6f 72 2d 72 65 66 20 72 65 73 64 61 74 20 ctor-ref resdat
4c80: 30 29 29 0a 09 20 28 72 65 73 20 20 20 20 20 20 0)).. (res
4c90: 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 (vector-re
4ca0: 66 20 72 65 73 64 61 74 20 31 29 29 0a 09 20 28 f resdat 1)).. (
4cb0: 64 75 72 61 74 69 6f 6e 20 20 20 20 20 20 20 28 duration (
4cc0: 2d 20 28 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 - (current-milli
4cd0: 73 65 63 6f 6e 64 73 29 20 73 74 61 72 74 29 29 seconds) start))
4ce0: 29 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 72 ). (if (and r
4cf0: 65 61 64 2d 6f 6e 6c 79 20 71 72 79 2d 69 73 2d ead-only qry-is-
4d00: 77 72 69 74 65 29 0a 20 20 20 20 20 20 20 20 28 write). (
4d10: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
4d20: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
4d30: 20 22 45 52 52 4f 52 3a 20 61 74 74 65 6d 70 74 "ERROR: attempt
4d40: 20 74 6f 20 77 72 69 74 65 20 74 6f 20 72 65 61 to write to rea
4d50: 64 2d 6f 6e 6c 79 20 64 61 74 61 62 61 73 65 20 d-only database
4d60: 69 67 6e 6f 72 65 64 2e 20 63 6d 64 3d 22 20 63 ignored. cmd=" c
4d70: 6d 64 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f md)). (if (no
4d80: 74 20 73 75 63 63 65 73 73 29 0a 09 28 69 66 20 t success)..(if
4d90: 28 3e 20 72 65 6d 72 65 74 72 69 65 73 20 30 29 (> remretries 0)
4da0: 0a 09 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 .. (begin..
4db0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
4dc0: 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c -error 0 *defaul
4dd0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 6c 6f 63 t-log-port* "loc
4de0: 61 6c 20 71 75 65 72 79 20 66 61 69 6c 65 64 2e al query failed.
4df0: 20 54 72 79 69 6e 67 20 61 67 61 69 6e 2e 22 29 Trying again.")
4e00: 0a 09 20 20 20 20 20 20 28 74 68 72 65 61 64 2d .. (thread-
4e10: 73 6c 65 65 70 21 20 28 2f 20 28 72 61 6e 64 6f sleep! (/ (rando
4e20: 6d 20 35 30 30 30 29 20 31 30 30 30 29 29 20 3b m 5000) 1000)) ;
4e30: 3b 20 73 6f 6d 65 20 72 61 6e 64 6f 6d 20 64 65 ; some random de
4e40: 6c 61 79 20 0a 09 20 20 20 20 20 20 28 6d 72 6d lay .. (mrm
4e50: 74 3a 6f 70 65 6e 2d 71 72 79 2d 63 6c 6f 73 65 t:open-qry-close
4e60: 2d 6c 6f 63 61 6c 6c 79 20 63 6d 64 20 72 75 6e -locally cmd run
4e70: 2d 69 64 20 70 61 72 61 6d 73 20 72 65 6d 72 65 -id params remre
4e80: 74 72 69 65 73 3a 20 28 2d 20 72 65 6d 72 65 74 tries: (- remret
4e90: 72 69 65 73 20 31 29 29 29 0a 09 20 20 20 20 28 ries 1))).. (
4ea0: 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 64 65 begin.. (de
4eb0: 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 bug:print-error
4ec0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
4ed0: 6f 72 74 2a 20 22 74 6f 6f 20 6d 61 6e 79 20 72 ort* "too many r
4ee0: 65 74 72 69 65 73 20 69 6e 20 6d 72 6d 74 3a 6f etries in mrmt:o
4ef0: 70 65 6e 2d 71 72 79 2d 63 6c 6f 73 65 2d 6c 6f pen-qry-close-lo
4f00: 63 61 6c 6c 79 2c 20 67 69 76 69 6e 67 20 75 70 cally, giving up
4f10: 22 29 0a 09 20 20 20 20 20 20 23 66 29 29 0a 09 ").. #f))..
4f20: 28 62 65 67 69 6e 0a 09 20 20 3b 3b 20 28 6d 72 (begin.. ;; (mr
4f30: 6d 74 3a 75 70 64 61 74 65 2d 64 62 2d 73 74 61 mt:update-db-sta
4f40: 74 73 20 72 75 6e 2d 69 64 20 63 6d 64 20 70 61 ts run-id cmd pa
4f50: 72 61 6d 73 20 64 75 72 61 74 69 6f 6e 29 0a 09 rams duration)..
4f60: 20 20 3b 3b 20 6d 61 72 6b 20 74 68 69 73 20 72 ;; mark this r
4f70: 75 6e 20 61 73 20 64 69 72 74 79 20 69 66 20 74 un as dirty if t
4f80: 68 69 73 20 77 61 73 20 61 20 77 72 69 74 65 2c his was a write,
4f90: 20 74 68 65 20 77 61 74 63 68 64 6f 67 20 69 73 the watchdog is
4fa0: 20 72 65 73 70 6f 6e 73 69 62 6c 65 20 66 6f 72 responsible for
4fb0: 20 73 79 6e 63 69 6e 67 20 69 74 0a 09 20 20 28 syncing it.. (
4fc0: 69 66 20 71 72 79 2d 69 73 2d 77 72 69 74 65 0a if qry-is-write.
4fd0: 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 73 74 . (let ((st
4fe0: 61 72 74 2d 74 69 6d 65 20 28 63 75 72 72 65 6e art-time (curren
4ff0: 74 2d 73 65 63 6f 6e 64 73 29 29 29 0a 09 09 28 t-seconds)))...(
5000: 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 64 62 2d mutex-lock! *db-
5010: 6d 75 6c 74 69 2d 73 79 6e 63 2d 6d 75 74 65 78 multi-sync-mutex
5020: 2a 29 0a 2f 09 09 28 73 65 74 21 20 2a 64 62 2d *)./..(set! *db-
5030: 6c 61 73 74 2d 61 63 63 65 73 73 2a 20 73 74 61 last-access* sta
5040: 72 74 2d 74 69 6d 65 29 20 20 3b 3b 20 54 48 49 rt-time) ;; THI
5050: 53 20 49 53 20 50 52 4f 42 41 42 4c 59 20 55 53 S IS PROBABLY US
5060: 45 4c 45 53 53 3f 20 28 77 65 20 61 72 65 20 6f ELESS? (we are o
5070: 6e 20 61 20 63 6c 69 65 6e 74 29 0a 20 20 20 20 n a client).
5080: 20 20 20 20 20 20 20 20 20 20 20 20 28 6d 75 74 (mut
5090: 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 64 62 2d 6d ex-unlock! *db-m
50a0: 75 6c 74 69 2d 73 79 6e 63 2d 6d 75 74 65 78 2a ulti-sync-mutex*
50b0: 29 29 29 29 29 0a 20 20 20 20 72 65 73 29 29 0a ))))). res)).
50c0: 0a 28 64 65 66 69 6e 65 20 28 6d 72 6d 74 3a 73 .(define (mrmt:s
50d0: 65 6e 64 2d 72 65 63 65 69 76 65 2d 6e 6f 2d 61 end-receive-no-a
50e0: 75 74 6f 2d 63 6c 69 65 6e 74 2d 73 65 74 75 70 uto-client-setup
50f0: 20 63 6f 6e 6e 65 63 74 69 6f 6e 2d 69 6e 66 6f connection-info
5100: 20 63 6d 64 20 72 75 6e 2d 69 64 20 70 61 72 61 cmd run-id para
5110: 6d 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 72 75 ms). (let* ((ru
5120: 6e 2d 69 64 20 20 20 28 69 66 20 72 75 6e 2d 69 n-id (if run-i
5130: 64 20 72 75 6e 2d 69 64 20 30 29 29 0a 09 20 28 d run-id 0)).. (
5140: 72 65 73 20 20 09 20 20 20 28 68 61 6e 64 6c 65 res . (handle
5150: 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 20 20 -exceptions...
5160: 20 20 65 78 6e 0a 09 09 20 20 20 20 23 66 0a 09 exn... #f..
5170: 09 20 20 20 20 28 68 74 74 70 2d 74 72 61 6e 73 . (http-trans
5180: 70 6f 72 74 3a 63 6c 69 65 6e 74 2d 61 70 69 2d port:client-api-
5190: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 72 75 6e send-receive run
51a0: 2d 69 64 20 63 6f 6e 6e 65 63 74 69 6f 6e 2d 69 -id connection-i
51b0: 6e 66 6f 20 63 6d 64 20 70 61 72 61 6d 73 29 29 nfo cmd params))
51c0: 29 29 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 )). (if (and
51d0: 72 65 73 20 28 76 65 63 74 6f 72 2d 72 65 66 20 res (vector-ref
51e0: 72 65 73 20 30 29 29 0a 09 28 76 65 63 74 6f 72 res 0))..(vector
51f0: 2d 72 65 66 20 72 65 73 20 31 29 20 3b 3b 3b 20 -ref res 1) ;;;
5200: 59 45 53 21 21 20 54 48 49 53 20 49 53 20 43 4f YES!! THIS IS CO
5210: 52 52 45 43 54 21 21 20 43 48 41 4e 47 45 20 49 RRECT!! CHANGE I
5220: 54 20 48 45 52 45 2c 20 54 48 45 4e 20 43 48 41 T HERE, THEN CHA
5230: 4e 47 45 20 6d 72 6d 74 3a 73 65 6e 64 2d 72 65 NGE mrmt:send-re
5240: 63 65 69 76 65 20 41 4c 53 4f 21 21 21 0a 09 23 ceive ALSO!!!..#
5250: 66 29 29 29 0a 0a 3b 3b 20 3b 3b 20 57 72 61 70 f)))..;; ;; Wrap
5260: 20 6a 73 6f 6e 20 6c 69 62 72 61 72 79 20 66 6f json library fo
5270: 72 20 73 74 72 69 6e 67 73 20 28 77 68 79 20 74 r strings (why t
5280: 68 65 20 70 6f 72 74 73 20 63 72 61 70 20 69 6e he ports crap in
5290: 20 74 68 65 20 66 69 72 73 74 20 70 6c 61 63 65 the first place
52a0: 3f 29 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 6d ?).;; (define (m
52b0: 72 6d 74 3a 64 61 74 2d 3e 6a 73 6f 6e 2d 73 74 rmt:dat->json-st
52c0: 72 20 64 61 74 29 0a 3b 3b 20 20 20 28 77 69 74 r dat).;; (wit
52d0: 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 73 74 72 69 h-output-to-stri
52e0: 6e 67 20 0a 3b 3b 20 20 20 20 20 28 6c 61 6d 62 ng .;; (lamb
52f0: 64 61 20 28 29 0a 3b 3b 20 20 20 20 20 20 20 28 da ().;; (
5300: 6a 73 6f 6e 2d 77 72 69 74 65 20 64 61 74 29 29 json-write dat))
5310: 29 29 0a 3b 3b 20 0a 3b 3b 20 28 64 65 66 69 6e )).;; .;; (defin
5320: 65 20 28 6d 72 6d 74 3a 6a 73 6f 6e 2d 73 74 72 e (mrmt:json-str
5330: 2d 3e 64 61 74 20 6a 73 6f 6e 2d 73 74 72 29 0a ->dat json-str).
5340: 3b 3b 20 20 20 28 77 69 74 68 2d 69 6e 70 75 74 ;; (with-input
5350: 2d 66 72 6f 6d 2d 73 74 72 69 6e 67 20 6a 73 6f -from-string jso
5360: 6e 2d 73 74 72 0a 3b 3b 20 20 20 20 20 28 6c 61 n-str.;; (la
5370: 6d 62 64 61 20 28 29 0a 3b 3b 20 20 20 20 20 20 mbda ().;;
5380: 20 28 6a 73 6f 6e 2d 72 65 61 64 29 29 29 29 0a (json-read)))).
5390: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
53a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
53b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
53c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
53d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 0a 3b 3b 20 =========.;;.;;
53e0: 41 20 43 20 54 20 55 20 41 20 4c 20 20 20 41 20 A C T U A L A
53f0: 50 20 49 20 20 20 43 20 41 20 4c 20 4c 20 53 20 P I C A L L S
5400: 20 0a 3b 3b 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;.;;=========
5410: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5420: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5430: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5440: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b =============..;
5450: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
5460: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5470: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5480: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5490: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 53 20 45 20 =======.;; S E
54a0: 52 20 56 20 45 20 52 0a 3b 3b 3d 3d 3d 3d 3d 3d R V E R.;;======
54b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
54c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
54d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
54e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
54f0: 0a 0a 28 64 65 66 69 6e 65 20 28 6d 72 6d 74 3a ..(define (mrmt:
5500: 6b 69 6c 6c 2d 73 65 72 76 65 72 20 72 75 6e 2d kill-server run-
5510: 69 64 29 0a 20 20 28 6d 72 6d 74 3a 73 65 6e 64 id). (mrmt:send
5520: 2d 72 65 63 65 69 76 65 20 27 6b 69 6c 6c 2d 73 -receive 'kill-s
5530: 65 72 76 65 72 20 72 75 6e 2d 69 64 20 28 6c 69 erver run-id (li
5540: 73 74 20 72 75 6e 2d 69 64 29 29 29 0a 0a 28 64 st run-id)))..(d
5550: 65 66 69 6e 65 20 28 6d 72 6d 74 3a 73 74 61 72 efine (mrmt:star
5560: 74 2d 73 65 72 76 65 72 20 72 75 6e 2d 69 64 29 t-server run-id)
5570: 0a 20 20 28 6d 72 6d 74 3a 73 65 6e 64 2d 72 65 . (mrmt:send-re
5580: 63 65 69 76 65 20 27 73 74 61 72 74 2d 73 65 72 ceive 'start-ser
5590: 76 65 72 20 30 20 28 6c 69 73 74 20 72 75 6e 2d ver 0 (list run-
55a0: 69 64 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d id)))..;;=======
55b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
55c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
55d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
55e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
55f0: 3b 3b 20 20 4d 20 49 20 53 20 43 0a 3b 3b 3d 3d ;; M I S C.;;==
5600: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5610: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5620: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5630: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5640: 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 6d ====..(define (m
5650: 72 6d 74 3a 6c 6f 67 69 6e 20 72 75 6e 2d 69 64 rmt:login run-id
5660: 29 0a 20 20 28 6d 72 6d 74 3a 73 65 6e 64 2d 72 ). (mrmt:send-r
5670: 65 63 65 69 76 65 20 27 6c 6f 67 69 6e 20 72 75 eceive 'login ru
5680: 6e 2d 69 64 20 28 6c 69 73 74 20 2a 74 6f 70 70 n-id (list *topp
5690: 61 74 68 2a 20 6d 65 67 61 74 65 73 74 2d 76 65 ath* megatest-ve
56a0: 72 73 69 6f 6e 20 2a 6d 79 2d 63 6c 69 65 6e 74 rsion *my-client
56b0: 2d 73 69 67 6e 61 74 75 72 65 2a 29 29 29 0a 0a -signature*)))..
56c0: 3b 3b 20 54 68 69 73 20 6c 6f 67 69 6e 20 64 6f ;; This login do
56d0: 65 73 20 6e 6f 20 72 65 74 72 69 65 73 20 75 6e es no retries un
56e0: 64 65 72 20 74 68 65 20 68 6f 6f 64 20 2d 20 69 der the hood - i
56f0: 74 20 61 63 74 73 20 61 20 62 69 74 20 6c 69 6b t acts a bit lik
5700: 65 20 61 20 70 69 6e 67 2e 0a 3b 3b 20 44 65 70 e a ping..;; Dep
5710: 72 65 63 61 74 65 64 20 66 6f 72 20 6e 6d 73 67 recated for nmsg
5720: 2d 74 72 61 6e 73 70 6f 72 74 2e 0a 3b 3b 0a 28 -transport..;;.(
5730: 64 65 66 69 6e 65 20 28 6d 72 6d 74 3a 6c 6f 67 define (mrmt:log
5740: 69 6e 2d 6e 6f 2d 61 75 74 6f 2d 63 6c 69 65 6e in-no-auto-clien
5750: 74 2d 73 65 74 75 70 20 63 6f 6e 6e 65 63 74 69 t-setup connecti
5760: 6f 6e 2d 69 6e 66 6f 29 0a 20 20 28 63 61 73 65 on-info). (case
5770: 20 2a 74 72 61 6e 73 70 6f 72 74 2d 74 79 70 65 *transport-type
5780: 2a 20 3b 3b 20 72 75 6e 2d 69 64 20 6f 66 20 30 * ;; run-id of 0
5790: 20 69 73 20 6a 75 73 74 20 61 20 70 6c 61 63 65 is just a place
57a0: 68 6f 6c 64 65 72 0a 20 20 20 20 28 28 68 74 74 holder. ((htt
57b0: 70 29 28 6d 72 6d 74 3a 73 65 6e 64 2d 72 65 63 p)(mrmt:send-rec
57c0: 65 69 76 65 2d 6e 6f 2d 61 75 74 6f 2d 63 6c 69 eive-no-auto-cli
57d0: 65 6e 74 2d 73 65 74 75 70 20 63 6f 6e 6e 65 63 ent-setup connec
57e0: 74 69 6f 6e 2d 69 6e 66 6f 20 27 6c 6f 67 69 6e tion-info 'login
57f0: 20 30 20 28 6c 69 73 74 20 2a 74 6f 70 70 61 74 0 (list *toppat
5800: 68 2a 20 6d 65 67 61 74 65 73 74 2d 76 65 72 73 h* megatest-vers
5810: 69 6f 6e 20 2a 6d 79 2d 63 6c 69 65 6e 74 2d 73 ion *my-client-s
5820: 69 67 6e 61 74 75 72 65 2a 29 29 29 0a 20 20 20 ignature*))).
5830: 20 3b 3b 28 28 6e 6d 73 67 29 28 6e 6d 73 67 2d ;;((nmsg)(nmsg-
5840: 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 65 6e 74 transport:client
5850: 2d 61 70 69 2d 73 65 6e 64 2d 72 65 63 65 69 76 -api-send-receiv
5860: 65 20 72 75 6e 2d 69 64 20 63 6f 6e 6e 65 63 74 e run-id connect
5870: 69 6f 6e 2d 69 6e 66 6f 20 27 6c 6f 67 69 6e 20 ion-info 'login
5880: 28 6c 69 73 74 20 2a 74 6f 70 70 61 74 68 2a 20 (list *toppath*
5890: 6d 65 67 61 74 65 73 74 2d 76 65 72 73 69 6f 6e megatest-version
58a0: 20 72 75 6e 2d 69 64 20 2a 6d 79 2d 63 6c 69 65 run-id *my-clie
58b0: 6e 74 2d 73 69 67 6e 61 74 75 72 65 2a 29 29 29 nt-signature*)))
58c0: 0a 20 20 20 20 29 29 0a 0a 3b 3b 20 68 61 6e 64 . ))..;; hand
58d0: 20 6f 66 66 20 61 20 63 61 6c 6c 20 74 6f 20 6f off a call to o
58e0: 6e 65 20 6f 66 20 74 68 65 20 64 62 3a 71 75 65 ne of the db:que
58f0: 72 69 65 73 20 73 74 61 74 65 6d 65 6e 74 73 0a ries statements.
5900: 3b 3b 20 61 64 64 65 64 20 72 75 6e 2d 69 64 20 ;; added run-id
5910: 74 6f 20 6d 61 6b 65 20 6c 6f 6f 6b 69 6e 67 20 to make looking
5920: 75 70 20 74 68 65 20 63 6f 72 72 65 63 74 20 64 up the correct d
5930: 62 20 70 6f 73 73 69 62 6c 65 20 0a 3b 3b 0a 28 b possible .;;.(
5940: 64 65 66 69 6e 65 20 28 6d 72 6d 74 3a 67 65 6e define (mrmt:gen
5950: 65 72 61 6c 2d 63 61 6c 6c 20 73 74 6d 74 6e 61 eral-call stmtna
5960: 6d 65 20 72 75 6e 2d 69 64 20 2e 20 70 61 72 61 me run-id . para
5970: 6d 73 29 0a 20 20 28 6d 72 6d 74 3a 73 65 6e 64 ms). (mrmt:send
5980: 2d 72 65 63 65 69 76 65 20 27 67 65 6e 65 72 61 -receive 'genera
5990: 6c 2d 63 61 6c 6c 20 72 75 6e 2d 69 64 20 28 61 l-call run-id (a
59a0: 70 70 65 6e 64 20 28 6c 69 73 74 20 73 74 6d 74 ppend (list stmt
59b0: 6e 61 6d 65 20 72 75 6e 2d 69 64 29 20 70 61 72 name run-id) par
59c0: 61 6d 73 29 29 29 0a 0a 0a 3b 3b 20 67 69 76 65 ams)))...;; give
59d0: 6e 20 61 20 68 6f 73 74 6e 61 6d 65 2c 20 72 65 n a hostname, re
59e0: 74 75 72 6e 20 61 20 70 61 69 72 20 6f 66 20 63 turn a pair of c
59f0: 70 75 20 6c 6f 61 64 20 61 6e 64 20 75 70 64 61 pu load and upda
5a00: 74 65 20 74 69 6d 65 20 72 65 70 72 65 73 65 6e te time represen
5a10: 74 69 6e 67 20 6c 61 74 65 73 74 20 69 6e 74 65 ting latest inte
5a20: 6c 6c 69 67 65 6e 63 65 20 66 72 6f 6d 20 74 65 lligence from te
5a30: 73 74 73 20 72 75 6e 6e 69 6e 67 20 6f 6e 20 74 sts running on t
5a40: 68 61 74 20 68 6f 73 74 0a 28 64 65 66 69 6e 65 hat host.(define
5a50: 20 28 6d 72 6d 74 3a 67 65 74 2d 6c 61 74 65 73 (mrmt:get-lates
5a60: 74 2d 68 6f 73 74 2d 6c 6f 61 64 20 68 6f 73 74 t-host-load host
5a70: 6e 61 6d 65 29 0a 20 20 28 6d 72 6d 74 3a 73 65 name). (mrmt:se
5a80: 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d nd-receive 'get-
5a90: 6c 61 74 65 73 74 2d 68 6f 73 74 2d 6c 6f 61 64 latest-host-load
5aa0: 20 30 20 28 6c 69 73 74 20 68 6f 73 74 6e 61 6d 0 (list hostnam
5ab0: 65 29 29 29 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 e)))..;; (define
5ac0: 20 28 6d 72 6d 74 3a 73 79 6e 63 2d 69 6e 6d 65 (mrmt:sync-inme
5ad0: 6d 2d 3e 64 62 20 72 75 6e 2d 69 64 29 0a 3b 3b m->db run-id).;;
5ae0: 20 20 20 28 6d 72 6d 74 3a 73 65 6e 64 2d 72 65 (mrmt:send-re
5af0: 63 65 69 76 65 20 27 73 79 6e 63 2d 69 6e 6d 65 ceive 'sync-inme
5b00: 6d 2d 3e 64 62 20 72 75 6e 2d 69 64 20 27 28 29 m->db run-id '()
5b10: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 6d 72 6d ))..(define (mrm
5b20: 74 3a 73 64 62 2d 71 72 79 20 71 72 79 20 76 61 t:sdb-qry qry va
5b30: 6c 20 72 75 6e 2d 69 64 29 0a 20 20 3b 3b 20 61 l run-id). ;; a
5b40: 64 64 20 63 61 63 68 69 6e 67 20 69 66 20 71 72 dd caching if qr
5b50: 79 20 69 73 20 27 67 65 74 69 64 20 6f 72 20 27 y is 'getid or '
5b60: 67 65 74 73 74 72 0a 20 20 28 6d 72 6d 74 3a 73 getstr. (mrmt:s
5b70: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 73 64 62 end-receive 'sdb
5b80: 2d 71 72 79 20 72 75 6e 2d 69 64 20 28 6c 69 73 -qry run-id (lis
5b90: 74 20 71 72 79 20 76 61 6c 29 29 29 0a 0a 3b 3b t qry val)))..;;
5ba0: 20 4e 4f 54 20 43 4f 4d 50 4c 45 54 45 44 0a 28 NOT COMPLETED.(
5bb0: 64 65 66 69 6e 65 20 28 6d 72 6d 74 3a 72 75 6e define (mrmt:run
5bc0: 74 65 73 74 73 20 75 73 65 72 20 72 75 6e 2d 69 tests user run-i
5bd0: 64 20 74 65 73 74 70 61 74 74 20 70 61 72 61 6d d testpatt param
5be0: 73 29 0a 20 20 28 6d 72 6d 74 3a 73 65 6e 64 2d s). (mrmt:send-
5bf0: 72 65 63 65 69 76 65 20 27 72 75 6e 74 65 73 74 receive 'runtest
5c00: 73 20 72 75 6e 2d 69 64 20 74 65 73 74 70 61 74 s run-id testpat
5c10: 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 6d 72 t))..(define (mr
5c20: 6d 74 3a 67 65 74 2d 63 68 61 6e 67 65 64 2d 72 mt:get-changed-r
5c30: 65 63 6f 72 64 2d 69 64 73 20 73 69 6e 63 65 2d ecord-ids since-
5c40: 74 69 6d 65 29 0a 20 20 28 6d 72 6d 74 3a 73 65 time). (mrmt:se
5c50: 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d nd-receive 'get-
5c60: 63 68 61 6e 67 65 64 2d 72 65 63 6f 72 64 2d 69 changed-record-i
5c70: 64 73 20 23 66 20 28 6c 69 73 74 20 73 69 6e 63 ds #f (list sinc
5c80: 65 2d 74 69 6d 65 29 29 20 29 0a 0a 3b 3b 3d 3d e-time)) )..;;==
5c90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5ca0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5cb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5cc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5cd0: 3d 3d 3d 3d 0a 3b 3b 20 20 54 20 45 20 53 20 54 ====.;; T E S T
5ce0: 20 20 20 4d 20 45 20 54 20 41 20 0a 3b 3b 3d 3d M E T A .;;==
5cf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5d00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5d10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5d20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5d30: 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 6d ====..(define (m
5d40: 72 6d 74 3a 67 65 74 2d 74 65 73 74 73 2d 74 61 rmt:get-tests-ta
5d50: 67 73 29 0a 20 20 28 6d 72 6d 74 3a 73 65 6e 64 gs). (mrmt:send
5d60: 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 74 65 -receive 'get-te
5d70: 73 74 73 2d 74 61 67 73 20 23 66 20 27 28 29 29 sts-tags #f '())
5d80: 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )..;;===========
5d90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5da0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5db0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5dc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 ===========.;;
5dd0: 4b 20 45 20 59 20 53 20 0a 3b 3b 3d 3d 3d 3d 3d K E Y S .;;=====
5de0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5df0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5e00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5e10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5e20: 3d 0a 0a 3b 3b 20 54 68 65 73 65 20 72 65 71 75 =..;; These requ
5e30: 69 72 65 20 72 75 6e 2d 69 64 20 62 65 63 61 75 ire run-id becau
5e40: 73 65 20 74 68 65 20 76 61 6c 75 65 73 20 63 6f se the values co
5e50: 6d 65 20 66 72 6f 6d 20 74 68 65 20 72 75 6e 21 me from the run!
5e60: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 6d 72 6d .;;.(define (mrm
5e70: 74 3a 67 65 74 2d 6b 65 79 2d 76 61 6c 2d 70 61 t:get-key-val-pa
5e80: 69 72 73 20 72 75 6e 2d 69 64 29 0a 20 20 28 6d irs run-id). (m
5e90: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
5ea0: 20 27 67 65 74 2d 6b 65 79 2d 76 61 6c 2d 70 61 'get-key-val-pa
5eb0: 69 72 73 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 irs run-id (list
5ec0: 20 72 75 6e 2d 69 64 29 29 29 0a 0a 28 64 65 66 run-id)))..(def
5ed0: 69 6e 65 20 28 6d 72 6d 74 3a 67 65 74 2d 6b 65 ine (mrmt:get-ke
5ee0: 79 73 29 0a 20 20 3b 3b 20 28 69 66 20 2a 64 62 ys). ;; (if *db
5ef0: 2d 6b 65 79 73 2a 20 2a 64 62 2d 6b 65 79 73 2a -keys* *db-keys*
5f00: 20 0a 20 20 28 6c 65 74 20 28 28 72 65 73 20 28 . (let ((res (
5f10: 6d 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 mrmt:send-receiv
5f20: 65 20 27 67 65 74 2d 6b 65 79 73 20 23 66 20 27 e 'get-keys #f '
5f30: 28 29 29 29 29 0a 20 20 20 20 3b 3b 20 28 73 65 ()))). ;; (se
5f40: 74 21 20 2a 64 62 2d 6b 65 79 73 2a 20 72 65 73 t! *db-keys* res
5f50: 29 0a 20 20 20 20 72 65 73 29 29 20 3b 3b 20 29 ). res)) ;; )
5f60: 0a 0a 28 64 65 66 69 6e 65 20 28 6d 72 6d 74 3a ..(define (mrmt:
5f70: 67 65 74 2d 6b 65 79 73 2d 77 72 69 74 65 29 20 get-keys-write)
5f80: 3b 3b 20 64 75 6d 6d 79 20 71 75 65 72 79 20 74 ;; dummy query t
5f90: 6f 20 66 6f 72 63 65 20 73 65 72 76 65 72 20 73 o force server s
5fa0: 74 61 72 74 0a 20 20 28 6c 65 74 20 28 28 72 65 tart. (let ((re
5fb0: 73 20 28 6d 72 6d 74 3a 73 65 6e 64 2d 72 65 63 s (mrmt:send-rec
5fc0: 65 69 76 65 20 27 67 65 74 2d 6b 65 79 73 2d 77 eive 'get-keys-w
5fd0: 72 69 74 65 20 23 66 20 27 28 29 29 29 29 0a 20 rite #f '()))).
5fe0: 20 20 20 3b 3b 20 28 73 65 74 21 20 2a 64 62 2d ;; (set! *db-
5ff0: 6b 65 79 73 2a 20 72 65 73 29 0a 20 20 20 20 72 keys* res). r
6000: 65 73 29 29 0a 0a 3b 3b 20 77 65 20 64 6f 6e 27 es))..;; we don'
6010: 74 20 72 65 75 73 65 20 72 75 6e 2d 69 64 27 73 t reuse run-id's
6020: 20 28 65 78 63 65 70 74 20 70 6f 73 73 69 62 6c (except possibl
6030: 79 20 2a 61 66 74 65 72 2a 20 61 20 64 62 20 63 y *after* a db c
6040: 6c 65 61 6e 75 70 29 20 73 6f 20 69 74 20 69 73 leanup) so it is
6050: 20 73 61 66 65 0a 3b 3b 20 74 6f 20 63 61 63 68 safe.;; to cach
6060: 65 20 74 68 65 20 72 65 73 75 6c 73 20 69 6e 20 e the resuls in
6070: 61 20 68 61 73 68 0a 3b 3b 0a 28 64 65 66 69 6e a hash.;;.(defin
6080: 65 20 28 6d 72 6d 74 3a 67 65 74 2d 6b 65 79 2d e (mrmt:get-key-
6090: 76 61 6c 73 20 72 75 6e 2d 69 64 29 0a 20 20 28 vals run-id). (
60a0: 6f 72 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 or (hash-table-r
60b0: 65 66 2f 64 65 66 61 75 6c 74 20 2a 6b 65 79 76 ef/default *keyv
60c0: 61 6c 73 2a 20 72 75 6e 2d 69 64 20 23 66 29 0a als* run-id #f).
60d0: 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 (let ((res
60e0: 20 28 6d 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (mrmt:send-rece
60f0: 69 76 65 20 27 67 65 74 2d 6b 65 79 2d 76 61 6c ive 'get-key-val
6100: 73 20 23 66 20 28 6c 69 73 74 20 72 75 6e 2d 69 s #f (list run-i
6110: 64 29 29 29 29 0a 20 20 20 20 20 20 20 20 28 68 d)))). (h
6120: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a ash-table-set! *
6130: 6b 65 79 76 61 6c 73 2a 20 72 75 6e 2d 69 64 20 keyvals* run-id
6140: 72 65 73 29 0a 20 20 20 20 20 20 20 20 72 65 73 res). res
6150: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 6d 72 )))..(define (mr
6160: 6d 74 3a 67 65 74 2d 74 61 72 67 65 74 73 29 0a mt:get-targets).
6170: 20 20 28 6d 72 6d 74 3a 73 65 6e 64 2d 72 65 63 (mrmt:send-rec
6180: 65 69 76 65 20 27 67 65 74 2d 74 61 72 67 65 74 eive 'get-target
6190: 73 20 23 66 20 27 28 29 29 29 0a 0a 28 64 65 66 s #f '()))..(def
61a0: 69 6e 65 20 28 6d 72 6d 74 3a 67 65 74 2d 74 61 ine (mrmt:get-ta
61b0: 72 67 65 74 20 72 75 6e 2d 69 64 29 0a 20 20 28 rget run-id). (
61c0: 6d 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 mrmt:send-receiv
61d0: 65 20 27 67 65 74 2d 74 61 72 67 65 74 20 72 75 e 'get-target ru
61e0: 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 n-id (list run-i
61f0: 64 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d d)))..;;========
6200: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6210: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6220: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6230: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
6240: 3b 20 20 54 20 45 20 53 20 54 20 53 0a 3b 3b 3d ; T E S T S.;;=
6250: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6260: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6270: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6280: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6290: 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 4a 75 73 74 20 73 =====..;; Just s
62a0: 6f 6d 65 20 73 79 6e 74 61 74 69 63 20 73 75 67 ome syntatic sug
62b0: 61 72 0a 28 64 65 66 69 6e 65 20 28 6d 72 6d 74 ar.(define (mrmt
62c0: 3a 72 65 67 69 73 74 65 72 2d 74 65 73 74 20 72 :register-test r
62d0: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 un-id test-name
62e0: 69 74 65 6d 2d 70 61 74 68 29 0a 20 20 28 6d 72 item-path). (mr
62f0: 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 mt:general-call
6300: 27 72 65 67 69 73 74 65 72 2d 74 65 73 74 20 72 'register-test r
6310: 75 6e 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 un-id run-id tes
6320: 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 t-name item-path
6330: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 6d 72 6d ))..(define (mrm
6340: 74 3a 67 65 74 2d 74 65 73 74 2d 69 64 20 72 75 t:get-test-id ru
6350: 6e 2d 69 64 20 74 65 73 74 6e 61 6d 65 20 69 74 n-id testname it
6360: 65 6d 2d 70 61 74 68 29 0a 20 20 28 6d 72 6d 74 em-path). (mrmt
6370: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 :send-receive 'g
6380: 65 74 2d 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 et-test-id run-i
6390: 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 d (list run-id t
63a0: 65 73 74 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 estname item-pat
63b0: 68 29 29 29 0a 0a 3b 3b 20 72 75 6e 2d 69 64 20 h)))..;; run-id
63c0: 69 73 20 4e 4f 54 20 75 73 65 64 0a 3b 3b 0a 28 is NOT used.;;.(
63d0: 64 65 66 69 6e 65 20 28 6d 72 6d 74 3a 67 65 74 define (mrmt:get
63e0: 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 -test-info-by-id
63f0: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 run-id test-id)
6400: 0a 20 20 28 69 66 20 28 6e 75 6d 62 65 72 3f 20 . (if (number?
6410: 74 65 73 74 2d 69 64 29 0a 20 20 20 20 20 20 28 test-id). (
6420: 6d 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 mrmt:send-receiv
6430: 65 20 27 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f e 'get-test-info
6440: 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 28 6c -by-id run-id (l
6450: 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d ist run-id test-
6460: 69 64 29 29 0a 20 20 20 20 20 20 28 62 65 67 69 id)). (begi
6470: 6e 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 n..(debug:print
6480: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
6490: 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 42 ort* "WARNING: B
64a0: 61 64 20 64 61 74 61 20 68 61 6e 64 65 64 20 74 ad data handed t
64b0: 6f 20 6d 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d o mrmt:get-test-
64c0: 69 6e 66 6f 2d 62 79 2d 69 64 20 72 75 6e 2d 69 info-by-id run-i
64d0: 64 3d 22 20 72 75 6e 2d 69 64 20 22 2c 20 74 65 d=" run-id ", te
64e0: 73 74 2d 69 64 3d 22 20 74 65 73 74 2d 69 64 29 st-id=" test-id)
64f0: 0a 09 28 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 ..(print-call-ch
6500: 61 69 6e 20 28 63 75 72 72 65 6e 74 2d 65 72 72 ain (current-err
6510: 6f 72 2d 70 6f 72 74 29 29 0a 09 23 66 29 29 29 or-port))..#f)))
6520: 0a 0a 28 64 65 66 69 6e 65 20 28 6d 72 6d 74 3a ..(define (mrmt:
6530: 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 2d test-get-rundir-
6540: 66 72 6f 6d 2d 74 65 73 74 2d 69 64 20 72 75 6e from-test-id run
6550: 2d 69 64 20 74 65 73 74 2d 69 64 29 0a 20 20 28 -id test-id). (
6560: 6d 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 mrmt:send-receiv
6570: 65 20 27 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 e 'test-get-rund
6580: 69 72 2d 66 72 6f 6d 2d 74 65 73 74 2d 69 64 20 ir-from-test-id
6590: 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e run-id (list run
65a0: 2d 69 64 20 74 65 73 74 2d 69 64 29 29 29 0a 0a -id test-id)))..
65b0: 28 64 65 66 69 6e 65 20 28 6d 72 6d 74 3a 6f 70 (define (mrmt:op
65c0: 65 6e 2d 74 65 73 74 2d 64 62 2d 62 79 2d 74 65 en-test-db-by-te
65d0: 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 st-id run-id tes
65e0: 74 2d 69 64 20 23 21 6b 65 79 20 28 77 6f 72 6b t-id #!key (work
65f0: 2d 61 72 65 61 20 23 66 29 29 0a 20 20 28 6c 65 -area #f)). (le
6600: 74 2a 20 28 28 74 65 73 74 2d 70 61 74 68 20 28 t* ((test-path (
6610: 69 66 20 28 73 74 72 69 6e 67 3f 20 77 6f 72 6b if (string? work
6620: 2d 61 72 65 61 29 0a 09 09 09 77 6f 72 6b 2d 61 -area)....work-a
6630: 72 65 61 0a 09 09 09 28 6d 72 6d 74 3a 74 65 73 rea....(mrmt:tes
6640: 74 2d 67 65 74 2d 72 75 6e 64 69 72 2d 66 72 6f t-get-rundir-fro
6650: 6d 2d 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 m-test-id run-id
6660: 20 74 65 73 74 2d 69 64 29 29 29 29 0a 20 20 20 test-id)))).
6670: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 33 20 (debug:print 3
6680: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
6690: 74 2a 20 22 54 45 53 54 20 50 41 54 48 3a 20 22 t* "TEST PATH: "
66a0: 20 74 65 73 74 2d 70 61 74 68 29 0a 20 20 20 20 test-path).
66b0: 28 6f 70 65 6e 2d 74 65 73 74 2d 64 62 20 74 65 (open-test-db te
66c0: 73 74 2d 70 61 74 68 29 29 29 0a 0a 3b 3b 20 57 st-path)))..;; W
66d0: 41 52 4e 49 4e 47 3a 20 54 68 69 73 20 63 75 72 ARNING: This cur
66e0: 72 65 6e 74 6c 79 20 62 79 70 61 73 73 65 73 20 rently bypasses
66f0: 74 68 65 20 74 72 61 6e 73 61 63 74 69 6f 6e 20 the transaction
6700: 77 72 61 70 70 65 64 20 77 72 69 74 65 73 20 73 wrapped writes s
6710: 79 73 74 65 6d 0a 28 64 65 66 69 6e 65 20 28 6d ystem.(define (m
6720: 72 6d 74 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 rmt:test-set-sta
6730: 74 65 2d 73 74 61 74 75 73 2d 62 79 2d 69 64 20 te-status-by-id
6740: 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 6e run-id test-id n
6750: 65 77 73 74 61 74 65 20 6e 65 77 73 74 61 74 75 ewstate newstatu
6760: 73 20 6e 65 77 63 6f 6d 6d 65 6e 74 29 0a 20 20 s newcomment).
6770: 28 6d 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (mrmt:send-recei
6780: 76 65 20 27 74 65 73 74 2d 73 65 74 2d 73 74 61 ve 'test-set-sta
6790: 74 65 2d 73 74 61 74 75 73 2d 62 79 2d 69 64 20 te-status-by-id
67a0: 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e run-id (list run
67b0: 2d 69 64 20 74 65 73 74 2d 69 64 20 6e 65 77 73 -id test-id news
67c0: 74 61 74 65 20 6e 65 77 73 74 61 74 75 73 20 6e tate newstatus n
67d0: 65 77 63 6f 6d 6d 65 6e 74 29 29 29 0a 0a 28 64 ewcomment)))..(d
67e0: 65 66 69 6e 65 20 28 6d 72 6d 74 3a 73 65 74 2d efine (mrmt:set-
67f0: 74 65 73 74 73 2d 73 74 61 74 65 2d 73 74 61 74 tests-state-stat
6800: 75 73 20 72 75 6e 2d 69 64 20 20 20 20 20 20 20 us run-id
6810: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 74 t
6820: 65 73 74 6e 61 6d 65 73 20 63 75 72 72 73 74 61 estnames currsta
6830: 74 65 20 63 75 72 72 73 74 61 74 75 73 20 6e 65 te currstatus ne
6840: 77 73 74 61 74 65 20 6e 65 77 73 74 61 74 75 73 wstate newstatus
6850: 29 0a 20 20 28 6d 72 6d 74 3a 73 65 6e 64 2d 72 ). (mrmt:send-r
6860: 65 63 65 69 76 65 20 27 73 65 74 2d 74 65 73 74 eceive 'set-test
6870: 73 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 72 s-state-status r
6880: 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d un-id (list run-
6890: 69 64 20 74 65 73 74 6e 61 6d 65 73 20 63 75 72 id testnames cur
68a0: 72 73 74 61 74 65 20 63 75 72 72 73 74 61 74 75 rstate currstatu
68b0: 73 20 6e 65 77 73 74 61 74 65 20 6e 65 77 73 74 s newstate newst
68c0: 61 74 75 73 29 29 29 0a 0a 28 64 65 66 69 6e 65 atus)))..(define
68d0: 20 28 6d 72 6d 74 3a 67 65 74 2d 74 65 73 74 73 (mrmt:get-tests
68e0: 2d 66 6f 72 2d 72 75 6e 20 72 75 6e 2d 69 64 20 -for-run run-id
68f0: 74 65 73 74 70 61 74 74 20 73 74 61 74 65 73 20 testpatt states
6900: 73 74 61 74 75 73 65 73 20 6f 66 66 73 65 74 20 statuses offset
6910: 6c 69 6d 69 74 20 6e 6f 74 2d 69 6e 20 73 6f 72 limit not-in sor
6920: 74 2d 62 79 20 73 6f 72 74 2d 6f 72 64 65 72 20 t-by sort-order
6930: 71 72 79 76 61 6c 73 20 6c 61 73 74 2d 75 70 64 qryvals last-upd
6940: 61 74 65 20 6d 6f 64 65 29 0a 20 20 3b 3b 20 28 ate mode). ;; (
6950: 69 66 20 28 6e 75 6d 62 65 72 3f 20 72 75 6e 2d if (number? run-
6960: 69 64 29 0a 20 20 28 6d 72 6d 74 3a 73 65 6e 64 id). (mrmt:send
6970: 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 74 65 -receive 'get-te
6980: 73 74 73 2d 66 6f 72 2d 72 75 6e 20 72 75 6e 2d sts-for-run run-
6990: 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 id (list run-id
69a0: 74 65 73 74 70 61 74 74 20 73 74 61 74 65 73 20 testpatt states
69b0: 73 74 61 74 75 73 65 73 20 6f 66 66 73 65 74 20 statuses offset
69c0: 6c 69 6d 69 74 20 6e 6f 74 2d 69 6e 20 73 6f 72 limit not-in sor
69d0: 74 2d 62 79 20 73 6f 72 74 2d 6f 72 64 65 72 20 t-by sort-order
69e0: 71 72 79 76 61 6c 73 20 6c 61 73 74 2d 75 70 64 qryvals last-upd
69f0: 61 74 65 20 6d 6f 64 65 29 29 29 0a 20 20 3b 3b ate mode))). ;;
6a00: 20 20 20 20 28 62 65 67 69 6e 0a 20 20 3b 3b 09 (begin. ;;.
6a10: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 (debug:print-err
6a20: 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f or 0 *default-lo
6a30: 67 2d 70 6f 72 74 2a 20 22 6d 72 6d 74 3a 67 65 g-port* "mrmt:ge
6a40: 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 t-tests-for-run
6a50: 63 61 6c 6c 65 64 20 77 69 74 68 20 62 61 64 20 called with bad
6a60: 72 75 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 64 29 run-id=" run-id)
6a70: 0a 20 20 3b 3b 09 28 70 72 69 6e 74 2d 63 61 6c . ;;.(print-cal
6a80: 6c 2d 63 68 61 69 6e 20 28 63 75 72 72 65 6e 74 l-chain (current
6a90: 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 0a 20 20 -error-port)).
6aa0: 3b 3b 09 27 28 29 29 29 29 0a 0a 3b 3b 20 67 65 ;;.'())))..;; ge
6ab0: 74 20 73 74 75 66 66 20 76 69 61 20 73 79 6e 63 t stuff via sync
6ac0: 68 61 73 68 20 0a 28 64 65 66 69 6e 65 20 28 6d hash .(define (m
6ad0: 72 6d 74 3a 73 79 6e 63 68 61 73 68 2d 67 65 74 rmt:synchash-get
6ae0: 20 72 75 6e 2d 69 64 20 70 72 6f 63 20 73 79 6e run-id proc syn
6af0: 63 6b 65 79 20 6b 65 79 6e 75 6d 20 70 61 72 61 ckey keynum para
6b00: 6d 73 29 0a 20 20 28 6d 72 6d 74 3a 73 65 6e 64 ms). (mrmt:send
6b10: 2d 72 65 63 65 69 76 65 20 27 73 79 6e 63 68 61 -receive 'syncha
6b20: 73 68 2d 67 65 74 20 72 75 6e 2d 69 64 20 28 6c sh-get run-id (l
6b30: 69 73 74 20 72 75 6e 2d 69 64 20 70 72 6f 63 20 ist run-id proc
6b40: 73 79 6e 63 6b 65 79 20 6b 65 79 6e 75 6d 20 70 synckey keynum p
6b50: 61 72 61 6d 73 29 29 29 0a 0a 3b 3b 20 49 44 45 arams)))..;; IDE
6b60: 41 3a 20 54 68 72 65 61 64 69 66 79 20 74 68 65 A: Threadify the
6b70: 73 65 20 2d 20 74 68 65 79 20 73 70 65 6e 64 20 se - they spend
6b80: 61 20 6c 6f 74 20 6f 66 20 74 69 6d 65 20 77 61 a lot of time wa
6b90: 69 74 69 6e 67 20 2e 2e 2e 0a 3b 3b 0a 28 64 65 iting ....;;.(de
6ba0: 66 69 6e 65 20 28 6d 72 6d 74 3a 67 65 74 2d 74 fine (mrmt:get-t
6bb0: 65 73 74 73 2d 66 6f 72 2d 72 75 6e 73 2d 6d 69 ests-for-runs-mi
6bc0: 6e 64 61 74 61 20 72 75 6e 2d 69 64 73 20 74 65 ndata run-ids te
6bd0: 73 74 70 61 74 74 20 73 74 61 74 65 73 20 73 74 stpatt states st
6be0: 61 74 75 73 20 6e 6f 74 2d 69 6e 29 0a 20 20 28 atus not-in). (
6bf0: 6c 65 74 20 28 28 6d 75 6c 74 69 2d 72 75 6e 2d let ((multi-run-
6c00: 6d 75 74 65 78 20 28 6d 61 6b 65 2d 6d 75 74 65 mutex (make-mute
6c10: 78 29 29 0a 09 28 72 75 6e 2d 69 64 2d 6c 69 73 x))..(run-id-lis
6c20: 74 20 28 69 66 20 72 75 6e 2d 69 64 73 0a 09 09 t (if run-ids...
6c30: 09 20 72 75 6e 2d 69 64 73 0a 09 09 09 20 28 6d . run-ids.... (m
6c40: 72 6d 74 3a 67 65 74 2d 61 6c 6c 2d 72 75 6e 2d rmt:get-all-run-
6c50: 69 64 73 29 29 29 0a 09 28 72 65 73 75 6c 74 20 ids)))..(result
6c60: 20 20 20 20 20 27 28 29 29 29 0a 20 20 20 20 28 '())). (
6c70: 69 66 20 28 6e 75 6c 6c 3f 20 72 75 6e 2d 69 64 if (null? run-id
6c80: 2d 6c 69 73 74 29 0a 09 27 28 29 0a 09 28 6c 65 -list)..'()..(le
6c90: 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 20 20 20 t loop ((hed
6ca0: 20 28 63 61 72 20 72 75 6e 2d 69 64 2d 6c 69 73 (car run-id-lis
6cb0: 74 29 29 0a 09 09 20 20 20 28 74 61 6c 20 20 20 t))... (tal
6cc0: 20 20 28 63 64 72 20 72 75 6e 2d 69 64 2d 6c 69 (cdr run-id-li
6cd0: 73 74 29 29 0a 09 09 20 20 20 28 74 68 72 65 61 st))... (threa
6ce0: 64 73 20 27 28 29 29 29 0a 09 20 20 28 69 66 20 ds '())).. (if
6cf0: 28 3e 20 28 6c 65 6e 67 74 68 20 74 68 72 65 61 (> (length threa
6d00: 64 73 29 20 35 29 0a 09 20 20 20 20 20 20 28 6c ds) 5).. (l
6d10: 6f 6f 70 20 68 65 64 20 74 61 6c 20 28 66 69 6c oop hed tal (fil
6d20: 74 65 72 20 28 6c 61 6d 62 64 61 20 28 74 68 29 ter (lambda (th)
6d30: 28 6e 6f 74 20 28 6d 65 6d 62 65 72 20 28 74 68 (not (member (th
6d40: 72 65 61 64 2d 73 74 61 74 65 20 74 68 29 20 27 read-state th) '
6d50: 28 74 65 72 6d 69 6e 61 74 65 64 20 64 65 61 64 (terminated dead
6d60: 29 29 29 29 20 74 68 72 65 61 64 73 29 29 0a 09 )))) threads))..
6d70: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 6e 65 (let* ((ne
6d80: 77 74 68 72 65 61 64 20 28 6d 61 6b 65 2d 74 68 wthread (make-th
6d90: 72 65 61 64 0a 09 09 09 09 20 28 6c 61 6d 62 64 read..... (lambd
6da0: 61 20 28 29 0a 09 09 09 09 20 20 20 28 6c 65 74 a ()..... (let
6db0: 20 28 28 72 65 73 20 28 6d 72 6d 74 3a 73 65 6e ((res (mrmt:sen
6dc0: 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 74 d-receive 'get-t
6dd0: 65 73 74 73 2d 66 6f 72 2d 72 75 6e 2d 6d 69 6e ests-for-run-min
6de0: 64 61 74 61 20 68 65 64 20 28 6c 69 73 74 20 68 data hed (list h
6df0: 65 64 20 74 65 73 74 70 61 74 74 20 73 74 61 74 ed testpatt stat
6e00: 65 73 20 73 74 61 74 75 73 20 6e 6f 74 2d 69 6e es status not-in
6e10: 29 29 29 29 0a 09 09 09 09 20 20 20 20 20 28 69 ))))..... (i
6e20: 66 20 28 6c 69 73 74 3f 20 72 65 73 29 0a 09 09 f (list? res)...
6e30: 09 09 09 20 28 62 65 67 69 6e 0a 09 09 09 09 09 ... (begin......
6e40: 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 (mutex-lock!
6e50: 6d 75 6c 74 69 2d 72 75 6e 2d 6d 75 74 65 78 29 multi-run-mutex)
6e60: 0a 09 09 09 09 09 20 20 20 28 73 65 74 21 20 72 ...... (set! r
6e70: 65 73 75 6c 74 20 28 61 70 70 65 6e 64 20 72 65 esult (append re
6e80: 73 75 6c 74 20 72 65 73 29 29 0a 09 09 09 09 09 sult res))......
6e90: 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b (mutex-unlock
6ea0: 21 20 6d 75 6c 74 69 2d 72 75 6e 2d 6d 75 74 65 ! multi-run-mute
6eb0: 78 29 29 0a 09 09 09 09 09 20 28 64 65 62 75 67 x))...... (debug
6ec0: 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a :print-error 0 *
6ed0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
6ee0: 2a 20 22 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 * "get-tests-for
6ef0: 2d 72 75 6e 2d 6d 69 6e 64 61 74 61 20 66 61 69 -run-mindata fai
6f00: 6c 65 64 20 66 6f 72 20 72 75 6e 2d 69 64 20 22 led for run-id "
6f10: 20 68 65 64 20 22 2c 20 74 65 73 74 70 61 74 74 hed ", testpatt
6f20: 20 22 20 74 65 73 74 70 61 74 74 20 22 2c 20 73 " testpatt ", s
6f30: 74 61 74 65 73 20 22 20 73 74 61 74 65 73 20 22 tates " states "
6f40: 2c 20 73 74 61 74 75 73 20 22 20 73 74 61 74 75 , status " statu
6f50: 73 20 22 2c 20 6e 6f 74 2d 69 6e 20 22 20 6e 6f s ", not-in " no
6f60: 74 2d 69 6e 29 29 29 29 0a 09 09 09 09 20 28 63 t-in))))..... (c
6f70: 6f 6e 63 20 22 6d 75 6c 74 69 2d 72 75 6e 2d 74 onc "multi-run-t
6f80: 68 72 65 61 64 20 66 6f 72 20 72 75 6e 2d 69 64 hread for run-id
6f90: 20 22 20 68 65 64 29 29 29 0a 09 09 20 20 20 20 " hed)))...
6fa0: 20 28 6e 65 77 74 68 72 65 61 64 73 20 28 63 6f (newthreads (co
6fb0: 6e 73 20 6e 65 77 74 68 72 65 61 64 20 74 68 72 ns newthread thr
6fc0: 65 61 64 73 29 29 29 0a 09 09 28 74 68 72 65 61 eads)))...(threa
6fd0: 64 2d 73 74 61 72 74 21 20 6e 65 77 74 68 72 65 d-start! newthre
6fe0: 61 64 29 0a 09 09 28 74 68 72 65 61 64 2d 73 6c ad)...(thread-sl
6ff0: 65 65 70 21 20 30 2e 30 35 29 20 3b 3b 20 67 69 eep! 0.05) ;; gi
7000: 76 65 20 74 68 61 74 20 74 68 72 65 61 64 20 73 ve that thread s
7010: 6f 6d 65 20 74 69 6d 65 20 74 6f 20 73 74 61 72 ome time to star
7020: 74 0a 09 09 28 69 66 20 28 6e 75 6c 6c 3f 20 74 t...(if (null? t
7030: 61 6c 29 0a 09 09 20 20 20 20 6e 65 77 74 68 72 al)... newthr
7040: 65 61 64 73 0a 09 09 20 20 20 20 28 6c 6f 6f 70 eads... (loop
7050: 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 (car tal)(cdr t
7060: 61 6c 29 20 6e 65 77 74 68 72 65 61 64 73 29 29 al) newthreads))
7070: 29 29 29 29 0a 20 20 20 20 72 65 73 75 6c 74 29 )))). result)
7080: 29 0a 0a 3b 3b 20 3b 3b 20 49 44 45 41 3a 20 54 )..;; ;; IDEA: T
7090: 68 72 65 61 64 69 66 79 20 74 68 65 73 65 20 2d hreadify these -
70a0: 20 74 68 65 79 20 73 70 65 6e 64 20 61 20 6c 6f they spend a lo
70b0: 74 20 6f 66 20 74 69 6d 65 20 77 61 69 74 69 6e t of time waitin
70c0: 67 20 2e 2e 2e 0a 3b 3b 20 3b 3b 0a 3b 3b 20 28 g ....;; ;;.;; (
70d0: 64 65 66 69 6e 65 20 28 6d 72 6d 74 3a 67 65 74 define (mrmt:get
70e0: 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 73 2d -tests-for-runs-
70f0: 6d 69 6e 64 61 74 61 20 72 75 6e 2d 69 64 73 20 mindata run-ids
7100: 74 65 73 74 70 61 74 74 20 73 74 61 74 65 73 20 testpatt states
7110: 73 74 61 74 75 73 20 6e 6f 74 2d 69 6e 29 0a 3b status not-in).;
7120: 3b 20 20 20 28 6c 65 74 20 28 28 72 75 6e 2d 69 ; (let ((run-i
7130: 64 2d 6c 69 73 74 20 28 69 66 20 72 75 6e 2d 69 d-list (if run-i
7140: 64 73 0a 3b 3b 20 09 09 09 20 72 75 6e 2d 69 64 ds.;; ... run-id
7150: 73 0a 3b 3b 20 09 09 09 20 28 6d 72 6d 74 3a 67 s.;; ... (mrmt:g
7160: 65 74 2d 61 6c 6c 2d 72 75 6e 2d 69 64 73 29 29 et-all-run-ids))
7170: 29 29 0a 3b 3b 20 20 20 20 20 28 61 70 70 6c 79 )).;; (apply
7180: 20 61 70 70 65 6e 64 20 28 6d 61 70 20 28 6c 61 append (map (la
7190: 6d 62 64 61 20 28 72 75 6e 2d 69 64 29 0a 3b 3b mbda (run-id).;;
71a0: 20 09 09 09 20 28 6d 72 6d 74 3a 73 65 6e 64 2d ... (mrmt:send-
71b0: 72 65 63 65 69 76 65 20 27 67 65 74 2d 74 65 73 receive 'get-tes
71c0: 74 73 2d 66 6f 72 2d 72 75 6e 2d 6d 69 6e 64 61 ts-for-run-minda
71d0: 74 61 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 ta run-id (list
71e0: 72 75 6e 2d 69 64 73 20 74 65 73 74 70 61 74 74 run-ids testpatt
71f0: 20 73 74 61 74 65 73 20 73 74 61 74 75 73 20 6e states status n
7200: 6f 74 2d 69 6e 29 29 29 0a 3b 3b 20 09 09 20 20 ot-in))).;; ..
7210: 20 20 20 20 20 72 75 6e 2d 69 64 2d 6c 69 73 74 run-id-list
7220: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 6d ))))..(define (m
7230: 72 6d 74 3a 64 65 6c 65 74 65 2d 74 65 73 74 2d rmt:delete-test-
7240: 72 65 63 6f 72 64 73 20 72 75 6e 2d 69 64 20 74 records run-id t
7250: 65 73 74 2d 69 64 29 0a 20 20 28 6d 72 6d 74 3a est-id). (mrmt:
7260: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 64 65 send-receive 'de
7270: 6c 65 74 65 2d 74 65 73 74 2d 72 65 63 6f 72 64 lete-test-record
7280: 73 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 s run-id (list r
7290: 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 29 29 un-id test-id)))
72a0: 0a 0a 3b 3b 20 54 68 69 73 20 69 73 20 6e 6f 74 ..;; This is not
72b0: 20 6e 65 65 64 65 64 20 61 73 20 74 65 73 74 20 needed as test
72c0: 73 74 65 70 73 20 61 72 65 20 64 65 6c 65 74 65 steps are delete
72d0: 64 20 6f 6e 20 74 65 73 74 20 64 65 6c 65 74 65 d on test delete
72e0: 20 63 61 6c 6c 0a 3b 3b 0a 3b 3b 20 28 64 65 66 call.;;.;; (def
72f0: 69 6e 65 20 28 6d 72 6d 74 3a 64 65 6c 65 74 65 ine (mrmt:delete
7300: 2d 74 65 73 74 2d 73 74 65 70 2d 72 65 63 6f 72 -test-step-recor
7310: 64 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 ds run-id test-i
7320: 64 29 0a 3b 3b 20 20 20 28 6d 72 6d 74 3a 73 65 d).;; (mrmt:se
7330: 6e 64 2d 72 65 63 65 69 76 65 20 27 64 65 6c 65 nd-receive 'dele
7340: 74 65 2d 74 65 73 74 2d 73 74 65 70 2d 72 65 63 te-test-step-rec
7350: 6f 72 64 73 20 72 75 6e 2d 69 64 20 28 6c 69 73 ords run-id (lis
7360: 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 t run-id test-id
7370: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 6d 72 )))..(define (mr
7380: 6d 74 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 mt:test-set-stat
7390: 65 2d 73 74 61 74 75 73 20 72 75 6e 2d 69 64 20 e-status run-id
73a0: 74 65 73 74 2d 69 64 20 73 74 61 74 65 20 73 74 test-id state st
73b0: 61 74 75 73 20 6d 73 67 29 0a 20 20 28 6d 72 6d atus msg). (mrm
73c0: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
73d0: 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 test-set-state-s
73e0: 74 61 74 75 73 20 72 75 6e 2d 69 64 20 28 6c 69 tatus run-id (li
73f0: 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 st run-id test-i
7400: 64 20 73 74 61 74 65 20 73 74 61 74 75 73 20 6d d state status m
7410: 73 67 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 sg)))..(define (
7420: 6d 72 6d 74 3a 74 65 73 74 2d 74 6f 70 6c 65 76 mrmt:test-toplev
7430: 65 6c 2d 6e 75 6d 2d 69 74 65 6d 73 20 72 75 6e el-num-items run
7440: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 29 0a 20 -id test-name).
7450: 20 28 6d 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (mrmt:send-rece
7460: 69 76 65 20 27 74 65 73 74 2d 74 6f 70 6c 65 76 ive 'test-toplev
7470: 65 6c 2d 6e 75 6d 2d 69 74 65 6d 73 20 72 75 6e el-num-items run
7480: 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 -id (list run-id
7490: 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a 0a 3b test-name)))..;
74a0: 3b 20 28 64 65 66 69 6e 65 20 28 6d 72 6d 74 3a ; (define (mrmt:
74b0: 67 65 74 2d 70 72 65 76 69 6f 75 73 2d 74 65 73 get-previous-tes
74c0: 74 2d 72 75 6e 2d 72 65 63 6f 72 64 20 72 75 6e t-run-record run
74d0: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 -id test-name it
74e0: 65 6d 2d 70 61 74 68 29 0a 3b 3b 20 20 20 28 6d em-path).;; (m
74f0: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
7500: 20 27 67 65 74 2d 70 72 65 76 69 6f 75 73 2d 74 'get-previous-t
7510: 65 73 74 2d 72 75 6e 2d 72 65 63 6f 72 64 20 72 est-run-record r
7520: 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d un-id (list run-
7530: 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 id test-name ite
7540: 6d 2d 70 61 74 68 29 29 29 0a 0a 28 64 65 66 69 m-path)))..(defi
7550: 6e 65 20 28 6d 72 6d 74 3a 67 65 74 2d 6d 61 74 ne (mrmt:get-mat
7560: 63 68 69 6e 67 2d 70 72 65 76 69 6f 75 73 2d 74 ching-previous-t
7570: 65 73 74 2d 72 75 6e 2d 72 65 63 6f 72 64 73 20 est-run-records
7580: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
7590: 20 69 74 65 6d 2d 70 61 74 68 29 0a 20 20 28 6d item-path). (m
75a0: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
75b0: 20 27 67 65 74 2d 6d 61 74 63 68 69 6e 67 2d 70 'get-matching-p
75c0: 72 65 76 69 6f 75 73 2d 74 65 73 74 2d 72 75 6e revious-test-run
75d0: 2d 72 65 63 6f 72 64 73 20 72 75 6e 2d 69 64 20 -records run-id
75e0: 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 (list run-id tes
75f0: 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 t-name item-path
7600: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 6d 72 )))..(define (mr
7610: 6d 74 3a 74 65 73 74 2d 67 65 74 2d 6c 6f 67 66 mt:test-get-logf
7620: 69 6c 65 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 20 ile-info run-id
7630: 74 65 73 74 2d 6e 61 6d 65 29 0a 20 20 28 6d 72 test-name). (mr
7640: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
7650: 27 74 65 73 74 2d 67 65 74 2d 6c 6f 67 66 69 6c 'test-get-logfil
7660: 65 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 20 28 6c e-info run-id (l
7670: 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d ist run-id test-
7680: 6e 61 6d 65 29 29 29 0a 0a 28 64 65 66 69 6e 65 name)))..(define
7690: 20 28 6d 72 6d 74 3a 74 65 73 74 2d 67 65 74 2d (mrmt:test-get-
76a0: 72 65 63 6f 72 64 73 2d 66 6f 72 2d 69 6e 64 65 records-for-inde
76b0: 78 2d 66 69 6c 65 20 72 75 6e 2d 69 64 20 74 65 x-file run-id te
76c0: 73 74 2d 6e 61 6d 65 29 0a 20 20 28 6d 72 6d 74 st-name). (mrmt
76d0: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 74 :send-receive 't
76e0: 65 73 74 2d 67 65 74 2d 72 65 63 6f 72 64 73 2d est-get-records-
76f0: 66 6f 72 2d 69 6e 64 65 78 2d 66 69 6c 65 20 72 for-index-file r
7700: 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d un-id (list run-
7710: 69 64 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a id test-name))).
7720: 0a 28 64 65 66 69 6e 65 20 28 6d 72 6d 74 3a 67 .(define (mrmt:g
7730: 65 74 2d 74 65 73 74 69 6e 66 6f 2d 73 74 61 74 et-testinfo-stat
7740: 65 2d 73 74 61 74 75 73 20 72 75 6e 2d 69 64 20 e-status run-id
7750: 74 65 73 74 2d 69 64 29 0a 20 20 28 6d 72 6d 74 test-id). (mrmt
7760: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 :send-receive 'g
7770: 65 74 2d 74 65 73 74 69 6e 66 6f 2d 73 74 61 74 et-testinfo-stat
7780: 65 2d 73 74 61 74 75 73 20 72 75 6e 2d 69 64 20 e-status run-id
7790: 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 (list run-id tes
77a0: 74 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 t-id)))..(define
77b0: 20 28 6d 72 6d 74 3a 74 65 73 74 2d 73 65 74 2d (mrmt:test-set-
77c0: 6c 6f 67 21 20 72 75 6e 2d 69 64 20 74 65 73 74 log! run-id test
77d0: 2d 69 64 20 6c 6f 67 66 29 0a 20 20 28 69 66 20 -id logf). (if
77e0: 28 73 74 72 69 6e 67 3f 20 6c 6f 67 66 29 28 6d (string? logf)(m
77f0: 72 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 61 6c 6c rmt:general-call
7800: 20 27 74 65 73 74 2d 73 65 74 2d 6c 6f 67 20 72 'test-set-log r
7810: 75 6e 2d 69 64 20 6c 6f 67 66 20 74 65 73 74 2d un-id logf test-
7820: 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 id)))..(define (
7830: 6d 72 6d 74 3a 74 65 73 74 2d 73 65 74 2d 74 6f mrmt:test-set-to
7840: 70 2d 70 72 6f 63 65 73 73 2d 70 69 64 20 72 75 p-process-pid ru
7850: 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 70 69 64 n-id test-id pid
7860: 29 0a 20 20 28 6d 72 6d 74 3a 73 65 6e 64 2d 72 ). (mrmt:send-r
7870: 65 63 65 69 76 65 20 27 74 65 73 74 2d 73 65 74 eceive 'test-set
7880: 2d 74 6f 70 2d 70 72 6f 63 65 73 73 2d 70 69 64 -top-process-pid
7890: 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 run-id (list ru
78a0: 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 70 69 64 n-id test-id pid
78b0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 6d 72 )))..(define (mr
78c0: 6d 74 3a 74 65 73 74 2d 67 65 74 2d 74 6f 70 2d mt:test-get-top-
78d0: 70 72 6f 63 65 73 73 2d 70 69 64 20 72 75 6e 2d process-pid run-
78e0: 69 64 20 74 65 73 74 2d 69 64 29 0a 20 20 28 6d id test-id). (m
78f0: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
7900: 20 27 74 65 73 74 2d 67 65 74 2d 74 6f 70 2d 70 'test-get-top-p
7910: 72 6f 63 65 73 73 2d 70 69 64 20 72 75 6e 2d 69 rocess-pid run-i
7920: 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 d (list run-id t
7930: 65 73 74 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 est-id)))..(defi
7940: 6e 65 20 28 6d 72 6d 74 3a 67 65 74 2d 72 75 6e ne (mrmt:get-run
7950: 2d 69 64 73 2d 6d 61 74 63 68 69 6e 67 2d 74 61 -ids-matching-ta
7960: 72 67 65 74 20 6b 65 79 6e 61 6d 65 73 20 74 61 rget keynames ta
7970: 72 67 65 74 20 72 65 73 20 72 75 6e 6e 61 6d 65 rget res runname
7980: 20 74 65 73 74 70 61 74 74 20 73 74 61 74 65 70 testpatt statep
7990: 61 74 74 20 73 74 61 74 75 73 70 61 74 74 29 0a att statuspatt).
79a0: 20 20 28 6d 72 6d 74 3a 73 65 6e 64 2d 72 65 63 (mrmt:send-rec
79b0: 65 69 76 65 20 27 67 65 74 2d 72 75 6e 2d 69 64 eive 'get-run-id
79c0: 73 2d 6d 61 74 63 68 69 6e 67 2d 74 61 72 67 65 s-matching-targe
79d0: 74 20 23 66 20 28 6c 69 73 74 20 6b 65 79 6e 61 t #f (list keyna
79e0: 6d 65 73 20 74 61 72 67 65 74 20 72 65 73 20 72 mes target res r
79f0: 75 6e 6e 61 6d 65 20 74 65 73 74 70 61 74 74 20 unname testpatt
7a00: 73 74 61 74 65 70 61 74 74 20 73 74 61 74 75 73 statepatt status
7a10: 70 61 74 74 29 29 29 0a 0a 3b 3b 20 4e 4f 54 45 patt)))..;; NOTE
7a20: 3a 20 54 68 69 73 20 77 69 6c 6c 20 6f 70 65 6e : This will open
7a30: 20 61 6e 64 20 61 63 63 65 73 73 20 41 4c 4c 20 and access ALL
7a40: 72 75 6e 20 64 61 74 61 62 61 73 65 73 2e 20 0a run databases. .
7a50: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 6d 72 6d 74 ;;.(define (mrmt
7a60: 3a 74 65 73 74 2d 67 65 74 2d 70 61 74 68 73 2d :test-get-paths-
7a70: 6d 61 74 63 68 69 6e 67 2d 6b 65 79 6e 61 6d 65 matching-keyname
7a80: 73 2d 74 61 72 67 65 74 2d 6e 65 77 20 6b 65 79 s-target-new key
7a90: 6e 61 6d 65 73 20 74 61 72 67 65 74 20 72 65 73 names target res
7aa0: 20 74 65 73 74 70 61 74 74 20 73 74 61 74 65 70 testpatt statep
7ab0: 61 74 74 20 73 74 61 74 75 73 70 61 74 74 20 72 att statuspatt r
7ac0: 75 6e 6e 61 6d 65 29 0a 20 20 28 6c 65 74 20 28 unname). (let (
7ad0: 28 72 75 6e 2d 69 64 73 20 28 6d 72 6d 74 3a 67 (run-ids (mrmt:g
7ae0: 65 74 2d 72 75 6e 2d 69 64 73 2d 6d 61 74 63 68 et-run-ids-match
7af0: 69 6e 67 2d 74 61 72 67 65 74 20 6b 65 79 6e 61 ing-target keyna
7b00: 6d 65 73 20 74 61 72 67 65 74 20 72 65 73 20 72 mes target res r
7b10: 75 6e 6e 61 6d 65 20 74 65 73 74 70 61 74 74 20 unname testpatt
7b20: 73 74 61 74 65 70 61 74 74 20 73 74 61 74 75 73 statepatt status
7b30: 70 61 74 74 29 29 29 0a 20 20 20 20 28 61 70 70 patt))). (app
7b40: 6c 79 20 61 70 70 65 6e 64 20 0a 09 20 20 20 28 ly append .. (
7b50: 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 72 75 6e map (lambda (run
7b60: 2d 69 64 29 0a 09 09 20 20 28 6d 72 6d 74 3a 73 -id)... (mrmt:s
7b70: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 74 65 73 end-receive 'tes
7b80: 74 2d 67 65 74 2d 70 61 74 68 73 2d 6d 61 74 63 t-get-paths-matc
7b90: 68 69 6e 67 2d 6b 65 79 6e 61 6d 65 73 2d 74 61 hing-keynames-ta
7ba0: 72 67 65 74 2d 6e 65 77 20 72 75 6e 2d 69 64 20 rget-new run-id
7bb0: 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 6b 65 79 (list run-id key
7bc0: 6e 61 6d 65 73 20 74 61 72 67 65 74 20 72 65 73 names target res
7bd0: 20 74 65 73 74 70 61 74 74 20 73 74 61 74 65 70 testpatt statep
7be0: 61 74 74 20 73 74 61 74 75 73 70 61 74 74 20 72 att statuspatt r
7bf0: 75 6e 6e 61 6d 65 29 29 29 0a 09 20 20 20 72 75 unname))).. ru
7c00: 6e 2d 69 64 73 29 29 29 29 0a 0a 3b 3b 20 28 64 n-ids))))..;; (d
7c10: 65 66 69 6e 65 20 28 6d 72 6d 74 3a 67 65 74 2d efine (mrmt:get-
7c20: 72 75 6e 2d 69 64 73 2d 6d 61 74 63 68 69 6e 67 run-ids-matching
7c30: 20 6b 65 79 6e 61 6d 65 73 20 74 61 72 67 65 74 keynames target
7c40: 20 72 65 73 29 0a 3b 3b 20 20 20 28 6d 72 6d 74 res).;; (mrmt
7c50: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 23 66 :send-receive #f
7c60: 20 27 67 65 74 2d 72 75 6e 2d 69 64 73 2d 6d 61 'get-run-ids-ma
7c70: 74 63 68 69 6e 67 20 28 6c 69 73 74 20 6b 65 79 tching (list key
7c80: 6e 61 6d 65 73 20 74 61 72 67 65 74 20 72 65 73 names target res
7c90: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 6d 72 )))..(define (mr
7ca0: 6d 74 3a 67 65 74 2d 70 72 65 72 65 71 73 2d 6e mt:get-prereqs-n
7cb0: 6f 74 2d 6d 65 74 20 72 75 6e 2d 69 64 20 77 61 ot-met run-id wa
7cc0: 69 74 6f 6e 73 20 72 65 66 2d 74 65 73 74 2d 6e itons ref-test-n
7cd0: 61 6d 65 20 72 65 66 2d 69 74 65 6d 2d 70 61 74 ame ref-item-pat
7ce0: 68 20 23 21 6b 65 79 20 28 6d 6f 64 65 20 27 28 h #!key (mode '(
7cf0: 6e 6f 72 6d 61 6c 29 29 28 69 74 65 6d 6d 61 70 normal))(itemmap
7d00: 73 20 23 66 29 29 0a 20 20 28 6d 72 6d 74 3a 73 s #f)). (mrmt:s
7d10: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 end-receive 'get
7d20: 2d 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 -prereqs-not-met
7d30: 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 run-id (list ru
7d40: 6e 2d 69 64 20 77 61 69 74 6f 6e 73 20 72 65 66 n-id waitons ref
7d50: 2d 74 65 73 74 2d 6e 61 6d 65 20 72 65 66 2d 69 -test-name ref-i
7d60: 74 65 6d 2d 70 61 74 68 20 6d 6f 64 65 20 69 74 tem-path mode it
7d70: 65 6d 6d 61 70 73 29 29 29 0a 0a 28 64 65 66 69 emmaps)))..(defi
7d80: 6e 65 20 28 6d 72 6d 74 3a 67 65 74 2d 63 6f 75 ne (mrmt:get-cou
7d90: 6e 74 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 nt-tests-running
7da0: 2d 66 6f 72 2d 72 75 6e 2d 69 64 20 72 75 6e 2d -for-run-id run-
7db0: 69 64 29 0a 20 20 28 6d 72 6d 74 3a 73 65 6e 64 id). (mrmt:send
7dc0: 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 63 6f -receive 'get-co
7dd0: 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e unt-tests-runnin
7de0: 67 2d 66 6f 72 2d 72 75 6e 2d 69 64 20 72 75 6e g-for-run-id run
7df0: 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 -id (list run-id
7e00: 29 29 29 0a 0a 3b 3b 20 53 74 61 74 69 73 74 69 )))..;; Statisti
7e10: 63 61 6c 20 71 75 65 72 69 65 73 0a 0a 28 64 65 cal queries..(de
7e20: 66 69 6e 65 20 28 6d 72 6d 74 3a 67 65 74 2d 63 fine (mrmt:get-c
7e30: 6f 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e 6e 69 ount-tests-runni
7e40: 6e 67 20 72 75 6e 2d 69 64 29 0a 20 20 28 6d 72 ng run-id). (mr
7e50: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
7e60: 27 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 'get-count-tests
7e70: 2d 72 75 6e 6e 69 6e 67 20 72 75 6e 2d 69 64 20 -running run-id
7e80: 28 6c 69 73 74 20 72 75 6e 2d 69 64 29 29 29 0a (list run-id))).
7e90: 0a 28 64 65 66 69 6e 65 20 28 6d 72 6d 74 3a 67 .(define (mrmt:g
7ea0: 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d 72 et-count-tests-r
7eb0: 75 6e 6e 69 6e 67 2d 66 6f 72 2d 74 65 73 74 6e unning-for-testn
7ec0: 61 6d 65 20 72 75 6e 2d 69 64 20 74 65 73 74 6e ame run-id testn
7ed0: 61 6d 65 29 0a 20 20 28 6d 72 6d 74 3a 73 65 6e ame). (mrmt:sen
7ee0: 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 63 d-receive 'get-c
7ef0: 6f 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e 6e 69 ount-tests-runni
7f00: 6e 67 2d 66 6f 72 2d 74 65 73 74 6e 61 6d 65 20 ng-for-testname
7f10: 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e run-id (list run
7f20: 2d 69 64 20 74 65 73 74 6e 61 6d 65 29 29 29 0a -id testname))).
7f30: 0a 28 64 65 66 69 6e 65 20 28 6d 72 6d 74 3a 67 .(define (mrmt:g
7f40: 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d 72 et-count-tests-r
7f50: 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f unning-in-jobgro
7f60: 75 70 20 72 75 6e 2d 69 64 20 6a 6f 62 67 72 6f up run-id jobgro
7f70: 75 70 29 0a 20 20 28 6d 72 6d 74 3a 73 65 6e 64 up). (mrmt:send
7f80: 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 63 6f -receive 'get-co
7f90: 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e unt-tests-runnin
7fa0: 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 72 75 g-in-jobgroup ru
7fb0: 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 n-id (list run-i
7fc0: 64 20 6a 6f 62 67 72 6f 75 70 29 29 29 0a 0a 3b d jobgroup)))..;
7fd0: 3b 20 73 74 61 74 65 20 61 6e 64 20 73 74 61 74 ; state and stat
7fe0: 75 73 20 61 72 65 20 65 78 74 72 61 20 68 69 6e us are extra hin
7ff0: 74 73 20 6e 6f 74 20 75 73 75 61 6c 6c 79 20 75 ts not usually u
8000: 73 65 64 20 69 6e 20 74 68 65 20 63 61 6c 63 75 sed in the calcu
8010: 6c 61 74 69 6f 6e 0a 3b 3b 0a 28 64 65 66 69 6e lation.;;.(defin
8020: 65 20 28 6d 72 6d 74 3a 73 65 74 2d 73 74 61 74 e (mrmt:set-stat
8030: 65 2d 73 74 61 74 75 73 2d 61 6e 64 2d 72 6f 6c e-status-and-rol
8040: 6c 2d 75 70 2d 69 74 65 6d 73 20 72 75 6e 2d 69 l-up-items run-i
8050: 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d d test-name item
8060: 2d 70 61 74 68 20 73 74 61 74 65 20 73 74 61 74 -path state stat
8070: 75 73 20 63 6f 6d 6d 65 6e 74 29 0a 20 20 28 6d us comment). (m
8080: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
8090: 20 27 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 'set-state-stat
80a0: 75 73 2d 61 6e 64 2d 72 6f 6c 6c 2d 75 70 2d 69 us-and-roll-up-i
80b0: 74 65 6d 73 20 72 75 6e 2d 69 64 20 28 6c 69 73 tems run-id (lis
80c0: 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 t run-id test-na
80d0: 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 73 74 61 me item-path sta
80e0: 74 65 20 73 74 61 74 75 73 20 63 6f 6d 6d 65 6e te status commen
80f0: 74 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 6d t)))..(define (m
8100: 72 6d 74 3a 75 70 64 61 74 65 2d 70 61 73 73 2d rmt:update-pass-
8110: 66 61 69 6c 2d 63 6f 75 6e 74 73 20 72 75 6e 2d fail-counts run-
8120: 69 64 20 74 65 73 74 2d 6e 61 6d 65 29 0a 20 20 id test-name).
8130: 28 6d 72 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 61 (mrmt:general-ca
8140: 6c 6c 20 27 75 70 64 61 74 65 2d 70 61 73 73 2d ll 'update-pass-
8150: 66 61 69 6c 2d 63 6f 75 6e 74 73 20 72 75 6e 2d fail-counts run-
8160: 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 id test-name tes
8170: 74 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 t-name test-name
8180: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 6d 72 6d ))..(define (mrm
8190: 74 3a 74 6f 70 2d 74 65 73 74 2d 73 65 74 2d 70 t:top-test-set-p
81a0: 65 72 2d 70 66 2d 63 6f 75 6e 74 73 20 72 75 6e er-pf-counts run
81b0: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 29 0a 20 -id test-name).
81c0: 20 28 6d 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (mrmt:send-rece
81d0: 69 76 65 20 27 74 6f 70 2d 74 65 73 74 2d 73 65 ive 'top-test-se
81e0: 74 2d 70 65 72 2d 70 66 2d 63 6f 75 6e 74 73 20 t-per-pf-counts
81f0: 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e run-id (list run
8200: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 -id test-name)))
8210: 0a 0a 28 64 65 66 69 6e 65 20 28 6d 72 6d 74 3a ..(define (mrmt:
8220: 67 65 74 2d 72 61 77 2d 72 75 6e 2d 73 74 61 74 get-raw-run-stat
8230: 73 20 72 75 6e 2d 69 64 29 0a 20 20 28 6d 72 6d s run-id). (mrm
8240: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
8250: 67 65 74 2d 72 61 77 2d 72 75 6e 2d 73 74 61 74 get-raw-run-stat
8260: 73 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 s run-id (list r
8270: 75 6e 2d 69 64 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d un-id)))..;;====
8280: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8290: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
82a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
82b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
82c0: 3d 3d 0a 3b 3b 20 20 52 20 55 20 4e 20 53 0a 3b ==.;; R U N S.;
82d0: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
82e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
82f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8300: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8310: 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 =======..(define
8320: 20 28 6d 72 6d 74 3a 67 65 74 2d 72 75 6e 2d 69 (mrmt:get-run-i
8330: 6e 66 6f 20 72 75 6e 2d 69 64 29 0a 20 20 28 6d nfo run-id). (m
8340: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
8350: 20 27 67 65 74 2d 72 75 6e 2d 69 6e 66 6f 20 72 'get-run-info r
8360: 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d un-id (list run-
8370: 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 id)))..(define (
8380: 6d 72 6d 74 3a 67 65 74 2d 6e 75 6d 2d 72 75 6e mrmt:get-num-run
8390: 73 20 72 75 6e 70 61 74 74 29 0a 20 20 28 6d 72 s runpatt). (mr
83a0: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
83b0: 27 67 65 74 2d 6e 75 6d 2d 72 75 6e 73 20 23 66 'get-num-runs #f
83c0: 20 28 6c 69 73 74 20 72 75 6e 70 61 74 74 29 29 (list runpatt))
83d0: 29 0a 0a 3b 3b 20 55 73 65 20 74 68 65 20 73 70 )..;; Use the sp
83e0: 65 63 69 61 6c 20 72 75 6e 2d 69 64 20 3d 3d 20 ecial run-id ==
83f0: 23 66 20 73 63 65 6e 61 72 69 6f 20 68 65 72 65 #f scenario here
8400: 20 73 69 6e 63 65 20 74 68 65 72 65 20 69 73 20 since there is
8410: 6e 6f 20 72 75 6e 20 79 65 74 0a 28 64 65 66 69 no run yet.(defi
8420: 6e 65 20 28 6d 72 6d 74 3a 72 65 67 69 73 74 65 ne (mrmt:registe
8430: 72 2d 72 75 6e 20 6b 65 79 76 61 6c 73 20 72 75 r-run keyvals ru
8440: 6e 6e 61 6d 65 20 73 74 61 74 65 20 73 74 61 74 nname state stat
8450: 75 73 20 75 73 65 72 20 63 6f 6e 74 6f 75 72 29 us user contour)
8460: 0a 20 20 28 6d 72 6d 74 3a 73 65 6e 64 2d 72 65 . (mrmt:send-re
8470: 63 65 69 76 65 20 27 72 65 67 69 73 74 65 72 2d ceive 'register-
8480: 72 75 6e 20 23 66 20 28 6c 69 73 74 20 6b 65 79 run #f (list key
8490: 76 61 6c 73 20 72 75 6e 6e 61 6d 65 20 73 74 61 vals runname sta
84a0: 74 65 20 73 74 61 74 75 73 20 75 73 65 72 20 63 te status user c
84b0: 6f 6e 74 6f 75 72 29 29 29 0a 20 20 20 20 0a 28 ontour))). .(
84c0: 64 65 66 69 6e 65 20 28 6d 72 6d 74 3a 67 65 74 define (mrmt:get
84d0: 2d 72 75 6e 2d 6e 61 6d 65 2d 66 72 6f 6d 2d 69 -run-name-from-i
84e0: 64 20 72 75 6e 2d 69 64 29 0a 20 20 28 6d 72 6d d run-id). (mrm
84f0: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
8500: 67 65 74 2d 72 75 6e 2d 6e 61 6d 65 2d 66 72 6f get-run-name-fro
8510: 6d 2d 69 64 20 72 75 6e 2d 69 64 20 28 6c 69 73 m-id run-id (lis
8520: 74 20 72 75 6e 2d 69 64 29 29 29 0a 0a 28 64 65 t run-id)))..(de
8530: 66 69 6e 65 20 28 6d 72 6d 74 3a 64 65 6c 65 74 fine (mrmt:delet
8540: 65 2d 72 75 6e 20 72 75 6e 2d 69 64 29 0a 20 20 e-run run-id).
8550: 28 6d 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (mrmt:send-recei
8560: 76 65 20 27 64 65 6c 65 74 65 2d 72 75 6e 20 72 ve 'delete-run r
8570: 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d un-id (list run-
8580: 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 id)))..(define (
8590: 6d 72 6d 74 3a 75 70 64 61 74 65 2d 72 75 6e 2d mrmt:update-run-
85a0: 73 74 61 74 73 20 72 75 6e 2d 69 64 20 73 74 61 stats run-id sta
85b0: 74 73 29 0a 20 20 28 6d 72 6d 74 3a 73 65 6e 64 ts). (mrmt:send
85c0: 2d 72 65 63 65 69 76 65 20 27 75 70 64 61 74 65 -receive 'update
85d0: 2d 72 75 6e 2d 73 74 61 74 73 20 23 66 20 28 6c -run-stats #f (l
85e0: 69 73 74 20 72 75 6e 2d 69 64 20 73 74 61 74 73 ist run-id stats
85f0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 6d 72 )))..(define (mr
8600: 6d 74 3a 64 65 6c 65 74 65 2d 6f 6c 64 2d 64 65 mt:delete-old-de
8610: 6c 65 74 65 64 2d 74 65 73 74 2d 72 65 63 6f 72 leted-test-recor
8620: 64 73 29 0a 20 20 28 6d 72 6d 74 3a 73 65 6e 64 ds). (mrmt:send
8630: 2d 72 65 63 65 69 76 65 20 27 64 65 6c 65 74 65 -receive 'delete
8640: 2d 6f 6c 64 2d 64 65 6c 65 74 65 64 2d 74 65 73 -old-deleted-tes
8650: 74 2d 72 65 63 6f 72 64 73 20 23 66 20 27 28 29 t-records #f '()
8660: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 6d 72 6d ))..(define (mrm
8670: 74 3a 67 65 74 2d 72 75 6e 73 20 72 75 6e 70 61 t:get-runs runpa
8680: 74 74 20 63 6f 75 6e 74 20 6f 66 66 73 65 74 20 tt count offset
8690: 6b 65 79 70 61 74 74 73 29 0a 20 20 28 6d 72 6d keypatts). (mrm
86a0: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
86b0: 67 65 74 2d 72 75 6e 73 20 23 66 20 28 6c 69 73 get-runs #f (lis
86c0: 74 20 72 75 6e 70 61 74 74 20 63 6f 75 6e 74 20 t runpatt count
86d0: 6f 66 66 73 65 74 20 6b 65 79 70 61 74 74 73 29 offset keypatts)
86e0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 6d 72 6d ))..(define (mrm
86f0: 74 3a 67 65 74 2d 61 6c 6c 2d 72 75 6e 2d 69 64 t:get-all-run-id
8700: 73 29 0a 20 20 28 6d 72 6d 74 3a 73 65 6e 64 2d s). (mrmt:send-
8710: 72 65 63 65 69 76 65 20 27 67 65 74 2d 61 6c 6c receive 'get-all
8720: 2d 72 75 6e 2d 69 64 73 20 23 66 20 27 28 29 29 -run-ids #f '())
8730: 29 0a 0a 28 64 65 66 69 6e 65 20 28 6d 72 6d 74 )..(define (mrmt
8740: 3a 67 65 74 2d 70 72 65 76 2d 72 75 6e 2d 69 64 :get-prev-run-id
8750: 73 20 72 75 6e 2d 69 64 29 0a 20 20 28 6d 72 6d s run-id). (mrm
8760: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
8770: 67 65 74 2d 70 72 65 76 2d 72 75 6e 2d 69 64 73 get-prev-run-ids
8780: 20 23 66 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 #f (list run-id
8790: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 6d 72 )))..(define (mr
87a0: 6d 74 3a 6c 6f 63 6b 2f 75 6e 6c 6f 63 6b 2d 72 mt:lock/unlock-r
87b0: 75 6e 20 72 75 6e 2d 69 64 20 6c 6f 63 6b 20 75 un run-id lock u
87c0: 6e 6c 6f 63 6b 20 75 73 65 72 29 0a 20 20 28 6d nlock user). (m
87d0: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
87e0: 20 27 6c 6f 63 6b 2f 75 6e 6c 6f 63 6b 2d 72 75 'lock/unlock-ru
87f0: 6e 20 23 66 20 28 6c 69 73 74 20 72 75 6e 2d 69 n #f (list run-i
8800: 64 20 6c 6f 63 6b 20 75 6e 6c 6f 63 6b 20 75 73 d lock unlock us
8810: 65 72 29 29 29 0a 0a 3b 3b 20 73 65 74 2f 67 65 er)))..;; set/ge
8820: 74 20 73 74 61 74 75 73 0a 28 64 65 66 69 6e 65 t status.(define
8830: 20 28 6d 72 6d 74 3a 67 65 74 2d 72 75 6e 2d 73 (mrmt:get-run-s
8840: 74 61 74 75 73 20 72 75 6e 2d 69 64 29 0a 20 20 tatus run-id).
8850: 28 6d 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (mrmt:send-recei
8860: 76 65 20 27 67 65 74 2d 72 75 6e 2d 73 74 61 74 ve 'get-run-stat
8870: 75 73 20 23 66 20 28 6c 69 73 74 20 72 75 6e 2d us #f (list run-
8880: 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 id)))..(define (
8890: 6d 72 6d 74 3a 73 65 74 2d 72 75 6e 2d 73 74 61 mrmt:set-run-sta
88a0: 74 75 73 20 72 75 6e 2d 69 64 20 72 75 6e 2d 73 tus run-id run-s
88b0: 74 61 74 75 73 20 23 21 6b 65 79 20 28 6d 73 67 tatus #!key (msg
88c0: 20 23 66 29 29 0a 20 20 28 6d 72 6d 74 3a 73 65 #f)). (mrmt:se
88d0: 6e 64 2d 72 65 63 65 69 76 65 20 27 73 65 74 2d nd-receive 'set-
88e0: 72 75 6e 2d 73 74 61 74 75 73 20 23 66 20 28 6c run-status #f (l
88f0: 69 73 74 20 72 75 6e 2d 69 64 20 72 75 6e 2d 73 ist run-id run-s
8900: 74 61 74 75 73 20 6d 73 67 29 29 29 0a 0a 28 64 tatus msg)))..(d
8910: 65 66 69 6e 65 20 28 6d 72 6d 74 3a 75 70 64 61 efine (mrmt:upda
8920: 74 65 2d 72 75 6e 2d 65 76 65 6e 74 5f 74 69 6d te-run-event_tim
8930: 65 20 72 75 6e 2d 69 64 29 0a 20 20 28 6d 72 6d e run-id). (mrm
8940: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
8950: 75 70 64 61 74 65 2d 72 75 6e 2d 65 76 65 6e 74 update-run-event
8960: 5f 74 69 6d 65 20 23 66 20 28 6c 69 73 74 20 72 _time #f (list r
8970: 75 6e 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 6e un-id)))..(defin
8980: 65 20 28 6d 72 6d 74 3a 67 65 74 2d 72 75 6e 73 e (mrmt:get-runs
8990: 2d 62 79 2d 70 61 74 74 20 20 6b 65 79 73 20 72 -by-patt keys r
89a0: 75 6e 6e 61 6d 65 70 61 74 74 20 74 61 72 67 70 unnamepatt targp
89b0: 61 74 74 20 6f 66 66 73 65 74 20 6c 69 6d 69 74 att offset limit
89c0: 20 66 69 65 6c 64 73 20 6c 61 73 74 2d 72 75 6e fields last-run
89d0: 73 2d 75 70 64 61 74 65 29 20 3b 3b 20 66 69 65 s-update) ;; fie
89e0: 6c 64 73 20 6f 66 20 23 66 20 75 73 65 73 20 64 lds of #f uses d
89f0: 65 66 61 75 6c 74 0a 20 20 28 6d 72 6d 74 3a 73 efault. (mrmt:s
8a00: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 end-receive 'get
8a10: 2d 72 75 6e 73 2d 62 79 2d 70 61 74 74 20 23 66 -runs-by-patt #f
8a20: 20 28 6c 69 73 74 20 6b 65 79 73 20 72 75 6e 6e (list keys runn
8a30: 61 6d 65 70 61 74 74 20 74 61 72 67 70 61 74 74 amepatt targpatt
8a40: 20 6f 66 66 73 65 74 20 6c 69 6d 69 74 20 66 69 offset limit fi
8a50: 65 6c 64 73 20 6c 61 73 74 2d 72 75 6e 73 2d 75 elds last-runs-u
8a60: 70 64 61 74 65 29 29 29 0a 0a 28 64 65 66 69 6e pdate)))..(defin
8a70: 65 20 28 6d 72 6d 74 3a 66 69 6e 64 2d 61 6e 64 e (mrmt:find-and
8a80: 2d 6d 61 72 6b 2d 69 6e 63 6f 6d 70 6c 65 74 65 -mark-incomplete
8a90: 20 72 75 6e 2d 69 64 20 6f 76 72 2d 64 65 61 64 run-id ovr-dead
8aa0: 74 69 6d 65 29 0a 20 20 3b 3b 20 28 69 66 20 28 time). ;; (if (
8ab0: 6d 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 mrmt:send-receiv
8ac0: 65 20 27 68 61 76 65 2d 69 6e 63 6f 6d 70 6c 65 e 'have-incomple
8ad0: 74 65 73 3f 20 72 75 6e 2d 69 64 20 28 6c 69 73 tes? run-id (lis
8ae0: 74 20 72 75 6e 2d 69 64 20 6f 76 72 2d 64 65 61 t run-id ovr-dea
8af0: 64 74 69 6d 65 29 29 0a 20 20 28 6d 72 6d 74 3a dtime)). (mrmt:
8b00: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 6d 61 send-receive 'ma
8b10: 72 6b 2d 69 6e 63 6f 6d 70 6c 65 74 65 20 72 75 rk-incomplete ru
8b20: 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 n-id (list run-i
8b30: 64 20 6f 76 72 2d 64 65 61 64 74 69 6d 65 29 29 d ovr-deadtime))
8b40: 29 20 3b 3b 20 29 0a 0a 28 64 65 66 69 6e 65 20 ) ;; )..(define
8b50: 28 6d 72 6d 74 3a 67 65 74 2d 6d 61 69 6e 2d 72 (mrmt:get-main-r
8b60: 75 6e 2d 73 74 61 74 73 20 72 75 6e 2d 69 64 29 un-stats run-id)
8b70: 0a 20 20 28 6d 72 6d 74 3a 73 65 6e 64 2d 72 65 . (mrmt:send-re
8b80: 63 65 69 76 65 20 27 67 65 74 2d 6d 61 69 6e 2d ceive 'get-main-
8b90: 72 75 6e 2d 73 74 61 74 73 20 23 66 20 28 6c 69 run-stats #f (li
8ba0: 73 74 20 72 75 6e 2d 69 64 29 29 29 0a 0a 28 64 st run-id)))..(d
8bb0: 65 66 69 6e 65 20 28 6d 72 6d 74 3a 67 65 74 2d efine (mrmt:get-
8bc0: 76 61 72 20 76 61 72 6e 61 6d 65 29 0a 20 20 28 var varname). (
8bd0: 6d 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 mrmt:send-receiv
8be0: 65 20 27 67 65 74 2d 76 61 72 20 23 66 20 28 6c e 'get-var #f (l
8bf0: 69 73 74 20 76 61 72 6e 61 6d 65 29 29 29 0a 0a ist varname)))..
8c00: 28 64 65 66 69 6e 65 20 28 6d 72 6d 74 3a 64 65 (define (mrmt:de
8c10: 6c 2d 76 61 72 20 76 61 72 6e 61 6d 65 29 0a 20 l-var varname).
8c20: 20 28 6d 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (mrmt:send-rece
8c30: 69 76 65 20 27 64 65 6c 2d 76 61 72 20 23 66 20 ive 'del-var #f
8c40: 28 6c 69 73 74 20 76 61 72 6e 61 6d 65 29 29 29 (list varname)))
8c50: 0a 0a 28 64 65 66 69 6e 65 20 28 6d 72 6d 74 3a ..(define (mrmt:
8c60: 73 65 74 2d 76 61 72 20 76 61 72 6e 61 6d 65 20 set-var varname
8c70: 76 61 6c 75 65 29 0a 20 20 28 6d 72 6d 74 3a 73 value). (mrmt:s
8c80: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 73 65 74 end-receive 'set
8c90: 2d 76 61 72 20 23 66 20 28 6c 69 73 74 20 76 61 -var #f (list va
8ca0: 72 6e 61 6d 65 20 76 61 6c 75 65 29 29 29 0a 0a rname value)))..
8cb0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
8cc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8cd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8ce0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8cf0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4d 20 55 20 ========.;; M U
8d00: 4c 20 54 20 49 20 52 20 55 20 4e 20 20 20 51 20 L T I R U N Q
8d10: 55 20 45 20 52 20 49 20 45 20 53 0a 3b 3b 3d 3d U E R I E S.;;==
8d20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8d30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8d40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8d50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8d60: 3d 3d 3d 3d 0a 0a 3b 3b 20 4e 65 65 64 20 74 6f ====..;; Need to
8d70: 20 6d 6f 76 65 20 74 68 69 73 20 74 6f 20 6d 75 move this to mu
8d80: 6c 74 69 2d 72 75 6e 20 73 65 63 74 69 6f 6e 20 lti-run section
8d90: 61 6e 64 20 6d 61 6b 65 20 61 73 73 6f 63 69 61 and make associa
8da0: 74 65 64 20 63 68 61 6e 67 65 73 0a 28 64 65 66 ted changes.(def
8db0: 69 6e 65 20 28 6d 72 6d 74 3a 66 69 6e 64 2d 61 ine (mrmt:find-a
8dc0: 6e 64 2d 6d 61 72 6b 2d 69 6e 63 6f 6d 70 6c 65 nd-mark-incomple
8dd0: 74 65 2d 61 6c 6c 2d 72 75 6e 73 20 23 21 6b 65 te-all-runs #!ke
8de0: 79 20 28 6f 76 72 2d 64 65 61 64 74 69 6d 65 20 y (ovr-deadtime
8df0: 23 66 29 29 0a 20 20 28 6c 65 74 20 28 28 72 75 #f)). (let ((ru
8e00: 6e 2d 69 64 73 20 28 6d 72 6d 74 3a 67 65 74 2d n-ids (mrmt:get-
8e10: 61 6c 6c 2d 72 75 6e 2d 69 64 73 29 29 29 0a 20 all-run-ids))).
8e20: 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 (for-each (la
8e30: 6d 62 64 61 20 28 72 75 6e 2d 69 64 29 0a 09 20 mbda (run-id)..
8e40: 20 20 20 20 20 20 28 6d 72 6d 74 3a 66 69 6e 64 (mrmt:find
8e50: 2d 61 6e 64 2d 6d 61 72 6b 2d 69 6e 63 6f 6d 70 -and-mark-incomp
8e60: 6c 65 74 65 20 72 75 6e 2d 69 64 20 6f 76 72 2d lete run-id ovr-
8e70: 64 65 61 64 74 69 6d 65 29 29 0a 09 20 20 20 20 deadtime))..
8e80: 20 72 75 6e 2d 69 64 73 29 29 29 0a 0a 3b 3b 20 run-ids)))..;;
8e90: 67 65 74 20 74 68 65 20 70 72 65 76 69 6f 75 73 get the previous
8ea0: 20 72 65 63 6f 72 64 20 66 6f 72 20 77 68 65 6e record for when
8eb0: 20 74 68 69 73 20 74 65 73 74 20 77 61 73 20 72 this test was r
8ec0: 75 6e 20 77 68 65 72 65 20 61 6c 6c 20 6b 65 79 un where all key
8ed0: 73 20 6d 61 74 63 68 20 62 75 74 20 72 75 6e 6e s match but runn
8ee0: 61 6d 65 0a 3b 3b 20 72 65 74 75 72 6e 73 20 23 ame.;; returns #
8ef0: 66 20 69 66 20 6e 6f 20 73 75 63 68 20 74 65 73 f if no such tes
8f00: 74 20 66 6f 75 6e 64 2c 20 72 65 74 75 72 6e 73 t found, returns
8f10: 20 61 20 73 69 6e 67 6c 65 20 74 65 73 74 20 72 a single test r
8f20: 65 63 6f 72 64 20 69 66 20 66 6f 75 6e 64 0a 3b ecord if found.;
8f30: 3b 20 0a 3b 3b 20 52 75 6e 20 74 68 69 73 20 61 ; .;; Run this a
8f40: 74 20 74 68 65 20 63 6c 69 65 6e 74 20 65 6e 64 t the client end
8f50: 20 73 69 6e 63 65 20 77 65 20 68 61 76 65 20 74 since we have t
8f60: 6f 20 63 6f 6e 6e 65 63 74 20 74 6f 20 6d 75 6c o connect to mul
8f70: 74 69 70 6c 65 20 72 75 6e 2d 69 64 20 64 62 73 tiple run-id dbs
8f80: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 6d 72 6d .;;.(define (mrm
8f90: 74 3a 67 65 74 2d 70 72 65 76 69 6f 75 73 2d 74 t:get-previous-t
8fa0: 65 73 74 2d 72 75 6e 2d 72 65 63 6f 72 64 20 72 est-run-record r
8fb0: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 un-id test-name
8fc0: 69 74 65 6d 2d 70 61 74 68 29 0a 20 20 28 6c 65 item-path). (le
8fd0: 74 2a 20 28 28 6b 65 79 76 61 6c 73 20 28 6d 72 t* ((keyvals (mr
8fe0: 6d 74 3a 67 65 74 2d 6b 65 79 2d 76 61 6c 2d 70 mt:get-key-val-p
8ff0: 61 69 72 73 20 72 75 6e 2d 69 64 29 29 0a 09 20 airs run-id))..
9000: 28 6b 65 79 73 20 20 20 20 28 6d 72 6d 74 3a 67 (keys (mrmt:g
9010: 65 74 2d 6b 65 79 73 29 29 0a 09 20 28 73 65 6c et-keys)).. (sel
9020: 73 74 72 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 str (string-int
9030: 65 72 73 70 65 72 73 65 20 20 6b 65 79 73 20 22 ersperse keys "
9040: 2c 22 29 29 0a 09 20 28 71 72 79 73 74 72 20 20 ,")).. (qrystr
9050: 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 (string-interspe
9060: 72 73 65 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 rse (map (lambda
9070: 20 28 78 29 28 63 6f 6e 63 20 78 20 22 3d 3f 22 (x)(conc x "=?"
9080: 29 29 20 6b 65 79 73 29 20 22 20 41 4e 44 20 22 )) keys) " AND "
9090: 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 ))). (if (not
90a0: 20 6b 65 79 76 61 6c 73 29 0a 09 23 66 0a 09 28 keyvals)..#f..(
90b0: 6c 65 74 20 28 28 70 72 65 76 2d 72 75 6e 2d 69 let ((prev-run-i
90c0: 64 73 20 28 6d 72 6d 74 3a 67 65 74 2d 70 72 65 ds (mrmt:get-pre
90d0: 76 2d 72 75 6e 2d 69 64 73 20 72 75 6e 2d 69 64 v-run-ids run-id
90e0: 29 29 29 0a 09 20 20 3b 3b 20 66 6f 72 20 65 61 ))).. ;; for ea
90f0: 63 68 20 72 75 6e 20 73 74 61 72 74 69 6e 67 20 ch run starting
9100: 77 69 74 68 20 74 68 65 20 6d 6f 73 74 20 72 65 with the most re
9110: 63 65 6e 74 20 6c 6f 6f 6b 20 74 6f 20 73 65 65 cent look to see
9120: 20 69 66 20 74 68 65 72 65 20 69 73 20 61 20 6d if there is a m
9130: 61 74 63 68 69 6e 67 20 74 65 73 74 0a 09 20 20 atching test..
9140: 3b 3b 20 69 66 20 66 6f 75 6e 64 20 74 68 65 6e ;; if found then
9150: 20 72 65 74 75 72 6e 20 74 68 61 74 20 6d 61 74 return that mat
9160: 63 68 69 6e 67 20 74 65 73 74 20 72 65 63 6f 72 ching test recor
9170: 64 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e d.. (debug:prin
9180: 74 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 4 *default-log
9190: 2d 70 6f 72 74 2a 20 22 73 65 6c 73 74 72 3a 20 -port* "selstr:
91a0: 22 20 73 65 6c 73 74 72 20 22 2c 20 71 72 79 73 " selstr ", qrys
91b0: 74 72 3a 20 22 20 71 72 79 73 74 72 20 22 2c 20 tr: " qrystr ",
91c0: 6b 65 79 76 61 6c 73 3a 20 22 20 6b 65 79 76 61 keyvals: " keyva
91d0: 6c 73 20 22 2c 20 70 72 65 76 69 6f 75 73 20 72 ls ", previous r
91e0: 75 6e 20 69 64 73 20 66 6f 75 6e 64 3a 20 22 20 un ids found: "
91f0: 70 72 65 76 2d 72 75 6e 2d 69 64 73 29 0a 09 20 prev-run-ids)..
9200: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 70 72 65 76 (if (null? prev
9210: 2d 72 75 6e 2d 69 64 73 29 20 23 66 0a 09 20 20 -run-ids) #f..
9220: 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 (let loop ((
9230: 68 65 64 20 28 63 61 72 20 70 72 65 76 2d 72 75 hed (car prev-ru
9240: 6e 2d 69 64 73 29 29 0a 09 09 09 20 28 74 61 6c n-ids)).... (tal
9250: 20 28 63 64 72 20 70 72 65 76 2d 72 75 6e 2d 69 (cdr prev-run-i
9260: 64 73 29 29 29 0a 09 09 28 6c 65 74 20 28 28 72 ds)))...(let ((r
9270: 65 73 75 6c 74 73 20 28 6d 72 6d 74 3a 67 65 74 esults (mrmt:get
9280: 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 68 -tests-for-run h
9290: 65 64 20 28 63 6f 6e 63 20 74 65 73 74 2d 6e 61 ed (conc test-na
92a0: 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 me "/" item-path
92b0: 29 20 27 28 29 20 27 28 29 20 3b 3b 20 72 75 6e ) '() '() ;; run
92c0: 2d 69 64 20 74 65 73 74 70 61 74 74 20 73 74 61 -id testpatt sta
92d0: 74 65 73 20 73 74 61 74 75 73 65 73 0a 09 09 09 tes statuses....
92e0: 09 09 09 20 20 20 20 20 20 23 66 20 23 66 20 23 ... #f #f #
92f0: 66 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 f
9300: 3b 3b 20 6f 66 66 73 65 74 20 6c 69 6d 69 74 20 ;; offset limit
9310: 6e 6f 74 2d 69 6e 20 68 69 64 65 2f 6e 6f 74 2d not-in hide/not-
9320: 68 69 64 65 0a 09 09 09 09 09 09 20 20 20 20 20 hide.......
9330: 20 23 66 20 23 66 20 23 66 20 23 66 20 27 6e 6f #f #f #f #f 'no
9340: 72 6d 61 6c 29 29 29 20 3b 3b 20 73 6f 72 74 2d rmal))) ;; sort-
9350: 62 79 20 73 6f 72 74 2d 6f 72 64 65 72 20 71 72 by sort-order qr
9360: 79 76 61 6c 73 20 6c 61 73 74 2d 75 70 64 61 74 yvals last-updat
9370: 65 20 6d 6f 64 65 0a 09 09 20 20 28 64 65 62 75 e mode... (debu
9380: 67 3a 70 72 69 6e 74 20 34 20 2a 64 65 66 61 75 g:print 4 *defau
9390: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 47 6f lt-log-port* "Go
93a0: 74 20 74 65 73 74 73 20 66 6f 72 20 72 75 6e 2d t tests for run-
93b0: 69 64 20 22 20 72 75 6e 2d 69 64 20 22 2c 20 74 id " run-id ", t
93c0: 65 73 74 2d 6e 61 6d 65 20 22 20 74 65 73 74 2d est-name " test-
93d0: 6e 61 6d 65 20 22 2c 20 69 74 65 6d 2d 70 61 74 name ", item-pat
93e0: 68 20 22 20 69 74 65 6d 2d 70 61 74 68 20 22 3a h " item-path ":
93f0: 20 22 20 72 65 73 75 6c 74 73 29 0a 09 09 20 20 " results)...
9400: 28 69 66 20 28 61 6e 64 20 28 6e 75 6c 6c 3f 20 (if (and (null?
9410: 72 65 73 75 6c 74 73 29 0a 09 09 09 20 20 20 28 results).... (
9420: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 not (null? tal))
9430: 29 0a 09 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 )... (loop
9440: 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 (car tal)(cdr ta
9450: 6c 29 29 0a 09 09 20 20 20 20 20 20 28 69 66 20 l))... (if
9460: 28 6e 75 6c 6c 3f 20 72 65 73 75 6c 74 73 29 20 (null? results)
9470: 23 66 0a 09 09 09 20 20 28 63 61 72 20 72 65 73 #f.... (car res
9480: 75 6c 74 73 29 29 29 29 29 29 29 29 29 29 0a 0a ults))))))))))..
9490: 28 64 65 66 69 6e 65 20 28 6d 72 6d 74 3a 67 65 (define (mrmt:ge
94a0: 74 2d 72 75 6e 2d 73 74 61 74 73 29 0a 20 20 28 t-run-stats). (
94b0: 6d 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 mrmt:send-receiv
94c0: 65 20 27 67 65 74 2d 72 75 6e 2d 73 74 61 74 73 e 'get-run-stats
94d0: 20 23 66 20 27 28 29 29 29 0a 0a 3b 3b 3d 3d 3d #f '()))..;;===
94e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
94f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9500: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9510: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9520: 3d 3d 3d 0a 3b 3b 20 20 53 20 54 20 45 20 50 20 ===.;; S T E P
9530: 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d S.;;============
9540: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9550: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9560: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9570: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 47 ==========..;; G
9580: 65 74 74 69 6e 67 20 73 74 65 70 73 20 69 73 20 etting steps is
9590: 6d 6f 72 65 20 63 6f 6d 70 6c 69 63 61 74 65 64 more complicated
95a0: 2e 0a 3b 3b 0a 3b 3b 20 49 66 20 67 69 76 65 6e ..;;.;; If given
95b0: 20 77 6f 72 6b 20 61 72 65 61 20 0a 3b 3b 20 20 work area .;;
95c0: 31 2e 20 46 69 6e 64 20 74 68 65 20 74 65 73 74 1. Find the test
95d0: 64 61 74 2e 64 62 20 66 69 6c 65 0a 3b 3b 20 20 dat.db file.;;
95e0: 32 2e 20 4f 70 65 6e 20 74 68 65 20 74 65 73 74 2. Open the test
95f0: 64 61 74 2e 64 62 20 66 69 6c 65 20 61 6e 64 20 dat.db file and
9600: 64 6f 20 74 68 65 20 71 75 65 72 79 0a 3b 3b 20 do the query.;;
9610: 49 66 20 6e 6f 74 20 67 69 76 65 6e 20 74 68 65 If not given the
9620: 20 77 6f 72 6b 20 61 72 65 61 0a 3b 3b 20 20 31 work area.;; 1
9630: 2e 20 44 6f 20 61 20 72 65 6d 6f 74 65 20 63 61 . Do a remote ca
9640: 6c 6c 20 74 6f 20 67 65 74 20 74 68 65 20 74 65 ll to get the te
9650: 73 74 20 70 61 74 68 0a 3b 3b 20 20 32 2e 20 43 st path.;; 2. C
9660: 6f 6e 74 69 6e 75 65 20 61 73 20 61 62 6f 76 65 ontinue as above
9670: 0a 3b 3b 20 0a 3b 3b 28 64 65 66 69 6e 65 20 28 .;; .;;(define (
9680: 6d 72 6d 74 3a 67 65 74 2d 73 74 65 70 73 2d 66 mrmt:get-steps-f
9690: 6f 72 2d 74 65 73 74 20 72 75 6e 2d 69 64 20 74 or-test run-id t
96a0: 65 73 74 2d 69 64 29 0a 3b 3b 20 20 28 6d 72 6d est-id).;; (mrm
96b0: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
96c0: 67 65 74 2d 73 74 65 70 73 2d 64 61 74 61 20 72 get-steps-data r
96d0: 75 6e 2d 69 64 20 28 6c 69 73 74 20 74 65 73 74 un-id (list test
96e0: 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 -id)))..(define
96f0: 28 6d 72 6d 74 3a 74 65 73 74 73 74 65 70 2d 73 (mrmt:teststep-s
9700: 65 74 2d 73 74 61 74 75 73 21 20 72 75 6e 2d 69 et-status! run-i
9710: 64 20 74 65 73 74 2d 69 64 20 74 65 73 74 73 74 d test-id testst
9720: 65 70 2d 6e 61 6d 65 20 73 74 61 74 65 2d 69 6e ep-name state-in
9730: 20 73 74 61 74 75 73 2d 69 6e 20 63 6f 6d 6d 65 status-in comme
9740: 6e 74 20 6c 6f 67 66 69 6c 65 29 0a 20 20 28 6c nt logfile). (l
9750: 65 74 2a 20 28 28 73 74 61 74 65 20 20 20 20 20 et* ((state
9760: 28 69 74 65 6d 73 3a 63 68 65 63 6b 2d 76 61 6c (items:check-val
9770: 69 64 2d 69 74 65 6d 73 20 22 73 74 61 74 65 22 id-items "state"
9780: 20 73 74 61 74 65 2d 69 6e 29 29 0a 09 20 28 73 state-in)).. (s
9790: 74 61 74 75 73 20 20 20 20 28 69 74 65 6d 73 3a tatus (items:
97a0: 63 68 65 63 6b 2d 76 61 6c 69 64 2d 69 74 65 6d check-valid-item
97b0: 73 20 22 73 74 61 74 75 73 22 20 73 74 61 74 75 s "status" statu
97c0: 73 2d 69 6e 29 29 29 0a 20 20 20 20 28 69 66 20 s-in))). (if
97d0: 28 6f 72 20 28 6e 6f 74 20 73 74 61 74 65 29 28 (or (not state)(
97e0: 6e 6f 74 20 73 74 61 74 75 73 29 29 0a 09 28 64 not status))..(d
97f0: 65 62 75 67 3a 70 72 69 6e 74 20 33 20 2a 64 65 ebug:print 3 *de
9800: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
9810: 22 57 41 52 4e 49 4e 47 3a 20 49 6e 76 61 6c 69 "WARNING: Invali
9820: 64 20 22 20 28 69 66 20 73 74 61 74 75 73 20 22 d " (if status "
9830: 73 74 61 74 75 73 22 20 22 73 74 61 74 65 22 29 status" "state")
9840: 0a 09 09 20 20 20 20 20 22 20 76 61 6c 75 65 20 ... " value
9850: 5c 22 22 20 28 69 66 20 73 74 61 74 75 73 20 73 \"" (if status s
9860: 74 61 74 65 2d 69 6e 20 73 74 61 74 75 73 2d 69 tate-in status-i
9870: 6e 29 20 22 5c 22 2c 20 75 70 64 61 74 65 20 79 n) "\", update y
9880: 6f 75 72 20 76 61 6c 69 64 76 61 6c 75 65 73 20 our validvalues
9890: 73 65 63 74 69 6f 6e 20 69 6e 20 6d 65 67 61 74 section in megat
98a0: 65 73 74 2e 63 6f 6e 66 69 67 22 29 29 0a 20 20 est.config")).
98b0: 20 20 28 6d 72 6d 74 3a 73 65 6e 64 2d 72 65 63 (mrmt:send-rec
98c0: 65 69 76 65 20 27 74 65 73 74 73 74 65 70 2d 73 eive 'teststep-s
98d0: 65 74 2d 73 74 61 74 75 73 21 20 72 75 6e 2d 69 et-status! run-i
98e0: 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 d (list run-id t
98f0: 65 73 74 2d 69 64 20 74 65 73 74 73 74 65 70 2d est-id teststep-
9900: 6e 61 6d 65 20 73 74 61 74 65 2d 69 6e 20 73 74 name state-in st
9910: 61 74 75 73 2d 69 6e 20 63 6f 6d 6d 65 6e 74 20 atus-in comment
9920: 6c 6f 67 66 69 6c 65 29 29 29 29 0a 0a 28 64 65 logfile))))..(de
9930: 66 69 6e 65 20 28 6d 72 6d 74 3a 67 65 74 2d 73 fine (mrmt:get-s
9940: 74 65 70 73 2d 66 6f 72 2d 74 65 73 74 20 72 75 teps-for-test ru
9950: 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 0a 20 20 n-id test-id).
9960: 28 6d 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (mrmt:send-recei
9970: 76 65 20 27 67 65 74 2d 73 74 65 70 73 2d 66 6f ve 'get-steps-fo
9980: 72 2d 74 65 73 74 20 72 75 6e 2d 69 64 20 28 6c r-test run-id (l
9990: 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d ist run-id test-
99a0: 69 64 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d id)))..;;=======
99b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
99c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
99d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
99e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
99f0: 3b 3b 20 20 54 20 45 20 53 20 54 20 20 20 44 20 ;; T E S T D
9a00: 41 20 54 20 41 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d A T A .;;=======
9a10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9a20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9a30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9a40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
9a50: 0a 28 64 65 66 69 6e 65 20 28 6d 72 6d 74 3a 72 .(define (mrmt:r
9a60: 65 61 64 2d 74 65 73 74 2d 64 61 74 61 20 72 75 ead-test-data ru
9a70: 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 63 61 74 n-id test-id cat
9a80: 65 67 6f 72 79 70 61 74 74 20 23 21 6b 65 79 20 egorypatt #!key
9a90: 28 77 6f 72 6b 2d 61 72 65 61 20 23 66 29 29 20 (work-area #f))
9aa0: 0a 20 20 28 6d 72 6d 74 3a 73 65 6e 64 2d 72 65 . (mrmt:send-re
9ab0: 63 65 69 76 65 20 27 72 65 61 64 2d 74 65 73 74 ceive 'read-test
9ac0: 2d 64 61 74 61 20 72 75 6e 2d 69 64 20 28 6c 69 -data run-id (li
9ad0: 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 st run-id test-i
9ae0: 64 20 63 61 74 65 67 6f 72 79 70 61 74 74 29 29 d categorypatt))
9af0: 29 0a 28 64 65 66 69 6e 65 20 28 6d 72 6d 74 3a ).(define (mrmt:
9b00: 72 65 61 64 2d 74 65 73 74 2d 64 61 74 61 2a 20 read-test-data*
9b10: 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 63 run-id test-id c
9b20: 61 74 65 67 6f 72 79 70 61 74 74 20 76 61 72 70 ategorypatt varp
9b30: 61 74 74 20 23 21 6b 65 79 20 28 77 6f 72 6b 2d att #!key (work-
9b40: 61 72 65 61 20 23 66 29 29 20 0a 20 20 28 6d 72 area #f)) . (mr
9b50: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
9b60: 27 72 65 61 64 2d 74 65 73 74 2d 64 61 74 61 2a 'read-test-data*
9b70: 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 run-id (list ru
9b80: 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 63 61 74 n-id test-id cat
9b90: 65 67 6f 72 79 70 61 74 74 20 76 61 72 70 61 74 egorypatt varpat
9ba0: 74 29 29 29 0a 0a 3b 3b 20 20 20 28 6c 65 74 20 t)))..;; (let
9bb0: 28 28 74 64 62 20 20 28 6d 72 6d 74 3a 6f 70 65 ((tdb (mrmt:ope
9bc0: 6e 2d 74 65 73 74 2d 64 62 2d 62 79 2d 74 65 73 n-test-db-by-tes
9bd0: 74 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 t-id run-id test
9be0: 2d 69 64 20 77 6f 72 6b 2d 61 72 65 61 3a 20 77 -id work-area: w
9bf0: 6f 72 6b 2d 61 72 65 61 29 29 29 0a 3b 3b 20 20 ork-area))).;;
9c00: 20 20 20 28 69 66 20 74 64 62 0a 3b 3b 20 09 28 (if tdb.;; .(
9c10: 74 64 62 3a 72 65 61 64 2d 74 65 73 74 2d 64 61 tdb:read-test-da
9c20: 74 61 20 74 64 62 20 74 65 73 74 2d 69 64 20 63 ta tdb test-id c
9c30: 61 74 65 67 6f 72 79 70 61 74 74 29 0a 3b 3b 20 ategorypatt).;;
9c40: 09 27 28 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 .'())))..(define
9c50: 20 28 6d 72 6d 74 3a 74 65 73 74 6d 65 74 61 2d (mrmt:testmeta-
9c60: 61 64 64 2d 72 65 63 6f 72 64 20 74 65 73 74 6e add-record testn
9c70: 61 6d 65 29 0a 20 20 28 6d 72 6d 74 3a 73 65 6e ame). (mrmt:sen
9c80: 64 2d 72 65 63 65 69 76 65 20 27 74 65 73 74 6d d-receive 'testm
9c90: 65 74 61 2d 61 64 64 2d 72 65 63 6f 72 64 20 23 eta-add-record #
9ca0: 66 20 28 6c 69 73 74 20 74 65 73 74 6e 61 6d 65 f (list testname
9cb0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 6d 72 )))..(define (mr
9cc0: 6d 74 3a 74 65 73 74 6d 65 74 61 2d 67 65 74 2d mt:testmeta-get-
9cd0: 72 65 63 6f 72 64 20 74 65 73 74 6e 61 6d 65 29 record testname)
9ce0: 0a 20 20 28 6d 72 6d 74 3a 73 65 6e 64 2d 72 65 . (mrmt:send-re
9cf0: 63 65 69 76 65 20 27 74 65 73 74 6d 65 74 61 2d ceive 'testmeta-
9d00: 67 65 74 2d 72 65 63 6f 72 64 20 23 66 20 28 6c get-record #f (l
9d10: 69 73 74 20 74 65 73 74 6e 61 6d 65 29 29 29 0a ist testname))).
9d20: 0a 28 64 65 66 69 6e 65 20 28 6d 72 6d 74 3a 74 .(define (mrmt:t
9d30: 65 73 74 6d 65 74 61 2d 75 70 64 61 74 65 2d 66 estmeta-update-f
9d40: 69 65 6c 64 20 74 65 73 74 2d 6e 61 6d 65 20 66 ield test-name f
9d50: 6c 64 20 76 61 6c 29 0a 20 20 28 6d 72 6d 74 3a ld val). (mrmt:
9d60: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 74 65 send-receive 'te
9d70: 73 74 6d 65 74 61 2d 75 70 64 61 74 65 2d 66 69 stmeta-update-fi
9d80: 65 6c 64 20 23 66 20 28 6c 69 73 74 20 74 65 73 eld #f (list tes
9d90: 74 2d 6e 61 6d 65 20 66 6c 64 20 76 61 6c 29 29 t-name fld val))
9da0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 6d 72 6d 74 )..(define (mrmt
9db0: 3a 74 65 73 74 2d 64 61 74 61 2d 72 6f 6c 6c 75 :test-data-rollu
9dc0: 70 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 p run-id test-id
9dd0: 20 73 74 61 74 75 73 29 0a 20 20 28 6d 72 6d 74 status). (mrmt
9de0: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 74 :send-receive 't
9df0: 65 73 74 2d 64 61 74 61 2d 72 6f 6c 6c 75 70 20 est-data-rollup
9e00: 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e run-id (list run
9e10: 2d 69 64 20 74 65 73 74 2d 69 64 20 73 74 61 74 -id test-id stat
9e20: 75 73 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 us)))..(define (
9e30: 6d 72 6d 74 3a 63 73 76 2d 3e 74 65 73 74 2d 64 mrmt:csv->test-d
9e40: 61 74 61 20 72 75 6e 2d 69 64 20 74 65 73 74 2d ata run-id test-
9e50: 69 64 20 63 73 76 64 61 74 61 29 0a 20 20 28 6d id csvdata). (m
9e60: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
9e70: 20 27 63 73 76 2d 3e 74 65 73 74 2d 64 61 74 61 'csv->test-data
9e80: 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 run-id (list ru
9e90: 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 63 73 76 n-id test-id csv
9ea0: 64 61 74 61 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d data)))..;;=====
9eb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9ec0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9ed0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9ee0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9ef0: 3d 0a 3b 3b 20 20 54 20 41 20 53 20 4b 20 53 0a =.;; T A S K S.
9f00: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
9f10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9f20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9f30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9f40: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e ========..(defin
9f50: 65 20 28 6d 72 6d 74 3a 74 61 73 6b 73 2d 66 69 e (mrmt:tasks-fi
9f60: 6e 64 2d 74 61 73 6b 2d 71 75 65 75 65 2d 72 65 nd-task-queue-re
9f70: 63 6f 72 64 73 20 74 61 72 67 65 74 20 72 75 6e cords target run
9f80: 2d 6e 61 6d 65 20 74 65 73 74 2d 70 61 74 74 20 -name test-patt
9f90: 73 74 61 74 65 2d 70 61 74 74 20 61 63 74 69 6f state-patt actio
9fa0: 6e 2d 70 61 74 74 29 0a 20 20 28 6d 72 6d 74 3a n-patt). (mrmt:
9fb0: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 66 69 send-receive 'fi
9fc0: 6e 64 2d 74 61 73 6b 2d 71 75 65 75 65 2d 72 65 nd-task-queue-re
9fd0: 63 6f 72 64 73 20 23 66 20 28 6c 69 73 74 20 74 cords #f (list t
9fe0: 61 72 67 65 74 20 72 75 6e 2d 6e 61 6d 65 20 74 arget run-name t
9ff0: 65 73 74 2d 70 61 74 74 20 73 74 61 74 65 2d 70 est-patt state-p
a000: 61 74 74 20 61 63 74 69 6f 6e 2d 70 61 74 74 29 att action-patt)
a010: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 6d 72 6d ))..(define (mrm
a020: 74 3a 74 61 73 6b 73 2d 61 64 64 20 61 63 74 69 t:tasks-add acti
a030: 6f 6e 20 6f 77 6e 65 72 20 74 61 72 67 65 74 20 on owner target
a040: 72 75 6e 6e 61 6d 65 20 74 65 73 74 70 61 74 74 runname testpatt
a050: 20 70 61 72 61 6d 73 29 0a 20 20 28 6d 72 6d 74 params). (mrmt
a060: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 74 :send-receive 't
a070: 61 73 6b 73 2d 61 64 64 20 23 66 20 28 6c 69 73 asks-add #f (lis
a080: 74 20 61 63 74 69 6f 6e 20 6f 77 6e 65 72 20 74 t action owner t
a090: 61 72 67 65 74 20 72 75 6e 6e 61 6d 65 20 74 65 arget runname te
a0a0: 73 74 70 61 74 74 20 70 61 72 61 6d 73 29 29 29 stpatt params)))
a0b0: 0a 0a 28 64 65 66 69 6e 65 20 28 6d 72 6d 74 3a ..(define (mrmt:
a0c0: 74 61 73 6b 73 2d 73 65 74 2d 73 74 61 74 65 2d tasks-set-state-
a0d0: 67 69 76 65 6e 2d 70 61 72 61 6d 2d 6b 65 79 20 given-param-key
a0e0: 70 61 72 61 6d 2d 6b 65 79 20 6e 65 77 2d 73 74 param-key new-st
a0f0: 61 74 65 29 0a 20 20 28 6d 72 6d 74 3a 73 65 6e ate). (mrmt:sen
a100: 64 2d 72 65 63 65 69 76 65 20 27 74 61 73 6b 73 d-receive 'tasks
a110: 2d 73 65 74 2d 73 74 61 74 65 2d 67 69 76 65 6e -set-state-given
a120: 2d 70 61 72 61 6d 2d 6b 65 79 20 23 66 20 28 6c -param-key #f (l
a130: 69 73 74 20 20 70 61 72 61 6d 2d 6b 65 79 20 6e ist param-key n
a140: 65 77 2d 73 74 61 74 65 29 29 29 0a 0a 28 64 65 ew-state)))..(de
a150: 66 69 6e 65 20 28 6d 72 6d 74 3a 74 61 73 6b 73 fine (mrmt:tasks
a160: 2d 67 65 74 2d 6c 61 73 74 20 74 61 72 67 65 74 -get-last target
a170: 20 72 75 6e 6e 61 6d 65 29 0a 20 20 28 6d 72 6d runname). (mrm
a180: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
a190: 74 61 73 6b 73 2d 67 65 74 2d 6c 61 73 74 20 23 tasks-get-last #
a1a0: 66 20 28 6c 69 73 74 20 74 61 72 67 65 74 20 72 f (list target r
a1b0: 75 6e 6e 61 6d 65 29 29 29 0a 0a 3b 3b 3d 3d 3d unname)))..;;===
a1c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a1d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a1e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a1f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a200: 3d 3d 3d 0a 3b 3b 20 4e 20 4f 20 20 20 53 20 59 ===.;; N O S Y
a210: 20 4e 20 43 20 20 20 44 20 42 20 0a 3b 3b 3d 3d N C D B .;;==
a220: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a230: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a240: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a250: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a260: 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 6d ====..(define (m
a270: 72 6d 74 3a 6e 6f 2d 73 79 6e 63 2d 73 65 74 20 rmt:no-sync-set
a280: 76 61 72 20 76 61 6c 29 0a 20 20 28 6d 72 6d 74 var val). (mrmt
a290: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 6e :send-receive 'n
a2a0: 6f 2d 73 79 6e 63 2d 73 65 74 20 23 66 20 60 28 o-sync-set #f `(
a2b0: 2c 76 61 72 20 2c 76 61 6c 29 29 29 0a 0a 28 64 ,var ,val)))..(d
a2c0: 65 66 69 6e 65 20 28 6d 72 6d 74 3a 6e 6f 2d 73 efine (mrmt:no-s
a2d0: 79 6e 63 2d 67 65 74 2f 64 65 66 61 75 6c 74 20 ync-get/default
a2e0: 76 61 72 20 64 65 66 61 75 6c 74 29 0a 20 20 28 var default). (
a2f0: 6d 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 mrmt:send-receiv
a300: 65 20 27 6e 6f 2d 73 79 6e 63 2d 67 65 74 2f 64 e 'no-sync-get/d
a310: 65 66 61 75 6c 74 20 23 66 20 60 28 2c 76 61 72 efault #f `(,var
a320: 20 2c 64 65 66 61 75 6c 74 29 29 29 0a 0a 28 64 ,default)))..(d
a330: 65 66 69 6e 65 20 28 6d 72 6d 74 3a 6e 6f 2d 73 efine (mrmt:no-s
a340: 79 6e 63 2d 64 65 6c 21 20 76 61 72 29 0a 20 20 ync-del! var).
a350: 28 6d 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (mrmt:send-recei
a360: 76 65 20 27 6e 6f 2d 73 79 6e 63 2d 64 65 6c 21 ve 'no-sync-del!
a370: 20 23 66 20 60 28 2c 76 61 72 29 29 29 0a 0a 28 #f `(,var)))..(
a380: 64 65 66 69 6e 65 20 28 6d 72 6d 74 3a 6e 6f 2d define (mrmt:no-
a390: 73 79 6e 63 2d 67 65 74 2d 6c 6f 63 6b 20 6b 65 sync-get-lock ke
a3a0: 79 6e 61 6d 65 29 0a 20 20 28 6d 72 6d 74 3a 73 yname). (mrmt:s
a3b0: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 6e 6f 2d end-receive 'no-
a3c0: 73 79 6e 63 2d 67 65 74 2d 6c 6f 63 6b 20 23 66 sync-get-lock #f
a3d0: 20 60 28 2c 6b 65 79 6e 61 6d 65 29 29 29 0a 0a `(,keyname)))..
a3e0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
a3f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a400: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a410: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a420: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 41 20 52 20 ========.;; A R
a430: 43 20 48 20 49 20 56 20 45 20 53 0a 3b 3b 3d 3d C H I V E S.;;==
a440: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a450: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a460: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a470: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a480: 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 6d ====..(define (m
a490: 72 6d 74 3a 61 72 63 68 69 76 65 2d 67 65 74 2d rmt:archive-get-
a4a0: 61 6c 6c 6f 63 61 74 69 6f 6e 73 20 20 74 65 73 allocations tes
a4b0: 74 6e 61 6d 65 20 69 74 65 6d 70 61 74 68 20 64 tname itempath d
a4c0: 6e 65 65 64 65 64 29 0a 20 20 28 6d 72 6d 74 3a needed). (mrmt:
a4d0: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 61 72 send-receive 'ar
a4e0: 63 68 69 76 65 2d 67 65 74 2d 61 6c 6c 6f 63 61 chive-get-alloca
a4f0: 74 69 6f 6e 73 20 23 66 20 28 6c 69 73 74 20 74 tions #f (list t
a500: 65 73 74 6e 61 6d 65 20 69 74 65 6d 70 61 74 68 estname itempath
a510: 20 64 6e 65 65 64 65 64 29 29 29 0a 0a 28 64 65 dneeded)))..(de
a520: 66 69 6e 65 20 28 6d 72 6d 74 3a 61 72 63 68 69 fine (mrmt:archi
a530: 76 65 2d 72 65 67 69 73 74 65 72 2d 62 6c 6f 63 ve-register-bloc
a540: 6b 2d 6e 61 6d 65 20 62 64 69 73 6b 2d 69 64 20 k-name bdisk-id
a550: 61 72 63 68 69 76 65 2d 70 61 74 68 29 0a 20 20 archive-path).
a560: 28 6d 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (mrmt:send-recei
a570: 76 65 20 27 61 72 63 68 69 76 65 2d 72 65 67 69 ve 'archive-regi
a580: 73 74 65 72 2d 62 6c 6f 63 6b 2d 6e 61 6d 65 20 ster-block-name
a590: 23 66 20 28 6c 69 73 74 20 62 64 69 73 6b 2d 69 #f (list bdisk-i
a5a0: 64 20 61 72 63 68 69 76 65 2d 70 61 74 68 29 29 d archive-path))
a5b0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 6d 72 6d 74 )..(define (mrmt
a5c0: 3a 61 72 63 68 69 76 65 2d 61 6c 6c 6f 63 61 74 :archive-allocat
a5d0: 65 2d 74 65 73 74 73 75 69 74 65 2f 61 72 65 61 e-testsuite/area
a5e0: 2d 74 6f 2d 62 6c 6f 63 6b 20 62 6c 6f 63 6b 2d -to-block block-
a5f0: 69 64 20 74 65 73 74 73 75 69 74 65 2d 6e 61 6d id testsuite-nam
a600: 65 20 61 72 65 61 6b 65 79 29 0a 20 20 28 6d 72 e areakey). (mr
a610: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
a620: 27 61 72 63 68 69 76 65 2d 61 6c 6c 6f 63 61 74 'archive-allocat
a630: 65 2d 74 65 73 74 2d 74 6f 2d 62 6c 6f 63 6b 20 e-test-to-block
a640: 23 66 20 28 6c 69 73 74 20 20 62 6c 6f 63 6b 2d #f (list block-
a650: 69 64 20 74 65 73 74 73 75 69 74 65 2d 6e 61 6d id testsuite-nam
a660: 65 20 61 72 65 61 6b 65 79 29 29 29 0a 0a 28 64 e areakey)))..(d
a670: 65 66 69 6e 65 20 28 6d 72 6d 74 3a 61 72 63 68 efine (mrmt:arch
a680: 69 76 65 2d 72 65 67 69 73 74 65 72 2d 64 69 73 ive-register-dis
a690: 6b 20 62 64 69 73 6b 2d 6e 61 6d 65 20 62 64 69 k bdisk-name bdi
a6a0: 73 6b 2d 70 61 74 68 20 64 66 29 0a 20 20 28 6d sk-path df). (m
a6b0: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
a6c0: 20 27 61 72 63 68 69 76 65 2d 72 65 67 69 73 74 'archive-regist
a6d0: 65 72 2d 64 69 73 6b 20 23 66 20 28 6c 69 73 74 er-disk #f (list
a6e0: 20 62 64 69 73 6b 2d 6e 61 6d 65 20 62 64 69 73 bdisk-name bdis
a6f0: 6b 2d 70 61 74 68 20 64 66 29 29 29 0a 0a 28 64 k-path df)))..(d
a700: 65 66 69 6e 65 20 28 6d 72 6d 74 3a 74 65 73 74 efine (mrmt:test
a710: 2d 73 65 74 2d 61 72 63 68 69 76 65 2d 62 6c 6f -set-archive-blo
a720: 63 6b 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 ck-id run-id tes
a730: 74 2d 69 64 20 61 72 63 68 69 76 65 2d 62 6c 6f t-id archive-blo
a740: 63 6b 2d 69 64 29 0a 20 20 28 6d 72 6d 74 3a 73 ck-id). (mrmt:s
a750: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 74 65 73 end-receive 'tes
a760: 74 2d 73 65 74 2d 61 72 63 68 69 76 65 2d 62 6c t-set-archive-bl
a770: 6f 63 6b 2d 69 64 20 72 75 6e 2d 69 64 20 28 6c ock-id run-id (l
a780: 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d ist run-id test-
a790: 69 64 20 61 72 63 68 69 76 65 2d 62 6c 6f 63 6b id archive-block
a7a0: 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 -id)))..(define
a7b0: 28 6d 72 6d 74 3a 74 65 73 74 2d 67 65 74 2d 61 (mrmt:test-get-a
a7c0: 72 63 68 69 76 65 2d 62 6c 6f 63 6b 2d 69 6e 66 rchive-block-inf
a7d0: 6f 20 61 72 63 68 69 76 65 2d 62 6c 6f 63 6b 2d o archive-block-
a7e0: 69 64 29 0a 20 20 28 6d 72 6d 74 3a 73 65 6e 64 id). (mrmt:send
a7f0: 2d 72 65 63 65 69 76 65 20 27 74 65 73 74 2d 67 -receive 'test-g
a800: 65 74 2d 61 72 63 68 69 76 65 2d 62 6c 6f 63 6b et-archive-block
a810: 2d 69 6e 66 6f 20 23 66 20 28 6c 69 73 74 20 61 -info #f (list a
a820: 72 63 68 69 76 65 2d 62 6c 6f 63 6b 2d 69 64 29 rchive-block-id)
a830: 29 29 0a )).