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 54 68 69 73 20 66 69 ..;; .;; This fi
0080: 6c 65 20 69 73 20 70 61 72 74 20 6f 66 20 4d 65 le is part of Me
0090: 67 61 74 65 73 74 2e 0a 3b 3b 20 0a 3b 3b 20 20 gatest..;; .;;
00a0: 20 20 20 4d 65 67 61 74 65 73 74 20 69 73 20 66 Megatest is f
00b0: 72 65 65 20 73 6f 66 74 77 61 72 65 3a 20 79 6f ree software: yo
00c0: 75 20 63 61 6e 20 72 65 64 69 73 74 72 69 62 75 u can redistribu
00d0: 74 65 20 69 74 20 61 6e 64 2f 6f 72 20 6d 6f 64 te it and/or mod
00e0: 69 66 79 0a 3b 3b 20 20 20 20 20 69 74 20 75 6e ify.;; it un
00f0: 64 65 72 20 74 68 65 20 74 65 72 6d 73 20 6f 66 der the terms of
0100: 20 74 68 65 20 47 4e 55 20 47 65 6e 65 72 61 6c the GNU General
0110: 20 50 75 62 6c 69 63 20 4c 69 63 65 6e 73 65 20 Public License
0120: 61 73 20 70 75 62 6c 69 73 68 65 64 20 62 79 0a as published by.
0130: 3b 3b 20 20 20 20 20 74 68 65 20 46 72 65 65 20 ;; the Free
0140: 53 6f 66 74 77 61 72 65 20 46 6f 75 6e 64 61 74 Software Foundat
0150: 69 6f 6e 2c 20 65 69 74 68 65 72 20 76 65 72 73 ion, either vers
0160: 69 6f 6e 20 33 20 6f 66 20 74 68 65 20 4c 69 63 ion 3 of the Lic
0170: 65 6e 73 65 2c 20 6f 72 0a 3b 3b 20 20 20 20 20 ense, or.;;
0180: 28 61 74 20 79 6f 75 72 20 6f 70 74 69 6f 6e 29 (at your option)
0190: 20 61 6e 79 20 6c 61 74 65 72 20 76 65 72 73 69 any later versi
01a0: 6f 6e 2e 0a 3b 3b 20 0a 3b 3b 20 20 20 20 20 4d on..;; .;; M
01b0: 65 67 61 74 65 73 74 20 69 73 20 64 69 73 74 72 egatest is distr
01c0: 69 62 75 74 65 64 20 69 6e 20 74 68 65 20 68 6f ibuted in the ho
01d0: 70 65 20 74 68 61 74 20 69 74 20 77 69 6c 6c 20 pe that it will
01e0: 62 65 20 75 73 65 66 75 6c 2c 0a 3b 3b 20 20 20 be useful,.;;
01f0: 20 20 62 75 74 20 57 49 54 48 4f 55 54 20 41 4e but WITHOUT AN
0200: 59 20 57 41 52 52 41 4e 54 59 3b 20 77 69 74 68 Y WARRANTY; with
0210: 6f 75 74 20 65 76 65 6e 20 74 68 65 20 69 6d 70 out even the imp
0220: 6c 69 65 64 20 77 61 72 72 61 6e 74 79 20 6f 66 lied warranty of
0230: 0a 3b 3b 20 20 20 20 20 4d 45 52 43 48 41 4e 54 .;; MERCHANT
0240: 41 42 49 4c 49 54 59 20 6f 72 20 46 49 54 4e 45 ABILITY or FITNE
0250: 53 53 20 46 4f 52 20 41 20 50 41 52 54 49 43 55 SS FOR A PARTICU
0260: 4c 41 52 20 50 55 52 50 4f 53 45 2e 20 20 53 65 LAR PURPOSE. Se
0270: 65 20 74 68 65 0a 3b 3b 20 20 20 20 20 47 4e 55 e the.;; GNU
0280: 20 47 65 6e 65 72 61 6c 20 50 75 62 6c 69 63 20 General Public
0290: 4c 69 63 65 6e 73 65 20 66 6f 72 20 6d 6f 72 65 License for more
02a0: 20 64 65 74 61 69 6c 73 2e 0a 3b 3b 20 0a 3b 3b details..;; .;;
02b0: 20 20 20 20 20 59 6f 75 20 73 68 6f 75 6c 64 20 You should
02c0: 68 61 76 65 20 72 65 63 65 69 76 65 64 20 61 20 have received a
02d0: 63 6f 70 79 20 6f 66 20 74 68 65 20 47 4e 55 20 copy of the GNU
02e0: 47 65 6e 65 72 61 6c 20 50 75 62 6c 69 63 20 4c General Public L
02f0: 69 63 65 6e 73 65 0a 3b 3b 20 20 20 20 20 61 6c icense.;; al
0300: 6f 6e 67 20 77 69 74 68 20 4d 65 67 61 74 65 73 ong with Megates
0310: 74 2e 20 20 49 66 20 6e 6f 74 2c 20 73 65 65 20 t. If not, see
0320: 3c 68 74 74 70 3a 2f 2f 77 77 77 2e 67 6e 75 2e <http://www.gnu.
0330: 6f 72 67 2f 6c 69 63 65 6e 73 65 73 2f 3e 2e 0a org/licenses/>..
0340: 3b 3b 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;.;;===========
0350: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0360: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0370: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0380: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 75 73 ===========..(us
0390: 65 20 66 6f 72 6d 61 74 20 74 79 70 65 64 2d 72 e format typed-r
03a0: 65 63 6f 72 64 73 29 20 3b 3b 20 52 41 44 54 20 ecords) ;; RADT
03b0: 3d 3e 20 70 75 72 70 6f 73 65 20 6f 66 20 6a 73 => purpose of js
03c0: 6f 6e 20 66 6f 72 6d 61 74 3f 3f 0a 0a 28 64 65 on format??..(de
03d0: 63 6c 61 72 65 20 28 75 6e 69 74 20 72 6d 74 29 clare (unit rmt)
03e0: 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 ).(declare (uses
03f0: 20 61 70 69 29 29 0a 28 64 65 63 6c 61 72 65 20 api)).(declare
0400: 28 75 73 65 73 20 68 74 74 70 2d 74 72 61 6e 73 (uses http-trans
0410: 70 6f 72 74 29 29 0a 0a 28 64 65 63 6c 61 72 65 port))..(declare
0420: 20 28 75 73 65 73 20 63 6f 6d 6d 6f 6e 6d 6f 64 (uses commonmod
0430: 29 29 0a 28 69 6d 70 6f 72 74 20 63 6f 6d 6d 6f )).(import commo
0440: 6e 6d 6f 64 29 0a 0a 28 64 65 63 6c 61 72 65 20 nmod)..(declare
0450: 28 75 73 65 73 20 61 70 69 6d 6f 64 29 29 0a 28 (uses apimod)).(
0460: 69 6d 70 6f 72 74 20 61 70 69 6d 6f 64 29 0a 0a import apimod)..
0470: 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 72 (declare (uses r
0480: 6d 74 6d 6f 64 29 29 0a 28 69 6d 70 6f 72 74 20 mtmod)).(import
0490: 72 6d 74 6d 6f 64 29 0a 0a 3b 3b 20 73 68 6f 75 rmtmod)..;; shou
04a0: 6c 64 20 6e 6f 74 20 62 65 20 68 65 72 65 0a 28 ld not be here.(
04b0: 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 64 62 declare (uses db
04c0: 6d 6f 64 29 29 0a 28 69 6d 70 6f 72 74 20 64 62 mod)).(import db
04d0: 6d 6f 64 29 0a 0a 28 64 65 63 6c 61 72 65 20 28 mod)..(declare (
04e0: 75 73 65 73 20 63 6f 6e 66 69 67 66 6d 6f 64 29 uses configfmod)
04f0: 29 0a 28 69 6d 70 6f 72 74 20 63 6f 6e 66 69 67 ).(import config
0500: 66 6d 6f 64 29 0a 0a 28 64 65 63 6c 61 72 65 20 fmod)..(declare
0510: 28 75 73 65 73 20 73 65 72 76 65 72 6d 6f 64 29 (uses servermod)
0520: 29 0a 28 69 6d 70 6f 72 74 20 73 65 72 76 65 72 ).(import server
0530: 6d 6f 64 29 0a 0a 28 69 6e 63 6c 75 64 65 20 22 mod)..(include "
0540: 63 6f 6d 6d 6f 6e 5f 72 65 63 6f 72 64 73 2e 73 common_records.s
0550: 63 6d 22 29 0a 3b 3b 20 28 64 65 63 6c 61 72 65 cm").;; (declare
0560: 20 28 75 73 65 73 20 72 6d 74 6d 6f 64 29 29 0a (uses rmtmod)).
0570: 0a 3b 3b 20 28 69 6d 70 6f 72 74 20 72 6d 74 6d .;; (import rmtm
0580: 6f 64 29 0a 0a 3b 3b 0a 3b 3b 20 54 48 45 53 45 od)..;;.;; THESE
0590: 20 41 52 45 20 41 4c 4c 20 43 41 4c 4c 45 44 20 ARE ALL CALLED
05a0: 4f 4e 20 54 48 45 20 43 4c 49 45 4e 54 20 53 49 ON THE CLIENT SI
05b0: 44 45 21 21 21 0a 3b 3b 0a 0a 3b 3b 20 67 65 6e DE!!!.;;..;; gen
05c0: 65 72 61 74 65 20 65 6e 74 72 69 65 73 20 66 6f erate entries fo
05d0: 72 20 7e 2f 2e 6d 65 67 61 74 65 73 74 72 63 20 r ~/.megatestrc
05e0: 77 69 74 68 20 74 68 65 20 66 6f 6c 6c 6f 77 69 with the followi
05f0: 6e 67 0a 3b 3b 0a 3b 3b 20 20 67 72 65 70 20 64 ng.;;.;; grep d
0600: 65 66 69 6e 65 20 2e 2e 2f 72 6d 74 2e 73 63 6d efine ../rmt.scm
0610: 20 7c 20 67 72 65 70 20 72 6d 74 3a 20 7c 70 65 | grep rmt: |pe
0620: 72 6c 20 2d 70 69 20 2d 65 20 27 73 2f 5c 28 64 rl -pi -e 's/\(d
0630: 65 66 69 6e 65 5c 73 2b 5c 28 28 5c 53 2b 29 5c efine\s+\((\S+)\
0640: 57 2e 2a 24 2f 5c 31 2f 27 7c 73 6f 72 74 20 2d W.*$/\1/'|sort -
0650: 75 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d u..;;===========
0660: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0670: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0680: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0690: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 ===========.;;
06a0: 53 20 55 20 50 20 50 20 4f 20 52 20 54 20 20 20 S U P P O R T
06b0: 46 20 55 20 4e 20 43 20 54 20 49 20 4f 20 4e 20 F U N C T I O N
06c0: 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d S.;;============
06d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
06e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
06f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0700: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 69 ==========..;; i
0710: 66 20 61 20 73 65 72 76 65 72 20 69 73 20 65 69 f a server is ei
0720: 74 68 65 72 20 72 75 6e 6e 69 6e 67 20 6f 72 20 ther running or
0730: 69 6e 20 74 68 65 20 70 72 6f 63 65 73 73 20 6f in the process o
0740: 66 20 73 74 61 72 74 69 6e 67 20 63 61 6c 6c 20 f starting call
0750: 63 6c 69 65 6e 74 3a 73 65 74 75 70 0a 3b 3b 20 client:setup.;;
0760: 65 6c 73 65 20 72 65 74 75 72 6e 20 23 66 20 74 else return #f t
0770: 6f 20 6c 65 74 20 74 68 65 20 63 61 6c 6c 69 6e o let the callin
0780: 67 20 70 72 6f 63 20 6b 6e 6f 77 20 74 68 61 74 g proc know that
0790: 20 74 68 65 72 65 20 69 73 20 6e 6f 20 73 65 72 there is no ser
07a0: 76 65 72 20 61 76 61 69 6c 61 62 6c 65 0a 3b 3b ver available.;;
07b0: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 .(define (rmt:ge
07c0: 74 2d 63 6f 6e 6e 65 63 74 69 6f 6e 2d 69 6e 66 t-connection-inf
07d0: 6f 20 61 72 65 61 70 61 74 68 20 23 21 6b 65 79 o areapath #!key
07e0: 20 28 61 72 65 61 2d 64 61 74 20 23 66 29 29 20 (area-dat #f))
07f0: 3b 3b 20 54 4f 44 4f 3a 20 70 75 73 68 20 61 72 ;; TODO: push ar
0800: 65 61 70 61 74 68 20 64 6f 77 6e 2e 0a 20 20 28 eapath down.. (
0810: 6c 65 74 2a 20 28 28 72 75 6e 72 65 6d 6f 74 65 let* ((runremote
0820: 20 28 6f 72 20 61 72 65 61 2d 64 61 74 20 2a 72 (or area-dat *r
0830: 75 6e 72 65 6d 6f 74 65 2a 29 29 0a 09 20 28 63 unremote*)).. (c
0840: 69 6e 66 6f 20 20 20 20 20 28 69 66 20 28 72 65 info (if (re
0850: 6d 6f 74 65 3f 20 72 75 6e 72 65 6d 6f 74 65 29 mote? runremote)
0860: 0a 09 09 09 28 72 65 6d 6f 74 65 2d 63 6f 6e 6e ....(remote-conn
0870: 64 61 74 20 72 75 6e 72 65 6d 6f 74 65 29 0a 09 dat runremote)..
0880: 09 09 23 66 29 29 29 0a 09 20 20 28 69 66 20 63 ..#f))).. (if c
0890: 69 6e 66 6f 0a 09 20 20 20 20 20 20 63 69 6e 66 info.. cinf
08a0: 6f 0a 09 20 20 20 20 20 20 28 69 66 20 28 73 65 o.. (if (se
08b0: 72 76 65 72 3a 63 68 65 63 6b 2d 69 66 2d 72 75 rver:check-if-ru
08c0: 6e 6e 69 6e 67 20 61 72 65 61 70 61 74 68 29 0a nning areapath).
08d0: 09 09 20 20 28 63 6c 69 65 6e 74 3a 73 65 74 75 .. (client:setu
08e0: 70 20 61 72 65 61 70 61 74 68 29 0a 09 09 20 20 p areapath)...
08f0: 23 66 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d #f))))..;;======
0900: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0910: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0920: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0930: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0940: 0a 0a 28 64 65 66 69 6e 65 20 28 63 72 65 61 74 ..(define (creat
0950: 65 2d 72 65 6d 6f 74 65 2d 72 65 63 6f 72 64 29 e-remote-record)
0960: 0a 20 20 28 6c 65 74 20 28 28 72 72 20 28 6d 61 . (let ((rr (ma
0970: 6b 65 2d 72 65 6d 6f 74 65 29 29 29 0a 20 20 20 ke-remote))).
0980: 20 28 72 6d 74 3a 69 6e 69 74 2d 72 65 6d 6f 74 (rmt:init-remot
0990: 65 20 72 72 29 0a 20 20 20 20 72 72 29 29 0a 0a e rr). rr))..
09a0: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 69 6e 69 (define (rmt:ini
09b0: 74 2d 72 65 6d 6f 74 65 20 72 72 29 0a 20 20 28 t-remote rr). (
09c0: 72 65 6d 6f 74 65 2d 68 68 2d 64 61 74 2d 73 65 remote-hh-dat-se
09d0: 74 21 20 20 20 20 20 20 20 20 20 72 72 20 28 63 t! rr (c
09e0: 6f 6d 6d 6f 6e 3a 67 65 74 2d 68 6f 6d 65 68 6f ommon:get-homeho
09f0: 73 74 29 29 20 3b 0a 20 20 28 72 65 6d 6f 74 65 st)) ;. (remote
0a00: 2d 73 65 72 76 65 72 2d 69 6e 66 6f 2d 73 65 74 -server-info-set
0a10: 21 20 20 20 20 72 72 20 28 69 66 20 2a 74 6f 70 ! rr (if *top
0a20: 70 61 74 68 2a 20 28 73 65 72 76 65 72 3a 63 68 path* (server:ch
0a30: 65 63 6b 2d 69 66 2d 72 75 6e 6e 69 6e 67 20 2a eck-if-running *
0a40: 74 6f 70 70 61 74 68 2a 29 20 23 66 29 29 0a 20 toppath*) #f)).
0a50: 20 28 72 65 6d 6f 74 65 2d 74 72 61 6e 73 70 6f (remote-transpo
0a60: 72 74 2d 73 65 74 21 20 20 20 20 20 20 72 72 20 rt-set! rr
0a70: 2a 74 72 61 6e 73 70 6f 72 74 2d 74 79 70 65 2a *transport-type*
0a80: 29 0a 20 20 28 72 65 6d 6f 74 65 2d 73 65 72 76 ). (remote-serv
0a90: 65 72 2d 74 69 6d 65 6f 75 74 2d 73 65 74 21 20 er-timeout-set!
0aa0: 72 72 20 28 73 65 72 76 65 72 3a 65 78 70 69 72 rr (server:expir
0ab0: 61 74 69 6f 6e 2d 74 69 6d 65 6f 75 74 29 29 0a ation-timeout)).
0ac0: 20 20 72 72 29 0a 20 20 0a 3b 3b 20 52 41 20 3d rr). .;; RA =
0ad0: 3e 20 65 2e 67 2e 20 75 73 61 67 65 20 28 72 6d > e.g. usage (rm
0ae0: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
0af0: 67 65 74 2d 76 61 72 20 23 66 20 28 6c 69 73 74 get-var #f (list
0b00: 20 76 61 72 6e 61 6d 65 29 29 0a 3b 3b 0a 28 64 varname)).;;.(d
0b10: 65 66 69 6e 65 20 28 72 6d 74 3a 73 65 6e 64 2d efine (rmt:send-
0b20: 72 65 63 65 69 76 65 20 63 6d 64 20 72 69 64 20 receive cmd rid
0b30: 70 61 72 61 6d 73 20 23 21 6b 65 79 20 28 61 74 params #!key (at
0b40: 74 65 6d 70 74 6e 75 6d 20 31 29 28 61 72 65 61 temptnum 1)(area
0b50: 2d 64 61 74 20 23 66 29 29 20 3b 3b 20 73 74 61 -dat #f)) ;; sta
0b60: 72 74 20 61 74 74 65 6d 70 74 6e 75 6d 20 61 74 rt attemptnum at
0b70: 20 31 20 73 6f 20 74 68 65 20 6d 6f 64 75 6c 6f 1 so the modulo
0b80: 20 62 65 6c 6f 77 20 77 6f 72 6b 73 20 61 73 20 below works as
0b90: 65 78 70 65 63 74 65 64 0a 0a 20 20 23 3b 28 63 expected.. #;(c
0ba0: 6f 6d 6d 6f 6e 3a 74 65 6c 65 6d 65 74 72 79 2d ommon:telemetry-
0bb0: 6c 6f 67 20 28 63 6f 6e 63 20 22 72 6d 74 3a 22 log (conc "rmt:"
0bc0: 28 2d 3e 73 74 72 69 6e 67 20 63 6d 64 29 29 0a (->string cmd)).
0bd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0be0: 20 20 20 20 20 20 20 20 70 61 79 6c 6f 61 64 3a payload:
0bf0: 20 60 28 28 72 69 64 20 2e 20 2c 72 69 64 29 0a `((rid . ,rid).
0c00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0c10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0c20: 20 20 20 28 70 61 72 61 6d 73 20 2e 20 2c 70 61 (params . ,pa
0c30: 72 61 6d 73 29 29 29 0a 20 20 20 20 20 20 20 20 rams))).
0c40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0c50: 20 20 0a 20 20 28 69 66 20 28 3e 20 61 74 74 65 . (if (> atte
0c60: 6d 70 74 6e 75 6d 20 32 29 0a 20 20 20 20 20 20 mptnum 2).
0c70: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
0c80: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
0c90: 2a 20 22 49 4e 46 4f 3a 20 61 74 74 65 6d 70 74 * "INFO: attempt
0ca0: 6e 75 6d 20 69 6e 20 72 6d 74 3a 73 65 6e 64 2d num in rmt:send-
0cb0: 72 65 63 65 69 76 65 20 69 73 20 22 20 61 74 74 receive is " att
0cc0: 65 6d 70 74 6e 75 6d 29 29 0a 20 20 20 20 0a 20 emptnum)). .
0cd0: 20 28 63 6f 6e 64 0a 20 20 20 28 28 3e 20 61 74 (cond. ((> at
0ce0: 74 65 6d 70 74 6e 75 6d 20 32 29 20 28 74 68 72 temptnum 2) (thr
0cf0: 65 61 64 2d 73 6c 65 65 70 21 20 30 2e 30 35 29 ead-sleep! 0.05)
0d00: 29 0a 20 20 20 28 28 3e 20 61 74 74 65 6d 70 74 ). ((> attempt
0d10: 6e 75 6d 20 31 30 29 20 28 74 68 72 65 61 64 2d num 10) (thread-
0d20: 73 6c 65 65 70 21 20 30 2e 35 29 29 0a 20 20 20 sleep! 0.5)).
0d30: 28 28 3e 20 61 74 74 65 6d 70 74 6e 75 6d 20 32 ((> attemptnum 2
0d40: 30 29 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 0) (thread-sleep
0d50: 21 20 31 29 29 29 0a 20 20 28 69 66 20 28 61 6e ! 1))). (if (an
0d60: 64 20 28 3e 20 61 74 74 65 6d 70 74 6e 75 6d 20 d (> attemptnum
0d70: 35 29 20 28 3d 20 30 20 28 6d 6f 64 75 6c 6f 20 5) (= 0 (modulo
0d80: 61 74 74 65 6d 70 74 6e 75 6d 20 31 35 29 29 29 attemptnum 15)))
0d90: 20 20 0a 20 20 20 20 28 62 65 67 69 6e 20 28 73 . (begin (s
0da0: 65 72 76 65 72 3a 72 75 6e 20 2a 74 6f 70 70 61 erver:run *toppa
0db0: 74 68 2a 29 20 28 74 68 72 65 61 64 2d 73 6c 65 th*) (thread-sle
0dc0: 65 70 21 20 33 29 29 29 20 0a 20 20 0a 20 20 0a ep! 3))) . . .
0dd0: 20 20 3b 3b 44 4f 54 20 64 69 67 72 61 70 68 20 ;;DOT digraph
0de0: 6d 65 67 61 74 65 73 74 5f 73 74 61 74 65 5f 73 megatest_state_s
0df0: 74 61 74 75 73 20 7b 0a 20 20 3b 3b 44 4f 54 20 tatus {. ;;DOT
0e00: 20 20 72 61 6e 6b 73 65 70 3d 30 3b 0a 20 20 3b ranksep=0;. ;
0e10: 3b 44 4f 54 20 20 20 2f 2f 20 72 61 6e 6b 64 69 ;DOT // rankdi
0e20: 72 3d 4c 52 3b 0a 20 20 3b 3b 44 4f 54 20 20 20 r=LR;. ;;DOT
0e30: 6e 6f 64 65 20 5b 73 68 61 70 65 3d 22 62 6f 78 node [shape="box
0e40: 22 5d 3b 0a 20 20 3b 3b 44 4f 54 20 22 72 6d 74 "];. ;;DOT "rmt
0e50: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 22 20 2d :send-receive" -
0e60: 3e 20 4d 55 54 45 58 4c 4f 43 4b 3b 0a 20 20 3b > MUTEXLOCK;. ;
0e70: 3b 44 4f 54 20 7b 20 65 64 67 65 20 5b 73 74 79 ;DOT { edge [sty
0e80: 6c 65 3d 69 6e 76 69 73 5d 3b 22 63 61 73 65 20 le=invis];"case
0e90: 31 22 20 2d 3e 20 22 63 61 73 65 20 32 22 20 2d 1" -> "case 2" -
0ea0: 3e 20 22 63 61 73 65 20 33 22 20 2d 3e 20 22 63 > "case 3" -> "c
0eb0: 61 73 65 20 34 22 20 2d 3e 20 22 63 61 73 65 20 ase 4" -> "case
0ec0: 35 22 20 2d 3e 20 22 63 61 73 65 20 36 22 20 2d 5" -> "case 6" -
0ed0: 3e 20 22 63 61 73 65 20 37 22 20 2d 3e 20 22 63 > "case 7" -> "c
0ee0: 61 73 65 20 38 22 20 2d 3e 20 22 63 61 73 65 20 ase 8" -> "case
0ef0: 39 22 20 2d 3e 20 22 63 61 73 65 20 31 30 22 20 9" -> "case 10"
0f00: 2d 3e 20 22 63 61 73 65 20 31 31 22 3b 20 7d 0a -> "case 11"; }.
0f10: 20 20 3b 3b 20 64 6f 20 61 6c 6c 20 74 68 65 20 ;; do all the
0f20: 70 72 65 70 20 6c 6f 63 6b 65 64 20 75 6e 64 65 prep locked unde
0f30: 72 20 74 68 65 20 72 6d 74 2d 6d 75 74 65 78 0a r the rmt-mutex.
0f40: 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a (mutex-lock! *
0f50: 72 6d 74 2d 6d 75 74 65 78 2a 29 0a 0a 20 20 3b rmt-mutex*).. ;
0f60: 3b 20 73 65 74 20 75 70 20 72 75 6e 72 65 6d 6f ; set up runremo
0f70: 74 65 20 72 65 63 6f 72 64 20 65 61 72 6c 69 65 te record earlie
0f80: 72 20 74 68 61 6e 20 74 68 65 20 6c 6f 6f 70 20 r than the loop
0f90: 62 65 6c 6f 77 0a 20 20 28 69 66 20 28 6e 6f 74 below. (if (not
0fa0: 20 61 72 65 61 2d 64 61 74 29 20 20 20 20 20 20 area-dat)
0fb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ;;
0fc0: 63 61 6e 20 72 65 6d 6f 76 65 20 74 68 69 73 20 can remove this
0fd0: 6f 6e 65 2e 20 73 68 6f 75 6c 64 20 6e 65 76 65 one. should neve
0fe0: 72 20 67 65 74 20 68 65 72 65 2e 20 20 20 20 20 r get here.
0ff0: 20 20 20 20 0a 20 20 20 20 20 20 28 62 65 67 69 . (begi
1000: 6e 0a 09 28 73 65 74 21 20 2a 72 75 6e 72 65 6d n..(set! *runrem
1010: 6f 74 65 2a 20 28 63 72 65 61 74 65 2d 72 65 6d ote* (create-rem
1020: 6f 74 65 2d 72 65 63 6f 72 64 29 29 0a 09 28 6c ote-record))..(l
1030: 65 74 2a 20 28 28 73 65 72 76 65 72 2d 69 6e 66 et* ((server-inf
1040: 6f 20 28 72 65 6d 6f 74 65 2d 73 65 72 76 65 72 o (remote-server
1050: 2d 69 6e 66 6f 20 2a 72 75 6e 72 65 6d 6f 74 65 -info *runremote
1060: 2a 29 29 29 20 0a 09 20 20 28 69 66 20 73 65 72 *))) .. (if ser
1070: 76 65 72 2d 69 6e 66 6f 0a 09 20 20 20 20 20 20 ver-info..
1080: 28 62 65 67 69 6e 0a 09 09 28 72 65 6d 6f 74 65 (begin...(remote
1090: 2d 73 65 72 76 65 72 2d 75 72 6c 2d 73 65 74 21 -server-url-set!
10a0: 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 28 73 65 *runremote* (se
10b0: 72 76 65 72 3a 72 65 63 6f 72 64 2d 3e 75 72 6c rver:record->url
10c0: 20 73 65 72 76 65 72 2d 69 6e 66 6f 29 29 0a 09 server-info))..
10d0: 09 28 72 65 6d 6f 74 65 2d 73 65 72 76 65 72 2d .(remote-server-
10e0: 69 64 2d 73 65 74 21 20 2a 72 75 6e 72 65 6d 6f id-set! *runremo
10f0: 74 65 2a 20 28 73 65 72 76 65 72 3a 72 65 63 6f te* (server:reco
1100: 72 64 2d 3e 69 64 20 73 65 72 76 65 72 2d 69 6e rd->id server-in
1110: 66 6f 29 29 29 29 29 20 20 0a 09 28 73 65 74 21 fo))))) ..(set!
1120: 20 61 72 65 61 2d 64 61 74 20 2a 72 75 6e 72 65 area-dat *runre
1130: 6d 6f 74 65 2a 29 29 29 20 3b 3b 20 6e 65 77 20 mote*))) ;; new
1140: 72 75 6e 72 65 6d 6f 74 65 20 77 69 6c 6c 20 63 runremote will c
1150: 6f 6d 65 20 66 72 6f 6d 20 74 68 69 73 20 6f 6e ome from this on
1160: 20 6e 65 78 74 20 69 74 65 72 61 74 69 6f 6e 0a next iteration.
1170: 20 20 20 20 0a 20 20 3b 3b 20 31 2e 20 63 68 65 . ;; 1. che
1180: 63 6b 20 69 66 20 73 65 72 76 65 72 20 69 73 20 ck if server is
1190: 73 74 61 72 74 65 64 20 49 46 46 20 63 6d 64 20 started IFF cmd
11a0: 69 73 20 61 20 77 72 69 74 65 20 4f 52 20 69 66 is a write OR if
11b0: 20 77 65 20 61 72 65 20 6e 6f 74 20 6f 6e 20 74 we are not on t
11c0: 68 65 20 68 6f 6d 65 68 6f 73 74 2c 20 73 74 6f he homehost, sto
11d0: 72 65 20 69 6e 20 72 75 6e 72 65 6d 6f 74 65 0a re in runremote.
11e0: 20 20 3b 3b 20 32 2e 20 63 68 65 63 6b 20 74 68 ;; 2. check th
11f0: 65 20 61 67 65 20 6f 66 20 74 68 65 20 63 6f 6e e age of the con
1200: 6e 65 63 74 69 6f 6e 73 2e 20 72 65 66 72 65 73 nections. refres
1210: 68 20 74 68 65 20 63 6f 6e 6e 65 63 74 69 6f 6e h the connection
1220: 20 69 66 20 69 74 20 69 73 20 6f 6c 64 65 72 20 if it is older
1230: 74 68 61 6e 20 74 69 6d 65 6f 75 74 2d 32 30 20 than timeout-20
1240: 73 65 63 6f 6e 64 73 2e 0a 20 20 3b 3b 20 33 2e seconds.. ;; 3.
1250: 20 64 6f 20 74 68 65 20 71 75 65 72 79 2c 20 69 do the query, i
1260: 66 20 6f 6e 20 68 6f 6d 65 68 6f 73 74 20 75 73 f on homehost us
1270: 65 20 6c 6f 63 61 6c 20 61 63 63 65 73 73 0a 20 e local access.
1280: 20 3b 3b 0a 20 20 28 6c 65 74 2a 20 28 28 73 74 ;;. (let* ((st
1290: 61 72 74 2d 74 69 6d 65 20 20 20 20 28 63 75 72 art-time (cur
12a0: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 20 3b rent-seconds)) ;
12b0: 3b 20 73 6e 61 70 73 68 6f 74 20 74 69 6d 65 20 ; snapshot time
12c0: 73 6f 20 61 6c 6c 20 75 73 65 20 63 61 73 65 73 so all use cases
12d0: 20 67 65 74 20 73 61 6d 65 20 76 61 6c 75 65 0a get same value.
12e0: 20 20 20 20 20 20 20 20 20 28 61 72 65 61 70 61 (areapa
12f0: 74 68 20 20 20 20 20 20 2a 74 6f 70 70 61 74 68 th *toppath
1300: 2a 29 3b 3b 20 54 4f 44 4f 20 2d 20 72 65 73 6f *);; TODO - reso
1310: 6c 76 65 20 66 72 6f 6d 20 64 62 73 74 72 75 63 lve from dbstruc
1320: 74 20 74 6f 20 62 65 20 63 6f 6d 70 61 74 69 62 t to be compatib
1330: 6c 65 20 77 69 74 68 20 6d 75 6c 74 69 70 6c 65 le with multiple
1340: 20 61 72 65 61 73 0a 09 20 28 72 75 6e 72 65 6d areas.. (runrem
1350: 6f 74 65 20 20 20 20 20 28 6f 72 20 61 72 65 61 ote (or area
1360: 2d 64 61 74 0a 09 09 09 20 20 20 20 2a 72 75 6e -dat.... *run
1370: 72 65 6d 6f 74 65 2a 29 29 0a 20 20 20 20 20 20 remote*)).
1380: 20 20 20 28 61 74 74 65 6d 70 74 6e 75 6d 20 20 (attemptnum
1390: 20 20 28 2b 20 31 20 61 74 74 65 6d 70 74 6e 75 (+ 1 attemptnu
13a0: 6d 29 29 0a 09 20 28 72 65 61 64 6f 6e 6c 79 2d m)).. (readonly-
13b0: 6d 6f 64 65 20 28 72 6d 74 6d 6f 64 3a 63 61 6c mode (rmtmod:cal
13c0: 63 2d 72 6f 2d 6d 6f 64 65 20 72 75 6e 72 65 6d c-ro-mode runrem
13d0: 6f 74 65 20 2a 74 6f 70 70 61 74 68 2a 29 29 29 ote *toppath*)))
13e0: 0a 0a 20 20 20 20 3b 3b 20 44 4f 54 20 49 4e 49 .. ;; DOT INI
13f0: 54 5f 52 55 4e 52 45 4d 4f 54 45 3b 20 2f 2f 20 T_RUNREMOTE; //
1400: 6c 65 61 76 69 6e 67 20 6f 66 66 20 2d 20 64 6f leaving off - do
1410: 65 73 6e 27 74 20 72 65 61 6c 6c 79 20 61 64 64 esn't really add
1420: 20 74 6f 20 74 68 65 20 63 6c 61 72 69 74 79 0a to the clarity.
1430: 20 20 20 20 3b 3b 20 44 4f 54 20 4d 55 54 45 58 ;; DOT MUTEX
1440: 4c 4f 43 4b 20 2d 3e 20 49 4e 49 54 5f 52 55 4e LOCK -> INIT_RUN
1450: 52 45 4d 4f 54 45 20 5b 6c 61 62 65 6c 3d 22 6e REMOTE [label="n
1460: 6f 20 72 65 6d 6f 74 65 3f 22 5d 3b 0a 20 20 20 o remote?"];.
1470: 20 3b 3b 20 44 4f 54 20 49 4e 49 54 5f 52 55 4e ;; DOT INIT_RUN
1480: 52 45 4d 4f 54 45 20 2d 3e 20 4d 55 54 45 58 4c REMOTE -> MUTEXL
1490: 4f 43 4b 3b 0a 20 20 20 20 3b 3b 20 65 6e 73 75 OCK;. ;; ensu
14a0: 72 65 20 77 65 20 68 61 76 65 20 61 20 72 65 63 re we have a rec
14b0: 6f 72 64 20 66 6f 72 20 6f 75 72 20 63 6f 6e 6e ord for our conn
14c0: 65 63 74 69 6f 6e 20 66 6f 72 20 67 69 76 65 6e ection for given
14d0: 20 61 72 65 61 0a 20 20 20 20 3b 3b 20 44 4f 54 area. ;; DOT
14e0: 20 53 45 54 5f 48 4f 4d 45 48 4f 53 54 3b 20 2f SET_HOMEHOST; /
14f0: 2f 20 6c 65 61 76 69 6e 67 20 6f 66 66 20 2d 20 / leaving off -
1500: 64 6f 65 73 6e 27 74 20 72 65 61 6c 6c 79 20 61 doesn't really a
1510: 64 64 20 74 6f 20 74 68 65 20 63 6c 61 72 69 74 dd to the clarit
1520: 79 0a 20 20 20 20 3b 3b 20 44 4f 54 20 4d 55 54 y. ;; DOT MUT
1530: 45 58 4c 4f 43 4b 20 2d 3e 20 53 45 54 5f 48 4f EXLOCK -> SET_HO
1540: 4d 45 48 4f 53 54 20 5b 6c 61 62 65 6c 3d 22 6e MEHOST [label="n
1550: 6f 20 68 6f 6d 65 68 6f 73 74 3f 22 5d 3b 0a 20 o homehost?"];.
1560: 20 20 20 3b 3b 20 44 4f 54 20 53 45 54 5f 48 4f ;; DOT SET_HO
1570: 4d 45 48 4f 53 54 20 2d 3e 20 4d 55 54 45 58 4c MEHOST -> MUTEXL
1580: 4f 43 4b 3b 0a 20 20 20 20 3b 3b 20 65 6e 73 75 OCK;. ;; ensu
1590: 72 65 20 77 65 20 68 61 76 65 20 61 20 68 6f 6d re we have a hom
15a0: 65 68 6f 73 74 20 72 65 63 6f 72 64 0a 20 20 20 ehost record.
15b0: 20 28 69 66 20 28 6e 6f 74 20 28 70 61 69 72 3f (if (not (pair?
15c0: 20 28 72 65 6d 6f 74 65 2d 68 68 2d 64 61 74 20 (remote-hh-dat
15d0: 72 75 6e 72 65 6d 6f 74 65 29 29 29 20 20 3b 3b runremote))) ;;
15e0: 20 6e 6f 74 20 6f 6e 20 68 6f 6d 65 68 6f 73 74 not on homehost
15f0: 0a 09 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 ..(thread-sleep!
1600: 20 30 2e 31 29 20 3b 3b 20 73 69 6e 63 65 20 77 0.1) ;; since w
1610: 65 20 73 68 6f 75 6c 64 6e 27 74 20 67 65 74 20 e shouldn't get
1620: 68 65 72 65 2c 20 64 65 6c 61 79 20 61 20 6c 69 here, delay a li
1630: 74 74 6c 65 0a 09 28 72 65 6d 6f 74 65 2d 68 68 ttle..(remote-hh
1640: 2d 64 61 74 2d 73 65 74 21 20 72 75 6e 72 65 6d -dat-set! runrem
1650: 6f 74 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d ote (common:get-
1660: 68 6f 6d 65 68 6f 73 74 29 29 29 0a 20 20 20 20 homehost))).
1670: 0a 20 20 20 20 3b 3b 28 70 72 69 6e 74 20 22 42 . ;;(print "B
1680: 42 3e 20 72 65 61 64 6f 6e 6c 79 2d 6d 6f 64 65 B> readonly-mode
1690: 20 69 73 20 22 72 65 61 64 6f 6e 6c 79 2d 6d 6f is "readonly-mo
16a0: 64 65 22 20 64 62 66 69 6c 65 20 69 73 20 22 64 de" dbfile is "d
16b0: 62 66 69 6c 65 29 0a 20 20 20 20 28 63 6f 6e 64 bfile). (cond
16c0: 0a 20 20 20 20 20 3b 3b 44 4f 54 20 45 58 49 54 . ;;DOT EXIT
16d0: 3b 0a 20 20 20 20 20 3b 3b 44 4f 54 20 4d 55 54 ;. ;;DOT MUT
16e0: 45 58 4c 4f 43 4b 20 2d 3e 20 45 58 49 54 20 5b EXLOCK -> EXIT [
16f0: 6c 61 62 65 6c 3d 22 3e 20 31 35 20 61 74 74 65 label="> 15 atte
1700: 6d 70 74 73 22 5d 3b 20 7b 72 61 6e 6b 3d 73 61 mpts"]; {rank=sa
1710: 6d 65 20 22 63 61 73 65 20 31 22 20 22 45 58 49 me "case 1" "EXI
1720: 54 22 20 7d 0a 20 20 20 20 20 3b 3b 20 67 69 76 T" }. ;; giv
1730: 65 20 75 70 20 69 66 20 6d 6f 72 65 20 74 68 61 e up if more tha
1740: 6e 20 31 35 30 20 61 74 74 65 6d 70 74 73 0a 20 n 150 attempts.
1750: 20 20 20 20 28 28 3e 20 61 74 74 65 6d 70 74 6e ((> attemptn
1760: 75 6d 20 31 35 30 29 0a 20 20 20 20 20 20 28 64 um 150). (d
1770: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
1780: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
1790: 22 45 52 52 4f 52 3a 20 31 35 30 20 74 72 69 65 "ERROR: 150 trie
17a0: 73 20 74 6f 20 73 74 61 72 74 2f 63 6f 6e 6e 65 s to start/conne
17b0: 63 74 20 74 6f 20 73 65 72 76 65 72 2e 20 47 69 ct to server. Gi
17c0: 76 69 6e 67 20 75 70 2e 22 29 0a 20 20 20 20 20 ving up.").
17d0: 20 28 65 78 69 74 20 31 29 29 0a 0a 20 20 20 20 (exit 1))..
17e0: 20 3b 3b 44 4f 54 20 43 41 53 45 32 20 5b 6c 61 ;;DOT CASE2 [la
17f0: 62 65 6c 3d 22 6c 6f 63 61 6c 5c 6e 72 65 61 64 bel="local\nread
1800: 6f 6e 6c 79 5c 6e 71 75 65 72 79 22 5d 3b 0a 20 only\nquery"];.
1810: 20 20 20 20 3b 3b 44 4f 54 20 4d 55 54 45 58 4c ;;DOT MUTEXL
1820: 4f 43 4b 20 2d 3e 20 43 41 53 45 32 3b 20 7b 72 OCK -> CASE2; {r
1830: 61 6e 6b 3d 73 61 6d 65 20 22 63 61 73 65 20 32 ank=same "case 2
1840: 22 20 43 41 53 45 32 7d 0a 20 20 20 20 20 3b 3b " CASE2}. ;;
1850: 44 4f 54 20 43 41 53 45 32 20 2d 3e 20 22 72 6d DOT CASE2 -> "rm
1860: 74 3a 6f 70 65 6e 2d 71 72 79 2d 63 6c 6f 73 65 t:open-qry-close
1870: 2d 6c 6f 63 61 6c 6c 79 22 3b 0a 20 20 20 20 20 -locally";.
1880: 3b 3b 20 72 65 61 64 6f 6e 6c 79 20 6d 6f 64 65 ;; readonly mode
1890: 2c 20 72 65 61 64 20 72 65 71 75 65 73 74 2d 20 , read request-
18a0: 20 68 61 6e 64 6c 65 20 69 74 20 2d 20 63 61 73 handle it - cas
18b0: 65 20 32 0a 20 20 20 20 20 28 28 61 6e 64 20 72 e 2. ((and r
18c0: 65 61 64 6f 6e 6c 79 2d 6d 6f 64 65 0a 20 20 20 eadonly-mode.
18d0: 20 20 20 20 20 20 20 20 28 6d 65 6d 62 65 72 20 (member
18e0: 63 6d 64 20 61 70 69 3a 72 65 61 64 2d 6f 6e 6c cmd api:read-onl
18f0: 79 2d 71 75 65 72 69 65 73 29 29 20 0a 20 20 20 y-queries)) .
1900: 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b (mutex-unlock
1910: 21 20 2a 72 6d 74 2d 6d 75 74 65 78 2a 29 0a 20 ! *rmt-mutex*).
1920: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
1930: 74 2d 69 6e 66 6f 20 31 32 20 2a 64 65 66 61 75 t-info 12 *defau
1940: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 6d lt-log-port* "rm
1950: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 2c 20 t:send-receive,
1960: 63 61 73 65 20 32 22 29 0a 20 20 20 20 20 20 28 case 2"). (
1970: 72 6d 74 3a 6f 70 65 6e 2d 71 72 79 2d 63 6c 6f rmt:open-qry-clo
1980: 73 65 2d 6c 6f 63 61 6c 6c 79 20 63 6d 64 20 30 se-locally cmd 0
1990: 20 70 61 72 61 6d 73 29 0a 20 20 20 20 20 20 29 params). )
19a0: 0a 0a 20 20 20 20 20 3b 3b 44 4f 54 20 43 41 53 .. ;;DOT CAS
19b0: 45 33 20 5b 6c 61 62 65 6c 3d 22 77 72 69 74 65 E3 [label="write
19c0: 20 69 6e 5c 6e 72 65 61 64 2d 6f 6e 6c 79 20 6d in\nread-only m
19d0: 6f 64 65 22 5d 3b 0a 20 20 20 20 20 3b 3b 44 4f ode"];. ;;DO
19e0: 54 20 4d 55 54 45 58 4c 4f 43 4b 20 2d 3e 20 43 T MUTEXLOCK -> C
19f0: 41 53 45 33 20 5b 6c 61 62 65 6c 3d 22 72 65 61 ASE3 [label="rea
1a00: 64 6f 6e 6c 79 5c 6e 6d 6f 64 65 3f 22 5d 3b 20 donly\nmode?"];
1a10: 7b 72 61 6e 6b 3d 73 61 6d 65 20 22 63 61 73 65 {rank=same "case
1a20: 20 33 22 20 43 41 53 45 33 7d 0a 20 20 20 20 20 3" CASE3}.
1a30: 3b 3b 44 4f 54 20 43 41 53 45 33 20 2d 3e 20 22 ;;DOT CASE3 -> "
1a40: 23 66 22 3b 0a 20 20 20 20 20 3b 3b 20 72 65 61 #f";. ;; rea
1a50: 64 6f 6e 6c 79 20 6d 6f 64 65 2c 20 77 72 69 74 donly mode, writ
1a60: 65 20 72 65 71 75 65 73 74 2e 20 20 44 6f 20 6e e request. Do n
1a70: 6f 74 68 69 6e 67 2c 20 72 65 74 75 72 6e 20 23 othing, return #
1a80: 66 0a 20 20 20 20 20 28 72 65 61 64 6f 6e 6c 79 f. (readonly
1a90: 2d 6d 6f 64 65 20 28 65 78 74 72 61 73 2d 72 65 -mode (extras-re
1aa0: 61 64 6f 6e 6c 79 2d 6d 6f 64 65 20 2a 72 6d 74 adonly-mode *rmt
1ab0: 2d 6d 75 74 65 78 2a 20 2a 64 65 66 61 75 6c 74 -mutex* *default
1ac0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 63 6d 64 20 70 -log-port* cmd p
1ad0: 61 72 61 6d 73 29 29 0a 0a 20 20 20 20 20 3b 3b arams)).. ;;
1ae0: 20 54 68 69 73 20 62 6c 6f 63 6b 20 77 61 73 20 This block was
1af0: 66 6f 72 20 70 72 65 2d 65 6d 70 74 69 76 65 6c for pre-emptivel
1b00: 79 20 72 65 73 65 74 74 69 6e 67 20 74 68 65 20 y resetting the
1b10: 63 6f 6e 6e 65 63 74 69 6f 6e 20 69 66 20 74 68 connection if th
1b20: 65 72 65 20 68 61 64 20 62 65 65 6e 20 6e 6f 20 ere had been no
1b30: 63 6f 6d 6d 75 6e 69 63 61 74 69 6f 6e 20 66 6f communication fo
1b40: 72 20 73 6f 6d 65 20 74 69 6d 65 2e 0a 20 20 20 r some time..
1b50: 20 20 3b 3b 20 49 20 64 6f 6e 27 74 20 74 68 69 ;; I don't thi
1b60: 6e 6b 20 69 74 20 61 64 64 73 20 61 6e 79 20 76 nk it adds any v
1b70: 61 6c 75 65 2e 20 49 66 20 74 68 65 20 73 65 72 alue. If the ser
1b80: 76 65 72 20 69 73 20 6e 6f 74 20 74 68 65 72 65 ver is not there
1b90: 2c 20 6a 75 73 74 20 66 61 69 6c 20 61 6e 64 20 , just fail and
1ba0: 73 74 61 72 74 20 61 20 6e 65 77 20 63 6f 6e 6e start a new conn
1bb0: 65 63 74 69 6f 6e 2e 0a 20 20 20 20 20 3b 3b 20 ection.. ;;
1bc0: 61 6c 73 6f 2c 20 74 68 65 20 65 78 70 69 72 65 also, the expire
1bd0: 2d 74 69 6d 65 20 63 61 6c 63 75 6c 61 74 69 6f -time calculatio
1be0: 6e 20 6d 69 67 68 74 20 6e 6f 74 20 62 65 20 63 n might not be c
1bf0: 6f 72 72 65 63 74 2e 20 57 65 20 77 61 6e 74 2c orrect. We want,
1c00: 20 74 69 6d 65 2d 73 69 6e 63 65 2d 6c 61 73 74 time-since-last
1c10: 2d 73 65 72 76 65 72 2d 61 63 63 65 73 73 20 3e -server-access >
1c20: 20 28 73 65 72 76 65 72 3a 67 65 74 2d 74 69 6d (server:get-tim
1c30: 65 6f 75 74 29 0a 20 20 20 20 20 3b 3b 0a 20 20 eout). ;;.
1c40: 20 20 20 3b 3b 44 4f 54 20 43 41 53 45 34 20 5b ;;DOT CASE4 [
1c50: 6c 61 62 65 6c 3d 22 72 65 73 65 74 5c 6e 63 6f label="reset\nco
1c60: 6e 6e 65 63 74 69 6f 6e 22 5d 3b 0a 20 20 20 20 nnection"];.
1c70: 20 3b 3b 44 4f 54 20 4d 55 54 45 58 4c 4f 43 4b ;;DOT MUTEXLOCK
1c80: 20 2d 3e 20 43 41 53 45 34 20 5b 6c 61 62 65 6c -> CASE4 [label
1c90: 3d 22 68 61 76 65 20 63 6f 6e 6e 65 63 74 69 6f ="have connectio
1ca0: 6e 2c 5c 6e 6c 61 73 74 5f 61 63 63 65 73 73 20 n,\nlast_access
1cb0: 3e 20 65 78 70 69 72 65 5f 74 69 6d 65 22 5d 3b > expire_time"];
1cc0: 20 7b 72 61 6e 6b 3d 73 61 6d 65 20 22 63 61 73 {rank=same "cas
1cd0: 65 20 34 22 20 43 41 53 45 34 7d 0a 20 20 20 20 e 4" CASE4}.
1ce0: 20 3b 3b 44 4f 54 20 43 41 53 45 34 20 2d 3e 20 ;;DOT CASE4 ->
1cf0: 22 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 "rmt:send-receiv
1d00: 65 22 3b 0a 20 20 20 20 20 3b 3b 20 72 65 73 65 e";. ;; rese
1d10: 74 20 74 68 65 20 63 6f 6e 6e 65 63 74 69 6f 6e t the connection
1d20: 20 69 66 20 69 74 20 68 61 73 20 62 65 65 6e 20 if it has been
1d30: 75 6e 75 73 65 64 20 74 6f 6f 20 6c 6f 6e 67 0a unused too long.
1d40: 20 20 20 20 20 28 28 61 6e 64 20 72 75 6e 72 65 ((and runre
1d50: 6d 6f 74 65 0a 20 20 20 20 20 20 20 20 20 20 20 mote.
1d60: 28 72 65 6d 6f 74 65 2d 63 6f 6e 6e 64 61 74 20 (remote-conndat
1d70: 72 75 6e 72 65 6d 6f 74 65 29 0a 09 20 20 20 28 runremote).. (
1d80: 3e 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e > (current-secon
1d90: 64 73 29 20 3b 3b 20 69 66 20 69 74 20 68 61 73 ds) ;; if it has
1da0: 20 62 65 65 6e 20 6d 6f 72 65 20 74 68 61 6e 20 been more than
1db0: 73 65 72 76 65 72 2d 74 69 6d 65 6f 75 74 20 73 server-timeout s
1dc0: 65 63 6f 6e 64 73 20 73 69 6e 63 65 20 6c 61 73 econds since las
1dd0: 74 20 63 6f 6e 74 61 63 74 2c 20 63 6c 6f 73 65 t contact, close
1de0: 20 74 68 69 73 20 63 6f 6e 6e 65 63 74 69 6f 6e this connection
1df0: 20 61 6e 64 20 73 74 61 72 74 20 61 20 6e 65 77 and start a new
1e00: 20 6f 6e 0a 09 20 20 20 20 20 20 28 2b 20 28 68 on.. (+ (h
1e10: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 ttp-transport:se
1e20: 72 76 65 72 2d 64 61 74 2d 67 65 74 2d 6c 61 73 rver-dat-get-las
1e30: 74 2d 61 63 63 65 73 73 20 28 72 65 6d 6f 74 65 t-access (remote
1e40: 2d 63 6f 6e 6e 64 61 74 20 72 75 6e 72 65 6d 6f -conndat runremo
1e50: 74 65 29 29 0a 09 09 20 28 72 65 6d 6f 74 65 2d te))... (remote-
1e60: 73 65 72 76 65 72 2d 74 69 6d 65 6f 75 74 20 72 server-timeout r
1e70: 75 6e 72 65 6d 6f 74 65 29 29 29 29 0a 20 20 20 unremote)))).
1e80: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
1e90: 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d info 0 *default-
1ea0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 43 6f 6e 6e 65 log-port* "Conne
1eb0: 63 74 69 6f 6e 20 74 6f 20 22 20 28 72 65 6d 6f ction to " (remo
1ec0: 74 65 2d 73 65 72 76 65 72 2d 75 72 6c 20 72 75 te-server-url ru
1ed0: 6e 72 65 6d 6f 74 65 29 20 22 20 65 78 70 69 72 nremote) " expir
1ee0: 65 64 20 64 75 65 20 74 6f 20 6e 6f 20 61 63 63 ed due to no acc
1ef0: 65 73 73 65 73 2c 20 66 6f 72 63 69 6e 67 20 6e esses, forcing n
1f00: 65 77 20 63 6f 6e 6e 65 63 74 69 6f 6e 2e 22 29 ew connection.")
1f10: 0a 20 20 20 20 20 20 28 68 74 74 70 2d 74 72 61 . (http-tra
1f20: 6e 73 70 6f 72 74 3a 63 6c 6f 73 65 2d 63 6f 6e nsport:close-con
1f30: 6e 65 63 74 69 6f 6e 73 20 61 72 65 61 2d 64 61 nections area-da
1f40: 74 3a 20 72 75 6e 72 65 6d 6f 74 65 29 0a 20 20 t: runremote).
1f50: 20 20 20 20 28 72 65 6d 6f 74 65 2d 63 6f 6e 6e (remote-conn
1f60: 64 61 74 2d 73 65 74 21 20 72 75 6e 72 65 6d 6f dat-set! runremo
1f70: 74 65 20 23 66 29 20 3b 3b 20 69 6e 76 61 6c 69 te #f) ;; invali
1f80: 64 61 74 65 20 74 68 65 20 63 6f 6e 6e 65 63 74 date the connect
1f90: 69 6f 6e 2c 20 74 68 75 73 20 66 6f 72 63 69 6e ion, thus forcin
1fa0: 67 20 61 20 6e 65 77 20 63 6f 6e 6e 65 63 74 69 g a new connecti
1fb0: 6f 6e 2e 0a 20 20 20 20 20 20 28 6d 75 74 65 78 on.. (mutex
1fc0: 2d 75 6e 6c 6f 63 6b 21 20 2a 72 6d 74 2d 6d 75 -unlock! *rmt-mu
1fd0: 74 65 78 2a 29 0a 20 20 20 20 20 20 28 72 6d 74 tex*). (rmt
1fe0: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 63 6d :send-receive cm
1ff0: 64 20 72 69 64 20 70 61 72 61 6d 73 20 61 74 74 d rid params att
2000: 65 6d 70 74 6e 75 6d 3a 20 61 74 74 65 6d 70 74 emptnum: attempt
2010: 6e 75 6d 29 29 0a 20 20 20 20 20 0a 20 20 20 20 num)). .
2020: 20 3b 3b 44 4f 54 20 43 41 53 45 35 20 5b 6c 61 ;;DOT CASE5 [la
2030: 62 65 6c 3d 22 6c 6f 63 61 6c 5c 6e 72 65 61 64 bel="local\nread
2040: 22 5d 3b 0a 20 20 20 20 20 3b 3b 44 4f 54 20 4d "];. ;;DOT M
2050: 55 54 45 58 4c 4f 43 4b 20 2d 3e 20 43 41 53 45 UTEXLOCK -> CASE
2060: 35 20 5b 6c 61 62 65 6c 3d 22 73 65 72 76 65 72 5 [label="server
2070: 20 6e 6f 74 20 72 65 71 75 69 72 65 64 2c 5c 6e not required,\n
2080: 6f 6e 20 68 6f 6d 65 68 6f 73 74 2c 5c 6e 72 65 on homehost,\nre
2090: 61 64 2d 6f 6e 6c 79 20 71 75 65 72 79 22 5d 3b ad-only query"];
20a0: 20 7b 72 61 6e 6b 3d 73 61 6d 65 20 22 63 61 73 {rank=same "cas
20b0: 65 20 35 22 20 43 41 53 45 35 7d 3b 0a 20 20 20 e 5" CASE5};.
20c0: 20 20 3b 3b 44 4f 54 20 43 41 53 45 35 20 2d 3e ;;DOT CASE5 ->
20d0: 20 22 72 6d 74 3a 6f 70 65 6e 2d 71 72 79 2d 63 "rmt:open-qry-c
20e0: 6c 6f 73 65 2d 6c 6f 63 61 6c 6c 79 22 3b 0a 0a lose-locally";..
20f0: 20 20 20 20 20 3b 3b 20 6f 6e 20 68 6f 6d 65 68 ;; on homeh
2100: 6f 73 74 20 61 6e 64 20 74 68 69 73 20 69 73 20 ost and this is
2110: 61 20 72 65 61 64 0a 20 20 20 20 20 28 28 61 6e a read. ((an
2120: 64 20 28 6e 6f 74 20 28 72 65 6d 6f 74 65 2d 66 d (not (remote-f
2130: 6f 72 63 65 2d 73 65 72 76 65 72 20 72 75 6e 72 orce-server runr
2140: 65 6d 6f 74 65 29 29 20 3b 3b 20 68 6f 6e 6f 72 emote)) ;; honor
2150: 20 66 6f 72 63 65 64 20 75 73 65 20 6f 66 20 73 forced use of s
2160: 65 72 76 65 72 2c 20 69 2e 65 2e 20 73 65 72 76 erver, i.e. serv
2170: 65 72 20 4e 4f 54 20 72 65 71 75 69 72 65 64 0a er NOT required.
2180: 09 20 20 20 28 63 64 72 20 28 72 65 6d 6f 74 65 . (cdr (remote
2190: 2d 68 68 2d 64 61 74 20 72 75 6e 72 65 6d 6f 74 -hh-dat runremot
21a0: 65 29 29 20 20 20 20 20 20 20 3b 3b 20 6f 6e 20 e)) ;; on
21b0: 68 6f 6d 65 68 6f 73 74 0a 20 20 20 20 20 20 20 homehost.
21c0: 20 20 20 20 28 6d 65 6d 62 65 72 20 63 6d 64 20 (member cmd
21d0: 61 70 69 3a 72 65 61 64 2d 6f 6e 6c 79 2d 71 75 api:read-only-qu
21e0: 65 72 69 65 73 29 29 20 20 20 3b 3b 20 74 68 69 eries)) ;; thi
21f0: 73 20 69 73 20 61 20 72 65 61 64 0a 20 20 20 20 s is a read.
2200: 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 (mutex-unlock!
2210: 20 2a 72 6d 74 2d 6d 75 74 65 78 2a 29 0a 20 20 *rmt-mutex*).
2220: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
2230: 2d 69 6e 66 6f 20 31 32 20 2a 64 65 66 61 75 6c -info 12 *defaul
2240: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 6d 74 t-log-port* "rmt
2250: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 2c 20 63 :send-receive, c
2260: 61 73 65 20 20 35 22 29 0a 20 20 20 20 20 20 28 ase 5"). (
2270: 72 6d 74 3a 6f 70 65 6e 2d 71 72 79 2d 63 6c 6f rmt:open-qry-clo
2280: 73 65 2d 6c 6f 63 61 6c 6c 79 20 63 6d 64 20 30 se-locally cmd 0
2290: 20 70 61 72 61 6d 73 29 29 0a 0a 20 20 20 20 20 params))..
22a0: 3b 3b 44 4f 54 20 43 41 53 45 36 20 5b 6c 61 62 ;;DOT CASE6 [lab
22b0: 65 6c 3d 22 69 6e 69 74 5c 6e 72 65 6d 6f 74 65 el="init\nremote
22c0: 22 5d 3b 0a 20 20 20 20 20 3b 3b 44 4f 54 20 4d "];. ;;DOT M
22d0: 55 54 45 58 4c 4f 43 4b 20 2d 3e 20 43 41 53 45 UTEXLOCK -> CASE
22e0: 36 20 5b 6c 61 62 65 6c 3d 22 6f 6e 20 68 6f 6d 6 [label="on hom
22f0: 65 68 6f 73 74 2c 5c 6e 77 72 69 74 65 20 71 75 ehost,\nwrite qu
2300: 65 72 79 2c 5c 6e 68 61 76 65 20 73 65 72 76 65 ery,\nhave serve
2310: 72 2c 5c 6e 63 61 6e 27 74 20 72 65 61 63 68 20 r,\ncan't reach
2320: 69 74 22 5d 3b 20 7b 72 61 6e 6b 3d 73 61 6d 65 it"]; {rank=same
2330: 20 22 63 61 73 65 20 36 22 20 43 41 53 45 36 7d "case 6" CASE6}
2340: 3b 0a 20 20 20 20 20 3b 3b 44 4f 54 20 43 41 53 ;. ;;DOT CAS
2350: 45 36 20 2d 3e 20 22 72 6d 74 3a 73 65 6e 64 2d E6 -> "rmt:send-
2360: 72 65 63 65 69 76 65 22 3b 0a 20 20 20 20 20 3b receive";. ;
2370: 3b 20 6f 6e 20 68 6f 6d 65 68 6f 73 74 20 61 6e ; on homehost an
2380: 64 20 74 68 69 73 20 69 73 20 61 20 77 72 69 74 d this is a writ
2390: 65 2c 20 77 65 20 61 6c 72 65 61 64 79 20 68 61 e, we already ha
23a0: 76 65 20 61 20 73 65 72 76 65 72 2c 20 62 75 74 ve a server, but
23b0: 20 73 65 72 76 65 72 20 68 61 73 20 64 69 65 64 server has died
23c0: 0a 20 20 20 20 20 28 28 61 6e 64 20 28 63 64 72 . ((and (cdr
23d0: 20 28 72 65 6d 6f 74 65 2d 68 68 2d 64 61 74 20 (remote-hh-dat
23e0: 72 75 6e 72 65 6d 6f 74 65 29 29 20 20 20 20 20 runremote))
23f0: 20 20 20 20 20 20 3b 3b 20 6f 6e 20 68 6f 6d 65 ;; on home
2400: 68 6f 73 74 0a 20 20 20 20 20 20 20 20 20 20 20 host.
2410: 28 6e 6f 74 20 28 6d 65 6d 62 65 72 20 63 6d 64 (not (member cmd
2420: 20 61 70 69 3a 72 65 61 64 2d 6f 6e 6c 79 2d 71 api:read-only-q
2430: 75 65 72 69 65 73 29 29 20 20 3b 3b 20 74 68 69 ueries)) ;; thi
2440: 73 20 69 73 20 61 20 77 72 69 74 65 0a 20 20 20 s is a write.
2450: 20 20 20 20 20 20 20 20 28 72 65 6d 6f 74 65 2d (remote-
2460: 73 65 72 76 65 72 2d 75 72 6c 20 72 75 6e 72 65 server-url runre
2470: 6d 6f 74 65 29 20 20 20 20 20 20 20 20 20 20 20 mote)
2480: 20 20 3b 3b 20 68 61 76 65 20 61 20 73 65 72 76 ;; have a serv
2490: 65 72 0a 20 20 20 20 20 20 20 20 20 20 20 28 6e er. (n
24a0: 6f 74 20 28 73 65 72 76 65 72 3a 70 69 6e 67 20 ot (server:ping
24b0: 28 72 65 6d 6f 74 65 2d 73 65 72 76 65 72 2d 75 (remote-server-u
24c0: 72 6c 20 72 75 6e 72 65 6d 6f 74 65 29 20 28 72 rl runremote) (r
24d0: 65 6d 6f 74 65 2d 73 65 72 76 65 72 2d 69 64 20 emote-server-id
24e0: 72 75 6e 72 65 6d 6f 74 65 29 29 29 29 20 20 3b runremote)))) ;
24f0: 3b 20 73 65 72 76 65 72 20 68 61 73 20 64 69 65 ; server has die
2500: 64 2e 20 4e 4f 54 45 3a 20 74 68 69 73 20 69 73 d. NOTE: this is
2510: 20 6e 6f 74 20 61 20 63 68 65 61 70 20 63 61 6c not a cheap cal
2520: 6c 21 20 4e 65 65 64 20 62 65 74 74 65 72 20 61 l! Need better a
2530: 70 70 72 6f 61 63 68 2e 0a 20 20 20 20 20 20 28 pproach.. (
2540: 73 65 74 21 20 2a 72 75 6e 72 65 6d 6f 74 65 2a set! *runremote*
2550: 20 28 63 72 65 61 74 65 2d 72 65 6d 6f 74 65 2d (create-remote-
2560: 72 65 63 6f 72 64 29 29 20 0a 20 20 20 20 20 20 record)) .
2570: 28 6c 65 74 2a 20 28 28 73 65 72 76 65 72 2d 69 (let* ((server-i
2580: 6e 66 6f 20 28 72 65 6d 6f 74 65 2d 73 65 72 76 nfo (remote-serv
2590: 65 72 2d 69 6e 66 6f 20 2a 72 75 6e 72 65 6d 6f er-info *runremo
25a0: 74 65 2a 29 29 29 20 0a 20 20 20 20 20 20 20 20 te*))) .
25b0: 20 20 20 20 28 69 66 20 73 65 72 76 65 72 2d 69 (if server-i
25c0: 6e 66 6f 0a 09 09 28 62 65 67 69 6e 0a 09 09 20 nfo...(begin...
25d0: 20 28 72 65 6d 6f 74 65 2d 73 65 72 76 65 72 2d (remote-server-
25e0: 75 72 6c 2d 73 65 74 21 20 2a 72 75 6e 72 65 6d url-set! *runrem
25f0: 6f 74 65 2a 20 28 73 65 72 76 65 72 3a 72 65 63 ote* (server:rec
2600: 6f 72 64 2d 3e 75 72 6c 20 73 65 72 76 65 72 2d ord->url server-
2610: 69 6e 66 6f 29 29 0a 20 20 20 20 20 20 20 20 20 info)).
2620: 20 20 20 20 20 20 20 20 20 28 72 65 6d 6f 74 65 (remote
2630: 2d 73 65 72 76 65 72 2d 69 64 2d 73 65 74 21 20 -server-id-set!
2640: 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 28 73 65 72 *runremote* (ser
2650: 76 65 72 3a 72 65 63 6f 72 64 2d 3e 69 64 20 73 ver:record->id s
2660: 65 72 76 65 72 2d 69 6e 66 6f 29 29 29 29 29 0a erver-info))))).
2670: 20 20 20 20 20 20 28 72 65 6d 6f 74 65 2d 66 6f (remote-fo
2680: 72 63 65 2d 73 65 72 76 65 72 2d 73 65 74 21 20 rce-server-set!
2690: 72 75 6e 72 65 6d 6f 74 65 20 28 63 6f 6d 6d 6f runremote (commo
26a0: 6e 3a 66 6f 72 63 65 2d 73 65 72 76 65 72 3f 29 n:force-server?)
26b0: 29 0a 20 20 20 20 20 20 28 6d 75 74 65 78 2d 75 ). (mutex-u
26c0: 6e 6c 6f 63 6b 21 20 2a 72 6d 74 2d 6d 75 74 65 nlock! *rmt-mute
26d0: 78 2a 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 x*). (debug
26e0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 32 20 2a :print-info 12 *
26f0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
2700: 2a 20 22 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 * "rmt:send-rece
2710: 69 76 65 2c 20 63 61 73 65 20 20 36 22 29 0a 20 ive, case 6").
2720: 20 20 20 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 (rmt:send-r
2730: 65 63 65 69 76 65 20 63 6d 64 20 72 69 64 20 70 eceive cmd rid p
2740: 61 72 61 6d 73 20 61 74 74 65 6d 70 74 6e 75 6d arams attemptnum
2750: 3a 20 61 74 74 65 6d 70 74 6e 75 6d 29 29 0a 0a : attemptnum))..
2760: 20 20 20 20 20 3b 3b 44 4f 54 20 43 41 53 45 37 ;;DOT CASE7
2770: 20 5b 6c 61 62 65 6c 3d 22 68 6f 6d 65 68 6f 73 [label="homehos
2780: 74 5c 6e 77 72 69 74 65 22 5d 3b 0a 20 20 20 20 t\nwrite"];.
2790: 20 3b 3b 44 4f 54 20 4d 55 54 45 58 4c 4f 43 4b ;;DOT MUTEXLOCK
27a0: 20 2d 3e 20 43 41 53 45 37 20 5b 6c 61 62 65 6c -> CASE7 [label
27b0: 3d 22 73 65 72 76 65 72 20 6e 6f 74 20 72 65 71 ="server not req
27c0: 75 69 72 65 64 2c 5c 6e 6f 6e 20 68 6f 6d 65 68 uired,\non homeh
27d0: 6f 73 74 2c 5c 6e 61 20 77 72 69 74 65 2c 5c 6e ost,\na write,\n
27e0: 68 61 76 65 20 61 20 73 65 72 76 65 72 22 5d 3b have a server"];
27f0: 20 7b 72 61 6e 6b 3d 73 61 6d 65 20 22 63 61 73 {rank=same "cas
2800: 65 20 37 22 20 43 41 53 45 37 7d 3b 0a 20 20 20 e 7" CASE7};.
2810: 20 20 3b 3b 44 4f 54 20 43 41 53 45 37 20 2d 3e ;;DOT CASE7 ->
2820: 20 22 72 6d 74 3a 6f 70 65 6e 2d 71 72 79 2d 63 "rmt:open-qry-c
2830: 6c 6f 73 65 2d 6c 6f 63 61 6c 6c 79 22 3b 0a 20 lose-locally";.
2840: 20 20 20 20 3b 3b 20 6f 6e 20 68 6f 6d 65 68 6f ;; on homeho
2850: 73 74 20 61 6e 64 20 74 68 69 73 20 69 73 20 61 st and this is a
2860: 20 77 72 69 74 65 2c 20 77 65 20 61 6c 72 65 61 write, we alrea
2870: 64 79 20 68 61 76 65 20 61 20 73 65 72 76 65 72 dy have a server
2880: 0a 20 20 20 20 20 28 28 61 6e 64 20 28 6e 6f 74 . ((and (not
2890: 20 28 72 65 6d 6f 74 65 2d 66 6f 72 63 65 2d 73 (remote-force-s
28a0: 65 72 76 65 72 20 72 75 6e 72 65 6d 6f 74 65 29 erver runremote)
28b0: 29 20 20 20 20 20 3b 3b 20 68 6f 6e 6f 72 20 66 ) ;; honor f
28c0: 6f 72 63 65 64 20 75 73 65 20 6f 66 20 73 65 72 orced use of ser
28d0: 76 65 72 2c 20 69 2e 65 2e 20 73 65 72 76 65 72 ver, i.e. server
28e0: 20 4e 4f 54 20 72 65 71 75 69 72 65 64 0a 09 20 NOT required..
28f0: 20 20 28 63 64 72 20 28 72 65 6d 6f 74 65 2d 68 (cdr (remote-h
2900: 68 2d 64 61 74 20 72 75 6e 72 65 6d 6f 74 65 29 h-dat runremote)
2910: 29 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 6f ) ;; o
2920: 6e 20 68 6f 6d 65 68 6f 73 74 0a 20 20 20 20 20 n homehost.
2930: 20 20 20 20 20 20 28 6e 6f 74 20 28 6d 65 6d 62 (not (memb
2940: 65 72 20 63 6d 64 20 61 70 69 3a 72 65 61 64 2d er cmd api:read-
2950: 6f 6e 6c 79 2d 71 75 65 72 69 65 73 29 29 20 20 only-queries))
2960: 3b 3b 20 74 68 69 73 20 69 73 20 61 20 77 72 69 ;; this is a wri
2970: 74 65 0a 20 20 20 20 20 20 20 20 20 20 20 28 72 te. (r
2980: 65 6d 6f 74 65 2d 73 65 72 76 65 72 2d 75 72 6c emote-server-url
2990: 20 72 75 6e 72 65 6d 6f 74 65 29 29 20 20 20 20 runremote))
29a0: 20 20 20 20 20 20 20 20 3b 3b 20 68 61 76 65 20 ;; have
29b0: 61 20 73 65 72 76 65 72 0a 20 20 20 20 20 20 28 a server. (
29c0: 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 72 mutex-unlock! *r
29d0: 6d 74 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 20 mt-mutex*).
29e0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
29f0: 66 6f 20 31 32 20 2a 64 65 66 61 75 6c 74 2d 6c fo 12 *default-l
2a00: 6f 67 2d 70 6f 72 74 2a 20 22 72 6d 74 3a 73 65 og-port* "rmt:se
2a10: 6e 64 2d 72 65 63 65 69 76 65 2c 20 63 61 73 65 nd-receive, case
2a20: 20 20 34 2e 31 22 29 0a 20 20 20 20 20 20 28 72 4.1"). (r
2a30: 6d 74 3a 6f 70 65 6e 2d 71 72 79 2d 63 6c 6f 73 mt:open-qry-clos
2a40: 65 2d 6c 6f 63 61 6c 6c 79 20 63 6d 64 20 30 20 e-locally cmd 0
2a50: 70 61 72 61 6d 73 29 29 0a 0a 20 20 20 20 20 3b params)).. ;
2a60: 3b 44 4f 54 20 43 41 53 45 38 20 5b 6c 61 62 65 ;DOT CASE8 [labe
2a70: 6c 3d 22 66 6f 72 63 65 5c 6e 73 65 72 76 65 72 l="force\nserver
2a80: 22 5d 3b 0a 20 20 20 20 20 3b 3b 44 4f 54 20 4d "];. ;;DOT M
2a90: 55 54 45 58 4c 4f 43 4b 20 2d 3e 20 43 41 53 45 UTEXLOCK -> CASE
2aa0: 38 20 5b 6c 61 62 65 6c 3d 22 73 65 72 76 65 72 8 [label="server
2ab0: 20 6e 6f 74 20 72 65 71 75 69 72 65 64 2c 5c 6e not required,\n
2ac0: 68 61 76 65 20 68 6f 6d 65 68 6f 73 74 20 69 6e have homehost in
2ad0: 66 6f 2c 5c 6e 6e 6f 20 63 6f 6e 6e 65 63 74 69 fo,\nno connecti
2ae0: 6f 6e 20 79 65 74 2c 5c 6e 6e 6f 74 20 61 20 72 on yet,\nnot a r
2af0: 65 61 64 2d 6f 6e 6c 79 20 71 75 65 72 79 22 5d ead-only query"]
2b00: 3b 20 7b 72 61 6e 6b 3d 73 61 6d 65 20 22 63 61 ; {rank=same "ca
2b10: 73 65 20 38 22 20 43 41 53 45 38 7d 3b 0a 20 20 se 8" CASE8};.
2b20: 20 20 20 3b 3b 44 4f 54 20 43 41 53 45 38 20 2d ;;DOT CASE8 -
2b30: 3e 20 22 72 6d 74 3a 6f 70 65 6e 2d 71 72 79 2d > "rmt:open-qry-
2b40: 63 6c 6f 73 65 2d 6c 6f 63 61 6c 6c 79 22 3b 0a close-locally";.
2b50: 20 20 20 20 20 3b 3b 20 20 6f 6e 20 68 6f 6d 65 ;; on home
2b60: 68 6f 73 74 2c 20 6e 6f 20 73 65 72 76 65 72 20 host, no server
2b70: 63 6f 6e 74 61 63 74 20 6d 61 64 65 20 61 6e 64 contact made and
2b80: 20 74 68 69 73 20 69 73 20 61 20 77 72 69 74 65 this is a write
2b90: 2c 20 70 61 73 73 69 76 65 6c 79 20 73 74 61 72 , passively star
2ba0: 74 20 61 20 73 65 72 76 65 72 20 0a 20 20 20 20 t a server .
2bb0: 20 28 28 61 6e 64 20 28 6e 6f 74 20 28 72 65 6d ((and (not (rem
2bc0: 6f 74 65 2d 66 6f 72 63 65 2d 73 65 72 76 65 72 ote-force-server
2bd0: 20 72 75 6e 72 65 6d 6f 74 65 29 29 20 20 20 20 runremote))
2be0: 20 3b 3b 20 68 6f 6e 6f 72 20 66 6f 72 63 65 64 ;; honor forced
2bf0: 20 75 73 65 20 6f 66 20 73 65 72 76 65 72 2c 20 use of server,
2c00: 69 2e 65 2e 20 73 65 72 76 65 72 20 4e 4f 54 20 i.e. server NOT
2c10: 72 65 71 75 69 72 65 64 0a 09 20 20 20 28 63 64 required.. (cd
2c20: 72 20 28 72 65 6d 6f 74 65 2d 68 68 2d 64 61 74 r (remote-hh-dat
2c30: 20 72 75 6e 72 65 6d 6f 74 65 29 29 20 20 20 20 runremote))
2c40: 20 20 20 20 20 20 20 3b 3b 20 68 61 76 65 20 68 ;; have h
2c50: 6f 6d 65 68 6f 73 74 0a 20 20 20 20 20 20 20 20 omehost.
2c60: 20 20 20 28 6e 6f 74 20 28 72 65 6d 6f 74 65 2d (not (remote-
2c70: 73 65 72 76 65 72 2d 75 72 6c 20 72 75 6e 72 65 server-url runre
2c80: 6d 6f 74 65 29 29 20 20 20 20 20 20 20 3b 3b 20 mote)) ;;
2c90: 6e 6f 20 63 6f 6e 6e 65 63 74 69 6f 6e 20 79 65 no connection ye
2ca0: 74 0a 09 20 20 20 28 6e 6f 74 20 28 6d 65 6d 62 t.. (not (memb
2cb0: 65 72 20 63 6d 64 20 61 70 69 3a 72 65 61 64 2d er cmd api:read-
2cc0: 6f 6e 6c 79 2d 71 75 65 72 69 65 73 29 29 29 20 only-queries)))
2cd0: 3b 3b 20 6e 6f 74 20 61 20 72 65 61 64 2d 6f 6e ;; not a read-on
2ce0: 6c 79 20 71 75 65 72 79 0a 20 20 20 20 20 20 28 ly query. (
2cf0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
2d00: 20 31 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 12 *default-log
2d10: 2d 70 6f 72 74 2a 20 22 72 6d 74 3a 73 65 6e 64 -port* "rmt:send
2d20: 2d 72 65 63 65 69 76 65 2c 20 63 61 73 65 20 20 -receive, case
2d30: 38 22 29 0a 20 20 20 20 20 20 28 6c 65 74 20 28 8"). (let (
2d40: 28 73 65 72 76 65 72 2d 69 6e 66 6f 20 20 28 73 (server-info (s
2d50: 65 72 76 65 72 3a 63 68 65 63 6b 2d 69 66 2d 72 erver:check-if-r
2d60: 75 6e 6e 69 6e 67 20 2a 74 6f 70 70 61 74 68 2a unning *toppath*
2d70: 29 29 29 20 3b 3b 20 28 73 65 72 76 65 72 3a 72 ))) ;; (server:r
2d80: 65 61 64 2d 64 6f 74 73 65 72 76 65 72 2d 3e 75 ead-dotserver->u
2d90: 72 6c 20 2a 74 6f 70 70 61 74 68 2a 29 29 29 20 rl *toppath*)))
2da0: 3b 3b 20 28 73 65 72 76 65 72 3a 63 68 65 63 6b ;; (server:check
2db0: 2d 69 66 2d 72 75 6e 6e 69 6e 67 20 2a 74 6f 70 -if-running *top
2dc0: 70 61 74 68 2a 29 29 29 20 3b 3b 20 44 6f 20 4e path*))) ;; Do N
2dd0: 4f 54 20 77 61 6e 74 20 74 6f 20 72 75 6e 20 73 OT want to run s
2de0: 65 72 76 65 72 3a 63 68 65 63 6b 2d 69 66 2d 72 erver:check-if-r
2df0: 75 6e 6e 69 6e 67 20 2d 20 76 65 72 79 20 65 78 unning - very ex
2e00: 70 65 6e 73 69 76 65 20 74 6f 20 64 6f 20 66 6f pensive to do fo
2e10: 72 20 65 76 65 72 79 20 77 72 69 74 65 20 63 61 r every write ca
2e20: 6c 6c 0a 09 28 69 66 20 73 65 72 76 65 72 2d 69 ll..(if server-i
2e30: 6e 66 6f 0a 09 20 20 20 20 28 62 65 67 69 6e 0a nfo.. (begin.
2e40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 (r
2e50: 65 6d 6f 74 65 2d 73 65 72 76 65 72 2d 75 72 6c emote-server-url
2e60: 2d 73 65 74 21 20 72 75 6e 72 65 6d 6f 74 65 20 -set! runremote
2e70: 28 73 65 72 76 65 72 3a 72 65 63 6f 72 64 2d 3e (server:record->
2e80: 75 72 6c 20 73 65 72 76 65 72 2d 69 6e 66 6f 29 url server-info)
2e90: 29 20 3b 3b 20 74 68 65 20 73 74 72 69 6e 67 20 ) ;; the string
2ea0: 63 61 6e 20 62 65 20 63 6f 6e 73 75 6d 65 64 20 can be consumed
2eb0: 62 79 20 74 68 65 20 63 6c 69 65 6e 74 20 73 65 by the client se
2ec0: 74 75 70 20 69 66 20 6e 65 65 64 65 64 0a 20 20 tup if needed.
2ed0: 20 20 20 20 20 20 20 20 20 20 20 20 28 72 65 6d (rem
2ee0: 6f 74 65 2d 73 65 72 76 65 72 2d 69 64 2d 73 65 ote-server-id-se
2ef0: 74 21 20 72 75 6e 72 65 6d 6f 74 65 20 28 73 65 t! runremote (se
2f00: 72 76 65 72 3a 72 65 63 6f 72 64 2d 3e 69 64 20 rver:record->id
2f10: 73 65 72 76 65 72 2d 69 6e 66 6f 29 29 29 20 20 server-info)))
2f20: 0a 09 20 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f .. (if (commo
2f30: 6e 3a 66 6f 72 63 65 2d 73 65 72 76 65 72 3f 29 n:force-server?)
2f40: 0a 09 09 28 73 65 72 76 65 72 3a 73 74 61 72 74 ...(server:start
2f50: 2d 61 6e 64 2d 77 61 69 74 20 2a 74 6f 70 70 61 -and-wait *toppa
2f60: 74 68 2a 29 0a 09 09 28 73 65 72 76 65 72 3a 6b th*)...(server:k
2f70: 69 6e 64 2d 72 75 6e 20 2a 74 6f 70 70 61 74 68 ind-run *toppath
2f80: 2a 29 29 29 0a 20 20 20 20 20 20 28 72 65 6d 6f *))). (remo
2f90: 74 65 2d 66 6f 72 63 65 2d 73 65 72 76 65 72 2d te-force-server-
2fa0: 73 65 74 21 20 72 75 6e 72 65 6d 6f 74 65 20 28 set! runremote (
2fb0: 63 6f 6d 6d 6f 6e 3a 66 6f 72 63 65 2d 73 65 72 common:force-ser
2fc0: 76 65 72 3f 29 29 0a 20 20 20 20 20 20 28 6d 75 ver?)). (mu
2fd0: 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 72 6d 74 tex-unlock! *rmt
2fe0: 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 20 20 28 -mutex*). (
2ff0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
3000: 20 31 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 12 *default-log
3010: 2d 70 6f 72 74 2a 20 22 72 6d 74 3a 73 65 6e 64 -port* "rmt:send
3020: 2d 72 65 63 65 69 76 65 2c 20 63 61 73 65 20 20 -receive, case
3030: 38 2e 31 22 29 0a 20 20 20 20 20 20 28 72 6d 74 8.1"). (rmt
3040: 3a 6f 70 65 6e 2d 71 72 79 2d 63 6c 6f 73 65 2d :open-qry-close-
3050: 6c 6f 63 61 6c 6c 79 20 63 6d 64 20 30 20 70 61 locally cmd 0 pa
3060: 72 61 6d 73 29 29 29 0a 0a 20 20 20 20 20 3b 3b rams))).. ;;
3070: 44 4f 54 20 43 41 53 45 39 20 5b 6c 61 62 65 6c DOT CASE9 [label
3080: 3d 22 66 6f 72 63 65 20 73 65 72 76 65 72 5c 6e ="force server\n
3090: 6e 6f 74 20 6f 6e 20 68 6f 6d 65 68 6f 73 74 22 not on homehost"
30a0: 5d 3b 0a 20 20 20 20 20 3b 3b 44 4f 54 20 4d 55 ];. ;;DOT MU
30b0: 54 45 58 4c 4f 43 4b 20 2d 3e 20 43 41 53 45 39 TEXLOCK -> CASE9
30c0: 20 5b 6c 61 62 65 6c 3d 22 6e 6f 20 63 6f 6e 6e [label="no conn
30d0: 65 63 74 69 6f 6e 5c 6e 61 6e 64 20 65 69 74 68 ection\nand eith
30e0: 65 72 20 72 65 71 75 69 72 65 20 73 65 72 76 65 er require serve
30f0: 72 5c 6e 6f 72 20 6e 6f 74 20 6f 6e 20 68 6f 6d r\nor not on hom
3100: 65 68 6f 73 74 22 5d 3b 20 7b 72 61 6e 6b 3d 73 ehost"]; {rank=s
3110: 61 6d 65 20 22 63 61 73 65 20 39 22 20 43 41 53 ame "case 9" CAS
3120: 45 39 7d 3b 0a 20 20 20 20 20 3b 3b 44 4f 54 20 E9};. ;;DOT
3130: 43 41 53 45 39 20 2d 3e 20 22 73 74 61 72 74 5c CASE9 -> "start\
3140: 6e 73 65 72 76 65 72 22 20 2d 3e 20 22 72 6d 74 nserver" -> "rmt
3150: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 22 3b 0a :send-receive";.
3160: 20 20 20 20 20 28 28 6f 72 20 28 61 6e 64 20 28 ((or (and (
3170: 72 65 6d 6f 74 65 2d 66 6f 72 63 65 2d 73 65 72 remote-force-ser
3180: 76 65 72 20 72 75 6e 72 65 6d 6f 74 65 29 20 20 ver runremote)
3190: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 77 ;; w
31a0: 65 20 61 72 65 20 66 6f 72 63 69 6e 67 20 61 20 e are forcing a
31b0: 73 65 72 76 65 72 20 61 6e 64 20 64 6f 6e 27 74 server and don't
31c0: 20 79 65 74 20 68 61 76 65 20 61 20 63 6f 6e 6e yet have a conn
31d0: 65 63 74 69 6f 6e 20 74 6f 20 6f 6e 65 0a 09 20 ection to one..
31e0: 20 20 20 20 20 20 28 6e 6f 74 20 28 72 65 6d 6f (not (remo
31f0: 74 65 2d 63 6f 6e 6e 64 61 74 20 72 75 6e 72 65 te-conndat runre
3200: 6d 6f 74 65 29 29 29 0a 09 20 20 28 61 6e 64 20 mote))).. (and
3210: 28 6e 6f 74 20 28 63 64 72 20 28 72 65 6d 6f 74 (not (cdr (remot
3220: 65 2d 68 68 2d 64 61 74 20 72 75 6e 72 65 6d 6f e-hh-dat runremo
3230: 74 65 29 29 29 20 20 20 20 20 20 20 20 3b 3b 20 te))) ;;
3240: 6e 6f 74 20 6f 6e 20 61 20 68 6f 6d 65 68 6f 73 not on a homehos
3250: 74 20 0a 09 20 20 20 20 20 20 20 28 6e 6f 74 20 t .. (not
3260: 28 72 65 6d 6f 74 65 2d 63 6f 6e 6e 64 61 74 20 (remote-conndat
3270: 72 75 6e 72 65 6d 6f 74 65 29 29 29 29 20 20 20 runremote))))
3280: 20 20 20 20 20 20 20 20 3b 3b 20 61 6e 64 20 6e ;; and n
3290: 6f 20 63 6f 6e 6e 65 63 74 69 6f 6e 0a 20 20 20 o connection.
32a0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
32b0: 69 6e 66 6f 20 31 32 20 2a 64 65 66 61 75 6c 74 info 12 *default
32c0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 6d 74 3a -log-port* "rmt:
32d0: 73 65 6e 64 2d 72 65 63 65 69 76 65 2c 20 63 61 send-receive, ca
32e0: 73 65 20 39 2c 20 68 68 2d 64 61 74 3a 20 22 20 se 9, hh-dat: "
32f0: 28 72 65 6d 6f 74 65 2d 68 68 2d 64 61 74 20 72 (remote-hh-dat r
3300: 75 6e 72 65 6d 6f 74 65 29 20 22 20 63 6f 6e 6e unremote) " conn
3310: 64 61 74 3a 20 22 20 28 72 65 6d 6f 74 65 2d 63 dat: " (remote-c
3320: 6f 6e 6e 64 61 74 20 72 75 6e 72 65 6d 6f 74 65 onndat runremote
3330: 29 29 0a 20 20 20 20 20 20 28 6d 75 74 65 78 2d )). (mutex-
3340: 75 6e 6c 6f 63 6b 21 20 2a 72 6d 74 2d 6d 75 74 unlock! *rmt-mut
3350: 65 78 2a 29 0a 20 20 20 20 20 20 28 69 66 20 28 ex*). (if (
3360: 6e 6f 74 20 28 73 65 72 76 65 72 3a 63 68 65 63 not (server:chec
3370: 6b 2d 69 66 2d 72 75 6e 6e 69 6e 67 20 2a 74 6f k-if-running *to
3380: 70 70 61 74 68 2a 29 29 20 3b 3b 20 77 68 6f 20 ppath*)) ;; who
3390: 6b 6e 6f 77 73 2c 20 6d 61 79 62 65 20 6f 6e 65 knows, maybe one
33a0: 20 68 61 73 20 73 74 61 72 74 65 64 20 75 70 3f has started up?
33b0: 0a 09 20 20 28 73 65 72 76 65 72 3a 73 74 61 72 .. (server:star
33c0: 74 2d 61 6e 64 2d 77 61 69 74 20 2a 74 6f 70 70 t-and-wait *topp
33d0: 61 74 68 2a 29 29 0a 20 20 20 20 20 20 28 72 65 ath*)). (re
33e0: 6d 6f 74 65 2d 63 6f 6e 6e 64 61 74 2d 73 65 74 mote-conndat-set
33f0: 21 20 72 75 6e 72 65 6d 6f 74 65 20 28 72 6d 74 ! runremote (rmt
3400: 3a 67 65 74 2d 63 6f 6e 6e 65 63 74 69 6f 6e 2d :get-connection-
3410: 69 6e 66 6f 20 2a 74 6f 70 70 61 74 68 2a 29 29 info *toppath*))
3420: 20 3b 3b 20 63 61 6c 6c 73 20 63 6c 69 65 6e 74 ;; calls client
3430: 3a 73 65 74 75 70 20 77 68 69 63 68 20 63 61 6c :setup which cal
3440: 6c 73 20 63 6c 69 65 6e 74 3a 73 65 74 75 70 2d ls client:setup-
3450: 68 74 74 70 0a 20 20 20 20 20 20 28 72 6d 74 3a http. (rmt:
3460: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 63 6d 64 send-receive cmd
3470: 20 72 69 64 20 70 61 72 61 6d 73 20 61 74 74 65 rid params atte
3480: 6d 70 74 6e 75 6d 3a 20 61 74 74 65 6d 70 74 6e mptnum: attemptn
3490: 75 6d 29 29 20 3b 3b 20 54 4f 44 4f 3a 20 61 64 um)) ;; TODO: ad
34a0: 64 20 62 61 63 6b 2d 6f 66 66 20 74 69 6d 65 6f d back-off timeo
34b0: 75 74 20 61 73 0a 0a 20 20 20 20 20 3b 3b 44 4f ut as.. ;;DO
34c0: 54 20 43 41 53 45 31 30 20 5b 6c 61 62 65 6c 3d T CASE10 [label=
34d0: 22 6f 6e 20 68 6f 6d 65 68 6f 73 74 22 5d 3b 0a "on homehost"];.
34e0: 20 20 20 20 20 3b 3b 44 4f 54 20 4d 55 54 45 58 ;;DOT MUTEX
34f0: 4c 4f 43 4b 20 2d 3e 20 43 41 53 45 31 30 20 5b LOCK -> CASE10 [
3500: 6c 61 62 65 6c 3d 22 73 65 72 76 65 72 20 6e 6f label="server no
3510: 74 20 72 65 71 75 69 72 65 64 2c 5c 6e 6f 6e 20 t required,\non
3520: 68 6f 6d 65 68 6f 73 74 22 5d 3b 20 7b 72 61 6e homehost"]; {ran
3530: 6b 3d 73 61 6d 65 20 22 63 61 73 65 20 31 30 22 k=same "case 10"
3540: 20 43 41 53 45 31 30 7d 3b 0a 20 20 20 20 20 3b CASE10};. ;
3550: 3b 44 4f 54 20 43 41 53 45 31 30 20 2d 3e 20 22 ;DOT CASE10 -> "
3560: 72 6d 74 3a 6f 70 65 6e 2d 71 72 79 2d 63 6c 6f rmt:open-qry-clo
3570: 73 65 2d 6c 6f 63 61 6c 6c 79 22 3b 0a 20 20 20 se-locally";.
3580: 20 20 3b 3b 20 61 6c 6c 20 73 65 74 20 75 70 20 ;; all set up
3590: 69 66 20 67 65 74 20 74 68 69 73 20 66 61 72 2c if get this far,
35a0: 20 64 69 73 70 61 74 63 68 20 74 68 65 20 71 75 dispatch the qu
35b0: 65 72 79 0a 20 20 20 20 20 28 28 61 6e 64 20 28 ery. ((and (
35c0: 6e 6f 74 20 28 72 65 6d 6f 74 65 2d 66 6f 72 63 not (remote-forc
35d0: 65 2d 73 65 72 76 65 72 20 72 75 6e 72 65 6d 6f e-server runremo
35e0: 74 65 29 29 0a 09 20 20 20 28 63 64 72 20 28 72 te)).. (cdr (r
35f0: 65 6d 6f 74 65 2d 68 68 2d 64 61 74 20 72 75 6e emote-hh-dat run
3600: 72 65 6d 6f 74 65 29 29 29 20 3b 3b 20 77 65 20 remote))) ;; we
3610: 61 72 65 20 6f 6e 20 68 6f 6d 65 68 6f 73 74 0a are on homehost.
3620: 20 20 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c (mutex-unl
3630: 6f 63 6b 21 20 2a 72 6d 74 2d 6d 75 74 65 78 2a ock! *rmt-mutex*
3640: 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 ). (debug:p
3650: 72 69 6e 74 2d 69 6e 66 6f 20 31 32 20 2a 64 65 rint-info 12 *de
3660: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
3670: 22 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 "rmt:send-receiv
3680: 65 2c 20 63 61 73 65 20 31 30 22 29 0a 20 20 20 e, case 10").
3690: 20 20 20 28 72 6d 74 3a 6f 70 65 6e 2d 71 72 79 (rmt:open-qry
36a0: 2d 63 6c 6f 73 65 2d 6c 6f 63 61 6c 6c 79 20 63 -close-locally c
36b0: 6d 64 20 28 69 66 20 72 69 64 20 72 69 64 20 30 md (if rid rid 0
36c0: 29 20 70 61 72 61 6d 73 29 29 0a 0a 20 20 20 20 ) params))..
36d0: 20 3b 3b 44 4f 54 20 43 41 53 45 31 31 20 5b 6c ;;DOT CASE11 [l
36e0: 61 62 65 6c 3d 22 73 65 6e 64 5f 72 65 63 65 69 abel="send_recei
36f0: 76 65 22 5d 3b 0a 20 20 20 20 20 3b 3b 44 4f 54 ve"];. ;;DOT
3700: 20 4d 55 54 45 58 4c 4f 43 4b 20 2d 3e 20 43 41 MUTEXLOCK -> CA
3710: 53 45 31 31 20 5b 6c 61 62 65 6c 3d 22 65 6c 73 SE11 [label="els
3720: 65 22 5d 3b 20 7b 72 61 6e 6b 3d 73 61 6d 65 20 e"]; {rank=same
3730: 22 63 61 73 65 20 31 31 22 20 43 41 53 45 31 31 "case 11" CASE11
3740: 7d 3b 0a 20 20 20 20 20 3b 3b 44 4f 54 20 43 41 };. ;;DOT CA
3750: 53 45 31 31 20 2d 3e 20 22 72 6d 74 3a 73 65 6e SE11 -> "rmt:sen
3760: 64 2d 72 65 63 65 69 76 65 22 20 5b 6c 61 62 65 d-receive" [labe
3770: 6c 3d 22 63 61 6c 6c 20 66 61 69 6c 65 64 22 5d l="call failed"]
3780: 3b 0a 20 20 20 20 20 3b 3b 44 4f 54 20 43 41 53 ;. ;;DOT CAS
3790: 45 31 31 20 2d 3e 20 22 52 45 53 55 4c 54 22 20 E11 -> "RESULT"
37a0: 5b 6c 61 62 65 6c 3d 22 63 61 6c 6c 20 73 75 63 [label="call suc
37b0: 63 65 65 64 65 64 22 5d 3b 0a 20 20 20 20 20 3b ceeded"];. ;
37c0: 3b 20 6e 6f 74 20 6f 6e 20 68 6f 6d 65 68 6f 73 ; not on homehos
37d0: 74 2c 20 64 6f 20 73 65 72 76 65 72 20 71 75 65 t, do server que
37e0: 72 79 0a 20 20 20 20 20 28 65 6c 73 65 20 28 65 ry. (else (e
37f0: 78 74 72 61 73 2d 63 61 73 65 2d 31 31 20 2a 64 xtras-case-11 *d
3800: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
3810: 20 72 75 6e 72 65 6d 6f 74 65 20 63 6d 64 20 70 runremote cmd p
3820: 61 72 61 6d 73 20 61 74 74 65 6d 70 74 6e 75 6d arams attemptnum
3830: 20 72 69 64 29 29 29 29 29 0a 20 20 20 20 3b 3b rid))))). ;;
3840: 44 4f 54 20 7d 0a 0a 3b 3b 20 62 75 6e 63 68 20 DOT }..;; bunch
3850: 6f 66 20 73 6d 61 6c 6c 20 66 75 6e 63 74 69 6f of small functio
3860: 6e 73 20 66 61 63 74 6f 72 65 64 20 6f 75 74 20 ns factored out
3870: 6f 66 20 73 65 6e 64 2d 72 65 63 65 69 76 65 20 of send-receive
3880: 74 6f 20 6d 61 6b 65 20 64 65 62 75 67 20 65 61 to make debug ea
3890: 73 69 65 72 0a 3b 3b 0a 0a 28 64 65 66 69 6e 65 sier.;;..(define
38a0: 20 28 65 78 74 72 61 73 2d 63 61 73 65 2d 31 31 (extras-case-11
38b0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
38c0: 72 74 2a 20 72 75 6e 72 65 6d 6f 74 65 20 63 6d rt* runremote cm
38d0: 64 20 70 61 72 61 6d 73 20 61 74 74 65 6d 70 74 d params attempt
38e0: 6e 75 6d 20 72 69 64 29 0a 20 20 3b 3b 20 28 6d num rid). ;; (m
38f0: 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 72 6d utex-unlock! *rm
3900: 74 2d 6d 75 74 65 78 2a 29 0a 20 20 28 64 65 62 t-mutex*). (deb
3910: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 32 ug:print-info 12
3920: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
3930: 72 74 2a 20 22 72 6d 74 3a 73 65 6e 64 2d 72 65 rt* "rmt:send-re
3940: 63 65 69 76 65 2c 20 63 61 73 65 20 20 39 22 29 ceive, case 9")
3950: 0a 20 20 3b 3b 20 28 6d 75 74 65 78 2d 6c 6f 63 . ;; (mutex-loc
3960: 6b 21 20 2a 72 6d 74 2d 6d 75 74 65 78 2a 29 0a k! *rmt-mutex*).
3970: 20 20 28 6c 65 74 2a 20 28 28 63 6f 6e 6e 69 6e (let* ((connin
3980: 66 6f 20 28 72 65 6d 6f 74 65 2d 63 6f 6e 6e 64 fo (remote-connd
3990: 61 74 20 72 75 6e 72 65 6d 6f 74 65 29 29 0a 09 at runremote))..
39a0: 20 28 64 61 74 2d 69 6e 20 20 20 20 20 20 28 63 (dat-in (c
39b0: 61 73 65 20 28 72 65 6d 6f 74 65 2d 74 72 61 6e ase (remote-tran
39c0: 73 70 6f 72 74 20 72 75 6e 72 65 6d 6f 74 65 29 sport runremote)
39d0: 0a 09 09 20 20 20 20 20 28 28 68 74 74 70 29 20 ... ((http)
39e0: 28 63 6f 6e 64 69 74 69 6f 6e 2d 63 61 73 65 20 (condition-case
39f0: 3b 3b 20 68 61 6e 64 6c 69 6e 67 20 68 65 72 65 ;; handling here
3a00: 20 68 61 73 0a 09 09 09 09 09 20 20 20 20 20 3b has...... ;
3a10: 3b 20 63 61 75 73 65 64 20 61 20 6c 6f 74 20 6f ; caused a lot o
3a20: 66 0a 09 09 09 09 09 20 20 20 20 20 3b 3b 20 70 f...... ;; p
3a30: 72 6f 62 6c 65 6d 73 2e 20 48 6f 77 65 76 65 72 roblems. However
3a40: 20 69 74 0a 09 09 09 09 09 20 20 20 20 20 3b 3b it...... ;;
3a50: 20 69 73 20 6e 65 65 64 65 64 20 74 6f 20 64 65 is needed to de
3a60: 61 6c 20 77 69 74 68 0a 09 09 09 09 09 20 20 20 al with......
3a70: 20 20 3b 3b 20 61 74 74 65 6d 74 70 65 64 0a 09 ;; attemtped..
3a80: 09 09 09 09 20 20 20 20 20 3b 3b 20 63 6f 6d 6d .... ;; comm
3a90: 75 6e 69 63 61 74 69 6f 6e 20 74 6f 0a 09 09 09 unication to....
3aa0: 09 09 20 20 20 20 20 3b 3b 20 73 65 72 76 65 72 .. ;; server
3ab0: 73 20 74 68 61 74 20 68 61 76 65 20 67 6f 6e 65 s that have gone
3ac0: 0a 09 09 09 09 09 20 20 20 20 20 3b 3b 20 61 77 ...... ;; aw
3ad0: 61 79 0a 09 09 09 20 20 20 20 20 20 28 68 74 74 ay.... (htt
3ae0: 70 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c 69 65 p-transport:clie
3af0: 6e 74 2d 61 70 69 2d 73 65 6e 64 2d 72 65 63 65 nt-api-send-rece
3b00: 69 76 65 20 30 20 63 6f 6e 6e 69 6e 66 6f 20 63 ive 0 conninfo c
3b10: 6d 64 20 70 61 72 61 6d 73 29 0a 20 20 20 20 20 md params).
3b20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3b30: 20 20 20 20 20 20 20 20 20 28 28 73 65 72 76 65 ((serve
3b40: 72 6d 69 73 6d 61 74 63 68 29 20 20 28 76 65 63 rmismatch) (vec
3b50: 74 6f 72 20 23 66 20 22 53 65 72 76 65 72 20 69 tor #f "Server i
3b60: 64 20 6d 69 73 6d 61 74 63 68 22 20 29 29 0a 09 d mismatch" ))..
3b70: 09 09 20 20 20 20 20 20 28 28 63 6f 6d 6d 66 61 .. ((commfa
3b80: 69 6c 29 28 76 65 63 74 6f 72 20 23 66 20 22 63 il)(vector #f "c
3b90: 6f 6d 6d 75 6e 69 63 61 74 69 6f 6e 73 20 66 61 ommunications fa
3ba0: 69 6c 22 29 29 0a 09 09 09 20 20 20 20 20 20 28 il")).... (
3bb0: 28 65 78 6e 29 28 76 65 63 74 6f 72 20 23 66 20 (exn)(vector #f
3bc0: 22 6f 74 68 65 72 20 66 61 69 6c 22 20 28 70 72 "other fail" (pr
3bd0: 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 29 29 int-call-chain))
3be0: 29 29 29 0a 09 09 20 20 20 20 20 28 65 6c 73 65 )))... (else
3bf0: 0a 09 09 20 20 20 20 20 20 28 64 65 62 75 67 3a ... (debug:
3c00: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
3c10: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 52 52 4f -log-port* "ERRO
3c20: 52 3a 20 74 72 61 6e 73 70 6f 72 74 20 22 20 28 R: transport " (
3c30: 72 65 6d 6f 74 65 2d 74 72 61 6e 73 70 6f 72 74 remote-transport
3c40: 20 72 75 6e 72 65 6d 6f 74 65 29 20 22 20 6e 6f runremote) " no
3c50: 74 20 73 75 70 70 6f 72 74 65 64 22 29 0a 09 09 t supported")...
3c60: 20 20 20 20 20 20 28 65 78 69 74 29 29 29 29 0a (exit)))).
3c70: 0a 3b 3b 20 4e 6f 20 54 69 74 6c 65 20 0a 3b 3b .;; No Title .;;
3c80: 20 45 72 72 6f 72 3a 20 28 76 65 63 74 6f 72 2d Error: (vector-
3c90: 72 65 66 29 20 6f 75 74 20 6f 66 20 72 61 6e 67 ref) out of rang
3ca0: 65 0a 3b 3b 20 23 28 23 3c 63 6f 6e 64 69 74 69 e.;; #(#<conditi
3cb0: 6f 6e 3a 20 28 65 78 6e 20 74 79 70 65 29 3e 20 on: (exn type)>
3cc0: 28 23 28 22 64 62 2e 73 63 6d 3a 33 37 34 30 3a (#("db.scm:3740:
3cd0: 20 72 65 67 65 78 23 72 65 67 65 78 70 22 20 23 regex#regexp" #
3ce0: 66 20 23 66 29 20 23 28 22 64 62 2e 73 63 6d 3a f #f) #("db.scm:
3cf0: 33 37 33 39 3a 20 72 65 67 65 78 23 73 74 72 69 3739: regex#stri
3d00: 6e 67 2d 73 75 62 73 74 69 74 75 74 65 22 20 23 ng-substitute" #
3d10: 66 20 23 66 29 20 23 28 22 64 62 2e 73 63 6d 3a f #f) #("db.scm:
3d20: 33 37 33 38 3a 20 62 61 73 65 36 34 23 62 61 73 3738: base64#bas
3d30: 65 36 34 2d 64 65 63 6f 64 65 22 20 23 66 20 23 e64-decode" #f #
3d40: 66 29 20 23 28 22 64 62 2e 73 63 6d 3a 33 37 33 f) #("db.scm:373
3d50: 37 3a 20 7a 33 23 7a 33 3a 64 65 63 6f 64 65 2d 7: z3#z3:decode-
3d60: 62 75 66 66 65 72 22 20 23 66 20 23 66 29 20 23 buffer" #f #f) #
3d70: 28 22 64 62 2e 73 63 6d 3a 33 37 33 36 3a 20 77 ("db.scm:3736: w
3d80: 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 73 ith-input-from-s
3d90: 74 72 69 6e 67 22 20 23 66 20 23 66 29 20 23 28 tring" #f #f) #(
3da0: 22 64 62 2e 73 63 6d 3a 33 37 34 31 3a 20 73 31 "db.scm:3741: s1
3db0: 31 6e 23 64 65 73 65 72 69 61 6c 69 7a 65 22 20 1n#deserialize"
3dc0: 23 66 20 23 66 29 20 23 28 22 61 70 69 2e 73 63 #f #f) #("api.sc
3dd0: 6d 3a 33 37 34 3a 20 61 70 69 3a 65 78 65 63 75 m:374: api:execu
3de0: 74 65 2d 72 65 71 75 65 73 74 73 22 20 23 66 20 te-requests" #f
3df0: 23 66 29 20 23 28 22 61 70 69 2e 73 63 6d 3a 31 #f) #("api.scm:1
3e00: 33 39 3a 20 63 61 6c 6c 2d 77 69 74 68 2d 63 75 39: call-with-cu
3e10: 72 72 65 6e 74 2d 63 6f 6e 74 69 6e 75 61 74 69 rrent-continuati
3e20: 6f 6e 22 20 23 66 20 23 66 29 20 23 28 22 61 70 on" #f #f) #("ap
3e30: 69 2e 73 63 6d 3a 31 33 39 3a 20 77 69 74 68 2d i.scm:139: with-
3e40: 65 78 63 65 70 74 69 6f 6e 2d 68 61 6e 64 6c 65 exception-handle
3e50: 72 22 20 23 66 20 23 66 29 20 23 28 22 61 70 69 r" #f #f) #("api
3e60: 2e 73 63 6d 3a 31 33 39 3a 20 23 23 73 79 73 23 .scm:139: ##sys#
3e70: 63 61 6c 6c 2d 77 69 74 68 2d 76 61 6c 75 65 73 call-with-values
3e80: 22 20 23 66 20 23 66 29 20 23 28 22 61 70 69 2e " #f #f) #("api.
3e90: 73 63 6d 3a 31 35 38 3a 20 73 74 72 69 6e 67 2d scm:158: string-
3ea0: 3e 73 79 6d 62 6f 6c 22 20 23 66 20 23 66 29 20 >symbol" #f #f)
3eb0: 23 28 22 61 70 69 2e 73 63 6d 3a 31 36 30 3a 20 #("api.scm:160:
3ec0: 63 75 72 72 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 current-millisec
3ed0: 6f 6e 64 73 22 20 23 66 20 23 66 29 20 23 28 22 onds" #f #f) #("
3ee0: 61 70 69 2e 73 63 6d 3a 31 36 31 3a 20 64 62 72 api.scm:161: dbr
3ef0: 3a 64 62 73 74 72 75 63 74 2d 72 65 61 64 2d 6f :dbstruct-read-o
3f00: 6e 6c 79 22 20 23 66 20 23 66 29 20 23 28 22 61 nly" #f #f) #("a
3f10: 70 69 2e 73 63 6d 3a 31 33 39 3a 20 6b 31 35 22 pi.scm:139: k15"
3f20: 20 23 66 20 23 66 29 20 23 28 22 61 70 69 2e 73 #f #f) #("api.s
3f30: 63 6d 3a 31 33 39 3a 20 67 31 39 22 20 23 66 20 cm:139: g19" #f
3f40: 23 66 29 20 23 28 22 61 70 69 2e 73 63 6d 3a 31 #f) #("api.scm:1
3f50: 34 32 3a 20 67 65 74 2d 63 61 6c 6c 2d 63 68 61 42: get-call-cha
3f60: 69 6e 22 20 23 66 20 23 66 29 29 20 23 28 22 67 in" #f #f)) #("g
3f70: 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d et-test-info-by-
3f80: 69 64 22 20 28 31 31 30 32 20 35 30 37 32 39 39 id" (1102 507299
3f90: 29 29 29 0a 3b 3b 20 36 0a 3b 3b 20 0a 3b 3b 20 ))).;; 6.;; .;;
3fa0: 09 43 61 6c 6c 20 68 69 73 74 6f 72 79 3a 0a 3b .Call history:.;
3fb0: 3b 20 0a 3b 3b 20 09 68 74 74 70 2d 74 72 61 6e ; .;; .http-tran
3fc0: 73 70 6f 72 74 2e 73 63 6d 3a 33 30 36 3a 20 74 sport.scm:306: t
3fd0: 68 72 65 61 64 2d 74 65 72 6d 69 6e 61 74 65 21 hread-terminate!
3fe0: 09 20 20 0a 3b 3b 20 09 68 74 74 70 2d 74 72 61 . .;; .http-tra
3ff0: 6e 73 70 6f 72 74 2e 73 63 6d 3a 33 30 37 3a 20 nsport.scm:307:
4000: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
4010: 09 20 20 0a 3b 3b 20 09 63 6f 6d 6d 6f 6e 5f 72 . .;; .common_r
4020: 65 63 6f 72 64 73 2e 73 63 6d 3a 32 33 35 3a 20 ecords.scm:235:
4030: 64 65 62 75 67 3a 64 65 62 75 67 2d 6d 6f 64 65 debug:debug-mode
4040: 09 20 20 0a 3b 3b 20 09 72 6d 74 2e 73 63 6d 3a . .;; .rmt.scm:
4050: 32 35 39 3a 20 6b 35 38 37 09 20 20 0a 3b 3b 20 259: k587. .;;
4060: 09 72 6d 74 2e 73 63 6d 3a 32 35 39 3a 20 67 35 .rmt.scm:259: g5
4070: 39 31 09 20 20 0a 3b 3b 20 09 72 6d 74 2e 73 63 91. .;; .rmt.sc
4080: 6d 3a 32 37 36 3a 20 68 74 74 70 2d 74 72 61 6e m:276: http-tran
4090: 73 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 74 sport:server-dat
40a0: 2d 75 70 64 61 74 65 2d 6c 61 73 74 2d 61 63 63 -update-last-acc
40b0: 65 73 73 09 20 20 0a 3b 3b 20 09 68 74 74 70 2d ess. .;; .http-
40c0: 74 72 61 6e 73 70 6f 72 74 2e 73 63 6d 3a 33 36 transport.scm:36
40d0: 34 3a 20 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 4: current-secon
40e0: 64 73 09 20 20 0a 3b 3b 20 09 72 6d 74 2e 73 63 ds. .;; .rmt.sc
40f0: 6d 3a 32 38 32 3a 20 64 65 62 75 67 3a 70 72 69 m:282: debug:pri
4100: 6e 74 2d 69 6e 66 6f 09 20 20 0a 3b 3b 20 09 63 nt-info. .;; .c
4110: 6f 6d 6d 6f 6e 5f 72 65 63 6f 72 64 73 2e 73 63 ommon_records.sc
4120: 6d 3a 32 33 35 3a 20 64 65 62 75 67 3a 64 65 62 m:235: debug:deb
4130: 75 67 2d 6d 6f 64 65 09 20 20 0a 3b 3b 20 09 72 ug-mode. .;; .r
4140: 6d 74 2e 73 63 6d 3a 32 38 33 3a 20 6d 75 74 65 mt.scm:283: mute
4150: 78 2d 75 6e 6c 6f 63 6b 21 09 20 20 0a 3b 3b 20 x-unlock!. .;;
4160: 09 72 6d 74 2e 73 63 6d 3a 32 38 37 3a 20 65 78 .rmt.scm:287: ex
4170: 74 72 61 73 2d 74 72 61 6e 73 70 6f 72 74 2d 73 tras-transport-s
4180: 75 63 63 65 64 65 64 09 20 20 09 3c 2d 2d 0a 3b ucceded. .<--.;
4190: 3b 20 2b 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d ; +-------------
41a0: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d ----------------
41b0: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d ----------------
41c0: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d ----------------
41d0: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d ----------------
41e0: 2b 0a 3b 3b 20 7c 20 45 78 69 74 20 53 74 61 74 +.;; | Exit Stat
41f0: 75 73 20 20 20 20 3a 20 37 30 20 20 0a 3b 3b 20 us : 70 .;;
4200: 20 0a 0a 09 20 28 64 61 74 20 20 20 20 20 20 28 ... (dat (
4210: 69 66 20 28 61 6e 64 20 28 76 65 63 74 6f 72 3f if (and (vector?
4220: 20 64 61 74 2d 69 6e 29 20 3b 3b 20 2e 2e 2e 20 dat-in) ;; ...
4230: 63 68 65 63 6b 20 69 74 20 69 73 20 61 20 63 6f check it is a co
4240: 72 72 65 63 74 20 73 69 7a 65 0a 09 09 09 20 20 rrect size....
4250: 20 20 28 3e 20 28 76 65 63 74 6f 72 2d 6c 65 6e (> (vector-len
4260: 67 74 68 20 64 61 74 2d 69 6e 29 20 31 29 29 0a gth dat-in) 1)).
4270: 09 09 20 20 20 20 20 20 20 64 61 74 2d 69 6e 0a .. dat-in.
4280: 09 09 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 .. (vector
4290: 20 23 66 20 28 63 6f 6e 63 20 22 63 6f 6d 6d 75 #f (conc "commu
42a0: 6e 69 63 61 74 69 6f 6e 73 20 66 61 69 6c 20 28 nications fail (
42b0: 74 79 70 65 20 32 29 2c 20 64 61 74 2d 69 6e 3d type 2), dat-in=
42c0: 22 20 64 61 74 2d 69 6e 29 29 29 29 0a 09 20 28 " dat-in)))).. (
42d0: 73 75 63 63 65 73 73 20 20 28 69 66 20 28 76 65 success (if (ve
42e0: 63 74 6f 72 3f 20 64 61 74 29 20 28 76 65 63 74 ctor? dat) (vect
42f0: 6f 72 2d 72 65 66 20 64 61 74 20 30 29 20 23 66 or-ref dat 0) #f
4300: 29 29 0a 09 20 28 72 65 73 20 20 20 20 20 20 28 )).. (res (
4310: 69 66 20 28 76 65 63 74 6f 72 3f 20 64 61 74 29 if (vector? dat)
4320: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 64 61 74 (vector-ref dat
4330: 20 31 29 20 23 66 29 29 29 0a 20 20 20 20 28 69 1) #f))). (i
4340: 66 20 28 61 6e 64 20 28 76 65 63 74 6f 72 3f 20 f (and (vector?
4350: 63 6f 6e 6e 69 6e 66 6f 29 20 28 3c 20 35 20 28 conninfo) (< 5 (
4360: 76 65 63 74 6f 72 2d 6c 65 6e 67 74 68 20 63 6f vector-length co
4370: 6e 6e 69 6e 66 6f 29 29 29 0a 09 28 68 74 74 70 nninfo)))..(http
4380: 2d 74 72 61 6e 73 70 6f 72 74 3a 73 65 72 76 65 -transport:serve
4390: 72 2d 64 61 74 2d 75 70 64 61 74 65 2d 6c 61 73 r-dat-update-las
43a0: 74 2d 61 63 63 65 73 73 20 63 6f 6e 6e 69 6e 66 t-access conninf
43b0: 6f 29 20 3b 3b 20 72 65 66 72 65 73 68 20 61 63 o) ;; refresh ac
43c0: 63 65 73 73 20 74 69 6d 65 0a 09 28 62 65 67 69 cess time..(begi
43d0: 6e 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e n.. (debug:prin
43e0: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
43f0: 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 53 68 -port* "INFO: Sh
4400: 6f 75 6c 64 20 6e 6f 74 20 67 65 74 20 68 65 72 ould not get her
4410: 65 21 20 63 6f 6e 6e 69 6e 66 6f 3d 22 20 63 6f e! conninfo=" co
4420: 6e 6e 69 6e 66 6f 29 0a 09 20 20 28 73 65 74 21 nninfo).. (set!
4430: 20 63 6f 6e 6e 69 6e 66 6f 20 23 66 29 0a 09 20 conninfo #f)..
4440: 20 28 72 65 6d 6f 74 65 2d 63 6f 6e 6e 64 61 74 (remote-conndat
4450: 2d 73 65 74 21 20 2a 72 75 6e 72 65 6d 6f 74 65 -set! *runremote
4460: 2a 20 23 66 29 20 3b 3b 20 4e 4f 54 45 3a 20 2a * #f) ;; NOTE: *
4470: 72 75 6e 72 65 6d 6f 74 65 2a 20 69 73 20 67 6c runremote* is gl
4480: 6f 62 61 6c 20 63 6f 70 79 20 6f 66 20 72 75 6e obal copy of run
4490: 72 65 6d 6f 74 65 2e 20 50 75 72 70 6f 73 65 3a remote. Purpose:
44a0: 20 66 61 63 74 6f 72 20 6f 75 74 20 67 6c 6f 62 factor out glob
44b0: 61 6c 2e 0a 09 20 20 28 68 74 74 70 2d 74 72 61 al... (http-tra
44c0: 6e 73 70 6f 72 74 3a 63 6c 6f 73 65 2d 63 6f 6e nsport:close-con
44d0: 6e 65 63 74 69 6f 6e 73 20 20 61 72 65 61 2d 64 nections area-d
44e0: 61 74 3a 20 72 75 6e 72 65 6d 6f 74 65 29 29 29 at: runremote)))
44f0: 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
4500: 74 2d 69 6e 66 6f 20 31 33 20 2a 64 65 66 61 75 t-info 13 *defau
4510: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 6d lt-log-port* "rm
4520: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 2c 20 t:send-receive,
4530: 63 61 73 65 20 20 39 2e 20 63 6f 6e 6e 69 6e 66 case 9. conninf
4540: 6f 3d 22 20 63 6f 6e 6e 69 6e 66 6f 20 22 20 64 o=" conninfo " d
4550: 61 74 3d 22 20 64 61 74 20 22 20 72 75 6e 72 65 at=" dat " runre
4560: 6d 6f 74 65 20 3d 20 22 20 72 75 6e 72 65 6d 6f mote = " runremo
4570: 74 65 29 0a 20 20 20 20 28 6d 75 74 65 78 2d 75 te). (mutex-u
4580: 6e 6c 6f 63 6b 21 20 2a 72 6d 74 2d 6d 75 74 65 nlock! *rmt-mute
4590: 78 2a 29 0a 20 20 20 20 28 69 66 20 73 75 63 63 x*). (if succ
45a0: 65 73 73 20 3b 3b 20 73 75 63 63 65 73 73 20 6f ess ;; success o
45b0: 6e 6c 79 20 74 65 6c 6c 73 20 75 73 20 74 68 61 nly tells us tha
45c0: 74 20 74 68 65 20 74 72 61 6e 73 70 6f 72 74 20 t the transport
45d0: 77 61 73 0a 09 3b 3b 20 73 75 63 63 65 73 73 66 was..;; successf
45e0: 75 6c 2c 20 68 61 76 65 20 74 6f 20 65 78 61 6d ul, have to exam
45f0: 69 6e 65 20 74 68 65 20 64 61 74 61 20 74 6f 20 ine the data to
4600: 73 65 65 20 69 66 0a 09 3b 3b 20 74 68 65 72 65 see if..;; there
4610: 20 77 61 73 20 61 20 64 65 74 65 63 74 65 64 20 was a detected
4620: 69 73 73 75 65 20 61 74 20 74 68 65 20 6f 74 68 issue at the oth
4630: 65 72 20 65 6e 64 0a 09 28 65 78 74 72 61 73 2d er end..(extras-
4640: 74 72 61 6e 73 70 6f 72 74 2d 73 75 63 63 65 64 transport-succed
4650: 65 64 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d ed *default-log-
4660: 70 6f 72 74 2a 20 2a 72 6d 74 2d 6d 75 74 65 78 port* *rmt-mutex
4670: 2a 20 61 74 74 65 6d 70 74 6e 75 6d 20 72 75 6e * attemptnum run
4680: 72 65 6d 6f 74 65 20 72 65 73 20 70 61 72 61 6d remote res param
4690: 73 20 72 69 64 20 63 6d 64 29 0a 09 28 62 65 67 s rid cmd)..(beg
46a0: 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 28 64 in. (d
46b0: 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 ebug:print-error
46c0: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
46d0: 70 6f 72 74 2a 20 22 20 64 61 74 3d 22 20 64 61 port* " dat=" da
46e0: 74 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 28 t) . (
46f0: 65 78 74 72 61 73 2d 74 72 61 6e 73 70 6f 72 74 extras-transport
4700: 2d 66 61 69 6c 65 64 20 2a 64 65 66 61 75 6c 74 -failed *default
4710: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 2a 72 6d 74 2d -log-port* *rmt-
4720: 6d 75 74 65 78 2a 20 61 74 74 65 6d 70 74 6e 75 mutex* attemptnu
4730: 6d 20 72 75 6e 72 65 6d 6f 74 65 20 63 6d 64 20 m runremote cmd
4740: 72 69 64 20 70 61 72 61 6d 73 29 29 0a 09 29 29 rid params))..))
4750: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a )..(define (rmt:
4760: 70 72 69 6e 74 2d 64 62 2d 73 74 61 74 73 29 0a print-db-stats).
4770: 20 20 28 6c 65 74 20 28 28 66 6d 74 73 74 72 20 (let ((fmtstr
4780: 22 7e 34 30 61 7e 37 2d 64 7e 39 2d 64 7e 32 30 "~40a~7-d~9-d~20
4790: 2c 32 2d 66 22 29 29 20 3b 3b 20 22 7e 32 30 2c ,2-f")) ;; "~20,
47a0: 32 2d 66 22 0a 20 20 20 20 28 64 65 62 75 67 3a 2-f". (debug:
47b0: 70 72 69 6e 74 20 31 38 20 2a 64 65 66 61 75 6c print 18 *defaul
47c0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 44 42 20 t-log-port* "DB
47d0: 53 74 61 74 73 5c 6e 3d 3d 3d 3d 3d 3d 3d 3d 22 Stats\n========"
47e0: 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 ). (debug:pri
47f0: 6e 74 20 31 38 20 2a 64 65 66 61 75 6c 74 2d 6c nt 18 *default-l
4800: 6f 67 2d 70 6f 72 74 2a 20 28 66 6f 72 6d 61 74 og-port* (format
4810: 20 23 66 20 22 7e 34 30 61 7e 38 61 7e 31 30 61 #f "~40a~8a~10a
4820: 7e 31 30 61 22 20 22 43 6d 64 22 20 22 43 6f 75 ~10a" "Cmd" "Cou
4830: 6e 74 22 20 22 54 6f 74 54 69 6d 65 22 20 22 41 nt" "TotTime" "A
4840: 76 67 22 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 vg")). (for-e
4850: 61 63 68 20 28 6c 61 6d 62 64 61 20 28 63 6d 64 ach (lambda (cmd
4860: 29 0a 09 09 28 6c 65 74 20 28 28 63 6d 64 2d 64 )...(let ((cmd-d
4870: 61 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 at (hash-table-r
4880: 65 66 20 2a 64 62 2d 73 74 61 74 73 2a 20 63 6d ef *db-stats* cm
4890: 64 29 29 29 0a 09 09 20 20 28 64 65 62 75 67 3a d)))... (debug:
48a0: 70 72 69 6e 74 20 31 38 20 2a 64 65 66 61 75 6c print 18 *defaul
48b0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 28 66 6f 72 t-log-port* (for
48c0: 6d 61 74 20 23 66 20 66 6d 74 73 74 72 20 63 6d mat #f fmtstr cm
48d0: 64 20 28 76 65 63 74 6f 72 2d 72 65 66 20 63 6d d (vector-ref cm
48e0: 64 2d 64 61 74 20 30 29 20 28 76 65 63 74 6f 72 d-dat 0) (vector
48f0: 2d 72 65 66 20 63 6d 64 2d 64 61 74 20 31 29 20 -ref cmd-dat 1)
4900: 28 2f 20 28 76 65 63 74 6f 72 2d 72 65 66 20 63 (/ (vector-ref c
4910: 6d 64 2d 64 61 74 20 31 29 28 76 65 63 74 6f 72 md-dat 1)(vector
4920: 2d 72 65 66 20 63 6d 64 2d 64 61 74 20 30 29 29 -ref cmd-dat 0))
4930: 29 29 29 29 0a 09 20 20 20 20 20 20 28 73 6f 72 )))).. (sor
4940: 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 t (hash-table-ke
4950: 79 73 20 2a 64 62 2d 73 74 61 74 73 2a 29 0a 09 ys *db-stats*)..
4960: 09 20 20 20 20 28 6c 61 6d 62 64 61 20 28 61 20 . (lambda (a
4970: 62 29 0a 09 09 20 20 20 20 20 20 28 3e 20 28 76 b)... (> (v
4980: 65 63 74 6f 72 2d 72 65 66 20 28 68 61 73 68 2d ector-ref (hash-
4990: 74 61 62 6c 65 2d 72 65 66 20 2a 64 62 2d 73 74 table-ref *db-st
49a0: 61 74 73 2a 20 61 29 20 30 29 0a 09 09 09 20 28 ats* a) 0).... (
49b0: 76 65 63 74 6f 72 2d 72 65 66 20 28 68 61 73 68 vector-ref (hash
49c0: 2d 74 61 62 6c 65 2d 72 65 66 20 2a 64 62 2d 73 -table-ref *db-s
49d0: 74 61 74 73 2a 20 62 29 20 30 29 29 29 29 29 29 tats* b) 0))))))
49e0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a )..(define (rmt:
49f0: 67 65 74 2d 6d 61 78 2d 71 75 65 72 79 2d 61 76 get-max-query-av
4a00: 65 72 61 67 65 20 72 75 6e 2d 69 64 29 0a 20 20 erage run-id).
4a10: 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 64 62 (mutex-lock! *db
4a20: 2d 73 74 61 74 73 2d 6d 75 74 65 78 2a 29 0a 20 -stats-mutex*).
4a30: 20 28 6c 65 74 2a 20 28 28 72 75 6e 6b 65 79 20 (let* ((runkey
4a40: 28 63 6f 6e 63 20 22 72 75 6e 2d 69 64 3d 22 20 (conc "run-id="
4a50: 72 75 6e 2d 69 64 20 22 20 22 29 29 0a 09 20 28 run-id " ")).. (
4a60: 63 6d 64 73 20 20 20 28 66 69 6c 74 65 72 20 28 cmds (filter (
4a70: 6c 61 6d 62 64 61 20 28 78 29 0a 09 09 09 20 20 lambda (x)....
4a80: 20 28 73 75 62 73 74 72 69 6e 67 2d 69 6e 64 65 (substring-inde
4a90: 78 20 72 75 6e 6b 65 79 20 78 29 29 0a 09 09 09 x runkey x))....
4aa0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 (hash-table-key
4ab0: 73 20 2a 64 62 2d 73 74 61 74 73 2a 29 29 29 0a s *db-stats*))).
4ac0: 09 20 28 72 65 73 20 20 20 20 28 69 66 20 28 6e . (res (if (n
4ad0: 75 6c 6c 3f 20 63 6d 64 73 29 0a 09 09 20 20 20 ull? cmds)...
4ae0: 20 20 28 63 6f 6e 73 20 27 6e 6f 6e 65 20 30 29 (cons 'none 0)
4af0: 0a 09 09 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f ... (let loo
4b00: 70 20 28 28 63 6d 64 20 28 63 61 72 20 63 6d 64 p ((cmd (car cmd
4b10: 73 29 29 0a 09 09 09 09 28 74 61 6c 20 28 63 64 s)).....(tal (cd
4b20: 72 20 63 6d 64 73 29 29 0a 09 09 09 09 28 6d 61 r cmds)).....(ma
4b30: 78 2d 63 6d 64 20 28 63 61 72 20 63 6d 64 73 29 x-cmd (car cmds)
4b40: 29 0a 09 09 09 09 28 72 65 73 20 30 29 29 0a 09 ).....(res 0))..
4b50: 09 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 . (let* ((
4b60: 63 6d 64 2d 64 61 74 20 28 68 61 73 68 2d 74 61 cmd-dat (hash-ta
4b70: 62 6c 65 2d 72 65 66 20 2a 64 62 2d 73 74 61 74 ble-ref *db-stat
4b80: 73 2a 20 63 6d 64 29 29 0a 09 09 09 20 20 20 20 s* cmd))....
4b90: 20 20 28 74 6f 74 20 20 20 20 20 28 76 65 63 74 (tot (vect
4ba0: 6f 72 2d 72 65 66 20 63 6d 64 2d 64 61 74 20 30 or-ref cmd-dat 0
4bb0: 29 29 0a 09 09 09 20 20 20 20 20 20 28 63 75 72 )).... (cur
4bc0: 72 61 76 67 20 28 2f 20 28 76 65 63 74 6f 72 2d ravg (/ (vector-
4bd0: 72 65 66 20 63 6d 64 2d 64 61 74 20 31 29 20 28 ref cmd-dat 1) (
4be0: 76 65 63 74 6f 72 2d 72 65 66 20 63 6d 64 2d 64 vector-ref cmd-d
4bf0: 61 74 20 30 29 29 29 20 3b 3b 20 63 6f 75 6e 74 at 0))) ;; count
4c00: 20 69 73 20 6e 65 76 65 72 20 7a 65 72 6f 20 62 is never zero b
4c10: 79 20 63 6f 6e 73 74 72 75 63 74 69 6f 6e 0a 09 y construction..
4c20: 09 09 20 20 20 20 20 20 28 63 75 72 72 6d 61 78 .. (currmax
4c30: 20 28 6d 61 78 20 72 65 73 20 63 75 72 72 61 76 (max res currav
4c40: 67 29 29 0a 09 09 09 20 20 20 20 20 20 28 6e 65 g)).... (ne
4c50: 77 6d 61 78 2d 63 6d 64 20 28 69 66 20 28 3e 20 wmax-cmd (if (>
4c60: 63 75 72 72 61 76 67 20 72 65 73 29 20 63 6d 64 curravg res) cmd
4c70: 20 6d 61 78 2d 63 6d 64 29 29 29 0a 09 09 09 20 max-cmd)))....
4c80: 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a (if (null? tal).
4c90: 09 09 09 20 20 20 20 20 28 69 66 20 28 3e 20 74 ... (if (> t
4ca0: 6f 74 20 31 30 29 0a 09 09 09 09 20 28 63 6f 6e ot 10)..... (con
4cb0: 73 20 6e 65 77 6d 61 78 2d 63 6d 64 20 63 75 72 s newmax-cmd cur
4cc0: 72 6d 61 78 29 0a 09 09 09 09 20 28 63 6f 6e 73 rmax)..... (cons
4cd0: 20 27 6e 6f 6e 65 20 30 29 29 0a 09 09 09 20 20 'none 0))....
4ce0: 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 (loop (car ta
4cf0: 6c 29 28 63 64 72 20 74 61 6c 29 20 6e 65 77 6d l)(cdr tal) newm
4d00: 61 78 2d 63 6d 64 20 63 75 72 72 6d 61 78 29 29 ax-cmd currmax))
4d10: 29 29 29 29 29 0a 20 20 20 20 28 6d 75 74 65 78 ))))). (mutex
4d20: 2d 75 6e 6c 6f 63 6b 21 20 2a 64 62 2d 73 74 61 -unlock! *db-sta
4d30: 74 73 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 72 ts-mutex*). r
4d40: 65 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 es))..(define (r
4d50: 6d 74 3a 6f 70 65 6e 2d 71 72 79 2d 63 6c 6f 73 mt:open-qry-clos
4d60: 65 2d 6c 6f 63 61 6c 6c 79 20 63 6d 64 20 72 75 e-locally cmd ru
4d70: 6e 2d 69 64 20 70 61 72 61 6d 73 20 23 21 6b 65 n-id params #!ke
4d80: 79 20 28 72 65 6d 72 65 74 72 69 65 73 20 35 29 y (remretries 5)
4d90: 29 0a 20 20 28 6c 65 74 2a 20 28 28 71 72 79 2d ). (let* ((qry-
4da0: 69 73 2d 77 72 69 74 65 20 20 20 28 6e 6f 74 20 is-write (not
4db0: 28 6d 65 6d 62 65 72 20 63 6d 64 20 61 70 69 3a (member cmd api:
4dc0: 72 65 61 64 2d 6f 6e 6c 79 2d 71 75 65 72 69 65 read-only-querie
4dd0: 73 29 29 29 0a 09 20 28 64 62 2d 66 69 6c 65 2d s))).. (db-file-
4de0: 70 61 74 68 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 path (common:g
4df0: 65 74 2d 64 62 2d 74 6d 70 2d 61 72 65 61 29 29 et-db-tmp-area))
4e00: 20 3b 3b 20 64 62 3a 64 62 66 69 6c 65 2d 70 61 ;; db:dbfile-pa
4e10: 74 68 29 29 20 3b 3b 20 20 30 29 29 0a 09 20 28 th)) ;; 0)).. (
4e20: 64 62 73 74 72 75 63 74 2d 6c 6f 63 61 6c 20 28 dbstruct-local (
4e30: 64 62 3a 73 65 74 75 70 20 23 74 29 29 20 20 3b db:setup #t)) ;
4e40: 3b 20 6d 61 6b 65 2d 64 62 72 3a 64 62 73 74 72 ; make-dbr:dbstr
4e50: 75 63 74 20 70 61 74 68 3a 20 20 64 62 64 69 72 uct path: dbdir
4e60: 20 6c 6f 63 61 6c 3a 20 23 74 29 29 29 0a 09 20 local: #t)))..
4e70: 28 72 65 61 64 2d 6f 6e 6c 79 20 20 20 20 20 20 (read-only
4e80: 28 6e 6f 74 20 28 66 69 6c 65 2d 77 72 69 74 65 (not (file-write
4e90: 2d 61 63 63 65 73 73 3f 20 64 62 2d 66 69 6c 65 -access? db-file
4ea0: 2d 70 61 74 68 29 29 29 0a 09 20 28 73 74 61 72 -path))).. (star
4eb0: 74 20 20 20 20 20 20 20 20 20 20 28 63 75 72 72 t (curr
4ec0: 65 6e 74 2d 6d 69 6c 6c 69 73 65 63 6f 6e 64 73 ent-milliseconds
4ed0: 29 29 0a 09 20 28 72 65 73 64 61 74 20 20 20 20 )).. (resdat
4ee0: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 61 (if (not (a
4ef0: 6e 64 20 72 65 61 64 2d 6f 6e 6c 79 20 71 72 79 nd read-only qry
4f00: 2d 69 73 2d 77 72 69 74 65 29 29 0a 09 09 09 20 -is-write))....
4f10: 20 20 20 20 28 6c 65 74 20 28 28 76 20 28 61 70 (let ((v (ap
4f20: 69 3a 65 78 65 63 75 74 65 2d 72 65 71 75 65 73 i:execute-reques
4f30: 74 73 20 64 62 73 74 72 75 63 74 2d 6c 6f 63 61 ts dbstruct-loca
4f40: 6c 20 28 76 65 63 74 6f 72 20 28 73 79 6d 62 6f l (vector (symbo
4f50: 6c 2d 3e 73 74 72 69 6e 67 20 63 6d 64 29 20 70 l->string cmd) p
4f60: 61 72 61 6d 73 29 29 29 29 0a 09 09 09 20 20 20 arams))))....
4f70: 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 (handle-exce
4f80: 70 74 69 6f 6e 73 20 3b 3b 20 74 68 65 72 65 20 ptions ;; there
4f90: 68 61 73 20 62 65 65 6e 20 61 20 6c 6f 6e 67 20 has been a long
4fa0: 68 69 73 74 6f 72 79 20 6f 66 20 72 65 63 65 69 history of recei
4fb0: 76 69 6e 67 20 73 74 72 61 6e 67 65 20 65 72 72 ving strange err
4fc0: 6f 72 73 20 66 72 6f 6d 20 76 61 6c 75 65 73 20 ors from values
4fd0: 72 65 74 75 72 6e 65 64 20 62 79 20 74 68 65 20 returned by the
4fe0: 63 6c 69 65 6e 74 20 77 68 65 6e 20 74 68 69 6e client when thin
4ff0: 67 73 20 67 6f 20 77 72 6f 6e 67 2e 2e 0a 09 09 gs go wrong.....
5000: 09 09 65 78 6e 20 20 20 20 20 20 20 20 20 20 20 ..exn
5010: 20 20 20 20 3b 3b 20 20 54 68 69 73 20 69 73 20 ;; This is
5020: 61 6e 20 61 74 74 65 6d 70 74 20 74 6f 20 64 65 an attempt to de
5030: 74 65 63 74 20 74 68 61 74 20 73 69 74 75 61 74 tect that situat
5040: 69 6f 6e 20 61 6e 64 20 72 65 63 6f 76 65 72 20 ion and recover
5050: 67 72 61 63 65 66 75 6c 6c 79 0a 09 09 09 09 28 gracefully.....(
5060: 62 65 67 69 6e 0a 09 09 09 09 20 20 28 64 65 62 begin..... (deb
5070: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
5080: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 ult-log-port* "E
5090: 52 52 4f 52 3a 20 62 61 64 20 64 61 74 61 20 66 RROR: bad data f
50a0: 72 6f 6d 20 73 65 72 76 65 72 20 22 20 76 20 22 rom server " v "
50b0: 20 6d 65 73 73 61 67 65 3a 20 22 20 20 28 28 63 message: " ((c
50c0: 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 ondition-propert
50d0: 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 y-accessor 'exn
50e0: 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 20 22 'message) exn) "
50f0: 2c 20 65 78 6e 3d 22 20 65 78 6e 29 0a 09 09 09 , exn=" exn)....
5100: 09 20 20 28 76 65 63 74 6f 72 20 23 74 20 27 28 . (vector #t '(
5110: 29 29 29 20 3b 3b 20 73 68 6f 75 6c 64 20 61 6c ))) ;; should al
5120: 77 61 79 73 20 67 65 74 20 61 20 76 65 63 74 6f ways get a vecto
5130: 72 20 62 75 74 20 69 66 20 73 6f 6d 65 74 68 69 r but if somethi
5140: 6e 67 20 67 6f 65 73 20 77 72 6f 6e 67 20 72 65 ng goes wrong re
5150: 74 75 72 6e 20 61 20 64 75 6d 6d 79 0a 09 09 09 turn a dummy....
5160: 09 28 69 66 20 28 61 6e 64 20 28 76 65 63 74 6f .(if (and (vecto
5170: 72 3f 20 76 29 0a 09 09 09 09 09 20 28 3e 20 28 r? v)...... (> (
5180: 76 65 63 74 6f 72 2d 6c 65 6e 67 74 68 20 76 29 vector-length v)
5190: 20 31 29 29 0a 09 09 09 09 20 20 20 20 28 6c 65 1))..... (le
51a0: 74 20 28 28 6e 65 77 76 65 63 20 28 76 65 63 74 t ((newvec (vect
51b0: 6f 72 20 28 76 65 63 74 6f 72 2d 72 65 66 20 76 or (vector-ref v
51c0: 20 30 29 28 76 65 63 74 6f 72 2d 72 65 66 20 76 0)(vector-ref v
51d0: 20 31 29 29 29 29 0a 09 09 09 09 20 20 20 20 20 1)))).....
51e0: 20 6e 65 77 76 65 63 29 20 20 20 20 20 20 20 20 newvec)
51f0: 20 20 20 3b 3b 20 62 79 20 63 6f 70 79 69 6e 67 ;; by copying
5200: 20 74 68 65 20 76 65 63 74 6f 72 20 77 68 69 6c the vector whil
5210: 65 20 69 6e 73 69 64 65 20 74 68 65 20 65 72 72 e inside the err
5220: 6f 72 20 68 61 6e 64 6c 65 72 20 77 65 20 73 68 or handler we sh
5230: 6f 75 6c 64 20 66 6f 72 63 65 20 74 68 65 20 64 ould force the d
5240: 65 74 65 63 74 69 6f 6e 20 6f 66 20 61 20 63 6f etection of a co
5250: 72 72 75 70 74 65 64 20 72 65 63 6f 72 64 0a 09 rrupted record..
5260: 09 09 09 20 20 20 20 28 76 65 63 74 6f 72 20 23 ... (vector #
5270: 74 20 27 28 29 29 29 29 29 20 20 3b 3b 20 77 65 t '())))) ;; we
5280: 20 63 6f 75 6c 64 20 61 6c 73 6f 20 63 68 65 63 could also chec
5290: 6b 20 74 68 61 74 20 74 68 65 20 72 65 74 75 72 k that the retur
52a0: 6e 65 64 20 74 79 70 65 73 20 61 72 65 20 76 61 ned types are va
52b0: 6c 69 64 0a 09 09 09 20 20 20 20 20 28 76 65 63 lid.... (vec
52c0: 74 6f 72 20 23 74 20 27 28 29 29 29 29 0a 09 20 tor #t '())))..
52d0: 28 73 75 63 63 65 73 73 20 20 20 20 20 20 20 20 (success
52e0: 28 76 65 63 74 6f 72 2d 72 65 66 20 72 65 73 64 (vector-ref resd
52f0: 61 74 20 30 29 29 0a 09 20 28 72 65 73 20 20 20 at 0)).. (res
5300: 20 20 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 (vector
5310: 2d 72 65 66 20 72 65 73 64 61 74 20 31 29 29 0a -ref resdat 1)).
5320: 09 20 28 64 75 72 61 74 69 6f 6e 20 20 20 20 20 . (duration
5330: 20 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 6d 69 (- (current-mi
5340: 6c 6c 69 73 65 63 6f 6e 64 73 29 20 73 74 61 72 lliseconds) star
5350: 74 29 29 29 0a 20 20 20 20 28 69 66 20 28 61 6e t))). (if (an
5360: 64 20 72 65 61 64 2d 6f 6e 6c 79 20 71 72 79 2d d read-only qry-
5370: 69 73 2d 77 72 69 74 65 29 0a 20 20 20 20 20 20 is-write).
5380: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
5390: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
53a0: 72 74 2a 20 22 45 52 52 4f 52 3a 20 61 74 74 65 rt* "ERROR: atte
53b0: 6d 70 74 20 74 6f 20 77 72 69 74 65 20 74 6f 20 mpt to write to
53c0: 72 65 61 64 2d 6f 6e 6c 79 20 64 61 74 61 62 61 read-only databa
53d0: 73 65 20 69 67 6e 6f 72 65 64 2e 20 63 6d 64 3d se ignored. cmd=
53e0: 22 20 63 6d 64 29 29 0a 20 20 20 20 28 69 66 20 " cmd)). (if
53f0: 28 6e 6f 74 20 73 75 63 63 65 73 73 29 0a 09 28 (not success)..(
5400: 69 66 20 28 3e 20 72 65 6d 72 65 74 72 69 65 73 if (> remretries
5410: 20 30 29 0a 09 20 20 20 20 28 62 65 67 69 6e 0a 0).. (begin.
5420: 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
5430: 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 int-error 0 *def
5440: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
5450: 6c 6f 63 61 6c 20 71 75 65 72 79 20 66 61 69 6c local query fail
5460: 65 64 2e 20 54 72 79 69 6e 67 20 61 67 61 69 6e ed. Trying again
5470: 2e 22 29 0a 09 20 20 20 20 20 20 28 74 68 72 65 .").. (thre
5480: 61 64 2d 73 6c 65 65 70 21 20 28 2f 20 28 72 61 ad-sleep! (/ (ra
5490: 6e 64 6f 6d 20 35 30 30 30 29 20 31 30 30 30 29 ndom 5000) 1000)
54a0: 29 20 3b 3b 20 73 6f 6d 65 20 72 61 6e 64 6f 6d ) ;; some random
54b0: 20 64 65 6c 61 79 20 0a 09 20 20 20 20 20 20 28 delay .. (
54c0: 72 6d 74 3a 6f 70 65 6e 2d 71 72 79 2d 63 6c 6f rmt:open-qry-clo
54d0: 73 65 2d 6c 6f 63 61 6c 6c 79 20 63 6d 64 20 72 se-locally cmd r
54e0: 75 6e 2d 69 64 20 70 61 72 61 6d 73 20 72 65 6d un-id params rem
54f0: 72 65 74 72 69 65 73 3a 20 28 2d 20 72 65 6d 72 retries: (- remr
5500: 65 74 72 69 65 73 20 31 29 29 29 0a 09 20 20 20 etries 1)))..
5510: 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 (begin.. (
5520: 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f debug:print-erro
5530: 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 r 0 *default-log
5540: 2d 70 6f 72 74 2a 20 22 74 6f 6f 20 6d 61 6e 79 -port* "too many
5550: 20 72 65 74 72 69 65 73 20 69 6e 20 72 6d 74 3a retries in rmt:
5560: 6f 70 65 6e 2d 71 72 79 2d 63 6c 6f 73 65 2d 6c open-qry-close-l
5570: 6f 63 61 6c 6c 79 2c 20 67 69 76 69 6e 67 20 75 ocally, giving u
5580: 70 22 29 0a 09 20 20 20 20 20 20 23 66 29 29 0a p").. #f)).
5590: 09 28 62 65 67 69 6e 0a 09 20 20 3b 3b 20 28 72 .(begin.. ;; (r
55a0: 6d 74 3a 75 70 64 61 74 65 2d 64 62 2d 73 74 61 mt:update-db-sta
55b0: 74 73 20 72 75 6e 2d 69 64 20 63 6d 64 20 70 61 ts run-id cmd pa
55c0: 72 61 6d 73 20 64 75 72 61 74 69 6f 6e 29 0a 09 rams duration)..
55d0: 20 20 3b 3b 20 6d 61 72 6b 20 74 68 69 73 20 72 ;; mark this r
55e0: 75 6e 20 61 73 20 64 69 72 74 79 20 69 66 20 74 un as dirty if t
55f0: 68 69 73 20 77 61 73 20 61 20 77 72 69 74 65 2c his was a write,
5600: 20 74 68 65 20 77 61 74 63 68 64 6f 67 20 69 73 the watchdog is
5610: 20 72 65 73 70 6f 6e 73 69 62 6c 65 20 66 6f 72 responsible for
5620: 20 73 79 6e 63 69 6e 67 20 69 74 0a 09 20 20 28 syncing it.. (
5630: 69 66 20 71 72 79 2d 69 73 2d 77 72 69 74 65 0a if qry-is-write.
5640: 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 73 74 . (let ((st
5650: 61 72 74 2d 74 69 6d 65 20 28 63 75 72 72 65 6e art-time (curren
5660: 74 2d 73 65 63 6f 6e 64 73 29 29 29 0a 09 09 28 t-seconds)))...(
5670: 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 64 62 2d mutex-lock! *db-
5680: 6d 75 6c 74 69 2d 73 79 6e 63 2d 6d 75 74 65 78 multi-sync-mutex
5690: 2a 29 0a 09 09 28 73 65 74 21 20 2a 64 62 2d 6c *)...(set! *db-l
56a0: 61 73 74 2d 61 63 63 65 73 73 2a 20 73 74 61 72 ast-access* star
56b0: 74 2d 74 69 6d 65 29 20 20 3b 3b 20 54 48 49 53 t-time) ;; THIS
56c0: 20 49 53 20 50 52 4f 42 41 42 4c 59 20 55 53 45 IS PROBABLY USE
56d0: 4c 45 53 53 3f 20 28 77 65 20 61 72 65 20 6f 6e LESS? (we are on
56e0: 20 61 20 63 6c 69 65 6e 74 29 0a 20 20 20 20 20 a client).
56f0: 20 20 20 20 20 20 20 20 20 20 20 28 6d 75 74 65 (mute
5700: 78 2d 75 6e 6c 6f 63 6b 21 20 2a 64 62 2d 6d 75 x-unlock! *db-mu
5710: 6c 74 69 2d 73 79 6e 63 2d 6d 75 74 65 78 2a 29 lti-sync-mutex*)
5720: 29 29 29 29 0a 20 20 20 20 72 65 73 29 29 0a 0a )))). res))..
5730: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 73 65 6e (define (rmt:sen
5740: 64 2d 72 65 63 65 69 76 65 2d 6e 6f 2d 61 75 74 d-receive-no-aut
5750: 6f 2d 63 6c 69 65 6e 74 2d 73 65 74 75 70 20 63 o-client-setup c
5760: 6f 6e 6e 65 63 74 69 6f 6e 2d 69 6e 66 6f 20 63 onnection-info c
5770: 6d 64 20 72 75 6e 2d 69 64 20 70 61 72 61 6d 73 md run-id params
5780: 29 0a 20 20 28 6c 65 74 2a 20 28 28 72 75 6e 2d ). (let* ((run-
5790: 69 64 20 20 20 28 69 66 20 72 75 6e 2d 69 64 20 id (if run-id
57a0: 72 75 6e 2d 69 64 20 30 29 29 0a 09 20 28 72 65 run-id 0)).. (re
57b0: 73 20 20 09 20 20 20 28 68 61 6e 64 6c 65 2d 65 s . (handle-e
57c0: 78 63 65 70 74 69 6f 6e 73 0a 09 09 20 20 20 20 xceptions...
57d0: 20 20 20 65 78 6e 0a 09 09 20 20 20 20 20 28 62 exn... (b
57e0: 65 67 69 6e 0a 09 09 20 20 20 20 20 20 20 28 70 egin... (p
57f0: 72 69 6e 74 20 22 74 72 61 6e 73 70 6f 72 74 20 rint "transport
5800: 66 61 69 6c 65 64 2e 20 65 78 6e 3d 22 20 65 78 failed. exn=" ex
5810: 6e 29 0a 09 09 20 20 20 20 20 20 20 23 66 29 0a n)... #f).
5820: 09 09 20 20 20 20 20 28 68 74 74 70 2d 74 72 61 .. (http-tra
5830: 6e 73 70 6f 72 74 3a 63 6c 69 65 6e 74 2d 61 70 nsport:client-ap
5840: 69 2d 73 65 6e 64 2d 72 65 63 65 69 76 65 20 72 i-send-receive r
5850: 75 6e 2d 69 64 20 63 6f 6e 6e 65 63 74 69 6f 6e un-id connection
5860: 2d 69 6e 66 6f 20 63 6d 64 20 70 61 72 61 6d 73 -info cmd params
5870: 29 29 29 29 0a 20 20 20 20 28 69 66 20 28 61 6e )))). (if (an
5880: 64 20 72 65 73 20 28 76 65 63 74 6f 72 2d 72 65 d res (vector-re
5890: 66 20 72 65 73 20 30 29 29 0a 09 28 76 65 63 74 f res 0))..(vect
58a0: 6f 72 2d 72 65 66 20 72 65 73 20 31 29 20 3b 3b or-ref res 1) ;;
58b0: 3b 20 59 45 53 21 21 20 54 48 49 53 20 49 53 20 ; YES!! THIS IS
58c0: 43 4f 52 52 45 43 54 21 21 20 43 48 41 4e 47 45 CORRECT!! CHANGE
58d0: 20 49 54 20 48 45 52 45 2c 20 54 48 45 4e 20 43 IT HERE, THEN C
58e0: 48 41 4e 47 45 20 72 6d 74 3a 73 65 6e 64 2d 72 HANGE rmt:send-r
58f0: 65 63 65 69 76 65 20 41 4c 53 4f 21 21 21 0a 09 eceive ALSO!!!..
5900: 23 66 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d #f)))..;;=======
5910: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5920: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5930: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5940: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
5950: 3b 3b 0a 3b 3b 20 41 20 43 20 54 20 55 20 41 20 ;;.;; A C T U A
5960: 4c 20 20 20 41 20 50 20 49 20 20 20 43 20 41 20 L A P I C A
5970: 4c 20 4c 20 53 20 20 0a 3b 3b 0a 3b 3b 3d 3d 3d L L S .;;.;;===
5980: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5990: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
59a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
59b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
59c0: 3d 3d 3d 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d ===..;;=========
59d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
59e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
59f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5a00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
5a10: 20 20 53 20 45 20 52 20 56 20 45 20 52 0a 3b 3b S E R V E R.;;
5a20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5a30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5a40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5a50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5a60: 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 ======..(define
5a70: 28 72 6d 74 3a 6b 69 6c 6c 2d 73 65 72 76 65 72 (rmt:kill-server
5a80: 20 72 75 6e 2d 69 64 29 0a 20 20 28 72 6d 74 3a run-id). (rmt:
5a90: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 6b 69 send-receive 'ki
5aa0: 6c 6c 2d 73 65 72 76 65 72 20 72 75 6e 2d 69 64 ll-server run-id
5ab0: 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 29 29 29 (list run-id)))
5ac0: 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 73 ..(define (rmt:s
5ad0: 74 61 72 74 2d 73 65 72 76 65 72 20 72 75 6e 2d tart-server run-
5ae0: 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d id). (rmt:send-
5af0: 72 65 63 65 69 76 65 20 27 73 74 61 72 74 2d 73 receive 'start-s
5b00: 65 72 76 65 72 20 30 20 28 6c 69 73 74 20 72 75 erver 0 (list ru
5b10: 6e 2d 69 64 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d n-id)))..;;=====
5b20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5b30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5b40: 3d 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 0a 3b 3b 20 20 4d 20 49 20 53 20 43 0a 3b 3b =.;; M I S C.;;
5b70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5b80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5b90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5ba0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5bb0: 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 ======..(define
5bc0: 28 72 6d 74 3a 6c 6f 67 69 6e 20 72 75 6e 2d 69 (rmt:login run-i
5bd0: 64 29 0a 20 20 28 61 73 73 65 72 74 20 2a 6d 79 d). (assert *my
5be0: 2d 63 6c 69 65 6e 74 2d 73 69 67 6e 61 74 75 72 -client-signatur
5bf0: 65 2a 20 22 45 52 52 4f 52 3a 20 6c 6f 67 69 6e e* "ERROR: login
5c00: 20 61 74 74 65 6d 70 74 65 64 20 77 69 74 68 6f attempted witho
5c10: 75 74 20 66 69 72 73 74 20 63 61 6c 6c 69 6e 67 ut first calling
5c20: 20 28 63 6c 69 65 6e 74 3a 67 65 74 2d 73 69 67 (client:get-sig
5c30: 6e 61 74 75 72 65 29 2e 22 29 0a 20 20 28 72 6d nature)."). (rm
5c40: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
5c50: 6c 6f 67 69 6e 20 72 75 6e 2d 69 64 20 28 6c 69 login run-id (li
5c60: 73 74 20 2a 74 6f 70 70 61 74 68 2a 20 6d 65 67 st *toppath* meg
5c70: 61 74 65 73 74 2d 76 65 72 73 69 6f 6e 20 2a 6d atest-version *m
5c80: 79 2d 63 6c 69 65 6e 74 2d 73 69 67 6e 61 74 75 y-client-signatu
5c90: 72 65 2a 29 29 29 0a 0a 3b 3b 20 54 68 69 73 20 re*)))..;; This
5ca0: 6c 6f 67 69 6e 20 64 6f 65 73 20 6e 6f 20 72 65 login does no re
5cb0: 74 72 69 65 73 20 75 6e 64 65 72 20 74 68 65 20 tries under the
5cc0: 68 6f 6f 64 20 2d 20 69 74 20 61 63 74 73 20 61 hood - it acts a
5cd0: 20 62 69 74 20 6c 69 6b 65 20 61 20 70 69 6e 67 bit like a ping
5ce0: 2e 0a 3b 3b 20 44 65 70 72 65 63 61 74 65 64 20 ..;; Deprecated
5cf0: 66 6f 72 20 6e 6d 73 67 2d 74 72 61 6e 73 70 6f for nmsg-transpo
5d00: 72 74 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 rt..;;.(define (
5d10: 72 6d 74 3a 6c 6f 67 69 6e 2d 6e 6f 2d 61 75 74 rmt:login-no-aut
5d20: 6f 2d 63 6c 69 65 6e 74 2d 73 65 74 75 70 20 63 o-client-setup c
5d30: 6f 6e 6e 65 63 74 69 6f 6e 2d 69 6e 66 6f 29 0a onnection-info).
5d40: 20 20 28 63 61 73 65 20 2a 74 72 61 6e 73 70 6f (case *transpo
5d50: 72 74 2d 74 79 70 65 2a 20 3b 3b 20 72 75 6e 2d rt-type* ;; run-
5d60: 69 64 20 6f 66 20 30 20 69 73 20 6a 75 73 74 20 id of 0 is just
5d70: 61 20 70 6c 61 63 65 68 6f 6c 64 65 72 0a 20 20 a placeholder.
5d80: 20 20 28 28 68 74 74 70 29 28 72 6d 74 3a 73 65 ((http)(rmt:se
5d90: 6e 64 2d 72 65 63 65 69 76 65 2d 6e 6f 2d 61 75 nd-receive-no-au
5da0: 74 6f 2d 63 6c 69 65 6e 74 2d 73 65 74 75 70 20 to-client-setup
5db0: 63 6f 6e 6e 65 63 74 69 6f 6e 2d 69 6e 66 6f 20 connection-info
5dc0: 27 6c 6f 67 69 6e 20 30 20 28 6c 69 73 74 20 2a 'login 0 (list *
5dd0: 74 6f 70 70 61 74 68 2a 20 6d 65 67 61 74 65 73 toppath* megates
5de0: 74 2d 76 65 72 73 69 6f 6e 20 2a 6d 79 2d 63 6c t-version *my-cl
5df0: 69 65 6e 74 2d 73 69 67 6e 61 74 75 72 65 2a 29 ient-signature*)
5e00: 29 29 0a 20 20 20 20 3b 3b 28 28 6e 6d 73 67 29 )). ;;((nmsg)
5e10: 28 6e 6d 73 67 2d 74 72 61 6e 73 70 6f 72 74 3a (nmsg-transport:
5e20: 63 6c 69 65 6e 74 2d 61 70 69 2d 73 65 6e 64 2d client-api-send-
5e30: 72 65 63 65 69 76 65 20 72 75 6e 2d 69 64 20 63 receive run-id c
5e40: 6f 6e 6e 65 63 74 69 6f 6e 2d 69 6e 66 6f 20 27 onnection-info '
5e50: 6c 6f 67 69 6e 20 28 6c 69 73 74 20 2a 74 6f 70 login (list *top
5e60: 70 61 74 68 2a 20 6d 65 67 61 74 65 73 74 2d 76 path* megatest-v
5e70: 65 72 73 69 6f 6e 20 72 75 6e 2d 69 64 20 2a 6d ersion run-id *m
5e80: 79 2d 63 6c 69 65 6e 74 2d 73 69 67 6e 61 74 75 y-client-signatu
5e90: 72 65 2a 29 29 29 0a 20 20 20 20 29 29 0a 0a 3b re*))). ))..;
5ea0: 3b 20 68 61 6e 64 20 6f 66 66 20 61 20 63 61 6c ; hand off a cal
5eb0: 6c 20 74 6f 20 6f 6e 65 20 6f 66 20 74 68 65 20 l to one of the
5ec0: 64 62 3a 71 75 65 72 69 65 73 20 73 74 61 74 65 db:queries state
5ed0: 6d 65 6e 74 73 0a 3b 3b 20 61 64 64 65 64 20 72 ments.;; added r
5ee0: 75 6e 2d 69 64 20 74 6f 20 6d 61 6b 65 20 6c 6f un-id to make lo
5ef0: 6f 6b 69 6e 67 20 75 70 20 74 68 65 20 63 6f 72 oking up the cor
5f00: 72 65 63 74 20 64 62 20 70 6f 73 73 69 62 6c 65 rect db possible
5f10: 20 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 72 6d .;;.(define (rm
5f20: 74 3a 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 73 t:general-call s
5f30: 74 6d 74 6e 61 6d 65 20 72 75 6e 2d 69 64 20 2e tmtname run-id .
5f40: 20 70 61 72 61 6d 73 29 0a 20 20 28 72 6d 74 3a params). (rmt:
5f50: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 send-receive 'ge
5f60: 6e 65 72 61 6c 2d 63 61 6c 6c 20 72 75 6e 2d 69 neral-call run-i
5f70: 64 20 28 61 70 70 65 6e 64 20 28 6c 69 73 74 20 d (append (list
5f80: 73 74 6d 74 6e 61 6d 65 20 72 75 6e 2d 69 64 29 stmtname run-id)
5f90: 20 70 61 72 61 6d 73 29 29 29 0a 0a 0a 3b 3b 20 params)))...;;
5fa0: 67 69 76 65 6e 20 61 20 68 6f 73 74 6e 61 6d 65 given a hostname
5fb0: 2c 20 72 65 74 75 72 6e 20 61 20 70 61 69 72 20 , return a pair
5fc0: 6f 66 20 63 70 75 20 6c 6f 61 64 20 61 6e 64 20 of cpu load and
5fd0: 75 70 64 61 74 65 20 74 69 6d 65 20 72 65 70 72 update time repr
5fe0: 65 73 65 6e 74 69 6e 67 20 6c 61 74 65 73 74 20 esenting latest
5ff0: 69 6e 74 65 6c 6c 69 67 65 6e 63 65 20 66 72 6f intelligence fro
6000: 6d 20 74 65 73 74 73 20 72 75 6e 6e 69 6e 67 20 m tests running
6010: 6f 6e 20 74 68 61 74 20 68 6f 73 74 0a 28 64 65 on that host.(de
6020: 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 6c 61 fine (rmt:get-la
6030: 74 65 73 74 2d 68 6f 73 74 2d 6c 6f 61 64 20 68 test-host-load h
6040: 6f 73 74 6e 61 6d 65 29 0a 20 20 28 72 6d 74 3a ostname). (rmt:
6050: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 send-receive 'ge
6060: 74 2d 6c 61 74 65 73 74 2d 68 6f 73 74 2d 6c 6f t-latest-host-lo
6070: 61 64 20 30 20 28 6c 69 73 74 20 68 6f 73 74 6e ad 0 (list hostn
6080: 61 6d 65 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ame)))..(define
6090: 28 72 6d 74 3a 73 64 62 2d 71 72 79 20 71 72 79 (rmt:sdb-qry qry
60a0: 20 76 61 6c 20 72 75 6e 2d 69 64 29 0a 20 20 3b val run-id). ;
60b0: 3b 20 61 64 64 20 63 61 63 68 69 6e 67 20 69 66 ; add caching if
60c0: 20 71 72 79 20 69 73 20 27 67 65 74 69 64 20 6f qry is 'getid o
60d0: 72 20 27 67 65 74 73 74 72 0a 20 20 28 72 6d 74 r 'getstr. (rmt
60e0: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 73 :send-receive 's
60f0: 64 62 2d 71 72 79 20 72 75 6e 2d 69 64 20 28 6c db-qry run-id (l
6100: 69 73 74 20 71 72 79 20 76 61 6c 29 29 29 0a 0a ist qry val)))..
6110: 3b 3b 20 4e 4f 54 20 43 4f 4d 50 4c 45 54 45 44 ;; NOT COMPLETED
6120: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 72 75 .(define (rmt:ru
6130: 6e 74 65 73 74 73 20 75 73 65 72 20 72 75 6e 2d ntests user run-
6140: 69 64 20 74 65 73 74 70 61 74 74 20 70 61 72 61 id testpatt para
6150: 6d 73 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d ms). (rmt:send-
6160: 72 65 63 65 69 76 65 20 27 72 75 6e 74 65 73 74 receive 'runtest
6170: 73 20 72 75 6e 2d 69 64 20 74 65 73 74 70 61 74 s run-id testpat
6180: 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d t))..(define (rm
6190: 74 3a 67 65 74 2d 72 75 6e 2d 72 65 63 6f 72 64 t:get-run-record
61a0: 2d 69 64 73 20 20 74 61 72 67 65 74 20 72 75 6e -ids target run
61b0: 20 6b 65 79 6e 61 6d 65 73 20 74 65 73 74 2d 70 keynames test-p
61c0: 61 74 74 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 att). (rmt:send
61d0: 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 72 75 -receive 'get-ru
61e0: 6e 2d 72 65 63 6f 72 64 2d 69 64 73 20 23 66 20 n-record-ids #f
61f0: 28 6c 69 73 74 20 74 61 72 67 65 74 20 72 75 6e (list target run
6200: 20 6b 65 79 6e 61 6d 65 73 20 74 65 73 74 2d 70 keynames test-p
6210: 61 74 74 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 att)))..(define
6220: 28 72 6d 74 3a 67 65 74 2d 63 68 61 6e 67 65 64 (rmt:get-changed
6230: 2d 72 65 63 6f 72 64 2d 69 64 73 20 73 69 6e 63 -record-ids sinc
6240: 65 2d 74 69 6d 65 29 0a 20 20 28 72 6d 74 3a 73 e-time). (rmt:s
6250: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 end-receive 'get
6260: 2d 63 68 61 6e 67 65 64 2d 72 65 63 6f 72 64 2d -changed-record-
6270: 69 64 73 20 23 66 20 28 6c 69 73 74 20 73 69 6e ids #f (list sin
6280: 63 65 2d 74 69 6d 65 29 29 20 29 0a 0a 28 64 65 ce-time)) )..(de
6290: 66 69 6e 65 20 28 72 6d 74 3a 64 72 6f 70 2d 61 fine (rmt:drop-a
62a0: 6c 6c 2d 74 72 69 67 67 65 72 73 29 0a 20 20 20 ll-triggers).
62b0: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
62c0: 69 76 65 20 27 64 72 6f 70 2d 61 6c 6c 2d 74 72 ive 'drop-all-tr
62d0: 69 67 67 65 72 73 20 23 66 20 27 28 29 29 29 0a iggers #f '())).
62e0: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 63 72 .(define (rmt:cr
62f0: 65 61 74 65 2d 61 6c 6c 2d 74 72 69 67 67 65 72 eate-all-trigger
6300: 73 29 0a 20 20 20 20 20 28 72 6d 74 3a 73 65 6e s). (rmt:sen
6310: 64 2d 72 65 63 65 69 76 65 20 27 63 72 65 61 74 d-receive 'creat
6320: 65 2d 61 6c 6c 2d 74 72 69 67 67 65 72 73 20 23 e-all-triggers #
6330: 66 20 27 28 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d f '()))..;;=====
6340: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6350: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6360: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6370: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6380: 3d 0a 3b 3b 20 20 54 20 45 20 53 20 54 20 20 20 =.;; T E S T
6390: 4d 20 45 20 54 20 41 20 0a 3b 3b 3d 3d 3d 3d 3d M E T A .;;=====
63a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
63b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
63c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
63d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
63e0: 3d 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a =..(define (rmt:
63f0: 67 65 74 2d 74 65 73 74 73 2d 74 61 67 73 29 0a get-tests-tags).
6400: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
6410: 69 76 65 20 27 67 65 74 2d 74 65 73 74 73 2d 74 ive 'get-tests-t
6420: 61 67 73 20 23 66 20 27 28 29 29 29 0a 0a 3b 3b ags #f '()))..;;
6430: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6440: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6450: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6460: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6470: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 4b 20 45 20 59 ======.;; K E Y
6480: 20 53 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d S .;;==========
6490: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
64a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
64b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
64c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b ============..;;
64d0: 20 54 68 65 73 65 20 72 65 71 75 69 72 65 20 72 These require r
64e0: 75 6e 2d 69 64 20 62 65 63 61 75 73 65 20 74 68 un-id because th
64f0: 65 20 76 61 6c 75 65 73 20 63 6f 6d 65 20 66 72 e values come fr
6500: 6f 6d 20 74 68 65 20 72 75 6e 21 0a 3b 3b 0a 28 om the run!.;;.(
6510: 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d define (rmt:get-
6520: 6b 65 79 2d 76 61 6c 2d 70 61 69 72 73 20 72 75 key-val-pairs ru
6530: 6e 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e n-id). (rmt:sen
6540: 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 6b d-receive 'get-k
6550: 65 79 2d 76 61 6c 2d 70 61 69 72 73 20 72 75 6e ey-val-pairs run
6560: 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 -id (list run-id
6570: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d )))..(define (rm
6580: 74 3a 67 65 74 2d 6b 65 79 73 29 0a 20 20 28 69 t:get-keys). (i
6590: 66 20 2a 64 62 2d 6b 65 79 73 2a 20 2a 64 62 2d f *db-keys* *db-
65a0: 6b 65 79 73 2a 20 0a 20 20 20 20 20 28 6c 65 74 keys* . (let
65b0: 20 28 28 72 65 73 20 28 72 6d 74 3a 73 65 6e 64 ((res (rmt:send
65c0: 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 6b 65 -receive 'get-ke
65d0: 79 73 20 23 66 20 27 28 29 29 29 29 0a 20 20 20 ys #f '()))).
65e0: 20 20 20 20 28 73 65 74 21 20 2a 64 62 2d 6b 65 (set! *db-ke
65f0: 79 73 2a 20 72 65 73 29 0a 20 20 20 20 20 20 20 ys* res).
6600: 72 65 73 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 res)))..(define
6610: 28 72 6d 74 3a 67 65 74 2d 6b 65 79 73 2d 77 72 (rmt:get-keys-wr
6620: 69 74 65 29 20 3b 3b 20 64 75 6d 6d 79 20 71 75 ite) ;; dummy qu
6630: 65 72 79 20 74 6f 20 66 6f 72 63 65 20 73 65 72 ery to force ser
6640: 76 65 72 20 73 74 61 72 74 0a 20 20 28 6c 65 74 ver start. (let
6650: 20 28 28 72 65 73 20 28 72 6d 74 3a 73 65 6e 64 ((res (rmt:send
6660: 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 6b 65 -receive 'get-ke
6670: 79 73 2d 77 72 69 74 65 20 23 66 20 27 28 29 29 ys-write #f '())
6680: 29 29 0a 20 20 20 20 28 73 65 74 21 20 2a 64 62 )). (set! *db
6690: 2d 6b 65 79 73 2a 20 72 65 73 29 0a 20 20 20 20 -keys* res).
66a0: 72 65 73 29 29 0a 0a 3b 3b 20 77 65 20 64 6f 6e res))..;; we don
66b0: 27 74 20 72 65 75 73 65 20 72 75 6e 2d 69 64 27 't reuse run-id'
66c0: 73 20 28 65 78 63 65 70 74 20 70 6f 73 73 69 62 s (except possib
66d0: 6c 79 20 2a 61 66 74 65 72 2a 20 61 20 64 62 20 ly *after* a db
66e0: 63 6c 65 61 6e 75 70 29 20 73 6f 20 69 74 20 69 cleanup) so it i
66f0: 73 20 73 61 66 65 0a 3b 3b 20 74 6f 20 63 61 63 s safe.;; to cac
6700: 68 65 20 74 68 65 20 72 65 73 75 6c 73 20 69 6e he the resuls in
6710: 20 61 20 68 61 73 68 0a 3b 3b 0a 28 64 65 66 69 a hash.;;.(defi
6720: 6e 65 20 28 72 6d 74 3a 67 65 74 2d 6b 65 79 2d ne (rmt:get-key-
6730: 76 61 6c 73 20 72 75 6e 2d 69 64 29 0a 20 20 28 vals run-id). (
6740: 6f 72 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 or (hash-table-r
6750: 65 66 2f 64 65 66 61 75 6c 74 20 2a 6b 65 79 76 ef/default *keyv
6760: 61 6c 73 2a 20 72 75 6e 2d 69 64 20 23 66 29 0a als* run-id #f).
6770: 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 (let ((res
6780: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
6790: 76 65 20 27 67 65 74 2d 6b 65 79 2d 76 61 6c 73 ve 'get-key-vals
67a0: 20 23 66 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 #f (list run-id
67b0: 29 29 29 29 0a 20 20 20 20 20 20 20 20 28 68 61 )))). (ha
67c0: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a 6b sh-table-set! *k
67d0: 65 79 76 61 6c 73 2a 20 72 75 6e 2d 69 64 20 72 eyvals* run-id r
67e0: 65 73 29 0a 20 20 20 20 20 20 20 20 72 65 73 29 es). res)
67f0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
6800: 3a 67 65 74 2d 74 61 72 67 65 74 73 29 0a 20 20 :get-targets).
6810: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
6820: 65 20 27 67 65 74 2d 74 61 72 67 65 74 73 20 23 e 'get-targets #
6830: 66 20 27 28 29 29 29 0a 0a 28 64 65 66 69 6e 65 f '()))..(define
6840: 20 28 72 6d 74 3a 67 65 74 2d 74 61 72 67 65 74 (rmt:get-target
6850: 20 72 75 6e 2d 69 64 29 0a 20 20 28 72 6d 74 3a run-id). (rmt:
6860: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 send-receive 'ge
6870: 74 2d 74 61 72 67 65 74 20 72 75 6e 2d 69 64 20 t-target run-id
6880: 28 6c 69 73 74 20 72 75 6e 2d 69 64 29 29 29 0a (list run-id))).
6890: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 .(define (rmt:ge
68a0: 74 2d 72 75 6e 2d 74 69 6d 65 73 20 72 75 6e 70 t-run-times runp
68b0: 61 74 74 20 74 61 72 67 65 74 70 61 74 74 29 0a att targetpatt).
68c0: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
68d0: 69 76 65 20 27 67 65 74 2d 72 75 6e 2d 74 69 6d ive 'get-run-tim
68e0: 65 73 20 23 66 20 28 6c 69 73 74 20 72 75 6e 70 es #f (list runp
68f0: 61 74 74 20 74 61 72 67 65 74 70 61 74 74 20 29 att targetpatt )
6900: 29 29 20 0a 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d )) ...;;========
6910: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6920: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6930: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6940: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
6950: 3b 20 20 54 20 45 20 53 20 54 20 53 0a 3b 3b 3d ; T E S T S.;;=
6960: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6970: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6980: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6990: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
69a0: 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 4a 75 73 74 20 73 =====..;; Just s
69b0: 6f 6d 65 20 73 79 6e 74 61 74 69 63 20 73 75 67 ome syntatic sug
69c0: 61 72 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a ar.(define (rmt:
69d0: 72 65 67 69 73 74 65 72 2d 74 65 73 74 20 72 75 register-test ru
69e0: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 n-id test-name i
69f0: 74 65 6d 2d 70 61 74 68 29 0a 20 20 28 72 6d 74 tem-path). (rmt
6a00: 3a 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 72 :general-call 'r
6a10: 65 67 69 73 74 65 72 2d 74 65 73 74 20 72 75 6e egister-test run
6a20: 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d -id run-id test-
6a30: 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 name item-path))
6a40: 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 ..(define (rmt:g
6a50: 65 74 2d 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 et-test-id run-i
6a60: 64 20 74 65 73 74 6e 61 6d 65 20 69 74 65 6d 2d d testname item-
6a70: 70 61 74 68 29 0a 20 20 28 72 6d 74 3a 73 65 6e path). (rmt:sen
6a80: 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 74 d-receive 'get-t
6a90: 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 28 6c est-id run-id (l
6aa0: 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 6e ist run-id testn
6ab0: 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 29 ame item-path)))
6ac0: 0a 0a 3b 3b 20 72 75 6e 2d 69 64 20 69 73 20 4e ..;; run-id is N
6ad0: 4f 54 20 75 73 65 64 0a 3b 3b 0a 28 64 65 66 69 OT used.;;.(defi
6ae0: 6e 65 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 ne (rmt:get-test
6af0: 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 72 75 6e 2d -info-by-id run-
6b00: 69 64 20 74 65 73 74 2d 69 64 29 0a 20 20 28 69 id test-id). (i
6b10: 66 20 28 6e 75 6d 62 65 72 3f 20 74 65 73 74 2d f (number? test-
6b20: 69 64 29 0a 20 20 20 20 20 20 28 72 6d 74 3a 73 id). (rmt:s
6b30: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 end-receive 'get
6b40: 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 -test-info-by-id
6b50: 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 run-id (list ru
6b60: 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 29 0a 20 n-id test-id)).
6b70: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 28 64 65 (begin..(de
6b80: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
6b90: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
6ba0: 57 41 52 4e 49 4e 47 3a 20 42 61 64 20 64 61 74 WARNING: Bad dat
6bb0: 61 20 68 61 6e 64 65 64 20 74 6f 20 72 6d 74 3a a handed to rmt:
6bc0: 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 get-test-info-by
6bd0: 2d 69 64 20 72 75 6e 2d 69 64 3d 22 20 72 75 6e -id run-id=" run
6be0: 2d 69 64 20 22 2c 20 74 65 73 74 2d 69 64 3d 22 -id ", test-id="
6bf0: 20 74 65 73 74 2d 69 64 29 0a 09 28 70 72 69 6e test-id)..(prin
6c00: 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 20 28 63 75 t-call-chain (cu
6c10: 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 rrent-error-port
6c20: 29 29 0a 09 23 66 29 29 29 0a 0a 28 64 65 66 69 ))..#f)))..(defi
6c30: 6e 65 20 28 72 6d 74 3a 74 65 73 74 2d 67 65 74 ne (rmt:test-get
6c40: 2d 72 75 6e 64 69 72 2d 66 72 6f 6d 2d 74 65 73 -rundir-from-tes
6c50: 74 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 t-id run-id test
6c60: 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 -id). (rmt:send
6c70: 2d 72 65 63 65 69 76 65 20 27 74 65 73 74 2d 67 -receive 'test-g
6c80: 65 74 2d 72 75 6e 64 69 72 2d 66 72 6f 6d 2d 74 et-rundir-from-t
6c90: 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 28 6c est-id run-id (l
6ca0: 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d ist run-id test-
6cb0: 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 id)))..(define (
6cc0: 72 6d 74 3a 6f 70 65 6e 2d 74 65 73 74 2d 64 62 rmt:open-test-db
6cd0: 2d 62 79 2d 74 65 73 74 2d 69 64 20 72 75 6e 2d -by-test-id run-
6ce0: 69 64 20 74 65 73 74 2d 69 64 20 23 21 6b 65 79 id test-id #!key
6cf0: 20 28 77 6f 72 6b 2d 61 72 65 61 20 23 66 29 29 (work-area #f))
6d00: 0a 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 2d . (let* ((test-
6d10: 70 61 74 68 20 28 69 66 20 28 73 74 72 69 6e 67 path (if (string
6d20: 3f 20 77 6f 72 6b 2d 61 72 65 61 29 0a 09 09 09 ? work-area)....
6d30: 77 6f 72 6b 2d 61 72 65 61 0a 09 09 09 28 72 6d work-area....(rm
6d40: 74 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 t:test-get-rundi
6d50: 72 2d 66 72 6f 6d 2d 74 65 73 74 2d 69 64 20 72 r-from-test-id r
6d60: 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 29 29 un-id test-id)))
6d70: 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 ). (debug:pri
6d80: 6e 74 20 33 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 3 *default-lo
6d90: 67 2d 70 6f 72 74 2a 20 22 54 45 53 54 20 50 41 g-port* "TEST PA
6da0: 54 48 3a 20 22 20 74 65 73 74 2d 70 61 74 68 29 TH: " test-path)
6db0: 0a 20 20 20 20 28 6f 70 65 6e 2d 74 65 73 74 2d . (open-test-
6dc0: 64 62 20 74 65 73 74 2d 70 61 74 68 29 29 29 0a db test-path))).
6dd0: 0a 3b 3b 20 57 41 52 4e 49 4e 47 3a 20 54 68 69 .;; WARNING: Thi
6de0: 73 20 63 75 72 72 65 6e 74 6c 79 20 62 79 70 61 s currently bypa
6df0: 73 73 65 73 20 74 68 65 20 74 72 61 6e 73 61 63 sses the transac
6e00: 74 69 6f 6e 20 77 72 61 70 70 65 64 20 77 72 69 tion wrapped wri
6e10: 74 65 73 20 73 79 73 74 65 6d 0a 28 64 65 66 69 tes system.(defi
6e20: 6e 65 20 28 72 6d 74 3a 74 65 73 74 2d 73 65 74 ne (rmt:test-set
6e30: 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d 62 79 -state-status-by
6e40: 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d -id run-id test-
6e50: 69 64 20 6e 65 77 73 74 61 74 65 20 6e 65 77 73 id newstate news
6e60: 74 61 74 75 73 20 6e 65 77 63 6f 6d 6d 65 6e 74 tatus newcomment
6e70: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
6e80: 63 65 69 76 65 20 27 74 65 73 74 2d 73 65 74 2d ceive 'test-set-
6e90: 73 74 61 74 65 2d 73 74 61 74 75 73 2d 62 79 2d state-status-by-
6ea0: 69 64 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 id run-id (list
6eb0: 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 6e run-id test-id n
6ec0: 65 77 73 74 61 74 65 20 6e 65 77 73 74 61 74 75 ewstate newstatu
6ed0: 73 20 6e 65 77 63 6f 6d 6d 65 6e 74 29 29 29 0a s newcomment))).
6ee0: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 73 65 .(define (rmt:se
6ef0: 74 2d 74 65 73 74 73 2d 73 74 61 74 65 2d 73 74 t-tests-state-st
6f00: 61 74 75 73 20 72 75 6e 2d 69 64 20 20 20 20 20 atus run-id
6f10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6f20: 20 74 65 73 74 6e 61 6d 65 73 20 63 75 72 72 73 testnames currs
6f30: 74 61 74 65 20 63 75 72 72 73 74 61 74 75 73 20 tate currstatus
6f40: 6e 65 77 73 74 61 74 65 20 6e 65 77 73 74 61 74 newstate newstat
6f50: 75 73 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d us). (rmt:send-
6f60: 72 65 63 65 69 76 65 20 27 73 65 74 2d 74 65 73 receive 'set-tes
6f70: 74 73 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 ts-state-status
6f80: 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e run-id (list run
6f90: 2d 69 64 20 74 65 73 74 6e 61 6d 65 73 20 63 75 -id testnames cu
6fa0: 72 72 73 74 61 74 65 20 63 75 72 72 73 74 61 74 rrstate currstat
6fb0: 75 73 20 6e 65 77 73 74 61 74 65 20 6e 65 77 73 us newstate news
6fc0: 74 61 74 75 73 29 29 29 0a 0a 28 64 65 66 69 6e tatus)))..(defin
6fd0: 65 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 73 e (rmt:get-tests
6fe0: 2d 66 6f 72 2d 72 75 6e 20 72 75 6e 2d 69 64 20 -for-run run-id
6ff0: 74 65 73 74 70 61 74 74 20 73 74 61 74 65 73 20 testpatt states
7000: 73 74 61 74 75 73 65 73 20 6f 66 66 73 65 74 20 statuses offset
7010: 6c 69 6d 69 74 20 6e 6f 74 2d 69 6e 20 73 6f 72 limit not-in sor
7020: 74 2d 62 79 20 73 6f 72 74 2d 6f 72 64 65 72 20 t-by sort-order
7030: 71 72 79 76 61 6c 73 20 6c 61 73 74 2d 75 70 64 qryvals last-upd
7040: 61 74 65 20 6d 6f 64 65 29 0a 20 20 3b 3b 20 28 ate mode). ;; (
7050: 69 66 20 28 6e 75 6d 62 65 72 3f 20 72 75 6e 2d if (number? run-
7060: 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d id). (rmt:send-
7070: 72 65 63 65 69 76 65 20 27 67 65 74 2d 74 65 73 receive 'get-tes
7080: 74 73 2d 66 6f 72 2d 72 75 6e 20 72 75 6e 2d 69 ts-for-run run-i
7090: 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 d (list run-id t
70a0: 65 73 74 70 61 74 74 20 73 74 61 74 65 73 20 73 estpatt states s
70b0: 74 61 74 75 73 65 73 20 6f 66 66 73 65 74 20 6c tatuses offset l
70c0: 69 6d 69 74 20 6e 6f 74 2d 69 6e 20 73 6f 72 74 imit not-in sort
70d0: 2d 62 79 20 73 6f 72 74 2d 6f 72 64 65 72 20 71 -by sort-order q
70e0: 72 79 76 61 6c 73 20 6c 61 73 74 2d 75 70 64 61 ryvals last-upda
70f0: 74 65 20 6d 6f 64 65 29 29 29 0a 20 20 3b 3b 20 te mode))). ;;
7100: 20 20 20 28 62 65 67 69 6e 0a 20 20 3b 3b 09 28 (begin. ;;.(
7110: 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f debug:print-erro
7120: 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 r 0 *default-log
7130: 2d 70 6f 72 74 2a 20 22 72 6d 74 3a 67 65 74 2d -port* "rmt:get-
7140: 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 63 61 tests-for-run ca
7150: 6c 6c 65 64 20 77 69 74 68 20 62 61 64 20 72 75 lled with bad ru
7160: 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 64 29 0a 20 n-id=" run-id).
7170: 20 3b 3b 09 28 70 72 69 6e 74 2d 63 61 6c 6c 2d ;;.(print-call-
7180: 63 68 61 69 6e 20 28 63 75 72 72 65 6e 74 2d 65 chain (current-e
7190: 72 72 6f 72 2d 70 6f 72 74 29 29 0a 20 20 3b 3b rror-port)). ;;
71a0: 09 27 28 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 .'())))..(define
71b0: 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 73 2d (rmt:get-tests-
71c0: 66 6f 72 2d 72 75 6e 2d 73 74 61 74 65 2d 73 74 for-run-state-st
71d0: 61 74 75 73 20 72 75 6e 2d 69 64 20 74 65 73 74 atus run-id test
71e0: 70 61 74 74 20 6c 61 73 74 2d 75 70 64 61 74 65 patt last-update
71f0: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
7200: 63 65 69 76 65 20 27 67 65 74 2d 74 65 73 74 73 ceive 'get-tests
7210: 2d 66 6f 72 2d 72 75 6e 2d 73 74 61 74 65 2d 73 -for-run-state-s
7220: 74 61 74 75 73 20 72 75 6e 2d 69 64 20 28 6c 69 tatus run-id (li
7230: 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 70 61 st run-id testpa
7240: 74 74 20 6c 61 73 74 2d 75 70 64 61 74 65 29 29 tt last-update))
7250: 29 0a 0a 3b 3b 20 67 65 74 20 73 74 75 66 66 20 )..;; get stuff
7260: 76 69 61 20 73 79 6e 63 68 61 73 68 20 0a 28 64 via synchash .(d
7270: 65 66 69 6e 65 20 28 72 6d 74 3a 73 79 6e 63 68 efine (rmt:synch
7280: 61 73 68 2d 67 65 74 20 72 75 6e 2d 69 64 20 70 ash-get run-id p
7290: 72 6f 63 20 73 79 6e 63 6b 65 79 20 6b 65 79 6e roc synckey keyn
72a0: 75 6d 20 70 61 72 61 6d 73 29 0a 20 20 28 72 6d um params). (rm
72b0: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
72c0: 73 79 6e 63 68 61 73 68 2d 67 65 74 20 72 75 6e synchash-get run
72d0: 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 -id (list run-id
72e0: 20 70 72 6f 63 20 73 79 6e 63 6b 65 79 20 6b 65 proc synckey ke
72f0: 79 6e 75 6d 20 70 61 72 61 6d 73 29 29 29 0a 0a ynum params)))..
7300: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 (define (rmt:get
7310: 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 2d 6d -tests-for-run-m
7320: 69 6e 64 61 74 61 20 72 75 6e 2d 69 64 20 74 65 indata run-id te
7330: 73 74 70 61 74 74 20 73 74 61 74 65 73 20 73 74 stpatt states st
7340: 61 74 75 73 20 6e 6f 74 2d 69 6e 29 0a 20 20 28 atus not-in). (
7350: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
7360: 20 27 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 'get-tests-for-
7370: 72 75 6e 2d 6d 69 6e 64 61 74 61 20 72 75 6e 2d run-mindata run-
7380: 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 id (list run-id
7390: 74 65 73 74 70 61 74 74 20 73 74 61 74 65 73 20 testpatt states
73a0: 73 74 61 74 75 73 20 6e 6f 74 2d 69 6e 29 29 29 status not-in)))
73b0: 0a 20 20 0a 3b 3b 20 49 44 45 41 3a 20 54 68 72 . .;; IDEA: Thr
73c0: 65 61 64 69 66 79 20 74 68 65 73 65 20 2d 20 74 eadify these - t
73d0: 68 65 79 20 73 70 65 6e 64 20 61 20 6c 6f 74 20 hey spend a lot
73e0: 6f 66 20 74 69 6d 65 20 77 61 69 74 69 6e 67 20 of time waiting
73f0: 2e 2e 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 ....;;.(define (
7400: 72 6d 74 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f rmt:get-tests-fo
7410: 72 2d 72 75 6e 73 2d 6d 69 6e 64 61 74 61 20 72 r-runs-mindata r
7420: 75 6e 2d 69 64 73 20 74 65 73 74 70 61 74 74 20 un-ids testpatt
7430: 73 74 61 74 65 73 20 73 74 61 74 75 73 20 6e 6f states status no
7440: 74 2d 69 6e 29 0a 20 20 28 6c 65 74 20 28 28 6d t-in). (let ((m
7450: 75 6c 74 69 2d 72 75 6e 2d 6d 75 74 65 78 20 28 ulti-run-mutex (
7460: 6d 61 6b 65 2d 6d 75 74 65 78 29 29 0a 09 28 72 make-mutex))..(r
7470: 75 6e 2d 69 64 2d 6c 69 73 74 20 28 69 66 20 72 un-id-list (if r
7480: 75 6e 2d 69 64 73 0a 09 09 09 20 72 75 6e 2d 69 un-ids.... run-i
7490: 64 73 0a 09 09 09 20 28 72 6d 74 3a 67 65 74 2d ds.... (rmt:get-
74a0: 61 6c 6c 2d 72 75 6e 2d 69 64 73 29 29 29 0a 09 all-run-ids)))..
74b0: 28 72 65 73 75 6c 74 20 20 20 20 20 20 27 28 29 (result '()
74c0: 29 29 0a 20 20 20 20 28 69 66 20 28 6e 75 6c 6c )). (if (null
74d0: 3f 20 72 75 6e 2d 69 64 2d 6c 69 73 74 29 0a 09 ? run-id-list)..
74e0: 27 28 29 0a 09 28 6c 65 74 20 6c 6f 6f 70 20 28 '()..(let loop (
74f0: 28 68 65 64 20 20 20 20 20 28 63 61 72 20 72 75 (hed (car ru
7500: 6e 2d 69 64 2d 6c 69 73 74 29 29 0a 09 09 20 20 n-id-list))...
7510: 20 28 74 61 6c 20 20 20 20 20 28 63 64 72 20 72 (tal (cdr r
7520: 75 6e 2d 69 64 2d 6c 69 73 74 29 29 0a 09 09 20 un-id-list))...
7530: 20 20 28 74 68 72 65 61 64 73 20 27 28 29 29 29 (threads '()))
7540: 0a 09 20 20 28 69 66 20 28 3e 20 28 6c 65 6e 67 .. (if (> (leng
7550: 74 68 20 74 68 72 65 61 64 73 29 20 35 29 0a 09 th threads) 5)..
7560: 20 20 20 20 20 20 28 6c 6f 6f 70 20 68 65 64 20 (loop hed
7570: 74 61 6c 20 28 66 69 6c 74 65 72 20 28 6c 61 6d tal (filter (lam
7580: 62 64 61 20 28 74 68 29 28 6e 6f 74 20 28 6d 65 bda (th)(not (me
7590: 6d 62 65 72 20 28 74 68 72 65 61 64 2d 73 74 61 mber (thread-sta
75a0: 74 65 20 74 68 29 20 27 28 74 65 72 6d 69 6e 61 te th) '(termina
75b0: 74 65 64 20 64 65 61 64 29 29 29 29 20 74 68 72 ted dead)))) thr
75c0: 65 61 64 73 29 29 0a 09 20 20 20 20 20 20 28 6c eads)).. (l
75d0: 65 74 2a 20 28 28 6e 65 77 74 68 72 65 61 64 20 et* ((newthread
75e0: 28 6d 61 6b 65 2d 74 68 72 65 61 64 0a 09 09 09 (make-thread....
75f0: 09 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 . (lambda ()....
7600: 09 20 20 20 28 6c 65 74 20 28 28 72 65 73 20 28 . (let ((res (
7610: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
7620: 20 27 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 'get-tests-for-
7630: 72 75 6e 2d 6d 69 6e 64 61 74 61 20 68 65 64 20 run-mindata hed
7640: 28 6c 69 73 74 20 68 65 64 20 74 65 73 74 70 61 (list hed testpa
7650: 74 74 20 73 74 61 74 65 73 20 73 74 61 74 75 73 tt states status
7660: 20 6e 6f 74 2d 69 6e 29 29 29 29 0a 09 09 09 09 not-in)))).....
7670: 20 20 20 20 20 28 69 66 20 28 6c 69 73 74 3f 20 (if (list?
7680: 72 65 73 29 0a 09 09 09 09 09 20 28 62 65 67 69 res)...... (begi
7690: 6e 0a 09 09 09 09 09 20 20 20 28 6d 75 74 65 78 n...... (mutex
76a0: 2d 6c 6f 63 6b 21 20 6d 75 6c 74 69 2d 72 75 6e -lock! multi-run
76b0: 2d 6d 75 74 65 78 29 0a 09 09 09 09 09 20 20 20 -mutex)......
76c0: 28 73 65 74 21 20 72 65 73 75 6c 74 20 28 61 70 (set! result (ap
76d0: 70 65 6e 64 20 72 65 73 75 6c 74 20 72 65 73 29 pend result res)
76e0: 29 0a 09 09 09 09 09 20 20 20 28 6d 75 74 65 78 )...... (mutex
76f0: 2d 75 6e 6c 6f 63 6b 21 20 6d 75 6c 74 69 2d 72 -unlock! multi-r
7700: 75 6e 2d 6d 75 74 65 78 29 29 0a 09 09 09 09 09 un-mutex))......
7710: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 (debug:print-er
7720: 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c ror 0 *default-l
7730: 6f 67 2d 70 6f 72 74 2a 20 22 67 65 74 2d 74 65 og-port* "get-te
7740: 73 74 73 2d 66 6f 72 2d 72 75 6e 2d 6d 69 6e 64 sts-for-run-mind
7750: 61 74 61 20 66 61 69 6c 65 64 20 66 6f 72 20 72 ata failed for r
7760: 75 6e 2d 69 64 20 22 20 68 65 64 20 22 2c 20 74 un-id " hed ", t
7770: 65 73 74 70 61 74 74 20 22 20 74 65 73 74 70 61 estpatt " testpa
7780: 74 74 20 22 2c 20 73 74 61 74 65 73 20 22 20 73 tt ", states " s
7790: 74 61 74 65 73 20 22 2c 20 73 74 61 74 75 73 20 tates ", status
77a0: 22 20 73 74 61 74 75 73 20 22 2c 20 6e 6f 74 2d " status ", not-
77b0: 69 6e 20 22 20 6e 6f 74 2d 69 6e 29 29 29 29 0a in " not-in)))).
77c0: 09 09 09 09 20 28 63 6f 6e 63 20 22 6d 75 6c 74 .... (conc "mult
77d0: 69 2d 72 75 6e 2d 74 68 72 65 61 64 20 66 6f 72 i-run-thread for
77e0: 20 72 75 6e 2d 69 64 20 22 20 68 65 64 29 29 29 run-id " hed)))
77f0: 0a 09 09 20 20 20 20 20 28 6e 65 77 74 68 72 65 ... (newthre
7800: 61 64 73 20 28 63 6f 6e 73 20 6e 65 77 74 68 72 ads (cons newthr
7810: 65 61 64 20 74 68 72 65 61 64 73 29 29 29 0a 09 ead threads)))..
7820: 09 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 .(thread-start!
7830: 6e 65 77 74 68 72 65 61 64 29 0a 09 09 28 74 68 newthread)...(th
7840: 72 65 61 64 2d 73 6c 65 65 70 21 20 30 2e 30 35 read-sleep! 0.05
7850: 29 20 3b 3b 20 67 69 76 65 20 74 68 61 74 20 74 ) ;; give that t
7860: 68 72 65 61 64 20 73 6f 6d 65 20 74 69 6d 65 20 hread some time
7870: 74 6f 20 73 74 61 72 74 0a 09 09 28 69 66 20 28 to start...(if (
7880: 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 20 20 20 null? tal)...
7890: 20 6e 65 77 74 68 72 65 61 64 73 0a 09 09 20 20 newthreads...
78a0: 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c (loop (car tal
78b0: 29 28 63 64 72 20 74 61 6c 29 20 6e 65 77 74 68 )(cdr tal) newth
78c0: 72 65 61 64 73 29 29 29 29 29 29 0a 20 20 20 20 reads)))))).
78d0: 72 65 73 75 6c 74 29 29 0a 0a 3b 3b 20 3b 3b 20 result))..;; ;;
78e0: 49 44 45 41 3a 20 54 68 72 65 61 64 69 66 79 20 IDEA: Threadify
78f0: 74 68 65 73 65 20 2d 20 74 68 65 79 20 73 70 65 these - they spe
7900: 6e 64 20 61 20 6c 6f 74 20 6f 66 20 74 69 6d 65 nd a lot of time
7910: 20 77 61 69 74 69 6e 67 20 2e 2e 2e 0a 3b 3b 20 waiting ....;;
7920: 3b 3b 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 72 ;;.;; (define (r
7930: 6d 74 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 mt:get-tests-for
7940: 2d 72 75 6e 73 2d 6d 69 6e 64 61 74 61 20 72 75 -runs-mindata ru
7950: 6e 2d 69 64 73 20 74 65 73 74 70 61 74 74 20 73 n-ids testpatt s
7960: 74 61 74 65 73 20 73 74 61 74 75 73 20 6e 6f 74 tates status not
7970: 2d 69 6e 29 0a 3b 3b 20 20 20 28 6c 65 74 20 28 -in).;; (let (
7980: 28 72 75 6e 2d 69 64 2d 6c 69 73 74 20 28 69 66 (run-id-list (if
7990: 20 72 75 6e 2d 69 64 73 0a 3b 3b 20 09 09 09 20 run-ids.;; ...
79a0: 72 75 6e 2d 69 64 73 0a 3b 3b 20 09 09 09 20 28 run-ids.;; ... (
79b0: 72 6d 74 3a 67 65 74 2d 61 6c 6c 2d 72 75 6e 2d rmt:get-all-run-
79c0: 69 64 73 29 29 29 29 0a 3b 3b 20 20 20 20 20 28 ids)))).;; (
79d0: 61 70 70 6c 79 20 61 70 70 65 6e 64 20 28 6d 61 apply append (ma
79e0: 70 20 28 6c 61 6d 62 64 61 20 28 72 75 6e 2d 69 p (lambda (run-i
79f0: 64 29 0a 3b 3b 20 09 09 09 20 28 72 6d 74 3a 73 d).;; ... (rmt:s
7a00: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 end-receive 'get
7a10: 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 2d 6d -tests-for-run-m
7a20: 69 6e 64 61 74 61 20 72 75 6e 2d 69 64 20 28 6c indata run-id (l
7a30: 69 73 74 20 72 75 6e 2d 69 64 73 20 74 65 73 74 ist run-ids test
7a40: 70 61 74 74 20 73 74 61 74 65 73 20 73 74 61 74 patt states stat
7a50: 75 73 20 6e 6f 74 2d 69 6e 29 29 29 0a 3b 3b 20 us not-in))).;;
7a60: 09 09 20 20 20 20 20 20 20 72 75 6e 2d 69 64 2d .. run-id-
7a70: 6c 69 73 74 29 29 29 29 0a 0a 28 64 65 66 69 6e list))))..(defin
7a80: 65 20 28 72 6d 74 3a 64 65 6c 65 74 65 2d 74 65 e (rmt:delete-te
7a90: 73 74 2d 72 65 63 6f 72 64 73 20 72 75 6e 2d 69 st-records run-i
7aa0: 64 20 74 65 73 74 2d 69 64 29 0a 20 20 28 72 6d d test-id). (rm
7ab0: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
7ac0: 64 65 6c 65 74 65 2d 74 65 73 74 2d 72 65 63 6f delete-test-reco
7ad0: 72 64 73 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 rds run-id (list
7ae0: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 run-id test-id)
7af0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
7b00: 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d :test-set-state-
7b10: 73 74 61 74 75 73 20 72 75 6e 2d 69 64 20 74 65 status run-id te
7b20: 73 74 2d 69 64 20 73 74 61 74 65 20 73 74 61 74 st-id state stat
7b30: 75 73 20 6d 73 67 29 0a 20 20 28 72 6d 74 3a 73 us msg). (rmt:s
7b40: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 74 65 73 end-receive 'tes
7b50: 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 t-set-state-stat
7b60: 75 73 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 us run-id (list
7b70: 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 73 run-id test-id s
7b80: 74 61 74 65 20 73 74 61 74 75 73 20 6d 73 67 29 tate status msg)
7b90: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
7ba0: 3a 74 65 73 74 2d 74 6f 70 6c 65 76 65 6c 2d 6e :test-toplevel-n
7bb0: 75 6d 2d 69 74 65 6d 73 20 72 75 6e 2d 69 64 20 um-items run-id
7bc0: 74 65 73 74 2d 6e 61 6d 65 29 0a 20 20 28 72 6d test-name). (rm
7bd0: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
7be0: 74 65 73 74 2d 74 6f 70 6c 65 76 65 6c 2d 6e 75 test-toplevel-nu
7bf0: 6d 2d 69 74 65 6d 73 20 72 75 6e 2d 69 64 20 28 m-items run-id (
7c00: 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 list run-id test
7c10: 2d 6e 61 6d 65 29 29 29 0a 0a 3b 3b 20 28 64 65 -name)))..;; (de
7c20: 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 70 72 fine (rmt:get-pr
7c30: 65 76 69 6f 75 73 2d 74 65 73 74 2d 72 75 6e 2d evious-test-run-
7c40: 72 65 63 6f 72 64 20 72 75 6e 2d 69 64 20 74 65 record run-id te
7c50: 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 st-name item-pat
7c60: 68 29 0a 3b 3b 20 20 20 28 72 6d 74 3a 73 65 6e h).;; (rmt:sen
7c70: 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 70 d-receive 'get-p
7c80: 72 65 76 69 6f 75 73 2d 74 65 73 74 2d 72 75 6e revious-test-run
7c90: 2d 72 65 63 6f 72 64 20 72 75 6e 2d 69 64 20 28 -record run-id (
7ca0: 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 list run-id test
7cb0: 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 -name item-path)
7cc0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
7cd0: 3a 67 65 74 2d 6d 61 74 63 68 69 6e 67 2d 70 72 :get-matching-pr
7ce0: 65 76 69 6f 75 73 2d 74 65 73 74 2d 72 75 6e 2d evious-test-run-
7cf0: 72 65 63 6f 72 64 73 20 72 75 6e 2d 69 64 20 74 records run-id t
7d00: 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 est-name item-pa
7d10: 74 68 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d th). (rmt:send-
7d20: 72 65 63 65 69 76 65 20 27 67 65 74 2d 6d 61 74 receive 'get-mat
7d30: 63 68 69 6e 67 2d 70 72 65 76 69 6f 75 73 2d 74 ching-previous-t
7d40: 65 73 74 2d 72 75 6e 2d 72 65 63 6f 72 64 73 20 est-run-records
7d50: 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e run-id (list run
7d60: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 -id test-name it
7d70: 65 6d 2d 70 61 74 68 29 29 29 0a 0a 28 64 65 66 em-path)))..(def
7d80: 69 6e 65 20 28 72 6d 74 3a 74 65 73 74 2d 67 65 ine (rmt:test-ge
7d90: 74 2d 6c 6f 67 66 69 6c 65 2d 69 6e 66 6f 20 72 t-logfile-info r
7da0: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 29 un-id test-name)
7db0: 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 . (rmt:send-rec
7dc0: 65 69 76 65 20 27 74 65 73 74 2d 67 65 74 2d 6c eive 'test-get-l
7dd0: 6f 67 66 69 6c 65 2d 69 6e 66 6f 20 72 75 6e 2d ogfile-info run-
7de0: 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 id (list run-id
7df0: 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a 0a 28 64 test-name)))..(d
7e00: 65 66 69 6e 65 20 28 72 6d 74 3a 74 65 73 74 2d efine (rmt:test-
7e10: 67 65 74 2d 72 65 63 6f 72 64 73 2d 66 6f 72 2d get-records-for-
7e20: 69 6e 64 65 78 2d 66 69 6c 65 20 72 75 6e 2d 69 index-file run-i
7e30: 64 20 74 65 73 74 2d 6e 61 6d 65 29 0a 20 20 28 d test-name). (
7e40: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
7e50: 20 27 74 65 73 74 2d 67 65 74 2d 72 65 63 6f 72 'test-get-recor
7e60: 64 73 2d 66 6f 72 2d 69 6e 64 65 78 2d 66 69 6c ds-for-index-fil
7e70: 65 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 e run-id (list r
7e80: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 29 un-id test-name)
7e90: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
7ea0: 3a 67 65 74 2d 74 65 73 74 69 6e 66 6f 2d 73 74 :get-testinfo-st
7eb0: 61 74 65 2d 73 74 61 74 75 73 20 72 75 6e 2d 69 ate-status run-i
7ec0: 64 20 74 65 73 74 2d 69 64 29 0a 20 20 28 72 6d d test-id). (rm
7ed0: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
7ee0: 67 65 74 2d 74 65 73 74 69 6e 66 6f 2d 73 74 61 get-testinfo-sta
7ef0: 74 65 2d 73 74 61 74 75 73 20 72 75 6e 2d 69 64 te-status run-id
7f00: 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 (list run-id te
7f10: 73 74 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 6e st-id)))..(defin
7f20: 65 20 28 72 6d 74 3a 74 65 73 74 2d 73 65 74 2d e (rmt:test-set-
7f30: 6c 6f 67 21 20 72 75 6e 2d 69 64 20 74 65 73 74 log! run-id test
7f40: 2d 69 64 20 6c 6f 67 66 29 0a 20 20 28 69 66 20 -id logf). (if
7f50: 28 73 74 72 69 6e 67 3f 20 6c 6f 67 66 29 28 72 (string? logf)(r
7f60: 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 mt:general-call
7f70: 27 74 65 73 74 2d 73 65 74 2d 6c 6f 67 20 72 75 'test-set-log ru
7f80: 6e 2d 69 64 20 6c 6f 67 66 20 74 65 73 74 2d 69 n-id logf test-i
7f90: 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 d)))..(define (r
7fa0: 6d 74 3a 74 65 73 74 2d 73 65 74 2d 74 6f 70 2d mt:test-set-top-
7fb0: 70 72 6f 63 65 73 73 2d 70 69 64 20 72 75 6e 2d process-pid run-
7fc0: 69 64 20 74 65 73 74 2d 69 64 20 70 69 64 29 0a id test-id pid).
7fd0: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
7fe0: 69 76 65 20 27 74 65 73 74 2d 73 65 74 2d 74 6f ive 'test-set-to
7ff0: 70 2d 70 72 6f 63 65 73 73 2d 70 69 64 20 72 75 p-process-pid ru
8000: 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 n-id (list run-i
8010: 64 20 74 65 73 74 2d 69 64 20 70 69 64 29 29 29 d test-id pid)))
8020: 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 ..(define (rmt:t
8030: 65 73 74 2d 67 65 74 2d 74 6f 70 2d 70 72 6f 63 est-get-top-proc
8040: 65 73 73 2d 70 69 64 20 72 75 6e 2d 69 64 20 74 ess-pid run-id t
8050: 65 73 74 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 est-id). (rmt:s
8060: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 74 65 73 end-receive 'tes
8070: 74 2d 67 65 74 2d 74 6f 70 2d 70 72 6f 63 65 73 t-get-top-proces
8080: 73 2d 70 69 64 20 72 75 6e 2d 69 64 20 28 6c 69 s-pid run-id (li
8090: 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 st run-id test-i
80a0: 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 d)))..(define (r
80b0: 6d 74 3a 67 65 74 2d 72 75 6e 2d 69 64 73 2d 6d mt:get-run-ids-m
80c0: 61 74 63 68 69 6e 67 2d 74 61 72 67 65 74 20 6b atching-target k
80d0: 65 79 6e 61 6d 65 73 20 74 61 72 67 65 74 20 72 eynames target r
80e0: 65 73 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 70 es runname testp
80f0: 61 74 74 20 73 74 61 74 65 70 61 74 74 20 73 74 att statepatt st
8100: 61 74 75 73 70 61 74 74 29 0a 20 20 28 72 6d 74 atuspatt). (rmt
8110: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 :send-receive 'g
8120: 65 74 2d 72 75 6e 2d 69 64 73 2d 6d 61 74 63 68 et-run-ids-match
8130: 69 6e 67 2d 74 61 72 67 65 74 20 23 66 20 28 6c ing-target #f (l
8140: 69 73 74 20 6b 65 79 6e 61 6d 65 73 20 74 61 72 ist keynames tar
8150: 67 65 74 20 72 65 73 20 72 75 6e 6e 61 6d 65 20 get res runname
8160: 74 65 73 74 70 61 74 74 20 73 74 61 74 65 70 61 testpatt statepa
8170: 74 74 20 73 74 61 74 75 73 70 61 74 74 29 29 29 tt statuspatt)))
8180: 0a 0a 3b 3b 20 4e 4f 54 45 3a 20 54 68 69 73 20 ..;; NOTE: This
8190: 77 69 6c 6c 20 6f 70 65 6e 20 61 6e 64 20 61 63 will open and ac
81a0: 63 65 73 73 20 41 4c 4c 20 72 75 6e 20 64 61 74 cess ALL run dat
81b0: 61 62 61 73 65 73 2e 20 0a 3b 3b 0a 28 64 65 66 abases. .;;.(def
81c0: 69 6e 65 20 28 72 6d 74 3a 74 65 73 74 2d 67 65 ine (rmt:test-ge
81d0: 74 2d 70 61 74 68 73 2d 6d 61 74 63 68 69 6e 67 t-paths-matching
81e0: 2d 6b 65 79 6e 61 6d 65 73 2d 74 61 72 67 65 74 -keynames-target
81f0: 2d 6e 65 77 20 6b 65 79 6e 61 6d 65 73 20 74 61 -new keynames ta
8200: 72 67 65 74 20 72 65 73 20 74 65 73 74 70 61 74 rget res testpat
8210: 74 20 73 74 61 74 65 70 61 74 74 20 73 74 61 74 t statepatt stat
8220: 75 73 70 61 74 74 20 72 75 6e 6e 61 6d 65 29 0a uspatt runname).
8230: 20 20 28 6c 65 74 20 28 28 72 75 6e 2d 69 64 73 (let ((run-ids
8240: 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e 2d 69 64 (rmt:get-run-id
8250: 73 2d 6d 61 74 63 68 69 6e 67 2d 74 61 72 67 65 s-matching-targe
8260: 74 20 6b 65 79 6e 61 6d 65 73 20 74 61 72 67 65 t keynames targe
8270: 74 20 72 65 73 20 72 75 6e 6e 61 6d 65 20 74 65 t res runname te
8280: 73 74 70 61 74 74 20 73 74 61 74 65 70 61 74 74 stpatt statepatt
8290: 20 73 74 61 74 75 73 70 61 74 74 29 29 29 0a 20 statuspatt))).
82a0: 20 20 20 28 61 70 70 6c 79 20 61 70 70 65 6e 64 (apply append
82b0: 20 0a 09 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 .. (map (lamb
82c0: 64 61 20 28 72 75 6e 2d 69 64 29 0a 09 09 20 20 da (run-id)...
82d0: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
82e0: 65 20 27 74 65 73 74 2d 67 65 74 2d 70 61 74 68 e 'test-get-path
82f0: 73 2d 6d 61 74 63 68 69 6e 67 2d 6b 65 79 6e 61 s-matching-keyna
8300: 6d 65 73 2d 74 61 72 67 65 74 2d 6e 65 77 20 72 mes-target-new r
8310: 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d un-id (list run-
8320: 69 64 20 6b 65 79 6e 61 6d 65 73 20 74 61 72 67 id keynames targ
8330: 65 74 20 72 65 73 20 74 65 73 74 70 61 74 74 20 et res testpatt
8340: 73 74 61 74 65 70 61 74 74 20 73 74 61 74 75 73 statepatt status
8350: 70 61 74 74 20 72 75 6e 6e 61 6d 65 29 29 29 0a patt runname))).
8360: 09 20 20 20 72 75 6e 2d 69 64 73 29 29 29 29 0a . run-ids)))).
8370: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 .(define (rmt:ge
8380: 74 2d 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 t-prereqs-not-me
8390: 74 20 72 75 6e 2d 69 64 20 77 61 69 74 6f 6e 73 t run-id waitons
83a0: 20 72 65 66 2d 74 65 73 74 2d 6e 61 6d 65 20 72 ref-test-name r
83b0: 65 66 2d 69 74 65 6d 2d 70 61 74 68 20 23 21 6b ef-item-path #!k
83c0: 65 79 20 28 6d 6f 64 65 20 27 28 6e 6f 72 6d 61 ey (mode '(norma
83d0: 6c 29 29 28 69 74 65 6d 6d 61 70 73 20 23 66 29 l))(itemmaps #f)
83e0: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
83f0: 63 65 69 76 65 20 27 67 65 74 2d 70 72 65 72 65 ceive 'get-prere
8400: 71 73 2d 6e 6f 74 2d 6d 65 74 20 72 75 6e 2d 69 qs-not-met run-i
8410: 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 77 d (list run-id w
8420: 61 69 74 6f 6e 73 20 72 65 66 2d 74 65 73 74 2d aitons ref-test-
8430: 6e 61 6d 65 20 72 65 66 2d 69 74 65 6d 2d 70 61 name ref-item-pa
8440: 74 68 20 6d 6f 64 65 20 69 74 65 6d 6d 61 70 73 th mode itemmaps
8450: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d )))..(define (rm
8460: 74 3a 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 t:get-count-test
8470: 73 2d 72 75 6e 6e 69 6e 67 2d 66 6f 72 2d 72 75 s-running-for-ru
8480: 6e 2d 69 64 20 72 75 6e 2d 69 64 29 0a 20 20 28 n-id run-id). (
8490: 69 66 20 28 6e 75 6d 62 65 72 3f 20 72 75 6e 2d if (number? run-
84a0: 69 64 29 0a 20 20 20 20 20 20 28 72 6d 74 3a 73 id). (rmt:s
84b0: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 end-receive 'get
84c0: 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e -count-tests-run
84d0: 6e 69 6e 67 2d 66 6f 72 2d 72 75 6e 2d 69 64 20 ning-for-run-id
84e0: 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e run-id (list run
84f0: 2d 69 64 29 29 0a 20 20 20 20 20 20 30 29 29 0a -id)). 0)).
8500: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 .(define (rmt:ge
8510: 74 2d 6e 6f 74 2d 63 6f 6d 70 6c 65 74 65 64 2d t-not-completed-
8520: 63 6e 74 20 72 75 6e 2d 69 64 29 0a 20 20 28 72 cnt run-id). (r
8530: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
8540: 27 67 65 74 2d 6e 6f 74 2d 63 6f 6d 70 6c 65 74 'get-not-complet
8550: 65 64 2d 63 6e 74 20 72 75 6e 2d 69 64 20 28 6c ed-cnt run-id (l
8560: 69 73 74 20 72 75 6e 2d 69 64 29 29 29 0a 0a 0a ist run-id)))...
8570: 3b 3b 20 53 74 61 74 69 73 74 69 63 61 6c 20 71 ;; Statistical q
8580: 75 65 72 69 65 73 0a 0a 28 64 65 66 69 6e 65 20 ueries..(define
8590: 28 72 6d 74 3a 67 65 74 2d 63 6f 75 6e 74 2d 74 (rmt:get-count-t
85a0: 65 73 74 73 2d 72 75 6e 6e 69 6e 67 20 72 75 6e ests-running run
85b0: 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 -id). (rmt:send
85c0: 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 63 6f -receive 'get-co
85d0: 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e unt-tests-runnin
85e0: 67 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 g run-id (list r
85f0: 75 6e 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 6e un-id)))..(defin
8600: 65 20 28 72 6d 74 3a 67 65 74 2d 63 6f 75 6e 74 e (rmt:get-count
8610: 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 2d 66 -tests-running-f
8620: 6f 72 2d 74 65 73 74 6e 61 6d 65 20 72 75 6e 2d or-testname run-
8630: 69 64 20 74 65 73 74 6e 61 6d 65 29 0a 20 20 28 id testname). (
8640: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
8650: 20 27 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 'get-count-test
8660: 73 2d 72 75 6e 6e 69 6e 67 2d 66 6f 72 2d 74 65 s-running-for-te
8670: 73 74 6e 61 6d 65 20 72 75 6e 2d 69 64 20 28 6c stname run-id (l
8680: 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 6e ist run-id testn
8690: 61 6d 65 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ame)))..(define
86a0: 28 72 6d 74 3a 67 65 74 2d 63 6f 75 6e 74 2d 74 (rmt:get-count-t
86b0: 65 73 74 73 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d ests-running-in-
86c0: 6a 6f 62 67 72 6f 75 70 20 72 75 6e 2d 69 64 20 jobgroup run-id
86d0: 6a 6f 62 67 72 6f 75 70 29 0a 20 20 28 72 6d 74 jobgroup). (rmt
86e0: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 :send-receive 'g
86f0: 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d 72 et-count-tests-r
8700: 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f unning-in-jobgro
8710: 75 70 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 up run-id (list
8720: 72 75 6e 2d 69 64 20 6a 6f 62 67 72 6f 75 70 29 run-id jobgroup)
8730: 29 29 0a 0a 3b 3b 20 73 74 61 74 65 20 61 6e 64 ))..;; state and
8740: 20 73 74 61 74 75 73 20 61 72 65 20 65 78 74 72 status are extr
8750: 61 20 68 69 6e 74 73 20 6e 6f 74 20 75 73 75 61 a hints not usua
8760: 6c 6c 79 20 75 73 65 64 20 69 6e 20 74 68 65 20 lly used in the
8770: 63 61 6c 63 75 6c 61 74 69 6f 6e 0a 3b 3b 0a 28 calculation.;;.(
8780: 64 65 66 69 6e 65 20 28 72 6d 74 3a 73 65 74 2d define (rmt:set-
8790: 73 74 61 74 65 2d 73 74 61 74 75 73 2d 61 6e 64 state-status-and
87a0: 2d 72 6f 6c 6c 2d 75 70 2d 69 74 65 6d 73 20 72 -roll-up-items r
87b0: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 un-id test-name
87c0: 69 74 65 6d 2d 70 61 74 68 20 73 74 61 74 65 20 item-path state
87d0: 73 74 61 74 75 73 20 63 6f 6d 6d 65 6e 74 29 0a status comment).
87e0: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
87f0: 69 76 65 20 27 73 65 74 2d 73 74 61 74 65 2d 73 ive 'set-state-s
8800: 74 61 74 75 73 2d 61 6e 64 2d 72 6f 6c 6c 2d 75 tatus-and-roll-u
8810: 70 2d 69 74 65 6d 73 20 72 75 6e 2d 69 64 20 28 p-items run-id (
8820: 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 list run-id test
8830: 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 -name item-path
8840: 73 74 61 74 65 20 73 74 61 74 75 73 20 63 6f 6d state status com
8850: 6d 65 6e 74 29 29 29 0a 0a 28 64 65 66 69 6e 65 ment)))..(define
8860: 20 28 72 6d 74 3a 73 65 74 2d 73 74 61 74 65 2d (rmt:set-state-
8870: 73 74 61 74 75 73 2d 61 6e 64 2d 72 6f 6c 6c 2d status-and-roll-
8880: 75 70 2d 72 75 6e 20 72 75 6e 2d 69 64 20 73 74 up-run run-id st
8890: 61 74 65 20 73 74 61 74 75 73 29 0a 20 20 28 72 ate status). (r
88a0: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
88b0: 27 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 'set-state-statu
88c0: 73 2d 61 6e 64 2d 72 6f 6c 6c 2d 75 70 2d 72 75 s-and-roll-up-ru
88d0: 6e 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 n run-id (list r
88e0: 75 6e 2d 69 64 20 73 74 61 74 65 20 73 74 61 74 un-id state stat
88f0: 75 73 29 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 us)))...(define
8900: 28 72 6d 74 3a 75 70 64 61 74 65 2d 70 61 73 73 (rmt:update-pass
8910: 2d 66 61 69 6c 2d 63 6f 75 6e 74 73 20 72 75 6e -fail-counts run
8920: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 29 0a 20 -id test-name).
8930: 20 28 72 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 61 (rmt:general-ca
8940: 6c 6c 20 27 75 70 64 61 74 65 2d 70 61 73 73 2d ll 'update-pass-
8950: 66 61 69 6c 2d 63 6f 75 6e 74 73 20 72 75 6e 2d fail-counts run-
8960: 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 id test-name tes
8970: 74 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 t-name test-name
8980: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
8990: 3a 74 6f 70 2d 74 65 73 74 2d 73 65 74 2d 70 65 :top-test-set-pe
89a0: 72 2d 70 66 2d 63 6f 75 6e 74 73 20 72 75 6e 2d r-pf-counts run-
89b0: 69 64 20 74 65 73 74 2d 6e 61 6d 65 29 0a 20 20 id test-name).
89c0: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
89d0: 65 20 27 74 6f 70 2d 74 65 73 74 2d 73 65 74 2d e 'top-test-set-
89e0: 70 65 72 2d 70 66 2d 63 6f 75 6e 74 73 20 72 75 per-pf-counts ru
89f0: 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 n-id (list run-i
8a00: 64 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a 0a d test-name)))..
8a10: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 (define (rmt:get
8a20: 2d 72 61 77 2d 72 75 6e 2d 73 74 61 74 73 20 72 -raw-run-stats r
8a30: 75 6e 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 un-id). (rmt:se
8a40: 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d nd-receive 'get-
8a50: 72 61 77 2d 72 75 6e 2d 73 74 61 74 73 20 72 75 raw-run-stats ru
8a60: 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 n-id (list run-i
8a70: 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 d)))..(define (r
8a80: 6d 74 3a 67 65 74 2d 74 65 73 74 2d 74 69 6d 65 mt:get-test-time
8a90: 73 20 72 75 6e 6e 61 6d 65 20 74 61 72 67 65 74 s runname target
8aa0: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
8ab0: 63 65 69 76 65 20 27 67 65 74 2d 74 65 73 74 2d ceive 'get-test-
8ac0: 74 69 6d 65 73 20 23 66 20 28 6c 69 73 74 20 72 times #f (list r
8ad0: 75 6e 6e 61 6d 65 20 74 61 72 67 65 74 20 29 29 unname target ))
8ae0: 29 20 0a 0a 3b 3b 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 3d 3d 3d 3d 3d 3d 3d 3d ================
8b20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
8b30: 20 52 20 55 20 4e 20 53 0a 3b 3b 3d 3d 3d 3d 3d R U N S.;;=====
8b40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8b50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8b60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8b70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8b80: 3d 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a =..(define (rmt:
8b90: 67 65 74 2d 72 75 6e 2d 69 6e 66 6f 20 72 75 6e get-run-info run
8ba0: 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 -id). (rmt:send
8bb0: 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d 72 75 -receive 'get-ru
8bc0: 6e 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 20 28 6c n-info run-id (l
8bd0: 69 73 74 20 72 75 6e 2d 69 64 29 29 29 0a 0a 28 ist run-id)))..(
8be0: 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d define (rmt:get-
8bf0: 6e 75 6d 2d 72 75 6e 73 20 72 75 6e 70 61 74 74 num-runs runpatt
8c00: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
8c10: 63 65 69 76 65 20 27 67 65 74 2d 6e 75 6d 2d 72 ceive 'get-num-r
8c20: 75 6e 73 20 23 66 20 28 6c 69 73 74 20 72 75 6e uns #f (list run
8c30: 70 61 74 74 29 29 29 0a 0a 28 64 65 66 69 6e 65 patt)))..(define
8c40: 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e 73 2d 63 (rmt:get-runs-c
8c50: 6e 74 2d 62 79 2d 70 61 74 74 20 72 75 6e 70 61 nt-by-patt runpa
8c60: 74 74 20 74 61 72 67 65 74 70 61 74 74 20 6b 65 tt targetpatt ke
8c70: 79 73 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d ys). (rmt:send-
8c80: 72 65 63 65 69 76 65 20 27 67 65 74 2d 72 75 6e receive 'get-run
8c90: 73 2d 63 6e 74 2d 62 79 2d 70 61 74 74 20 23 66 s-cnt-by-patt #f
8ca0: 20 28 6c 69 73 74 20 72 75 6e 70 61 74 74 20 20 (list runpatt
8cb0: 74 61 72 67 65 74 70 61 74 74 20 6b 65 79 73 29 targetpatt keys)
8cc0: 29 29 0a 0a 3b 3b 20 55 73 65 20 74 68 65 20 73 ))..;; Use the s
8cd0: 70 65 63 69 61 6c 20 72 75 6e 2d 69 64 20 3d 3d pecial run-id ==
8ce0: 20 23 66 20 73 63 65 6e 61 72 69 6f 20 68 65 72 #f scenario her
8cf0: 65 20 73 69 6e 63 65 20 74 68 65 72 65 20 69 73 e since there is
8d00: 20 6e 6f 20 72 75 6e 20 79 65 74 0a 28 64 65 66 no run yet.(def
8d10: 69 6e 65 20 28 72 6d 74 3a 72 65 67 69 73 74 65 ine (rmt:registe
8d20: 72 2d 72 75 6e 20 6b 65 79 76 61 6c 73 20 72 75 r-run keyvals ru
8d30: 6e 6e 61 6d 65 20 73 74 61 74 65 20 73 74 61 74 nname state stat
8d40: 75 73 20 75 73 65 72 20 63 6f 6e 74 6f 75 72 29 us user contour)
8d50: 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 . (rmt:send-rec
8d60: 65 69 76 65 20 27 72 65 67 69 73 74 65 72 2d 72 eive 'register-r
8d70: 75 6e 20 23 66 20 28 6c 69 73 74 20 6b 65 79 76 un #f (list keyv
8d80: 61 6c 73 20 72 75 6e 6e 61 6d 65 20 73 74 61 74 als runname stat
8d90: 65 20 73 74 61 74 75 73 20 75 73 65 72 20 63 6f e status user co
8da0: 6e 74 6f 75 72 29 29 29 0a 20 20 20 20 0a 28 64 ntour))). .(d
8db0: 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 72 efine (rmt:get-r
8dc0: 75 6e 2d 6e 61 6d 65 2d 66 72 6f 6d 2d 69 64 20 un-name-from-id
8dd0: 72 75 6e 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 run-id). (rmt:s
8de0: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 end-receive 'get
8df0: 2d 72 75 6e 2d 6e 61 6d 65 2d 66 72 6f 6d 2d 69 -run-name-from-i
8e00: 64 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 d run-id (list r
8e10: 75 6e 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 6e un-id)))..(defin
8e20: 65 20 28 72 6d 74 3a 64 65 6c 65 74 65 2d 72 75 e (rmt:delete-ru
8e30: 6e 20 72 75 6e 2d 69 64 29 0a 20 20 28 72 6d 74 n run-id). (rmt
8e40: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 64 :send-receive 'd
8e50: 65 6c 65 74 65 2d 72 75 6e 20 72 75 6e 2d 69 64 elete-run run-id
8e60: 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 29 29 29 (list run-id)))
8e70: 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 75 ..(define (rmt:u
8e80: 70 64 61 74 65 2d 72 75 6e 2d 73 74 61 74 73 20 pdate-run-stats
8e90: 72 75 6e 2d 69 64 20 73 74 61 74 73 29 0a 20 20 run-id stats).
8ea0: 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 (rmt:send-receiv
8eb0: 65 20 27 75 70 64 61 74 65 2d 72 75 6e 2d 73 74 e 'update-run-st
8ec0: 61 74 73 20 23 66 20 28 6c 69 73 74 20 72 75 6e ats #f (list run
8ed0: 2d 69 64 20 73 74 61 74 73 29 29 29 0a 0a 28 64 -id stats)))..(d
8ee0: 65 66 69 6e 65 20 28 72 6d 74 3a 64 65 6c 65 74 efine (rmt:delet
8ef0: 65 2d 6f 6c 64 2d 64 65 6c 65 74 65 64 2d 74 65 e-old-deleted-te
8f00: 73 74 2d 72 65 63 6f 72 64 73 29 0a 20 20 28 72 st-records). (r
8f10: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
8f20: 27 64 65 6c 65 74 65 2d 6f 6c 64 2d 64 65 6c 65 'delete-old-dele
8f30: 74 65 64 2d 74 65 73 74 2d 72 65 63 6f 72 64 73 ted-test-records
8f40: 20 23 66 20 27 28 29 29 29 0a 0a 28 64 65 66 69 #f '()))..(defi
8f50: 6e 65 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e 73 ne (rmt:get-runs
8f60: 20 72 75 6e 70 61 74 74 20 63 6f 75 6e 74 20 6f runpatt count o
8f70: 66 66 73 65 74 20 6b 65 79 70 61 74 74 73 29 0a ffset keypatts).
8f80: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
8f90: 69 76 65 20 27 67 65 74 2d 72 75 6e 73 20 23 66 ive 'get-runs #f
8fa0: 20 28 6c 69 73 74 20 72 75 6e 70 61 74 74 20 63 (list runpatt c
8fb0: 6f 75 6e 74 20 6f 66 66 73 65 74 20 6b 65 79 70 ount offset keyp
8fc0: 61 74 74 73 29 29 29 0a 0a 28 64 65 66 69 6e 65 atts)))..(define
8fd0: 20 28 72 6d 74 3a 73 69 6d 70 6c 65 2d 67 65 74 (rmt:simple-get
8fe0: 2d 72 75 6e 73 20 72 75 6e 70 61 74 74 20 63 6f -runs runpatt co
8ff0: 75 6e 74 20 6f 66 66 73 65 74 20 74 61 72 67 65 unt offset targe
9000: 74 20 6c 61 73 74 2d 75 70 64 61 74 65 29 0a 20 t last-update).
9010: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
9020: 76 65 20 27 73 69 6d 70 6c 65 2d 67 65 74 2d 72 ve 'simple-get-r
9030: 75 6e 73 20 23 66 20 28 6c 69 73 74 20 72 75 6e uns #f (list run
9040: 70 61 74 74 20 63 6f 75 6e 74 20 6f 66 66 73 65 patt count offse
9050: 74 20 74 61 72 67 65 74 20 6c 61 73 74 2d 75 70 t target last-up
9060: 64 61 74 65 29 29 29 0a 0a 28 64 65 66 69 6e 65 date)))..(define
9070: 20 28 72 6d 74 3a 67 65 74 2d 61 6c 6c 2d 72 75 (rmt:get-all-ru
9080: 6e 2d 69 64 73 29 0a 20 20 28 72 6d 74 3a 73 65 n-ids). (rmt:se
9090: 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d nd-receive 'get-
90a0: 61 6c 6c 2d 72 75 6e 2d 69 64 73 20 23 66 20 27 all-run-ids #f '
90b0: 28 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 ()))..(define (r
90c0: 6d 74 3a 67 65 74 2d 70 72 65 76 2d 72 75 6e 2d mt:get-prev-run-
90d0: 69 64 73 20 72 75 6e 2d 69 64 29 0a 20 20 28 72 ids run-id). (r
90e0: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
90f0: 27 67 65 74 2d 70 72 65 76 2d 72 75 6e 2d 69 64 'get-prev-run-id
9100: 73 20 23 66 20 28 6c 69 73 74 20 72 75 6e 2d 69 s #f (list run-i
9110: 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 d)))..(define (r
9120: 6d 74 3a 6c 6f 63 6b 2f 75 6e 6c 6f 63 6b 2d 72 mt:lock/unlock-r
9130: 75 6e 20 72 75 6e 2d 69 64 20 6c 6f 63 6b 20 75 un run-id lock u
9140: 6e 6c 6f 63 6b 20 75 73 65 72 29 0a 20 20 28 72 nlock user). (r
9150: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
9160: 27 6c 6f 63 6b 2f 75 6e 6c 6f 63 6b 2d 72 75 6e 'lock/unlock-run
9170: 20 23 66 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 #f (list run-id
9180: 20 6c 6f 63 6b 20 75 6e 6c 6f 63 6b 20 75 73 65 lock unlock use
9190: 72 29 29 29 0a 0a 3b 3b 20 73 65 74 2f 67 65 74 r)))..;; set/get
91a0: 20 73 74 61 74 75 73 0a 28 64 65 66 69 6e 65 20 status.(define
91b0: 28 72 6d 74 3a 67 65 74 2d 72 75 6e 2d 73 74 61 (rmt:get-run-sta
91c0: 74 75 73 20 72 75 6e 2d 69 64 29 0a 20 20 28 72 tus run-id). (r
91d0: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
91e0: 27 67 65 74 2d 72 75 6e 2d 73 74 61 74 75 73 20 'get-run-status
91f0: 23 66 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 29 #f (list run-id)
9200: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
9210: 3a 67 65 74 2d 72 75 6e 2d 73 74 61 74 65 20 72 :get-run-state r
9220: 75 6e 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 un-id). (rmt:se
9230: 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 2d nd-receive 'get-
9240: 72 75 6e 2d 73 74 61 74 65 20 23 66 20 28 6c 69 run-state #f (li
9250: 73 74 20 72 75 6e 2d 69 64 29 29 29 0a 0a 0a 28 st run-id)))...(
9260: 64 65 66 69 6e 65 20 28 72 6d 74 3a 73 65 74 2d define (rmt:set-
9270: 72 75 6e 2d 73 74 61 74 75 73 20 72 75 6e 2d 69 run-status run-i
9280: 64 20 72 75 6e 2d 73 74 61 74 75 73 20 23 21 6b d run-status #!k
9290: 65 79 20 28 6d 73 67 20 23 66 29 29 0a 20 20 28 ey (msg #f)). (
92a0: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
92b0: 20 27 73 65 74 2d 72 75 6e 2d 73 74 61 74 75 73 'set-run-status
92c0: 20 23 66 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 #f (list run-id
92d0: 20 72 75 6e 2d 73 74 61 74 75 73 20 6d 73 67 29 run-status msg)
92e0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
92f0: 3a 73 65 74 2d 72 75 6e 2d 73 74 61 74 65 2d 73 :set-run-state-s
9300: 74 61 74 75 73 20 72 75 6e 2d 69 64 20 73 74 61 tatus run-id sta
9310: 74 65 20 73 74 61 74 75 73 20 29 0a 20 20 28 72 te status ). (r
9320: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
9330: 27 73 65 74 2d 72 75 6e 2d 73 74 61 74 65 2d 73 'set-run-state-s
9340: 74 61 74 75 73 20 23 66 20 28 6c 69 73 74 20 72 tatus #f (list r
9350: 75 6e 2d 69 64 20 73 74 61 74 65 20 73 74 61 74 un-id state stat
9360: 75 73 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 us)))..(define (
9370: 72 6d 74 3a 75 70 64 61 74 65 2d 74 65 73 64 61 rmt:update-tesda
9380: 74 61 2d 6f 6e 2d 72 65 70 69 6c 63 61 74 65 2d ta-on-repilcate-
9390: 64 62 20 6f 6c 64 2d 6c 74 20 6e 65 77 2d 6c 74 db old-lt new-lt
93a0: 29 0a 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 ).(rmt:send-rece
93b0: 69 76 65 20 27 75 70 64 61 74 65 2d 74 65 73 64 ive 'update-tesd
93c0: 61 74 61 2d 6f 6e 2d 72 65 70 69 6c 63 61 74 65 ata-on-repilcate
93d0: 2d 64 62 20 23 66 20 28 6c 69 73 74 20 6f 6c 64 -db #f (list old
93e0: 2d 6c 74 20 6e 65 77 2d 6c 74 29 29 29 0a 0a 28 -lt new-lt)))..(
93f0: 64 65 66 69 6e 65 20 28 72 6d 74 3a 75 70 64 61 define (rmt:upda
9400: 74 65 2d 72 75 6e 2d 65 76 65 6e 74 5f 74 69 6d te-run-event_tim
9410: 65 20 72 75 6e 2d 69 64 29 0a 20 20 28 72 6d 74 e run-id). (rmt
9420: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 75 :send-receive 'u
9430: 70 64 61 74 65 2d 72 75 6e 2d 65 76 65 6e 74 5f pdate-run-event_
9440: 74 69 6d 65 20 23 66 20 28 6c 69 73 74 20 72 75 time #f (list ru
9450: 6e 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 n-id)))..(define
9460: 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e 73 2d 62 (rmt:get-runs-b
9470: 79 2d 70 61 74 74 20 20 6b 65 79 73 20 72 75 6e y-patt keys run
9480: 6e 61 6d 65 70 61 74 74 20 74 61 72 67 70 61 74 namepatt targpat
9490: 74 20 6f 66 66 73 65 74 20 6c 69 6d 69 74 20 66 t offset limit f
94a0: 69 65 6c 64 73 20 6c 61 73 74 2d 72 75 6e 73 2d ields last-runs-
94b0: 75 70 64 61 74 65 20 20 23 21 6b 65 79 20 20 28 update #!key (
94c0: 73 6f 72 74 2d 6f 72 64 65 72 20 22 61 73 63 22 sort-order "asc"
94d0: 29 29 20 3b 3b 20 66 69 65 6c 64 73 20 6f 66 20 )) ;; fields of
94e0: 23 66 20 75 73 65 73 20 64 65 66 61 75 6c 74 0a #f uses default.
94f0: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
9500: 69 76 65 20 27 67 65 74 2d 72 75 6e 73 2d 62 79 ive 'get-runs-by
9510: 2d 70 61 74 74 20 23 66 20 28 6c 69 73 74 20 6b -patt #f (list k
9520: 65 79 73 20 72 75 6e 6e 61 6d 65 70 61 74 74 20 eys runnamepatt
9530: 74 61 72 67 70 61 74 74 20 6f 66 66 73 65 74 20 targpatt offset
9540: 6c 69 6d 69 74 20 66 69 65 6c 64 73 20 6c 61 73 limit fields las
9550: 74 2d 72 75 6e 73 2d 75 70 64 61 74 65 20 73 6f t-runs-update so
9560: 72 74 2d 6f 72 64 65 72 29 29 29 0a 0a 28 64 65 rt-order)))..(de
9570: 66 69 6e 65 20 28 72 6d 74 3a 66 69 6e 64 2d 61 fine (rmt:find-a
9580: 6e 64 2d 6d 61 72 6b 2d 69 6e 63 6f 6d 70 6c 65 nd-mark-incomple
9590: 74 65 20 72 75 6e 2d 69 64 20 6f 76 72 2d 64 65 te run-id ovr-de
95a0: 61 64 74 69 6d 65 29 0a 20 20 3b 3b 20 28 69 66 adtime). ;; (if
95b0: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
95c0: 76 65 20 27 68 61 76 65 2d 69 6e 63 6f 6d 70 6c ve 'have-incompl
95d0: 65 74 65 73 3f 20 72 75 6e 2d 69 64 20 28 6c 69 etes? run-id (li
95e0: 73 74 20 72 75 6e 2d 69 64 20 6f 76 72 2d 64 65 st run-id ovr-de
95f0: 61 64 74 69 6d 65 29 29 0a 20 20 28 72 6d 74 3a adtime)). (rmt:
9600: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 6d 61 send-receive 'ma
9610: 72 6b 2d 69 6e 63 6f 6d 70 6c 65 74 65 20 72 75 rk-incomplete ru
9620: 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 n-id (list run-i
9630: 64 20 6f 76 72 2d 64 65 61 64 74 69 6d 65 29 29 d ovr-deadtime))
9640: 29 20 3b 3b 20 29 0a 0a 28 64 65 66 69 6e 65 20 ) ;; )..(define
9650: 28 72 6d 74 3a 67 65 74 2d 6d 61 69 6e 2d 72 75 (rmt:get-main-ru
9660: 6e 2d 73 74 61 74 73 20 72 75 6e 2d 69 64 29 0a n-stats run-id).
9670: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
9680: 69 76 65 20 27 67 65 74 2d 6d 61 69 6e 2d 72 75 ive 'get-main-ru
9690: 6e 2d 73 74 61 74 73 20 23 66 20 28 6c 69 73 74 n-stats #f (list
96a0: 20 72 75 6e 2d 69 64 29 29 29 0a 0a 28 64 65 66 run-id)))..(def
96b0: 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 76 61 72 ine (rmt:get-var
96c0: 20 76 61 72 6e 61 6d 65 29 0a 20 20 28 72 6d 74 varname). (rmt
96d0: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 :send-receive 'g
96e0: 65 74 2d 76 61 72 20 23 66 20 28 6c 69 73 74 20 et-var #f (list
96f0: 76 61 72 6e 61 6d 65 29 29 29 0a 0a 28 64 65 66 varname)))..(def
9700: 69 6e 65 20 28 72 6d 74 3a 64 65 6c 2d 76 61 72 ine (rmt:del-var
9710: 20 76 61 72 6e 61 6d 65 29 0a 20 20 28 72 6d 74 varname). (rmt
9720: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 64 :send-receive 'd
9730: 65 6c 2d 76 61 72 20 23 66 20 28 6c 69 73 74 20 el-var #f (list
9740: 76 61 72 6e 61 6d 65 29 29 29 0a 0a 28 64 65 66 varname)))..(def
9750: 69 6e 65 20 28 72 6d 74 3a 73 65 74 2d 76 61 72 ine (rmt:set-var
9760: 20 76 61 72 6e 61 6d 65 20 76 61 6c 75 65 29 0a varname value).
9770: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
9780: 69 76 65 20 27 73 65 74 2d 76 61 72 20 23 66 20 ive 'set-var #f
9790: 28 6c 69 73 74 20 76 61 72 6e 61 6d 65 20 76 61 (list varname va
97a0: 6c 75 65 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 lue)))..(define
97b0: 28 72 6d 74 3a 69 6e 63 2d 76 61 72 20 76 61 72 (rmt:inc-var var
97c0: 6e 61 6d 65 29 0a 20 20 28 72 6d 74 3a 73 65 6e name). (rmt:sen
97d0: 64 2d 72 65 63 65 69 76 65 20 27 69 6e 63 2d 76 d-receive 'inc-v
97e0: 61 72 20 23 66 20 28 6c 69 73 74 20 76 61 72 6e ar #f (list varn
97f0: 61 6d 65 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ame)))..(define
9800: 28 72 6d 74 3a 64 65 63 2d 76 61 72 20 76 61 72 (rmt:dec-var var
9810: 6e 61 6d 65 29 0a 20 20 28 72 6d 74 3a 73 65 6e name). (rmt:sen
9820: 64 2d 72 65 63 65 69 76 65 20 27 64 65 63 2d 76 d-receive 'dec-v
9830: 61 72 20 23 66 20 28 6c 69 73 74 20 76 61 72 6e ar #f (list varn
9840: 61 6d 65 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ame)))..(define
9850: 28 72 6d 74 3a 61 64 64 2d 76 61 72 20 76 61 72 (rmt:add-var var
9860: 6e 61 6d 65 20 76 61 6c 75 65 29 0a 20 20 28 72 name value). (r
9870: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
9880: 27 61 64 64 2d 76 61 72 20 23 66 20 28 6c 69 73 'add-var #f (lis
9890: 74 20 76 61 72 6e 61 6d 65 20 76 61 6c 75 65 29 t varname value)
98a0: 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ))..;;==========
98b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
98c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
98d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
98e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
98f0: 4d 20 55 20 4c 20 54 20 49 20 52 20 55 20 4e 20 M U L T I R U N
9900: 20 20 51 20 55 20 45 20 52 20 49 20 45 20 53 0a Q U E R I E S.
9910: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
9920: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9930: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9940: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9950: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 4e 65 65 ========..;; Nee
9960: 64 20 74 6f 20 6d 6f 76 65 20 74 68 69 73 20 74 d to move this t
9970: 6f 20 6d 75 6c 74 69 2d 72 75 6e 20 73 65 63 74 o multi-run sect
9980: 69 6f 6e 20 61 6e 64 20 6d 61 6b 65 20 61 73 73 ion and make ass
9990: 6f 63 69 61 74 65 64 20 63 68 61 6e 67 65 73 0a ociated changes.
99a0: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 66 69 6e (define (rmt:fin
99b0: 64 2d 61 6e 64 2d 6d 61 72 6b 2d 69 6e 63 6f 6d d-and-mark-incom
99c0: 70 6c 65 74 65 2d 61 6c 6c 2d 72 75 6e 73 20 23 plete-all-runs #
99d0: 21 6b 65 79 20 28 6f 76 72 2d 64 65 61 64 74 69 !key (ovr-deadti
99e0: 6d 65 20 23 66 29 29 0a 20 20 28 6c 65 74 20 28 me #f)). (let (
99f0: 28 72 75 6e 2d 69 64 73 20 28 72 6d 74 3a 67 65 (run-ids (rmt:ge
9a00: 74 2d 61 6c 6c 2d 72 75 6e 2d 69 64 73 29 29 29 t-all-run-ids)))
9a10: 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 . (for-each (
9a20: 6c 61 6d 62 64 61 20 28 72 75 6e 2d 69 64 29 0a lambda (run-id).
9a30: 09 20 20 20 20 20 20 20 28 72 6d 74 3a 66 69 6e . (rmt:fin
9a40: 64 2d 61 6e 64 2d 6d 61 72 6b 2d 69 6e 63 6f 6d d-and-mark-incom
9a50: 70 6c 65 74 65 20 72 75 6e 2d 69 64 20 6f 76 72 plete run-id ovr
9a60: 2d 64 65 61 64 74 69 6d 65 29 29 0a 09 20 20 20 -deadtime))..
9a70: 20 20 72 75 6e 2d 69 64 73 29 29 29 0a 0a 3b 3b run-ids)))..;;
9a80: 20 67 65 74 20 74 68 65 20 70 72 65 76 69 6f 75 get the previou
9a90: 73 20 72 65 63 6f 72 64 20 66 6f 72 20 77 68 65 s record for whe
9aa0: 6e 20 74 68 69 73 20 74 65 73 74 20 77 61 73 20 n this test was
9ab0: 72 75 6e 20 77 68 65 72 65 20 61 6c 6c 20 6b 65 run where all ke
9ac0: 79 73 20 6d 61 74 63 68 20 62 75 74 20 72 75 6e ys match but run
9ad0: 6e 61 6d 65 0a 3b 3b 20 72 65 74 75 72 6e 73 20 name.;; returns
9ae0: 23 66 20 69 66 20 6e 6f 20 73 75 63 68 20 74 65 #f if no such te
9af0: 73 74 20 66 6f 75 6e 64 2c 20 72 65 74 75 72 6e st found, return
9b00: 73 20 61 20 73 69 6e 67 6c 65 20 74 65 73 74 20 s a single test
9b10: 72 65 63 6f 72 64 20 69 66 20 66 6f 75 6e 64 0a record if found.
9b20: 3b 3b 20 0a 3b 3b 20 52 75 6e 20 74 68 69 73 20 ;; .;; Run this
9b30: 61 74 20 74 68 65 20 63 6c 69 65 6e 74 20 65 6e at the client en
9b40: 64 20 73 69 6e 63 65 20 77 65 20 68 61 76 65 20 d since we have
9b50: 74 6f 20 63 6f 6e 6e 65 63 74 20 74 6f 20 6d 75 to connect to mu
9b60: 6c 74 69 70 6c 65 20 72 75 6e 2d 69 64 20 64 62 ltiple run-id db
9b70: 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 72 6d s.;;.(define (rm
9b80: 74 3a 67 65 74 2d 70 72 65 76 69 6f 75 73 2d 74 t:get-previous-t
9b90: 65 73 74 2d 72 75 6e 2d 72 65 63 6f 72 64 20 72 est-run-record r
9ba0: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 un-id test-name
9bb0: 69 74 65 6d 2d 70 61 74 68 29 0a 20 20 28 6c 65 item-path). (le
9bc0: 74 2a 20 28 28 6b 65 79 76 61 6c 73 20 28 72 6d t* ((keyvals (rm
9bd0: 74 3a 67 65 74 2d 6b 65 79 2d 76 61 6c 2d 70 61 t:get-key-val-pa
9be0: 69 72 73 20 72 75 6e 2d 69 64 29 29 0a 09 20 28 irs run-id)).. (
9bf0: 6b 65 79 73 20 20 20 20 28 72 6d 74 3a 67 65 74 keys (rmt:get
9c00: 2d 6b 65 79 73 29 29 0a 09 20 28 73 65 6c 73 74 -keys)).. (selst
9c10: 72 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 r (string-inter
9c20: 73 70 65 72 73 65 20 20 6b 65 79 73 20 22 2c 22 sperse keys ","
9c30: 29 29 0a 09 20 28 71 72 79 73 74 72 20 20 28 73 )).. (qrystr (s
9c40: 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 tring-interspers
9c50: 65 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 e (map (lambda (
9c60: 78 29 28 63 6f 6e 63 20 78 20 22 3d 3f 22 29 29 x)(conc x "=?"))
9c70: 20 6b 65 79 73 29 20 22 20 41 4e 44 20 22 29 29 keys) " AND "))
9c80: 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 6b ). (if (not k
9c90: 65 79 76 61 6c 73 29 0a 09 23 66 0a 09 28 6c 65 eyvals)..#f..(le
9ca0: 74 20 28 28 70 72 65 76 2d 72 75 6e 2d 69 64 73 t ((prev-run-ids
9cb0: 20 28 72 6d 74 3a 67 65 74 2d 70 72 65 76 2d 72 (rmt:get-prev-r
9cc0: 75 6e 2d 69 64 73 20 72 75 6e 2d 69 64 29 29 29 un-ids run-id)))
9cd0: 0a 09 20 20 3b 3b 20 66 6f 72 20 65 61 63 68 20 .. ;; for each
9ce0: 72 75 6e 20 73 74 61 72 74 69 6e 67 20 77 69 74 run starting wit
9cf0: 68 20 74 68 65 20 6d 6f 73 74 20 72 65 63 65 6e h the most recen
9d00: 74 20 6c 6f 6f 6b 20 74 6f 20 73 65 65 20 69 66 t look to see if
9d10: 20 74 68 65 72 65 20 69 73 20 61 20 6d 61 74 63 there is a matc
9d20: 68 69 6e 67 20 74 65 73 74 0a 09 20 20 3b 3b 20 hing test.. ;;
9d30: 69 66 20 66 6f 75 6e 64 20 74 68 65 6e 20 72 65 if found then re
9d40: 74 75 72 6e 20 74 68 61 74 20 6d 61 74 63 68 69 turn that matchi
9d50: 6e 67 20 74 65 73 74 20 72 65 63 6f 72 64 0a 09 ng test record..
9d60: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 (debug:print 4
9d70: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
9d80: 72 74 2a 20 22 73 65 6c 73 74 72 3a 20 22 20 73 rt* "selstr: " s
9d90: 65 6c 73 74 72 20 22 2c 20 71 72 79 73 74 72 3a elstr ", qrystr:
9da0: 20 22 20 71 72 79 73 74 72 20 22 2c 20 6b 65 79 " qrystr ", key
9db0: 76 61 6c 73 3a 20 22 20 6b 65 79 76 61 6c 73 20 vals: " keyvals
9dc0: 22 2c 20 70 72 65 76 69 6f 75 73 20 72 75 6e 20 ", previous run
9dd0: 69 64 73 20 66 6f 75 6e 64 3a 20 22 20 70 72 65 ids found: " pre
9de0: 76 2d 72 75 6e 2d 69 64 73 29 0a 09 20 20 28 69 v-run-ids).. (i
9df0: 66 20 28 6e 75 6c 6c 3f 20 70 72 65 76 2d 72 75 f (null? prev-ru
9e00: 6e 2d 69 64 73 29 20 23 66 0a 09 20 20 20 20 20 n-ids) #f..
9e10: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 (let loop ((hed
9e20: 20 28 63 61 72 20 70 72 65 76 2d 72 75 6e 2d 69 (car prev-run-i
9e30: 64 73 29 29 0a 09 09 09 20 28 74 61 6c 20 28 63 ds)).... (tal (c
9e40: 64 72 20 70 72 65 76 2d 72 75 6e 2d 69 64 73 29 dr prev-run-ids)
9e50: 29 29 0a 09 09 28 6c 65 74 20 28 28 72 65 73 75 ))...(let ((resu
9e60: 6c 74 73 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 lts (rmt:get-tes
9e70: 74 73 2d 66 6f 72 2d 72 75 6e 20 68 65 64 20 28 ts-for-run hed (
9e80: 63 6f 6e 63 20 74 65 73 74 2d 6e 61 6d 65 20 22 conc test-name "
9e90: 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 20 27 28 /" item-path) '(
9ea0: 29 20 27 28 29 20 3b 3b 20 72 75 6e 2d 69 64 20 ) '() ;; run-id
9eb0: 74 65 73 74 70 61 74 74 20 73 74 61 74 65 73 20 testpatt states
9ec0: 73 74 61 74 75 73 65 73 0a 09 09 09 09 09 09 20 statuses.......
9ed0: 20 20 20 20 20 23 66 20 23 66 20 23 66 20 20 20 #f #f #f
9ee0: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 6f ;; o
9ef0: 66 66 73 65 74 20 6c 69 6d 69 74 20 6e 6f 74 2d ffset limit not-
9f00: 69 6e 20 68 69 64 65 2f 6e 6f 74 2d 68 69 64 65 in hide/not-hide
9f10: 0a 09 09 09 09 09 09 20 20 20 20 20 20 23 66 20 ....... #f
9f20: 23 66 20 23 66 20 23 66 20 27 6e 6f 72 6d 61 6c #f #f #f 'normal
9f30: 29 29 29 20 3b 3b 20 73 6f 72 74 2d 62 79 20 73 ))) ;; sort-by s
9f40: 6f 72 74 2d 6f 72 64 65 72 20 71 72 79 76 61 6c ort-order qryval
9f50: 73 20 6c 61 73 74 2d 75 70 64 61 74 65 20 6d 6f s last-update mo
9f60: 64 65 0a 09 09 20 20 28 64 65 62 75 67 3a 70 72 de... (debug:pr
9f70: 69 6e 74 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c int 4 *default-l
9f80: 6f 67 2d 70 6f 72 74 2a 20 22 47 6f 74 20 74 65 og-port* "Got te
9f90: 73 74 73 20 66 6f 72 20 72 75 6e 2d 69 64 20 22 sts for run-id "
9fa0: 20 72 75 6e 2d 69 64 20 22 2c 20 74 65 73 74 2d run-id ", test-
9fb0: 6e 61 6d 65 20 22 20 74 65 73 74 2d 6e 61 6d 65 name " test-name
9fc0: 20 22 2c 20 69 74 65 6d 2d 70 61 74 68 20 22 20 ", item-path "
9fd0: 69 74 65 6d 2d 70 61 74 68 20 22 3a 20 22 20 72 item-path ": " r
9fe0: 65 73 75 6c 74 73 29 0a 09 09 20 20 28 69 66 20 esults)... (if
9ff0: 28 61 6e 64 20 28 6e 75 6c 6c 3f 20 72 65 73 75 (and (null? resu
a000: 6c 74 73 29 0a 09 09 09 20 20 20 28 6e 6f 74 20 lts).... (not
a010: 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 29 0a 09 09 (null? tal)))...
a020: 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 (loop (car
a030: 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 29 0a tal)(cdr tal)).
a040: 09 09 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c .. (if (nul
a050: 6c 3f 20 72 65 73 75 6c 74 73 29 20 23 66 0a 09 l? results) #f..
a060: 09 09 20 20 28 63 61 72 20 72 65 73 75 6c 74 73 .. (car results
a070: 29 29 29 29 29 29 29 29 29 29 0a 0a 28 64 65 66 ))))))))))..(def
a080: 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e ine (rmt:get-run
a090: 2d 73 74 61 74 73 29 0a 20 20 28 72 6d 74 3a 73 -stats). (rmt:s
a0a0: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 65 74 end-receive 'get
a0b0: 2d 72 75 6e 2d 73 74 61 74 73 20 23 66 20 27 28 -run-stats #f '(
a0c0: 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d )))..;;=========
a0d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a0e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a0f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a100: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
a110: 20 20 53 20 54 20 45 20 50 20 53 0a 3b 3b 3d 3d S T E P S.;;==
a120: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a130: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a140: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a150: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a160: 3d 3d 3d 3d 0a 0a 3b 3b 20 47 65 74 74 69 6e 67 ====..;; Getting
a170: 20 73 74 65 70 73 20 69 73 20 6d 6f 72 65 20 63 steps is more c
a180: 6f 6d 70 6c 69 63 61 74 65 64 2e 0a 3b 3b 0a 3b omplicated..;;.;
a190: 3b 20 49 66 20 67 69 76 65 6e 20 77 6f 72 6b 20 ; If given work
a1a0: 61 72 65 61 20 0a 3b 3b 20 20 31 2e 20 46 69 6e area .;; 1. Fin
a1b0: 64 20 74 68 65 20 74 65 73 74 64 61 74 2e 64 62 d the testdat.db
a1c0: 20 66 69 6c 65 0a 3b 3b 20 20 32 2e 20 4f 70 65 file.;; 2. Ope
a1d0: 6e 20 74 68 65 20 74 65 73 74 64 61 74 2e 64 62 n the testdat.db
a1e0: 20 66 69 6c 65 20 61 6e 64 20 64 6f 20 74 68 65 file and do the
a1f0: 20 71 75 65 72 79 0a 3b 3b 20 49 66 20 6e 6f 74 query.;; If not
a200: 20 67 69 76 65 6e 20 74 68 65 20 77 6f 72 6b 20 given the work
a210: 61 72 65 61 0a 3b 3b 20 20 31 2e 20 44 6f 20 61 area.;; 1. Do a
a220: 20 72 65 6d 6f 74 65 20 63 61 6c 6c 20 74 6f 20 remote call to
a230: 67 65 74 20 74 68 65 20 74 65 73 74 20 70 61 74 get the test pat
a240: 68 0a 3b 3b 20 20 32 2e 20 43 6f 6e 74 69 6e 75 h.;; 2. Continu
a250: 65 20 61 73 20 61 62 6f 76 65 0a 3b 3b 20 0a 3b e as above.;; .;
a260: 3b 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 67 65 ;(define (rmt:ge
a270: 74 2d 73 74 65 70 73 2d 66 6f 72 2d 74 65 73 74 t-steps-for-test
a280: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 run-id test-id)
a290: 0a 3b 3b 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 .;; (rmt:send-r
a2a0: 65 63 65 69 76 65 20 27 67 65 74 2d 73 74 65 70 eceive 'get-step
a2b0: 73 2d 64 61 74 61 20 72 75 6e 2d 69 64 20 28 6c s-data run-id (l
a2c0: 69 73 74 20 74 65 73 74 2d 69 64 29 29 29 0a 0a ist test-id)))..
a2d0: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 65 73 (define (rmt:tes
a2e0: 74 73 74 65 70 2d 73 65 74 2d 73 74 61 74 75 73 tstep-set-status
a2f0: 21 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 ! run-id test-id
a300: 20 74 65 73 74 73 74 65 70 2d 6e 61 6d 65 20 73 teststep-name s
a310: 74 61 74 65 2d 69 6e 20 73 74 61 74 75 73 2d 69 tate-in status-i
a320: 6e 20 63 6f 6d 6d 65 6e 74 20 6c 6f 67 66 69 6c n comment logfil
a330: 65 29 0a 20 20 28 6c 65 74 2a 20 28 28 73 74 61 e). (let* ((sta
a340: 74 65 20 20 20 20 20 28 69 74 65 6d 73 3a 63 68 te (items:ch
a350: 65 63 6b 2d 76 61 6c 69 64 2d 69 74 65 6d 73 20 eck-valid-items
a360: 22 73 74 61 74 65 22 20 73 74 61 74 65 2d 69 6e "state" state-in
a370: 29 29 0a 09 20 28 73 74 61 74 75 73 20 20 20 20 )).. (status
a380: 28 69 74 65 6d 73 3a 63 68 65 63 6b 2d 76 61 6c (items:check-val
a390: 69 64 2d 69 74 65 6d 73 20 22 73 74 61 74 75 73 id-items "status
a3a0: 22 20 73 74 61 74 75 73 2d 69 6e 29 29 29 0a 20 " status-in))).
a3b0: 20 20 20 28 69 66 20 28 6f 72 20 28 6e 6f 74 20 (if (or (not
a3c0: 73 74 61 74 65 29 28 6e 6f 74 20 73 74 61 74 75 state)(not statu
a3d0: 73 29 29 0a 09 28 64 65 62 75 67 3a 70 72 69 6e s))..(debug:prin
a3e0: 74 20 33 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 3 *default-log
a3f0: 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a -port* "WARNING:
a400: 20 49 6e 76 61 6c 69 64 20 22 20 28 69 66 20 73 Invalid " (if s
a410: 74 61 74 75 73 20 22 73 74 61 74 75 73 22 20 22 tatus "status" "
a420: 73 74 61 74 65 22 29 0a 09 09 20 20 20 20 20 22 state")... "
a430: 20 76 61 6c 75 65 20 5c 22 22 20 28 69 66 20 73 value \"" (if s
a440: 74 61 74 75 73 20 73 74 61 74 65 2d 69 6e 20 73 tatus state-in s
a450: 74 61 74 75 73 2d 69 6e 29 20 22 5c 22 2c 20 75 tatus-in) "\", u
a460: 70 64 61 74 65 20 79 6f 75 72 20 76 61 6c 69 64 pdate your valid
a470: 76 61 6c 75 65 73 20 73 65 63 74 69 6f 6e 20 69 values section i
a480: 6e 20 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 n megatest.confi
a490: 67 22 29 29 0a 20 20 20 20 28 72 6d 74 3a 73 65 g")). (rmt:se
a4a0: 6e 64 2d 72 65 63 65 69 76 65 20 27 74 65 73 74 nd-receive 'test
a4b0: 73 74 65 70 2d 73 65 74 2d 73 74 61 74 75 73 21 step-set-status!
a4c0: 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 20 72 75 run-id (list ru
a4d0: 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 74 65 73 n-id test-id tes
a4e0: 74 73 74 65 70 2d 6e 61 6d 65 20 73 74 61 74 65 tstep-name state
a4f0: 2d 69 6e 20 73 74 61 74 75 73 2d 69 6e 20 63 6f -in status-in co
a500: 6d 6d 65 6e 74 20 6c 6f 67 66 69 6c 65 29 29 29 mment logfile)))
a510: 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 )...(define (rmt
a520: 3a 64 65 6c 65 74 65 2d 73 74 65 70 73 2d 66 6f :delete-steps-fo
a530: 72 2d 74 65 73 74 21 20 72 75 6e 2d 69 64 20 74 r-test! run-id t
a540: 65 73 74 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 est-id). (rmt:s
a550: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 64 65 6c end-receive 'del
a560: 65 74 65 2d 73 74 65 70 73 2d 66 6f 72 2d 74 65 ete-steps-for-te
a570: 73 74 21 20 72 75 6e 2d 69 64 20 28 6c 69 73 74 st! run-id (list
a580: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 run-id test-id)
a590: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ))..(define (rmt
a5a0: 3a 67 65 74 2d 73 74 65 70 73 2d 66 6f 72 2d 74 :get-steps-for-t
a5b0: 65 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d est run-id test-
a5c0: 69 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d id). (rmt:send-
a5d0: 72 65 63 65 69 76 65 20 27 67 65 74 2d 73 74 65 receive 'get-ste
a5e0: 70 73 2d 66 6f 72 2d 74 65 73 74 20 72 75 6e 2d ps-for-test run-
a5f0: 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 id (list run-id
a600: 74 65 73 74 2d 69 64 29 29 29 0a 0a 28 64 65 66 test-id)))..(def
a610: 69 6e 65 20 28 72 6d 74 3a 67 65 74 2d 73 74 65 ine (rmt:get-ste
a620: 70 73 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 74 65 ps-info-by-id te
a630: 73 74 2d 73 74 65 70 2d 69 64 29 0a 20 20 28 72 st-step-id). (r
a640: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
a650: 27 67 65 74 2d 73 74 65 70 73 2d 69 6e 66 6f 2d 'get-steps-info-
a660: 62 79 2d 69 64 20 23 66 20 28 6c 69 73 74 20 74 by-id #f (list t
a670: 65 73 74 2d 73 74 65 70 2d 69 64 29 29 29 0a 0a est-step-id)))..
a680: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
a690: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a6a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a6b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a6c0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 54 20 45 ========.;; T E
a6d0: 20 53 20 54 20 20 20 44 20 41 20 54 20 41 20 0a S T D A T A .
a6e0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
a6f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a700: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a710: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a720: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e ========..(defin
a730: 65 20 28 72 6d 74 3a 72 65 61 64 2d 74 65 73 74 e (rmt:read-test
a740: 2d 64 61 74 61 20 72 75 6e 2d 69 64 20 74 65 73 -data run-id tes
a750: 74 2d 69 64 20 63 61 74 65 67 6f 72 79 70 61 74 t-id categorypat
a760: 74 20 23 21 6b 65 79 20 28 77 6f 72 6b 2d 61 72 t #!key (work-ar
a770: 65 61 20 23 66 29 29 20 0a 20 20 28 72 6d 74 3a ea #f)) . (rmt:
a780: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 72 65 send-receive 're
a790: 61 64 2d 74 65 73 74 2d 64 61 74 61 20 72 75 6e ad-test-data run
a7a0: 2d 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 -id (list run-id
a7b0: 20 74 65 73 74 2d 69 64 20 63 61 74 65 67 6f 72 test-id categor
a7c0: 79 70 61 74 74 29 29 29 0a 0a 28 64 65 66 69 6e ypatt)))..(defin
a7d0: 65 20 28 72 6d 74 3a 72 65 61 64 2d 74 65 73 74 e (rmt:read-test
a7e0: 2d 64 61 74 61 2d 76 61 72 70 61 74 74 20 72 75 -data-varpatt ru
a7f0: 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 63 61 74 n-id test-id cat
a800: 65 67 6f 72 79 70 61 74 74 20 76 61 72 70 61 74 egorypatt varpat
a810: 74 20 23 21 6b 65 79 20 28 77 6f 72 6b 2d 61 72 t #!key (work-ar
a820: 65 61 20 23 66 29 29 20 0a 20 20 28 72 6d 74 3a ea #f)) . (rmt:
a830: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 72 65 send-receive 're
a840: 61 64 2d 74 65 73 74 2d 64 61 74 61 2d 76 61 72 ad-test-data-var
a850: 70 61 74 74 20 72 75 6e 2d 69 64 20 28 6c 69 73 patt run-id (lis
a860: 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 t run-id test-id
a870: 20 63 61 74 65 67 6f 72 79 70 61 74 74 20 76 61 categorypatt va
a880: 72 70 61 74 74 29 29 29 0a 0a 28 64 65 66 69 6e rpatt)))..(defin
a890: 65 20 28 72 6d 74 3a 67 65 74 2d 64 61 74 61 2d e (rmt:get-data-
a8a0: 69 6e 66 6f 2d 62 79 2d 69 64 20 74 65 73 74 2d info-by-id test-
a8b0: 64 61 74 61 2d 69 64 29 0a 20 20 20 28 72 6d 74 data-id). (rmt
a8c0: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 67 :send-receive 'g
a8d0: 65 74 2d 64 61 74 61 2d 69 6e 66 6f 2d 62 79 2d et-data-info-by-
a8e0: 69 64 20 23 66 20 28 6c 69 73 74 20 74 65 73 74 id #f (list test
a8f0: 2d 64 61 74 61 2d 69 64 29 29 29 0a 0a 28 64 65 -data-id)))..(de
a900: 66 69 6e 65 20 28 72 6d 74 3a 74 65 73 74 6d 65 fine (rmt:testme
a910: 74 61 2d 61 64 64 2d 72 65 63 6f 72 64 20 74 65 ta-add-record te
a920: 73 74 6e 61 6d 65 29 0a 20 20 28 72 6d 74 3a 73 stname). (rmt:s
a930: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 74 65 73 end-receive 'tes
a940: 74 6d 65 74 61 2d 61 64 64 2d 72 65 63 6f 72 64 tmeta-add-record
a950: 20 23 66 20 28 6c 69 73 74 20 74 65 73 74 6e 61 #f (list testna
a960: 6d 65 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 me)))..(define (
a970: 72 6d 74 3a 74 65 73 74 6d 65 74 61 2d 67 65 74 rmt:testmeta-get
a980: 2d 72 65 63 6f 72 64 20 74 65 73 74 6e 61 6d 65 -record testname
a990: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
a9a0: 63 65 69 76 65 20 27 74 65 73 74 6d 65 74 61 2d ceive 'testmeta-
a9b0: 67 65 74 2d 72 65 63 6f 72 64 20 23 66 20 28 6c get-record #f (l
a9c0: 69 73 74 20 74 65 73 74 6e 61 6d 65 29 29 29 0a ist testname))).
a9d0: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 65 .(define (rmt:te
a9e0: 73 74 6d 65 74 61 2d 75 70 64 61 74 65 2d 66 69 stmeta-update-fi
a9f0: 65 6c 64 20 74 65 73 74 2d 6e 61 6d 65 20 66 6c eld test-name fl
aa00: 64 20 76 61 6c 29 0a 20 20 28 72 6d 74 3a 73 65 d val). (rmt:se
aa10: 6e 64 2d 72 65 63 65 69 76 65 20 27 74 65 73 74 nd-receive 'test
aa20: 6d 65 74 61 2d 75 70 64 61 74 65 2d 66 69 65 6c meta-update-fiel
aa30: 64 20 23 66 20 28 6c 69 73 74 20 74 65 73 74 2d d #f (list test-
aa40: 6e 61 6d 65 20 66 6c 64 20 76 61 6c 29 29 29 0a name fld val))).
aa50: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 65 .(define (rmt:te
aa60: 73 74 2d 64 61 74 61 2d 72 6f 6c 6c 75 70 20 72 st-data-rollup r
aa70: 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 73 74 un-id test-id st
aa80: 61 74 75 73 29 0a 20 20 28 72 6d 74 3a 73 65 6e atus). (rmt:sen
aa90: 64 2d 72 65 63 65 69 76 65 20 27 74 65 73 74 2d d-receive 'test-
aaa0: 64 61 74 61 2d 72 6f 6c 6c 75 70 20 72 75 6e 2d data-rollup run-
aab0: 69 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 id (list run-id
aac0: 74 65 73 74 2d 69 64 20 73 74 61 74 75 73 29 29 test-id status))
aad0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a )..(define (rmt:
aae0: 63 73 76 2d 3e 74 65 73 74 2d 64 61 74 61 20 72 csv->test-data r
aaf0: 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 63 73 un-id test-id cs
ab00: 76 64 61 74 61 29 0a 20 20 28 72 6d 74 3a 73 65 vdata). (rmt:se
ab10: 6e 64 2d 72 65 63 65 69 76 65 20 27 63 73 76 2d nd-receive 'csv-
ab20: 3e 74 65 73 74 2d 64 61 74 61 20 72 75 6e 2d 69 >test-data run-i
ab30: 64 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 74 d (list run-id t
ab40: 65 73 74 2d 69 64 20 63 73 76 64 61 74 61 29 29 est-id csvdata))
ab50: 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )..;;===========
ab60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ab70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ab80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ab90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 ===========.;;
aba0: 54 20 41 20 53 20 4b 20 53 0a 3b 3b 3d 3d 3d 3d T A S K S.;;====
abb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
abc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
abd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
abe0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
abf0: 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 ==..(define (rmt
ac00: 3a 74 61 73 6b 73 2d 66 69 6e 64 2d 74 61 73 6b :tasks-find-task
ac10: 2d 71 75 65 75 65 2d 72 65 63 6f 72 64 73 20 74 -queue-records t
ac20: 61 72 67 65 74 20 72 75 6e 2d 6e 61 6d 65 20 74 arget run-name t
ac30: 65 73 74 2d 70 61 74 74 20 73 74 61 74 65 2d 70 est-patt state-p
ac40: 61 74 74 20 61 63 74 69 6f 6e 2d 70 61 74 74 29 att action-patt)
ac50: 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 . (rmt:send-rec
ac60: 65 69 76 65 20 27 66 69 6e 64 2d 74 61 73 6b 2d eive 'find-task-
ac70: 71 75 65 75 65 2d 72 65 63 6f 72 64 73 20 23 66 queue-records #f
ac80: 20 28 6c 69 73 74 20 74 61 72 67 65 74 20 72 75 (list target ru
ac90: 6e 2d 6e 61 6d 65 20 74 65 73 74 2d 70 61 74 74 n-name test-patt
aca0: 20 73 74 61 74 65 2d 70 61 74 74 20 61 63 74 69 state-patt acti
acb0: 6f 6e 2d 70 61 74 74 29 29 29 0a 0a 28 64 65 66 on-patt)))..(def
acc0: 69 6e 65 20 28 72 6d 74 3a 74 61 73 6b 73 2d 61 ine (rmt:tasks-a
acd0: 64 64 20 61 63 74 69 6f 6e 20 6f 77 6e 65 72 20 dd action owner
ace0: 74 61 72 67 65 74 20 72 75 6e 6e 61 6d 65 20 74 target runname t
acf0: 65 73 74 70 61 74 74 20 70 61 72 61 6d 73 29 0a estpatt params).
ad00: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
ad10: 69 76 65 20 27 74 61 73 6b 73 2d 61 64 64 20 23 ive 'tasks-add #
ad20: 66 20 28 6c 69 73 74 20 61 63 74 69 6f 6e 20 6f f (list action o
ad30: 77 6e 65 72 20 74 61 72 67 65 74 20 72 75 6e 6e wner target runn
ad40: 61 6d 65 20 74 65 73 74 70 61 74 74 20 70 61 72 ame testpatt par
ad50: 61 6d 73 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ams)))..(define
ad60: 28 72 6d 74 3a 74 61 73 6b 73 2d 73 65 74 2d 73 (rmt:tasks-set-s
ad70: 74 61 74 65 2d 67 69 76 65 6e 2d 70 61 72 61 6d tate-given-param
ad80: 2d 6b 65 79 20 70 61 72 61 6d 2d 6b 65 79 20 6e -key param-key n
ad90: 65 77 2d 73 74 61 74 65 29 0a 20 20 28 72 6d 74 ew-state). (rmt
ada0: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 74 :send-receive 't
adb0: 61 73 6b 73 2d 73 65 74 2d 73 74 61 74 65 2d 67 asks-set-state-g
adc0: 69 76 65 6e 2d 70 61 72 61 6d 2d 6b 65 79 20 23 iven-param-key #
add0: 66 20 28 6c 69 73 74 20 20 70 61 72 61 6d 2d 6b f (list param-k
ade0: 65 79 20 6e 65 77 2d 73 74 61 74 65 29 29 29 0a ey new-state))).
adf0: 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 61 .(define (rmt:ta
ae00: 73 6b 73 2d 67 65 74 2d 6c 61 73 74 20 74 61 72 sks-get-last tar
ae10: 67 65 74 20 72 75 6e 6e 61 6d 65 29 0a 20 20 28 get runname). (
ae20: 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 rmt:send-receive
ae30: 20 27 74 61 73 6b 73 2d 67 65 74 2d 6c 61 73 74 'tasks-get-last
ae40: 20 23 66 20 28 6c 69 73 74 20 74 61 72 67 65 74 #f (list target
ae50: 20 72 75 6e 6e 61 6d 65 29 29 29 0a 0a 3b 3b 3d runname)))..;;=
ae60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ae70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ae80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ae90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aea0: 3d 3d 3d 3d 3d 0a 3b 3b 20 4e 20 4f 20 20 20 53 =====.;; N O S
aeb0: 20 59 20 4e 20 43 20 20 20 44 20 42 20 0a 3b 3b Y N C D B .;;
aec0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aed0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aee0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aef0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
af00: 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 ======..(define
af10: 28 72 6d 74 3a 6e 6f 2d 73 79 6e 63 2d 73 65 74 (rmt:no-sync-set
af20: 20 76 61 72 20 76 61 6c 29 0a 20 20 28 72 6d 74 var val). (rmt
af30: 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 6e :send-receive 'n
af40: 6f 2d 73 79 6e 63 2d 73 65 74 20 23 66 20 60 28 o-sync-set #f `(
af50: 2c 76 61 72 20 2c 76 61 6c 29 29 29 0a 0a 28 64 ,var ,val)))..(d
af60: 65 66 69 6e 65 20 28 72 6d 74 3a 6e 6f 2d 73 79 efine (rmt:no-sy
af70: 6e 63 2d 67 65 74 2f 64 65 66 61 75 6c 74 20 76 nc-get/default v
af80: 61 72 20 64 65 66 61 75 6c 74 29 0a 20 20 28 72 ar default). (r
af90: 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 mt:send-receive
afa0: 27 6e 6f 2d 73 79 6e 63 2d 67 65 74 2f 64 65 66 'no-sync-get/def
afb0: 61 75 6c 74 20 23 66 20 60 28 2c 76 61 72 20 2c ault #f `(,var ,
afc0: 64 65 66 61 75 6c 74 29 29 29 0a 0a 28 64 65 66 default)))..(def
afd0: 69 6e 65 20 28 72 6d 74 3a 6e 6f 2d 73 79 6e 63 ine (rmt:no-sync
afe0: 2d 64 65 6c 21 20 76 61 72 29 0a 20 20 28 72 6d -del! var). (rm
aff0: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 27 t:send-receive '
b000: 6e 6f 2d 73 79 6e 63 2d 64 65 6c 21 20 23 66 20 no-sync-del! #f
b010: 60 28 2c 76 61 72 29 29 29 0a 0a 28 64 65 66 69 `(,var)))..(defi
b020: 6e 65 20 28 72 6d 74 3a 6e 6f 2d 73 79 6e 63 2d ne (rmt:no-sync-
b030: 67 65 74 2d 6c 6f 63 6b 20 6b 65 79 6e 61 6d 65 get-lock keyname
b040: 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 ). (rmt:send-re
b050: 63 65 69 76 65 20 27 6e 6f 2d 73 79 6e 63 2d 67 ceive 'no-sync-g
b060: 65 74 2d 6c 6f 63 6b 20 23 66 20 60 28 2c 6b 65 et-lock #f `(,ke
b070: 79 6e 61 6d 65 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d yname)))..;;====
b080: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b090: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b0a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b0b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b0c0: 3d 3d 0a 3b 3b 20 41 20 52 20 43 20 48 20 49 20 ==.;; A R C H I
b0d0: 56 20 45 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d V E S.;;========
b0e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b0f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b100: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b110: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
b120: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 61 72 63 (define (rmt:arc
b130: 68 69 76 65 2d 67 65 74 2d 61 6c 6c 6f 63 61 74 hive-get-allocat
b140: 69 6f 6e 73 20 20 74 65 73 74 6e 61 6d 65 20 69 ions testname i
b150: 74 65 6d 70 61 74 68 20 64 6e 65 65 64 65 64 29 tempath dneeded)
b160: 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 . (rmt:send-rec
b170: 65 69 76 65 20 27 61 72 63 68 69 76 65 2d 67 65 eive 'archive-ge
b180: 74 2d 61 6c 6c 6f 63 61 74 69 6f 6e 73 20 23 66 t-allocations #f
b190: 20 28 6c 69 73 74 20 74 65 73 74 6e 61 6d 65 20 (list testname
b1a0: 69 74 65 6d 70 61 74 68 20 64 6e 65 65 64 65 64 itempath dneeded
b1b0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d )))..(define (rm
b1c0: 74 3a 61 72 63 68 69 76 65 2d 72 65 67 69 73 74 t:archive-regist
b1d0: 65 72 2d 62 6c 6f 63 6b 2d 6e 61 6d 65 20 62 64 er-block-name bd
b1e0: 69 73 6b 2d 69 64 20 61 72 63 68 69 76 65 2d 70 isk-id archive-p
b1f0: 61 74 68 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 ath). (rmt:send
b200: 2d 72 65 63 65 69 76 65 20 27 61 72 63 68 69 76 -receive 'archiv
b210: 65 2d 72 65 67 69 73 74 65 72 2d 62 6c 6f 63 6b e-register-block
b220: 2d 6e 61 6d 65 20 23 66 20 28 6c 69 73 74 20 62 -name #f (list b
b230: 64 69 73 6b 2d 69 64 20 61 72 63 68 69 76 65 2d disk-id archive-
b240: 70 61 74 68 29 29 29 0a 0a 28 64 65 66 69 6e 65 path)))..(define
b250: 20 28 72 6d 74 3a 61 72 63 68 69 76 65 2d 61 6c (rmt:archive-al
b260: 6c 6f 63 61 74 65 2d 74 65 73 74 73 75 69 74 65 locate-testsuite
b270: 2f 61 72 65 61 2d 74 6f 2d 62 6c 6f 63 6b 20 62 /area-to-block b
b280: 6c 6f 63 6b 2d 69 64 20 74 65 73 74 73 75 69 74 lock-id testsuit
b290: 65 2d 6e 61 6d 65 20 61 72 65 61 6b 65 79 29 0a e-name areakey).
b2a0: 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 (rmt:send-rece
b2b0: 69 76 65 20 27 61 72 63 68 69 76 65 2d 61 6c 6c ive 'archive-all
b2c0: 6f 63 61 74 65 2d 74 65 73 74 2d 74 6f 2d 62 6c ocate-test-to-bl
b2d0: 6f 63 6b 20 23 66 20 28 6c 69 73 74 20 20 62 6c ock #f (list bl
b2e0: 6f 63 6b 2d 69 64 20 74 65 73 74 73 75 69 74 65 ock-id testsuite
b2f0: 2d 6e 61 6d 65 20 61 72 65 61 6b 65 79 29 29 29 -name areakey)))
b300: 0a 0a 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 61 ..(define (rmt:a
b310: 72 63 68 69 76 65 2d 72 65 67 69 73 74 65 72 2d rchive-register-
b320: 64 69 73 6b 20 62 64 69 73 6b 2d 6e 61 6d 65 20 disk bdisk-name
b330: 62 64 69 73 6b 2d 70 61 74 68 20 64 66 29 0a 20 bdisk-path df).
b340: 20 28 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 69 (rmt:send-recei
b350: 76 65 20 27 61 72 63 68 69 76 65 2d 72 65 67 69 ve 'archive-regi
b360: 73 74 65 72 2d 64 69 73 6b 20 23 66 20 28 6c 69 ster-disk #f (li
b370: 73 74 20 62 64 69 73 6b 2d 6e 61 6d 65 20 62 64 st bdisk-name bd
b380: 69 73 6b 2d 70 61 74 68 20 64 66 29 29 29 0a 0a isk-path df)))..
b390: 28 64 65 66 69 6e 65 20 28 72 6d 74 3a 74 65 73 (define (rmt:tes
b3a0: 74 2d 73 65 74 2d 61 72 63 68 69 76 65 2d 62 6c t-set-archive-bl
b3b0: 6f 63 6b 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 ock-id run-id te
b3c0: 73 74 2d 69 64 20 61 72 63 68 69 76 65 2d 62 6c st-id archive-bl
b3d0: 6f 63 6b 2d 69 64 29 0a 20 20 28 72 6d 74 3a 73 ock-id). (rmt:s
b3e0: 65 6e 64 2d 72 65 63 65 69 76 65 20 27 74 65 73 end-receive 'tes
b3f0: 74 2d 73 65 74 2d 61 72 63 68 69 76 65 2d 62 6c t-set-archive-bl
b400: 6f 63 6b 2d 69 64 20 72 75 6e 2d 69 64 20 28 6c ock-id run-id (l
b410: 69 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d ist run-id test-
b420: 69 64 20 61 72 63 68 69 76 65 2d 62 6c 6f 63 6b id archive-block
b430: 2d 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 -id)))..(define
b440: 28 72 6d 74 3a 74 65 73 74 2d 67 65 74 2d 61 72 (rmt:test-get-ar
b450: 63 68 69 76 65 2d 62 6c 6f 63 6b 2d 69 6e 66 6f chive-block-info
b460: 20 61 72 63 68 69 76 65 2d 62 6c 6f 63 6b 2d 69 archive-block-i
b470: 64 29 0a 20 20 28 72 6d 74 3a 73 65 6e 64 2d 72 d). (rmt:send-r
b480: 65 63 65 69 76 65 20 27 74 65 73 74 2d 67 65 74 eceive 'test-get
b490: 2d 61 72 63 68 69 76 65 2d 62 6c 6f 63 6b 2d 69 -archive-block-i
b4a0: 6e 66 6f 20 23 66 20 28 6c 69 73 74 20 61 72 63 nfo #f (list arc
b4b0: 68 69 76 65 2d 62 6c 6f 63 6b 2d 69 64 29 29 29 hive-block-id)))
b4c0: 0a 0a 28 64 65 66 69 6e 65 20 28 65 78 74 72 61 ..(define (extra
b4d0: 73 2d 72 65 61 64 6f 6e 6c 79 2d 6d 6f 64 65 20 s-readonly-mode
b4e0: 72 6d 74 2d 6d 75 74 65 78 20 6c 6f 67 2d 70 6f rmt-mutex log-po
b4f0: 72 74 20 63 6d 64 20 70 61 72 61 6d 73 29 0a 20 rt cmd params).
b500: 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 (mutex-unlock!
b510: 72 6d 74 2d 6d 75 74 65 78 29 0a 20 20 28 64 65 rmt-mutex). (de
b520: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 bug:print-info 1
b530: 32 20 6c 6f 67 2d 70 6f 72 74 20 22 72 6d 74 3a 2 log-port "rmt:
b540: 73 65 6e 64 2d 72 65 63 65 69 76 65 2c 20 63 61 send-receive, ca
b550: 73 65 20 33 22 29 0a 20 20 28 64 65 62 75 67 3a se 3"). (debug:
b560: 70 72 69 6e 74 20 30 20 6c 6f 67 2d 70 6f 72 74 print 0 log-port
b570: 20 22 57 41 52 4e 49 4e 47 3a 20 77 72 69 74 65 "WARNING: write
b580: 20 74 72 61 6e 73 61 63 74 69 6f 6e 20 72 65 71 transaction req
b590: 75 65 73 74 65 64 20 6f 6e 20 61 20 72 65 61 64 uested on a read
b5a0: 6f 6e 6c 79 20 61 72 65 61 2e 20 20 63 6d 64 3d only area. cmd=
b5b0: 22 63 6d 64 22 20 70 61 72 61 6d 73 3d 22 70 61 "cmd" params="pa
b5c0: 72 61 6d 73 29 0a 20 20 23 66 29 0a 0a 28 64 65 rams). #f)..(de
b5d0: 66 69 6e 65 20 28 65 78 74 72 61 73 2d 74 72 61 fine (extras-tra
b5e0: 6e 73 70 6f 72 74 2d 66 61 69 6c 65 64 20 2a 64 nsport-failed *d
b5f0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
b600: 20 2a 72 6d 74 2d 6d 75 74 65 78 2a 20 61 74 74 *rmt-mutex* att
b610: 65 6d 70 74 6e 75 6d 20 72 75 6e 72 65 6d 6f 74 emptnum runremot
b620: 65 20 63 6d 64 20 72 69 64 20 70 61 72 61 6d 73 e cmd rid params
b630: 29 0a 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ). (debug:print
b640: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
b650: 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 port* "WARNING:
b660: 63 6f 6d 6d 75 6e 69 63 61 74 69 6f 6e 20 66 61 communication fa
b670: 69 6c 65 64 2e 20 54 72 79 69 6e 67 20 61 67 61 iled. Trying aga
b680: 69 6e 2c 20 74 72 79 20 6e 75 6d 3a 20 22 20 61 in, try num: " a
b690: 74 74 65 6d 70 74 6e 75 6d 29 0a 20 20 28 6d 75 ttemptnum). (mu
b6a0: 74 65 78 2d 6c 6f 63 6b 21 20 2a 72 6d 74 2d 6d tex-lock! *rmt-m
b6b0: 75 74 65 78 2a 29 0a 20 20 28 72 65 6d 6f 74 65 utex*). (remote
b6c0: 2d 63 6f 6e 6e 64 61 74 2d 73 65 74 21 20 20 20 -conndat-set!
b6d0: 20 72 75 6e 72 65 6d 6f 74 65 20 23 66 29 0a 20 runremote #f).
b6e0: 20 28 68 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 (http-transport
b6f0: 3a 63 6c 6f 73 65 2d 63 6f 6e 6e 65 63 74 69 6f :close-connectio
b700: 6e 73 20 61 72 65 61 2d 64 61 74 3a 20 72 75 6e ns area-dat: run
b710: 72 65 6d 6f 74 65 29 0a 20 20 28 72 65 6d 6f 74 remote). (remot
b720: 65 2d 73 65 72 76 65 72 2d 75 72 6c 2d 73 65 74 e-server-url-set
b730: 21 20 72 75 6e 72 65 6d 6f 74 65 20 23 66 29 0a ! runremote #f).
b740: 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 (mutex-unlock!
b750: 20 2a 72 6d 74 2d 6d 75 74 65 78 2a 29 0a 20 20 *rmt-mutex*).
b760: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
b770: 6f 20 31 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f o 12 *default-lo
b780: 67 2d 70 6f 72 74 2a 20 22 72 6d 74 3a 73 65 6e g-port* "rmt:sen
b790: 64 2d 72 65 63 65 69 76 65 2c 20 63 61 73 65 20 d-receive, case
b7a0: 20 39 2e 31 22 29 0a 20 20 28 72 6d 74 3a 73 65 9.1"). (rmt:se
b7b0: 6e 64 2d 72 65 63 65 69 76 65 20 63 6d 64 20 72 nd-receive cmd r
b7c0: 69 64 20 70 61 72 61 6d 73 20 61 74 74 65 6d 70 id params attemp
b7d0: 74 6e 75 6d 3a 20 28 2b 20 61 74 74 65 6d 70 74 tnum: (+ attempt
b7e0: 6e 75 6d 20 31 29 29 29 0a 20 20 0a 28 64 65 66 num 1))). .(def
b7f0: 69 6e 65 20 28 65 78 74 72 61 73 2d 74 72 61 6e ine (extras-tran
b800: 73 70 6f 72 74 2d 73 75 63 63 65 64 65 64 20 2a sport-succeded *
b810: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
b820: 2a 20 2a 72 6d 74 2d 6d 75 74 65 78 2a 20 61 74 * *rmt-mutex* at
b830: 74 65 6d 70 74 6e 75 6d 20 72 75 6e 72 65 6d 6f temptnum runremo
b840: 74 65 20 72 65 73 20 70 61 72 61 6d 73 20 72 69 te res params ri
b850: 64 20 63 6d 64 29 0a 20 20 28 69 66 20 28 61 6e d cmd). (if (an
b860: 64 20 28 76 65 63 74 6f 72 3f 20 72 65 73 29 0a d (vector? res).
b870: 09 20 20 20 28 65 71 3f 20 28 76 65 63 74 6f 72 . (eq? (vector
b880: 2d 6c 65 6e 67 74 68 20 72 65 73 29 20 32 29 0a -length res) 2).
b890: 09 20 20 20 28 65 71 3f 20 28 76 65 63 74 6f 72 . (eq? (vector
b8a0: 2d 72 65 66 20 72 65 73 20 31 29 20 27 6f 76 65 -ref res 1) 'ove
b8b0: 72 6c 6f 61 64 65 64 29 29 20 3b 3b 20 73 69 6e rloaded)) ;; sin
b8c0: 63 65 20 77 65 20 61 72 65 0a 09 09 09 09 09 09 ce we are.......
b8d0: 20 3b 3b 20 6c 6f 6f 6b 69 6e 67 20 61 74 20 74 ;; looking at t
b8e0: 68 65 0a 09 09 09 09 09 09 20 3b 3b 20 64 61 74 he....... ;; dat
b8f0: 61 20 74 6f 20 63 61 72 72 79 20 74 68 65 0a 09 a to carry the..
b900: 09 09 09 09 09 20 3b 3b 20 65 72 72 6f 72 20 77 ..... ;; error w
b910: 65 27 6c 6c 20 75 73 65 20 61 0a 09 09 09 09 09 e'll use a......
b920: 09 20 3b 3b 20 66 61 69 72 6c 79 20 6f 62 74 75 . ;; fairly obtu
b930: 73 65 0a 09 09 09 09 09 09 20 3b 3b 20 63 6f 6d se....... ;; com
b940: 62 6f 20 74 6f 20 6d 69 6e 69 6d 69 73 65 0a 09 bo to minimise..
b950: 09 09 09 09 09 20 3b 3b 20 74 68 65 20 63 68 61 ..... ;; the cha
b960: 6e 63 65 73 20 6f 66 0a 09 09 09 09 09 09 20 3b nces of....... ;
b970: 3b 20 73 6f 6d 65 20 73 6f 72 74 20 6f 66 0a 09 ; some sort of..
b980: 09 09 09 09 09 20 3b 3b 20 63 6f 6c 6c 69 73 69 ..... ;; collisi
b990: 6f 6e 2e 20 20 74 68 69 73 0a 09 09 09 09 09 09 on. this.......
b9a0: 20 3b 3b 20 69 73 20 74 68 65 20 63 61 73 65 20 ;; is the case
b9b0: 77 68 65 72 65 0a 09 09 09 09 09 09 20 3b 3b 20 where....... ;;
b9c0: 74 68 65 20 72 65 74 75 72 6e 65 64 20 64 61 74 the returned dat
b9d0: 61 0a 09 09 09 09 09 09 20 3b 3b 20 69 73 20 62 a....... ;; is b
b9e0: 61 64 20 6f 72 20 74 68 65 0a 09 09 09 09 09 09 ad or the.......
b9f0: 20 3b 3b 20 73 65 72 76 65 72 20 69 73 0a 09 09 ;; server is...
ba00: 09 09 09 09 20 3b 3b 20 6f 76 65 72 6c 6f 61 64 .... ;; overload
ba10: 65 64 20 61 6e 64 20 77 65 0a 09 09 09 09 09 09 ed and we.......
ba20: 20 3b 3b 20 77 61 6e 74 20 74 6f 20 65 61 73 65 ;; want to ease
ba30: 20 6f 66 66 0a 09 09 09 09 09 09 20 3b 3b 20 74 off....... ;; t
ba40: 68 65 20 71 75 65 72 69 65 73 0a 20 20 20 20 20 he queries.
ba50: 20 28 6c 65 74 20 28 28 77 61 69 74 2d 64 65 6c (let ((wait-del
ba60: 61 79 20 28 2b 20 61 74 74 65 6d 70 74 6e 75 6d ay (+ attemptnum
ba70: 20 28 2a 20 61 74 74 65 6d 70 74 6e 75 6d 20 31 (* attemptnum 1
ba80: 30 29 29 29 29 0a 09 28 64 65 62 75 67 3a 70 72 0))))..(debug:pr
ba90: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
baa0: 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e og-port* "WARNIN
bab0: 47 3a 20 73 65 72 76 65 72 20 69 73 20 6f 76 65 G: server is ove
bac0: 72 6c 6f 61 64 65 64 2e 20 44 65 6c 61 79 69 6e rloaded. Delayin
bad0: 67 20 22 20 77 61 69 74 2d 64 65 6c 61 79 20 22 g " wait-delay "
bae0: 20 73 65 63 6f 6e 64 73 20 61 6e 64 20 74 72 79 seconds and try
baf0: 69 6e 67 20 63 61 6c 6c 20 61 67 61 69 6e 2e 22 ing call again."
bb00: 29 0a 09 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 )..(mutex-lock!
bb10: 2a 72 6d 74 2d 6d 75 74 65 78 2a 29 0a 09 28 68 *rmt-mutex*)..(h
bb20: 74 74 70 2d 74 72 61 6e 73 70 6f 72 74 3a 63 6c ttp-transport:cl
bb30: 6f 73 65 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 20 ose-connections
bb40: 61 72 65 61 2d 64 61 74 3a 20 72 75 6e 72 65 6d area-dat: runrem
bb50: 6f 74 65 29 0a 09 28 73 65 74 21 20 2a 72 75 6e ote)..(set! *run
bb60: 72 65 6d 6f 74 65 2a 20 23 66 29 20 3b 3b 20 66 remote* #f) ;; f
bb70: 6f 72 63 65 20 73 74 61 72 74 69 6e 67 20 6f 76 orce starting ov
bb80: 65 72 0a 09 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 er..(mutex-unloc
bb90: 6b 21 20 2a 72 6d 74 2d 6d 75 74 65 78 2a 29 0a k! *rmt-mutex*).
bba0: 09 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 .(thread-sleep!
bbb0: 77 61 69 74 2d 64 65 6c 61 79 29 0a 09 28 72 6d wait-delay)..(rm
bbc0: 74 3a 73 65 6e 64 2d 72 65 63 65 69 76 65 20 63 t:send-receive c
bbd0: 6d 64 20 72 69 64 20 70 61 72 61 6d 73 20 61 74 md rid params at
bbe0: 74 65 6d 70 74 6e 75 6d 3a 20 28 2b 20 61 74 74 temptnum: (+ att
bbf0: 65 6d 70 74 6e 75 6d 20 31 29 29 29 0a 20 20 20 emptnum 1))).
bc00: 20 20 20 72 65 73 29 29 20 3b 3b 20 41 6c 6c 20 res)) ;; All
bc10: 67 6f 6f 64 2c 20 72 65 74 75 72 6e 20 72 65 73 good, return res
bc20: 0a 0a 23 3b 28 73 65 74 2d 66 75 6e 63 74 69 6f ..#;(set-functio
bc30: 6e 73 20 72 6d 74 3a 73 65 6e 64 2d 72 65 63 65 ns rmt:send-rece
bc40: 69 76 65 20 20 20 20 20 20 20 20 20 20 20 20 20 ive
bc50: 20 20 20 20 20 20 20 20 20 20 72 65 6d 6f 74 65 remote
bc60: 2d 73 65 72 76 65 72 2d 75 72 6c 2d 73 65 74 21 -server-url-set!
bc70: 0a 09 20 20 20 20 20 20 20 68 74 74 70 2d 74 72 .. http-tr
bc80: 61 6e 73 70 6f 72 74 3a 63 6c 6f 73 65 2d 63 6f ansport:close-co
bc90: 6e 6e 65 63 74 69 6f 6e 73 09 20 20 20 20 20 20 nnections.
bca0: 72 65 6d 6f 74 65 2d 63 6f 6e 6e 64 61 74 2d 73 remote-conndat-s
bcb0: 65 74 21 0a 09 20 20 20 20 20 20 20 64 65 62 75 et!.. debu
bcc0: 67 3a 70 72 69 6e 74 20 20 20 20 20 20 20 20 20 g:print
bcd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bce0: 20 20 20 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 debug:print-i
bcf0: 6e 66 6f 0a 09 20 20 20 20 20 20 20 72 65 6d 6f nfo.. remo
bd00: 74 65 2d 72 6f 2d 6d 6f 64 65 20 20 20 20 20 20 te-ro-mode
bd10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bd20: 20 20 20 72 65 6d 6f 74 65 2d 72 6f 2d 6d 6f 64 remote-ro-mod
bd30: 65 2d 73 65 74 21 0a 09 20 20 20 20 20 20 20 72 e-set!.. r
bd40: 65 6d 6f 74 65 2d 72 6f 2d 6d 6f 64 65 2d 63 68 emote-ro-mode-ch
bd50: 65 63 6b 65 64 2d 73 65 74 21 20 20 20 20 20 20 ecked-set!
bd60: 20 20 20 20 20 20 72 65 6d 6f 74 65 2d 72 6f 2d remote-ro-
bd70: 6d 6f 64 65 2d 63 68 65 63 6b 65 64 29 0a mode-checked).