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 72 6d 74 29 29 lare (unit rmt))
0230: 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 .(declare (uses
0240: 61 70 69 29 29 0a 28 64 65 63 6c 61 72 65 20 28 api)).(declare (
0250: 75 73 65 73 20 74 64 62 29 29 0a 28 64 65 63 6c uses tdb)).(decl
0260: 61 72 65 20 28 75 73 65 73 20 68 74 74 70 2d 74 are (uses http-t
0270: 72 61 6e 73 70 6f 72 74 29 29 0a 3b 3b 28 64 65 ransport)).;;(de
0280: 63 6c 61 72 65 20 28 75 73 65 73 20 6e 6d 73 67 clare (uses nmsg
0290: 2d 74 72 61 6e 73 70 6f 72 74 29 29 0a 28 69 6e -transport)).(in
02a0: 63 6c 75 64 65 20 22 63 6f 6d 6d 6f 6e 5f 72 65 clude "common_re
02b0: 63 6f 72 64 73 2e 73 63 6d 22 29 0a 0a 3b 3b 0a cords.scm")..;;.
02c0: 3b 3b 20 54 48 45 53 45 20 41 52 45 20 41 4c 4c ;; THESE ARE ALL
02d0: 20 43 41 4c 4c 45 44 20 4f 4e 20 54 48 45 20 43 CALLED ON THE C
02e0: 4c 49 45 4e 54 20 53 49 44 45 21 21 21 0a 3b 3b LIENT SIDE!!!.;;
02f0: 0a 0a 3b 3b 20 67 65 6e 65 72 61 74 65 20 65 6e ..;; generate en
0300: 74 72 69 65 73 20 66 6f 72 20 7e 2f 2e 6d 65 67 tries for ~/.meg
0310: 61 74 65 73 74 72 63 20 77 69 74 68 20 74 68 65 atestrc with the
0320: 20 66 6f 6c 6c 6f 77 69 6e 67 0a 3b 3b 0a 3b 3b following.;;.;;
0330: 20 20 67 72 65 70 20 64 65 66 69 6e 65 20 2e 2e grep define ..
0340: 2f 72 6d 74 2e 73 63 6d 20 7c 20 67 72 65 70 20 /rmt.scm | grep
0350: 72 6d 74 3a 20 7c 70 65 72 6c 20 2d 70 69 20 2d rmt: |perl -pi -
0360: 65 20 27 73 2f 5c 28 64 65 66 69 6e 65 5c 73 2b e 's/\(define\s+
0370: 5c 28 28 5c 53 2b 29 5c 57 2e 2a 24 2f 5c 31 2f \((\S+)\W.*$/\1/
0380: 27 7c 73 6f 72 74 20 2d 75 0a 0a 3b 3b 3d 3d 3d '|sort -u..;;===
0390: 3d 3d 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 0a 3b 3b 20 20 53 20 55 20 50 20 50 20 ===.;; S U P P
03e0: 4f 20 52 20 54 20 20 20 46 20 55 20 4e 20 43 20 O R T F U N C
03f0: 54 20 49 20 4f 20 4e 20 53 0a 3b 3b 3d 3d 3d 3d T I O N S.;;====
0400: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0410: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0420: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 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 0a 0a 3b 3b 20 69 66 20 61 20 73 65 72 76 ==..;; if a serv
0450: 65 72 20 69 73 20 65 69 74 68 65 72 20 72 75 6e er is either run
0460: 6e 69 6e 67 20 6f 72 20 69 6e 20 74 68 65 20 70 ning or in the p
0470: 72 6f 63 65 73 73 20 6f 66 20 73 74 61 72 74 69 rocess of starti
0480: 6e 67 20 63 61 6c 6c 20 63 6c 69 65 6e 74 3a 73 ng call client:s
0490: 65 74 75 70 0a 3b 3b 20 65 6c 73 65 20 72 65 74 etup.;; else ret
04a0: 75 72 6e 20 23 66 20 74 6f 20 6c 65 74 20 74 68 urn #f to let th
04b0: 65 20 63 61 6c 6c 69 6e 67 20 70 72 6f 63 20 6b e calling proc k
04c0: 6e 6f 77 20 74 68 61 74 20 74 68 65 72 65 20 69 now that there i
04d0: 73 20 6e 6f 20 73 65 72 76 65 72 20 61 76 61 69 s no server avai
04e0: 6c 61 62 6c 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 lable.;;.(define
04f0: 20 28 72 6d 74 3a 67 65 74 2d 63 6f 6e 6e 65 63 (rmt:get-connec
0500: 74 69 6f 6e 2d 69 6e 66 6f 20 61 72 65 61 70 61 tion-info areapa
0510: 74 68 20 23 21 6b 65 79 20 28 61 72 65 61 2d 64 th #!key (area-d
0520: 61 74 20 23 66 29 29 20 3b 3b 20 54 4f 44 4f 3a at #f)) ;; TODO:
0530: 20 70 75 73 68 20 61 72 65 61 70 61 74 68 20 64 push areapath d
0540: 6f 77 6e 2e 0a 20 20 28 6c 65 74 2a 20 28 28 72 own.. (let* ((r
0550: 75 6e 72 65 6d 6f 74 65 20 28 6f 72 20 61 72 65 unremote (or are
0560: 61 2d 64 61 74 20 2a 72 75 6e 72 65 6d 6f 74 65 a-dat *runremote
0570: 2a 29 29 0a 09 20 28 63 69 6e 66 6f 20 20 20 20 *)).. (cinfo
0580: 20 28 69 66 20 28 72 65 6d 6f 74 65 3f 20 72 75 (if (remote? ru
0590: 6e 72 65 6d 6f 74 65 29 0a 09 09 09 28 72 65 6d nremote)....(rem
05a0: 6f 74 65 2d 63 6f 6e 6e 64 61 74 20 72 75 6e 72 ote-conndat runr
05b0: 65 6d 6f 74 65 29 0a 09 09 09 23 66 29 29 29 0a emote)....#f))).
05c0: 09 20 20 28 69 66 20 63 69 6e 66 6f 0a 09 20 20 . (if cinfo..
05d0: 20 20 20 20 63 69 6e 66 6f 0a 09 20 20 20 20 20 cinfo..
05e0: 20 28 69 66 20 28 73 65 72 76 65 72 3a 63 68 65 (if (server:che
05f0: 63 6b 2d 69 66 2d 72 75 6e 6e 69 6e 67 20 61 72 ck-if-running ar
0600: 65 61 70 61 74 68 29 0a 09 09 20 20 28 63 6c 69 eapath)... (cli
0610: 65 6e 74 3a 73 65 74 75 70 20 61 72 65 61 70 61 ent:setup areapa
0620: 74 68 29 0a 09 09 20 20 23 66 29 29 29 29 0a 0a th)... #f))))..
0630: 28 64 65 66 69 6e 65 20 2a 73 65 6e 64 2d 72 65 (define *send-re
0640: 63 65 69 76 65 2d 6d 75 74 65 78 2a 20 28 6d 61 ceive-mutex* (ma
0650: 6b 65 2d 6d 75 74 65 78 29 29 20 3b 3b 20 73 68 ke-mutex)) ;; sh
0660: 6f 75 6c 64 20 68 61 76 65 20 73 65 70 61 72 61 ould have separa
0670: 74 65 20 6d 75 74 65 78 20 70 65 72 20 72 75 6e te mutex per run
0680: 2d 69 64 0a 0a 3b 3b 20 52 41 20 3d 3e 20 65 2e -id..;; RA => e.
0690: 67 2e 20 75 73 61 67 65 20 28 72 6d 74 3a 73 65 g. usage (rmt:se
06a0: 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d nd-receive 'get-
06b0: 76 61 72 20 23 66 20 28 6c 69 73 74 20 76 61 72 var #f (list var
06c0: 6e 61 6d 65 29 29 0a 3b 3b 0a 28 64 65 66 69 6e name)).;;.(defin
06d0: 65 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 e (rmt:send-rece
06e0: 69 76 65 20 63 6d 64 20 72 69 64 20 70 61 72 61 ive cmd rid para
06f0: 6d 73 20 23 21 6b 65 79 20 28 61 74 74 65 6d 70 ms #!key (attemp
0700: 74 6e 75 6d 20 31 29 28 61 72 65 61 2d 64 61 74 tnum 1)(area-dat
0710: 20 23 66 29 29 20 3b 3b 20 73 74 61 72 74 20 61 #f)) ;; start a
0720: 74 74 65 6d 70 74 6e 75 6d 20 61 74 20 31 20 73 ttemptnum at 1 s
0730: 6f 20 74 68 65 20 6d 6f 64 75 6c 6f 20 62 65 6c o the modulo bel
0740: 6f 77 20 77 6f 72 6b 73 20 61 73 20 65 78 70 65 ow works as expe
0750: 63 74 65 64 0a 0a 20 20 3b 3b 44 4f 54 20 64 69 cted.. ;;DOT di
0760: 67 72 61 70 68 20 6d 65 67 61 74 65 73 74 5f 73 graph megatest_s
0770: 74 61 74 65 5f 73 74 61 74 75 73 20 7b 0a 20 20 tate_status {.
0780: 3b 3b 44 4f 54 20 20 20 72 61 6e 6b 73 65 70 3d ;;DOT ranksep=
0790: 30 3b 0a 20 20 3b 3b 44 4f 54 20 20 20 2f 2f 20 0;. ;;DOT //
07a0: 72 61 6e 6b 64 69 72 3d 4c 52 3b 0a 20 20 3b 3b rankdir=LR;. ;;
07b0: 44 4f 54 20 20 20 6e 6f 64 65 20 5b 73 68 61 70 DOT node [shap
07c0: 65 3d 22 62 6f 78 22 5d 3b 0a 20 20 3b 3b 44 4f e="box"];. ;;DO
07d0: 54 20 22 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 T "rmt:send-rece
07e0: 69 76 65 22 20 2d 3e 20 4d 55 54 45 58 4c 4f 43 ive" -> MUTEXLOC
07f0: 4b 3b 0a 20 20 3b 3b 44 4f 54 20 7b 20 65 64 67 K;. ;;DOT { edg
0800: 65 20 5b 73 74 79 6c 65 3d 69 6e 76 69 73 5d 3b e [style=invis];
0810: 22 63 61 73 65 20 31 22 20 2d 3e 20 22 63 61 73 "case 1" -> "cas
0820: 65 20 32 22 20 2d 3e 20 22 63 61 73 65 20 33 22 e 2" -> "case 3"
0830: 20 2d 3e 20 22 63 61 73 65 20 34 22 20 2d 3e 20 -> "case 4" ->
0840: 22 63 61 73 65 20 35 22 20 2d 3e 20 22 63 61 73 "case 5" -> "cas
0850: 65 20 36 22 20 2d 3e 20 22 63 61 73 65 20 37 22 e 6" -> "case 7"
0860: 20 2d 3e 20 22 63 61 73 65 20 38 22 20 2d 3e 20 -> "case 8" ->
0870: 22 63 61 73 65 20 39 22 20 2d 3e 20 22 63 61 73 "case 9" -> "cas
0880: 65 20 31 30 22 20 2d 3e 20 22 63 61 73 65 20 31 e 10" -> "case 1
0890: 31 22 3b 20 7d 0a 20 20 3b 3b 20 64 6f 20 61 6c 1"; }. ;; do al
08a0: 6c 20 74 68 65 20 70 72 65 70 20 6c 6f 63 6b 65 l the prep locke
08b0: 64 20 75 6e 64 65 72 20 74 68 65 20 72 6d 74 2d d under the rmt-
08c0: 6d 75 74 65 78 0a 20 20 28 6d 75 74 65 78 2d 6c mutex. (mutex-l
08d0: 6f 63 6b 21 20 2a 72 6d 74 2d 6d 75 74 65 78 2a ock! *rmt-mutex*
08e0: 29 0a 20 20 0a 20 20 3b 3b 20 31 2e 20 63 68 65 ). . ;; 1. che
08f0: 63 6b 20 69 66 20 73 65 72 76 65 72 20 69 73 20 ck if server is
0900: 73 74 61 72 74 65 64 20 49 46 46 20 63 6d 64 20 started IFF cmd
0910: 69 73 20 61 20 77 72 69 74 65 20 4f 52 20 69 66 is a write OR if
0920: 20 77 65 20 61 72 65 20 6e 6f 74 20 6f 6e 20 74 we are not on t
0930: 68 65 20 68 6f 6d 65 68 6f 73 74 2c 20 73 74 6f he homehost, sto
0940: 72 65 20 69 6e 20 72 75 6e 72 65 6d 6f 74 65 0a re in runremote.
0950: 20 20 3b 3b 20 32 2e 20 63 68 65 63 6b 20 74 68 ;; 2. check th
0960: 65 20 61 67 65 20 6f 66 20 74 68 65 20 63 6f 6e e age of the con
0970: 6e 65 63 74 69 6f 6e 73 2e 20 72 65 66 72 65 73 nections. refres
0980: 68 20 74 68 65 20 63 6f 6e 6e 65 63 74 69 6f 6e h the connection
0990: 20 69 66 20 69 74 20 69 73 20 6f 6c 64 65 72 20 if it is older
09a0: 74 68 61 6e 20 74 69 6d 65 6f 75 74 2d 32 30 20 than timeout-20
09b0: 73 65 63 6f 6e 64 73 2e 0a 20 20 3b 3b 20 33 2e seconds.. ;; 3.
09c0: 20 64 6f 20 74 68 65 20 71 75 65 72 79 2c 20 69 do the query, i
09d0: 66 20 6f 6e 20 68 6f 6d 65 68 6f 73 74 20 75 73 f on homehost us
09e0: 65 20 6c 6f 63 61 6c 20 61 63 63 65 73 73 0a 20 e local access.
09f0: 20 3b 3b 0a 20 20 28 6c 65 74 2a 20 28 28 73 74 ;;. (let* ((st
0a00: 61 72 74 2d 74 69 6d 65 20 20 20 20 28 63 75 72 art-time (cur
0a10: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 20 3b rent-seconds)) ;
0a20: 3b 20 73 6e 61 70 73 68 6f 74 20 74 69 6d 65 20 ; snapshot time
0a30: 73 6f 20 61 6c 6c 20 75 73 65 20 63 61 73 65 73 so all use cases
0a40: 20 67 65 74 20 73 61 6d 65 20 76 61 6c 75 65 0a get same value.
0a50: 20 20 20 20 20 20 20 20 20 28 61 72 65 61 70 61 (areapa
0a60: 74 68 20 20 20 20 20 20 2a 74 6f 70 70 61 74 68 th *toppath
0a70: 2a 29 3b 3b 20 54 4f 44 4f 20 2d 20 72 65 73 6f *);; TODO - reso
0a80: 6c 76 65 20 66 72 6f 6d 20 64 62 73 74 72 75 63 lve from dbstruc
0a90: 74 20 74 6f 20 62 65 20 63 6f 6d 70 61 74 69 62 t to be compatib
0aa0: 6c 65 20 77 69 74 68 20 6d 75 6c 74 69 70 6c 65 le with multiple
0ab0: 20 61 72 65 61 73 0a 09 20 28 72 75 6e 72 65 6d areas.. (runrem
0ac0: 6f 74 65 20 20 20 20 20 28 6f 72 20 61 72 65 61 ote (or area
0ad0: 2d 64 61 74 0a 09 09 09 20 20 20 20 2a 72 75 6e -dat.... *run
0ae0: 72 65 6d 6f 74 65 2a 29 29 0a 09 20 28 72 65 61 remote*)).. (rea
0af0: 64 6f 6e 6c 79 2d 6d 6f 64 65 20 28 69 66 20 28 donly-mode (if (
0b00: 61 6e 64 20 72 75 6e 72 65 6d 6f 74 65 0a 09 09 and runremote...
0b10: 09 09 20 28 72 65 6d 6f 74 65 2d 72 6f 2d 6d 6f .. (remote-ro-mo
0b20: 64 65 2d 63 68 65 63 6b 65 64 20 72 75 6e 72 65 de-checked runre
0b30: 6d 6f 74 65 29 29 0a 09 09 09 20 20 20 20 28 72 mote)).... (r
0b40: 65 6d 6f 74 65 2d 72 6f 2d 6d 6f 64 65 20 72 75 emote-ro-mode ru
0b50: 6e 72 65 6d 6f 74 65 29 0a 09 09 09 20 20 20 20 nremote)....
0b60: 28 6c 65 74 2a 20 28 28 64 62 66 69 6c 65 20 20 (let* ((dbfile
0b70: 28 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 (conc *toppath*
0b80: 22 2f 6d 65 67 61 74 65 73 74 2e 64 62 22 29 29 "/megatest.db"))
0b90: 0a 09 09 09 09 20 20 20 28 72 6f 2d 6d 6f 64 65 ..... (ro-mode
0ba0: 20 28 6e 6f 74 20 28 66 69 6c 65 2d 77 72 69 74 (not (file-writ
0bb0: 65 2d 61 63 63 65 73 73 3f 20 64 62 66 69 6c 65 e-access? dbfile
0bc0: 29 29 29 29 20 3b 3b 20 54 4f 44 4f 3a 20 75 73 )))) ;; TODO: us
0bd0: 65 20 64 62 73 74 72 75 63 74 20 6f 72 20 72 75 e dbstruct or ru
0be0: 6e 72 65 6d 6f 74 65 20 74 6f 20 66 69 67 75 72 nremote to figur
0bf0: 65 20 74 68 69 73 20 6f 75 74 20 69 6e 20 66 75 e this out in fu
0c00: 74 75 72 65 0a 09 09 09 20 20 20 20 20 20 28 69 ture.... (i
0c10: 66 20 72 75 6e 72 65 6d 6f 74 65 0a 09 09 09 09 f runremote.....
0c20: 20 20 28 62 65 67 69 6e 0a 09 09 09 09 20 20 20 (begin.....
0c30: 20 28 72 65 6d 6f 74 65 2d 72 6f 2d 6d 6f 64 65 (remote-ro-mode
0c40: 2d 73 65 74 21 20 72 75 6e 72 65 6d 6f 74 65 20 -set! runremote
0c50: 72 6f 2d 6d 6f 64 65 29 0a 09 09 09 09 20 20 20 ro-mode).....
0c60: 20 28 72 65 6d 6f 74 65 2d 72 6f 2d 6d 6f 64 65 (remote-ro-mode
0c70: 2d 63 68 65 63 6b 65 64 2d 73 65 74 21 20 72 75 -checked-set! ru
0c80: 6e 72 65 6d 6f 74 65 20 23 74 29 0a 09 09 09 09 nremote #t).....
0c90: 20 20 20 20 72 6f 2d 6d 6f 64 65 29 0a 09 09 09 ro-mode)....
0ca0: 09 20 20 72 6f 2d 6d 6f 64 65 29 29 29 29 29 0a . ro-mode))))).
0cb0: 0a 20 20 20 20 3b 3b 20 44 4f 54 20 49 4e 49 54 . ;; DOT INIT
0cc0: 5f 52 55 4e 52 45 4d 4f 54 45 3b 20 2f 2f 20 6c _RUNREMOTE; // l
0cd0: 65 61 76 69 6e 67 20 6f 66 66 20 2d 20 64 6f 65 eaving off - doe
0ce0: 73 6e 27 74 20 72 65 61 6c 6c 79 20 61 64 64 20 sn't really add
0cf0: 74 6f 20 74 68 65 20 63 6c 61 72 69 74 79 0a 20 to the clarity.
0d00: 20 20 20 3b 3b 20 44 4f 54 20 4d 55 54 45 58 4c ;; DOT MUTEXL
0d10: 4f 43 4b 20 2d 3e 20 49 4e 49 54 5f 52 55 4e 52 OCK -> INIT_RUNR
0d20: 45 4d 4f 54 45 20 5b 6c 61 62 65 6c 3d 22 6e 6f EMOTE [label="no
0d30: 20 72 65 6d 6f 74 65 3f 22 5d 3b 0a 20 20 20 20 remote?"];.
0d40: 3b 3b 20 44 4f 54 20 49 4e 49 54 5f 52 55 4e 52 ;; DOT INIT_RUNR
0d50: 45 4d 4f 54 45 20 2d 3e 20 4d 55 54 45 58 4c 4f EMOTE -> MUTEXLO
0d60: 43 4b 3b 0a 20 20 20 20 3b 3b 20 65 6e 73 75 72 CK;. ;; ensur
0d70: 65 20 77 65 20 68 61 76 65 20 61 20 72 65 63 6f e we have a reco
0d80: 72 64 20 66 6f 72 20 6f 75 72 20 63 6f 6e 6e 65 rd for our conne
0d90: 63 74 69 6f 6e 20 66 6f 72 20 67 69 76 65 6e 20 ction for given
0da0: 61 72 65 61 0a 20 20 20 20 28 69 66 20 28 6e 6f area. (if (no
0db0: 74 20 72 75 6e 72 65 6d 6f 74 65 29 20 20 20 20 t runremote)
0dc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
0dd0: 3b 20 63 61 6e 20 72 65 6d 6f 76 65 20 74 68 69 ; can remove thi
0de0: 73 20 6f 6e 65 2e 20 73 68 6f 75 6c 64 20 6e 65 s one. should ne
0df0: 76 65 72 20 67 65 74 20 68 65 72 65 2e 20 20 20 ver get here.
0e00: 20 20 20 20 20 20 0a 09 28 62 65 67 69 6e 0a 09 ..(begin..
0e10: 20 20 28 73 65 74 21 20 2a 72 75 6e 72 65 6d 6f (set! *runremo
0e20: 74 65 2a 20 28 6d 61 6b 65 2d 72 65 6d 6f 74 65 te* (make-remote
0e30: 29 29 0a 09 20 20 28 73 65 74 21 20 72 75 6e 72 )).. (set! runr
0e40: 65 6d 6f 74 65 20 20 20 2a 72 75 6e 72 65 6d 6f emote *runremo
0e50: 74 65 2a 29 29 29 20 3b 3b 20 6e 65 77 20 72 75 te*))) ;; new ru
0e60: 6e 72 65 6d 6f 74 65 20 77 69 6c 6c 20 63 6f 6d nremote will com
0e70: 65 20 66 72 6f 6d 20 74 68 69 73 20 6f 6e 20 6e e from this on n
0e80: 65 78 74 20 69 74 65 72 61 74 69 6f 6e 0a 20 20 ext iteration.
0e90: 20 20 0a 20 20 20 20 3b 3b 20 44 4f 54 20 53 45 . ;; DOT SE
0ea0: 54 5f 48 4f 4d 45 48 4f 53 54 3b 20 2f 2f 20 6c T_HOMEHOST; // l
0eb0: 65 61 76 69 6e 67 20 6f 66 66 20 2d 20 64 6f 65 eaving off - doe
0ec0: 73 6e 27 74 20 72 65 61 6c 6c 79 20 61 64 64 20 sn't really add
0ed0: 74 6f 20 74 68 65 20 63 6c 61 72 69 74 79 0a 20 to the clarity.
0ee0: 20 20 20 3b 3b 20 44 4f 54 20 4d 55 54 45 58 4c ;; DOT MUTEXL
0ef0: 4f 43 4b 20 2d 3e 20 53 45 54 5f 48 4f 4d 45 48 OCK -> SET_HOMEH
0f00: 4f 53 54 20 5b 6c 61 62 65 6c 3d 22 6e 6f 20 68 OST [label="no h
0f10: 6f 6d 65 68 6f 73 74 3f 22 5d 3b 0a 20 20 20 20 omehost?"];.
0f20: 3b 3b 20 44 4f 54 20 53 45 54 5f 48 4f 4d 45 48 ;; DOT SET_HOMEH
0f30: 4f 53 54 20 2d 3e 20 4d 55 54 45 58 4c 4f 43 4b OST -> MUTEXLOCK
0f40: 3b 0a 20 20 20 20 3b 3b 20 65 6e 73 75 72 65 20 ;. ;; ensure
0f50: 77 65 20 68 61 76 65 20 61 20 68 6f 6d 65 68 6f we have a homeho
0f60: 73 74 20 72 65 63 6f 72 64 0a 20 20 20 20 28 69 st record. (i
0f70: 66 20 28 6e 6f 74 20 28 70 61 69 72 3f 20 28 72 f (not (pair? (r
0f80: 65 6d 6f 74 65 2d 68 68 2d 64 61 74 20 72 75 6e emote-hh-dat run
0f90: 72 65 6d 6f 74 65 29 29 29 20 20 3b 3b 20 6e 6f remote))) ;; no
0fa0: 74 20 6f 6e 20 68 6f 6d 65 68 6f 73 74 0a 09 28 t on homehost..(
0fb0: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 2e thread-sleep! 0.
0fc0: 31 29 20 3b 3b 20 73 69 6e 63 65 20 77 65 20 73 1) ;; since we s
0fd0: 68 6f 75 6c 64 6e 27 74 20 67 65 74 20 68 65 72 houldn't get her
0fe0: 65 2c 20 64 65 6c 61 79 20 61 20 6c 69 74 74 6c e, delay a littl
0ff0: 65 0a 09 28 72 65 6d 6f 74 65 2d 68 68 2d 64 61 e..(remote-hh-da
1000: 74 2d 73 65 74 21 20 72 75 6e 72 65 6d 6f 74 65 t-set! runremote
1010: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 68 6f 6d (common:get-hom
1020: 65 68 6f 73 74 29 29 29 0a 20 20 20 20 0a 20 20 ehost))). .
1030: 20 20 3b 3b 28 70 72 69 6e 74 20 22 42 42 3e 20 ;;(print "BB>
1040: 72 65 61 64 6f 6e 6c 79 2d 6d 6f 64 65 20 69 73 readonly-mode is
1050: 20 22 72 65 61 64 6f 6e 6c 79 2d 6d 6f 64 65 22 "readonly-mode"
1060: 20 64 62 66 69 6c 65 20 69 73 20 22 64 62 66 69 dbfile is "dbfi
1070: 6c 65 29 0a 20 20 20 20 28 63 6f 6e 64 0a 20 20 le). (cond.
1080: 20 20 20 3b 3b 44 4f 54 20 45 58 49 54 3b 0a 20 ;;DOT EXIT;.
1090: 20 20 20 20 3b 3b 44 4f 54 20 4d 55 54 45 58 4c ;;DOT MUTEXL
10a0: 4f 43 4b 20 2d 3e 20 45 58 49 54 20 5b 6c 61 62 OCK -> EXIT [lab
10b0: 65 6c 3d 22 3e 20 31 35 20 61 74 74 65 6d 70 74 el="> 15 attempt
10c0: 73 22 5d 3b 20 7b 72 61 6e 6b 3d 73 61 6d 65 20 s"]; {rank=same
10d0: 22 63 61 73 65 20 31 22 20 22 45 58 49 54 22 20 "case 1" "EXIT"
10e0: 7d 0a 20 20 20 20 20 3b 3b 20 67 69 76 65 20 75 }. ;; give u
10f0: 70 20 69 66 20 6d 6f 72 65 20 74 68 61 6e 20 31 p if more than 1
1100: 35 20 61 74 74 65 6d 70 74 73 0a 20 20 20 20 20 5 attempts.
1110: 28 28 3e 20 61 74 74 65 6d 70 74 6e 75 6d 20 31 ((> attemptnum 1
1120: 35 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a 5). (debug:
1130: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
1140: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 52 52 4f -log-port* "ERRO
1150: 52 3a 20 31 35 20 74 72 69 65 73 20 74 6f 20 73 R: 15 tries to s
1160: 74 61 72 74 2f 63 6f 6e 6e 65 63 74 20 74 6f 20 tart/connect to
1170: 73 65 72 76 65 72 2e 20 47 69 76 69 6e 67 20 75 server. Giving u
1180: 70 2e 22 29 0a 20 20 20 20 20 20 28 65 78 69 74 p."). (exit
1190: 20 31 29 29 0a 0a 20 20 20 20 20 3b 3b 44 4f 54 1)).. ;;DOT
11a0: 20 43 41 53 45 32 20 5b 6c 61 62 65 6c 3d 22 6c CASE2 [label="l
11b0: 6f 63 61 6c 5c 6e 72 65 61 64 6f 6e 6c 79 5c 6e ocal\nreadonly\n
11c0: 71 75 65 72 79 22 5d 3b 0a 20 20 20 20 20 3b 3b query"];. ;;
11d0: 44 4f 54 20 4d 55 54 45 58 4c 4f 43 4b 20 2d 3e DOT MUTEXLOCK ->
11e0: 20 43 41 53 45 32 3b 20 7b 72 61 6e 6b 3d 73 61 CASE2; {rank=sa
11f0: 6d 65 20 22 63 61 73 65 20 32 22 20 43 41 53 45 me "case 2" CASE
1200: 32 7d 0a 20 20 20 20 20 3b 3b 44 4f 54 20 43 41 2}. ;;DOT CA
1210: 53 45 32 20 2d 3e 20 22 72 6d 74 3a 6f 70 65 6e SE2 -> "rmt:open
1220: 2d 71 72 79 2d 63 6c 6f 73 65 2d 6c 6f 63 61 6c -qry-close-local
1230: 6c 79 22 3b 0a 20 20 20 20 20 3b 3b 20 72 65 61 ly";. ;; rea
1240: 64 6f 6e 6c 79 20 6d 6f 64 65 2c 20 72 65 61 64 donly mode, read
1250: 20 72 65 71 75 65 73 74 2d 20 20 68 61 6e 64 6c request- handl
1260: 65 20 69 74 20 2d 20 63 61 73 65 20 32 0a 20 20 e it - case 2.
1270: 20 20 20 28 28 61 6e 64 20 72 65 61 64 6f 6e 6c ((and readonl
1280: 79 2d 6d 6f 64 65 0a 20 20 20 20 20 20 20 20 20 y-mode.
1290: 20 20 28 6d 65 6d 62 65 72 20 63 6d 64 20 61 70 (member cmd ap
12a0: 69 3a 72 65 61 64 2d 6f 6e 6c 79 2d 71 75 65 72 i:read-only-quer
12b0: 69 65 73 29 29 20 0a 20 20 20 20 20 20 28 6d 75 ies)) . (mu
12c0: 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 72 6d 74 tex-unlock! *rmt
12d0: 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 20 20 28 -mutex*). (
12e0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
12f0: 20 31 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 12 *default-log
1300: 2d 70 6f 72 74 2a 20 22 72 6d 74 3a 73 65 6e 64 -port* "rmt:send
1310: 2d 72 65 63 65 69 76 65 2c 20 63 61 73 65 20 32 -receive, case 2
1320: 22 29 0a 20 20 20 20 20 20 28 72 6d 74 3a 6f 70 "). (rmt:op
1330: 65 6e 2d 71 72 79 2d 63 6c 6f 73 65 2d 6c 6f 63 en-qry-close-loc
1340: 61 6c 6c 79 20 63 6d 64 20 30 20 70 61 72 61 6d ally cmd 0 param
1350: 73 29 0a 20 20 20 20 20 20 29 0a 0a 20 20 20 20 s). )..
1360: 20 3b 3b 44 4f 54 20 43 41 53 45 33 20 5b 6c 61 ;;DOT CASE3 [la
1370: 62 65 6c 3d 22 77 72 69 74 65 20 69 6e 5c 6e 72 bel="write in\nr
1380: 65 61 64 2d 6f 6e 6c 79 20 6d 6f 64 65 22 5d 3b ead-only mode"];
1390: 0a 20 20 20 20 20 3b 3b 44 4f 54 20 4d 55 54 45 . ;;DOT MUTE
13a0: 58 4c 4f 43 4b 20 2d 3e 20 43 41 53 45 33 20 5b XLOCK -> CASE3 [
13b0: 6c 61 62 65 6c 3d 22 72 65 61 64 6f 6e 6c 79 5c label="readonly\
13c0: 6e 6d 6f 64 65 3f 22 5d 3b 20 7b 72 61 6e 6b 3d nmode?"]; {rank=
13d0: 73 61 6d 65 20 22 63 61 73 65 20 33 22 20 43 41 same "case 3" CA
13e0: 53 45 33 7d 0a 20 20 20 20 20 3b 3b 44 4f 54 20 SE3}. ;;DOT
13f0: 43 41 53 45 33 20 2d 3e 20 22 23 66 22 3b 0a 20 CASE3 -> "#f";.
1400: 20 20 20 20 3b 3b 20 72 65 61 64 6f 6e 6c 79 20 ;; readonly
1410: 6d 6f 64 65 2c 20 77 72 69 74 65 20 72 65 71 75 mode, write requ
1420: 65 73 74 2e 20 20 44 6f 20 6e 6f 74 68 69 6e 67 est. Do nothing
1430: 2c 20 72 65 74 75 72 6e 20 23 66 0a 20 20 20 20 , return #f.
1440: 20 28 72 65 61 64 6f 6e 6c 79 2d 6d 6f 64 65 0a (readonly-mode.
1450: 20 20 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c (mutex-unl
1460: 6f 63 6b 21 20 2a 72 6d 74 2d 6d 75 74 65 78 2a ock! *rmt-mutex*
1470: 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 ). (debug:p
1480: 72 69 6e 74 2d 69 6e 66 6f 20 31 32 20 2a 64 65 rint-info 12 *de
1490: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
14a0: 22 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 "rmt:send-receiv
14b0: 65 2c 20 63 61 73 65 20 33 22 29 0a 20 20 20 20 e, case 3").
14c0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
14d0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
14e0: 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 77 72 rt* "WARNING: wr
14f0: 69 74 65 20 74 72 61 6e 73 61 63 74 69 6f 6e 20 ite transaction
1500: 72 65 71 75 65 73 74 65 64 20 6f 6e 20 61 20 72 requested on a r
1510: 65 61 64 6f 6e 6c 79 20 61 72 65 61 2e 20 20 63 eadonly area. c
1520: 6d 64 3d 22 63 6d 64 22 20 70 61 72 61 6d 73 3d md="cmd" params=
1530: 22 70 61 72 61 6d 73 29 0a 20 20 20 20 20 20 23 "params). #
1540: 66 29 0a 0a 20 20 20 20 20 3b 3b 20 54 68 69 73 f).. ;; This
1550: 20 62 6c 6f 63 6b 20 77 61 73 20 66 6f 72 20 70 block was for p
1560: 72 65 2d 65 6d 70 74 69 76 65 6c 79 20 72 65 73 re-emptively res
1570: 65 74 74 69 6e 67 20 74 68 65 20 63 6f 6e 6e 65 etting the conne
1580: 63 74 69 6f 6e 20 69 66 20 74 68 65 72 65 20 68 ction if there h
1590: 61 64 20 62 65 65 6e 20 6e 6f 20 63 6f 6d 6d 75 ad been no commu
15a0: 6e 69 63 61 74 69 6f 6e 20 66 6f 72 20 73 6f 6d nication for som
15b0: 65 20 74 69 6d 65 2e 0a 20 20 20 20 20 3b 3b 20 e time.. ;;
15c0: 49 20 64 6f 6e 27 74 20 74 68 69 6e 6b 20 69 74 I don't think it
15d0: 20 61 64 64 73 20 61 6e 79 20 76 61 6c 75 65 2e adds any value.
15e0: 20 49 66 20 74 68 65 20 73 65 72 76 65 72 20 69 If the server i
15f0: 73 20 6e 6f 74 20 74 68 65 72 65 2c 20 6a 75 73 s not there, jus
1600: 74 20 66 61 69 6c 20 61 6e 64 20 73 74 61 72 74 t fail and start
1610: 20 61 20 6e 65 77 20 63 6f 6e 6e 65 63 74 69 6f a new connectio
1620: 6e 2e 0a 20 20 20 20 20 3b 3b 20 61 6c 73 6f 2c n.. ;; also,
1630: 20 74 68 65 20 65 78 70 69 72 65 2d 74 69 6d 65 the expire-time
1640: 20 63 61 6c 63 75 6c 61 74 69 6f 6e 20 6d 69 67 calculation mig
1650: 68 74 20 6e 6f 74 20 62 65 20 63 6f 72 72 65 63 ht not be correc
1660: 74 2e 20 57 65 20 77 61 6e 74 2c 20 74 69 6d 65 t. We want, time
1670: 2d 73 69 6e 63 65 2d 6c 61 73 74 2d 73 65 72 76 -since-last-serv
1680: 65 72 2d 61 63 63 65 73 73 20 3e 20 28 73 65 72 er-access > (ser
1690: 76 65 72 3a 67 65 74 2d 74 69 6d 65 6f 75 74 29 ver:get-timeout)
16a0: 0a 20 20 20 20 20 3b 3b 0a 20 20 20 20 20 3b 3b . ;;. ;;
16b0: 20 3b 3b 44 4f 54 20 43 41 53 45 34 20 5b 6c 61 ;;DOT CASE4 [la
16c0: 62 65 6c 3d 22 72 65 73 65 74 5c 6e 63 6f 6e 6e bel="reset\nconn
16d0: 65 63 74 69 6f 6e 22 5d 3b 0a 20 20 20 20 20 3b ection"];. ;
16e0: 3b 20 3b 3b 44 4f 54 20 4d 55 54 45 58 4c 4f 43 ; ;;DOT MUTEXLOC
16f0: 4b 20 2d 3e 20 43 41 53 45 34 20 5b 6c 61 62 65 K -> CASE4 [labe
1700: 6c 3d 22 68 61 76 65 20 63 6f 6e 6e 65 63 74 69 l="have connecti
1710: 6f 6e 2c 5c 6e 6c 61 73 74 5f 61 63 63 65 73 73 on,\nlast_access
1720: 20 3e 20 65 78 70 69 72 65 5f 74 69 6d 65 22 5d > expire_time"]
1730: 3b 20 7b 72 61 6e 6b 3d 73 61 6d 65 20 22 63 61 ; {rank=same "ca
1740: 73 65 20 34 22 20 43 41 53 45 34 7d 0a 20 20 20 se 4" CASE4}.
1750: 20 20 3b 3b 20 3b 3b 44 4f 54 20 43 41 53 45 34 ;; ;;DOT CASE4
1760: 20 2d 3e 20 22 72 6d 74 3a 73 65 6e 64 2d 72 65 -> "rmt:send-re
1770: 63 65 69 76 65 22 3b 0a 20 20 20 20 20 3b 3b 20 ceive";. ;;
1780: 3b 3b 20 72 65 73 65 74 20 74 68 65 20 63 6f 6e ;; reset the con
1790: 6e 65 63 74 69 6f 6e 20 69 66 20 69 74 20 68 61 nection if it ha
17a0: 73 20 62 65 65 6e 20 75 6e 75 73 65 64 20 74 6f s been unused to
17b0: 6f 20 6c 6f 6e 67 0a 20 20 20 20 20 3b 3b 20 28 o long. ;; (
17c0: 28 61 6e 64 20 72 75 6e 72 65 6d 6f 74 65 0a 20 (and runremote.
17d0: 20 20 20 20 3b 3b 20 20 20 20 20 20 20 28 72 65 ;; (re
17e0: 6d 6f 74 65 2d 63 6f 6e 6e 64 61 74 20 72 75 6e mote-conndat run
17f0: 72 65 6d 6f 74 65 29 0a 20 20 20 20 20 3b 3b 20 remote). ;;
1800: 09 20 20 20 28 6c 65 74 20 28 28 65 78 70 69 72 . (let ((expir
1810: 65 2d 74 69 6d 65 20 28 2b 20 28 2d 20 73 74 61 e-time (+ (- sta
1820: 72 74 2d 74 69 6d 65 20 28 72 65 6d 6f 74 65 2d rt-time (remote-
1830: 73 65 72 76 65 72 2d 74 69 6d 65 6f 75 74 20 72 server-timeout r
1840: 75 6e 72 65 6d 6f 74 65 29 29 28 72 61 6e 64 6f unremote))(rando
1850: 6d 20 31 30 29 29 29 29 20 3b 3b 20 53 75 62 74 m 10)))) ;; Subt
1860: 72 61 63 74 20 6f 72 20 61 64 64 20 74 68 65 20 ract or add the
1870: 72 61 6e 64 6f 6d 20 76 61 6c 75 65 3f 20 53 65 random value? Se
1880: 65 6d 73 20 6c 69 6b 65 20 69 74 20 73 68 6f 75 ems like it shou
1890: 6c 64 20 62 65 20 73 75 62 73 74 72 61 63 74 20 ld be substract
18a0: 62 75 74 20 4e 65 69 74 68 65 72 20 66 69 78 65 but Neither fixe
18b0: 73 20 74 68 65 20 22 57 41 52 4e 49 4e 47 3a 20 s the "WARNING:
18c0: 66 61 69 6c 75 72 65 20 69 6e 20 77 69 74 68 2d failure in with-
18d0: 69 6e 70 75 74 2d 66 72 6f 6d 2d 72 65 71 75 65 input-from-reque
18e0: 73 74 20 74 6f 20 23 3c 72 65 71 75 65 73 74 3e st to #<request>
18f0: 2e 5c 6e 20 6d 65 73 73 61 67 65 3a 20 53 65 72 .\n message: Ser
1900: 76 65 72 20 63 6c 6f 73 65 64 20 63 6f 6e 6e 65 ver closed conne
1910: 63 74 69 6f 6e 20 62 65 66 6f 72 65 20 73 65 6e ction before sen
1920: 64 69 6e 67 20 72 65 73 70 6f 6e 73 65 22 0a 20 ding response".
1930: 20 20 20 20 3b 3b 20 09 20 20 20 20 20 28 3c 20 ;; . (<
1940: 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a (http-transport:
1950: 73 65 72 76 65 72 2d 64 61 74 2d 67 65 74 2d 6c server-dat-get-l
1960: 61 73 74 2d 61 63 63 65 73 73 20 28 72 65 6d 6f ast-access (remo
1970: 74 65 2d 63 6f 6e 6e 64 61 74 20 72 75 6e 72 65 te-conndat runre
1980: 6d 6f 74 65 29 29 20 65 78 70 69 72 65 2d 74 69 mote)) expire-ti
1990: 6d 65 29 29 29 0a 20 20 20 20 20 3b 3b 20 20 28 me))). ;; (
19a0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
19b0: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
19c0: 70 6f 72 74 2a 20 22 43 6f 6e 6e 65 63 74 69 6f port* "Connectio
19d0: 6e 20 74 6f 20 22 20 28 72 65 6d 6f 74 65 2d 73 n to " (remote-s
19e0: 65 72 76 65 72 2d 75 72 6c 20 72 75 6e 72 65 6d erver-url runrem
19f0: 6f 74 65 29 20 22 20 65 78 70 69 72 65 64 20 64 ote) " expired d
1a00: 75 65 20 74 6f 20 6e 6f 20 61 63 63 65 73 73 65 ue to no accesse
1a10: 73 2c 20 66 6f 72 63 69 6e 67 20 6e 65 77 20 63 s, forcing new c
1a20: 6f 6e 6e 65 63 74 69 6f 6e 2e 22 29 0a 20 20 20 onnection.").
1a30: 20 20 3b 3b 20 20 28 68 74 74 70 2d 74 72 61 6e ;; (http-tran
1a40: 73 70 6f 72 74 3a 63 6c 6f 73 65 2d 63 6f 6e 6e sport:close-conn
1a50: 65 63 74 69 6f 6e 73 20 61 72 65 61 2d 64 61 74 ections area-dat
1a60: 3a 20 72 75 6e 72 65 6d 6f 74 65 29 0a 20 20 20 : runremote).
1a70: 20 20 3b 3b 20 20 28 72 65 6d 6f 74 65 2d 63 6f ;; (remote-co
1a80: 6e 6e 64 61 74 2d 73 65 74 21 20 72 75 6e 72 65 nndat-set! runre
1a90: 6d 6f 74 65 20 23 66 29 20 3b 3b 20 69 6e 76 61 mote #f) ;; inva
1aa0: 6c 69 64 61 74 65 20 74 68 65 20 63 6f 6e 6e 65 lidate the conne
1ab0: 63 74 69 6f 6e 2c 20 74 68 75 73 20 66 6f 72 63 ction, thus forc
1ac0: 69 6e 67 20 61 20 6e 65 77 20 63 6f 6e 6e 65 63 ing a new connec
1ad0: 74 69 6f 6e 2e 0a 20 20 20 20 20 3b 3b 20 20 28 tion.. ;; (
1ae0: 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 72 mutex-unlock! *r
1af0: 6d 74 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 20 mt-mutex*).
1b00: 3b 3b 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ;; (rmt:send-re
1b10: 63 65 69 76 65 20 63 6d 64 20 72 69 64 20 70 61 ceive cmd rid pa
1b20: 72 61 6d 73 20 61 74 74 65 6d 70 74 6e 75 6d 3a rams attemptnum:
1b30: 20 61 74 74 65 6d 70 74 6e 75 6d 29 29 0a 0a 20 attemptnum))..
1b40: 20 20 20 20 3b 3b 44 4f 54 20 43 41 53 45 35 20 ;;DOT CASE5
1b50: 5b 6c 61 62 65 6c 3d 22 6c 6f 63 61 6c 5c 6e 72 [label="local\nr
1b60: 65 61 64 22 5d 3b 0a 20 20 20 20 20 3b 3b 44 4f ead"];. ;;DO
1b70: 54 20 4d 55 54 45 58 4c 4f 43 4b 20 2d 3e 20 43 T MUTEXLOCK -> C
1b80: 41 53 45 35 20 5b 6c 61 62 65 6c 3d 22 73 65 72 ASE5 [label="ser
1b90: 76 65 72 20 6e 6f 74 20 72 65 71 75 69 72 65 64 ver not required
1ba0: 2c 5c 6e 6f 6e 20 68 6f 6d 65 68 6f 73 74 2c 5c ,\non homehost,\
1bb0: 6e 72 65 61 64 2d 6f 6e 6c 79 20 71 75 65 72 79 nread-only query
1bc0: 22 5d 3b 20 7b 72 61 6e 6b 3d 73 61 6d 65 20 22 "]; {rank=same "
1bd0: 63 61 73 65 20 35 22 20 43 41 53 45 35 7d 3b 0a case 5" CASE5};.
1be0: 20 20 20 20 20 3b 3b 44 4f 54 20 43 41 53 45 35 ;;DOT CASE5
1bf0: 20 2d 3e 20 22 72 6d 74 3a 6f 70 65 6e 2d 71 72 -> "rmt:open-qr
1c00: 79 2d 63 6c 6f 73 65 2d 6c 6f 63 61 6c 6c 79 22 y-close-locally"
1c10: 3b 0a 20 20 20 20 20 3b 3b 20 6f 6e 20 68 6f 6d ;. ;; on hom
1c20: 65 68 6f 73 74 20 61 6e 64 20 74 68 69 73 20 69 ehost and this i
1c30: 73 20 61 20 72 65 61 64 0a 20 20 20 20 20 28 28 s a read. ((
1c40: 61 6e 64 20 28 6e 6f 74 20 28 72 65 6d 6f 74 65 and (not (remote
1c50: 2d 66 6f 72 63 65 2d 73 65 72 76 65 72 20 72 75 -force-server ru
1c60: 6e 72 65 6d 6f 74 65 29 29 20 3b 3b 20 68 6f 6e nremote)) ;; hon
1c70: 6f 72 20 66 6f 72 63 65 64 20 75 73 65 20 6f 66 or forced use of
1c80: 20 73 65 72 76 65 72 2c 20 69 2e 65 2e 20 73 65 server, i.e. se
1c90: 72 76 65 72 20 4e 4f 54 20 72 65 71 75 69 72 65 rver NOT require
1ca0: 64 0a 09 20 20 20 28 63 64 72 20 28 72 65 6d 6f d.. (cdr (remo
1cb0: 74 65 2d 68 68 2d 64 61 74 20 72 75 6e 72 65 6d te-hh-dat runrem
1cc0: 6f 74 65 29 29 20 20 20 20 20 20 20 3b 3b 20 6f ote)) ;; o
1cd0: 6e 20 68 6f 6d 65 68 6f 73 74 0a 20 20 20 20 20 n homehost.
1ce0: 20 20 20 20 20 20 28 6d 65 6d 62 65 72 20 63 6d (member cm
1cf0: 64 20 61 70 69 3a 72 65 61 64 2d 6f 6e 6c 79 2d d api:read-only-
1d00: 71 75 65 72 69 65 73 29 29 20 20 20 3b 3b 20 74 queries)) ;; t
1d10: 68 69 73 20 69 73 20 61 20 72 65 61 64 0a 20 20 his is a read.
1d20: 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 (mutex-unloc
1d30: 6b 21 20 2a 72 6d 74 2d 6d 75 74 65 78 2a 29 0a k! *rmt-mutex*).
1d40: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
1d50: 6e 74 2d 69 6e 66 6f 20 31 32 20 2a 64 65 66 61 nt-info 12 *defa
1d60: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 ult-log-port* "r
1d70: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 2c mt:send-receive,
1d80: 20 63 61 73 65 20 20 35 22 29 0a 20 20 20 20 20 case 5").
1d90: 20 28 72 6d 74 3a 6f 70 65 6e 2d 71 72 79 2d 63 (rmt:open-qry-c
1da0: 6c 6f 73 65 2d 6c 6f 63 61 6c 6c 79 20 63 6d 64 lose-locally cmd
1db0: 20 30 20 70 61 72 61 6d 73 29 29 0a 0a 20 20 20 0 params))..
1dc0: 20 20 3b 3b 44 4f 54 20 43 41 53 45 36 20 5b 6c ;;DOT CASE6 [l
1dd0: 61 62 65 6c 3d 22 69 6e 69 74 5c 6e 72 65 6d 6f abel="init\nremo
1de0: 74 65 22 5d 3b 0a 20 20 20 20 20 3b 3b 44 4f 54 te"];. ;;DOT
1df0: 20 4d 55 54 45 58 4c 4f 43 4b 20 2d 3e 20 43 41 MUTEXLOCK -> CA
1e00: 53 45 36 20 5b 6c 61 62 65 6c 3d 22 6f 6e 20 68 SE6 [label="on h
1e10: 6f 6d 65 68 6f 73 74 2c 5c 6e 77 72 69 74 65 20 omehost,\nwrite
1e20: 71 75 65 72 79 2c 5c 6e 68 61 76 65 20 73 65 72 query,\nhave ser
1e30: 76 65 72 2c 5c 6e 63 61 6e 27 74 20 72 65 61 63 ver,\ncan't reac
1e40: 68 20 69 74 22 5d 3b 20 7b 72 61 6e 6b 3d 73 61 h it"]; {rank=sa
1e50: 6d 65 20 22 63 61 73 65 20 36 22 20 43 41 53 45 me "case 6" CASE
1e60: 36 7d 3b 0a 20 20 20 20 20 3b 3b 44 4f 54 20 43 6};. ;;DOT C
1e70: 41 53 45 36 20 2d 3e 20 22 72 6d 74 3a 73 65 6e ASE6 -> "rmt:sen
1e80: 64 2d 72 65 63 65 69 76 65 22 3b 0a 20 20 20 20 d-receive";.
1e90: 20 3b 3b 20 6f 6e 20 68 6f 6d 65 68 6f 73 74 20 ;; on homehost
1ea0: 61 6e 64 20 74 68 69 73 20 69 73 20 61 20 77 72 and this is a wr
1eb0: 69 74 65 2c 20 77 65 20 61 6c 72 65 61 64 79 20 ite, we already
1ec0: 68 61 76 65 20 61 20 73 65 72 76 65 72 2c 20 62 have a server, b
1ed0: 75 74 20 73 65 72 76 65 72 20 68 61 73 20 64 69 ut server has di
1ee0: 65 64 0a 20 20 20 20 20 28 28 61 6e 64 20 28 63 ed. ((and (c
1ef0: 64 72 20 28 72 65 6d 6f 74 65 2d 68 68 2d 64 61 dr (remote-hh-da
1f00: 74 20 72 75 6e 72 65 6d 6f 74 65 29 29 20 20 20 t runremote))
1f10: 20 20 20 20 20 20 20 20 3b 3b 20 6f 6e 20 68 6f ;; on ho
1f20: 6d 65 68 6f 73 74 0a 20 20 20 20 20 20 20 20 20 mehost.
1f30: 20 20 28 6e 6f 74 20 28 6d 65 6d 62 65 72 20 63 (not (member c
1f40: 6d 64 20 61 70 69 3a 72 65 61 64 2d 6f 6e 6c 79 md api:read-only
1f50: 2d 71 75 65 72 69 65 73 29 29 20 20 3b 3b 20 74 -queries)) ;; t
1f60: 68 69 73 20 69 73 20 61 20 77 72 69 74 65 0a 20 his is a write.
1f70: 20 20 20 20 20 20 20 20 20 20 28 72 65 6d 6f 74 (remot
1f80: 65 2d 73 65 72 76 65 72 2d 75 72 6c 20 72 75 6e e-server-url run
1f90: 72 65 6d 6f 74 65 29 20 20 20 20 20 20 20 20 20 remote)
1fa0: 20 20 20 20 3b 3b 20 68 61 76 65 20 61 20 73 65 ;; have a se
1fb0: 72 76 65 72 0a 20 20 20 20 20 20 20 20 20 20 20 rver.
1fc0: 28 6e 6f 74 20 28 73 65 72 76 65 72 3a 70 69 6e (not (server:pin
1fd0: 67 20 28 72 65 6d 6f 74 65 2d 73 65 72 76 65 72 g (remote-server
1fe0: 2d 75 72 6c 20 72 75 6e 72 65 6d 6f 74 65 29 29 -url runremote))
1ff0: 29 29 20 20 3b 3b 20 73 65 72 76 65 72 20 68 61 )) ;; server ha
2000: 73 20 64 69 65 64 2e 20 4e 4f 54 45 3a 20 74 68 s died. NOTE: th
2010: 69 73 20 69 73 20 6e 6f 74 20 61 20 63 68 65 61 is is not a chea
2020: 70 20 63 61 6c 6c 21 20 4e 65 65 64 20 62 65 74 p call! Need bet
2030: 74 65 72 20 61 70 70 72 6f 61 63 68 2e 0a 20 20 ter approach..
2040: 20 20 20 20 28 73 65 74 21 20 2a 72 75 6e 72 65 (set! *runre
2050: 6d 6f 74 65 2a 20 28 6d 61 6b 65 2d 72 65 6d 6f mote* (make-remo
2060: 74 65 29 29 0a 20 20 20 20 20 20 28 72 65 6d 6f te)). (remo
2070: 74 65 2d 66 6f 72 63 65 2d 73 65 72 76 65 72 2d te-force-server-
2080: 73 65 74 21 20 72 75 6e 72 65 6d 6f 74 65 20 28 set! runremote (
2090: 63 6f 6d 6d 6f 6e 3a 66 6f 72 63 65 2d 73 65 72 common:force-ser
20a0: 76 65 72 3f 29 29 0a 20 20 20 20 20 20 28 6d 75 ver?)). (mu
20b0: 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 72 6d 74 tex-unlock! *rmt
20c0: 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 20 20 28 -mutex*). (
20d0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
20e0: 20 31 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 12 *default-log
20f0: 2d 70 6f 72 74 2a 20 22 72 6d 74 3a 73 65 6e 64 -port* "rmt:send
2100: 2d 72 65 63 65 69 76 65 2c 20 63 61 73 65 20 20 -receive, case
2110: 36 22 29 0a 20 20 20 20 20 20 28 72 6d 74 3a 73 6"). (rmt:s
2120: 65 6e 64 2d 72 65 63 65 69 76 65 20 63 6d 64 20 end-receive cmd
2130: 72 69 64 20 70 61 72 61 6d 73 20 61 74 74 65 6d rid params attem
2140: 70 74 6e 75 6d 3a 20 61 74 74 65 6d 70 74 6e 75 ptnum: attemptnu
2150: 6d 29 29 0a 0a 20 20 20 20 20 3b 3b 44 4f 54 20 m)).. ;;DOT
2160: 43 41 53 45 37 20 5b 6c 61 62 65 6c 3d 22 68 6f CASE7 [label="ho
2170: 6d 65 68 6f 73 74 5c 6e 77 72 69 74 65 22 5d 3b mehost\nwrite"];
2180: 0a 20 20 20 20 20 3b 3b 44 4f 54 20 4d 55 54 45 . ;;DOT MUTE
2190: 58 4c 4f 43 4b 20 2d 3e 20 43 41 53 45 37 20 5b XLOCK -> CASE7 [
21a0: 6c 61 62 65 6c 3d 22 73 65 72 76 65 72 20 6e 6f label="server no
21b0: 74 20 72 65 71 75 69 72 65 64 2c 5c 6e 6f 6e 20 t required,\non
21c0: 68 6f 6d 65 68 6f 73 74 2c 5c 6e 61 20 77 72 69 homehost,\na wri
21d0: 74 65 2c 5c 6e 68 61 76 65 20 61 20 73 65 72 76 te,\nhave a serv
21e0: 65 72 22 5d 3b 20 7b 72 61 6e 6b 3d 73 61 6d 65 er"]; {rank=same
21f0: 20 22 63 61 73 65 20 37 22 20 43 41 53 45 37 7d "case 7" CASE7}
2200: 3b 0a 20 20 20 20 20 3b 3b 44 4f 54 20 43 41 53 ;. ;;DOT CAS
2210: 45 37 20 2d 3e 20 22 72 6d 74 3a 6f 70 65 6e 2d E7 -> "rmt:open-
2220: 71 72 79 2d 63 6c 6f 73 65 2d 6c 6f 63 61 6c 6c qry-close-locall
2230: 79 22 3b 0a 20 20 20 20 20 3b 3b 20 6f 6e 20 68 y";. ;; on h
2240: 6f 6d 65 68 6f 73 74 20 61 6e 64 20 74 68 69 73 omehost and this
2250: 20 69 73 20 61 20 77 72 69 74 65 2c 20 77 65 20 is a write, we
2260: 61 6c 72 65 61 64 79 20 68 61 76 65 20 61 20 73 already have a s
2270: 65 72 76 65 72 0a 20 20 20 20 20 28 28 61 6e 64 erver. ((and
2280: 20 28 6e 6f 74 20 28 72 65 6d 6f 74 65 2d 66 6f (not (remote-fo
2290: 72 63 65 2d 73 65 72 76 65 72 20 72 75 6e 72 65 rce-server runre
22a0: 6d 6f 74 65 29 29 20 20 20 20 20 3b 3b 20 68 6f mote)) ;; ho
22b0: 6e 6f 72 20 66 6f 72 63 65 64 20 75 73 65 20 6f nor forced use o
22c0: 66 20 73 65 72 76 65 72 2c 20 69 2e 65 2e 20 73 f server, i.e. s
22d0: 65 72 76 65 72 20 4e 4f 54 20 72 65 71 75 69 72 erver NOT requir
22e0: 65 64 0a 09 20 20 20 28 63 64 72 20 28 72 65 6d ed.. (cdr (rem
22f0: 6f 74 65 2d 68 68 2d 64 61 74 20 72 75 6e 72 65 ote-hh-dat runre
2300: 6d 6f 74 65 29 29 20 20 20 20 20 20 20 20 20 20 mote))
2310: 20 3b 3b 20 6f 6e 20 68 6f 6d 65 68 6f 73 74 0a ;; on homehost.
2320: 20 20 20 20 20 20 20 20 20 20 20 28 6e 6f 74 20 (not
2330: 28 6d 65 6d 62 65 72 20 63 6d 64 20 61 70 69 3a (member cmd api:
2340: 72 65 61 64 2d 6f 6e 6c 79 2d 71 75 65 72 69 65 read-only-querie
2350: 73 29 29 20 20 3b 3b 20 74 68 69 73 20 69 73 20 s)) ;; this is
2360: 61 20 77 72 69 74 65 0a 20 20 20 20 20 20 20 20 a write.
2370: 20 20 20 28 72 65 6d 6f 74 65 2d 73 65 72 76 65 (remote-serve
2380: 72 2d 75 72 6c 20 72 75 6e 72 65 6d 6f 74 65 29 r-url runremote)
2390: 29 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ) ;;
23a0: 68 61 76 65 20 61 20 73 65 72 76 65 72 0a 20 20 have a server.
23b0: 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 (mutex-unloc
23c0: 6b 21 20 2a 72 6d 74 2d 6d 75 74 65 78 2a 29 0a k! *rmt-mutex*).
23d0: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
23e0: 6e 74 2d 69 6e 66 6f 20 31 32 20 2a 64 65 66 61 nt-info 12 *defa
23f0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 ult-log-port* "r
2400: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 2c mt:send-receive,
2410: 20 63 61 73 65 20 20 34 2e 31 22 29 0a 20 20 20 case 4.1").
2420: 20 20 20 28 72 6d 74 3a 6f 70 65 6e 2d 71 72 79 (rmt:open-qry
2430: 2d 63 6c 6f 73 65 2d 6c 6f 63 61 6c 6c 79 20 63 -close-locally c
2440: 6d 64 20 30 20 70 61 72 61 6d 73 29 29 0a 0a 20 md 0 params))..
2450: 20 20 20 20 3b 3b 44 4f 54 20 43 41 53 45 38 20 ;;DOT CASE8
2460: 5b 6c 61 62 65 6c 3d 22 66 6f 72 63 65 5c 6e 73 [label="force\ns
2470: 65 72 76 65 72 22 5d 3b 0a 20 20 20 20 20 3b 3b erver"];. ;;
2480: 44 4f 54 20 4d 55 54 45 58 4c 4f 43 4b 20 2d 3e DOT MUTEXLOCK ->
2490: 20 43 41 53 45 38 20 5b 6c 61 62 65 6c 3d 22 73 CASE8 [label="s
24a0: 65 72 76 65 72 20 6e 6f 74 20 72 65 71 75 69 72 erver not requir
24b0: 65 64 2c 5c 6e 68 61 76 65 20 68 6f 6d 65 68 6f ed,\nhave homeho
24c0: 73 74 20 69 6e 66 6f 2c 5c 6e 6e 6f 20 63 6f 6e st info,\nno con
24d0: 6e 65 63 74 69 6f 6e 20 79 65 74 2c 5c 6e 6e 6f nection yet,\nno
24e0: 74 20 61 20 72 65 61 64 2d 6f 6e 6c 79 20 71 75 t a read-only qu
24f0: 65 72 79 22 5d 3b 20 7b 72 61 6e 6b 3d 73 61 6d ery"]; {rank=sam
2500: 65 20 22 63 61 73 65 20 38 22 20 43 41 53 45 38 e "case 8" CASE8
2510: 7d 3b 0a 20 20 20 20 20 3b 3b 44 4f 54 20 43 41 };. ;;DOT CA
2520: 53 45 38 20 2d 3e 20 22 72 6d 74 3a 6f 70 65 6e SE8 -> "rmt:open
2530: 2d 71 72 79 2d 63 6c 6f 73 65 2d 6c 6f 63 61 6c -qry-close-local
2540: 6c 79 22 3b 0a 20 20 20 20 20 3b 3b 20 20 6f 6e ly";. ;; on
2550: 20 68 6f 6d 65 68 6f 73 74 2c 20 6e 6f 20 73 65 homehost, no se
2560: 72 76 65 72 20 63 6f 6e 74 61 63 74 20 6d 61 64 rver contact mad
2570: 65 20 61 6e 64 20 74 68 69 73 20 69 73 20 61 20 e and this is a
2580: 77 72 69 74 65 2c 20 70 61 73 73 69 76 65 6c 79 write, passively
2590: 20 73 74 61 72 74 20 61 20 73 65 72 76 65 72 20 start a server
25a0: 0a 20 20 20 20 20 28 28 61 6e 64 20 28 6e 6f 74 . ((and (not
25b0: 20 28 72 65 6d 6f 74 65 2d 66 6f 72 63 65 2d 73 (remote-force-s
25c0: 65 72 76 65 72 20 72 75 6e 72 65 6d 6f 74 65 29 erver runremote)
25d0: 29 20 20 20 20 20 3b 3b 20 68 6f 6e 6f 72 20 66 ) ;; honor f
25e0: 6f 72 63 65 64 20 75 73 65 20 6f 66 20 73 65 72 orced use of ser
25f0: 76 65 72 2c 20 69 2e 65 2e 20 73 65 72 76 65 72 ver, i.e. server
2600: 20 4e 4f 54 20 72 65 71 75 69 72 65 64 0a 09 20 NOT required..
2610: 20 20 28 63 64 72 20 28 72 65 6d 6f 74 65 2d 68 (cdr (remote-h
2620: 68 2d 64 61 74 20 72 75 6e 72 65 6d 6f 74 65 29 h-dat runremote)
2630: 29 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 68 ) ;; h
2640: 61 76 65 20 68 6f 6d 65 68 6f 73 74 0a 20 20 20 ave homehost.
2650: 20 20 20 20 20 20 20 20 28 6e 6f 74 20 28 72 65 (not (re
2660: 6d 6f 74 65 2d 73 65 72 76 65 72 2d 75 72 6c 20 mote-server-url
2670: 72 75 6e 72 65 6d 6f 74 65 29 29 20 20 20 20 20 runremote))
2680: 20 20 3b 3b 20 6e 6f 20 63 6f 6e 6e 65 63 74 69 ;; no connecti
2690: 6f 6e 20 79 65 74 0a 09 20 20 20 28 6e 6f 74 20 on yet.. (not
26a0: 28 6d 65 6d 62 65 72 20 63 6d 64 20 61 70 69 3a (member cmd api:
26b0: 72 65 61 64 2d 6f 6e 6c 79 2d 71 75 65 72 69 65 read-only-querie
26c0: 73 29 29 29 20 3b 3b 20 6e 6f 74 20 61 20 72 65 s))) ;; not a re
26d0: 61 64 2d 6f 6e 6c 79 20 71 75 65 72 79 0a 20 20 ad-only query.
26e0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
26f0: 2d 69 6e 66 6f 20 31 32 20 2a 64 65 66 61 75 6c -info 12 *defaul
2700: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 6d 74 t-log-port* "rmt
2710: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 2c 20 63 :send-receive, c
2720: 61 73 65 20 20 38 22 29 0a 20 20 20 20 20 20 28 ase 8"). (
2730: 6c 65 74 20 28 28 73 65 72 76 65 72 2d 75 72 6c let ((server-url
2740: 20 20 28 73 65 72 76 65 72 3a 63 68 65 63 6b 2d (server:check-
2750: 69 66 2d 72 75 6e 6e 69 6e 67 20 2a 74 6f 70 70 if-running *topp
2760: 61 74 68 2a 29 29 29 20 3b 3b 20 28 73 65 72 76 ath*))) ;; (serv
2770: 65 72 3a 72 65 61 64 2d 64 6f 74 73 65 72 76 65 er:read-dotserve
2780: 72 2d 3e 75 72 6c 20 2a 74 6f 70 70 61 74 68 2a r->url *toppath*
2790: 29 29 29 20 3b 3b 20 28 73 65 72 76 65 72 3a 63 ))) ;; (server:c
27a0: 68 65 63 6b 2d 69 66 2d 72 75 6e 6e 69 6e 67 20 heck-if-running
27b0: 2a 74 6f 70 70 61 74 68 2a 29 29 29 20 3b 3b 20 *toppath*))) ;;
27c0: 44 6f 20 4e 4f 54 20 77 61 6e 74 20 74 6f 20 72 Do NOT want to r
27d0: 75 6e 20 73 65 72 76 65 72 3a 63 68 65 63 6b 2d un server:check-
27e0: 69 66 2d 72 75 6e 6e 69 6e 67 20 2d 20 76 65 72 if-running - ver
27f0: 79 20 65 78 70 65 6e 73 69 76 65 20 74 6f 20 64 y expensive to d
2800: 6f 20 66 6f 72 20 65 76 65 72 79 20 77 72 69 74 o for every writ
2810: 65 20 63 61 6c 6c 0a 09 28 69 66 20 73 65 72 76 e call..(if serv
2820: 65 72 2d 75 72 6c 0a 09 20 20 20 20 28 72 65 6d er-url.. (rem
2830: 6f 74 65 2d 73 65 72 76 65 72 2d 75 72 6c 2d 73 ote-server-url-s
2840: 65 74 21 20 72 75 6e 72 65 6d 6f 74 65 20 73 65 et! runremote se
2850: 72 76 65 72 2d 75 72 6c 29 20 3b 3b 20 74 68 65 rver-url) ;; the
2860: 20 73 74 72 69 6e 67 20 63 61 6e 20 62 65 20 63 string can be c
2870: 6f 6e 73 75 6d 65 64 20 62 79 20 74 68 65 20 63 onsumed by the c
2880: 6c 69 65 6e 74 20 73 65 74 75 70 20 69 66 20 6e lient setup if n
2890: 65 65 64 65 64 0a 09 20 20 20 20 28 69 66 20 28 eeded.. (if (
28a0: 63 6f 6d 6d 6f 6e 3a 66 6f 72 63 65 2d 73 65 72 common:force-ser
28b0: 76 65 72 3f 29 0a 09 09 28 73 65 72 76 65 72 3a ver?)...(server:
28c0: 73 74 61 72 74 2d 61 6e 64 2d 77 61 69 74 20 2a start-and-wait *
28d0: 74 6f 70 70 61 74 68 2a 29 0a 09 09 28 73 65 72 toppath*)...(ser
28e0: 76 65 72 3a 6b 69 6e 64 2d 72 75 6e 20 2a 74 6f ver:kind-run *to
28f0: 70 70 61 74 68 2a 29 29 29 29 0a 20 20 20 20 20 ppath*)))).
2900: 20 28 72 65 6d 6f 74 65 2d 66 6f 72 63 65 2d 73 (remote-force-s
2910: 65 72 76 65 72 2d 73 65 74 21 20 72 75 6e 72 65 erver-set! runre
2920: 6d 6f 74 65 20 28 63 6f 6d 6d 6f 6e 3a 66 6f 72 mote (common:for
2930: 63 65 2d 73 65 72 76 65 72 3f 29 29 0a 20 20 20 ce-server?)).
2940: 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b (mutex-unlock
2950: 21 20 2a 72 6d 74 2d 6d 75 74 65 78 2a 29 0a 20 ! *rmt-mutex*).
2960: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
2970: 74 2d 69 6e 66 6f 20 31 32 20 2a 64 65 66 61 75 t-info 12 *defau
2980: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 6d lt-log-port* "rm
2990: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 2c 20 t:send-receive,
29a0: 63 61 73 65 20 20 38 2e 31 22 29 0a 20 20 20 20 case 8.1").
29b0: 20 20 28 72 6d 74 3a 6f 70 65 6e 2d 71 72 79 2d (rmt:open-qry-
29c0: 63 6c 6f 73 65 2d 6c 6f 63 61 6c 6c 79 20 63 6d close-locally cm
29d0: 64 20 30 20 70 61 72 61 6d 73 29 29 0a 0a 20 20 d 0 params))..
29e0: 20 20 20 3b 3b 44 4f 54 20 43 41 53 45 39 20 5b ;;DOT CASE9 [
29f0: 6c 61 62 65 6c 3d 22 66 6f 72 63 65 20 73 65 72 label="force ser
2a00: 76 65 72 5c 6e 6e 6f 74 20 6f 6e 20 68 6f 6d 65 ver\nnot on home
2a10: 68 6f 73 74 22 5d 3b 0a 20 20 20 20 20 3b 3b 44 host"];. ;;D
2a20: 4f 54 20 4d 55 54 45 58 4c 4f 43 4b 20 2d 3e 20 OT MUTEXLOCK ->
2a30: 43 41 53 45 39 20 5b 6c 61 62 65 6c 3d 22 6e 6f CASE9 [label="no
2a40: 20 63 6f 6e 6e 65 63 74 69 6f 6e 5c 6e 61 6e 64 connection\nand
2a50: 20 65 69 74 68 65 72 20 72 65 71 75 69 72 65 20 either require
2a60: 73 65 72 76 65 72 5c 6e 6f 72 20 6e 6f 74 20 6f server\nor not o
2a70: 6e 20 68 6f 6d 65 68 6f 73 74 22 5d 3b 20 7b 72 n homehost"]; {r
2a80: 61 6e 6b 3d 73 61 6d 65 20 22 63 61 73 65 20 39 ank=same "case 9
2a90: 22 20 43 41 53 45 39 7d 3b 0a 20 20 20 20 20 3b " CASE9};. ;
2aa0: 3b 44 4f 54 20 43 41 53 45 39 20 2d 3e 20 22 73 ;DOT CASE9 -> "s
2ab0: 74 61 72 74 5c 6e 73 65 72 76 65 72 22 20 2d 3e tart\nserver" ->
2ac0: 20 22 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 "rmt:send-recei
2ad0: 76 65 22 3b 0a 20 20 20 20 20 28 28 6f 72 20 28 ve";. ((or (
2ae0: 61 6e 64 20 28 72 65 6d 6f 74 65 2d 66 6f 72 63 and (remote-forc
2af0: 65 2d 73 65 72 76 65 72 20 72 75 6e 72 65 6d 6f e-server runremo
2b00: 74 65 29 20 20 20 20 20 20 20 20 20 20 20 20 20 te)
2b10: 20 3b 3b 20 77 65 20 61 72 65 20 66 6f 72 63 69 ;; we are forci
2b20: 6e 67 20 61 20 73 65 72 76 65 72 20 61 6e 64 20 ng a server and
2b30: 64 6f 6e 27 74 20 79 65 74 20 68 61 76 65 20 61 don't yet have a
2b40: 20 63 6f 6e 6e 65 63 74 69 6f 6e 20 74 6f 20 6f connection to o
2b50: 6e 65 0a 09 20 20 20 20 20 20 20 28 6e 6f 74 20 ne.. (not
2b60: 28 72 65 6d 6f 74 65 2d 63 6f 6e 6e 64 61 74 20 (remote-conndat
2b70: 72 75 6e 72 65 6d 6f 74 65 29 29 29 0a 09 20 20 runremote)))..
2b80: 28 61 6e 64 20 28 6e 6f 74 20 28 63 64 72 20 28 (and (not (cdr (
2b90: 72 65 6d 6f 74 65 2d 68 68 2d 64 61 74 20 72 75 remote-hh-dat ru
2ba0: 6e 72 65 6d 6f 74 65 29 29 29 20 20 20 20 20 20 nremote)))
2bb0: 20 20 3b 3b 20 6e 6f 74 20 6f 6e 20 61 20 68 6f ;; not on a ho
2bc0: 6d 65 68 6f 73 74 20 0a 09 20 20 20 20 20 20 20 mehost ..
2bd0: 28 6e 6f 74 20 28 72 65 6d 6f 74 65 2d 63 6f 6e (not (remote-con
2be0: 6e 64 61 74 20 72 75 6e 72 65 6d 6f 74 65 29 29 ndat runremote))
2bf0: 29 29 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 )) ;;
2c00: 61 6e 64 20 6e 6f 20 63 6f 6e 6e 65 63 74 69 6f and no connectio
2c10: 6e 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 n. (debug:p
2c20: 72 69 6e 74 2d 69 6e 66 6f 20 31 32 20 2a 64 65 rint-info 12 *de
2c30: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
2c40: 22 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 "rmt:send-receiv
2c50: 65 2c 20 63 61 73 65 20 39 2c 20 68 68 2d 64 61 e, case 9, hh-da
2c60: 74 3a 20 22 20 28 72 65 6d 6f 74 65 2d 68 68 2d t: " (remote-hh-
2c70: 64 61 74 20 72 75 6e 72 65 6d 6f 74 65 29 20 22 dat runremote) "
2c80: 20 63 6f 6e 6e 64 61 74 3a 20 22 20 28 72 65 6d conndat: " (rem
2c90: 6f 74 65 2d 63 6f 6e 6e 64 61 74 20 72 75 6e 72 ote-conndat runr
2ca0: 65 6d 6f 74 65 29 29 0a 20 20 20 20 20 20 28 6d emote)). (m
2cb0: 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 72 6d utex-unlock! *rm
2cc0: 74 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 20 20 t-mutex*).
2cd0: 28 69 66 20 28 6e 6f 74 20 28 73 65 72 76 65 72 (if (not (server
2ce0: 3a 63 68 65 63 6b 2d 69 66 2d 72 75 6e 6e 69 6e :check-if-runnin
2cf0: 67 20 2a 74 6f 70 70 61 74 68 2a 29 29 20 3b 3b g *toppath*)) ;;
2d00: 20 77 68 6f 20 6b 6e 6f 77 73 2c 20 6d 61 79 62 who knows, mayb
2d10: 65 20 6f 6e 65 20 68 61 73 20 73 74 61 72 74 65 e one has starte
2d20: 64 20 75 70 3f 0a 09 20 20 28 73 65 72 76 65 72 d up?.. (server
2d30: 3a 73 74 61 72 74 2d 61 6e 64 2d 77 61 69 74 20 :start-and-wait
2d40: 2a 74 6f 70 70 61 74 68 2a 29 29 0a 20 20 20 20 *toppath*)).
2d50: 20 20 28 72 65 6d 6f 74 65 2d 63 6f 6e 6e 64 61 (remote-connda
2d60: 74 2d 73 65 74 21 20 72 75 6e 72 65 6d 6f 74 65 t-set! runremote
2d70: 20 28 72 6d 74 3a 67 65 74 2d 63 6f 6e 6e 65 63 (rmt:get-connec
2d80: 74 69 6f 6e 2d 69 6e 66 6f 20 2a 74 6f 70 70 61 tion-info *toppa
2d90: 74 68 2a 29 29 20 3b 3b 20 63 61 6c 6c 73 20 63 th*)) ;; calls c
2da0: 6c 69 65 6e 74 3a 73 65 74 75 70 20 77 68 69 63 lient:setup whic
2db0: 68 20 63 61 6c 6c 73 20 63 6c 69 65 6e 74 3a 73 h calls client:s
2dc0: 65 74 75 70 2d 68 74 74 70 0a 20 20 20 20 20 20 etup-http.
2dd0: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
2de0: 65 20 63 6d 64 20 72 69 64 20 70 61 72 61 6d 73 e cmd rid params
2df0: 20 61 74 74 65 6d 70 74 6e 75 6d 3a 20 61 74 74 attemptnum: att
2e00: 65 6d 70 74 6e 75 6d 29 29 20 3b 3b 20 54 4f 44 emptnum)) ;; TOD
2e10: 4f 3a 20 61 64 64 20 62 61 63 6b 2d 6f 66 66 20 O: add back-off
2e20: 74 69 6d 65 6f 75 74 20 61 73 0a 0a 20 20 20 20 timeout as..
2e30: 20 3b 3b 44 4f 54 20 43 41 53 45 31 30 20 5b 6c ;;DOT CASE10 [l
2e40: 61 62 65 6c 3d 22 6f 6e 20 68 6f 6d 65 68 6f 73 abel="on homehos
2e50: 74 22 5d 3b 0a 20 20 20 20 20 3b 3b 44 4f 54 20 t"];. ;;DOT
2e60: 4d 55 54 45 58 4c 4f 43 4b 20 2d 3e 20 43 41 53 MUTEXLOCK -> CAS
2e70: 45 31 30 20 5b 6c 61 62 65 6c 3d 22 73 65 72 76 E10 [label="serv
2e80: 65 72 20 6e 6f 74 20 72 65 71 75 69 72 65 64 2c er not required,
2e90: 5c 6e 6f 6e 20 68 6f 6d 65 68 6f 73 74 22 5d 3b \non homehost"];
2ea0: 20 7b 72 61 6e 6b 3d 73 61 6d 65 20 22 63 61 73 {rank=same "cas
2eb0: 65 20 31 30 22 20 43 41 53 45 31 30 7d 3b 0a 20 e 10" CASE10};.
2ec0: 20 20 20 20 3b 3b 44 4f 54 20 43 41 53 45 31 30 ;;DOT CASE10
2ed0: 20 2d 3e 20 22 72 6d 74 3a 6f 70 65 6e 2d 71 72 -> "rmt:open-qr
2ee0: 79 2d 63 6c 6f 73 65 2d 6c 6f 63 61 6c 6c 79 22 y-close-locally"
2ef0: 3b 0a 20 20 20 20 20 3b 3b 20 61 6c 6c 20 73 65 ;. ;; all se
2f00: 74 20 75 70 20 69 66 20 67 65 74 20 74 68 69 73 t up if get this
2f10: 20 66 61 72 2c 20 64 69 73 70 61 74 63 68 20 74 far, dispatch t
2f20: 68 65 20 71 75 65 72 79 0a 20 20 20 20 20 28 28 he query. ((
2f30: 61 6e 64 20 28 6e 6f 74 20 28 72 65 6d 6f 74 65 and (not (remote
2f40: 2d 66 6f 72 63 65 2d 73 65 72 76 65 72 20 72 75 -force-server ru
2f50: 6e 72 65 6d 6f 74 65 29 29 0a 09 20 20 20 28 63 nremote)).. (c
2f60: 64 72 20 28 72 65 6d 6f 74 65 2d 68 68 2d 64 61 dr (remote-hh-da
2f70: 74 20 72 75 6e 72 65 6d 6f 74 65 29 29 29 20 3b t runremote))) ;
2f80: 3b 20 77 65 20 61 72 65 20 6f 6e 20 68 6f 6d 65 ; we are on home
2f90: 68 6f 73 74 0a 20 20 20 20 20 20 28 6d 75 74 65 host. (mute
2fa0: 78 2d 75 6e 6c 6f 63 6b 21 20 2a 72 6d 74 2d 6d x-unlock! *rmt-m
2fb0: 75 74 65 78 2a 29 0a 20 20 20 20 20 20 28 64 65 utex*). (de
2fc0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 bug:print-info 1
2fd0: 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 2 *default-log-p
2fe0: 6f 72 74 2a 20 22 72 6d 74 3a 73 65 6e 64 2d 72 ort* "rmt:send-r
2ff0: 65 63 65 69 76 65 2c 20 63 61 73 65 20 31 30 22 eceive, case 10"
3000: 29 0a 20 20 20 20 20 20 28 72 6d 74 3a 6f 70 65 ). (rmt:ope
3010: 6e 2d 71 72 79 2d 63 6c 6f 73 65 2d 6c 6f 63 61 n-qry-close-loca
3020: 6c 6c 79 20 63 6d 64 20 28 69 66 20 72 69 64 20 lly cmd (if rid
3030: 72 69 64 20 30 29 20 70 61 72 61 6d 73 29 29 0a rid 0) params)).
3040: 0a 20 20 20 20 20 3b 3b 44 4f 54 20 43 41 53 45 . ;;DOT CASE
3050: 31 31 20 5b 6c 61 62 65 6c 3d 22 73 65 6e 64 5f 11 [label="send_
3060: 72 65 63 65 69 76 65 22 5d 3b 0a 20 20 20 20 20 receive"];.
3070: 3b 3b 44 4f 54 20 4d 55 54 45 58 4c 4f 43 4b 20 ;;DOT MUTEXLOCK
3080: 2d 3e 20 43 41 53 45 31 31 20 5b 6c 61 62 65 6c -> CASE11 [label
3090: 3d 22 65 6c 73 65 22 5d 3b 20 7b 72 61 6e 6b 3d ="else"]; {rank=
30a0: 73 61 6d 65 20 22 63 61 73 65 20 31 31 22 20 43 same "case 11" C
30b0: 41 53 45 31 31 7d 3b 0a 20 20 20 20 20 3b 3b 44 ASE11};. ;;D
30c0: 4f 54 20 43 41 53 45 31 31 20 2d 3e 20 22 72 6d OT CASE11 -> "rm
30d0: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 22 20 t:send-receive"
30e0: 5b 6c 61 62 65 6c 3d 22 63 61 6c 6c 20 66 61 69 [label="call fai
30f0: 6c 65 64 22 5d 3b 0a 20 20 20 20 20 3b 3b 44 4f led"];. ;;DO
3100: 54 20 43 41 53 45 31 31 20 2d 3e 20 22 52 45 53 T CASE11 -> "RES
3110: 55 4c 54 22 20 5b 6c 61 62 65 6c 3d 22 63 61 6c ULT" [label="cal
3120: 6c 20 73 75 63 63 65 65 64 65 64 22 5d 3b 0a 20 l succeeded"];.
3130: 20 20 20 20 3b 3b 20 6e 6f 74 20 6f 6e 20 68 6f ;; not on ho
3140: 6d 65 68 6f 73 74 2c 20 64 6f 20 73 65 72 76 65 mehost, do serve
3150: 72 20 71 75 65 72 79 0a 20 20 20 20 20 28 65 6c r query. (el
3160: 73 65 0a 20 20 20 20 20 20 28 6d 75 74 65 78 2d se. (mutex-
3170: 75 6e 6c 6f 63 6b 21 20 2a 72 6d 74 2d 6d 75 74 unlock! *rmt-mut
3180: 65 78 2a 29 0a 20 20 20 20 20 20 28 64 65 62 75 ex*). (debu
3190: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 32 20 g:print-info 12
31a0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
31b0: 74 2a 20 22 72 6d 74 3a 73 65 6e 64 2d 72 65 63 t* "rmt:send-rec
31c0: 65 69 76 65 2c 20 63 61 73 65 20 20 39 22 29 0a eive, case 9").
31d0: 20 20 20 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 (mutex-loc
31e0: 6b 21 20 2a 72 6d 74 2d 6d 75 74 65 78 2a 29 0a k! *rmt-mutex*).
31f0: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 63 6f (let* ((co
3200: 6e 6e 69 6e 66 6f 20 28 72 65 6d 6f 74 65 2d 63 nninfo (remote-c
3210: 6f 6e 6e 64 61 74 20 72 75 6e 72 65 6d 6f 74 65 onndat runremote
3220: 29 29 0a 09 20 20 20 20 20 28 64 61 74 20 20 20 )).. (dat
3230: 20 20 20 28 63 61 73 65 20 28 72 65 6d 6f 74 65 (case (remote
3240: 2d 74 72 61 6e 73 70 6f 72 74 20 72 75 6e 72 65 -transport runre
3250: 6d 6f 74 65 29 0a 09 09 09 20 28 28 68 74 74 70 mote).... ((http
3260: 29 20 28 63 6f 6e 64 69 74 69 6f 6e 2d 63 61 73 ) (condition-cas
3270: 65 20 3b 3b 20 68 61 6e 64 6c 69 6e 67 20 68 65 e ;; handling he
3280: 72 65 20 68 61 73 20 63 61 75 73 65 64 20 61 20 re has caused a
3290: 6c 6f 74 20 6f 66 20 70 72 6f 62 6c 65 6d 73 2e lot of problems.
32a0: 20 48 6f 77 65 76 65 72 20 69 74 20 69 73 20 6e However it is n
32b0: 65 65 64 65 64 20 74 6f 20 64 65 61 6c 20 77 69 eeded to deal wi
32c0: 74 68 20 61 74 74 65 6d 74 70 65 64 20 63 6f 6d th attemtped com
32d0: 6d 75 6e 69 63 61 74 69 6f 6e 20 74 6f 20 73 65 munication to se
32e0: 72 76 65 72 73 20 74 68 61 74 20 68 61 76 65 20 rvers that have
32f0: 67 6f 6e 65 20 61 77 61 79 0a 20 20 20 20 20 20 gone away.
3300: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3310: 20 20 20 20 20 20 20 20 20 20 20 20 28 68 74 74 (htt
3320: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 65 p-transport:clie
3330: 6e 74 2d 61 70 69 2d 73 65 6e 64 2d 72 65 63 65 nt-api-send-rece
3340: 69 76 65 20 30 20 63 6f 6e 6e 69 6e 66 6f 20 63 ive 0 conninfo c
3350: 6d 64 20 70 61 72 61 6d 73 29 0a 20 20 20 20 20 md params).
3360: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3370: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 63 ((c
3380: 6f 6d 6d 66 61 69 6c 29 28 76 65 63 74 6f 72 20 ommfail)(vector
3390: 23 66 20 22 63 6f 6d 6d 75 6e 69 63 61 74 69 6f #f "communicatio
33a0: 6e 73 20 66 61 69 6c 22 29 29 0a 20 20 20 20 20 ns fail")).
33b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
33c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 65 ((e
33d0: 78 6e 29 28 76 65 63 74 6f 72 20 23 66 20 22 6f xn)(vector #f "o
33e0: 74 68 65 72 20 66 61 69 6c 22 20 28 70 72 69 6e ther fail" (prin
33f0: 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 29 29 29 29 t-call-chain))))
3400: 29 0a 09 09 09 20 28 65 6c 73 65 0a 09 09 09 20 ).... (else....
3410: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
3420: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
3430: 74 2a 20 22 45 52 52 4f 52 3a 20 74 72 61 6e 73 t* "ERROR: trans
3440: 70 6f 72 74 20 22 20 28 72 65 6d 6f 74 65 2d 74 port " (remote-t
3450: 72 61 6e 73 70 6f 72 74 20 72 75 6e 72 65 6d 6f ransport runremo
3460: 74 65 29 20 22 20 6e 6f 74 20 73 75 70 70 6f 72 te) " not suppor
3470: 74 65 64 22 29 0a 09 09 09 20 20 28 65 78 69 74 ted").... (exit
3480: 29 29 29 29 0a 09 20 20 20 20 20 28 73 75 63 63 )))).. (succ
3490: 65 73 73 20 20 28 69 66 20 28 76 65 63 74 6f 72 ess (if (vector
34a0: 3f 20 64 61 74 29 20 28 76 65 63 74 6f 72 2d 72 ? dat) (vector-r
34b0: 65 66 20 64 61 74 20 30 29 20 23 66 29 29 0a 09 ef dat 0) #f))..
34c0: 20 20 20 20 20 28 72 65 73 20 20 20 20 20 20 28 (res (
34d0: 69 66 20 28 76 65 63 74 6f 72 3f 20 64 61 74 29 if (vector? dat)
34e0: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 64 61 74 (vector-ref dat
34f0: 20 31 29 20 23 66 29 29 29 0a 09 28 69 66 20 28 1) #f)))..(if (
3500: 76 65 63 74 6f 72 3f 20 63 6f 6e 6e 69 6e 66 6f vector? conninfo
3510: 29 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 )(http-transport
3520: 3a 73 65 72 76 65 72 2d 64 61 74 2d 75 70 64 61 :server-dat-upda
3530: 74 65 2d 6c 61 73 74 2d 61 63 63 65 73 73 20 63 te-last-access c
3540: 6f 6e 6e 69 6e 66 6f 29 29 20 3b 3b 20 72 65 66 onninfo)) ;; ref
3550: 72 65 73 68 20 61 63 63 65 73 73 20 74 69 6d 65 resh access time
3560: 0a 09 3b 3b 20 28 6d 75 74 65 78 2d 75 6e 6c 6f ..;; (mutex-unlo
3570: 63 6b 21 20 2a 72 6d 74 2d 6d 75 74 65 78 2a 29 ck! *rmt-mutex*)
3580: 0a 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a . (debug:
3590: 70 72 69 6e 74 2d 69 6e 66 6f 20 31 33 20 2a 64 print-info 13 *d
35a0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
35b0: 20 22 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 "rmt:send-recei
35c0: 76 65 2c 20 63 61 73 65 20 20 39 2e 20 63 6f 6e ve, case 9. con
35d0: 6e 69 6e 66 6f 3d 22 20 63 6f 6e 6e 69 6e 66 6f ninfo=" conninfo
35e0: 20 22 20 64 61 74 3d 22 20 64 61 74 20 22 20 72 " dat=" dat " r
35f0: 75 6e 72 65 6d 6f 74 65 20 3d 20 22 20 72 75 6e unremote = " run
3600: 72 65 6d 6f 74 65 29 0a 09 28 6d 75 74 65 78 2d remote)..(mutex-
3610: 75 6e 6c 6f 63 6b 21 20 2a 72 6d 74 2d 6d 75 74 unlock! *rmt-mut
3620: 65 78 2a 29 0a 09 28 69 66 20 73 75 63 63 65 73 ex*)..(if succes
3630: 73 20 3b 3b 20 73 75 63 63 65 73 73 20 6f 6e 6c s ;; success onl
3640: 79 20 74 65 6c 6c 73 20 75 73 20 74 68 61 74 20 y tells us that
3650: 74 68 65 20 74 72 61 6e 73 70 6f 72 74 20 77 61 the transport wa
3660: 73 20 73 75 63 63 65 73 73 66 75 6c 2c 20 68 61 s successful, ha
3670: 76 65 20 74 6f 20 65 78 61 6d 69 6e 65 20 74 68 ve to examine th
3680: 65 20 64 61 74 61 20 74 6f 20 73 65 65 20 69 66 e data to see if
3690: 20 74 68 65 72 65 20 77 61 73 20 61 20 64 65 74 there was a det
36a0: 65 63 74 65 64 20 69 73 73 75 65 20 61 74 20 74 ected issue at t
36b0: 68 65 20 6f 74 68 65 72 20 65 6e 64 0a 09 20 20 he other end..
36c0: 20 20 28 69 66 20 28 61 6e 64 20 28 76 65 63 74 (if (and (vect
36d0: 6f 72 3f 20 72 65 73 29 0a 09 09 20 20 20 20 20 or? res)...
36e0: 28 65 71 3f 20 28 76 65 63 74 6f 72 2d 6c 65 6e (eq? (vector-len
36f0: 67 74 68 20 72 65 73 29 20 32 29 0a 09 09 20 20 gth res) 2)...
3700: 20 20 20 28 65 71 3f 20 28 76 65 63 74 6f 72 2d (eq? (vector-
3710: 72 65 66 20 72 65 73 20 31 29 20 27 6f 76 65 72 ref res 1) 'over
3720: 6c 6f 61 64 65 64 29 29 20 3b 3b 20 73 69 6e 63 loaded)) ;; sinc
3730: 65 20 77 65 20 61 72 65 20 6c 6f 6f 6b 69 6e 67 e we are looking
3740: 20 61 74 20 74 68 65 20 64 61 74 61 20 74 6f 20 at the data to
3750: 63 61 72 72 79 20 74 68 65 20 65 72 72 6f 72 20 carry the error
3760: 77 65 27 6c 6c 20 75 73 65 20 61 20 66 61 69 72 we'll use a fair
3770: 6c 79 20 6f 62 74 75 73 65 20 63 6f 6d 62 6f 20 ly obtuse combo
3780: 74 6f 20 6d 69 6e 69 6d 69 73 65 20 74 68 65 20 to minimise the
3790: 63 68 61 6e 63 65 73 20 6f 66 20 73 6f 6d 65 20 chances of some
37a0: 73 6f 72 74 20 6f 66 20 63 6f 6c 6c 69 73 69 6f sort of collisio
37b0: 6e 2e 0a 09 09 28 6c 65 74 20 28 28 77 61 69 74 n....(let ((wait
37c0: 2d 64 65 6c 61 79 20 28 2b 20 61 74 74 65 6d 70 -delay (+ attemp
37d0: 74 6e 75 6d 20 28 2a 20 61 74 74 65 6d 70 74 6e tnum (* attemptn
37e0: 75 6d 20 31 30 29 29 29 29 0a 09 09 20 20 28 64 um 10))))... (d
37f0: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
3800: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
3810: 22 57 41 52 4e 49 4e 47 3a 20 73 65 72 76 65 72 "WARNING: server
3820: 20 69 73 20 6f 76 65 72 6c 6f 61 64 65 64 2e 20 is overloaded.
3830: 44 65 6c 61 79 69 6e 67 20 22 20 77 61 69 74 2d Delaying " wait-
3840: 64 65 6c 61 79 20 22 20 73 65 63 6f 6e 64 73 20 delay " seconds
3850: 61 6e 64 20 74 72 79 69 6e 67 20 63 61 6c 6c 20 and trying call
3860: 61 67 61 69 6e 2e 22 29 0a 09 09 20 20 28 6d 75 again.")... (mu
3870: 74 65 78 2d 6c 6f 63 6b 21 20 2a 72 6d 74 2d 6d tex-lock! *rmt-m
3880: 75 74 65 78 2a 29 0a 09 09 20 20 28 68 74 74 70 utex*)... (http
3890: 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c 6f 73 65 -transport:close
38a0: 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 20 61 72 65 -connections are
38b0: 61 2d 64 61 74 3a 20 72 75 6e 72 65 6d 6f 74 65 a-dat: runremote
38c0: 29 0a 09 09 20 20 28 73 65 74 21 20 2a 72 75 6e )... (set! *run
38d0: 72 65 6d 6f 74 65 2a 20 23 66 29 20 3b 3b 20 66 remote* #f) ;; f
38e0: 6f 72 63 65 20 73 74 61 72 74 69 6e 67 20 6f 76 orce starting ov
38f0: 65 72 0a 09 09 20 20 28 6d 75 74 65 78 2d 75 6e er... (mutex-un
3900: 6c 6f 63 6b 21 20 2a 72 6d 74 2d 6d 75 74 65 78 lock! *rmt-mutex
3910: 2a 29 0a 09 09 20 20 28 74 68 72 65 61 64 2d 73 *)... (thread-s
3920: 6c 65 65 70 21 20 77 61 69 74 2d 64 65 6c 61 79 leep! wait-delay
3930: 29 0a 09 09 20 20 28 72 6d 74 3a 73 65 6e 64 2d )... (rmt:send-
3940: 72 65 63 65 69 76 65 20 63 6d 64 20 72 69 64 20 receive cmd rid
3950: 70 61 72 61 6d 73 20 61 74 74 65 6d 70 74 6e 75 params attemptnu
3960: 6d 3a 20 28 2b 20 61 74 74 65 6d 70 74 6e 75 6d m: (+ attemptnum
3970: 20 31 29 29 29 0a 09 09 72 65 73 29 20 3b 3b 20 1)))...res) ;;
3980: 41 6c 6c 20 67 6f 6f 64 2c 20 72 65 74 75 72 6e All good, return
3990: 20 72 65 73 0a 09 20 20 20 20 28 62 65 67 69 6e res.. (begin
39a0: 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 .. (debug:p
39b0: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
39c0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 log-port* "WARNI
39d0: 4e 47 3a 20 63 6f 6d 6d 75 6e 69 63 61 74 69 6f NG: communicatio
39e0: 6e 20 66 61 69 6c 65 64 2e 20 54 72 79 69 6e 67 n failed. Trying
39f0: 20 61 67 61 69 6e 2c 20 74 72 79 20 6e 75 6d 3a again, try num:
3a00: 20 22 20 61 74 74 65 6d 70 74 6e 75 6d 29 0a 09 " attemptnum)..
3a10: 20 20 20 20 20 20 28 72 65 6d 6f 74 65 2d 63 6f (remote-co
3a20: 6e 6e 64 61 74 2d 73 65 74 21 20 20 20 20 72 75 nndat-set! ru
3a30: 6e 72 65 6d 6f 74 65 20 23 66 29 0a 09 20 20 20 nremote #f)..
3a40: 20 20 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f (http-transpo
3a50: 72 74 3a 63 6c 6f 73 65 2d 63 6f 6e 6e 65 63 74 rt:close-connect
3a60: 69 6f 6e 73 20 61 72 65 61 2d 64 61 74 3a 20 72 ions area-dat: r
3a70: 75 6e 72 65 6d 6f 74 65 29 0a 09 20 20 20 20 20 unremote)..
3a80: 20 28 72 65 6d 6f 74 65 2d 73 65 72 76 65 72 2d (remote-server-
3a90: 75 72 6c 2d 73 65 74 21 20 72 75 6e 72 65 6d 6f url-set! runremo
3aa0: 74 65 20 23 66 29 0a 09 20 20 20 20 20 20 28 64 te #f).. (d
3ab0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
3ac0: 31 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 12 *default-log-
3ad0: 70 6f 72 74 2a 20 22 72 6d 74 3a 73 65 6e 64 2d port* "rmt:send-
3ae0: 72 65 63 65 69 76 65 2c 20 63 61 73 65 20 20 39 receive, case 9
3af0: 2e 31 22 29 0a 09 20 20 20 20 20 20 3b 3b 20 28 .1").. ;; (
3b00: 69 66 20 28 6e 6f 74 20 28 73 65 72 76 65 72 3a if (not (server:
3b10: 63 68 65 63 6b 2d 69 66 2d 72 75 6e 6e 69 6e 67 check-if-running
3b20: 20 2a 74 6f 70 70 61 74 68 2a 29 29 0a 09 20 20 *toppath*))..
3b30: 20 20 20 20 3b 3b 20 09 20 20 28 73 65 72 76 65 ;; . (serve
3b40: 72 3a 73 74 61 72 74 2d 61 6e 64 2d 77 61 69 74 r:start-and-wait
3b50: 20 2a 74 6f 70 70 61 74 68 2a 29 29 0a 09 20 20 *toppath*))..
3b60: 20 20 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 (rmt:send-re
3b70: 63 65 69 76 65 20 63 6d 64 20 72 69 64 20 70 61 ceive cmd rid pa
3b80: 72 61 6d 73 20 61 74 74 65 6d 70 74 6e 75 6d 3a rams attemptnum:
3b90: 20 28 2b 20 61 74 74 65 6d 70 74 6e 75 6d 20 31 (+ attemptnum 1
3ba0: 29 29 29 29 29 29 29 29 29 0a 0a 20 20 20 20 3b ))))))))).. ;
3bb0: 3b 44 4f 54 20 7d 0a 20 20 20 20 0a 3b 3b 20 28 ;DOT }. .;; (
3bc0: 64 65 66 69 6e 65 20 28 72 6d 74 3a 75 70 64 61 define (rmt:upda
3bd0: 74 65 2d 64 62 2d 73 74 61 74 73 20 72 75 6e 2d te-db-stats run-
3be0: 69 64 20 72 61 77 63 6d 64 20 70 61 72 61 6d 73 id rawcmd params
3bf0: 20 64 75 72 61 74 69 6f 6e 29 0a 3b 3b 20 20 20 duration).;;
3c00: 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 64 62 (mutex-lock! *db
3c10: 2d 73 74 61 74 73 2d 6d 75 74 65 78 2a 29 0a 3b -stats-mutex*).;
3c20: 3b 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 ; (handle-exce
3c30: 70 74 69 6f 6e 73 0a 3b 3b 20 20 20 20 65 78 6e ptions.;; exn
3c40: 0a 3b 3b 20 20 20 20 28 62 65 67 69 6e 0a 3b 3b .;; (begin.;;
3c50: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
3c60: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
3c70: 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 g-port* "WARNING
3c80: 3a 20 73 74 61 74 73 20 63 6f 6c 6c 65 63 74 69 : stats collecti
3c90: 6f 6e 20 66 61 69 6c 65 64 20 69 6e 20 75 70 64 on failed in upd
3ca0: 61 74 65 2d 64 62 2d 73 74 61 74 73 22 29 0a 3b ate-db-stats").;
3cb0: 3b 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 ; (debug:pr
3cc0: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
3cd0: 6f 67 2d 70 6f 72 74 2a 20 22 20 6d 65 73 73 61 og-port* " messa
3ce0: 67 65 3a 20 22 20 28 28 63 6f 6e 64 69 74 69 6f ge: " ((conditio
3cf0: 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 n-property-acces
3d00: 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 sor 'exn 'messag
3d10: 65 29 20 65 78 6e 29 29 0a 3b 3b 20 20 20 20 20 e) exn)).;;
3d20: 20 28 70 72 69 6e 74 20 22 65 78 6e 3d 22 20 28 (print "exn=" (
3d30: 63 6f 6e 64 69 74 69 6f 6e 2d 3e 6c 69 73 74 20 condition->list
3d40: 65 78 6e 29 29 0a 3b 3b 20 20 20 20 20 20 23 66 exn)).;; #f
3d50: 29 20 3b 3b 20 69 66 20 74 68 69 73 20 66 61 69 ) ;; if this fai
3d60: 6c 73 20 77 65 20 64 6f 6e 27 74 20 63 61 72 65 ls we don't care
3d70: 2c 20 69 74 20 69 73 20 6a 75 73 74 20 73 74 61 , it is just sta
3d80: 74 73 0a 3b 3b 20 20 20 20 28 6c 65 74 2a 20 28 ts.;; (let* (
3d90: 28 63 6d 64 20 20 20 20 20 20 28 63 6f 6e 63 20 (cmd (conc
3da0: 22 72 75 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 64 "run-id=" run-id
3db0: 20 22 20 22 20 28 69 66 20 28 65 71 3f 20 72 61 " " (if (eq? ra
3dc0: 77 63 6d 64 20 27 67 65 6e 65 72 61 6c 2d 63 61 wcmd 'general-ca
3dd0: 6c 6c 29 20 28 63 61 72 20 70 61 72 61 6d 73 29 ll) (car params)
3de0: 20 72 61 77 63 6d 64 29 29 29 0a 3b 3b 20 09 20 rawcmd))).;; .
3df0: 20 28 73 74 61 74 2d 76 65 63 20 28 68 61 73 68 (stat-vec (hash
3e00: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
3e10: 6c 74 20 2a 64 62 2d 73 74 61 74 73 2a 20 63 6d lt *db-stats* cm
3e20: 64 20 23 66 29 29 29 0a 3b 3b 20 20 20 20 20 20 d #f))).;;
3e30: 28 69 66 20 28 6e 6f 74 20 28 76 65 63 74 6f 72 (if (not (vector
3e40: 3f 20 73 74 61 74 2d 76 65 63 29 29 0a 3b 3b 20 ? stat-vec)).;;
3e50: 09 20 28 6c 65 74 20 28 28 6e 65 77 76 65 63 20 . (let ((newvec
3e60: 28 76 65 63 74 6f 72 20 30 20 30 29 29 29 0a 3b (vector 0 0))).;
3e70: 3b 20 09 20 20 20 28 68 61 73 68 2d 74 61 62 6c ; . (hash-tabl
3e80: 65 2d 73 65 74 21 20 2a 64 62 2d 73 74 61 74 73 e-set! *db-stats
3e90: 2a 20 63 6d 64 20 6e 65 77 76 65 63 29 0a 3b 3b * cmd newvec).;;
3ea0: 20 09 20 20 20 28 73 65 74 21 20 73 74 61 74 2d . (set! stat-
3eb0: 76 65 63 20 6e 65 77 76 65 63 29 29 29 0a 3b 3b vec newvec))).;;
3ec0: 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 73 65 (vector-se
3ed0: 74 21 20 73 74 61 74 2d 76 65 63 20 30 20 28 2b t! stat-vec 0 (+
3ee0: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 73 74 61 (vector-ref sta
3ef0: 74 2d 76 65 63 20 30 29 20 31 29 29 0a 3b 3b 20 t-vec 0) 1)).;;
3f00: 20 20 20 20 20 28 76 65 63 74 6f 72 2d 73 65 74 (vector-set
3f10: 21 20 73 74 61 74 2d 76 65 63 20 31 20 28 2b 20 ! stat-vec 1 (+
3f20: 28 76 65 63 74 6f 72 2d 72 65 66 20 73 74 61 74 (vector-ref stat
3f30: 2d 76 65 63 20 31 29 20 64 75 72 61 74 69 6f 6e -vec 1) duration
3f40: 29 29 29 29 0a 3b 3b 20 20 20 28 6d 75 74 65 78 )))).;; (mutex
3f50: 2d 75 6e 6c 6f 63 6b 21 20 2a 64 62 2d 73 74 61 -unlock! *db-sta
3f60: 74 73 2d 6d 75 74 65 78 2a 29 29 0a 0a 28 64 65 ts-mutex*))..(de
3f70: 66 69 6e 65 20 28 72 6d 74 3a 70 72 69 6e 74 2d fine (rmt:print-
3f80: 64 62 2d 73 74 61 74 73 29 0a 20 20 28 6c 65 74 db-stats). (let
3f90: 20 28 28 66 6d 74 73 74 72 20 22 7e 34 30 61 7e ((fmtstr "~40a~
3fa0: 37 2d 64 7e 39 2d 64 7e 32 30 2c 32 2d 66 22 29 7-d~9-d~20,2-f")
3fb0: 29 20 3b 3b 20 22 7e 32 30 2c 32 2d 66 22 0a 20 ) ;; "~20,2-f".
3fc0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
3fd0: 31 38 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 18 *default-log-
3fe0: 70 6f 72 74 2a 20 22 44 42 20 53 74 61 74 73 5c port* "DB Stats\
3ff0: 6e 3d 3d 3d 3d 3d 3d 3d 3d 22 29 0a 20 20 20 20 n========").
4000: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 38 20 (debug:print 18
4010: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
4020: 74 2a 20 28 66 6f 72 6d 61 74 20 23 66 20 22 7e t* (format #f "~
4030: 34 30 61 7e 38 61 7e 31 30 61 7e 31 30 61 22 20 40a~8a~10a~10a"
4040: 22 43 6d 64 22 20 22 43 6f 75 6e 74 22 20 22 54 "Cmd" "Count" "T
4050: 6f 74 54 69 6d 65 22 20 22 41 76 67 22 29 29 0a otTime" "Avg")).
4060: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c (for-each (l
4070: 61 6d 62 64 61 20 28 63 6d 64 29 0a 09 09 28 6c ambda (cmd)...(l
4080: 65 74 20 28 28 63 6d 64 2d 64 61 74 20 28 68 61 et ((cmd-dat (ha
4090: 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 2a 64 62 sh-table-ref *db
40a0: 2d 73 74 61 74 73 2a 20 63 6d 64 29 29 29 0a 09 -stats* cmd)))..
40b0: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 . (debug:print
40c0: 31 38 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 18 *default-log-
40d0: 70 6f 72 74 2a 20 28 66 6f 72 6d 61 74 20 23 66 port* (format #f
40e0: 20 66 6d 74 73 74 72 20 63 6d 64 20 28 76 65 63 fmtstr cmd (vec
40f0: 74 6f 72 2d 72 65 66 20 63 6d 64 2d 64 61 74 20 tor-ref cmd-dat
4100: 30 29 20 28 76 65 63 74 6f 72 2d 72 65 66 20 63 0) (vector-ref c
4110: 6d 64 2d 64 61 74 20 31 29 20 28 2f 20 28 76 65 md-dat 1) (/ (ve
4120: 63 74 6f 72 2d 72 65 66 20 63 6d 64 2d 64 61 74 ctor-ref cmd-dat
4130: 20 31 29 28 76 65 63 74 6f 72 2d 72 65 66 20 63 1)(vector-ref c
4140: 6d 64 2d 64 61 74 20 30 29 29 29 29 29 29 0a 09 md-dat 0))))))..
4150: 20 20 20 20 20 20 28 73 6f 72 74 20 28 68 61 73 (sort (has
4160: 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 2a 64 62 h-table-keys *db
4170: 2d 73 74 61 74 73 2a 29 0a 09 09 20 20 20 20 28 -stats*)... (
4180: 6c 61 6d 62 64 61 20 28 61 20 62 29 0a 09 09 20 lambda (a b)...
4190: 20 20 20 20 20 28 3e 20 28 76 65 63 74 6f 72 2d (> (vector-
41a0: 72 65 66 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ref (hash-table-
41b0: 72 65 66 20 2a 64 62 2d 73 74 61 74 73 2a 20 61 ref *db-stats* a
41c0: 29 20 30 29 0a 09 09 09 20 28 76 65 63 74 6f 72 ) 0).... (vector
41d0: 2d 72 65 66 20 28 68 61 73 68 2d 74 61 62 6c 65 -ref (hash-table
41e0: 2d 72 65 66 20 2a 64 62 2d 73 74 61 74 73 2a 20 -ref *db-stats*
41f0: 62 29 20 30 29 29 29 29 29 29 29 0a 0a 28 64 65 b) 0)))))))..(de
4200: 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 6d 61 fine (rmt:get-ma
4210: 78 2d 71 75 65 72 79 2d 61 76 65 72 61 67 65 20 x-query-average
4220: 72 75 6e 2d 69 64 29 0a 20 20 28 6d 75 74 65 78 run-id). (mutex
4230: 2d 6c 6f 63 6b 21 20 2a 64 62 2d 73 74 61 74 73 -lock! *db-stats
4240: 2d 6d 75 74 65 78 2a 29 0a 20 20 28 6c 65 74 2a -mutex*). (let*
4250: 20 28 28 72 75 6e 6b 65 79 20 28 63 6f 6e 63 20 ((runkey (conc
4260: 22 72 75 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 64 "run-id=" run-id
4270: 20 22 20 22 29 29 0a 09 20 28 63 6d 64 73 20 20 " ")).. (cmds
4280: 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 (filter (lambda
4290: 20 28 78 29 0a 09 09 09 20 20 20 28 73 75 62 73 (x).... (subs
42a0: 74 72 69 6e 67 2d 69 6e 64 65 78 20 72 75 6e 6b tring-index runk
42b0: 65 79 20 78 29 29 0a 09 09 09 20 28 68 61 73 68 ey x)).... (hash
42c0: 2d 74 61 62 6c 65 2d 6b 65 79 73 20 2a 64 62 2d -table-keys *db-
42d0: 73 74 61 74 73 2a 29 29 29 0a 09 20 28 72 65 73 stats*))).. (res
42e0: 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 63 (if (null? c
42f0: 6d 64 73 29 0a 09 09 20 20 20 20 20 28 63 6f 6e mds)... (con
4300: 73 20 27 6e 6f 6e 65 20 30 29 0a 09 09 20 20 20 s 'none 0)...
4310: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 63 6d (let loop ((cm
4320: 64 20 28 63 61 72 20 63 6d 64 73 29 29 0a 09 09 d (car cmds))...
4330: 09 09 28 74 61 6c 20 28 63 64 72 20 63 6d 64 73 ..(tal (cdr cmds
4340: 29 29 0a 09 09 09 09 28 6d 61 78 2d 63 6d 64 20 )).....(max-cmd
4350: 28 63 61 72 20 63 6d 64 73 29 29 0a 09 09 09 09 (car cmds)).....
4360: 28 72 65 73 20 30 29 29 0a 09 09 20 20 20 20 20 (res 0))...
4370: 20 20 28 6c 65 74 2a 20 28 28 63 6d 64 2d 64 61 (let* ((cmd-da
4380: 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 t (hash-table-re
4390: 66 20 2a 64 62 2d 73 74 61 74 73 2a 20 63 6d 64 f *db-stats* cmd
43a0: 29 29 0a 09 09 09 20 20 20 20 20 20 28 74 6f 74 )).... (tot
43b0: 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 (vector-ref
43c0: 20 63 6d 64 2d 64 61 74 20 30 29 29 0a 09 09 09 cmd-dat 0))....
43d0: 20 20 20 20 20 20 28 63 75 72 72 61 76 67 20 28 (curravg (
43e0: 2f 20 28 76 65 63 74 6f 72 2d 72 65 66 20 63 6d / (vector-ref cm
43f0: 64 2d 64 61 74 20 31 29 20 28 76 65 63 74 6f 72 d-dat 1) (vector
4400: 2d 72 65 66 20 63 6d 64 2d 64 61 74 20 30 29 29 -ref cmd-dat 0))
4410: 29 20 3b 3b 20 63 6f 75 6e 74 20 69 73 20 6e 65 ) ;; count is ne
4420: 76 65 72 20 7a 65 72 6f 20 62 79 20 63 6f 6e 73 ver zero by cons
4430: 74 72 75 63 74 69 6f 6e 0a 09 09 09 20 20 20 20 truction....
4440: 20 20 28 63 75 72 72 6d 61 78 20 28 6d 61 78 20 (currmax (max
4450: 72 65 73 20 63 75 72 72 61 76 67 29 29 0a 09 09 res curravg))...
4460: 09 20 20 20 20 20 20 28 6e 65 77 6d 61 78 2d 63 . (newmax-c
4470: 6d 64 20 28 69 66 20 28 3e 20 63 75 72 72 61 76 md (if (> currav
4480: 67 20 72 65 73 29 20 63 6d 64 20 6d 61 78 2d 63 g res) cmd max-c
4490: 6d 64 29 29 29 0a 09 09 09 20 28 69 66 20 28 6e md))).... (if (n
44a0: 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 09 20 20 20 ull? tal)....
44b0: 20 20 28 69 66 20 28 3e 20 74 6f 74 20 31 30 29 (if (> tot 10)
44c0: 0a 09 09 09 09 20 28 63 6f 6e 73 20 6e 65 77 6d ..... (cons newm
44d0: 61 78 2d 63 6d 64 20 63 75 72 72 6d 61 78 29 0a ax-cmd currmax).
44e0: 09 09 09 09 20 28 63 6f 6e 73 20 27 6e 6f 6e 65 .... (cons 'none
44f0: 20 30 29 29 0a 09 09 09 20 20 20 20 20 28 6c 6f 0)).... (lo
4500: 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 op (car tal)(cdr
4510: 20 74 61 6c 29 20 6e 65 77 6d 61 78 2d 63 6d 64 tal) newmax-cmd
4520: 20 63 75 72 72 6d 61 78 29 29 29 29 29 29 29 0a currmax))))))).
4530: 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 (mutex-unloc
4540: 6b 21 20 2a 64 62 2d 73 74 61 74 73 2d 6d 75 74 k! *db-stats-mut
4550: 65 78 2a 29 0a 20 20 20 20 72 65 73 29 29 0a 0a ex*). res))..
4560: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 6f 70 65 (define (rmt:ope
4570: 6e 2d 71 72 79 2d 63 6c 6f 73 65 2d 6c 6f 63 61 n-qry-close-loca
4580: 6c 6c 79 20 63 6d 64 20 72 75 6e 2d 69 64 20 70 lly cmd run-id p
4590: 61 72 61 6d 73 20 23 21 6b 65 79 20 28 72 65 6d arams #!key (rem
45a0: 72 65 74 72 69 65 73 20 35 29 29 0a 20 20 28 6c retries 5)). (l
45b0: 65 74 2a 20 28 28 71 72 79 2d 69 73 2d 77 72 69 et* ((qry-is-wri
45c0: 74 65 20 20 20 28 6e 6f 74 20 28 6d 65 6d 62 65 te (not (membe
45d0: 72 20 63 6d 64 20 61 70 69 3a 72 65 61 64 2d 6f r cmd api:read-o
45e0: 6e 6c 79 2d 71 75 65 72 69 65 73 29 29 29 0a 09 nly-queries)))..
45f0: 20 28 64 62 2d 66 69 6c 65 2d 70 61 74 68 20 20 (db-file-path
4600: 20 28 64 62 3a 64 62 66 69 6c 65 2d 70 61 74 68 (db:dbfile-path
4610: 29 29 20 3b 3b 20 20 30 29 29 0a 09 20 28 64 62 )) ;; 0)).. (db
4620: 73 74 72 75 63 74 2d 6c 6f 63 61 6c 20 28 64 62 struct-local (db
4630: 3a 73 65 74 75 70 20 23 74 29 29 20 20 3b 3b 20 :setup #t)) ;;
4640: 6d 61 6b 65 2d 64 62 72 3a 64 62 73 74 72 75 63 make-dbr:dbstruc
4650: 74 20 70 61 74 68 3a 20 20 64 62 64 69 72 20 6c t path: dbdir l
4660: 6f 63 61 6c 3a 20 23 74 29 29 29 0a 09 20 28 72 ocal: #t))).. (r
4670: 65 61 64 2d 6f 6e 6c 79 20 20 20 20 20 20 28 6e ead-only (n
4680: 6f 74 20 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 ot (file-write-a
4690: 63 63 65 73 73 3f 20 64 62 2d 66 69 6c 65 2d 70 ccess? db-file-p
46a0: 61 74 68 29 29 29 0a 09 20 28 73 74 61 72 74 20 ath))).. (start
46b0: 20 20 20 20 20 20 20 20 20 28 63 75 72 72 65 6e (curren
46c0: 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 29 29 t-milliseconds))
46d0: 0a 09 20 28 72 65 73 64 61 74 20 20 20 20 20 20 .. (resdat
46e0: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 61 6e 64 (if (not (and
46f0: 20 72 65 61 64 2d 6f 6e 6c 79 20 71 72 79 2d 69 read-only qry-i
4700: 73 2d 77 72 69 74 65 29 29 0a 09 09 09 20 20 20 s-write))....
4710: 20 20 28 6c 65 74 20 28 28 76 20 28 61 70 69 3a (let ((v (api:
4720: 65 78 65 63 75 74 65 2d 72 65 71 75 65 73 74 73 execute-requests
4730: 20 64 62 73 74 72 75 63 74 2d 6c 6f 63 61 6c 20 dbstruct-local
4740: 28 76 65 63 74 6f 72 20 28 73 79 6d 62 6f 6c 2d (vector (symbol-
4750: 3e 73 74 72 69 6e 67 20 63 6d 64 29 20 70 61 72 >string cmd) par
4760: 61 6d 73 29 29 29 29 0a 09 09 09 20 20 20 20 20 ams))))....
4770: 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 (handle-except
4780: 69 6f 6e 73 20 3b 3b 20 74 68 65 72 65 20 68 61 ions ;; there ha
4790: 73 20 62 65 65 6e 20 61 20 6c 6f 6e 67 20 68 69 s been a long hi
47a0: 73 74 6f 72 79 20 6f 66 20 72 65 63 65 69 76 69 story of receivi
47b0: 6e 67 20 73 74 72 61 6e 67 65 20 65 72 72 6f 72 ng strange error
47c0: 73 20 66 72 6f 6d 20 76 61 6c 75 65 73 20 72 65 s from values re
47d0: 74 75 72 6e 65 64 20 62 79 20 74 68 65 20 63 6c turned by the cl
47e0: 69 65 6e 74 20 77 68 65 6e 20 74 68 69 6e 67 73 ient when things
47f0: 20 67 6f 20 77 72 6f 6e 67 2e 2e 0a 09 09 09 09 go wrong.......
4800: 65 78 6e 20 20 20 20 20 20 20 20 20 20 20 20 20 exn
4810: 20 20 3b 3b 20 20 54 68 69 73 20 69 73 20 61 6e ;; This is an
4820: 20 61 74 74 65 6d 70 74 20 74 6f 20 64 65 74 65 attempt to dete
4830: 63 74 20 74 68 61 74 20 73 69 74 75 61 74 69 6f ct that situatio
4840: 6e 20 61 6e 64 20 72 65 63 6f 76 65 72 20 67 72 n and recover gr
4850: 61 63 65 66 75 6c 6c 79 0a 09 09 09 09 28 62 65 acefully.....(be
4860: 67 69 6e 0a 09 09 09 09 20 20 28 64 65 62 75 67 gin..... (debug
4870: 3a 70 72 69 6e 74 30 20 2a 64 65 66 61 75 6c 74 :print0 *default
4880: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 52 52 4f -log-port* "ERRO
4890: 52 3a 20 62 61 64 20 64 61 74 61 20 66 72 6f 6d R: bad data from
48a0: 20 73 65 72 76 65 72 20 22 20 76 20 22 20 6d 65 server " v " me
48b0: 73 73 61 67 65 3a 20 22 20 20 28 28 63 6f 6e 64 ssage: " ((cond
48c0: 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 ition-property-a
48d0: 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 ccessor 'exn 'me
48e0: 73 73 61 67 65 29 20 65 78 6e 29 29 0a 09 09 09 ssage) exn))....
48f0: 09 20 20 28 76 65 63 74 6f 72 20 23 74 20 27 28 . (vector #t '(
4900: 29 29 29 20 3b 3b 20 73 68 6f 75 6c 64 20 61 6c ))) ;; should al
4910: 77 61 79 73 20 67 65 74 20 61 20 76 65 63 74 6f ways get a vecto
4920: 72 20 62 75 74 20 69 66 20 73 6f 6d 65 74 68 69 r but if somethi
4930: 6e 67 20 67 6f 65 73 20 77 72 6f 6e 67 20 72 65 ng goes wrong re
4940: 74 75 72 6e 20 61 20 64 75 6d 6d 79 0a 09 09 09 turn a dummy....
4950: 09 28 69 66 20 28 61 6e 64 20 28 76 65 63 74 6f .(if (and (vecto
4960: 72 3f 20 76 29 0a 09 09 09 09 09 20 28 3e 20 28 r? v)...... (> (
4970: 76 65 63 74 6f 72 2d 6c 65 6e 67 74 68 20 76 29 vector-length v)
4980: 20 31 29 29 0a 09 09 09 09 20 20 20 20 28 6c 65 1))..... (le
4990: 74 20 28 28 6e 65 77 76 65 63 20 28 76 65 63 74 t ((newvec (vect
49a0: 6f 72 20 28 76 65 63 74 6f 72 2d 72 65 66 20 76 or (vector-ref v
49b0: 20 30 29 28 76 65 63 74 6f 72 2d 72 65 66 20 76 0)(vector-ref v
49c0: 20 31 29 29 29 29 0a 09 09 09 09 20 20 20 20 20 1)))).....
49d0: 20 6e 65 77 76 65 63 29 20 20 20 20 20 20 20 20 newvec)
49e0: 20 20 20 3b 3b 20 62 79 20 63 6f 70 79 69 6e 67 ;; by copying
49f0: 20 74 68 65 20 76 65 63 74 6f 72 20 77 68 69 6c the vector whil
4a00: 65 20 69 6e 73 69 64 65 20 74 68 65 20 65 72 72 e inside the err
4a10: 6f 72 20 68 61 6e 64 6c 65 72 20 77 65 20 73 68 or handler we sh
4a20: 6f 75 6c 64 20 66 6f 72 63 65 20 74 68 65 20 64 ould force the d
4a30: 65 74 65 63 74 69 6f 6e 20 6f 66 20 61 20 63 6f etection of a co
4a40: 72 72 75 70 74 65 64 20 72 65 63 6f 72 64 0a 09 rrupted record..
4a50: 09 09 09 20 20 20 20 28 76 65 63 74 6f 72 20 23 ... (vector #
4a60: 74 20 27 28 29 29 29 29 29 20 20 3b 3b 20 77 65 t '())))) ;; we
4a70: 20 63 6f 75 6c 64 20 61 6c 73 6f 20 63 68 65 63 could also chec
4a80: 6b 20 74 68 61 74 20 74 68 65 20 72 65 74 75 72 k that the retur
4a90: 6e 65 64 20 74 79 70 65 73 20 61 72 65 20 76 61 ned types are va
4aa0: 6c 69 64 0a 09 09 09 20 20 20 20 20 28 76 65 63 lid.... (vec
4ab0: 74 6f 72 20 23 74 20 27 28 29 29 29 29 0a 09 20 tor #t '())))..
4ac0: 28 73 75 63 63 65 73 73 20 20 20 20 20 20 20 20 (success
4ad0: 28 76 65 63 74 6f 72 2d 72 65 66 20 72 65 73 64 (vector-ref resd
4ae0: 61 74 20 30 29 29 0a 09 20 28 72 65 73 20 20 20 at 0)).. (res
4af0: 20 20 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 (vector
4b00: 2d 72 65 66 20 72 65 73 64 61 74 20 31 29 29 0a -ref resdat 1)).
4b10: 09 20 28 64 75 72 61 74 69 6f 6e 20 20 20 20 20 . (duration
4b20: 20 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 6d 69 (- (current-mi
4b30: 6c 6c 69 73 65 63 6f 6e 64 73 29 20 73 74 61 72 lliseconds) star
4b40: 74 29 29 29 0a 20 20 20 20 28 69 66 20 28 61 6e t))). (if (an
4b50: 64 20 72 65 61 64 2d 6f 6e 6c 79 20 71 72 79 2d d read-only qry-
4b60: 69 73 2d 77 72 69 74 65 29 0a 20 20 20 20 20 20 is-write).
4b70: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
4b80: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
4b90: 72 74 2a 20 22 45 52 52 4f 52 3a 20 61 74 74 65 rt* "ERROR: atte
4ba0: 6d 70 74 20 74 6f 20 77 72 69 74 65 20 74 6f 20 mpt to write to
4bb0: 72 65 61 64 2d 6f 6e 6c 79 20 64 61 74 61 62 61 read-only databa
4bc0: 73 65 20 69 67 6e 6f 72 65 64 2e 20 63 6d 64 3d se ignored. cmd=
4bd0: 22 20 63 6d 64 29 29 0a 20 20 20 20 28 69 66 20 " cmd)). (if
4be0: 28 6e 6f 74 20 73 75 63 63 65 73 73 29 0a 09 28 (not success)..(
4bf0: 69 66 20 28 3e 20 72 65 6d 72 65 74 72 69 65 73 if (> remretries
4c00: 20 30 29 0a 09 20 20 20 20 28 62 65 67 69 6e 0a 0).. (begin.
4c10: 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
4c20: 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 int-error 0 *def
4c30: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
4c40: 6c 6f 63 61 6c 20 71 75 65 72 79 20 66 61 69 6c local query fail
4c50: 65 64 2e 20 54 72 79 69 6e 67 20 61 67 61 69 6e ed. Trying again
4c60: 2e 22 29 0a 09 20 20 20 20 20 20 28 74 68 72 65 .").. (thre
4c70: 61 64 2d 73 6c 65 65 70 21 20 28 2f 20 28 72 61 ad-sleep! (/ (ra
4c80: 6e 64 6f 6d 20 35 30 30 30 29 20 31 30 30 30 29 ndom 5000) 1000)
4c90: 29 20 3b 3b 20 73 6f 6d 65 20 72 61 6e 64 6f 6d ) ;; some random
4ca0: 20 64 65 6c 61 79 20 0a 09 20 20 20 20 20 20 28 delay .. (
4cb0: 72 6d 74 3a 6f 70 65 6e 2d 71 72 79 2d 63 6c 6f rmt:open-qry-clo
4cc0: 73 65 2d 6c 6f 63 61 6c 6c 79 20 63 6d 64 20 72 se-locally cmd r
4cd0: 75 6e 2d 69 64 20 70 61 72 61 6d 73 20 72 65 6d un-id params rem
4ce0: 72 65 74 72 69 65 73 3a 20 28 2d 20 72 65 6d 72 retries: (- remr
4cf0: 65 74 72 69 65 73 20 31 29 29 29 0a 09 20 20 20 etries 1)))..
4d00: 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 (begin.. (
4d10: 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f debug:print-erro
4d20: 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 r 0 *default-log
4d30: 2d 70 6f 72 74 2a 20 22 74 6f 6f 20 6d 61 6e 79 -port* "too many
4d40: 20 72 65 74 72 69 65 73 20 69 6e 20 72 6d 74 3a retries in rmt:
4d50: 6f 70 65 6e 2d 71 72 79 2d 63 6c 6f 73 65 2d 6c open-qry-close-l
4d60: 6f 63 61 6c 6c 79 2c 20 67 69 76 69 6e 67 20 75 ocally, giving u
4d70: 70 22 29 0a 09 20 20 20 20 20 20 23 66 29 29 0a p").. #f)).
4d80: 09 28 62 65 67 69 6e 0a 09 20 20 3b 3b 20 28 72 .(begin.. ;; (r
4d90: 6d 74 3a 75 70 64 61 74 65 2d 64 62 2d 73 74 61 mt:update-db-sta
4da0: 74 73 20 72 75 6e 2d 69 64 20 63 6d 64 20 70 61 ts run-id cmd pa
4db0: 72 61 6d 73 20 64 75 72 61 74 69 6f 6e 29 0a 09 rams duration)..
4dc0: 20 20 3b 3b 20 6d 61 72 6b 20 74 68 69 73 20 72 ;; mark this r
4dd0: 75 6e 20 61 73 20 64 69 72 74 79 20 69 66 20 74 un as dirty if t
4de0: 68 69 73 20 77 61 73 20 61 20 77 72 69 74 65 2c his was a write,
4df0: 20 74 68 65 20 77 61 74 63 68 64 6f 67 20 69 73 the watchdog is
4e00: 20 72 65 73 70 6f 6e 73 69 62 6c 65 20 66 6f 72 responsible for
4e10: 20 73 79 6e 63 69 6e 67 20 69 74 0a 09 20 20 28 syncing it.. (
4e20: 69 66 20 71 72 79 2d 69 73 2d 77 72 69 74 65 0a if qry-is-write.
4e30: 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 73 74 . (let ((st
4e40: 61 72 74 2d 74 69 6d 65 20 28 63 75 72 72 65 6e art-time (curren
4e50: 74 2d 73 65 63 6f 6e 64 73 29 29 29 0a 09 09 28 t-seconds)))...(
4e60: 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 64 62 2d mutex-lock! *db-
4e70: 6d 75 6c 74 69 2d 73 79 6e 63 2d 6d 75 74 65 78 multi-sync-mutex
4e80: 2a 29 0a 2f 09 09 28 73 65 74 21 20 2a 64 62 2d *)./..(set! *db-
4e90: 6c 61 73 74 2d 61 63 63 65 73 73 2a 20 73 74 61 last-access* sta
4ea0: 72 74 2d 74 69 6d 65 29 20 20 3b 3b 20 54 48 49 rt-time) ;; THI
4eb0: 53 20 49 53 20 50 52 4f 42 41 42 4c 59 20 55 53 S IS PROBABLY US
4ec0: 45 4c 45 53 53 3f 20 28 77 65 20 61 72 65 20 6f ELESS? (we are o
4ed0: 6e 20 61 20 63 6c 69 65 6e 74 29 0a 20 20 20 20 n a client).
4ee0: 20 20 20 20 20 20 20 20 20 20 20 20 28 6d 75 74 (mut
4ef0: 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 64 62 2d 6d ex-unlock! *db-m
4f00: 75 6c 74 69 2d 73 79 6e 63 2d 6d 75 74 65 78 2a ulti-sync-mutex*
4f10: 29 29 29 29 29 0a 20 20 20 20 72 65 73 29 29 0a ))))). res)).
4f20: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 73 65 .(define (rmt:se
4f30: 6e 64 2d 72 65 63 65 69 76 65 2d 6e 6f 2d 61 75 nd-receive-no-au
4f40: 74 6f 2d 63 6c 69 65 6e 74 2d 73 65 74 75 70 20 to-client-setup
4f50: 63 6f 6e 6e 65 63 74 69 6f 6e 2d 69 6e 66 6f 20 connection-info
4f60: 63 6d 64 20 72 75 6e 2d 69 64 20 70 61 72 61 6d cmd run-id param
4f70: 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 72 75 6e s). (let* ((run
4f80: 2d 69 64 20 20 20 28 69 66 20 72 75 6e 2d 69 64 -id (if run-id
4f90: 20 72 75 6e 2d 69 64 20 30 29 29 0a 09 20 28 72 run-id 0)).. (r
4fa0: 65 73 20 20 09 20 20 20 28 68 61 6e 64 6c 65 2d es . (handle-
4fb0: 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 20 20 20 exceptions...
4fc0: 20 65 78 6e 0a 09 09 20 20 20 20 23 66 0a 09 09 exn... #f...
4fd0: 20 20 20 20 28 68 74 74 70 2d 74 72 61 6e 73 70 (http-transp
4fe0: 6f 72 74 3a 63 6c 69 65 6e 74 2d 61 70 69 2d 73 ort:client-api-s
4ff0: 65 6e 64 2d 72 65 63 65 69 76 65 20 72 75 6e 2d end-receive run-
5000: 69 64 20 63 6f 6e 6e 65 63 74 69 6f 6e 2d 69 6e id connection-in
5010: 66 6f 20 63 6d 64 20 70 61 72 61 6d 73 29 29 29 fo cmd params)))
5020: 29 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 72 ). (if (and r
5030: 65 73 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 es (vector-ref r
5040: 65 73 20 30 29 29 0a 09 28 76 65 63 74 6f 72 2d es 0))..(vector-
5050: 72 65 66 20 72 65 73 20 31 29 20 3b 3b 3b 20 59 ref res 1) ;;; Y
5060: 45 53 21 21 20 54 48 49 53 20 49 53 20 43 4f 52 ES!! THIS IS COR
5070: 52 45 43 54 21 21 20 43 48 41 4e 47 45 20 49 54 RECT!! CHANGE IT
5080: 20 48 45 52 45 2c 20 54 48 45 4e 20 43 48 41 4e HERE, THEN CHAN
5090: 47 45 20 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 GE rmt:send-rece
50a0: 69 76 65 20 41 4c 53 4f 21 21 21 0a 09 23 66 29 ive ALSO!!!..#f)
50b0: 29 29 0a 0a 3b 3b 20 3b 3b 20 57 72 61 70 20 6a ))..;; ;; Wrap j
50c0: 73 6f 6e 20 6c 69 62 72 61 72 79 20 66 6f 72 20 son library for
50d0: 73 74 72 69 6e 67 73 20 28 77 68 79 20 74 68 65 strings (why the
50e0: 20 70 6f 72 74 73 20 63 72 61 70 20 69 6e 20 74 ports crap in t
50f0: 68 65 20 66 69 72 73 74 20 70 6c 61 63 65 3f 29 he first place?)
5100: 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 72 6d 74 .;; (define (rmt
5110: 3a 64 61 74 2d 3e 6a 73 6f 6e 2d 73 74 72 20 64 :dat->json-str d
5120: 61 74 29 0a 3b 3b 20 20 20 28 77 69 74 68 2d 6f at).;; (with-o
5130: 75 74 70 75 74 2d 74 6f 2d 73 74 72 69 6e 67 20 utput-to-string
5140: 0a 3b 3b 20 20 20 20 20 28 6c 61 6d 62 64 61 20 .;; (lambda
5150: 28 29 0a 3b 3b 20 20 20 20 20 20 20 28 6a 73 6f ().;; (jso
5160: 6e 2d 77 72 69 74 65 20 64 61 74 29 29 29 29 0a n-write dat)))).
5170: 3b 3b 20 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 ;; .;; (define (
5180: 72 6d 74 3a 6a 73 6f 6e 2d 73 74 72 2d 3e 64 61 rmt:json-str->da
5190: 74 20 6a 73 6f 6e 2d 73 74 72 29 0a 3b 3b 20 20 t json-str).;;
51a0: 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f (with-input-fro
51b0: 6d 2d 73 74 72 69 6e 67 20 6a 73 6f 6e 2d 73 74 m-string json-st
51c0: 72 0a 3b 3b 20 20 20 20 20 28 6c 61 6d 62 64 61 r.;; (lambda
51d0: 20 28 29 0a 3b 3b 20 20 20 20 20 20 20 28 6a 73 ().;; (js
51e0: 6f 6e 2d 72 65 61 64 29 29 29 29 0a 0a 3b 3b 3d on-read))))..;;=
51f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5200: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5210: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5220: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5230: 3d 3d 3d 3d 3d 0a 3b 3b 0a 3b 3b 20 41 20 43 20 =====.;;.;; A C
5240: 54 20 55 20 41 20 4c 20 20 20 41 20 50 20 49 20 T U A L A P I
5250: 20 20 43 20 41 20 4c 20 4c 20 53 20 20 0a 3b 3b C A L L S .;;
5260: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
5270: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5280: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5290: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
52a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 3d 3d 3d =========..;;===
52b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
52c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
52d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
52e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
52f0: 3d 3d 3d 0a 3b 3b 20 20 53 20 45 20 52 20 56 20 ===.;; S E R V
5300: 45 20 52 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d E R.;;==========
5310: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5320: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5330: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5340: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 ============..(d
5350: 65 66 69 6e 65 20 28 72 6d 74 3a 6b 69 6c 6c 2d efine (rmt:kill-
5360: 73 65 72 76 65 72 20 72 75 6e 2d 69 64 29 0a 20 server run-id).
5370: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
5380: 76 65 20 27 6b 69 6c 6c 2d 73 65 72 76 65 72 20 ve 'kill-server
5390: 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e run-id (list run
53a0: 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 -id)))..(define
53b0: 28 72 6d 74 3a 73 74 61 72 74 2d 73 65 72 76 65 (rmt:start-serve
53c0: 72 20 72 75 6e 2d 69 64 29 0a 20 20 28 72 6d 74 r run-id). (rmt
53d0: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 73 :send-receive 's
53e0: 74 61 72 74 2d 73 65 72 76 65 72 20 30 20 28 6c tart-server 0 (l
53f0: 69 73 74 20 72 75 6e 2d 69 64 29 29 29 0a 0a 3b ist run-id)))..;
5400: 3b 3d 3d 3d 3d 3d 3d 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 0a 3b 3b 20 20 4d 20 49 20 =======.;; M I
5450: 53 20 43 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d S C.;;==========
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 3d 3d 3d 3d 3d 0a 0a 28 64 ============..(d
54a0: 65 66 69 6e 65 20 28 72 6d 74 3a 6c 6f 67 69 6e efine (rmt:login
54b0: 20 72 75 6e 2d 69 64 29 0a 20 20 28 72 6d 74 3a run-id). (rmt:
54c0: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 6c 6f send-receive 'lo
54d0: 67 69 6e 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 gin run-id (list
54e0: 20 2a 74 6f 70 70 61 74 68 2a 20 6d 65 67 61 74 *toppath* megat
54f0: 65 73 74 2d 76 65 72 73 69 6f 6e 20 2a 6d 79 2d est-version *my-
5500: 63 6c 69 65 6e 74 2d 73 69 67 6e 61 74 75 72 65 client-signature
5510: 2a 29 29 29 0a 0a 3b 3b 20 54 68 69 73 20 6c 6f *)))..;; This lo
5520: 67 69 6e 20 64 6f 65 73 20 6e 6f 20 72 65 74 72 gin does no retr
5530: 69 65 73 20 75 6e 64 65 72 20 74 68 65 20 68 6f ies under the ho
5540: 6f 64 20 2d 20 69 74 20 61 63 74 73 20 61 20 62 od - it acts a b
5550: 69 74 20 6c 69 6b 65 20 61 20 70 69 6e 67 2e 0a it like a ping..
5560: 3b 3b 20 44 65 70 72 65 63 61 74 65 64 20 66 6f ;; Deprecated fo
5570: 72 20 6e 6d 73 67 2d 74 72 61 6e 73 70 6f 72 74 r nmsg-transport
5580: 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 72 6d ..;;.(define (rm
5590: 74 3a 6c 6f 67 69 6e 2d 6e 6f 2d 61 75 74 6f 2d t:login-no-auto-
55a0: 63 6c 69 65 6e 74 2d 73 65 74 75 70 20 63 6f 6e client-setup con
55b0: 6e 65 63 74 69 6f 6e 2d 69 6e 66 6f 29 0a 20 20 nection-info).
55c0: 28 63 61 73 65 20 2a 74 72 61 6e 73 70 6f 72 74 (case *transport
55d0: 2d 74 79 70 65 2a 20 3b 3b 20 72 75 6e 2d 69 64 -type* ;; run-id
55e0: 20 6f 66 20 30 20 69 73 20 6a 75 73 74 20 61 20 of 0 is just a
55f0: 70 6c 61 63 65 68 6f 6c 64 65 72 0a 20 20 20 20 placeholder.
5600: 28 28 68 74 74 70 29 28 72 6d 74 3a 73 65 6e 64 ((http)(rmt:send
5610: 2d 72 65 63 65 69 76 65 2d 6e 6f 2d 61 75 74 6f -receive-no-auto
5620: 2d 63 6c 69 65 6e 74 2d 73 65 74 75 70 20 63 6f -client-setup co
5630: 6e 6e 65 63 74 69 6f 6e 2d 69 6e 66 6f 20 27 6c nnection-info 'l
5640: 6f 67 69 6e 20 30 20 28 6c 69 73 74 20 2a 74 6f ogin 0 (list *to
5650: 70 70 61 74 68 2a 20 6d 65 67 61 74 65 73 74 2d ppath* megatest-
5660: 76 65 72 73 69 6f 6e 20 2a 6d 79 2d 63 6c 69 65 version *my-clie
5670: 6e 74 2d 73 69 67 6e 61 74 75 72 65 2a 29 29 29 nt-signature*)))
5680: 0a 20 20 20 20 3b 3b 28 28 6e 6d 73 67 29 28 6e . ;;((nmsg)(n
5690: 6d 73 67 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c msg-transport:cl
56a0: 69 65 6e 74 2d 61 70 69 2d 73 65 6e 64 2d 72 65 ient-api-send-re
56b0: 63 65 69 76 65 20 72 75 6e 2d 69 64 20 63 6f 6e ceive run-id con
56c0: 6e 65 63 74 69 6f 6e 2d 69 6e 66 6f 20 27 6c 6f nection-info 'lo
56d0: 67 69 6e 20 28 6c 69 73 74 20 2a 74 6f 70 70 61 gin (list *toppa
56e0: 74 68 2a 20 6d 65 67 61 74 65 73 74 2d 76 65 72 th* megatest-ver
56f0: 73 69 6f 6e 20 72 75 6e 2d 69 64 20 2a 6d 79 2d sion run-id *my-
5700: 63 6c 69 65 6e 74 2d 73 69 67 6e 61 74 75 72 65 client-signature
5710: 2a 29 29 29 0a 20 20 20 20 29 29 0a 0a 3b 3b 20 *))). ))..;;
5720: 68 61 6e 64 20 6f 66 66 20 61 20 63 61 6c 6c 20 hand off a call
5730: 74 6f 20 6f 6e 65 20 6f 66 20 74 68 65 20 64 62 to one of the db
5740: 3a 71 75 65 72 69 65 73 20 73 74 61 74 65 6d 65 :queries stateme
5750: 6e 74 73 0a 3b 3b 20 61 64 64 65 64 20 72 75 6e nts.;; added run
5760: 2d 69 64 20 74 6f 20 6d 61 6b 65 20 6c 6f 6f 6b -id to make look
5770: 69 6e 67 20 75 70 20 74 68 65 20 63 6f 72 72 65 ing up the corre
5780: 63 74 20 64 62 20 70 6f 73 73 69 62 6c 65 20 0a ct db possible .
5790: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a ;;.(define (rmt:
57a0: 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 73 74 6d general-call stm
57b0: 74 6e 61 6d 65 20 72 75 6e 2d 69 64 20 2e 20 70 tname run-id . p
57c0: 61 72 61 6d 73 29 0a 20 20 28 72 6d 74 3a 73 65 arams). (rmt:se
57d0: 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 6e 65 nd-receive 'gene
57e0: 72 61 6c 2d 63 61 6c 6c 20 72 75 6e 2d 69 64 20 ral-call run-id
57f0: 28 61 70 70 65 6e 64 20 28 6c 69 73 74 20 73 74 (append (list st
5800: 6d 74 6e 61 6d 65 20 72 75 6e 2d 69 64 29 20 70 mtname run-id) p
5810: 61 72 61 6d 73 29 29 29 0a 0a 0a 3b 3b 20 67 69 arams)))...;; gi
5820: 76 65 6e 20 61 20 68 6f 73 74 6e 61 6d 65 2c 20 ven a hostname,
5830: 72 65 74 75 72 6e 20 61 20 70 61 69 72 20 6f 66 return a pair of
5840: 20 63 70 75 20 6c 6f 61 64 20 61 6e 64 20 75 70 cpu load and up
5850: 64 61 74 65 20 74 69 6d 65 20 72 65 70 72 65 73 date time repres
5860: 65 6e 74 69 6e 67 20 6c 61 74 65 73 74 20 69 6e enting latest in
5870: 74 65 6c 6c 69 67 65 6e 63 65 20 66 72 6f 6d 20 telligence from
5880: 74 65 73 74 73 20 72 75 6e 6e 69 6e 67 20 6f 6e tests running on
5890: 20 74 68 61 74 20 68 6f 73 74 0a 28 64 65 66 69 that host.(defi
58a0: 6e 65 20 28 72 6d 74 3a 67 65 74 2d 6c 61 74 65 ne (rmt:get-late
58b0: 73 74 2d 68 6f 73 74 2d 6c 6f 61 64 20 68 6f 73 st-host-load hos
58c0: 74 6e 61 6d 65 29 0a 20 20 28 72 6d 74 3a 73 65 tname). (rmt:se
58d0: 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d nd-receive 'get-
58e0: 6c 61 74 65 73 74 2d 68 6f 73 74 2d 6c 6f 61 64 latest-host-load
58f0: 20 30 20 28 6c 69 73 74 20 68 6f 73 74 6e 61 6d 0 (list hostnam
5900: 65 29 29 29 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 e)))..;; (define
5910: 20 28 72 6d 74 3a 73 79 6e 63 2d 69 6e 6d 65 6d (rmt:sync-inmem
5920: 2d 3e 64 62 20 72 75 6e 2d 69 64 29 0a 3b 3b 20 ->db run-id).;;
5930: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
5940: 69 76 65 20 27 73 79 6e 63 2d 69 6e 6d 65 6d 2d ive 'sync-inmem-
5950: 3e 64 62 20 72 75 6e 2d 69 64 20 27 28 29 29 29 >db run-id '()))
5960: 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 73 ..(define (rmt:s
5970: 64 62 2d 71 72 79 20 71 72 79 20 76 61 6c 20 72 db-qry qry val r
5980: 75 6e 2d 69 64 29 0a 20 20 3b 3b 20 61 64 64 20 un-id). ;; add
5990: 63 61 63 68 69 6e 67 20 69 66 20 71 72 79 20 69 caching if qry i
59a0: 73 20 27 67 65 74 69 64 20 6f 72 20 27 67 65 74 s 'getid or 'get
59b0: 73 74 72 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d str. (rmt:send-
59c0: 72 65 63 65 69 76 65 20 27 73 64 62 2d 71 72 79 receive 'sdb-qry
59d0: 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 71 72 run-id (list qr
59e0: 79 20 76 61 6c 29 29 29 0a 0a 3b 3b 20 4e 4f 54 y val)))..;; NOT
59f0: 20 43 4f 4d 50 4c 45 54 45 44 0a 28 64 65 66 69 COMPLETED.(defi
5a00: 6e 65 20 28 72 6d 74 3a 72 75 6e 74 65 73 74 73 ne (rmt:runtests
5a10: 20 75 73 65 72 20 72 75 6e 2d 69 64 20 74 65 73 user run-id tes
5a20: 74 70 61 74 74 20 70 61 72 61 6d 73 29 0a 20 20 tpatt params).
5a30: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
5a40: 65 20 27 72 75 6e 74 65 73 74 73 20 72 75 6e 2d e 'runtests run-
5a50: 69 64 20 74 65 73 74 70 61 74 74 29 29 0a 0a 28 id testpatt))..(
5a60: 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d define (rmt:get-
5a70: 63 68 61 6e 67 65 64 2d 72 65 63 6f 72 64 2d 69 changed-record-i
5a80: 64 73 20 73 69 6e 63 65 2d 74 69 6d 65 29 0a 20 ds since-time).
5a90: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
5aa0: 76 65 20 27 67 65 74 2d 63 68 61 6e 67 65 64 2d ve 'get-changed-
5ab0: 72 65 63 6f 72 64 2d 69 64 73 20 23 66 20 28 6c record-ids #f (l
5ac0: 69 73 74 20 73 69 6e 63 65 2d 74 69 6d 65 29 29 ist since-time))
5ad0: 20 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )..;;==========
5ae0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5af0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5b00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5b10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
5b20: 20 54 20 45 20 53 20 54 20 20 20 4d 20 45 20 54 T E S T M E T
5b30: 20 41 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d A .;;==========
5b40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5b50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5b60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5b70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 ============..(d
5b80: 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 74 efine (rmt:get-t
5b90: 65 73 74 73 2d 74 61 67 73 29 0a 20 20 28 72 6d ests-tags). (rm
5ba0: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
5bb0: 67 65 74 2d 74 65 73 74 73 2d 74 61 67 73 20 23 get-tests-tags #
5bc0: 66 20 27 28 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d f '()))..;;=====
5bd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5be0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5bf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5c00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5c10: 3d 0a 3b 3b 20 20 4b 20 45 20 59 20 53 20 0a 3b =.;; K E Y S .;
5c20: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
5c30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5c40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5c50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5c60: 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 54 68 65 73 =======..;; Thes
5c70: 65 20 72 65 71 75 69 72 65 20 72 75 6e 2d 69 64 e require run-id
5c80: 20 62 65 63 61 75 73 65 20 74 68 65 20 76 61 6c because the val
5c90: 75 65 73 20 63 6f 6d 65 20 66 72 6f 6d 20 74 68 ues come from th
5ca0: 65 20 72 75 6e 21 0a 3b 3b 0a 28 64 65 66 69 6e e run!.;;.(defin
5cb0: 65 20 28 72 6d 74 3a 67 65 74 2d 6b 65 79 2d 76 e (rmt:get-key-v
5cc0: 61 6c 2d 70 61 69 72 73 20 72 75 6e 2d 69 64 29 al-pairs run-id)
5cd0: 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 . (rmt:send-rec
5ce0: 65 69 76 65 20 27 67 65 74 2d 6b 65 79 2d 76 61 eive 'get-key-va
5cf0: 6c 2d 70 61 69 72 73 20 72 75 6e 2d 69 64 20 28 l-pairs run-id (
5d00: 6c 69 73 74 20 72 75 6e 2d 69 64 29 29 29 0a 0a list run-id)))..
5d10: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 (define (rmt:get
5d20: 2d 6b 65 79 73 29 0a 20 20 28 69 66 20 2a 64 62 -keys). (if *db
5d30: 2d 6b 65 79 73 2a 20 2a 64 62 2d 6b 65 79 73 2a -keys* *db-keys*
5d40: 20 0a 20 20 20 20 20 28 6c 65 74 20 28 28 72 65 . (let ((re
5d50: 73 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 s (rmt:send-rece
5d60: 69 76 65 20 27 67 65 74 2d 6b 65 79 73 20 23 66 ive 'get-keys #f
5d70: 20 27 28 29 29 29 29 0a 20 20 20 20 20 20 20 28 '()))). (
5d80: 73 65 74 21 20 2a 64 62 2d 6b 65 79 73 2a 20 72 set! *db-keys* r
5d90: 65 73 29 0a 20 20 20 20 20 20 20 72 65 73 29 29 es). res))
5da0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a )..(define (rmt:
5db0: 67 65 74 2d 6b 65 79 73 2d 77 72 69 74 65 29 20 get-keys-write)
5dc0: 3b 3b 20 64 75 6d 6d 79 20 71 75 65 72 79 20 74 ;; dummy query t
5dd0: 6f 20 66 6f 72 63 65 20 73 65 72 76 65 72 20 73 o force server s
5de0: 74 61 72 74 0a 20 20 28 6c 65 74 20 28 28 72 65 tart. (let ((re
5df0: 73 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 s (rmt:send-rece
5e00: 69 76 65 20 27 67 65 74 2d 6b 65 79 73 2d 77 72 ive 'get-keys-wr
5e10: 69 74 65 20 23 66 20 27 28 29 29 29 29 0a 20 20 ite #f '()))).
5e20: 20 20 28 73 65 74 21 20 2a 64 62 2d 6b 65 79 73 (set! *db-keys
5e30: 2a 20 72 65 73 29 0a 20 20 20 20 72 65 73 29 29 * res). res))
5e40: 0a 0a 3b 3b 20 77 65 20 64 6f 6e 27 74 20 72 65 ..;; we don't re
5e50: 75 73 65 20 72 75 6e 2d 69 64 27 73 20 28 65 78 use run-id's (ex
5e60: 63 65 70 74 20 70 6f 73 73 69 62 6c 79 20 2a 61 cept possibly *a
5e70: 66 74 65 72 2a 20 61 20 64 62 20 63 6c 65 61 6e fter* a db clean
5e80: 75 70 29 20 73 6f 20 69 74 20 69 73 20 73 61 66 up) so it is saf
5e90: 65 0a 3b 3b 20 74 6f 20 63 61 63 68 65 20 74 68 e.;; to cache th
5ea0: 65 20 72 65 73 75 6c 73 20 69 6e 20 61 20 68 61 e resuls in a ha
5eb0: 73 68 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 72 sh.;;.(define (r
5ec0: 6d 74 3a 67 65 74 2d 6b 65 79 2d 76 61 6c 73 20 mt:get-key-vals
5ed0: 72 75 6e 2d 69 64 29 0a 20 20 28 6f 72 20 28 68 run-id). (or (h
5ee0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
5ef0: 66 61 75 6c 74 20 2a 6b 65 79 76 61 6c 73 2a 20 fault *keyvals*
5f00: 72 75 6e 2d 69 64 20 23 66 29 0a 20 20 20 20 20 run-id #f).
5f10: 20 28 6c 65 74 20 28 28 72 65 73 20 28 72 6d 74 (let ((res (rmt
5f20: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 :send-receive 'g
5f30: 65 74 2d 6b 65 79 2d 76 61 6c 73 20 23 66 20 28 et-key-vals #f (
5f40: 6c 69 73 74 20 72 75 6e 2d 69 64 29 29 29 29 0a list run-id)))).
5f50: 20 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 (hash-ta
5f60: 62 6c 65 2d 73 65 74 21 20 2a 6b 65 79 76 61 6c ble-set! *keyval
5f70: 73 2a 20 72 75 6e 2d 69 64 20 72 65 73 29 0a 20 s* run-id res).
5f80: 20 20 20 20 20 20 20 72 65 73 29 29 29 0a 0a 28 res)))..(
5f90: 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d define (rmt:get-
5fa0: 74 61 72 67 65 74 73 29 0a 20 20 28 72 6d 74 3a targets). (rmt:
5fb0: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 send-receive 'ge
5fc0: 74 2d 74 61 72 67 65 74 73 20 23 66 20 27 28 29 t-targets #f '()
5fd0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
5fe0: 3a 67 65 74 2d 74 61 72 67 65 74 20 72 75 6e 2d :get-target run-
5ff0: 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d id). (rmt:send-
6000: 72 65 63 65 69 76 65 20 27 67 65 74 2d 74 61 72 receive 'get-tar
6010: 67 65 74 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 get run-id (list
6020: 20 72 75 6e 2d 69 64 29 29 29 0a 0a 3b 3b 3d 3d run-id)))..;;==
6030: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6040: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6050: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6060: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6070: 3d 3d 3d 3d 0a 3b 3b 20 20 54 20 45 20 53 20 54 ====.;; T E S T
6080: 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d S.;;===========
6090: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
60a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
60b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
60c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 ===========..;;
60d0: 4a 75 73 74 20 73 6f 6d 65 20 73 79 6e 74 61 74 Just some syntat
60e0: 69 63 20 73 75 67 61 72 0a 28 64 65 66 69 6e 65 ic sugar.(define
60f0: 20 28 72 6d 74 3a 72 65 67 69 73 74 65 72 2d 74 (rmt:register-t
6100: 65 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d est run-id test-
6110: 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 0a name item-path).
6120: 20 20 28 72 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 (rmt:general-c
6130: 61 6c 6c 20 27 72 65 67 69 73 74 65 72 2d 74 65 all 'register-te
6140: 73 74 20 72 75 6e 2d 69 64 20 72 75 6e 2d 69 64 st run-id run-id
6150: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item-
6160: 70 61 74 68 29 29 0a 0a 28 64 65 66 69 6e 65 20 path))..(define
6170: 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 64 (rmt:get-test-id
6180: 20 72 75 6e 2d 69 64 20 74 65 73 74 6e 61 6d 65 run-id testname
6190: 20 69 74 65 6d 2d 70 61 74 68 29 0a 20 20 28 72 item-path). (r
61a0: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
61b0: 27 67 65 74 2d 74 65 73 74 2d 69 64 20 72 75 6e 'get-test-id run
61c0: 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 -id (list run-id
61d0: 20 74 65 73 74 6e 61 6d 65 20 69 74 65 6d 2d 70 testname item-p
61e0: 61 74 68 29 29 29 0a 0a 3b 3b 20 72 75 6e 2d 69 ath)))..;; run-i
61f0: 64 20 69 73 20 4e 4f 54 20 75 73 65 64 0a 3b 3b d is NOT used.;;
6200: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 .(define (rmt:ge
6210: 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 t-test-info-by-i
6220: 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 d run-id test-id
6230: 29 0a 20 20 28 69 66 20 28 6e 75 6d 62 65 72 3f ). (if (number?
6240: 20 74 65 73 74 2d 69 64 29 0a 20 20 20 20 20 20 test-id).
6250: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
6260: 65 20 27 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f e 'get-test-info
6270: 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 28 6c -by-id run-id (l
6280: 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d ist run-id test-
6290: 69 64 29 29 0a 20 20 20 20 20 20 28 62 65 67 69 id)). (begi
62a0: 6e 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 n..(debug:print
62b0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
62c0: 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 42 ort* "WARNING: B
62d0: 61 64 20 64 61 74 61 20 68 61 6e 64 65 64 20 74 ad data handed t
62e0: 6f 20 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 o rmt:get-test-i
62f0: 6e 66 6f 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 nfo-by-id run-id
6300: 3d 22 20 72 75 6e 2d 69 64 20 22 2c 20 74 65 73 =" run-id ", tes
6310: 74 2d 69 64 3d 22 20 74 65 73 74 2d 69 64 29 0a t-id=" test-id).
6320: 09 28 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 .(print-call-cha
6330: 69 6e 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f in (current-erro
6340: 72 2d 70 6f 72 74 29 29 0a 09 23 66 29 29 29 0a r-port))..#f))).
6350: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 65 .(define (rmt:te
6360: 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 2d 66 72 st-get-rundir-fr
6370: 6f 6d 2d 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 om-test-id run-i
6380: 64 20 74 65 73 74 2d 69 64 29 0a 20 20 28 72 6d d test-id). (rm
6390: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
63a0: 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 2d test-get-rundir-
63b0: 66 72 6f 6d 2d 74 65 73 74 2d 69 64 20 72 75 6e from-test-id run
63c0: 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 -id (list run-id
63d0: 20 74 65 73 74 2d 69 64 29 29 29 0a 0a 28 64 65 test-id)))..(de
63e0: 66 69 6e 65 20 28 72 6d 74 3a 6f 70 65 6e 2d 74 fine (rmt:open-t
63f0: 65 73 74 2d 64 62 2d 62 79 2d 74 65 73 74 2d 69 est-db-by-test-i
6400: 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 d run-id test-id
6410: 20 23 21 6b 65 79 20 28 77 6f 72 6b 2d 61 72 65 #!key (work-are
6420: 61 20 23 66 29 29 0a 20 20 28 6c 65 74 2a 20 28 a #f)). (let* (
6430: 28 74 65 73 74 2d 70 61 74 68 20 28 69 66 20 28 (test-path (if (
6440: 73 74 72 69 6e 67 3f 20 77 6f 72 6b 2d 61 72 65 string? work-are
6450: 61 29 0a 09 09 09 77 6f 72 6b 2d 61 72 65 61 0a a)....work-area.
6460: 09 09 09 28 72 6d 74 3a 74 65 73 74 2d 67 65 74 ...(rmt:test-get
6470: 2d 72 75 6e 64 69 72 2d 66 72 6f 6d 2d 74 65 73 -rundir-from-tes
6480: 74 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 t-id run-id test
6490: 2d 69 64 29 29 29 29 0a 20 20 20 20 28 64 65 62 -id)))). (deb
64a0: 75 67 3a 70 72 69 6e 74 20 33 20 2a 64 65 66 61 ug:print 3 *defa
64b0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 54 ult-log-port* "T
64c0: 45 53 54 20 50 41 54 48 3a 20 22 20 74 65 73 74 EST PATH: " test
64d0: 2d 70 61 74 68 29 0a 20 20 20 20 28 6f 70 65 6e -path). (open
64e0: 2d 74 65 73 74 2d 64 62 20 74 65 73 74 2d 70 61 -test-db test-pa
64f0: 74 68 29 29 29 0a 0a 3b 3b 20 57 41 52 4e 49 4e th)))..;; WARNIN
6500: 47 3a 20 54 68 69 73 20 63 75 72 72 65 6e 74 6c G: This currentl
6510: 79 20 62 79 70 61 73 73 65 73 20 74 68 65 20 74 y bypasses the t
6520: 72 61 6e 73 61 63 74 69 6f 6e 20 77 72 61 70 70 ransaction wrapp
6530: 65 64 20 77 72 69 74 65 73 20 73 79 73 74 65 6d ed writes system
6540: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 65 .(define (rmt:te
6550: 73 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 st-set-state-sta
6560: 74 75 73 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 tus-by-id run-id
6570: 20 74 65 73 74 2d 69 64 20 6e 65 77 73 74 61 74 test-id newstat
6580: 65 20 6e 65 77 73 74 61 74 75 73 20 6e 65 77 63 e newstatus newc
6590: 6f 6d 6d 65 6e 74 29 0a 20 20 28 72 6d 74 3a 73 omment). (rmt:s
65a0: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 74 65 73 end-receive 'tes
65b0: 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 t-set-state-stat
65c0: 75 73 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 us-by-id run-id
65d0: 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 (list run-id tes
65e0: 74 2d 69 64 20 6e 65 77 73 74 61 74 65 20 6e 65 t-id newstate ne
65f0: 77 73 74 61 74 75 73 20 6e 65 77 63 6f 6d 6d 65 wstatus newcomme
6600: 6e 74 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 nt)))..(define (
6610: 72 6d 74 3a 73 65 74 2d 74 65 73 74 73 2d 73 74 rmt:set-tests-st
6620: 61 74 65 2d 73 74 61 74 75 73 20 72 75 6e 2d 69 ate-status run-i
6630: 64 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 d
6640: 20 20 20 20 20 20 20 74 65 73 74 6e 61 6d 65 73 testnames
6650: 20 63 75 72 72 73 74 61 74 65 20 63 75 72 72 73 currstate currs
6660: 74 61 74 75 73 20 6e 65 77 73 74 61 74 65 20 6e tatus newstate n
6670: 65 77 73 74 61 74 75 73 29 0a 20 20 28 72 6d 74 ewstatus). (rmt
6680: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 73 :send-receive 's
6690: 65 74 2d 74 65 73 74 73 2d 73 74 61 74 65 2d 73 et-tests-state-s
66a0: 74 61 74 75 73 20 72 75 6e 2d 69 64 20 28 6c 69 tatus run-id (li
66b0: 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 6e 61 st run-id testna
66c0: 6d 65 73 20 63 75 72 72 73 74 61 74 65 20 63 75 mes currstate cu
66d0: 72 72 73 74 61 74 75 73 20 6e 65 77 73 74 61 74 rrstatus newstat
66e0: 65 20 6e 65 77 73 74 61 74 75 73 29 29 29 0a 0a e newstatus)))..
66f0: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 (define (rmt:get
6700: 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 72 -tests-for-run r
6710: 75 6e 2d 69 64 20 74 65 73 74 70 61 74 74 20 73 un-id testpatt s
6720: 74 61 74 65 73 20 73 74 61 74 75 73 65 73 20 6f tates statuses o
6730: 66 66 73 65 74 20 6c 69 6d 69 74 20 6e 6f 74 2d ffset limit not-
6740: 69 6e 20 73 6f 72 74 2d 62 79 20 73 6f 72 74 2d in sort-by sort-
6750: 6f 72 64 65 72 20 71 72 79 76 61 6c 73 20 6c 61 order qryvals la
6760: 73 74 2d 75 70 64 61 74 65 20 6d 6f 64 65 29 0a st-update mode).
6770: 20 20 28 69 66 20 28 6e 75 6d 62 65 72 3f 20 72 (if (number? r
6780: 75 6e 2d 69 64 29 0a 20 20 20 20 20 20 28 72 6d un-id). (rm
6790: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
67a0: 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 get-tests-for-ru
67b0: 6e 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 n run-id (list r
67c0: 75 6e 2d 69 64 20 74 65 73 74 70 61 74 74 20 73 un-id testpatt s
67d0: 74 61 74 65 73 20 73 74 61 74 75 73 65 73 20 6f tates statuses o
67e0: 66 66 73 65 74 20 6c 69 6d 69 74 20 6e 6f 74 2d ffset limit not-
67f0: 69 6e 20 73 6f 72 74 2d 62 79 20 73 6f 72 74 2d in sort-by sort-
6800: 6f 72 64 65 72 20 71 72 79 76 61 6c 73 20 6c 61 order qryvals la
6810: 73 74 2d 75 70 64 61 74 65 20 6d 6f 64 65 29 29 st-update mode))
6820: 0a 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 28 . (begin..(
6830: 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f debug:print-erro
6840: 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 r 0 *default-log
6850: 2d 70 6f 72 74 2a 20 22 72 6d 74 3a 67 65 74 2d -port* "rmt:get-
6860: 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 63 61 tests-for-run ca
6870: 6c 6c 65 64 20 77 69 74 68 20 62 61 64 20 72 75 lled with bad ru
6880: 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 64 29 0a 09 n-id=" run-id)..
6890: 28 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 (print-call-chai
68a0: 6e 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 n (current-error
68b0: 2d 70 6f 72 74 29 29 0a 09 27 28 29 29 29 29 0a -port))..'()))).
68c0: 0a 3b 3b 20 67 65 74 20 73 74 75 66 66 20 76 69 .;; get stuff vi
68d0: 61 20 73 79 6e 63 68 61 73 68 20 0a 28 64 65 66 a synchash .(def
68e0: 69 6e 65 20 28 72 6d 74 3a 73 79 6e 63 68 61 73 ine (rmt:synchas
68f0: 68 2d 67 65 74 20 72 75 6e 2d 69 64 20 70 72 6f h-get run-id pro
6900: 63 20 73 79 6e 63 6b 65 79 20 6b 65 79 6e 75 6d c synckey keynum
6910: 20 70 61 72 61 6d 73 29 0a 20 20 28 72 6d 74 3a params). (rmt:
6920: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 73 79 send-receive 'sy
6930: 6e 63 68 61 73 68 2d 67 65 74 20 72 75 6e 2d 69 nchash-get run-i
6940: 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 70 d (list run-id p
6950: 72 6f 63 20 73 79 6e 63 6b 65 79 20 6b 65 79 6e roc synckey keyn
6960: 75 6d 20 70 61 72 61 6d 73 29 29 29 0a 0a 3b 3b um params)))..;;
6970: 20 49 44 45 41 3a 20 54 68 72 65 61 64 69 66 79 IDEA: Threadify
6980: 20 74 68 65 73 65 20 2d 20 74 68 65 79 20 73 70 these - they sp
6990: 65 6e 64 20 61 20 6c 6f 74 20 6f 66 20 74 69 6d end a lot of tim
69a0: 65 20 77 61 69 74 69 6e 67 20 2e 2e 2e 0a 3b 3b e waiting ....;;
69b0: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 .(define (rmt:ge
69c0: 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 73 t-tests-for-runs
69d0: 2d 6d 69 6e 64 61 74 61 20 72 75 6e 2d 69 64 73 -mindata run-ids
69e0: 20 74 65 73 74 70 61 74 74 20 73 74 61 74 65 73 testpatt states
69f0: 20 73 74 61 74 75 73 20 6e 6f 74 2d 69 6e 29 0a status not-in).
6a00: 20 20 28 6c 65 74 20 28 28 6d 75 6c 74 69 2d 72 (let ((multi-r
6a10: 75 6e 2d 6d 75 74 65 78 20 28 6d 61 6b 65 2d 6d un-mutex (make-m
6a20: 75 74 65 78 29 29 0a 09 28 72 75 6e 2d 69 64 2d utex))..(run-id-
6a30: 6c 69 73 74 20 28 69 66 20 72 75 6e 2d 69 64 73 list (if run-ids
6a40: 0a 09 09 09 20 72 75 6e 2d 69 64 73 0a 09 09 09 .... run-ids....
6a50: 20 28 72 6d 74 3a 67 65 74 2d 61 6c 6c 2d 72 75 (rmt:get-all-ru
6a60: 6e 2d 69 64 73 29 29 29 0a 09 28 72 65 73 75 6c n-ids)))..(resul
6a70: 74 20 20 20 20 20 20 27 28 29 29 29 0a 20 20 20 t '())).
6a80: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 72 75 6e 2d (if (null? run-
6a90: 69 64 2d 6c 69 73 74 29 0a 09 27 28 29 0a 09 28 id-list)..'()..(
6aa0: 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 20 let loop ((hed
6ab0: 20 20 20 28 63 61 72 20 72 75 6e 2d 69 64 2d 6c (car run-id-l
6ac0: 69 73 74 29 29 0a 09 09 20 20 20 28 74 61 6c 20 ist))... (tal
6ad0: 20 20 20 20 28 63 64 72 20 72 75 6e 2d 69 64 2d (cdr run-id-
6ae0: 6c 69 73 74 29 29 0a 09 09 20 20 20 28 74 68 72 list))... (thr
6af0: 65 61 64 73 20 27 28 29 29 29 0a 09 20 20 28 69 eads '())).. (i
6b00: 66 20 28 3e 20 28 6c 65 6e 67 74 68 20 74 68 72 f (> (length thr
6b10: 65 61 64 73 29 20 35 29 0a 09 20 20 20 20 20 20 eads) 5)..
6b20: 28 6c 6f 6f 70 20 68 65 64 20 74 61 6c 20 28 66 (loop hed tal (f
6b30: 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 74 ilter (lambda (t
6b40: 68 29 28 6e 6f 74 20 28 6d 65 6d 62 65 72 20 28 h)(not (member (
6b50: 74 68 72 65 61 64 2d 73 74 61 74 65 20 74 68 29 thread-state th)
6b60: 20 27 28 74 65 72 6d 69 6e 61 74 65 64 20 64 65 '(terminated de
6b70: 61 64 29 29 29 29 20 74 68 72 65 61 64 73 29 29 ad)))) threads))
6b80: 0a 09 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 .. (let* ((
6b90: 6e 65 77 74 68 72 65 61 64 20 28 6d 61 6b 65 2d newthread (make-
6ba0: 74 68 72 65 61 64 0a 09 09 09 09 20 28 6c 61 6d thread..... (lam
6bb0: 62 64 61 20 28 29 0a 09 09 09 09 20 20 20 28 6c bda ()..... (l
6bc0: 65 74 20 28 28 72 65 73 20 28 72 6d 74 3a 73 65 et ((res (rmt:se
6bd0: 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d nd-receive 'get-
6be0: 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 2d 6d 69 tests-for-run-mi
6bf0: 6e 64 61 74 61 20 68 65 64 20 28 6c 69 73 74 20 ndata hed (list
6c00: 68 65 64 20 74 65 73 74 70 61 74 74 20 73 74 61 hed testpatt sta
6c10: 74 65 73 20 73 74 61 74 75 73 20 6e 6f 74 2d 69 tes status not-i
6c20: 6e 29 29 29 29 0a 09 09 09 09 20 20 20 20 20 28 n))))..... (
6c30: 69 66 20 28 6c 69 73 74 3f 20 72 65 73 29 0a 09 if (list? res)..
6c40: 09 09 09 09 20 28 62 65 67 69 6e 0a 09 09 09 09 .... (begin.....
6c50: 09 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 . (mutex-lock!
6c60: 20 6d 75 6c 74 69 2d 72 75 6e 2d 6d 75 74 65 78 multi-run-mutex
6c70: 29 0a 09 09 09 09 09 20 20 20 28 73 65 74 21 20 )...... (set!
6c80: 72 65 73 75 6c 74 20 28 61 70 70 65 6e 64 20 72 result (append r
6c90: 65 73 75 6c 74 20 72 65 73 29 29 0a 09 09 09 09 esult res)).....
6ca0: 09 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 . (mutex-unloc
6cb0: 6b 21 20 6d 75 6c 74 69 2d 72 75 6e 2d 6d 75 74 k! multi-run-mut
6cc0: 65 78 29 29 0a 09 09 09 09 09 20 28 64 65 62 75 ex))...... (debu
6cd0: 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 g:print-error 0
6ce0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
6cf0: 74 2a 20 22 67 65 74 2d 74 65 73 74 73 2d 66 6f t* "get-tests-fo
6d00: 72 2d 72 75 6e 2d 6d 69 6e 64 61 74 61 20 66 61 r-run-mindata fa
6d10: 69 6c 65 64 20 66 6f 72 20 72 75 6e 2d 69 64 20 iled for run-id
6d20: 22 20 68 65 64 20 22 2c 20 74 65 73 74 70 61 74 " hed ", testpat
6d30: 74 20 22 20 74 65 73 74 70 61 74 74 20 22 2c 20 t " testpatt ",
6d40: 73 74 61 74 65 73 20 22 20 73 74 61 74 65 73 20 states " states
6d50: 22 2c 20 73 74 61 74 75 73 20 22 20 73 74 61 74 ", status " stat
6d60: 75 73 20 22 2c 20 6e 6f 74 2d 69 6e 20 22 20 6e us ", not-in " n
6d70: 6f 74 2d 69 6e 29 29 29 29 0a 09 09 09 09 20 28 ot-in))))..... (
6d80: 63 6f 6e 63 20 22 6d 75 6c 74 69 2d 72 75 6e 2d conc "multi-run-
6d90: 74 68 72 65 61 64 20 66 6f 72 20 72 75 6e 2d 69 thread for run-i
6da0: 64 20 22 20 68 65 64 29 29 29 0a 09 09 20 20 20 d " hed)))...
6db0: 20 20 28 6e 65 77 74 68 72 65 61 64 73 20 28 63 (newthreads (c
6dc0: 6f 6e 73 20 6e 65 77 74 68 72 65 61 64 20 74 68 ons newthread th
6dd0: 72 65 61 64 73 29 29 29 0a 09 09 28 74 68 72 65 reads)))...(thre
6de0: 61 64 2d 73 74 61 72 74 21 20 6e 65 77 74 68 72 ad-start! newthr
6df0: 65 61 64 29 0a 09 09 28 74 68 72 65 61 64 2d 73 ead)...(thread-s
6e00: 6c 65 65 70 21 20 30 2e 30 35 29 20 3b 3b 20 67 leep! 0.05) ;; g
6e10: 69 76 65 20 74 68 61 74 20 74 68 72 65 61 64 20 ive that thread
6e20: 73 6f 6d 65 20 74 69 6d 65 20 74 6f 20 73 74 61 some time to sta
6e30: 72 74 0a 09 09 28 69 66 20 28 6e 75 6c 6c 3f 20 rt...(if (null?
6e40: 74 61 6c 29 0a 09 09 20 20 20 20 6e 65 77 74 68 tal)... newth
6e50: 72 65 61 64 73 0a 09 09 20 20 20 20 28 6c 6f 6f reads... (loo
6e60: 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 p (car tal)(cdr
6e70: 74 61 6c 29 20 6e 65 77 74 68 72 65 61 64 73 29 tal) newthreads)
6e80: 29 29 29 29 29 0a 20 20 20 20 72 65 73 75 6c 74 ))))). result
6e90: 29 29 0a 0a 3b 3b 20 3b 3b 20 49 44 45 41 3a 20 ))..;; ;; IDEA:
6ea0: 54 68 72 65 61 64 69 66 79 20 74 68 65 73 65 20 Threadify these
6eb0: 2d 20 74 68 65 79 20 73 70 65 6e 64 20 61 20 6c - they spend a l
6ec0: 6f 74 20 6f 66 20 74 69 6d 65 20 77 61 69 74 69 ot of time waiti
6ed0: 6e 67 20 2e 2e 2e 0a 3b 3b 20 3b 3b 0a 3b 3b 20 ng ....;; ;;.;;
6ee0: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 (define (rmt:get
6ef0: 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 73 2d -tests-for-runs-
6f00: 6d 69 6e 64 61 74 61 20 72 75 6e 2d 69 64 73 20 mindata run-ids
6f10: 74 65 73 74 70 61 74 74 20 73 74 61 74 65 73 20 testpatt states
6f20: 73 74 61 74 75 73 20 6e 6f 74 2d 69 6e 29 0a 3b status not-in).;
6f30: 3b 20 20 20 28 6c 65 74 20 28 28 72 75 6e 2d 69 ; (let ((run-i
6f40: 64 2d 6c 69 73 74 20 28 69 66 20 72 75 6e 2d 69 d-list (if run-i
6f50: 64 73 0a 3b 3b 20 09 09 09 20 72 75 6e 2d 69 64 ds.;; ... run-id
6f60: 73 0a 3b 3b 20 09 09 09 20 28 72 6d 74 3a 67 65 s.;; ... (rmt:ge
6f70: 74 2d 61 6c 6c 2d 72 75 6e 2d 69 64 73 29 29 29 t-all-run-ids)))
6f80: 29 0a 3b 3b 20 20 20 20 20 28 61 70 70 6c 79 20 ).;; (apply
6f90: 61 70 70 65 6e 64 20 28 6d 61 70 20 28 6c 61 6d append (map (lam
6fa0: 62 64 61 20 28 72 75 6e 2d 69 64 29 0a 3b 3b 20 bda (run-id).;;
6fb0: 09 09 09 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ... (rmt:send-re
6fc0: 63 65 69 76 65 20 27 67 65 74 2d 74 65 73 74 73 ceive 'get-tests
6fd0: 2d 66 6f 72 2d 72 75 6e 2d 6d 69 6e 64 61 74 61 -for-run-mindata
6fe0: 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 run-id (list ru
6ff0: 6e 2d 69 64 73 20 74 65 73 74 70 61 74 74 20 73 n-ids testpatt s
7000: 74 61 74 65 73 20 73 74 61 74 75 73 20 6e 6f 74 tates status not
7010: 2d 69 6e 29 29 29 0a 3b 3b 20 09 09 20 20 20 20 -in))).;; ..
7020: 20 20 20 72 75 6e 2d 69 64 2d 6c 69 73 74 29 29 run-id-list))
7030: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
7040: 3a 64 65 6c 65 74 65 2d 74 65 73 74 2d 72 65 63 :delete-test-rec
7050: 6f 72 64 73 20 72 75 6e 2d 69 64 20 74 65 73 74 ords run-id test
7060: 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 -id). (rmt:send
7070: 2d 72 65 63 65 69 76 65 20 27 64 65 6c 65 74 65 -receive 'delete
7080: 2d 74 65 73 74 2d 72 65 63 6f 72 64 73 20 72 75 -test-records ru
7090: 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 n-id (list run-i
70a0: 64 20 74 65 73 74 2d 69 64 29 29 29 0a 0a 3b 3b d test-id)))..;;
70b0: 20 54 68 69 73 20 69 73 20 6e 6f 74 20 6e 65 65 This is not nee
70c0: 64 65 64 20 61 73 20 74 65 73 74 20 73 74 65 70 ded as test step
70d0: 73 20 61 72 65 20 64 65 6c 65 74 65 64 20 6f 6e s are deleted on
70e0: 20 74 65 73 74 20 64 65 6c 65 74 65 20 63 61 6c test delete cal
70f0: 6c 0a 3b 3b 0a 3b 3b 20 28 64 65 66 69 6e 65 20 l.;;.;; (define
7100: 28 72 6d 74 3a 64 65 6c 65 74 65 2d 74 65 73 74 (rmt:delete-test
7110: 2d 73 74 65 70 2d 72 65 63 6f 72 64 73 20 72 75 -step-records ru
7120: 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 0a 3b 3b n-id test-id).;;
7130: 20 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 (rmt:send-rec
7140: 65 69 76 65 20 27 64 65 6c 65 74 65 2d 74 65 73 eive 'delete-tes
7150: 74 2d 73 74 65 70 2d 72 65 63 6f 72 64 73 20 72 t-step-records r
7160: 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d un-id (list run-
7170: 69 64 20 74 65 73 74 2d 69 64 29 29 29 0a 0a 28 id test-id)))..(
7180: 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 65 73 74 define (rmt:test
7190: 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 -set-state-statu
71a0: 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 s run-id test-id
71b0: 20 73 74 61 74 65 20 73 74 61 74 75 73 20 6d 73 state status ms
71c0: 67 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 g). (rmt:send-r
71d0: 65 63 65 69 76 65 20 27 74 65 73 74 2d 73 65 74 eceive 'test-set
71e0: 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 72 75 -state-status ru
71f0: 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 n-id (list run-i
7200: 64 20 74 65 73 74 2d 69 64 20 73 74 61 74 65 20 d test-id state
7210: 73 74 61 74 75 73 20 6d 73 67 29 29 29 0a 0a 28 status msg)))..(
7220: 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 65 73 74 define (rmt:test
7230: 2d 74 6f 70 6c 65 76 65 6c 2d 6e 75 6d 2d 69 74 -toplevel-num-it
7240: 65 6d 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d ems run-id test-
7250: 6e 61 6d 65 29 0a 20 20 28 72 6d 74 3a 73 65 6e name). (rmt:sen
7260: 64 2d 72 65 63 65 69 76 65 20 27 74 65 73 74 2d d-receive 'test-
7270: 74 6f 70 6c 65 76 65 6c 2d 6e 75 6d 2d 69 74 65 toplevel-num-ite
7280: 6d 73 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 ms run-id (list
7290: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
72a0: 29 29 29 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 20 )))..;; (define
72b0: 28 72 6d 74 3a 67 65 74 2d 70 72 65 76 69 6f 75 (rmt:get-previou
72c0: 73 2d 74 65 73 74 2d 72 75 6e 2d 72 65 63 6f 72 s-test-run-recor
72d0: 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 d run-id test-na
72e0: 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 0a 3b 3b me item-path).;;
72f0: 20 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 (rmt:send-rec
7300: 65 69 76 65 20 27 67 65 74 2d 70 72 65 76 69 6f eive 'get-previo
7310: 75 73 2d 74 65 73 74 2d 72 75 6e 2d 72 65 63 6f us-test-run-reco
7320: 72 64 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 rd run-id (list
7330: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
7340: 20 69 74 65 6d 2d 70 61 74 68 29 29 29 0a 0a 28 item-path)))..(
7350: 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d define (rmt:get-
7360: 6d 61 74 63 68 69 6e 67 2d 70 72 65 76 69 6f 75 matching-previou
7370: 73 2d 74 65 73 74 2d 72 75 6e 2d 72 65 63 6f 72 s-test-run-recor
7380: 64 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e ds run-id test-n
7390: 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 0a 20 ame item-path).
73a0: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
73b0: 76 65 20 27 67 65 74 2d 6d 61 74 63 68 69 6e 67 ve 'get-matching
73c0: 2d 70 72 65 76 69 6f 75 73 2d 74 65 73 74 2d 72 -previous-test-r
73d0: 75 6e 2d 72 65 63 6f 72 64 73 20 72 75 6e 2d 69 un-records run-i
73e0: 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 d (list run-id t
73f0: 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 est-name item-pa
7400: 74 68 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 th)))..(define (
7410: 72 6d 74 3a 74 65 73 74 2d 67 65 74 2d 6c 6f 67 rmt:test-get-log
7420: 66 69 6c 65 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 file-info run-id
7430: 20 74 65 73 74 2d 6e 61 6d 65 29 0a 20 20 28 72 test-name). (r
7440: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
7450: 27 74 65 73 74 2d 67 65 74 2d 6c 6f 67 66 69 6c 'test-get-logfil
7460: 65 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 20 28 6c e-info run-id (l
7470: 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d ist run-id test-
7480: 6e 61 6d 65 29 29 29 0a 0a 28 64 65 66 69 6e 65 name)))..(define
7490: 20 28 72 6d 74 3a 74 65 73 74 2d 67 65 74 2d 72 (rmt:test-get-r
74a0: 65 63 6f 72 64 73 2d 66 6f 72 2d 69 6e 64 65 78 ecords-for-index
74b0: 2d 66 69 6c 65 20 72 75 6e 2d 69 64 20 74 65 73 -file run-id tes
74c0: 74 2d 6e 61 6d 65 29 0a 20 20 28 72 6d 74 3a 73 t-name). (rmt:s
74d0: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 74 65 73 end-receive 'tes
74e0: 74 2d 67 65 74 2d 72 65 63 6f 72 64 73 2d 66 6f t-get-records-fo
74f0: 72 2d 69 6e 64 65 78 2d 66 69 6c 65 20 72 75 6e r-index-file run
7500: 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 -id (list run-id
7510: 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a 0a 28 test-name)))..(
7520: 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d define (rmt:get-
7530: 74 65 73 74 69 6e 66 6f 2d 73 74 61 74 65 2d 73 testinfo-state-s
7540: 74 61 74 75 73 20 72 75 6e 2d 69 64 20 74 65 73 tatus run-id tes
7550: 74 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e t-id). (rmt:sen
7560: 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 74 d-receive 'get-t
7570: 65 73 74 69 6e 66 6f 2d 73 74 61 74 65 2d 73 74 estinfo-state-st
7580: 61 74 75 73 20 72 75 6e 2d 69 64 20 28 6c 69 73 atus run-id (lis
7590: 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 t run-id test-id
75a0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d )))..(define (rm
75b0: 74 3a 74 65 73 74 2d 73 65 74 2d 6c 6f 67 21 20 t:test-set-log!
75c0: 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 6c run-id test-id l
75d0: 6f 67 66 29 0a 20 20 28 69 66 20 28 73 74 72 69 ogf). (if (stri
75e0: 6e 67 3f 20 6c 6f 67 66 29 28 72 6d 74 3a 67 65 ng? logf)(rmt:ge
75f0: 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 74 65 73 74 neral-call 'test
7600: 2d 73 65 74 2d 6c 6f 67 20 72 75 6e 2d 69 64 20 -set-log run-id
7610: 6c 6f 67 66 20 74 65 73 74 2d 69 64 29 29 29 0a logf test-id))).
7620: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 65 .(define (rmt:te
7630: 73 74 2d 73 65 74 2d 74 6f 70 2d 70 72 6f 63 65 st-set-top-proce
7640: 73 73 2d 70 69 64 20 72 75 6e 2d 69 64 20 74 65 ss-pid run-id te
7650: 73 74 2d 69 64 20 70 69 64 29 0a 20 20 28 72 6d st-id pid). (rm
7660: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
7670: 74 65 73 74 2d 73 65 74 2d 74 6f 70 2d 70 72 6f test-set-top-pro
7680: 63 65 73 73 2d 70 69 64 20 72 75 6e 2d 69 64 20 cess-pid run-id
7690: 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 (list run-id tes
76a0: 74 2d 69 64 20 70 69 64 29 29 29 0a 0a 28 64 65 t-id pid)))..(de
76b0: 66 69 6e 65 20 28 72 6d 74 3a 74 65 73 74 2d 67 fine (rmt:test-g
76c0: 65 74 2d 74 6f 70 2d 70 72 6f 63 65 73 73 2d 70 et-top-process-p
76d0: 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 id run-id test-i
76e0: 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 d). (rmt:send-r
76f0: 65 63 65 69 76 65 20 27 74 65 73 74 2d 67 65 74 eceive 'test-get
7700: 2d 74 6f 70 2d 70 72 6f 63 65 73 73 2d 70 69 64 -top-process-pid
7710: 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 run-id (list ru
7720: 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 29 29 0a n-id test-id))).
7730: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 .(define (rmt:ge
7740: 74 2d 72 75 6e 2d 69 64 73 2d 6d 61 74 63 68 69 t-run-ids-matchi
7750: 6e 67 2d 74 61 72 67 65 74 20 6b 65 79 6e 61 6d ng-target keynam
7760: 65 73 20 74 61 72 67 65 74 20 72 65 73 20 72 75 es target res ru
7770: 6e 6e 61 6d 65 20 74 65 73 74 70 61 74 74 20 73 nname testpatt s
7780: 74 61 74 65 70 61 74 74 20 73 74 61 74 75 73 70 tatepatt statusp
7790: 61 74 74 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 att). (rmt:send
77a0: 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 72 75 -receive 'get-ru
77b0: 6e 2d 69 64 73 2d 6d 61 74 63 68 69 6e 67 2d 74 n-ids-matching-t
77c0: 61 72 67 65 74 20 23 66 20 28 6c 69 73 74 20 6b arget #f (list k
77d0: 65 79 6e 61 6d 65 73 20 74 61 72 67 65 74 20 72 eynames target r
77e0: 65 73 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 70 es runname testp
77f0: 61 74 74 20 73 74 61 74 65 70 61 74 74 20 73 74 att statepatt st
7800: 61 74 75 73 70 61 74 74 29 29 29 0a 0a 3b 3b 20 atuspatt)))..;;
7810: 4e 4f 54 45 3a 20 54 68 69 73 20 77 69 6c 6c 20 NOTE: This will
7820: 6f 70 65 6e 20 61 6e 64 20 61 63 63 65 73 73 20 open and access
7830: 41 4c 4c 20 72 75 6e 20 64 61 74 61 62 61 73 65 ALL run database
7840: 73 2e 20 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 s. .;;.(define (
7850: 72 6d 74 3a 74 65 73 74 2d 67 65 74 2d 70 61 74 rmt:test-get-pat
7860: 68 73 2d 6d 61 74 63 68 69 6e 67 2d 6b 65 79 6e hs-matching-keyn
7870: 61 6d 65 73 2d 74 61 72 67 65 74 2d 6e 65 77 20 ames-target-new
7880: 6b 65 79 6e 61 6d 65 73 20 74 61 72 67 65 74 20 keynames target
7890: 72 65 73 20 74 65 73 74 70 61 74 74 20 73 74 61 res testpatt sta
78a0: 74 65 70 61 74 74 20 73 74 61 74 75 73 70 61 74 tepatt statuspat
78b0: 74 20 72 75 6e 6e 61 6d 65 29 0a 20 20 28 6c 65 t runname). (le
78c0: 74 20 28 28 72 75 6e 2d 69 64 73 20 28 72 6d 74 t ((run-ids (rmt
78d0: 3a 67 65 74 2d 72 75 6e 2d 69 64 73 2d 6d 61 74 :get-run-ids-mat
78e0: 63 68 69 6e 67 2d 74 61 72 67 65 74 20 6b 65 79 ching-target key
78f0: 6e 61 6d 65 73 20 74 61 72 67 65 74 20 72 65 73 names target res
7900: 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 70 61 74 runname testpat
7910: 74 20 73 74 61 74 65 70 61 74 74 20 73 74 61 74 t statepatt stat
7920: 75 73 70 61 74 74 29 29 29 0a 20 20 20 20 28 61 uspatt))). (a
7930: 70 70 6c 79 20 61 70 70 65 6e 64 20 0a 09 20 20 pply append ..
7940: 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 72 (map (lambda (r
7950: 75 6e 2d 69 64 29 0a 09 09 20 20 28 72 6d 74 3a un-id)... (rmt:
7960: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 74 65 send-receive 'te
7970: 73 74 2d 67 65 74 2d 70 61 74 68 73 2d 6d 61 74 st-get-paths-mat
7980: 63 68 69 6e 67 2d 6b 65 79 6e 61 6d 65 73 2d 74 ching-keynames-t
7990: 61 72 67 65 74 2d 6e 65 77 20 72 75 6e 2d 69 64 arget-new run-id
79a0: 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 6b 65 (list run-id ke
79b0: 79 6e 61 6d 65 73 20 74 61 72 67 65 74 20 72 65 ynames target re
79c0: 73 20 74 65 73 74 70 61 74 74 20 73 74 61 74 65 s testpatt state
79d0: 70 61 74 74 20 73 74 61 74 75 73 70 61 74 74 20 patt statuspatt
79e0: 72 75 6e 6e 61 6d 65 29 29 29 0a 09 20 20 20 72 runname))).. r
79f0: 75 6e 2d 69 64 73 29 29 29 29 0a 0a 3b 3b 20 28 un-ids))))..;; (
7a00: 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d define (rmt:get-
7a10: 72 75 6e 2d 69 64 73 2d 6d 61 74 63 68 69 6e 67 run-ids-matching
7a20: 20 6b 65 79 6e 61 6d 65 73 20 74 61 72 67 65 74 keynames target
7a30: 20 72 65 73 29 0a 3b 3b 20 20 20 28 72 6d 74 3a res).;; (rmt:
7a40: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 23 66 20 send-receive #f
7a50: 27 67 65 74 2d 72 75 6e 2d 69 64 73 2d 6d 61 74 'get-run-ids-mat
7a60: 63 68 69 6e 67 20 28 6c 69 73 74 20 6b 65 79 6e ching (list keyn
7a70: 61 6d 65 73 20 74 61 72 67 65 74 20 72 65 73 29 ames target res)
7a80: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
7a90: 3a 67 65 74 2d 70 72 65 72 65 71 73 2d 6e 6f 74 :get-prereqs-not
7aa0: 2d 6d 65 74 20 72 75 6e 2d 69 64 20 77 61 69 74 -met run-id wait
7ab0: 6f 6e 73 20 72 65 66 2d 74 65 73 74 2d 6e 61 6d ons ref-test-nam
7ac0: 65 20 72 65 66 2d 69 74 65 6d 2d 70 61 74 68 20 e ref-item-path
7ad0: 23 21 6b 65 79 20 28 6d 6f 64 65 20 27 28 6e 6f #!key (mode '(no
7ae0: 72 6d 61 6c 29 29 28 69 74 65 6d 6d 61 70 73 20 rmal))(itemmaps
7af0: 23 66 29 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 #f)). (rmt:send
7b00: 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 70 72 -receive 'get-pr
7b10: 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 72 75 ereqs-not-met ru
7b20: 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 n-id (list run-i
7b30: 64 20 77 61 69 74 6f 6e 73 20 72 65 66 2d 74 65 d waitons ref-te
7b40: 73 74 2d 6e 61 6d 65 20 72 65 66 2d 69 74 65 6d st-name ref-item
7b50: 2d 70 61 74 68 20 6d 6f 64 65 20 69 74 65 6d 6d -path mode itemm
7b60: 61 70 73 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 aps)))..(define
7b70: 28 72 6d 74 3a 67 65 74 2d 63 6f 75 6e 74 2d 74 (rmt:get-count-t
7b80: 65 73 74 73 2d 72 75 6e 6e 69 6e 67 2d 66 6f 72 ests-running-for
7b90: 2d 72 75 6e 2d 69 64 20 72 75 6e 2d 69 64 29 0a -run-id run-id).
7ba0: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
7bb0: 69 76 65 20 27 67 65 74 2d 63 6f 75 6e 74 2d 74 ive 'get-count-t
7bc0: 65 73 74 73 2d 72 75 6e 6e 69 6e 67 2d 66 6f 72 ests-running-for
7bd0: 2d 72 75 6e 2d 69 64 20 72 75 6e 2d 69 64 20 28 -run-id run-id (
7be0: 6c 69 73 74 20 72 75 6e 2d 69 64 29 29 29 0a 0a list run-id)))..
7bf0: 3b 3b 20 53 74 61 74 69 73 74 69 63 61 6c 20 71 ;; Statistical q
7c00: 75 65 72 69 65 73 0a 0a 28 64 65 66 69 6e 65 20 ueries..(define
7c10: 28 72 6d 74 3a 67 65 74 2d 63 6f 75 6e 74 2d 74 (rmt:get-count-t
7c20: 65 73 74 73 2d 72 75 6e 6e 69 6e 67 20 72 75 6e ests-running run
7c30: 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 -id). (rmt:send
7c40: 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 63 6f -receive 'get-co
7c50: 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e unt-tests-runnin
7c60: 67 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 g run-id (list r
7c70: 75 6e 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 6e un-id)))..(defin
7c80: 65 20 28 72 6d 74 3a 67 65 74 2d 63 6f 75 6e 74 e (rmt:get-count
7c90: 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 2d 66 -tests-running-f
7ca0: 6f 72 2d 74 65 73 74 6e 61 6d 65 20 72 75 6e 2d or-testname run-
7cb0: 69 64 20 74 65 73 74 6e 61 6d 65 29 0a 20 20 28 id testname). (
7cc0: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
7cd0: 20 27 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 'get-count-test
7ce0: 73 2d 72 75 6e 6e 69 6e 67 2d 66 6f 72 2d 74 65 s-running-for-te
7cf0: 73 74 6e 61 6d 65 20 72 75 6e 2d 69 64 20 28 6c stname run-id (l
7d00: 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 6e ist run-id testn
7d10: 61 6d 65 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ame)))..(define
7d20: 28 72 6d 74 3a 67 65 74 2d 63 6f 75 6e 74 2d 74 (rmt:get-count-t
7d30: 65 73 74 73 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d ests-running-in-
7d40: 6a 6f 62 67 72 6f 75 70 20 72 75 6e 2d 69 64 20 jobgroup run-id
7d50: 6a 6f 62 67 72 6f 75 70 29 0a 20 20 28 72 6d 74 jobgroup). (rmt
7d60: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 :send-receive 'g
7d70: 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d 72 et-count-tests-r
7d80: 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f unning-in-jobgro
7d90: 75 70 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 up run-id (list
7da0: 72 75 6e 2d 69 64 20 6a 6f 62 67 72 6f 75 70 29 run-id jobgroup)
7db0: 29 29 0a 0a 3b 3b 20 73 74 61 74 65 20 61 6e 64 ))..;; state and
7dc0: 20 73 74 61 74 75 73 20 61 72 65 20 65 78 74 72 status are extr
7dd0: 61 20 68 69 6e 74 73 20 6e 6f 74 20 75 73 75 61 a hints not usua
7de0: 6c 6c 79 20 75 73 65 64 20 69 6e 20 74 68 65 20 lly used in the
7df0: 63 61 6c 63 75 6c 61 74 69 6f 6e 0a 3b 3b 0a 28 calculation.;;.(
7e00: 64 65 66 69 6e 65 20 28 72 6d 74 3a 73 65 74 2d define (rmt:set-
7e10: 73 74 61 74 65 2d 73 74 61 74 75 73 2d 61 6e 64 state-status-and
7e20: 2d 72 6f 6c 6c 2d 75 70 2d 69 74 65 6d 73 20 72 -roll-up-items r
7e30: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 un-id test-name
7e40: 69 74 65 6d 2d 70 61 74 68 20 73 74 61 74 65 20 item-path state
7e50: 73 74 61 74 75 73 20 63 6f 6d 6d 65 6e 74 29 0a status comment).
7e60: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
7e70: 69 76 65 20 27 73 65 74 2d 73 74 61 74 65 2d 73 ive 'set-state-s
7e80: 74 61 74 75 73 2d 61 6e 64 2d 72 6f 6c 6c 2d 75 tatus-and-roll-u
7e90: 70 2d 69 74 65 6d 73 20 72 75 6e 2d 69 64 20 28 p-items run-id (
7ea0: 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 list run-id test
7eb0: 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 -name item-path
7ec0: 73 74 61 74 65 20 73 74 61 74 75 73 20 63 6f 6d state status com
7ed0: 6d 65 6e 74 29 29 29 0a 0a 28 64 65 66 69 6e 65 ment)))..(define
7ee0: 20 28 72 6d 74 3a 75 70 64 61 74 65 2d 70 61 73 (rmt:update-pas
7ef0: 73 2d 66 61 69 6c 2d 63 6f 75 6e 74 73 20 72 75 s-fail-counts ru
7f00: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 29 0a n-id test-name).
7f10: 20 20 28 72 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 (rmt:general-c
7f20: 61 6c 6c 20 27 75 70 64 61 74 65 2d 70 61 73 73 all 'update-pass
7f30: 2d 66 61 69 6c 2d 63 6f 75 6e 74 73 20 72 75 6e -fail-counts run
7f40: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 74 65 -id test-name te
7f50: 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d st-name test-nam
7f60: 65 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d e))..(define (rm
7f70: 74 3a 74 6f 70 2d 74 65 73 74 2d 73 65 74 2d 70 t:top-test-set-p
7f80: 65 72 2d 70 66 2d 63 6f 75 6e 74 73 20 72 75 6e er-pf-counts run
7f90: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 29 0a 20 -id test-name).
7fa0: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
7fb0: 76 65 20 27 74 6f 70 2d 74 65 73 74 2d 73 65 74 ve 'top-test-set
7fc0: 2d 70 65 72 2d 70 66 2d 63 6f 75 6e 74 73 20 72 -per-pf-counts r
7fd0: 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d un-id (list run-
7fe0: 69 64 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a id test-name))).
7ff0: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 .(define (rmt:ge
8000: 74 2d 72 61 77 2d 72 75 6e 2d 73 74 61 74 73 20 t-raw-run-stats
8010: 72 75 6e 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 run-id). (rmt:s
8020: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 end-receive 'get
8030: 2d 72 61 77 2d 72 75 6e 2d 73 74 61 74 73 20 72 -raw-run-stats r
8040: 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d un-id (list run-
8050: 69 64 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d id)))..;;=======
8060: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8070: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8080: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8090: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
80a0: 3b 3b 20 20 52 20 55 20 4e 20 53 0a 3b 3b 3d 3d ;; R U N S.;;==
80b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
80c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
80d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
80e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
80f0: 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 72 ====..(define (r
8100: 6d 74 3a 67 65 74 2d 72 75 6e 2d 69 6e 66 6f 20 mt:get-run-info
8110: 72 75 6e 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 run-id). (rmt:s
8120: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 end-receive 'get
8130: 2d 72 75 6e 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 -run-info run-id
8140: 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 29 29 29 (list run-id)))
8150: 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 ..(define (rmt:g
8160: 65 74 2d 6e 75 6d 2d 72 75 6e 73 20 72 75 6e 70 et-num-runs runp
8170: 61 74 74 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 att). (rmt:send
8180: 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 6e 75 -receive 'get-nu
8190: 6d 2d 72 75 6e 73 20 23 66 20 28 6c 69 73 74 20 m-runs #f (list
81a0: 72 75 6e 70 61 74 74 29 29 29 0a 0a 3b 3b 20 55 runpatt)))..;; U
81b0: 73 65 20 74 68 65 20 73 70 65 63 69 61 6c 20 72 se the special r
81c0: 75 6e 2d 69 64 20 3d 3d 20 23 66 20 73 63 65 6e un-id == #f scen
81d0: 61 72 69 6f 20 68 65 72 65 20 73 69 6e 63 65 20 ario here since
81e0: 74 68 65 72 65 20 69 73 20 6e 6f 20 72 75 6e 20 there is no run
81f0: 79 65 74 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 yet.(define (rmt
8200: 3a 72 65 67 69 73 74 65 72 2d 72 75 6e 20 6b 65 :register-run ke
8210: 79 76 61 6c 73 20 72 75 6e 6e 61 6d 65 20 73 74 yvals runname st
8220: 61 74 65 20 73 74 61 74 75 73 20 75 73 65 72 20 ate status user
8230: 63 6f 6e 74 6f 75 72 29 0a 20 20 28 72 6d 74 3a contour). (rmt:
8240: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 72 65 send-receive 're
8250: 67 69 73 74 65 72 2d 72 75 6e 20 23 66 20 28 6c gister-run #f (l
8260: 69 73 74 20 6b 65 79 76 61 6c 73 20 72 75 6e 6e ist keyvals runn
8270: 61 6d 65 20 73 74 61 74 65 20 73 74 61 74 75 73 ame state status
8280: 20 75 73 65 72 20 63 6f 6e 74 6f 75 72 29 29 29 user contour)))
8290: 0a 20 20 20 20 0a 28 64 65 66 69 6e 65 20 28 72 . .(define (r
82a0: 6d 74 3a 67 65 74 2d 72 75 6e 2d 6e 61 6d 65 2d mt:get-run-name-
82b0: 66 72 6f 6d 2d 69 64 20 72 75 6e 2d 69 64 29 0a from-id run-id).
82c0: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
82d0: 69 76 65 20 27 67 65 74 2d 72 75 6e 2d 6e 61 6d ive 'get-run-nam
82e0: 65 2d 66 72 6f 6d 2d 69 64 20 72 75 6e 2d 69 64 e-from-id run-id
82f0: 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 29 29 29 (list run-id)))
8300: 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 64 ..(define (rmt:d
8310: 65 6c 65 74 65 2d 72 75 6e 20 72 75 6e 2d 69 64 elete-run run-id
8320: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
8330: 63 65 69 76 65 20 27 64 65 6c 65 74 65 2d 72 75 ceive 'delete-ru
8340: 6e 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 n run-id (list r
8350: 75 6e 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 6e un-id)))..(defin
8360: 65 20 28 72 6d 74 3a 75 70 64 61 74 65 2d 72 75 e (rmt:update-ru
8370: 6e 2d 73 74 61 74 73 20 72 75 6e 2d 69 64 20 73 n-stats run-id s
8380: 74 61 74 73 29 0a 20 20 28 72 6d 74 3a 73 65 6e tats). (rmt:sen
8390: 64 2d 72 65 63 65 69 76 65 20 27 75 70 64 61 74 d-receive 'updat
83a0: 65 2d 72 75 6e 2d 73 74 61 74 73 20 23 66 20 28 e-run-stats #f (
83b0: 6c 69 73 74 20 72 75 6e 2d 69 64 20 73 74 61 74 list run-id stat
83c0: 73 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 s)))..(define (r
83d0: 6d 74 3a 64 65 6c 65 74 65 2d 6f 6c 64 2d 64 65 mt:delete-old-de
83e0: 6c 65 74 65 64 2d 74 65 73 74 2d 72 65 63 6f 72 leted-test-recor
83f0: 64 73 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d ds). (rmt:send-
8400: 72 65 63 65 69 76 65 20 27 64 65 6c 65 74 65 2d receive 'delete-
8410: 6f 6c 64 2d 64 65 6c 65 74 65 64 2d 74 65 73 74 old-deleted-test
8420: 2d 72 65 63 6f 72 64 73 20 23 66 20 27 28 29 29 -records #f '())
8430: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a )..(define (rmt:
8440: 67 65 74 2d 72 75 6e 73 20 72 75 6e 70 61 74 74 get-runs runpatt
8450: 20 63 6f 75 6e 74 20 6f 66 66 73 65 74 20 6b 65 count offset ke
8460: 79 70 61 74 74 73 29 0a 20 20 28 72 6d 74 3a 73 ypatts). (rmt:s
8470: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 end-receive 'get
8480: 2d 72 75 6e 73 20 23 66 20 28 6c 69 73 74 20 72 -runs #f (list r
8490: 75 6e 70 61 74 74 20 63 6f 75 6e 74 20 6f 66 66 unpatt count off
84a0: 73 65 74 20 6b 65 79 70 61 74 74 73 29 29 29 0a set keypatts))).
84b0: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 .(define (rmt:ge
84c0: 74 2d 61 6c 6c 2d 72 75 6e 2d 69 64 73 29 0a 20 t-all-run-ids).
84d0: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
84e0: 76 65 20 27 67 65 74 2d 61 6c 6c 2d 72 75 6e 2d ve 'get-all-run-
84f0: 69 64 73 20 23 66 20 27 28 29 29 29 0a 0a 28 64 ids #f '()))..(d
8500: 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 70 efine (rmt:get-p
8510: 72 65 76 2d 72 75 6e 2d 69 64 73 20 72 75 6e 2d rev-run-ids run-
8520: 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d id). (rmt:send-
8530: 72 65 63 65 69 76 65 20 27 67 65 74 2d 70 72 65 receive 'get-pre
8540: 76 2d 72 75 6e 2d 69 64 73 20 23 66 20 28 6c 69 v-run-ids #f (li
8550: 73 74 20 72 75 6e 2d 69 64 29 29 29 0a 0a 28 64 st run-id)))..(d
8560: 65 66 69 6e 65 20 28 72 6d 74 3a 6c 6f 63 6b 2f efine (rmt:lock/
8570: 75 6e 6c 6f 63 6b 2d 72 75 6e 20 72 75 6e 2d 69 unlock-run run-i
8580: 64 20 6c 6f 63 6b 20 75 6e 6c 6f 63 6b 20 75 73 d lock unlock us
8590: 65 72 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d er). (rmt:send-
85a0: 72 65 63 65 69 76 65 20 27 6c 6f 63 6b 2f 75 6e receive 'lock/un
85b0: 6c 6f 63 6b 2d 72 75 6e 20 23 66 20 28 6c 69 73 lock-run #f (lis
85c0: 74 20 72 75 6e 2d 69 64 20 6c 6f 63 6b 20 75 6e t run-id lock un
85d0: 6c 6f 63 6b 20 75 73 65 72 29 29 29 0a 0a 3b 3b lock user)))..;;
85e0: 20 73 65 74 2f 67 65 74 20 73 74 61 74 75 73 0a set/get status.
85f0: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 (define (rmt:get
8600: 2d 72 75 6e 2d 73 74 61 74 75 73 20 72 75 6e 2d -run-status run-
8610: 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d id). (rmt:send-
8620: 72 65 63 65 69 76 65 20 27 67 65 74 2d 72 75 6e receive 'get-run
8630: 2d 73 74 61 74 75 73 20 23 66 20 28 6c 69 73 74 -status #f (list
8640: 20 72 75 6e 2d 69 64 29 29 29 0a 0a 28 64 65 66 run-id)))..(def
8650: 69 6e 65 20 28 72 6d 74 3a 73 65 74 2d 72 75 6e ine (rmt:set-run
8660: 2d 73 74 61 74 75 73 20 72 75 6e 2d 69 64 20 72 -status run-id r
8670: 75 6e 2d 73 74 61 74 75 73 20 23 21 6b 65 79 20 un-status #!key
8680: 28 6d 73 67 20 23 66 29 29 0a 20 20 28 72 6d 74 (msg #f)). (rmt
8690: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 73 :send-receive 's
86a0: 65 74 2d 72 75 6e 2d 73 74 61 74 75 73 20 23 66 et-run-status #f
86b0: 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 72 75 (list run-id ru
86c0: 6e 2d 73 74 61 74 75 73 20 6d 73 67 29 29 29 0a n-status msg))).
86d0: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 75 70 .(define (rmt:up
86e0: 64 61 74 65 2d 72 75 6e 2d 65 76 65 6e 74 5f 74 date-run-event_t
86f0: 69 6d 65 20 72 75 6e 2d 69 64 29 0a 20 20 28 72 ime run-id). (r
8700: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
8710: 27 75 70 64 61 74 65 2d 72 75 6e 2d 65 76 65 6e 'update-run-even
8720: 74 5f 74 69 6d 65 20 23 66 20 28 6c 69 73 74 20 t_time #f (list
8730: 72 75 6e 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 run-id)))..(defi
8740: 6e 65 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e 73 ne (rmt:get-runs
8750: 2d 62 79 2d 70 61 74 74 20 20 6b 65 79 73 20 72 -by-patt keys r
8760: 75 6e 6e 61 6d 65 70 61 74 74 20 74 61 72 67 70 unnamepatt targp
8770: 61 74 74 20 6f 66 66 73 65 74 20 6c 69 6d 69 74 att offset limit
8780: 20 66 69 65 6c 64 73 20 6c 61 73 74 2d 72 75 6e fields last-run
8790: 73 2d 75 70 64 61 74 65 29 20 3b 3b 20 66 69 65 s-update) ;; fie
87a0: 6c 64 73 20 6f 66 20 23 66 20 75 73 65 73 20 64 lds of #f uses d
87b0: 65 66 61 75 6c 74 0a 20 20 28 72 6d 74 3a 73 65 efault. (rmt:se
87c0: 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d nd-receive 'get-
87d0: 72 75 6e 73 2d 62 79 2d 70 61 74 74 20 23 66 20 runs-by-patt #f
87e0: 28 6c 69 73 74 20 6b 65 79 73 20 72 75 6e 6e 61 (list keys runna
87f0: 6d 65 70 61 74 74 20 74 61 72 67 70 61 74 74 20 mepatt targpatt
8800: 6f 66 66 73 65 74 20 6c 69 6d 69 74 20 66 69 65 offset limit fie
8810: 6c 64 73 20 6c 61 73 74 2d 72 75 6e 73 2d 75 70 lds last-runs-up
8820: 64 61 74 65 29 29 29 0a 0a 28 64 65 66 69 6e 65 date)))..(define
8830: 20 28 72 6d 74 3a 66 69 6e 64 2d 61 6e 64 2d 6d (rmt:find-and-m
8840: 61 72 6b 2d 69 6e 63 6f 6d 70 6c 65 74 65 20 72 ark-incomplete r
8850: 75 6e 2d 69 64 20 6f 76 72 2d 64 65 61 64 74 69 un-id ovr-deadti
8860: 6d 65 29 0a 20 20 3b 3b 20 28 69 66 20 28 72 6d me). ;; (if (rm
8870: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
8880: 68 61 76 65 2d 69 6e 63 6f 6d 70 6c 65 74 65 73 have-incompletes
8890: 3f 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 ? run-id (list r
88a0: 75 6e 2d 69 64 20 6f 76 72 2d 64 65 61 64 74 69 un-id ovr-deadti
88b0: 6d 65 29 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 me)). (rmt:send
88c0: 2d 72 65 63 65 69 76 65 20 27 6d 61 72 6b 2d 69 -receive 'mark-i
88d0: 6e 63 6f 6d 70 6c 65 74 65 20 72 75 6e 2d 69 64 ncomplete run-id
88e0: 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 6f 76 (list run-id ov
88f0: 72 2d 64 65 61 64 74 69 6d 65 29 29 29 20 3b 3b r-deadtime))) ;;
8900: 20 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 )..(define (rmt
8910: 3a 67 65 74 2d 6d 61 69 6e 2d 72 75 6e 2d 73 74 :get-main-run-st
8920: 61 74 73 20 72 75 6e 2d 69 64 29 0a 20 20 28 72 ats run-id). (r
8930: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
8940: 27 67 65 74 2d 6d 61 69 6e 2d 72 75 6e 2d 73 74 'get-main-run-st
8950: 61 74 73 20 23 66 20 28 6c 69 73 74 20 72 75 6e ats #f (list run
8960: 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 -id)))..(define
8970: 28 72 6d 74 3a 67 65 74 2d 76 61 72 20 76 61 72 (rmt:get-var var
8980: 6e 61 6d 65 29 0a 20 20 28 72 6d 74 3a 73 65 6e name). (rmt:sen
8990: 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 76 d-receive 'get-v
89a0: 61 72 20 23 66 20 28 6c 69 73 74 20 76 61 72 6e ar #f (list varn
89b0: 61 6d 65 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ame)))..(define
89c0: 28 72 6d 74 3a 64 65 6c 2d 76 61 72 20 76 61 72 (rmt:del-var var
89d0: 6e 61 6d 65 29 0a 20 20 28 72 6d 74 3a 73 65 6e name). (rmt:sen
89e0: 64 2d 72 65 63 65 69 76 65 20 27 64 65 6c 2d 76 d-receive 'del-v
89f0: 61 72 20 23 66 20 28 6c 69 73 74 20 76 61 72 6e ar #f (list varn
8a00: 61 6d 65 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ame)))..(define
8a10: 28 72 6d 74 3a 73 65 74 2d 76 61 72 20 76 61 72 (rmt:set-var var
8a20: 6e 61 6d 65 20 76 61 6c 75 65 29 0a 20 20 28 72 name value). (r
8a30: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
8a40: 27 73 65 74 2d 76 61 72 20 23 66 20 28 6c 69 73 'set-var #f (lis
8a50: 74 20 76 61 72 6e 61 6d 65 20 76 61 6c 75 65 29 t varname value)
8a60: 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ))..;;==========
8a70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8a80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8a90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8aa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
8ab0: 4d 20 55 20 4c 20 54 20 49 20 52 20 55 20 4e 20 M U L T I R U N
8ac0: 20 20 51 20 55 20 45 20 52 20 49 20 45 20 53 0a Q U E R I E S.
8ad0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
8ae0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8af0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8b00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8b10: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 4e 65 65 ========..;; Nee
8b20: 64 20 74 6f 20 6d 6f 76 65 20 74 68 69 73 20 74 d to move this t
8b30: 6f 20 6d 75 6c 74 69 2d 72 75 6e 20 73 65 63 74 o multi-run sect
8b40: 69 6f 6e 20 61 6e 64 20 6d 61 6b 65 20 61 73 73 ion and make ass
8b50: 6f 63 69 61 74 65 64 20 63 68 61 6e 67 65 73 0a ociated changes.
8b60: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 66 69 6e (define (rmt:fin
8b70: 64 2d 61 6e 64 2d 6d 61 72 6b 2d 69 6e 63 6f 6d d-and-mark-incom
8b80: 70 6c 65 74 65 2d 61 6c 6c 2d 72 75 6e 73 20 23 plete-all-runs #
8b90: 21 6b 65 79 20 28 6f 76 72 2d 64 65 61 64 74 69 !key (ovr-deadti
8ba0: 6d 65 20 23 66 29 29 0a 20 20 28 6c 65 74 20 28 me #f)). (let (
8bb0: 28 72 75 6e 2d 69 64 73 20 28 72 6d 74 3a 67 65 (run-ids (rmt:ge
8bc0: 74 2d 61 6c 6c 2d 72 75 6e 2d 69 64 73 29 29 29 t-all-run-ids)))
8bd0: 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 . (for-each (
8be0: 6c 61 6d 62 64 61 20 28 72 75 6e 2d 69 64 29 0a lambda (run-id).
8bf0: 09 20 20 20 20 20 20 20 28 72 6d 74 3a 66 69 6e . (rmt:fin
8c00: 64 2d 61 6e 64 2d 6d 61 72 6b 2d 69 6e 63 6f 6d d-and-mark-incom
8c10: 70 6c 65 74 65 20 72 75 6e 2d 69 64 20 6f 76 72 plete run-id ovr
8c20: 2d 64 65 61 64 74 69 6d 65 29 29 0a 09 20 20 20 -deadtime))..
8c30: 20 20 72 75 6e 2d 69 64 73 29 29 29 0a 0a 3b 3b run-ids)))..;;
8c40: 20 67 65 74 20 74 68 65 20 70 72 65 76 69 6f 75 get the previou
8c50: 73 20 72 65 63 6f 72 64 20 66 6f 72 20 77 68 65 s record for whe
8c60: 6e 20 74 68 69 73 20 74 65 73 74 20 77 61 73 20 n this test was
8c70: 72 75 6e 20 77 68 65 72 65 20 61 6c 6c 20 6b 65 run where all ke
8c80: 79 73 20 6d 61 74 63 68 20 62 75 74 20 72 75 6e ys match but run
8c90: 6e 61 6d 65 0a 3b 3b 20 72 65 74 75 72 6e 73 20 name.;; returns
8ca0: 23 66 20 69 66 20 6e 6f 20 73 75 63 68 20 74 65 #f if no such te
8cb0: 73 74 20 66 6f 75 6e 64 2c 20 72 65 74 75 72 6e st found, return
8cc0: 73 20 61 20 73 69 6e 67 6c 65 20 74 65 73 74 20 s a single test
8cd0: 72 65 63 6f 72 64 20 69 66 20 66 6f 75 6e 64 0a record if found.
8ce0: 3b 3b 20 0a 3b 3b 20 52 75 6e 20 74 68 69 73 20 ;; .;; Run this
8cf0: 61 74 20 74 68 65 20 63 6c 69 65 6e 74 20 65 6e at the client en
8d00: 64 20 73 69 6e 63 65 20 77 65 20 68 61 76 65 20 d since we have
8d10: 74 6f 20 63 6f 6e 6e 65 63 74 20 74 6f 20 6d 75 to connect to mu
8d20: 6c 74 69 70 6c 65 20 72 75 6e 2d 69 64 20 64 62 ltiple run-id db
8d30: 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 72 6d s.;;.(define (rm
8d40: 74 3a 67 65 74 2d 70 72 65 76 69 6f 75 73 2d 74 t:get-previous-t
8d50: 65 73 74 2d 72 75 6e 2d 72 65 63 6f 72 64 20 72 est-run-record r
8d60: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 un-id test-name
8d70: 69 74 65 6d 2d 70 61 74 68 29 0a 20 20 28 6c 65 item-path). (le
8d80: 74 2a 20 28 28 6b 65 79 76 61 6c 73 20 28 72 6d t* ((keyvals (rm
8d90: 74 3a 67 65 74 2d 6b 65 79 2d 76 61 6c 2d 70 61 t:get-key-val-pa
8da0: 69 72 73 20 72 75 6e 2d 69 64 29 29 0a 09 20 28 irs run-id)).. (
8db0: 6b 65 79 73 20 20 20 20 28 72 6d 74 3a 67 65 74 keys (rmt:get
8dc0: 2d 6b 65 79 73 29 29 0a 09 20 28 73 65 6c 73 74 -keys)).. (selst
8dd0: 72 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 r (string-inter
8de0: 73 70 65 72 73 65 20 20 6b 65 79 73 20 22 2c 22 sperse keys ","
8df0: 29 29 0a 09 20 28 71 72 79 73 74 72 20 20 28 73 )).. (qrystr (s
8e00: 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 tring-interspers
8e10: 65 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 e (map (lambda (
8e20: 78 29 28 63 6f 6e 63 20 78 20 22 3d 3f 22 29 29 x)(conc x "=?"))
8e30: 20 6b 65 79 73 29 20 22 20 41 4e 44 20 22 29 29 keys) " AND "))
8e40: 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 6b ). (if (not k
8e50: 65 79 76 61 6c 73 29 0a 09 23 66 0a 09 28 6c 65 eyvals)..#f..(le
8e60: 74 20 28 28 70 72 65 76 2d 72 75 6e 2d 69 64 73 t ((prev-run-ids
8e70: 20 28 72 6d 74 3a 67 65 74 2d 70 72 65 76 2d 72 (rmt:get-prev-r
8e80: 75 6e 2d 69 64 73 20 72 75 6e 2d 69 64 29 29 29 un-ids run-id)))
8e90: 0a 09 20 20 3b 3b 20 66 6f 72 20 65 61 63 68 20 .. ;; for each
8ea0: 72 75 6e 20 73 74 61 72 74 69 6e 67 20 77 69 74 run starting wit
8eb0: 68 20 74 68 65 20 6d 6f 73 74 20 72 65 63 65 6e h the most recen
8ec0: 74 20 6c 6f 6f 6b 20 74 6f 20 73 65 65 20 69 66 t look to see if
8ed0: 20 74 68 65 72 65 20 69 73 20 61 20 6d 61 74 63 there is a matc
8ee0: 68 69 6e 67 20 74 65 73 74 0a 09 20 20 3b 3b 20 hing test.. ;;
8ef0: 69 66 20 66 6f 75 6e 64 20 74 68 65 6e 20 72 65 if found then re
8f00: 74 75 72 6e 20 74 68 61 74 20 6d 61 74 63 68 69 turn that matchi
8f10: 6e 67 20 74 65 73 74 20 72 65 63 6f 72 64 0a 09 ng test record..
8f20: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 (debug:print 4
8f30: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
8f40: 72 74 2a 20 22 73 65 6c 73 74 72 3a 20 22 20 73 rt* "selstr: " s
8f50: 65 6c 73 74 72 20 22 2c 20 71 72 79 73 74 72 3a elstr ", qrystr:
8f60: 20 22 20 71 72 79 73 74 72 20 22 2c 20 6b 65 79 " qrystr ", key
8f70: 76 61 6c 73 3a 20 22 20 6b 65 79 76 61 6c 73 20 vals: " keyvals
8f80: 22 2c 20 70 72 65 76 69 6f 75 73 20 72 75 6e 20 ", previous run
8f90: 69 64 73 20 66 6f 75 6e 64 3a 20 22 20 70 72 65 ids found: " pre
8fa0: 76 2d 72 75 6e 2d 69 64 73 29 0a 09 20 20 28 69 v-run-ids).. (i
8fb0: 66 20 28 6e 75 6c 6c 3f 20 70 72 65 76 2d 72 75 f (null? prev-ru
8fc0: 6e 2d 69 64 73 29 20 23 66 0a 09 20 20 20 20 20 n-ids) #f..
8fd0: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 (let loop ((hed
8fe0: 20 28 63 61 72 20 70 72 65 76 2d 72 75 6e 2d 69 (car prev-run-i
8ff0: 64 73 29 29 0a 09 09 09 20 28 74 61 6c 20 28 63 ds)).... (tal (c
9000: 64 72 20 70 72 65 76 2d 72 75 6e 2d 69 64 73 29 dr prev-run-ids)
9010: 29 29 0a 09 09 28 6c 65 74 20 28 28 72 65 73 75 ))...(let ((resu
9020: 6c 74 73 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 lts (rmt:get-tes
9030: 74 73 2d 66 6f 72 2d 72 75 6e 20 68 65 64 20 28 ts-for-run hed (
9040: 63 6f 6e 63 20 74 65 73 74 2d 6e 61 6d 65 20 22 conc test-name "
9050: 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 20 27 28 /" item-path) '(
9060: 29 20 27 28 29 20 3b 3b 20 72 75 6e 2d 69 64 20 ) '() ;; run-id
9070: 74 65 73 74 70 61 74 74 20 73 74 61 74 65 73 20 testpatt states
9080: 73 74 61 74 75 73 65 73 0a 09 09 09 09 09 09 20 statuses.......
9090: 20 20 20 20 20 23 66 20 23 66 20 23 66 20 20 20 #f #f #f
90a0: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 6f ;; o
90b0: 66 66 73 65 74 20 6c 69 6d 69 74 20 6e 6f 74 2d ffset limit not-
90c0: 69 6e 20 68 69 64 65 2f 6e 6f 74 2d 68 69 64 65 in hide/not-hide
90d0: 0a 09 09 09 09 09 09 20 20 20 20 20 20 23 66 20 ....... #f
90e0: 23 66 20 23 66 20 23 66 20 27 6e 6f 72 6d 61 6c #f #f #f 'normal
90f0: 29 29 29 20 3b 3b 20 73 6f 72 74 2d 62 79 20 73 ))) ;; sort-by s
9100: 6f 72 74 2d 6f 72 64 65 72 20 71 72 79 76 61 6c ort-order qryval
9110: 73 20 6c 61 73 74 2d 75 70 64 61 74 65 20 6d 6f s last-update mo
9120: 64 65 0a 09 09 20 20 28 64 65 62 75 67 3a 70 72 de... (debug:pr
9130: 69 6e 74 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c int 4 *default-l
9140: 6f 67 2d 70 6f 72 74 2a 20 22 47 6f 74 20 74 65 og-port* "Got te
9150: 73 74 73 20 66 6f 72 20 72 75 6e 2d 69 64 20 22 sts for run-id "
9160: 20 72 75 6e 2d 69 64 20 22 2c 20 74 65 73 74 2d run-id ", test-
9170: 6e 61 6d 65 20 22 20 74 65 73 74 2d 6e 61 6d 65 name " test-name
9180: 20 22 2c 20 69 74 65 6d 2d 70 61 74 68 20 22 20 ", item-path "
9190: 69 74 65 6d 2d 70 61 74 68 20 22 3a 20 22 20 72 item-path ": " r
91a0: 65 73 75 6c 74 73 29 0a 09 09 20 20 28 69 66 20 esults)... (if
91b0: 28 61 6e 64 20 28 6e 75 6c 6c 3f 20 72 65 73 75 (and (null? resu
91c0: 6c 74 73 29 0a 09 09 09 20 20 20 28 6e 6f 74 20 lts).... (not
91d0: 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 29 0a 09 09 (null? tal)))...
91e0: 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 (loop (car
91f0: 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 29 0a tal)(cdr tal)).
9200: 09 09 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c .. (if (nul
9210: 6c 3f 20 72 65 73 75 6c 74 73 29 20 23 66 0a 09 l? results) #f..
9220: 09 09 20 20 28 63 61 72 20 72 65 73 75 6c 74 73 .. (car results
9230: 29 29 29 29 29 29 29 29 29 29 0a 0a 28 64 65 66 ))))))))))..(def
9240: 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e ine (rmt:get-run
9250: 2d 73 74 61 74 73 29 0a 20 20 28 72 6d 74 3a 73 -stats). (rmt:s
9260: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 end-receive 'get
9270: 2d 72 75 6e 2d 73 74 61 74 73 20 23 66 20 27 28 -run-stats #f '(
9280: 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d )))..;;=========
9290: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
92a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
92b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
92c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
92d0: 20 20 53 20 54 20 45 20 50 20 53 0a 3b 3b 3d 3d S T E P S.;;==
92e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
92f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9300: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9310: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9320: 3d 3d 3d 3d 0a 0a 3b 3b 20 47 65 74 74 69 6e 67 ====..;; Getting
9330: 20 73 74 65 70 73 20 69 73 20 6d 6f 72 65 20 63 steps is more c
9340: 6f 6d 70 6c 69 63 61 74 65 64 2e 0a 3b 3b 0a 3b omplicated..;;.;
9350: 3b 20 49 66 20 67 69 76 65 6e 20 77 6f 72 6b 20 ; If given work
9360: 61 72 65 61 20 0a 3b 3b 20 20 31 2e 20 46 69 6e area .;; 1. Fin
9370: 64 20 74 68 65 20 74 65 73 74 64 61 74 2e 64 62 d the testdat.db
9380: 20 66 69 6c 65 0a 3b 3b 20 20 32 2e 20 4f 70 65 file.;; 2. Ope
9390: 6e 20 74 68 65 20 74 65 73 74 64 61 74 2e 64 62 n the testdat.db
93a0: 20 66 69 6c 65 20 61 6e 64 20 64 6f 20 74 68 65 file and do the
93b0: 20 71 75 65 72 79 0a 3b 3b 20 49 66 20 6e 6f 74 query.;; If not
93c0: 20 67 69 76 65 6e 20 74 68 65 20 77 6f 72 6b 20 given the work
93d0: 61 72 65 61 0a 3b 3b 20 20 31 2e 20 44 6f 20 61 area.;; 1. Do a
93e0: 20 72 65 6d 6f 74 65 20 63 61 6c 6c 20 74 6f 20 remote call to
93f0: 67 65 74 20 74 68 65 20 74 65 73 74 20 70 61 74 get the test pat
9400: 68 0a 3b 3b 20 20 32 2e 20 43 6f 6e 74 69 6e 75 h.;; 2. Continu
9410: 65 20 61 73 20 61 62 6f 76 65 0a 3b 3b 20 0a 3b e as above.;; .;
9420: 3b 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 ;(define (rmt:ge
9430: 74 2d 73 74 65 70 73 2d 66 6f 72 2d 74 65 73 74 t-steps-for-test
9440: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 run-id test-id)
9450: 0a 3b 3b 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 .;; (rmt:send-r
9460: 65 63 65 69 76 65 20 27 67 65 74 2d 73 74 65 70 eceive 'get-step
9470: 73 2d 64 61 74 61 20 72 75 6e 2d 69 64 20 28 6c s-data run-id (l
9480: 69 73 74 20 74 65 73 74 2d 69 64 29 29 29 0a 0a ist test-id)))..
9490: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 65 73 (define (rmt:tes
94a0: 74 73 74 65 70 2d 73 65 74 2d 73 74 61 74 75 73 tstep-set-status
94b0: 21 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 ! run-id test-id
94c0: 20 74 65 73 74 73 74 65 70 2d 6e 61 6d 65 20 73 teststep-name s
94d0: 74 61 74 65 2d 69 6e 20 73 74 61 74 75 73 2d 69 tate-in status-i
94e0: 6e 20 63 6f 6d 6d 65 6e 74 20 6c 6f 67 66 69 6c n comment logfil
94f0: 65 29 0a 20 20 28 6c 65 74 2a 20 28 28 73 74 61 e). (let* ((sta
9500: 74 65 20 20 20 20 20 28 69 74 65 6d 73 3a 63 68 te (items:ch
9510: 65 63 6b 2d 76 61 6c 69 64 2d 69 74 65 6d 73 20 eck-valid-items
9520: 22 73 74 61 74 65 22 20 73 74 61 74 65 2d 69 6e "state" state-in
9530: 29 29 0a 09 20 28 73 74 61 74 75 73 20 20 20 20 )).. (status
9540: 28 69 74 65 6d 73 3a 63 68 65 63 6b 2d 76 61 6c (items:check-val
9550: 69 64 2d 69 74 65 6d 73 20 22 73 74 61 74 75 73 id-items "status
9560: 22 20 73 74 61 74 75 73 2d 69 6e 29 29 29 0a 20 " status-in))).
9570: 20 20 20 28 69 66 20 28 6f 72 20 28 6e 6f 74 20 (if (or (not
9580: 73 74 61 74 65 29 28 6e 6f 74 20 73 74 61 74 75 state)(not statu
9590: 73 29 29 0a 09 28 64 65 62 75 67 3a 70 72 69 6e s))..(debug:prin
95a0: 74 20 33 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 3 *default-log
95b0: 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a -port* "WARNING:
95c0: 20 49 6e 76 61 6c 69 64 20 22 20 28 69 66 20 73 Invalid " (if s
95d0: 74 61 74 75 73 20 22 73 74 61 74 75 73 22 20 22 tatus "status" "
95e0: 73 74 61 74 65 22 29 0a 09 09 20 20 20 20 20 22 state")... "
95f0: 20 76 61 6c 75 65 20 5c 22 22 20 28 69 66 20 73 value \"" (if s
9600: 74 61 74 75 73 20 73 74 61 74 65 2d 69 6e 20 73 tatus state-in s
9610: 74 61 74 75 73 2d 69 6e 29 20 22 5c 22 2c 20 75 tatus-in) "\", u
9620: 70 64 61 74 65 20 79 6f 75 72 20 76 61 6c 69 64 pdate your valid
9630: 76 61 6c 75 65 73 20 73 65 63 74 69 6f 6e 20 69 values section i
9640: 6e 20 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 n megatest.confi
9650: 67 22 29 29 0a 20 20 20 20 28 72 6d 74 3a 73 65 g")). (rmt:se
9660: 6e 64 2d 72 65 63 65 69 76 65 20 27 74 65 73 74 nd-receive 'test
9670: 73 74 65 70 2d 73 65 74 2d 73 74 61 74 75 73 21 step-set-status!
9680: 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 run-id (list ru
9690: 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 74 65 73 n-id test-id tes
96a0: 74 73 74 65 70 2d 6e 61 6d 65 20 73 74 61 74 65 tstep-name state
96b0: 2d 69 6e 20 73 74 61 74 75 73 2d 69 6e 20 63 6f -in status-in co
96c0: 6d 6d 65 6e 74 20 6c 6f 67 66 69 6c 65 29 29 29 mment logfile)))
96d0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a )..(define (rmt:
96e0: 67 65 74 2d 73 74 65 70 73 2d 66 6f 72 2d 74 65 get-steps-for-te
96f0: 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 st run-id test-i
9700: 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 d). (rmt:send-r
9710: 65 63 65 69 76 65 20 27 67 65 74 2d 73 74 65 70 eceive 'get-step
9720: 73 2d 66 6f 72 2d 74 65 73 74 20 72 75 6e 2d 69 s-for-test run-i
9730: 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 d (list run-id t
9740: 65 73 74 2d 69 64 29 29 29 0a 0a 3b 3b 3d 3d 3d est-id)))..;;===
9750: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9760: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9770: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9780: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9790: 3d 3d 3d 0a 3b 3b 20 20 54 20 45 20 53 20 54 20 ===.;; T E S T
97a0: 20 20 44 20 41 20 54 20 41 20 0a 3b 3b 3d 3d 3d D A T A .;;===
97b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
97c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
97d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
97e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
97f0: 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d ===..(define (rm
9800: 74 3a 72 65 61 64 2d 74 65 73 74 2d 64 61 74 61 t:read-test-data
9810: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 run-id test-id
9820: 63 61 74 65 67 6f 72 79 70 61 74 74 20 23 21 6b categorypatt #!k
9830: 65 79 20 28 77 6f 72 6b 2d 61 72 65 61 20 23 66 ey (work-area #f
9840: 29 29 20 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d )) . (rmt:send-
9850: 72 65 63 65 69 76 65 20 27 72 65 61 64 2d 74 65 receive 'read-te
9860: 73 74 2d 64 61 74 61 20 72 75 6e 2d 69 64 20 28 st-data run-id (
9870: 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 list run-id test
9880: 2d 69 64 20 63 61 74 65 67 6f 72 79 70 61 74 74 -id categorypatt
9890: 29 29 29 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))).(define (rmt
98a0: 3a 72 65 61 64 2d 74 65 73 74 2d 64 61 74 61 2a :read-test-data*
98b0: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 run-id test-id
98c0: 63 61 74 65 67 6f 72 79 70 61 74 74 20 76 61 72 categorypatt var
98d0: 70 61 74 74 20 23 21 6b 65 79 20 28 77 6f 72 6b patt #!key (work
98e0: 2d 61 72 65 61 20 23 66 29 29 20 0a 20 20 28 72 -area #f)) . (r
98f0: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
9900: 27 72 65 61 64 2d 74 65 73 74 2d 64 61 74 61 2a 'read-test-data*
9910: 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 run-id (list ru
9920: 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 63 61 74 n-id test-id cat
9930: 65 67 6f 72 79 70 61 74 74 20 76 61 72 70 61 74 egorypatt varpat
9940: 74 29 29 29 0a 0a 3b 3b 20 20 20 28 6c 65 74 20 t)))..;; (let
9950: 28 28 74 64 62 20 20 28 72 6d 74 3a 6f 70 65 6e ((tdb (rmt:open
9960: 2d 74 65 73 74 2d 64 62 2d 62 79 2d 74 65 73 74 -test-db-by-test
9970: 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d -id run-id test-
9980: 69 64 20 77 6f 72 6b 2d 61 72 65 61 3a 20 77 6f id work-area: wo
9990: 72 6b 2d 61 72 65 61 29 29 29 0a 3b 3b 20 20 20 rk-area))).;;
99a0: 20 20 28 69 66 20 74 64 62 0a 3b 3b 20 09 28 74 (if tdb.;; .(t
99b0: 64 62 3a 72 65 61 64 2d 74 65 73 74 2d 64 61 74 db:read-test-dat
99c0: 61 20 74 64 62 20 74 65 73 74 2d 69 64 20 63 61 a tdb test-id ca
99d0: 74 65 67 6f 72 79 70 61 74 74 29 0a 3b 3b 20 09 tegorypatt).;; .
99e0: 27 28 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 '())))..(define
99f0: 28 72 6d 74 3a 74 65 73 74 6d 65 74 61 2d 61 64 (rmt:testmeta-ad
9a00: 64 2d 72 65 63 6f 72 64 20 74 65 73 74 6e 61 6d d-record testnam
9a10: 65 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 e). (rmt:send-r
9a20: 65 63 65 69 76 65 20 27 74 65 73 74 6d 65 74 61 eceive 'testmeta
9a30: 2d 61 64 64 2d 72 65 63 6f 72 64 20 23 66 20 28 -add-record #f (
9a40: 6c 69 73 74 20 74 65 73 74 6e 61 6d 65 29 29 29 list testname)))
9a50: 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 ..(define (rmt:t
9a60: 65 73 74 6d 65 74 61 2d 67 65 74 2d 72 65 63 6f estmeta-get-reco
9a70: 72 64 20 74 65 73 74 6e 61 6d 65 29 0a 20 20 28 rd testname). (
9a80: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
9a90: 20 27 74 65 73 74 6d 65 74 61 2d 67 65 74 2d 72 'testmeta-get-r
9aa0: 65 63 6f 72 64 20 23 66 20 28 6c 69 73 74 20 74 ecord #f (list t
9ab0: 65 73 74 6e 61 6d 65 29 29 29 0a 0a 28 64 65 66 estname)))..(def
9ac0: 69 6e 65 20 28 72 6d 74 3a 74 65 73 74 6d 65 74 ine (rmt:testmet
9ad0: 61 2d 75 70 64 61 74 65 2d 66 69 65 6c 64 20 74 a-update-field t
9ae0: 65 73 74 2d 6e 61 6d 65 20 66 6c 64 20 76 61 6c est-name fld val
9af0: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
9b00: 63 65 69 76 65 20 27 74 65 73 74 6d 65 74 61 2d ceive 'testmeta-
9b10: 75 70 64 61 74 65 2d 66 69 65 6c 64 20 23 66 20 update-field #f
9b20: 28 6c 69 73 74 20 74 65 73 74 2d 6e 61 6d 65 20 (list test-name
9b30: 66 6c 64 20 76 61 6c 29 29 29 0a 0a 28 64 65 66 fld val)))..(def
9b40: 69 6e 65 20 28 72 6d 74 3a 74 65 73 74 2d 64 61 ine (rmt:test-da
9b50: 74 61 2d 72 6f 6c 6c 75 70 20 72 75 6e 2d 69 64 ta-rollup run-id
9b60: 20 74 65 73 74 2d 69 64 20 73 74 61 74 75 73 29 test-id status)
9b70: 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 . (rmt:send-rec
9b80: 65 69 76 65 20 27 74 65 73 74 2d 64 61 74 61 2d eive 'test-data-
9b90: 72 6f 6c 6c 75 70 20 72 75 6e 2d 69 64 20 28 6c rollup run-id (l
9ba0: 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d ist run-id test-
9bb0: 69 64 20 73 74 61 74 75 73 29 29 29 0a 0a 28 64 id status)))..(d
9bc0: 65 66 69 6e 65 20 28 72 6d 74 3a 63 73 76 2d 3e efine (rmt:csv->
9bd0: 74 65 73 74 2d 64 61 74 61 20 72 75 6e 2d 69 64 test-data run-id
9be0: 20 74 65 73 74 2d 69 64 20 63 73 76 64 61 74 61 test-id csvdata
9bf0: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
9c00: 63 65 69 76 65 20 27 63 73 76 2d 3e 74 65 73 74 ceive 'csv->test
9c10: 2d 64 61 74 61 20 72 75 6e 2d 69 64 20 28 6c 69 -data run-id (li
9c20: 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 st run-id test-i
9c30: 64 20 63 73 76 64 61 74 61 29 29 29 0a 0a 3b 3b d csvdata)))..;;
9c40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9c50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9c60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9c70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9c80: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 54 20 41 20 53 ======.;; T A S
9c90: 20 4b 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d K S.;;=========
9ca0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9cb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9cc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9cd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 =============..(
9ce0: 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 61 73 6b define (rmt:task
9cf0: 73 2d 66 69 6e 64 2d 74 61 73 6b 2d 71 75 65 75 s-find-task-queu
9d00: 65 2d 72 65 63 6f 72 64 73 20 74 61 72 67 65 74 e-records target
9d10: 20 72 75 6e 2d 6e 61 6d 65 20 74 65 73 74 2d 70 run-name test-p
9d20: 61 74 74 20 73 74 61 74 65 2d 70 61 74 74 20 61 att state-patt a
9d30: 63 74 69 6f 6e 2d 70 61 74 74 29 0a 20 20 28 72 ction-patt). (r
9d40: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
9d50: 27 66 69 6e 64 2d 74 61 73 6b 2d 71 75 65 75 65 'find-task-queue
9d60: 2d 72 65 63 6f 72 64 73 20 23 66 20 28 6c 69 73 -records #f (lis
9d70: 74 20 74 61 72 67 65 74 20 72 75 6e 2d 6e 61 6d t target run-nam
9d80: 65 20 74 65 73 74 2d 70 61 74 74 20 73 74 61 74 e test-patt stat
9d90: 65 2d 70 61 74 74 20 61 63 74 69 6f 6e 2d 70 61 e-patt action-pa
9da0: 74 74 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 tt)))..(define (
9db0: 72 6d 74 3a 74 61 73 6b 73 2d 61 64 64 20 61 63 rmt:tasks-add ac
9dc0: 74 69 6f 6e 20 6f 77 6e 65 72 20 74 61 72 67 65 tion owner targe
9dd0: 74 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 70 61 t runname testpa
9de0: 74 74 20 70 61 72 61 6d 73 29 0a 20 20 28 72 6d tt params). (rm
9df0: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
9e00: 74 61 73 6b 73 2d 61 64 64 20 23 66 20 28 6c 69 tasks-add #f (li
9e10: 73 74 20 61 63 74 69 6f 6e 20 6f 77 6e 65 72 20 st action owner
9e20: 74 61 72 67 65 74 20 72 75 6e 6e 61 6d 65 20 74 target runname t
9e30: 65 73 74 70 61 74 74 20 70 61 72 61 6d 73 29 29 estpatt params))
9e40: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a )..(define (rmt:
9e50: 74 61 73 6b 73 2d 73 65 74 2d 73 74 61 74 65 2d tasks-set-state-
9e60: 67 69 76 65 6e 2d 70 61 72 61 6d 2d 6b 65 79 20 given-param-key
9e70: 70 61 72 61 6d 2d 6b 65 79 20 6e 65 77 2d 73 74 param-key new-st
9e80: 61 74 65 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 ate). (rmt:send
9e90: 2d 72 65 63 65 69 76 65 20 27 74 61 73 6b 73 2d -receive 'tasks-
9ea0: 73 65 74 2d 73 74 61 74 65 2d 67 69 76 65 6e 2d set-state-given-
9eb0: 70 61 72 61 6d 2d 6b 65 79 20 23 66 20 28 6c 69 param-key #f (li
9ec0: 73 74 20 20 70 61 72 61 6d 2d 6b 65 79 20 6e 65 st param-key ne
9ed0: 77 2d 73 74 61 74 65 29 29 29 0a 0a 28 64 65 66 w-state)))..(def
9ee0: 69 6e 65 20 28 72 6d 74 3a 74 61 73 6b 73 2d 67 ine (rmt:tasks-g
9ef0: 65 74 2d 6c 61 73 74 20 74 61 72 67 65 74 20 72 et-last target r
9f00: 75 6e 6e 61 6d 65 29 0a 20 20 28 72 6d 74 3a 73 unname). (rmt:s
9f10: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 74 61 73 end-receive 'tas
9f20: 6b 73 2d 67 65 74 2d 6c 61 73 74 20 23 66 20 28 ks-get-last #f (
9f30: 6c 69 73 74 20 74 61 72 67 65 74 20 72 75 6e 6e list target runn
9f40: 61 6d 65 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d ame)))..;;======
9f50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9f60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9f70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9f80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9f90: 0a 3b 3b 20 41 20 52 20 43 20 48 20 49 20 56 20 .;; A R C H I V
9fa0: 45 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d E S.;;==========
9fb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9fc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9fd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9fe0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 ============..(d
9ff0: 65 66 69 6e 65 20 28 72 6d 74 3a 61 72 63 68 69 efine (rmt:archi
a000: 76 65 2d 67 65 74 2d 61 6c 6c 6f 63 61 74 69 6f ve-get-allocatio
a010: 6e 73 20 20 74 65 73 74 6e 61 6d 65 20 69 74 65 ns testname ite
a020: 6d 70 61 74 68 20 64 6e 65 65 64 65 64 29 0a 20 mpath dneeded).
a030: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
a040: 76 65 20 27 61 72 63 68 69 76 65 2d 67 65 74 2d ve 'archive-get-
a050: 61 6c 6c 6f 63 61 74 69 6f 6e 73 20 23 66 20 28 allocations #f (
a060: 6c 69 73 74 20 74 65 73 74 6e 61 6d 65 20 69 74 list testname it
a070: 65 6d 70 61 74 68 20 64 6e 65 65 64 65 64 29 29 empath dneeded))
a080: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a )..(define (rmt:
a090: 61 72 63 68 69 76 65 2d 72 65 67 69 73 74 65 72 archive-register
a0a0: 2d 62 6c 6f 63 6b 2d 6e 61 6d 65 20 62 64 69 73 -block-name bdis
a0b0: 6b 2d 69 64 20 61 72 63 68 69 76 65 2d 70 61 74 k-id archive-pat
a0c0: 68 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 h). (rmt:send-r
a0d0: 65 63 65 69 76 65 20 27 61 72 63 68 69 76 65 2d eceive 'archive-
a0e0: 72 65 67 69 73 74 65 72 2d 62 6c 6f 63 6b 2d 6e register-block-n
a0f0: 61 6d 65 20 23 66 20 28 6c 69 73 74 20 62 64 69 ame #f (list bdi
a100: 73 6b 2d 69 64 20 61 72 63 68 69 76 65 2d 70 61 sk-id archive-pa
a110: 74 68 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 th)))..(define (
a120: 72 6d 74 3a 61 72 63 68 69 76 65 2d 61 6c 6c 6f rmt:archive-allo
a130: 63 61 74 65 2d 74 65 73 74 73 75 69 74 65 2f 61 cate-testsuite/a
a140: 72 65 61 2d 74 6f 2d 62 6c 6f 63 6b 20 62 6c 6f rea-to-block blo
a150: 63 6b 2d 69 64 20 74 65 73 74 73 75 69 74 65 2d ck-id testsuite-
a160: 6e 61 6d 65 20 61 72 65 61 6b 65 79 29 0a 20 20 name areakey).
a170: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
a180: 65 20 27 61 72 63 68 69 76 65 2d 61 6c 6c 6f 63 e 'archive-alloc
a190: 61 74 65 2d 74 65 73 74 2d 74 6f 2d 62 6c 6f 63 ate-test-to-bloc
a1a0: 6b 20 23 66 20 28 6c 69 73 74 20 20 62 6c 6f 63 k #f (list bloc
a1b0: 6b 2d 69 64 20 74 65 73 74 73 75 69 74 65 2d 6e k-id testsuite-n
a1c0: 61 6d 65 20 61 72 65 61 6b 65 79 29 29 29 0a 0a ame areakey)))..
a1d0: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 61 72 63 (define (rmt:arc
a1e0: 68 69 76 65 2d 72 65 67 69 73 74 65 72 2d 64 69 hive-register-di
a1f0: 73 6b 20 62 64 69 73 6b 2d 6e 61 6d 65 20 62 64 sk bdisk-name bd
a200: 69 73 6b 2d 70 61 74 68 20 64 66 29 0a 20 20 28 isk-path df). (
a210: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
a220: 20 27 61 72 63 68 69 76 65 2d 72 65 67 69 73 74 'archive-regist
a230: 65 72 2d 64 69 73 6b 20 23 66 20 28 6c 69 73 74 er-disk #f (list
a240: 20 62 64 69 73 6b 2d 6e 61 6d 65 20 62 64 69 73 bdisk-name bdis
a250: 6b 2d 70 61 74 68 20 64 66 29 29 29 0a 0a 28 64 k-path df)))..(d
a260: 65 66 69 6e 65 20 28 72 6d 74 3a 74 65 73 74 2d efine (rmt:test-
a270: 73 65 74 2d 61 72 63 68 69 76 65 2d 62 6c 6f 63 set-archive-bloc
a280: 6b 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 k-id run-id test
a290: 2d 69 64 20 61 72 63 68 69 76 65 2d 62 6c 6f 63 -id archive-bloc
a2a0: 6b 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e k-id). (rmt:sen
a2b0: 64 2d 72 65 63 65 69 76 65 20 27 74 65 73 74 2d d-receive 'test-
a2c0: 73 65 74 2d 61 72 63 68 69 76 65 2d 62 6c 6f 63 set-archive-bloc
a2d0: 6b 2d 69 64 20 72 75 6e 2d 69 64 20 28 6c 69 73 k-id run-id (lis
a2e0: 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 t run-id test-id
a2f0: 20 61 72 63 68 69 76 65 2d 62 6c 6f 63 6b 2d 69 archive-block-i
a300: 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 d)))..(define (r
a310: 6d 74 3a 74 65 73 74 2d 67 65 74 2d 61 72 63 68 mt:test-get-arch
a320: 69 76 65 2d 62 6c 6f 63 6b 2d 69 6e 66 6f 20 61 ive-block-info a
a330: 72 63 68 69 76 65 2d 62 6c 6f 63 6b 2d 69 64 29 rchive-block-id)
a340: 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 . (rmt:send-rec
a350: 65 69 76 65 20 27 74 65 73 74 2d 67 65 74 2d 61 eive 'test-get-a
a360: 72 63 68 69 76 65 2d 62 6c 6f 63 6b 2d 69 6e 66 rchive-block-inf
a370: 6f 20 23 66 20 28 6c 69 73 74 20 61 72 63 68 69 o #f (list archi
a380: 76 65 2d 62 6c 6f 63 6b 2d 69 64 29 29 29 0a ve-block-id))).